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

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

makeLenses ''Message

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

printMsg :: Member (Embed IO) r => Message -> Sem r ()
printMsg :: Message -> Sem r ()
printMsg (Message MessageType
_ Doc
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 -> String
renderDoc' Doc
m)

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

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

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

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

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

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

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