{-# OPTIONS_GHC -Wno-orphans #-}

-- | Internal utilities and instances
module Calamity.Internal.Utils
    ( whileMFinalIO
    , untilJustFinalIO
    , whenJust
    , whenM
    , unlessM
    , lastMaybe
    , leftToMaybe
    , rightToMaybe
    , justToEither
    , (<<$>>)
    , (<<*>>)
    , (<.>)
    , debug
    , info
    , Calamity.Internal.Utils.error
    , swap ) where

import           Calamity.Types.LogEff
import           Calamity.Internal.RunIntoIO

import           Control.Applicative

import           Data.Default.Class
import qualified Data.HashMap.Lazy     as LH
import qualified Data.Map              as M
import           Data.Semigroup        ( Last(..) )
import           Data.Text.Lazy
import           Data.Time
import qualified Data.Vector.Unboxing  as VU
import           Data.Vector.Unboxing  ( Vector )
import           Data.Aeson

import qualified DiPolysemy            as Di

import qualified Polysemy              as P

import           TextShow
import Data.Colour (Colour)

-- | Like whileM, but stateful effects are not preserved to mitigate memory leaks
--
-- This means Polysemy.Error won't work to break the loop, etc.
-- Instead, Error/Alternative will just result in the loop quitting.
whileMFinalIO :: P.Member (P.Final IO) r => P.Sem r Bool -> P.Sem r ()
whileMFinalIO :: Sem r Bool -> Sem r ()
whileMFinalIO Sem r Bool
action = do
  IO (Maybe Bool)
action' <- Sem r Bool -> Sem r (IO (Maybe Bool))
forall (r :: [(* -> *) -> * -> *]) a.
Member (Final IO) r =>
Sem r a -> Sem r (IO (Maybe a))
runSemToIO Sem r Bool
action
  IO () -> Sem r ()
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
(Member (Final m) r, Functor m) =>
m a -> Sem r a
P.embedFinal (IO () -> Sem r ()) -> IO () -> Sem r ()
forall a b. (a -> b) -> a -> b
$ IO (Maybe Bool) -> IO ()
forall (m :: * -> *). Monad m => m (Maybe Bool) -> m ()
go IO (Maybe Bool)
action'
  where go :: m (Maybe Bool) -> m ()
go m (Maybe Bool)
action' = do
          Maybe Bool
r <- m (Maybe Bool)
action'
          case Maybe Bool
r of
            Just Bool
True ->
              m (Maybe Bool) -> m ()
go m (Maybe Bool)
action'
            Maybe Bool
_ ->
              () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | Like untilJust, but stateful effects are not preserved to mitigate memory leaks
--
-- This means Polysemy.Error won't work to break the loop, etc.
-- Instead, Error/Alternative will just result in another loop.
untilJustFinalIO :: P.Member (P.Final IO) r => P.Sem r (Maybe a) -> P.Sem r a
untilJustFinalIO :: Sem r (Maybe a) -> Sem r a
untilJustFinalIO Sem r (Maybe a)
action = do
  IO (Maybe (Maybe a))
action' <- Sem r (Maybe a) -> Sem r (IO (Maybe (Maybe a)))
forall (r :: [(* -> *) -> * -> *]) a.
Member (Final IO) r =>
Sem r a -> Sem r (IO (Maybe a))
runSemToIO Sem r (Maybe a)
action
  IO a -> Sem r a
forall (m :: * -> *) (r :: [(* -> *) -> * -> *]) a.
(Member (Final m) r, Functor m) =>
m a -> Sem r a
P.embedFinal (IO a -> Sem r a) -> IO a -> Sem r a
forall a b. (a -> b) -> a -> b
$ IO (Maybe (Maybe a)) -> IO a
forall (m :: * -> *) b. Monad m => m (Maybe (Maybe b)) -> m b
go IO (Maybe (Maybe a))
action'
  where go :: m (Maybe (Maybe b)) -> m b
go m (Maybe (Maybe b))
action' = do
          Maybe (Maybe b)
r <- m (Maybe (Maybe b))
action'
          case Maybe (Maybe b)
r of
            Just (Just b
a) ->
              b -> m b
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
a
            Maybe (Maybe b)
_ ->
              m (Maybe (Maybe b)) -> m b
go m (Maybe (Maybe b))
action'

whenJust :: Applicative m => Maybe a -> (a -> m ()) -> m ()
whenJust :: Maybe a -> (a -> m ()) -> m ()
whenJust = ((a -> m ()) -> Maybe a -> m ()) -> Maybe a -> (a -> m ()) -> m ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip (((a -> m ()) -> Maybe a -> m ())
 -> Maybe a -> (a -> m ()) -> m ())
-> ((a -> m ()) -> Maybe a -> m ())
-> Maybe a
-> (a -> m ())
-> m ()
forall a b. (a -> b) -> a -> b
$ m () -> (a -> m ()) -> Maybe a -> m ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

whenM :: Monad m => m Bool -> m () -> m ()
whenM :: m Bool -> m () -> m ()
whenM m Bool
p m ()
m = m Bool
p m Bool -> (Bool -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  Bool
True  -> m ()
m
  Bool
False -> () -> m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

unlessM :: Monad m => m Bool -> m () -> m ()
unlessM :: m Bool -> m () -> m ()
unlessM = m Bool -> m () -> m ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (m Bool -> m () -> m ())
-> (m Bool -> m Bool) -> m Bool -> m () -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool -> Bool
not (Bool -> Bool) -> m Bool -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)

lastMaybe :: Maybe a -> Maybe a -> Maybe a
lastMaybe :: Maybe a -> Maybe a -> Maybe a
lastMaybe Maybe a
l Maybe a
r = Last a -> a
forall a. Last a -> a
getLast (Last a -> a) -> Maybe (Last a) -> Maybe a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> Last a) -> Maybe a -> Maybe (Last a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Last a
forall a. a -> Last a
Last Maybe a
l Maybe (Last a) -> Maybe (Last a) -> Maybe (Last a)
forall a. Semigroup a => a -> a -> a
<> (a -> Last a) -> Maybe a -> Maybe (Last a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Last a
forall a. a -> Last a
Last Maybe a
r

leftToMaybe :: Either e a -> Maybe e
leftToMaybe :: Either e a -> Maybe e
leftToMaybe (Left e
x) = e -> Maybe e
forall a. a -> Maybe a
Just e
x
leftToMaybe Either e a
_        = Maybe e
forall a. Maybe a
Nothing

rightToMaybe :: Either e a -> Maybe a
rightToMaybe :: Either e a -> Maybe a
rightToMaybe (Right a
x) = a -> Maybe a
forall a. a -> Maybe a
Just a
x
rightToMaybe Either e a
_         = Maybe a
forall a. Maybe a
Nothing

justToEither :: Maybe e -> Either e ()
justToEither :: Maybe e -> Either e ()
justToEither (Just e
x) = e -> Either e ()
forall a b. a -> Either a b
Left e
x
justToEither Maybe e
_        = () -> Either e ()
forall a b. b -> Either a b
Right ()

(<<$>>) :: (Functor f, Functor g) => (a -> b) -> f (g a) -> f (g b)
<<$>> :: (a -> b) -> f (g a) -> f (g b)
(<<$>>) = (g a -> g b) -> f (g a) -> f (g b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((g a -> g b) -> f (g a) -> f (g b))
-> ((a -> b) -> g a -> g b) -> (a -> b) -> f (g a) -> f (g b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b) -> g a -> g b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap

infixl 4 <<$>>

(<<*>>) :: (Applicative f, Applicative g) => f (g (a -> b)) -> f (g a) -> f (g b)
<<*>> :: f (g (a -> b)) -> f (g a) -> f (g b)
(<<*>>) = (g (a -> b) -> g a -> g b) -> f (g (a -> b)) -> f (g a) -> f (g b)
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 g (a -> b) -> g a -> g b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
(<*>)

infixl 4 <<*>>

(<.>) :: Functor f => (a -> b) -> (c -> f a) -> (c -> f b)
<.> :: (a -> b) -> (c -> f a) -> c -> f b
(<.>) a -> b
f c -> f a
g c
x = a -> b
f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> c -> f a
g c
x

infixl 4 <.>

debug :: P.Member LogEff r => Text -> P.Sem r ()
debug :: Text -> Sem r ()
debug = Text -> Sem r ()
forall msg path (r :: [(* -> *) -> * -> *]).
(ToMessage msg, Member (Di Level path Message) r) =>
msg -> Sem r ()
Di.debug

info :: P.Member LogEff r => Text -> P.Sem r ()
info :: Text -> Sem r ()
info = Text -> Sem r ()
forall msg path (r :: [(* -> *) -> * -> *]).
(ToMessage msg, Member (Di Level path Message) r) =>
msg -> Sem r ()
Di.info

error :: P.Member LogEff r => Text -> P.Sem r ()
error :: Text -> Sem r ()
error = Text -> Sem r ()
forall msg path (r :: [(* -> *) -> * -> *]).
(ToMessage msg, Member (Di Level path Message) r) =>
msg -> Sem r ()
Di.error

swap :: (a, b) -> (b, a)
swap :: (a, b) -> (b, a)
swap ~(a
a, b
b) = (b
b, a
a)

instance TextShow UTCTime where
  showb :: UTCTime -> Builder
showb = String -> Builder
fromString (String -> Builder) -> (UTCTime -> String) -> UTCTime -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTime -> String
forall a. Show a => a -> String
show

instance (TextShow a, VU.Unboxable a) => TextShow (Vector a) where
  showb :: Vector a -> Builder
showb = [a] -> Builder
forall a. TextShow a => [a] -> Builder
showbList ([a] -> Builder) -> (Vector a -> [a]) -> Vector a -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector a -> [a]
forall a. Unboxable a => Vector a -> [a]
VU.toList

instance (Show k, Show v) => TextShow (LH.HashMap k v) where
  showb :: HashMap k v -> Builder
showb = String -> Builder
fromString (String -> Builder)
-> (HashMap k v -> String) -> HashMap k v -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashMap k v -> String
forall a. Show a => a -> String
show

instance (Show k, Show v) => TextShow (M.Map k v) where
  showb :: Map k v -> Builder
showb = String -> Builder
fromString (String -> Builder) -> (Map k v -> String) -> Map k v -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map k v -> String
forall a. Show a => a -> String
show

instance (Show a, Fractional a) => TextShow (Colour a) where
  showb :: Colour a -> Builder
showb = String -> Builder
fromString (String -> Builder) -> (Colour a -> String) -> Colour a -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Colour a -> String
forall a. Show a => a -> String
show

instance Default (M.Map k v) where
    def :: Map k v
def = Map k v
forall k v. Map k v
M.empty

instance (FromJSON a, VU.Unboxable a) => FromJSON (VU.Vector a) where
  parseJSON :: Value -> Parser (Vector a)
parseJSON = ([a] -> Vector a
forall a. Unboxable a => [a] -> Vector a
VU.fromList ([a] -> Vector a) -> Parser [a] -> Parser (Vector a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (Parser [a] -> Parser (Vector a))
-> (Value -> Parser [a]) -> Value -> Parser (Vector a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Parser [a]
forall a. FromJSON a => Value -> Parser a
parseJSON

instance (ToJSON a, VU.Unboxable a) => ToJSON (VU.Vector a) where
  toJSON :: Vector a -> Value
toJSON = [a] -> Value
forall a. ToJSON a => a -> Value
toJSON ([a] -> Value) -> (Vector a -> [a]) -> Vector a -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector a -> [a]
forall a. Unboxable a => Vector a -> [a]
VU.toList
  toEncoding :: Vector a -> Encoding
toEncoding = [a] -> Encoding
forall a. ToJSON a => a -> Encoding
toEncoding ([a] -> Encoding) -> (Vector a -> [a]) -> Vector a -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector a -> [a]
forall a. Unboxable a => Vector a -> [a]
VU.toList