{-|
Module      : Event Data Model Contexts
Description : Defines the Context type and its component types, constructors, 
              and class instances
Copyright   : (c) NoviSci, Inc 2020
License     : BSD3
Maintainer  : bsaul@novisci.com
-}

{-# OPTIONS_HADDOCK hide #-}
{-# LANGUAGE NoImplicitPrelude #-}
-- {-# LANGUAGE Safe #-}
{-# LANGUAGE TemplateHaskell #-}

module EventData.Context
  ( Context(..)
  , concepts
  , facts
  , source
  , context
  , Concept
  , Concepts
  , toConcepts
  , getConcepts
  , packConcept
  , unpackConcept
  , packConcepts
  , unpackConcepts
  , HasConcept(..)
  , Source
  ) where

import           Control.Lens                   ( makeLenses )
import           Data.Bool                      ( Bool )
import           Data.Eq                        ( Eq )
import           Data.Function                  ( ($)
                                                , (.)
                                                )
import           Data.List                      ( all
                                                , any
                                                , map
                                                )
import           Data.Maybe                     ( Maybe(Nothing) )
import           Data.Monoid                    ( (<>)
                                                , Monoid(mempty)
                                                )
import           Data.Ord                       ( Ord )
import           Data.Semigroup                 ( Semigroup((<>)) )
import           Data.Set                       ( Set
                                                , empty
                                                , fromList
                                                , map
                                                , member
                                                , toList
                                                , union
                                                )
import           Data.Text                      ( Text )
import           EventData.Context.Domain       ( Domain )
import           GHC.Show                       ( Show(show) )

-- | A @Context@ consists of three parts: @concepts@, @facts@, and @source@. 
-- 
-- At this time, @facts@ and @source@ are simply stubs to be fleshed out in 
-- later versions of hasklepias. 
data Context = Context
  { Context -> Concepts
_concepts :: Concepts
  , Context -> Domain
_facts    :: Domain
  , Context -> Maybe Source
_source   :: Maybe Source
  }
  deriving (Context -> Context -> Bool
(Context -> Context -> Bool)
-> (Context -> Context -> Bool) -> Eq Context
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Context -> Context -> Bool
$c/= :: Context -> Context -> Bool
== :: Context -> Context -> Bool
$c== :: Context -> Context -> Bool
Eq, Int -> Context -> ShowS
[Context] -> ShowS
Context -> String
(Int -> Context -> ShowS)
-> (Context -> String) -> ([Context] -> ShowS) -> Show Context
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Context] -> ShowS
$cshowList :: [Context] -> ShowS
show :: Context -> String
$cshow :: Context -> String
showsPrec :: Int -> Context -> ShowS
$cshowsPrec :: Int -> Context -> ShowS
Show)

data Source = Source
  deriving (Source -> Source -> Bool
(Source -> Source -> Bool)
-> (Source -> Source -> Bool) -> Eq Source
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
(Int -> Source -> ShowS)
-> (Source -> String) -> ([Source] -> ShowS) -> Show Source
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)

instance HasConcept Context where
  hasConcept :: Context -> Text -> Bool
hasConcept Context
ctxt Text
concept =
    Concept -> Set Concept -> Bool
forall a. Ord a => a -> Set a -> Bool
member (Text -> Concept
packConcept Text
concept) (Concepts -> Set Concept
getConcepts (Concepts -> Set Concept) -> Concepts -> Set Concept
forall a b. (a -> b) -> a -> b
$ Context -> Concepts
_concepts Context
ctxt)

-- | Smart contructor for Context type
--
-- Creates 'Context' from a list of 'Concept's. At this time, the @facts@ and
-- @source@ are both set to 'Nothing'.
context :: Domain -> Concepts -> Context
context :: Domain -> Concepts -> Context
context Domain
d Concepts
x = Concepts -> Domain -> Maybe Source -> Context
Context Concepts
x Domain
d Maybe Source
forall a. Maybe a
Nothing

-- | A @Concept@ is textual "tag" for a context.
newtype Concept = Concept Text deriving (Concept -> Concept -> Bool
(Concept -> Concept -> Bool)
-> (Concept -> Concept -> Bool) -> Eq Concept
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Concept -> Concept -> Bool
$c/= :: Concept -> Concept -> Bool
== :: Concept -> Concept -> Bool
$c== :: Concept -> Concept -> Bool
Eq, Eq Concept
Eq Concept
-> (Concept -> Concept -> Ordering)
-> (Concept -> Concept -> Bool)
-> (Concept -> Concept -> Bool)
-> (Concept -> Concept -> Bool)
-> (Concept -> Concept -> Bool)
-> (Concept -> Concept -> Concept)
-> (Concept -> Concept -> Concept)
-> Ord Concept
Concept -> Concept -> Bool
Concept -> Concept -> Ordering
Concept -> Concept -> Concept
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 :: Concept -> Concept -> Concept
$cmin :: Concept -> Concept -> Concept
max :: Concept -> Concept -> Concept
$cmax :: Concept -> Concept -> Concept
>= :: Concept -> Concept -> Bool
$c>= :: Concept -> Concept -> Bool
> :: Concept -> Concept -> Bool
$c> :: Concept -> Concept -> Bool
<= :: Concept -> Concept -> Bool
$c<= :: Concept -> Concept -> Bool
< :: Concept -> Concept -> Bool
$c< :: Concept -> Concept -> Bool
compare :: Concept -> Concept -> Ordering
$ccompare :: Concept -> Concept -> Ordering
$cp1Ord :: Eq Concept
Ord)

instance Show Concept where
  show :: Concept -> String
show (Concept Text
x) = Text -> String
forall a. Show a => a -> String
show Text
x

-- | Pack text into a concept
packConcept :: Text -> Concept
packConcept :: Text -> Concept
packConcept = Text -> Concept
Concept

-- | Unpack text from a concept
unpackConcept :: Concept -> Text
unpackConcept :: Concept -> Text
unpackConcept (Concept Text
x) = Text
x

-- | @Concepts@ is a 'Set' of 'Concept's.
newtype Concepts = Concepts ( Set Concept )
    deriving (Concepts -> Concepts -> Bool
(Concepts -> Concepts -> Bool)
-> (Concepts -> Concepts -> Bool) -> Eq Concepts
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Concepts -> Concepts -> Bool
$c/= :: Concepts -> Concepts -> Bool
== :: Concepts -> Concepts -> Bool
$c== :: Concepts -> Concepts -> Bool
Eq, Int -> Concepts -> ShowS
[Concepts] -> ShowS
Concepts -> String
(Int -> Concepts -> ShowS)
-> (Concepts -> String) -> ([Concepts] -> ShowS) -> Show Concepts
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Concepts] -> ShowS
$cshowList :: [Concepts] -> ShowS
show :: Concepts -> String
$cshow :: Concepts -> String
showsPrec :: Int -> Concepts -> ShowS
$cshowsPrec :: Int -> Concepts -> ShowS
Show)

-- | Unwrap the `Concepts' newtype.
getConcepts :: Concepts -> Set Concept
getConcepts :: Concepts -> Set Concept
getConcepts (Concepts Set Concept
x) = Set Concept
x

instance Semigroup Concepts where
  Concepts Set Concept
x <> :: Concepts -> Concepts -> Concepts
<> Concepts Set Concept
y = Set Concept -> Concepts
Concepts (Set Concept
x Set Concept -> Set Concept -> Set Concept
forall a. Semigroup a => a -> a -> a
<> Set Concept
y)

instance Monoid Concepts where
  mempty :: Concepts
mempty = Set Concept -> Concepts
Concepts Set Concept
forall a. Monoid a => a
mempty

-- | Constructor for 'Concepts'.
toConcepts :: Set Concept -> Concepts
toConcepts :: Set Concept -> Concepts
toConcepts = Set Concept -> Concepts
Concepts

-- | Put a list of text into a set concepts.
packConcepts :: [Text] -> Concepts
packConcepts :: [Text] -> Concepts
packConcepts [Text]
x = Set Concept -> Concepts
Concepts (Set Concept -> Concepts) -> Set Concept -> Concepts
forall a b. (a -> b) -> a -> b
$ [Concept] -> Set Concept
forall a. Ord a => [a] -> Set a
fromList ([Concept] -> Set Concept) -> [Concept] -> Set Concept
forall a b. (a -> b) -> a -> b
$ (Text -> Concept) -> [Text] -> [Concept]
forall a b. (a -> b) -> [a] -> [b]
Data.List.map Text -> Concept
packConcept [Text]
x

-- | Take a set of concepts to a list of text.
unpackConcepts :: Concepts -> [Text]
unpackConcepts :: Concepts -> [Text]
unpackConcepts (Concepts Set Concept
x) = Set Text -> [Text]
forall a. Set a -> [a]
toList (Set Text -> [Text]) -> Set Text -> [Text]
forall a b. (a -> b) -> a -> b
$ (Concept -> Text) -> Set Concept -> Set Text
forall b a. Ord b => (a -> b) -> Set a -> Set b
Data.Set.map Concept -> Text
unpackConcept Set Concept
x

{- |
The 'HasConcept' typeclass provides predicate functions for determining whether
an @a@ has a concept.
-}
class HasConcept a where
    -- | Does an @a@ have a particular 'Concept'?
    hasConcept  :: a -> Text -> Bool

    -- | Does an @a@ have *any* of a list of 'Concept's?
    hasConcepts :: a -> [Text] -> Bool
    hasConcepts a
x = (Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\Text
c -> a
x a -> Text -> Bool
forall a. HasConcept a => a -> Text -> Bool
`hasConcept` Text
c)

    -- | Does an @a@ have *all* of a list of `Concept's?
    hasAllConcepts :: a -> [Text] -> Bool
    hasAllConcepts a
x = (Text -> Bool) -> [Text] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\Text
c -> a
x a -> Text -> Bool
forall a. HasConcept a => a -> Text -> Bool
`hasConcept` Text
c)

instance HasConcept Concepts where
  hasConcept :: Concepts -> Text -> Bool
hasConcept (Concepts Set Concept
e) Text
concept = Concept -> Set Concept -> Bool
forall a. Ord a => a -> Set a -> Bool
member (Text -> Concept
packConcept Text
concept) Set Concept
e

makeLenses ''Context