{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

-- |
-- Module      : Hasklepias Event Type
-- Description : Defines the Event type and its component types, constructors,
--               and class instance
-- Copyright   : (c) Target RWE 2023
-- License     : BSD3
-- Maintainer  : bbrown@targetrwe.com 
--               ljackman@targetrwe.com 
--               dpritchard@targetrwe.com
--
-- NOTE: The types herein are how events are represently internally.
-- Events may be represented in different structures for transferring or storing data, for example.
-- The To/FromJSON instances for types defined in this module are derived generically.
-- These can be useful for writing tests, for example, but
-- they are not designed to encode/decode data in the new line delimited format
-- defined in the
-- [event data model docs](https://docs.novisci.com/event-data/3.0/index.html)
-- See the neighboring EventLine module for types and To/FromJSON instances
-- designed for the purpose of marshaling data from JSON lines.
module EventDataTheory.Core
  ( Event,
    event,
    getEvent,
    getContext,
    Source (..),
    Tag,
    TagSet,
    Context,
    TagSetInterval,
    getFacts,
    getSource,
    getTagSet,
    context,
    toTagSet,
    packTag,
    unpackTag,
    packTagSet,
    unpackTagSet,
    hasTag,
    hasAnyTag,
    hasAllTags,
    addTagSet,
    liftToEventPredicate,
    liftToEventFunction,
    liftToContextFunction,
    bimapContext,
    mapTagSet,
    dropSource,
    SubjectID,
    -- TODO: evaluate this old note. does not seem that these should
    -- be exported if that is the only reason they are now.
    --
    -- the following names are exported for haddock linking
    HasTag,
    EventPredicate,
    Eventable,
    FromJSONEvent,
    ToJSONEvent,
  )
where

import Control.DeepSeq (NFData)
import Control.Monad (liftM2, liftM3)
import Data.Aeson
  ( FromJSON,
    ToJSON,
    Value (Number, String),
  )
import Data.Bifunctor
import Data.Binary (Binary)
import Data.Functor.Contravariant
  ( Contravariant (contramap),
    Predicate (..),
  )
import Data.Set (Set, fromList, map, member, toList)
import qualified Data.Text as T
import Dhall (FromDhall, ToDhall)
import GHC.Generics (Generic)
import IntervalAlgebra
  ( Interval,
    Intervallic (..),
    PairedInterval,
    getPairData,
    makePairedInterval,
  )
import Test.Tasty.QuickCheck (Arbitrary (arbitrary))
import Type.Reflection (Typeable)
import Witch (From (..), into, via)

-- |
-- The 'Event' type puts a certain amount of structure on
-- temporally organized data,
-- while being flexible in the details.
-- An 'Event t m a' contains information about
-- when something occurred (the 'Interval a')
-- and what occurred (the 'Context m t').
-- The type parameters @m@, @t@, and @a@ allow to specify
-- the types for the 'Context's @m@odel and @t@agSet
-- and for the type of the 'Interval' end points.
--
-- The 'Event' type parameters are ordered from changing the least often to most often.
-- A @m@odel tends to be shared across projects.
-- For example, multiple projects use data from insurance claims,
-- and thus share a single model.
-- A project often defines its own @t@agSet,
-- though tag sets can be shared across projects.
-- Within a project, multiple 'Interval' types may used.
-- Data may be imported as 'Interval Day',
-- but then modified to 'Interval Integer' based on some reference point.
--
-- The contents of a 'Context' are explained in a separate section,
-- but we give a couple examples of using events here.
--
-- The 'event' function is a smart constructor for 'Event'.
--
-- >>> :set -XOverloadedStrings
-- >>> import IntervalAlgebra ( beginerval )
--
-- >>> data SomeModel = A | B deriving (Eq, Ord, Show, Generic)
-- >>>
-- >>> type MyEvent = Event T.Text SomeModel Integer
-- >>> let myEvent = event (beginerval 5 0) (context (packTagSet ["foo"]) A Nothing) :: MyEvent
-- >>> show myEvent
-- "MkEvent {(0, 5), MkContext {getTagSet = MkTagSet (fromList [MkTag \"foo\"]), getFacts = A, getSource = Nothing}}"
--
-- >>> hasAnyTag myEvent (["foo", "duck"] :: [T.Text])
-- True
--
-- >>> hasAllTags myEvent (["foo", "duck"] :: [T.Text])
-- False
--
-- >>> data NewModel = A T.Text | B Integer deriving (Eq, Ord, Show, Generic)
-- >>> data MyTagSet = Foo | Bar | Baz deriving (Eq, Ord, Show, Generic)
-- >>>
-- >>> type NewEvent = Event MyTagSet NewModel Integer
-- >>> let newEvent = event (beginerval 5 0) (context (packTagSet [Foo, Bar]) (A "cool") Nothing) :: NewEvent
-- >>> show newEvent
-- "MkEvent {(0, 5), MkContext {getTagSet = MkTagSet (fromList [MkTag Foo,MkTag Bar]), getFacts = A \"cool\", getSource = Nothing}}"
--
-- >>> hasTag newEvent Foo
-- True
--
-- >>> hasTag newEvent Baz
-- False

{- tag::eventType[] -}
newtype Event t m a = MkEvent (PairedInterval (Context t m) a)
  {- end::eventType[] -}
  deriving (Event t m a -> Event t m a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall t m a.
(Eq a, Eq t, Eq m) =>
Event t m a -> Event t m a -> Bool
/= :: Event t m a -> Event t m a -> Bool
$c/= :: forall t m a.
(Eq a, Eq t, Eq m) =>
Event t m a -> Event t m a -> Bool
== :: Event t m a -> Event t m a -> Bool
$c== :: forall t m a.
(Eq a, Eq t, Eq m) =>
Event t m a -> Event t m a -> Bool
Eq, Int -> Event t m a -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall t m a.
(Show t, Show m, Show a, Ord a) =>
Int -> Event t m a -> ShowS
forall t m a.
(Show t, Show m, Show a, Ord a) =>
[Event t m a] -> ShowS
forall t m a.
(Show t, Show m, Show a, Ord a) =>
Event t m a -> String
showList :: [Event t m a] -> ShowS
$cshowList :: forall t m a.
(Show t, Show m, Show a, Ord a) =>
[Event t m a] -> ShowS
show :: Event t m a -> String
$cshow :: forall t m a.
(Show t, Show m, Show a, Ord a) =>
Event t m a -> String
showsPrec :: Int -> Event t m a -> ShowS
$cshowsPrec :: forall t m a.
(Show t, Show m, Show a, Ord a) =>
Int -> Event t m a -> ShowS
Show, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall t m a x. Rep (Event t m a) x -> Event t m a
forall t m a x. Event t m a -> Rep (Event t m a) x
$cto :: forall t m a x. Rep (Event t m a) x -> Event t m a
$cfrom :: forall t m a x. Event t m a -> Rep (Event t m a) x
Generic)

instance Intervallic (Event t m) where
  getInterval :: forall a. Event t m a -> Interval a
getInterval (MkEvent PairedInterval (Context t m) a
x) = forall (i :: * -> *) a. Intervallic i => i a -> Interval a
getInterval PairedInterval (Context t m) a
x
  setInterval :: forall a b. Event t m a -> Interval b -> Event t m b
setInterval (MkEvent PairedInterval (Context t m) a
x) Interval b
y = forall t m a. PairedInterval (Context t m) a -> Event t m a
MkEvent forall a b. (a -> b) -> a -> b
$ forall (i :: * -> *) a b. Intervallic i => i a -> Interval b -> i b
setInterval PairedInterval (Context t m) a
x Interval b
y

instance Ord t => HasTag (Event t m a) t where
  hasTag :: Event t m a -> t -> Bool
hasTag Event t m a
e = forall a t. HasTag a t => a -> t -> Bool
hasTag (forall t m a. Event t m a -> Context t m
getContext Event t m a
e)

instance (Ord a, Ord t, Eq m) => Ord (Event t m a) where
  -- \|
  --  Events are first ordered by their intervals.
  --  In the case two intervals are equal,
  --  the event are ordered by their tagSet.
  compare :: Event t m a -> Event t m a -> Ordering
compare Event t m a
x Event t m a
y = case Ordering
ic of
    Ordering
EQ -> forall a. Ord a => a -> a -> Ordering
compare (forall t m. Context t m -> TagSet t
getTagSet forall a b. (a -> b) -> a -> b
$ forall t m a. Event t m a -> Context t m
getContext Event t m a
x) (forall t m. Context t m -> TagSet t
getTagSet forall a b. (a -> b) -> a -> b
$ forall t m a. Event t m a -> Context t m
getContext Event t m a
y)
    Ordering
_ -> Ordering
ic
    where
      ic :: Ordering
ic = forall a. Ord a => a -> a -> Ordering
compare (forall (i :: * -> *) a. Intervallic i => i a -> Interval a
getInterval Event t m a
x) (forall (i :: * -> *) a. Intervallic i => i a -> Interval a
getInterval Event t m a
y)

instance (NFData a, NFData m, NFData t) => NFData (Event t m a)

instance (Binary m, Binary t, Binary a) => Binary (Event t m a)

instance (FromJSON a) => FromJSON (Interval a)

instance (ToJSON a) => ToJSON (Interval a)

instance (FromJSON b, FromJSON a) => FromJSON (PairedInterval b a)

instance (ToJSON b, ToJSON a) => ToJSON (PairedInterval b a)

instance (Ord t, FromJSON t, FromJSON m, FromJSON a) => FromJSON (Event t m a)

instance (Ord t, ToJSON t, ToJSON m, ToJSON a) => ToJSON (Event t m a)

instance
  ( 
    Ord t,
    Arbitrary m,
    Arbitrary t,
    Arbitrary (Interval a)
  ) =>
  Arbitrary (Event t m a)
  where
  arbitrary :: Gen (Event t m a)
arbitrary = forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 forall a t m. Interval a -> Context t m -> Event t m a
event forall a. Arbitrary a => Gen a
arbitrary forall a. Arbitrary a => Gen a
arbitrary

instance From (Event t m a) (Interval a) where
  from :: Event t m a -> Interval a
from = forall (i :: * -> *) a. Intervallic i => i a -> Interval a
getInterval

-- TODO: revisit this constraint synonym. these likely are not needed.
-- this pattern appears to be part of a design approach that constrains
-- constructors such as `event` not because that constructor actually needs
-- the given constraints but because imagined uses of values of the type
-- will require the constraints. however, it almost always is cleaner to
-- place the restrictions where they actually are used.

-- | A synonym for a basic set of constraints frequently used with
-- the 'Event' type.
type Eventable t m a = (Eq m, Ord t, Ord a, Show m, Show t, Show a)

-- | Constraint synonym for @ToJSON@ on an event's component types.
type ToJSONEvent t m a = (ToJSON m, ToJSON t, ToJSON a)

-- | Constraint synonym for @FromSON@ on an event's component types.
type FromJSONEvent t m a = (FromJSON m, FromJSON t, FromJSON a)

-- | A smart constructor for 'Event t m a's.
event :: Interval a -> Context t m -> Event t m a
event :: forall a t m. Interval a -> Context t m -> Event t m a
event Interval a
i Context t m
t = forall t m a. PairedInterval (Context t m) a -> Event t m a
MkEvent (forall b a. b -> Interval a -> PairedInterval b a
makePairedInterval Context t m
t Interval a
i)

-- | Unpack an 'Event' from its constructor.
getEvent :: Event t m a -> PairedInterval (Context t m) a
getEvent :: forall t m a. Event t m a -> PairedInterval (Context t m) a
getEvent (MkEvent PairedInterval (Context t m) a
x) = PairedInterval (Context t m) a
x

-- | Get the 'Context' of an 'Event'.
getContext :: Event t m a -> Context t m
getContext :: forall t m a. Event t m a -> Context t m
getContext = forall b a. PairedInterval b a -> b
getPairData forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t m a. Event t m a -> PairedInterval (Context t m) a
getEvent

-- |
-- A 'Context' contains information about what ocurred during an 'Event's interval.
-- This information is carried in context's @tagSet@ and/or @facts@.
-- 'TagSet' are set of tags that can be used to identify and filter events
-- using the 'hasTag' function
-- or the related 'hasAnyTag' and 'hasAllTags' functions.
-- The @facts@ field contains data of type @m@.
-- The @m@ stands for @m@odel,
-- meaning the scope and shape of facts
-- relevant to a particular scientific line of work.
-- For example, some studies using health care claims data may be sufficiently different
-- in scope, semanitcs, and aims to warrant having a different collection of facts
-- from, say, electronic medical records data.
-- However, one could create a collection of facts that includes both claims and EHR data.
-- By having a 'Context' parametrized by the shape of a model,
-- users are free to define the structure of their facts as needed.
--
-- A context also has a @source@ field,
-- possibly containing a 'Source',
-- which carries information about the provenance of the data.

{- tag::contextType[] -}
data Context t m = MkContext
  { -- | the 'TagSet' of a @Context@
    forall t m. Context t m -> TagSet t
getTagSet :: TagSet t, -- <1>

    -- | the facts of a @Context@.
    forall t m. Context t m -> m
getFacts :: m, -- <2>

    -- | the 'Source' of @Context@
    forall t m. Context t m -> Maybe Source
getSource :: Maybe Source -- <3>
  }
  {- end::contextType[] -}
  deriving (Context t m -> Context t m -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall t m. (Eq t, Eq m) => Context t m -> Context t m -> Bool
/= :: Context t m -> Context t m -> Bool
$c/= :: forall t m. (Eq t, Eq m) => Context t m -> Context t m -> Bool
== :: Context t m -> Context t m -> Bool
$c== :: forall t m. (Eq t, Eq m) => Context t m -> Context t m -> Bool
Eq, Int -> Context t m -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall t m. (Show t, Show m) => Int -> Context t m -> ShowS
forall t m. (Show t, Show m) => [Context t m] -> ShowS
forall t m. (Show t, Show m) => Context t m -> String
showList :: [Context t m] -> ShowS
$cshowList :: forall t m. (Show t, Show m) => [Context t m] -> ShowS
show :: Context t m -> String
$cshow :: forall t m. (Show t, Show m) => Context t m -> String
showsPrec :: Int -> Context t m -> ShowS
$cshowsPrec :: forall t m. (Show t, Show m) => Int -> Context t m -> ShowS
Show, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall t m x. Rep (Context t m) x -> Context t m
forall t m x. Context t m -> Rep (Context t m) x
$cto :: forall t m x. Rep (Context t m) x -> Context t m
$cfrom :: forall t m x. Context t m -> Rep (Context t m) x
Generic)


instance (Ord t) => HasTag (Context t m) t where
  hasTag :: Context t m -> t -> Bool
hasTag Context t m
t = forall a t. HasTag a t => a -> t -> Bool
hasTag (forall t m. Context t m -> TagSet t
getTagSet Context t m
t)

instance (NFData m, NFData t) => NFData (Context t m)

instance (Binary m, Binary t) => Binary (Context t m)

-- NOTE: Ord t is required because of TagSet.
instance (Ord t, FromJSON t, FromJSON m) => FromJSON (Context t m)

instance (Ord t, ToJSON t, ToJSON m) => ToJSON (Context t m)

-- | The 'Arbitrary' instance for 'Context' fixes 'getSource' to 'Nothing'.
instance
  ( Arbitrary m,
    Arbitrary t,
    Ord t
  ) =>
  Arbitrary (Context t m)
  where
  arbitrary :: Gen (Context t m)
arbitrary = forall (m :: * -> *) a1 a2 a3 r.
Monad m =>
(a1 -> a2 -> a3 -> r) -> m a1 -> m a2 -> m a3 -> m r
liftM3 forall t m. TagSet t -> m -> Maybe Source -> Context t m
MkContext forall a. Arbitrary a => Gen a
arbitrary forall a. Arbitrary a => Gen a
arbitrary (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing)

-- | The 'Functor' instance of @Context t@ maps over the 'getFacts'
-- field, leaving 'getSource' untouched.
instance Functor (Context t) where
  fmap :: forall a b. (a -> b) -> Context t a -> Context t b
fmap a -> b
f (MkContext TagSet t
t a
m Maybe Source
s) = forall t m. TagSet t -> m -> Maybe Source -> Context t m
MkContext TagSet t
t (a -> b
f a
m) Maybe Source
s

-- | Smart constructor for a 'Context',
context :: TagSet t -> d -> Maybe Source -> Context t d
context :: forall t m. TagSet t -> m -> Maybe Source -> Context t m
context = forall t m. TagSet t -> m -> Maybe Source -> Context t m
MkContext

-- |
-- Apply a two functions to a 'Context':
--
-- 1. a function transforming the tagSet
-- 2. a function transforming the facts
--
-- This function is simiilar in flavor to 'Data.Bifunctor.bimap'.
-- But @Context@ is not a 'Data.Bifunctor.Bifunctor'.
-- The underlying type of @TagSet@ is 'Data.Set.Set',
-- which is not a 'Functor'
-- because of the @Set@ 'Ord' constraints.
bimapContext ::
  (Ord t2) =>
  (t1 -> t2) ->
  (d1 -> d2) ->
  Context t1 d1 ->
  Context t2 d2
bimapContext :: forall t2 t1 d1 d2.
Ord t2 =>
(t1 -> t2) -> (d1 -> d2) -> Context t1 d1 -> Context t2 d2
bimapContext t1 -> t2
g d1 -> d2
f (MkContext TagSet t1
tSet d1
fcts Maybe Source
src) =
  forall t m. TagSet t -> m -> Maybe Source -> Context t m
MkContext (forall t2 t1. Ord t2 => (t1 -> t2) -> TagSet t1 -> TagSet t2
mapTagSet t1 -> t2
g TagSet t1
tSet) (d1 -> d2
f d1
fcts) Maybe Source
src

-- |
-- Turn the 'Source' within a 'Context' to 'Nothing'.
dropSource :: Context t m -> Context t m
dropSource :: forall t m. Context t m -> Context t m
dropSource (MkContext TagSet t
tSet m
fcts Maybe Source
_) = forall t m. TagSet t -> m -> Maybe Source -> Context t m
MkContext TagSet t
tSet m
fcts forall a. Maybe a
Nothing

-- |
-- A @Source@ may be used to record the source of an event from a database.
-- This data is sometimes useful for debugging.
-- We generally discourage using @Source@ information in defining features.
data Source = MkSource
  { Source -> Maybe Text
column :: Maybe T.Text,
    Source -> Maybe Text
file :: Maybe T.Text,
    Source -> Maybe Integer
row :: Maybe Integer,
    Source -> Text
table :: T.Text,
    Source -> Text
database :: T.Text
  }
  deriving (Source -> Source -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Source -> Source -> Bool
$c/= :: Source -> Source -> Bool
== :: Source -> Source -> Bool
$c== :: Source -> Source -> Bool
Eq, Int -> Source -> ShowS
[Source] -> ShowS
Source -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Source] -> ShowS
$cshowList :: [Source] -> ShowS
show :: Source -> String
$cshow :: Source -> String
showsPrec :: Int -> Source -> ShowS
$cshowsPrec :: Int -> Source -> ShowS
Show, forall x. Rep Source x -> Source
forall x. Source -> Rep Source x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Source x -> Source
$cfrom :: forall x. Source -> Rep Source x
Generic)

instance NFData Source

instance Binary Source

instance FromJSON Source

instance ToJSON Source

-- | A @Tag@ is simply a label for an 'Event'.
newtype Tag t = MkTag t deriving (Tag t -> Tag t -> Bool
forall t. Eq t => Tag t -> Tag t -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Tag t -> Tag t -> Bool
$c/= :: forall t. Eq t => Tag t -> Tag t -> Bool
== :: Tag t -> Tag t -> Bool
$c== :: forall t. Eq t => Tag t -> Tag t -> Bool
Eq, Tag t -> Tag t -> Bool
Tag t -> Tag t -> Ordering
Tag t -> Tag t -> Tag t
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
forall {t}. Ord t => Eq (Tag t)
forall t. Ord t => Tag t -> Tag t -> Bool
forall t. Ord t => Tag t -> Tag t -> Ordering
forall t. Ord t => Tag t -> Tag t -> Tag t
min :: Tag t -> Tag t -> Tag t
$cmin :: forall t. Ord t => Tag t -> Tag t -> Tag t
max :: Tag t -> Tag t -> Tag t
$cmax :: forall t. Ord t => Tag t -> Tag t -> Tag t
>= :: Tag t -> Tag t -> Bool
$c>= :: forall t. Ord t => Tag t -> Tag t -> Bool
> :: Tag t -> Tag t -> Bool
$c> :: forall t. Ord t => Tag t -> Tag t -> Bool
<= :: Tag t -> Tag t -> Bool
$c<= :: forall t. Ord t => Tag t -> Tag t -> Bool
< :: Tag t -> Tag t -> Bool
$c< :: forall t. Ord t => Tag t -> Tag t -> Bool
compare :: Tag t -> Tag t -> Ordering
$ccompare :: forall t. Ord t => Tag t -> Tag t -> Ordering
Ord, Int -> Tag t -> ShowS
forall t. Show t => Int -> Tag t -> ShowS
forall t. Show t => [Tag t] -> ShowS
forall t. Show t => Tag t -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Tag t] -> ShowS
$cshowList :: forall t. Show t => [Tag t] -> ShowS
show :: Tag t -> String
$cshow :: forall t. Show t => Tag t -> String
showsPrec :: Int -> Tag t -> ShowS
$cshowsPrec :: forall t. Show t => Int -> Tag t -> ShowS
Show, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall t x. Rep (Tag t) x -> Tag t
forall t x. Tag t -> Rep (Tag t) x
$cto :: forall t x. Rep (Tag t) x -> Tag t
$cfrom :: forall t x. Tag t -> Rep (Tag t) x
Generic)

instance Functor Tag where
  fmap :: forall a b. (a -> b) -> Tag a -> Tag b
fmap a -> b
f (MkTag a
x) = forall t. t -> Tag t
MkTag (a -> b
f a
x)

instance NFData t => NFData (Tag t)

instance Binary t => Binary (Tag t)

instance FromJSON t => FromJSON (Tag t)

instance ToJSON t => ToJSON (Tag t)

instance (ToDhall t) => ToDhall (Tag t)

instance (FromDhall t) => FromDhall (Tag t)

instance From (Tag t) t

instance From t (Tag t)

-- | Wrap value as a Tag
packTag :: t -> Tag t
packTag :: forall t. t -> Tag t
packTag = forall target source. From source target => source -> target
into

-- | Unwrap a value from a Tag
unpackTag :: Tag t -> t
unpackTag :: forall t. Tag t -> t
unpackTag = forall target source. From source target => source -> target
into

-- |
-- @TagSet t@ is a 'Set' of 'Tag t's.
-- TagSet inherit the monoidal properties of 'Set', by 'Data.Set.union'.
newtype TagSet t = MkTagSet (Set (Tag t))
  deriving (TagSet t -> TagSet t -> Bool
forall t. Eq t => TagSet t -> TagSet t -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TagSet t -> TagSet t -> Bool
$c/= :: forall t. Eq t => TagSet t -> TagSet t -> Bool
== :: TagSet t -> TagSet t -> Bool
$c== :: forall t. Eq t => TagSet t -> TagSet t -> Bool
Eq, Int -> TagSet t -> ShowS
forall t. Show t => Int -> TagSet t -> ShowS
forall t. Show t => [TagSet t] -> ShowS
forall t. Show t => TagSet t -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TagSet t] -> ShowS
$cshowList :: forall t. Show t => [TagSet t] -> ShowS
show :: TagSet t -> String
$cshow :: forall t. Show t => TagSet t -> String
showsPrec :: Int -> TagSet t -> ShowS
$cshowsPrec :: forall t. Show t => Int -> TagSet t -> ShowS
Show, TagSet t -> TagSet t -> Bool
TagSet t -> TagSet t -> Ordering
TagSet t -> TagSet t -> TagSet t
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
forall {t}. Ord t => Eq (TagSet t)
forall t. Ord t => TagSet t -> TagSet t -> Bool
forall t. Ord t => TagSet t -> TagSet t -> Ordering
forall t. Ord t => TagSet t -> TagSet t -> TagSet t
min :: TagSet t -> TagSet t -> TagSet t
$cmin :: forall t. Ord t => TagSet t -> TagSet t -> TagSet t
max :: TagSet t -> TagSet t -> TagSet t
$cmax :: forall t. Ord t => TagSet t -> TagSet t -> TagSet t
>= :: TagSet t -> TagSet t -> Bool
$c>= :: forall t. Ord t => TagSet t -> TagSet t -> Bool
> :: TagSet t -> TagSet t -> Bool
$c> :: forall t. Ord t => TagSet t -> TagSet t -> Bool
<= :: TagSet t -> TagSet t -> Bool
$c<= :: forall t. Ord t => TagSet t -> TagSet t -> Bool
< :: TagSet t -> TagSet t -> Bool
$c< :: forall t. Ord t => TagSet t -> TagSet t -> Bool
compare :: TagSet t -> TagSet t -> Ordering
$ccompare :: forall t. Ord t => TagSet t -> TagSet t -> Ordering
Ord, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall t x. Rep (TagSet t) x -> TagSet t
forall t x. TagSet t -> Rep (TagSet t) x
$cto :: forall t x. Rep (TagSet t) x -> TagSet t
$cfrom :: forall t x. TagSet t -> Rep (TagSet t) x
Generic)

instance NFData t => NFData (TagSet t)

instance Binary t => Binary (TagSet t)

-- See NOTE at top of module regarding To/FromJSON
instance (Ord t, FromJSON t) => FromJSON (TagSet t)

instance ToJSON t => ToJSON (TagSet t)

instance (ToDhall t) => ToDhall (TagSet t)

instance (FromDhall t, Ord t, Show t) => FromDhall (TagSet t)

instance (Arbitrary t, Ord t) => Arbitrary (TagSet t) where
  arbitrary :: Gen (TagSet t)
arbitrary = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall t. Ord t => [t] -> TagSet t
packTagSet forall a. Arbitrary a => Gen a
arbitrary

instance (Ord t) => Semigroup (TagSet t) where
  MkTagSet Set (Tag t)
x <> :: TagSet t -> TagSet t -> TagSet t
<> MkTagSet Set (Tag t)
y = forall t. Set (Tag t) -> TagSet t
MkTagSet (Set (Tag t)
x forall a. Semigroup a => a -> a -> a
<> Set (Tag t)
y)

instance (Ord t) => Monoid (TagSet t) where
  mempty :: TagSet t
mempty = forall t. Set (Tag t) -> TagSet t
MkTagSet forall a. Monoid a => a
mempty

instance (Ord t) => From (TagSet t) (Set (Tag t))

instance (Ord t) => From (Set (Tag t)) (TagSet t)

instance (Ord t) => From (Set (Tag t)) [t] where
  from :: Set (Tag t) -> [t]
from Set (Tag t)
x = forall source target. From source target => source -> target
from @(Set t) (forall b a. Ord b => (a -> b) -> Set a -> Set b
Data.Set.map (forall source target. From source target => source -> target
from @(Tag t)) Set (Tag t)
x)

instance (Ord t) => From [t] (Set (Tag t)) where
  from :: [t] -> Set (Tag t)
from [t]
x = forall source target. From source target => source -> target
from @[Tag t] (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall source target. From source target => source -> target
from [t]
x)

instance (Ord t) => From (TagSet t) [t] where
  from :: TagSet t -> [t]
from = forall through source target.
(From source through, From through target) =>
source -> target
via @(Set (Tag t))

instance (Ord t) => From [t] (TagSet t) where
  from :: [t] -> TagSet t
from = forall through source target.
(From source through, From through target) =>
source -> target
via @(Set (Tag t))

-- | Put a list of values into a set of tagSet.
packTagSet :: Ord t => [t] -> TagSet t
packTagSet :: forall t. Ord t => [t] -> TagSet t
packTagSet = forall source target. From source target => source -> target
from

-- | Take a tag set to a list of values.
unpackTagSet :: (Ord t) => TagSet t -> [t]
unpackTagSet :: forall t. Ord t => TagSet t -> [t]
unpackTagSet = forall source target. From source target => source -> target
from

-- | Constructor for 'TagSet'.
toTagSet :: (Ord t) => Set (Tag t) -> TagSet t
toTagSet :: forall t. Ord t => Set (Tag t) -> TagSet t
toTagSet = forall source target. From source target => source -> target
from

-- | A utility for adding tag sets to a 'TagSet' from a list.
addTagSet :: (Ord t) => [t] -> TagSet t -> TagSet t
addTagSet :: forall t. Ord t => [t] -> TagSet t -> TagSet t
addTagSet [t]
x TagSet t
tSet = forall target source. From source target => source -> target
into [t]
x forall a. Semigroup a => a -> a -> a
<> TagSet t
tSet

-- |
-- Apply a function to each 'Tag'
-- within a 'TagSet' set.
--
-- NOTE:
-- @TagSet@ are not a 'Functor'.
-- The underlying type of @TagSet@ is 'Data.Set.Set',
-- which is not a 'Functor'
-- due to the @Set@ 'Ord' constraints.
mapTagSet :: (Ord t2) => (t1 -> t2) -> TagSet t1 -> TagSet t2
mapTagSet :: forall t2 t1. Ord t2 => (t1 -> t2) -> TagSet t1 -> TagSet t2
mapTagSet t1 -> t2
f (MkTagSet Set (Tag t1)
x) = forall t. Set (Tag t) -> TagSet t
MkTagSet (forall b a. Ord b => (a -> b) -> Set a -> Set b
Data.Set.map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap t1 -> t2
f) Set (Tag t1)
x)

-- |
-- The 'HasTag' typeclass provides predicate functions
-- for determining whether an @a@ contains a tag.
--
-- This class is only used in this 'EventDataTheory.Core' module
-- for the purposes of having a single @hasTag@ function
-- that works on 'TagSet', 'Context', or 'Event' data.
class HasTag a t where
  -- | Test whether a type @a@ contains a @t@.
  hasTag :: a -> t -> Bool

instance (Ord t) => HasTag (TagSet t) t where
  hasTag :: TagSet t -> t -> Bool
hasTag (MkTagSet Set (Tag t)
e) t
tag = forall a. Ord a => a -> Set a -> Bool
member (forall t. t -> Tag t
MkTag t
tag) Set (Tag t)
e

instance (Ord t) => HasTag (PairedInterval (TagSet t) a) t where
  hasTag :: PairedInterval (TagSet t) a -> t -> Bool
hasTag PairedInterval (TagSet t) a
x = forall a t. HasTag a t => a -> t -> Bool
hasTag (forall b a. PairedInterval b a -> b
getPairData PairedInterval (TagSet t) a
x)

-- | Does an @a@ have *any* of a list of 'Tag's?
hasAnyTag :: HasTag a t => a -> [t] -> Bool
hasAnyTag :: forall a t. HasTag a t => a -> [t] -> Bool
hasAnyTag a
x = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\t
t -> a
x forall a t. HasTag a t => a -> t -> Bool
`hasTag` t
t)

-- | Does an @a@ have *all* of a list of `Tag's?
hasAllTags :: HasTag a t => a -> [t] -> Bool
hasAllTags :: forall a t. HasTag a t => a -> [t] -> Bool
hasAllTags a
x = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\t
t -> a
x forall a t. HasTag a t => a -> t -> Bool
`hasTag` t
t)

-- |
-- A Tag Interval is simply a synonym for an 'Interval' paired with 'TagSet'.
type TagSetInterval t a = PairedInterval (TagSet t) a

instance From (Event t m a) (TagSetInterval t a) where
  from :: Event t m a -> TagSetInterval t a
from Event t m a
x = forall b a. b -> Interval a -> PairedInterval b a
makePairedInterval (forall t m. Context t m -> TagSet t
getTagSet forall a b. (a -> b) -> a -> b
$ forall t m a. Event t m a -> Context t m
getContext Event t m a
x) (forall (i :: * -> *) a. Intervallic i => i a -> Interval a
getInterval Event t m a
x)

instance (Ord a) => From (TagSetInterval t a) (Interval a) where
  from :: TagSetInterval t a -> Interval a
from = forall (i :: * -> *) a. Intervallic i => i a -> Interval a
getInterval

-- | Creates a 'TagSetInterval` from an `Interval` with empty 'TagSet'.
instance (Ord t, Ord t) => From (Interval a) (TagSetInterval t a) where
  from :: Interval a -> TagSetInterval t a
from = forall b a. b -> Interval a -> PairedInterval b a
makePairedInterval forall a. Monoid a => a
mempty

-- | Contains a subject identifier
type SubjectID = T.Text

-- |
-- Provides a common interface to lift a @'Predicate' e@ to a
-- @Predicate (Event t m a)@.
--
-- For example, if @x@ is a 'Predicate' on some 'Context m t',
-- @liftToEventPredicate x@ yields a @Predicate (Event t m a)@,
-- thus the predicate then also be applied to @Event@s.
--
-- This class is only used in this 'EventDataTheory.Core' module
-- for the purposes of having a single @liftToEventPredicate@ function
-- that works on 'TagSet', 'Context', or 'Event' data.
class EventPredicate element t m a where
  -- |
  --  Lifts a 'Predicate' of a component of an 'Event'
  --  to a 'Predicate' on an 'Event'
  liftToEventPredicate :: Predicate element -> Predicate (Event t m a)

instance EventPredicate (Context t m) t m a where
  liftToEventPredicate :: Predicate (Context t m) -> Predicate (Event t m a)
liftToEventPredicate = forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap forall t m a. Event t m a -> Context t m
getContext

instance EventPredicate m t m a where
  liftToEventPredicate :: Predicate m -> Predicate (Event t m a)
liftToEventPredicate = forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap (forall t m. Context t m -> m
getFacts forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t m a. Event t m a -> Context t m
getContext)

instance EventPredicate (TagSet t) t m a where
  liftToEventPredicate :: Predicate (TagSet t) -> Predicate (Event t m a)
liftToEventPredicate = forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap (forall t m. Context t m -> TagSet t
getTagSet forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t m a. Event t m a -> Context t m
getContext)

instance EventPredicate (Maybe Source) t m a where
  liftToEventPredicate :: Predicate (Maybe Source) -> Predicate (Event t m a)
liftToEventPredicate = forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap (forall t m. Context t m -> Maybe Source
getSource forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t m a. Event t m a -> Context t m
getContext)

instance EventPredicate (Interval a) t m a where
  liftToEventPredicate :: Predicate (Interval a) -> Predicate (Event t m a)
liftToEventPredicate = forall (f :: * -> *) a' a.
Contravariant f =>
(a' -> a) -> f a -> f a'
contramap forall (i :: * -> *) a. Intervallic i => i a -> Interval a
getInterval

-- |
-- Provides a common interface to lift a function
-- operating on some component of an 'Event'
-- into a function on an 'Event'.
--
-- This class is only used in this 'EventDataTheory.Core' module
-- for the purposes of having a single @liftToEventFunction@ function
-- that works on 'TagSet', 'Context', or 'Event' data.
class EventFunction f t t' m m' a a' where
  -- |
  --  Lifts a function @@ of a component of an 'Event'
  --  to a function on an 'Event'
  liftToEventFunction :: (Ord t, Ord t') => f -> Event t m a -> Event t' m' a'

instance EventFunction (t -> t') t t' m m a a where
  liftToEventFunction :: (Ord t, Ord t') => (t -> t') -> Event t m a -> Event t' m a
liftToEventFunction t -> t'
f Event t m a
x =
    forall t m a. PairedInterval (Context t m) a -> Event t m a
MkEvent forall a b. (a -> b) -> a -> b
$
      forall b a. b -> Interval a -> PairedInterval b a
makePairedInterval (forall t2 t1 d1 d2.
Ord t2 =>
(t1 -> t2) -> (d1 -> d2) -> Context t1 d1 -> Context t2 d2
bimapContext t -> t'
f forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ forall t m a. Event t m a -> Context t m
getContext Event t m a
x) (forall (i :: * -> *) a. Intervallic i => i a -> Interval a
getInterval Event t m a
x)

instance EventFunction (m -> m') t t m m' a a where
  liftToEventFunction :: (Ord t, Ord t) => (m -> m') -> Event t m a -> Event t m' a
liftToEventFunction m -> m'
f Event t m a
x =
    forall t m a. PairedInterval (Context t m) a -> Event t m a
MkEvent forall a b. (a -> b) -> a -> b
$
      forall b a. b -> Interval a -> PairedInterval b a
makePairedInterval (forall t2 t1 d1 d2.
Ord t2 =>
(t1 -> t2) -> (d1 -> d2) -> Context t1 d1 -> Context t2 d2
bimapContext forall a. a -> a
id m -> m'
f forall a b. (a -> b) -> a -> b
$ forall t m a. Event t m a -> Context t m
getContext Event t m a
x) (forall (i :: * -> *) a. Intervallic i => i a -> Interval a
getInterval Event t m a
x)

instance EventFunction (Context t m -> Context t' m') t t' m m' a a where
  liftToEventFunction :: (Ord t, Ord t') =>
(Context t m -> Context t' m') -> Event t m a -> Event t' m' a
liftToEventFunction Context t m -> Context t' m'
f Event t m a
x =
    forall t m a. PairedInterval (Context t m) a -> Event t m a
MkEvent forall a b. (a -> b) -> a -> b
$ forall b a. b -> Interval a -> PairedInterval b a
makePairedInterval (Context t m -> Context t' m'
f forall a b. (a -> b) -> a -> b
$ forall t m a. Event t m a -> Context t m
getContext Event t m a
x) (forall (i :: * -> *) a. Intervallic i => i a -> Interval a
getInterval Event t m a
x)

-- |
-- Provides a common interface to lift a function
-- operating on some component of an 'Context'
-- into a function on an 'Context'.
--
-- This class is only used in this 'EventDataTheory.Core' module
-- for the purposes of having a single @liftToEventFunction@ function
-- that works on 'TagSet', 'Context', or 'Event' data.

-- NOTE: this kind of constraint solving could probably be done
-- using the Select monad from Control.Monad.Trans.Select
-- but it's not clear that would add anything other than additional deps.
class ContextFunction f t t' m m' where
  -- |
  --  Lifts a function @f@ of a component of an 'Context'
  --  to a function on an 'Context'
  liftToContextFunction :: (Ord t, Ord t') => f -> Context t m -> Context t' m'

instance ContextFunction (TagSet t -> TagSet t') t t' m m where
  liftToContextFunction :: (Ord t, Ord t') =>
(TagSet t -> TagSet t') -> Context t m -> Context t' m
liftToContextFunction TagSet t -> TagSet t'
f (MkContext TagSet t
x m
y Maybe Source
z) = forall t m. TagSet t -> m -> Maybe Source -> Context t m
MkContext (TagSet t -> TagSet t'
f TagSet t
x) m
y Maybe Source
z

instance ContextFunction (t -> t') t t' m m where
  liftToContextFunction :: (Ord t, Ord t') => (t -> t') -> Context t m -> Context t' m
liftToContextFunction t -> t'
f = forall t2 t1 d1 d2.
Ord t2 =>
(t1 -> t2) -> (d1 -> d2) -> Context t1 d1 -> Context t2 d2
bimapContext t -> t'
f forall a. a -> a
id

instance ContextFunction (m -> m') t t m m' where
  liftToContextFunction :: (Ord t, Ord t) => (m -> m') -> Context t m -> Context t m'
liftToContextFunction = forall t2 t1 d1 d2.
Ord t2 =>
(t1 -> t2) -> (d1 -> d2) -> Context t1 d1 -> Context t2 d2
bimapContext forall a. a -> a
id