{-|
Copyright        : (c) Galois, Inc. 2025
Maintainer       : Langston Barrett <langston@galois.com>
-}

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE OverloadedStrings #-}

module Lang.Crucible.Debug.Outputs
  ( Outputs
  , send
  , lift
  , accumulate
  , hPutStrLn
  , pretty
  , defaultDebuggerOutputs
  ) where

import Data.Functor.Contravariant (Contravariant(..))
import Data.IORef (IORef)
import Data.IORef qualified as IORef
import Data.Text (Text)
import Data.Text.IO qualified as IO
import Lang.Crucible.Debug.Response (Response, ResponseExt)
import Prettyprinter qualified as PP
import Prettyprinter.Render.Text qualified as PP
import System.IO (Handle, stdout)

newtype Outputs m a = Outputs { forall (m :: * -> *) a. Outputs m a -> a -> m ()
send :: a -> m () }

instance Contravariant (Outputs m) where
  contramap :: forall a' a. (a' -> a) -> Outputs m a -> Outputs m a'
contramap a' -> a
f (Outputs a -> m ()
o) = (a' -> m ()) -> Outputs m a'
forall (m :: * -> *) a. (a -> m ()) -> Outputs m a
Outputs (a -> m ()
o (a -> m ()) -> (a' -> a) -> a' -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a' -> a
f)

lift :: (n () -> m ()) -> Outputs n a -> Outputs m a
lift :: forall (n :: * -> *) (m :: * -> *) a.
(n () -> m ()) -> Outputs n a -> Outputs m a
lift n () -> m ()
f (Outputs a -> n ()
s) = (a -> m ()) -> Outputs m a
forall (m :: * -> *) a. (a -> m ()) -> Outputs m a
Outputs (n () -> m ()
f (n () -> m ()) -> (a -> n ()) -> a -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> n ()
s)

accumulate :: IORef [a] -> Outputs IO a
accumulate :: forall a. IORef [a] -> Outputs IO a
accumulate IORef [a]
r = (a -> IO ()) -> Outputs IO a
forall (m :: * -> *) a. (a -> m ()) -> Outputs m a
Outputs (IORef [a] -> ([a] -> [a]) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
IORef.modifyIORef IORef [a]
r (([a] -> [a]) -> IO ()) -> (a -> [a] -> [a]) -> a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (:))

hPutStrLn :: Handle -> Outputs IO Text
hPutStrLn :: Handle -> Outputs IO Text
hPutStrLn Handle
hOut = (Text -> IO ()) -> Outputs IO Text
forall (m :: * -> *) a. (a -> m ()) -> Outputs m a
Outputs (Handle -> Text -> IO ()
IO.hPutStrLn Handle
hOut)

pretty ::
  PP.Pretty a =>
  Handle ->
  PP.LayoutOptions ->
  Outputs IO a
pretty :: forall a. Pretty a => Handle -> LayoutOptions -> Outputs IO a
pretty Handle
hOut LayoutOptions
opts =
  (a -> IO ()) -> Outputs IO a
forall (m :: * -> *) a. (a -> m ()) -> Outputs m a
Outputs (Handle -> SimpleDocStream Any -> IO ()
forall ann. Handle -> SimpleDocStream ann -> IO ()
PP.renderIO Handle
hOut (SimpleDocStream Any -> IO ())
-> (a -> SimpleDocStream Any) -> a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LayoutOptions -> Doc Any -> SimpleDocStream Any
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
PP.layoutPretty LayoutOptions
opts (Doc Any -> SimpleDocStream Any)
-> (a -> Doc Any) -> a -> SimpleDocStream Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Doc Any -> Doc Any -> Doc Any
forall a. Semigroup a => a -> a -> a
PP.<> Doc Any
"\n") (Doc Any -> Doc Any) -> (a -> Doc Any) -> a -> Doc Any
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Doc Any
forall ann. a -> Doc ann
forall a ann. Pretty a => a -> Doc ann
PP.pretty)

defaultDebuggerOutputs ::
  PP.Pretty cExt =>
  PP.Pretty (ResponseExt cExt) =>
  Outputs IO (Response cExt)
defaultDebuggerOutputs :: forall cExt.
(Pretty cExt, Pretty (ResponseExt cExt)) =>
Outputs IO (Response cExt)
defaultDebuggerOutputs = Handle -> LayoutOptions -> Outputs IO (Response cExt)
forall a. Pretty a => Handle -> LayoutOptions -> Outputs IO a
pretty Handle
stdout LayoutOptions
PP.defaultLayoutOptions