-- | This module provides definitions for economic events.
--
-- /Note: The concept is not YET REA-compatible although we want to achieve it
-- at some point/.

{-# LANGUAGE DataKinds #-}

module Haspara.Accounting.Event where

import           Control.Monad.Except (MonadError(throwError))
import           Data.Aeson           ((.:), (.=))
import qualified Data.Aeson           as Aeson
import qualified Data.Char            as C
import qualified Data.Text            as T
import           Data.Time            (Day)
import           GHC.TypeLits         (KnownNat, Nat)
import           Haspara.Quantity     (Quantity, UnsignedQuantity)
import           Refined              (refine)


-- | Type encoding of an economic increment/decrement event.
--
-- The event explicitly carries the date and quantity information along with a
-- parameterized, arbitrary object providing the source of the event.
--
-- >>> :set -XDataKinds
-- >>> let date = read "2021-01-01"
-- >>> let oid = 1 :: Int
-- >>> let qty = $$(Refined.refineTH 42) :: UnsignedQuantity 2
-- >>> let event = EventDecrement date oid qty
-- >>> let json = Data.Aeson.encode event
-- >>> json
-- "{\"qty\":42.0,\"type\":\"DECREMENT\",\"obj\":1,\"date\":\"2021-01-01\"}"
-- >>> Data.Aeson.decode @(Event Int 2) json
-- Just (EventDecrement 2021-01-01 1 (Refined 42.00))
-- >>> Data.Aeson.decode json == Just event
-- True
data Event o (s :: Nat) =
    EventDecrement Day o (UnsignedQuantity s)
  | EventIncrement Day o (UnsignedQuantity s)
  deriving (Event o s -> Event o s -> Bool
(Event o s -> Event o s -> Bool)
-> (Event o s -> Event o s -> Bool) -> Eq (Event o s)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall o (s :: Nat). Eq o => Event o s -> Event o s -> Bool
/= :: Event o s -> Event o s -> Bool
$c/= :: forall o (s :: Nat). Eq o => Event o s -> Event o s -> Bool
== :: Event o s -> Event o s -> Bool
$c== :: forall o (s :: Nat). Eq o => Event o s -> Event o s -> Bool
Eq, Eq (Event o s)
Eq (Event o s)
-> (Event o s -> Event o s -> Ordering)
-> (Event o s -> Event o s -> Bool)
-> (Event o s -> Event o s -> Bool)
-> (Event o s -> Event o s -> Bool)
-> (Event o s -> Event o s -> Bool)
-> (Event o s -> Event o s -> Event o s)
-> (Event o s -> Event o s -> Event o s)
-> Ord (Event o s)
Event o s -> Event o s -> Bool
Event o s -> Event o s -> Ordering
Event o s -> Event o s -> Event o s
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 o (s :: Nat). Ord o => Eq (Event o s)
forall o (s :: Nat). Ord o => Event o s -> Event o s -> Bool
forall o (s :: Nat). Ord o => Event o s -> Event o s -> Ordering
forall o (s :: Nat). Ord o => Event o s -> Event o s -> Event o s
min :: Event o s -> Event o s -> Event o s
$cmin :: forall o (s :: Nat). Ord o => Event o s -> Event o s -> Event o s
max :: Event o s -> Event o s -> Event o s
$cmax :: forall o (s :: Nat). Ord o => Event o s -> Event o s -> Event o s
>= :: Event o s -> Event o s -> Bool
$c>= :: forall o (s :: Nat). Ord o => Event o s -> Event o s -> Bool
> :: Event o s -> Event o s -> Bool
$c> :: forall o (s :: Nat). Ord o => Event o s -> Event o s -> Bool
<= :: Event o s -> Event o s -> Bool
$c<= :: forall o (s :: Nat). Ord o => Event o s -> Event o s -> Bool
< :: Event o s -> Event o s -> Bool
$c< :: forall o (s :: Nat). Ord o => Event o s -> Event o s -> Bool
compare :: Event o s -> Event o s -> Ordering
$ccompare :: forall o (s :: Nat). Ord o => Event o s -> Event o s -> Ordering
$cp1Ord :: forall o (s :: Nat). Ord o => Eq (Event o s)
Ord, Int -> Event o s -> ShowS
[Event o s] -> ShowS
Event o s -> String
(Int -> Event o s -> ShowS)
-> (Event o s -> String)
-> ([Event o s] -> ShowS)
-> Show (Event o s)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall o (s :: Nat).
(Show o, KnownNat s) =>
Int -> Event o s -> ShowS
forall o (s :: Nat). (Show o, KnownNat s) => [Event o s] -> ShowS
forall o (s :: Nat). (Show o, KnownNat s) => Event o s -> String
showList :: [Event o s] -> ShowS
$cshowList :: forall o (s :: Nat). (Show o, KnownNat s) => [Event o s] -> ShowS
show :: Event o s -> String
$cshow :: forall o (s :: Nat). (Show o, KnownNat s) => Event o s -> String
showsPrec :: Int -> Event o s -> ShowS
$cshowsPrec :: forall o (s :: Nat).
(Show o, KnownNat s) =>
Int -> Event o s -> ShowS
Show)


instance (Aeson.FromJSON o, KnownNat s) => Aeson.FromJSON (Event o s) where
  parseJSON :: Value -> Parser (Event o s)
parseJSON = String
-> (Object -> Parser (Event o s)) -> Value -> Parser (Event o s)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject String
"Event" ((Object -> Parser (Event o s)) -> Value -> Parser (Event o s))
-> (Object -> Parser (Event o s)) -> Value -> Parser (Event o s)
forall a b. (a -> b) -> a -> b
$ \Object
o -> do
    Text
dorc <- Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"type"
    Day -> o -> UnsignedQuantity s -> Event o s
cons <- case (Char -> Char) -> Text -> Text
T.map Char -> Char
C.toUpper Text
dorc of
      Text
"DECREMENT" -> (Day -> o -> UnsignedQuantity s -> Event o s)
-> Parser (Day -> o -> UnsignedQuantity s -> Event o s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Day -> o -> UnsignedQuantity s -> Event o s
forall o (s :: Nat). Day -> o -> UnsignedQuantity s -> Event o s
EventDecrement
      Text
"INCREMENT" -> (Day -> o -> UnsignedQuantity s -> Event o s)
-> Parser (Day -> o -> UnsignedQuantity s -> Event o s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Day -> o -> UnsignedQuantity s -> Event o s
forall o (s :: Nat). Day -> o -> UnsignedQuantity s -> Event o s
EventIncrement
      Text
x           -> String -> Parser (Day -> o -> UnsignedQuantity s -> Event o s)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Unknown event type: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
T.unpack Text
x)
    Day
date <- Object
o Object -> Key -> Parser Day
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"date"
    o
obj <- Object
o Object -> Key -> Parser o
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"obj"
    UnsignedQuantity s
qty <- Object
o Object -> Key -> Parser (UnsignedQuantity s)
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"qty"
    Event o s -> Parser (Event o s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Day -> o -> UnsignedQuantity s -> Event o s
cons Day
date o
obj UnsignedQuantity s
qty)


instance (Aeson.ToJSON o, KnownNat s) => Aeson.ToJSON (Event o s) where
  toJSON :: Event o s -> Value
toJSON Event o s
x = case Event o s
x of
    EventDecrement Day
d o
o UnsignedQuantity s
q -> [Pair] -> Value
Aeson.object [Key
"type" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (Text
"DECREMENT" :: T.Text), Key
"date" Key -> Day -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Day
d, Key
"obj" Key -> o -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= o
o, Key
"qty" Key -> UnsignedQuantity s -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= UnsignedQuantity s
q]
    EventIncrement Day
d o
o UnsignedQuantity s
q -> [Pair] -> Value
Aeson.object [Key
"type" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (Text
"INCREMENT" :: T.Text), Key
"date" Key -> Day -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Day
d, Key
"obj" Key -> o -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= o
o, Key
"qty" Key -> UnsignedQuantity s -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= UnsignedQuantity s
q]


-- | Returns the date of the event.
eventDate :: (KnownNat s) => Event o s -> Day
eventDate :: Event o s -> Day
eventDate (EventDecrement Day
d o
_ UnsignedQuantity s
_) = Day
d
eventDate (EventIncrement Day
d o
_ UnsignedQuantity s
_) = Day
d


-- | Returns the source object of the event.
eventObject :: (KnownNat s) => Event o s -> o
eventObject :: Event o s -> o
eventObject (EventDecrement Day
_ o
o UnsignedQuantity s
_) = o
o
eventObject (EventIncrement Day
_ o
o UnsignedQuantity s
_) = o
o


-- | Negates the event.
negateEvent :: (KnownNat s) => Event o s -> Event o s
negateEvent :: Event o s -> Event o s
negateEvent (EventDecrement Day
d o
o UnsignedQuantity s
x) = Day -> o -> UnsignedQuantity s -> Event o s
forall o (s :: Nat). Day -> o -> UnsignedQuantity s -> Event o s
EventIncrement Day
d o
o UnsignedQuantity s
x
negateEvent (EventIncrement Day
d o
o UnsignedQuantity s
x) = Day -> o -> UnsignedQuantity s -> Event o s
forall o (s :: Nat). Day -> o -> UnsignedQuantity s -> Event o s
EventDecrement Day
d o
o UnsignedQuantity s
x


-- | Smart constuctor for 'Event' values.
mkEvent
  :: MonadError String m
  => KnownNat s
  => Day         -- ^ Date of the event.
  -> o           -- ^ Source object of the event.
  -> Quantity s  -- ^ Quantity of the event.
  -> m (Event o s)
mkEvent :: Day -> o -> Quantity s -> m (Event o s)
mkEvent Day
d o
o Quantity s
x
  | Quantity s
x Quantity s -> Quantity s -> Bool
forall a. Ord a => a -> a -> Bool
< Quantity s
0     = (RefineException -> m (Event o s))
-> (Event o s -> m (Event o s))
-> Either RefineException (Event o s)
-> m (Event o s)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> m (Event o s)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> m (Event o s))
-> (RefineException -> String) -> RefineException -> m (Event o s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RefineException -> String
forall a. Show a => a -> String
show) Event o s -> m (Event o s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either RefineException (Event o s) -> m (Event o s))
-> Either RefineException (Event o s) -> m (Event o s)
forall a b. (a -> b) -> a -> b
$ Day -> o -> UnsignedQuantity s -> Event o s
forall o (s :: Nat). Day -> o -> UnsignedQuantity s -> Event o s
EventDecrement Day
d o
o (UnsignedQuantity s -> Event o s)
-> Either RefineException (UnsignedQuantity s)
-> Either RefineException (Event o s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Quantity s -> Either RefineException (UnsignedQuantity s)
forall p x.
Predicate p x =>
x -> Either RefineException (Refined p x)
refine (Quantity s -> Quantity s
forall a. Num a => a -> a
abs Quantity s
x)
  | Bool
otherwise = (RefineException -> m (Event o s))
-> (Event o s -> m (Event o s))
-> Either RefineException (Event o s)
-> m (Event o s)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> m (Event o s)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (String -> m (Event o s))
-> (RefineException -> String) -> RefineException -> m (Event o s)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RefineException -> String
forall a. Show a => a -> String
show) Event o s -> m (Event o s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either RefineException (Event o s) -> m (Event o s))
-> Either RefineException (Event o s) -> m (Event o s)
forall a b. (a -> b) -> a -> b
$ Day -> o -> UnsignedQuantity s -> Event o s
forall o (s :: Nat). Day -> o -> UnsignedQuantity s -> Event o s
EventIncrement Day
d o
o (UnsignedQuantity s -> Event o s)
-> Either RefineException (UnsignedQuantity s)
-> Either RefineException (Event o s)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Quantity s -> Either RefineException (UnsignedQuantity s)
forall p x.
Predicate p x =>
x -> Either RefineException (Refined p x)
refine (Quantity s -> Quantity s
forall a. Num a => a -> a
abs Quantity s
x)