{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE TemplateHaskell #-}

-- |
-- Module      :  Disco.Messages
-- Copyright   :  disco team and contributors
-- Maintainer  :  byorgey@gmail.com
--
-- SPDX-License-Identifier: BSD-3-Clause
--
-- Message logging framework (e.g. for errors, warnings, etc.) for
-- disco.
module Disco.Messages where

import Control.Lens
import Control.Monad (when)
import Polysemy
import Polysemy.Output

import Disco.Pretty (Doc, Pretty, pretty', renderDoc')

data MessageType
  = Info
  | Warning
  | ErrMsg
  | Debug
  deriving (Int -> MessageType -> ShowS
[MessageType] -> ShowS
MessageType -> String
(Int -> MessageType -> ShowS)
-> (MessageType -> String)
-> ([MessageType] -> ShowS)
-> Show MessageType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MessageType -> ShowS
showsPrec :: Int -> MessageType -> ShowS
$cshow :: MessageType -> String
show :: MessageType -> String
$cshowList :: [MessageType] -> ShowS
showList :: [MessageType] -> ShowS
Show, ReadPrec [MessageType]
ReadPrec MessageType
Int -> ReadS MessageType
ReadS [MessageType]
(Int -> ReadS MessageType)
-> ReadS [MessageType]
-> ReadPrec MessageType
-> ReadPrec [MessageType]
-> Read MessageType
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS MessageType
readsPrec :: Int -> ReadS MessageType
$creadList :: ReadS [MessageType]
readList :: ReadS [MessageType]
$creadPrec :: ReadPrec MessageType
readPrec :: ReadPrec MessageType
$creadListPrec :: ReadPrec [MessageType]
readListPrec :: ReadPrec [MessageType]
Read, MessageType -> MessageType -> Bool
(MessageType -> MessageType -> Bool)
-> (MessageType -> MessageType -> Bool) -> Eq MessageType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MessageType -> MessageType -> Bool
== :: MessageType -> MessageType -> Bool
$c/= :: MessageType -> MessageType -> Bool
/= :: MessageType -> MessageType -> Bool
Eq, Eq MessageType
Eq MessageType =>
(MessageType -> MessageType -> Ordering)
-> (MessageType -> MessageType -> Bool)
-> (MessageType -> MessageType -> Bool)
-> (MessageType -> MessageType -> Bool)
-> (MessageType -> MessageType -> Bool)
-> (MessageType -> MessageType -> MessageType)
-> (MessageType -> MessageType -> MessageType)
-> Ord MessageType
MessageType -> MessageType -> Bool
MessageType -> MessageType -> Ordering
MessageType -> MessageType -> MessageType
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
$ccompare :: MessageType -> MessageType -> Ordering
compare :: MessageType -> MessageType -> Ordering
$c< :: MessageType -> MessageType -> Bool
< :: MessageType -> MessageType -> Bool
$c<= :: MessageType -> MessageType -> Bool
<= :: MessageType -> MessageType -> Bool
$c> :: MessageType -> MessageType -> Bool
> :: MessageType -> MessageType -> Bool
$c>= :: MessageType -> MessageType -> Bool
>= :: MessageType -> MessageType -> Bool
$cmax :: MessageType -> MessageType -> MessageType
max :: MessageType -> MessageType -> MessageType
$cmin :: MessageType -> MessageType -> MessageType
min :: MessageType -> MessageType -> MessageType
Ord, Int -> MessageType
MessageType -> Int
MessageType -> [MessageType]
MessageType -> MessageType
MessageType -> MessageType -> [MessageType]
MessageType -> MessageType -> MessageType -> [MessageType]
(MessageType -> MessageType)
-> (MessageType -> MessageType)
-> (Int -> MessageType)
-> (MessageType -> Int)
-> (MessageType -> [MessageType])
-> (MessageType -> MessageType -> [MessageType])
-> (MessageType -> MessageType -> [MessageType])
-> (MessageType -> MessageType -> MessageType -> [MessageType])
-> Enum MessageType
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: MessageType -> MessageType
succ :: MessageType -> MessageType
$cpred :: MessageType -> MessageType
pred :: MessageType -> MessageType
$ctoEnum :: Int -> MessageType
toEnum :: Int -> MessageType
$cfromEnum :: MessageType -> Int
fromEnum :: MessageType -> Int
$cenumFrom :: MessageType -> [MessageType]
enumFrom :: MessageType -> [MessageType]
$cenumFromThen :: MessageType -> MessageType -> [MessageType]
enumFromThen :: MessageType -> MessageType -> [MessageType]
$cenumFromTo :: MessageType -> MessageType -> [MessageType]
enumFromTo :: MessageType -> MessageType -> [MessageType]
$cenumFromThenTo :: MessageType -> MessageType -> MessageType -> [MessageType]
enumFromThenTo :: MessageType -> MessageType -> MessageType -> [MessageType]
Enum, MessageType
MessageType -> MessageType -> Bounded MessageType
forall a. a -> a -> Bounded a
$cminBound :: MessageType
minBound :: MessageType
$cmaxBound :: MessageType
maxBound :: MessageType
Bounded)

data Message ann = Message {forall ann. Message ann -> MessageType
_messageType :: MessageType, forall ann. Message ann -> Doc ann
_message :: Doc ann}
  deriving (Int -> Message ann -> ShowS
[Message ann] -> ShowS
Message ann -> String
(Int -> Message ann -> ShowS)
-> (Message ann -> String)
-> ([Message ann] -> ShowS)
-> Show (Message ann)
forall ann. Int -> Message ann -> ShowS
forall ann. [Message ann] -> ShowS
forall ann. Message ann -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall ann. Int -> Message ann -> ShowS
showsPrec :: Int -> Message ann -> ShowS
$cshow :: forall ann. Message ann -> String
show :: Message ann -> String
$cshowList :: forall ann. [Message ann] -> ShowS
showList :: [Message ann] -> ShowS
Show)

makeLenses ''Message

handleMsg :: Member (Embed IO) r => (Message ann -> Bool) -> Message ann -> Sem r ()
handleMsg :: forall (r :: EffectRow) ann.
Member (Embed IO) r =>
(Message ann -> Bool) -> Message ann -> Sem r ()
handleMsg Message ann -> Bool
p Message ann
m = Bool -> Sem r () -> Sem r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Message ann -> Bool
p Message ann
m) (Sem r () -> Sem r ()) -> Sem r () -> Sem r ()
forall a b. (a -> b) -> a -> b
$ Message ann -> Sem r ()
forall (r :: EffectRow) ann.
Member (Embed IO) r =>
Message ann -> Sem r ()
printMsg Message ann
m

printMsg :: Member (Embed IO) r => Message ann -> Sem r ()
printMsg :: forall (r :: EffectRow) ann.
Member (Embed IO) r =>
Message ann -> Sem r ()
printMsg (Message MessageType
_ Doc ann
m) = IO () -> Sem r ()
forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed (IO () -> Sem r ()) -> IO () -> Sem r ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (Doc ann -> String
forall ann. Doc ann -> String
renderDoc' Doc ann
m)

msg :: Member (Output (Message ann)) r => MessageType -> Sem r (Doc ann) -> Sem r ()
msg :: forall ann (r :: EffectRow).
Member (Output (Message ann)) r =>
MessageType -> Sem r (Doc ann) -> Sem r ()
msg MessageType
typ Sem r (Doc ann)
m = Sem r (Doc ann)
m Sem r (Doc ann) -> (Doc ann -> Sem r ()) -> Sem r ()
forall a b. Sem r a -> (a -> Sem r b) -> Sem r b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Message ann -> Sem r ()
forall o (r :: EffectRow). Member (Output o) r => o -> Sem r ()
output (Message ann -> Sem r ())
-> (Doc ann -> Message ann) -> Doc ann -> Sem r ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MessageType -> Doc ann -> Message ann
forall ann. MessageType -> Doc ann -> Message ann
Message MessageType
typ

info :: Member (Output (Message ann)) r => Sem r (Doc ann) -> Sem r ()
info :: forall ann (r :: EffectRow).
Member (Output (Message ann)) r =>
Sem r (Doc ann) -> Sem r ()
info = MessageType -> Sem r (Doc ann) -> Sem r ()
forall ann (r :: EffectRow).
Member (Output (Message ann)) r =>
MessageType -> Sem r (Doc ann) -> Sem r ()
msg MessageType
Info

infoPretty :: (Member (Output (Message ann)) r, Pretty t) => t -> Sem r ()
infoPretty :: forall ann (r :: EffectRow) t.
(Member (Output (Message ann)) r, Pretty t) =>
t -> Sem r ()
infoPretty = Sem r (Doc ann) -> Sem r ()
forall ann (r :: EffectRow).
Member (Output (Message ann)) r =>
Sem r (Doc ann) -> Sem r ()
info (Sem r (Doc ann) -> Sem r ())
-> (t -> Sem r (Doc ann)) -> t -> Sem r ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> Sem r (Doc ann)
forall t (r :: EffectRow) ann. Pretty t => t -> Sem r (Doc ann)
pretty'

warn :: Member (Output (Message ann)) r => Sem r (Doc ann) -> Sem r ()
warn :: forall ann (r :: EffectRow).
Member (Output (Message ann)) r =>
Sem r (Doc ann) -> Sem r ()
warn = MessageType -> Sem r (Doc ann) -> Sem r ()
forall ann (r :: EffectRow).
Member (Output (Message ann)) r =>
MessageType -> Sem r (Doc ann) -> Sem r ()
msg MessageType
Warning

debug :: Member (Output (Message ann)) r => Sem r (Doc ann) -> Sem r ()
debug :: forall ann (r :: EffectRow).
Member (Output (Message ann)) r =>
Sem r (Doc ann) -> Sem r ()
debug = MessageType -> Sem r (Doc ann) -> Sem r ()
forall ann (r :: EffectRow).
Member (Output (Message ann)) r =>
MessageType -> Sem r (Doc ann) -> Sem r ()
msg MessageType
Debug

debugPretty :: (Member (Output (Message ann)) r, Pretty t) => t -> Sem r ()
debugPretty :: forall ann (r :: EffectRow) t.
(Member (Output (Message ann)) r, Pretty t) =>
t -> Sem r ()
debugPretty = Sem r (Doc ann) -> Sem r ()
forall ann (r :: EffectRow).
Member (Output (Message ann)) r =>
Sem r (Doc ann) -> Sem r ()
debug (Sem r (Doc ann) -> Sem r ())
-> (t -> Sem r (Doc ann)) -> t -> Sem r ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> Sem r (Doc ann)
forall t (r :: EffectRow) ann. Pretty t => t -> Sem r (Doc ann)
pretty'

err :: Member (Output (Message ann)) r => Sem r (Doc ann) -> Sem r ()
err :: forall ann (r :: EffectRow).
Member (Output (Message ann)) r =>
Sem r (Doc ann) -> Sem r ()
err = MessageType -> Sem r (Doc ann) -> Sem r ()
forall ann (r :: EffectRow).
Member (Output (Message ann)) r =>
MessageType -> Sem r (Doc ann) -> Sem r ()
msg MessageType
ErrMsg