-- |Data structures related to logging and notifying the user
module Ribosome.Host.Data.Report where

import qualified Data.Text as Text
import Exon (exon)
import Fcf (Pure1, type (@@))
import Fcf.Class.Functor (FMap)
import Polysemy.Log (Severity (Error))
import Prelude hiding (tag)
import Text.Show (showParen, showsPrec)

-- |The provenance of a report, for use in logs.
newtype ReportContext =
  ReportContext { ReportContext -> [Text]
unReportContext :: [Text] }
  deriving stock (ReportContext -> ReportContext -> Bool
(ReportContext -> ReportContext -> Bool)
-> (ReportContext -> ReportContext -> Bool) -> Eq ReportContext
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ReportContext -> ReportContext -> Bool
$c/= :: ReportContext -> ReportContext -> Bool
== :: ReportContext -> ReportContext -> Bool
$c== :: ReportContext -> ReportContext -> Bool
Eq, Int -> ReportContext -> ShowS
[ReportContext] -> ShowS
ReportContext -> String
(Int -> ReportContext -> ShowS)
-> (ReportContext -> String)
-> ([ReportContext] -> ShowS)
-> Show ReportContext
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ReportContext] -> ShowS
$cshowList :: [ReportContext] -> ShowS
show :: ReportContext -> String
$cshow :: ReportContext -> String
showsPrec :: Int -> ReportContext -> ShowS
$cshowsPrec :: Int -> ReportContext -> ShowS
Show)
  deriving newtype (Eq ReportContext
Eq ReportContext
-> (ReportContext -> ReportContext -> Ordering)
-> (ReportContext -> ReportContext -> Bool)
-> (ReportContext -> ReportContext -> Bool)
-> (ReportContext -> ReportContext -> Bool)
-> (ReportContext -> ReportContext -> Bool)
-> (ReportContext -> ReportContext -> ReportContext)
-> (ReportContext -> ReportContext -> ReportContext)
-> Ord ReportContext
ReportContext -> ReportContext -> Bool
ReportContext -> ReportContext -> Ordering
ReportContext -> ReportContext -> ReportContext
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 :: ReportContext -> ReportContext -> ReportContext
$cmin :: ReportContext -> ReportContext -> ReportContext
max :: ReportContext -> ReportContext -> ReportContext
$cmax :: ReportContext -> ReportContext -> ReportContext
>= :: ReportContext -> ReportContext -> Bool
$c>= :: ReportContext -> ReportContext -> Bool
> :: ReportContext -> ReportContext -> Bool
$c> :: ReportContext -> ReportContext -> Bool
<= :: ReportContext -> ReportContext -> Bool
$c<= :: ReportContext -> ReportContext -> Bool
< :: ReportContext -> ReportContext -> Bool
$c< :: ReportContext -> ReportContext -> Bool
compare :: ReportContext -> ReportContext -> Ordering
$ccompare :: ReportContext -> ReportContext -> Ordering
Ord, NonEmpty ReportContext -> ReportContext
ReportContext -> ReportContext -> ReportContext
(ReportContext -> ReportContext -> ReportContext)
-> (NonEmpty ReportContext -> ReportContext)
-> (forall b. Integral b => b -> ReportContext -> ReportContext)
-> Semigroup ReportContext
forall b. Integral b => b -> ReportContext -> ReportContext
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: forall b. Integral b => b -> ReportContext -> ReportContext
$cstimes :: forall b. Integral b => b -> ReportContext -> ReportContext
sconcat :: NonEmpty ReportContext -> ReportContext
$csconcat :: NonEmpty ReportContext -> ReportContext
<> :: ReportContext -> ReportContext -> ReportContext
$c<> :: ReportContext -> ReportContext -> ReportContext
Semigroup, Semigroup ReportContext
ReportContext
Semigroup ReportContext
-> ReportContext
-> (ReportContext -> ReportContext -> ReportContext)
-> ([ReportContext] -> ReportContext)
-> Monoid ReportContext
[ReportContext] -> ReportContext
ReportContext -> ReportContext -> ReportContext
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [ReportContext] -> ReportContext
$cmconcat :: [ReportContext] -> ReportContext
mappend :: ReportContext -> ReportContext -> ReportContext
$cmappend :: ReportContext -> ReportContext -> ReportContext
mempty :: ReportContext
$cmempty :: ReportContext
Monoid)

-- |Render a 'ReportContext' by interspersing it with dots, returning 'Nothing' if it is empty.
reportContext' :: ReportContext -> Maybe Text
reportContext' :: ReportContext -> Maybe Text
reportContext' = \case
  ReportContext [] -> Maybe Text
forall a. Maybe a
Nothing
  ReportContext [Text]
c -> Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> [Text] -> Text
Text.intercalate Text
"." [Text]
c)

-- |Render a 'ReportContext' by interspersing it with dots, followed by a colon, returning 'Nothing' if it is empty.
prefixReportContext' :: ReportContext -> Maybe Text
prefixReportContext' :: ReportContext -> Maybe Text
prefixReportContext' ReportContext
c =
  (Text -> Char -> Text) -> Char -> Text -> Text
forall a b c. (a -> b -> c) -> b -> a -> c
flip Text -> Char -> Text
Text.snoc Char
':' (Text -> Text) -> Maybe Text -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReportContext -> Maybe Text
reportContext' ReportContext
c

-- |Render a 'ReportContext' by interspersing it with dots, using @global@ if it is empty.
reportContext :: ReportContext -> Text
reportContext :: ReportContext -> Text
reportContext ReportContext
c =
  Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"global" (ReportContext -> Maybe Text
reportContext' ReportContext
c)

-- |Render a 'ReportContext' by interspersing it with dots, followed by a colon, using @global@ if it is empty.
prefixReportContext :: ReportContext -> Text
prefixReportContext :: ReportContext -> Text
prefixReportContext ReportContext
c =
  Text -> Char -> Text
Text.snoc (ReportContext -> Text
reportContext ReportContext
c) Char
':'

instance IsString ReportContext where
  fromString :: String -> ReportContext
fromString =
    [Text] -> ReportContext
ReportContext ([Text] -> ReportContext)
-> (String -> [Text]) -> String -> ReportContext
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> [Text]) -> (String -> Text) -> String -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
forall a. ToText a => a -> Text
toText

-- |An report with different messages intended to be sent to Neovim and the log, respectively.
--
-- Used by request handlers and expected by the RPC dispatcher.
--
-- Also contains the 'Severity' of the report, or minimum log level, which determines whether the report should be
-- logged and echoed in Neovim, and what kind of highlighting should be used in Neovim (red for errors, orange for
-- warnings, none for infomrational errors).
--
-- The log message may span multiple lines.
data Report where
  Report :: HasCallStack => {
    Report -> Text
user :: !Text,
    Report -> [Text]
log :: ![Text],
    Report -> Severity
severity :: !Severity
  } -> Report

instance Show Report where
  showsPrec :: Int -> Report -> ShowS
showsPrec Int
d Report {[Text]
Text
Severity
severity :: Severity
log :: [Text]
user :: Text
$sel:severity:Report :: Report -> Severity
$sel:log:Report :: Report -> [Text]
$sel:user:Report :: Report -> Text
..} =
    Bool -> ShowS -> ShowS
showParen (Int
d Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10)
    [exon|LogReport { user = #{showsPrec 11 user}, log = #{showsPrec 11 log}, severity = #{showsPrec 11 severity} }|]

instance IsString Report where
  fromString :: String -> Report
fromString (String -> Text
forall a. ToText a => a -> Text
toText -> Text
s) =
    HasCallStack => Text -> [Text] -> Severity -> Report
Text -> [Text] -> Severity -> Report
Report Text
s [Text
Item [Text]
s] Severity
Error

-- |The type used by request handlers and expected by the RPC dispatcher.
data LogReport =
  LogReport {
    -- |The report
    LogReport -> Report
report :: Report,
    -- |Indicates whether this report may be echoed in Neovim
    LogReport -> Bool
echo :: Bool,
    -- |Indicates whether to store this report in the state of 'Ribosome.Reports'
    LogReport -> Bool
store :: Bool,
    -- |A list of prefixes used for log messages
    LogReport -> ReportContext
context :: ReportContext
  }
  deriving stock (Int -> LogReport -> ShowS
[LogReport] -> ShowS
LogReport -> String
(Int -> LogReport -> ShowS)
-> (LogReport -> String)
-> ([LogReport] -> ShowS)
-> Show LogReport
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LogReport] -> ShowS
$cshowList :: [LogReport] -> ShowS
show :: LogReport -> String
$cshow :: LogReport -> String
showsPrec :: Int -> LogReport -> ShowS
$cshowsPrec :: Int -> LogReport -> ShowS
Show, (forall x. LogReport -> Rep LogReport x)
-> (forall x. Rep LogReport x -> LogReport) -> Generic LogReport
forall x. Rep LogReport x -> LogReport
forall x. LogReport -> Rep LogReport x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep LogReport x -> LogReport
$cfrom :: forall x. LogReport -> Rep LogReport x
Generic)

-- |Construct a 'LogReport' error from a single 'Text'.
simple ::
  HasCallStack =>
  Text ->
  LogReport
simple :: HasCallStack => Text -> LogReport
simple Text
msg =
  (HasCallStack => LogReport) -> LogReport
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack do
    Report -> Bool -> Bool -> ReportContext -> LogReport
LogReport (HasCallStack => Text -> [Text] -> Severity -> Report
Text -> [Text] -> Severity -> Report
Report Text
msg [Text
Item [Text]
msg] Severity
Error) Bool
True Bool
True ReportContext
forall a. Monoid a => a
mempty

-- |Stop with a 'LogReport'.
basicReport ::
  Member (Stop Report) r =>
  HasCallStack =>
  Text ->
  [Text] ->
  Sem r a
basicReport :: forall (r :: EffectRow) a.
(Member (Stop Report) r, HasCallStack) =>
Text -> [Text] -> Sem r a
basicReport Text
user [Text]
log =
  (HasCallStack => Sem r a) -> Sem r a
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack do
    Report -> Sem r a
forall e (r :: EffectRow) a. Member (Stop e) r => e -> Sem r a
stop (HasCallStack => Text -> [Text] -> Severity -> Report
Text -> [Text] -> Severity -> Report
Report Text
user [Text]
log Severity
Error)

instance IsString LogReport where
  fromString :: HasCallStack => String -> LogReport
  fromString :: HasCallStack => String -> LogReport
fromString (String -> Text
forall a. ToText a => a -> Text
toText -> Text
msg) =
    (HasCallStack => LogReport) -> LogReport
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack do
      Report -> Bool -> Bool -> ReportContext -> LogReport
LogReport (HasCallStack => Text -> [Text] -> Severity -> Report
Text -> [Text] -> Severity -> Report
Report Text
msg [Text
Item [Text]
msg] Severity
Error) Bool
True Bool
True ReportContext
forall a. Monoid a => a
mempty

-- |The class of types that are convertible to a 'Report'.
--
-- This is used to create a uniform format for handlers, since control flow is passed on to the internal machinery when
-- they return.
-- If an error would be thrown that is not caught by the request dispatcher, the entire plugin would stop, so all 'Stop'
-- and 'Resumable' effects need to be converted to 'Report' before returning (see [Errors]("Ribosome#g:errors")).
--
-- The combinators associated with this class make this task a little less arduous:
--
-- > data NumbersError = InvalidNumber
-- >
-- > instance Reportable NumbersError where
-- >   toReport InvalidNumber = Report "Invalid number!" ["The user entered an invalid number"] Warn
-- >
-- > count :: Int -> Sem r Int
-- > count i =
-- >   resumeReport @Rpc $ mapReport @NumbersError do
-- >     when (i == 0) (stop InvalidNumber)
-- >     nvimGetVar ("number_" <> show i)
--
-- Here 'resumeReport' converts a potential 'RpcError' from 'Ribosome.Api.nvimGetVar' to 'Report' (e.g. if the variable
-- is not set), while 'mapReport' uses the instance @'Reportable' 'NumbersError'@ to convert the call to 'stop'.
class Reportable e where
  toReport :: e -> Report

instance Reportable Report where
  toReport :: Report -> Report
toReport =
    Report -> Report
forall a. a -> a
id

instance Reportable Void where
  toReport :: Void -> Report
toReport = Void -> Report
\case

-- |Reinterpret @'Stop' err@ to @'Stop' 'Report'@ if @err@ is an instance of 'Reportable'.
mapReport ::
  ∀ e r a .
  Reportable e =>
  Member (Stop Report) r =>
  Sem (Stop e : r) a ->
  Sem r a
mapReport :: forall e (r :: EffectRow) a.
(Reportable e, Member (Stop Report) r) =>
Sem (Stop e : r) a -> Sem r a
mapReport =
  (e -> Report) -> Sem (Stop e : r) a -> Sem r a
forall e e' (r :: EffectRow) a.
Member (Stop e') r =>
(e -> e') -> Sem (Stop e : r) a -> Sem r a
mapStop e -> Report
forall e. Reportable e => e -> Report
toReport

type Stops errs =
  FMap (Pure1 Stop) Fcf.@@ errs

-- |Map multiple errors to 'Report'.
class MapReports (errs :: [Type]) (r :: EffectRow) where
  -- |Map multiple errors to 'Report'.
  -- This needs the errors specified as type applications.
  --
  -- > mapReports @[RpcError, SettingError]
  mapReports :: InterpretersFor (Stops errs) r

instance MapReports '[] r where
  mapReports :: InterpretersFor (Stops '[]) r
mapReports =
    Sem (Append (Stops '[]) r) a -> Sem r a
forall a. a -> a
id

instance (
    Reportable err,
    MapReports errs r,
    Member (Stop Report) (Stops errs ++ r)
  ) => MapReports (err : errs) r where
    mapReports :: InterpretersFor (Stops (err : errs)) r
mapReports =
      forall (errs :: [*]) (r :: EffectRow).
MapReports errs r =>
InterpretersFor (Stops errs) r
mapReports @errs (Sem (Stops errs ++ r) a -> Sem r a)
-> (Sem (Stop err : (Stops errs ++ r)) a
    -> Sem (Stops errs ++ r) a)
-> Sem (Stop err : (Stops errs ++ r)) a
-> Sem r a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (r :: EffectRow) a.
(Reportable e, Member (Stop Report) r) =>
Sem (Stop e : r) a -> Sem r a
mapReport @err

-- |Convert the effect @eff@ to @'Resumable' err eff@ and @'Stop' 'Report'@ if @err@ is an instance of 'Reportable'.
resumeReport ::
  ∀ eff e r a .
  Reportable e =>
  Members [eff !! e, Stop Report] r =>
  Sem (eff : r) a ->
  Sem r a
resumeReport :: forall (eff :: (* -> *) -> * -> *) e (r :: EffectRow) a.
(Reportable e, Members '[eff !! e, Stop Report] r) =>
Sem (eff : r) a -> Sem r a
resumeReport =
  (e -> Report) -> Sem (eff : r) a -> Sem r a
forall err (eff :: (* -> *) -> * -> *) err' (r :: EffectRow) a.
Members '[Resumable err eff, Stop err'] r =>
(err -> err') -> Sem (eff : r) a -> Sem r a
resumeHoist e -> Report
forall e. Reportable e => e -> Report
toReport

-- |Resume multiple effects as 'Report's.
class ResumeReports (effs :: EffectRow) (errs :: [Type]) (r :: EffectRow) where
  -- |Resume multiple effects as 'Report's.
  -- This needs both effects and errors specified as type applications (though only the shape for the errors).
  --
  -- > resumeReports @[Rpc, Settings] @[_, _]
  resumeReports :: InterpretersFor effs r

instance ResumeReports '[] '[] r where
  resumeReports :: InterpretersFor '[] r
resumeReports =
    Sem (Append '[] r) a -> Sem r a
forall a. a -> a
id

instance (
    Reportable err,
    ResumeReports effs errs r,
    Members [eff !! err, Stop Report] (effs ++ r)
  ) => ResumeReports (eff : effs) (err : errs) r where
    resumeReports :: InterpretersFor (eff : effs) r
resumeReports =
      forall (effs :: EffectRow) (errs :: [*]) (r :: EffectRow).
ResumeReports effs errs r =>
InterpretersFor effs r
resumeReports @effs @errs (Sem (effs ++ r) a -> Sem r a)
-> (Sem (eff : (effs ++ r)) a -> Sem (effs ++ r) a)
-> Sem (eff : (effs ++ r)) a
-> Sem r a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (eff :: (* -> *) -> * -> *) e (r :: EffectRow) a.
(Reportable e, Members '[eff !! e, Stop Report] r) =>
Sem (eff : r) a -> Sem r a
resumeReport @eff @err

-- |Extract both user and log messages from an 'Report', for use in tests.
reportMessages :: Report -> Text
reportMessages :: Report -> Text
reportMessages Report {Text
user :: Text
$sel:user:Report :: Report -> Text
user, [Text]
log :: [Text]
$sel:log:Report :: Report -> [Text]
log} =
  [Text] -> Text
forall t. IsText t "unlines" => [t] -> t
unlines (Text
user Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
log)

-- |Extract the user message from an instance of 'Reportable'.
userReport ::
  ∀ e .
  Reportable e =>
  e ->
  Text
userReport :: forall e. Reportable e => e -> Text
userReport (e -> Report
forall e. Reportable e => e -> Report
toReport -> Report {Text
user :: Text
$sel:user:Report :: Report -> Text
user}) =
  Text
user

-- |Resume an effect with an error that's an instance of 'Reportable' by passing its user message to a function.
resumeHoistUserMessage ::
  ∀ err eff err' r .
  Reportable err =>
  Members [eff !! err, Stop err'] r =>
  (Text -> err') ->
  InterpreterFor eff r
resumeHoistUserMessage :: forall err (eff :: (* -> *) -> * -> *) err' (r :: EffectRow).
(Reportable err, Members '[eff !! err, Stop err'] r) =>
(Text -> err') -> InterpreterFor eff r
resumeHoistUserMessage Text -> err'
f =
  (err -> err') -> Sem (eff : r) a -> Sem r a
forall err (eff :: (* -> *) -> * -> *) err' (r :: EffectRow) a.
Members '[Resumable err eff, Stop err'] r =>
(err -> err') -> Sem (eff : r) a -> Sem r a
resumeHoist (Text -> err'
f (Text -> err') -> (err -> Text) -> err -> err'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. err -> Text
forall e. Reportable e => e -> Text
userReport)

-- |Map an error that's an instance of 'Reportable' by passing its user message to a function.
mapUserMessage ::
  ∀ err err' r .
  Reportable err =>
  Member (Stop err') r =>
  (Text -> err') ->
  InterpreterFor (Stop err) r
mapUserMessage :: forall err err' (r :: EffectRow).
(Reportable err, Member (Stop err') r) =>
(Text -> err') -> InterpreterFor (Stop err) r
mapUserMessage Text -> err'
f =
  (err -> err') -> Sem (Stop err : r) a -> Sem r a
forall e e' (r :: EffectRow) a.
Member (Stop e') r =>
(e -> e') -> Sem (Stop e : r) a -> Sem r a
mapStop (Text -> err'
f (Text -> err') -> (err -> Text) -> err -> err'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. err -> Text
forall e. Reportable e => e -> Text
userReport)

-- |Convert an error that's an instance of 'Reportable' to 'Fail', for use in tests.
stopReportToFail ::
  ∀ e r .
  Member Fail r =>
  Reportable e =>
  InterpreterFor (Stop e) r
stopReportToFail :: forall e (r :: EffectRow).
(Member Fail r, Reportable e) =>
InterpreterFor (Stop e) r
stopReportToFail =
  (e -> Sem r a) -> (a -> Sem r a) -> Either e a -> Sem r a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> Sem r a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Sem r a) -> (e -> String) -> e -> Sem r a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
forall a. ToString a => a -> String
toString (Text -> String) -> (e -> Text) -> e -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> Text
forall e. Reportable e => e -> Text
userReport) a -> Sem r a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either e a -> Sem r a)
-> (Sem (Stop e : r) a -> Sem r (Either e a))
-> Sem (Stop e : r) a
-> Sem r a
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Sem (Stop e : r) a -> Sem r (Either e a)
forall e (r :: EffectRow) a.
Sem (Stop e : r) a -> Sem r (Either e a)
runStop
{-# inline stopReportToFail #-}

-- |Resume an effect with an error that's an instance of 'Reportable' by reinterpreting to 'Fail', for use in tests.
resumeReportFail ::
  ∀ eff err r .
  Members [Fail, eff !! err] r =>
  Reportable err =>
  InterpreterFor eff r
resumeReportFail :: forall (eff :: (* -> *) -> * -> *) err (r :: EffectRow).
(Members '[Fail, eff !! err] r, Reportable err) =>
InterpreterFor eff r
resumeReportFail =
  (err -> Sem r a) -> Sem (eff : r) a -> Sem r a
forall err (eff :: (* -> *) -> * -> *) (r :: EffectRow) a.
Member (Resumable err eff) r =>
(err -> Sem r a) -> Sem (eff : r) a -> Sem r a
resuming (String -> Sem r a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Sem r a) -> (err -> String) -> err -> Sem r a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
forall a. ToString a => a -> String
toString (Text -> String) -> (err -> Text) -> err -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. err -> Text
forall e. Reportable e => e -> Text
userReport)
{-# inline resumeReportFail #-}