{-# LANGUAGE DataKinds        #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE KindSignatures   #-}

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           GHC.TypeLits             (KnownNat, Nat)
import qualified Haspara                  as H
import           Haspara.Accounting.Types (UnsignedQuantity)
import           Refined                  (refine)


-- | Encoding of an increment/decrement event.
--
-- >>> :set -XDataKinds
-- >>> import Refined
-- >>> let date = read "2021-01-01"
-- >>> let oid = 1 :: Int
-- >>> let qty = $$(refineTH 42) :: UnsignedQuantity 2
-- >>> let event = EventDecrement date oid qty
-- >>> let json = Aeson.encode event
-- >>> json
-- "{\"qty\":42.0,\"obj\":1,\"date\":\"2021-01-01\",\"type\":\"DECREMENT\"}"
-- >>> Aeson.decode json :: Maybe (Event Int 2)
-- Just (EventDecrement 2021-01-01 1 (Refined 42.00))
-- >>> Aeson.decode json == Just event
-- True
data Event o (s :: Nat) =
    EventDecrement H.Date o (UnsignedQuantity s)
  | EventIncrement H.Date 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 -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"type"
    Date -> o -> UnsignedQuantity s -> Event o s
cons <- case (Char -> Char) -> Text -> Text
T.map Char -> Char
C.toUpper Text
dorc of
      Text
"DECREMENT" -> (Date -> o -> UnsignedQuantity s -> Event o s)
-> Parser (Date -> o -> UnsignedQuantity s -> Event o s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Date -> o -> UnsignedQuantity s -> Event o s
forall o (s :: Nat). Date -> o -> UnsignedQuantity s -> Event o s
EventDecrement
      Text
"INCREMENT" -> (Date -> o -> UnsignedQuantity s -> Event o s)
-> Parser (Date -> o -> UnsignedQuantity s -> Event o s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Date -> o -> UnsignedQuantity s -> Event o s
forall o (s :: Nat). Date -> o -> UnsignedQuantity s -> Event o s
EventIncrement
      Text
x           -> String -> Parser (Date -> 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)
    Date
date <- Object
o Object -> Text -> Parser Date
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"date"
    o
obj <- Object
o Object -> Text -> Parser o
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"obj"
    UnsignedQuantity s
qty <- Object
o Object -> Text -> Parser (UnsignedQuantity s)
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"qty"
    Event o s -> Parser (Event o s)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Date -> o -> UnsignedQuantity s -> Event o s
cons Date
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 Date
d o
o UnsignedQuantity s
q -> [Pair] -> Value
Aeson.object [Text
"type" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (Text
"DECREMENT" :: T.Text), Text
"date" Text -> Date -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Date
d, Text
"obj" Text -> o -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= o
o, Text
"qty" Text -> UnsignedQuantity s -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= UnsignedQuantity s
q]
    EventIncrement Date
d o
o UnsignedQuantity s
q -> [Pair] -> Value
Aeson.object [Text
"type" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= (Text
"INCREMENT" :: T.Text), Text
"date" Text -> Date -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Date
d, Text
"obj" Text -> o -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= o
o, Text
"qty" Text -> UnsignedQuantity s -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= UnsignedQuantity s
q]


eventDate :: (KnownNat s) => Event o s -> H.Date
eventDate :: Event o s -> Date
eventDate (EventDecrement Date
d o
_ UnsignedQuantity s
_) = Date
d
eventDate (EventIncrement Date
d o
_ UnsignedQuantity s
_) = Date
d


eventObject :: (KnownNat s) => Event o s -> o
eventObject :: Event o s -> o
eventObject (EventDecrement Date
_ o
o UnsignedQuantity s
_) = o
o
eventObject (EventIncrement Date
_ o
o UnsignedQuantity s
_) = o
o


negateEvent :: (KnownNat s) => Event o s -> Event o s
negateEvent :: Event o s -> Event o s
negateEvent (EventDecrement Date
d o
o UnsignedQuantity s
x) = Date -> o -> UnsignedQuantity s -> Event o s
forall o (s :: Nat). Date -> o -> UnsignedQuantity s -> Event o s
EventIncrement Date
d o
o UnsignedQuantity s
x
negateEvent (EventIncrement Date
d o
o UnsignedQuantity s
x) = Date -> o -> UnsignedQuantity s -> Event o s
forall o (s :: Nat). Date -> o -> UnsignedQuantity s -> Event o s
EventDecrement Date
d o
o UnsignedQuantity s
x


mkEvent :: (MonadError String m, KnownNat s) => H.Date -> o -> H.Quantity s -> m (Event o s)
mkEvent :: Date -> o -> Quantity s -> m (Event o s)
mkEvent Date
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
$ Date -> o -> UnsignedQuantity s -> Event o s
forall o (s :: Nat). Date -> o -> UnsignedQuantity s -> Event o s
EventDecrement Date
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
$ Date -> o -> UnsignedQuantity s -> Event o s
forall o (s :: Nat). Date -> o -> UnsignedQuantity s -> Event o s
EventIncrement Date
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)