{-|
Module      : Hasklepias 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
-}

{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE Safe #-}

module Hasklepias.Types.Context(
    Context(getConcepts)
  , context
  , emptyContext

  , Concept
  , Concepts
  , toConcepts
  , fromConcepts
  , packConcept
  , unpackConcept
  , packConcepts
  , unpackConcepts
  , HasConcept(..)
) where

import GHC.Show                 ( Show(show) )
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.Text                (Text)
import Data.Set                 (Set
                                , fromList, union, empty, map, toList, member)

-- | 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
getConcepts :: Concepts
    , Context -> Maybe Facts
getFacts    :: Maybe Facts
    , Context -> Maybe Source
getSource   :: 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 Facts  = Facts  deriving (Facts -> Facts -> Bool
(Facts -> Facts -> Bool) -> (Facts -> Facts -> Bool) -> Eq Facts
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Facts -> Facts -> Bool
$c/= :: Facts -> Facts -> Bool
== :: Facts -> Facts -> Bool
$c== :: Facts -> Facts -> Bool
Eq, Int -> Facts -> ShowS
[Facts] -> ShowS
Facts -> String
(Int -> Facts -> ShowS)
-> (Facts -> String) -> ([Facts] -> ShowS) -> Show Facts
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Facts] -> ShowS
$cshowList :: [Facts] -> ShowS
show :: Facts -> String
$cshow :: Facts -> String
showsPrec :: Int -> Facts -> ShowS
$cshowsPrec :: Int -> Facts -> 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 Semigroup Context where
    Context
x <> :: Context -> Context -> Context
<> Context
y = Concepts -> Maybe Facts -> Maybe Source -> Context
Context (Context -> Concepts
getConcepts Context
x Concepts -> Concepts -> Concepts
forall a. Semigroup a => a -> a -> a
<> Context -> Concepts
getConcepts Context
y) Maybe Facts
forall a. Maybe a
Nothing Maybe Source
forall a. Maybe a
Nothing

instance Monoid Context where
    mempty :: Context
mempty = Context
emptyContext

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
fromConcepts (Concepts -> Set Concept) -> Concepts -> Set Concept
forall a b. (a -> b) -> a -> b
$ Context -> Concepts
getConcepts 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 :: Concepts -> Context
context :: Concepts -> Context
context Concepts
x = Concepts -> Maybe Facts -> Maybe Source -> Context
Context Concepts
x Maybe Facts
forall a. Maybe a
Nothing Maybe Source
forall a. Maybe a
Nothing

-- | Just an empty Context
emptyContext :: Context
emptyContext :: Context
emptyContext = Concepts -> Maybe Facts -> Maybe Source -> Context
Context Concepts
forall a. Monoid a => a
mempty Maybe Facts
forall a. Maybe a
Nothing 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 'Concepts'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)

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

fromConcepts :: Concepts -> Set Concept
fromConcepts :: Concepts -> Set Concept
fromConcepts (Concepts Set Concept
x) = Set Concept
x

-- | 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