{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeOperators #-}
-- | Provides common functions for running Output-Monad within IO

module Control.OutputCapable.Blocks.Debug where

import qualified Data.Text                        as T (unpack)
import qualified Text.PrettyPrint.HughesPJClass   as HughesPJ (
  Pretty,
  pPrint,
  render,
  )
import qualified Text.PrettyPrint.Leijen.Text     as Leijen (
  Pretty,
  displayTStrict,
  pretty,
  renderPretty,
  )

import Control.OutputCapable.Blocks (
  GenericReportT,
  LangM',
  LangM,
  Language,
  )
import Control.OutputCapable.Blocks.Generic (
  runLangMReport,
  )

import Control.Monad                    (void, when)
import Control.Monad.Extra              (whenJust)
import Data.Maybe                       (isJust, isNothing)

showDescription
  :: (m ~ GenericReportT Language (IO ()) IO)
  => Language
  -> IO inst
  -> (inst -> LangM m)
  -> IO (Maybe ())
showDescription :: forall (m :: * -> *) inst.
(m ~ GenericReportT Language (IO ()) IO) =>
Language -> IO inst -> (inst -> LangM m) -> IO (Maybe ())
showDescription Language
language IO inst
generate inst -> LangM m
f = do
  inst
inst <- IO inst
generate
  Language -> LangM m -> IO (Maybe ())
forall (m :: * -> *) a.
(m ~ GenericReportT Language (IO ()) IO) =>
Language -> LangM' m a -> IO (Maybe a)
run Language
language (inst -> LangM m
f inst
inst)

data Display a where
  Manual :: (a -> String) -> Display a
  AutoHughesPJ :: HughesPJ.Pretty a => Display a
  AutoLeijen :: Leijen.Pretty a => Display a

display :: Display a -> a -> String
display :: forall a. Display a -> a -> String
display (Manual a -> String
f) = a -> String
f
display Display a
AutoHughesPJ = Doc -> String
HughesPJ.render (Doc -> String) -> (a -> Doc) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Doc
forall a. Pretty a => a -> Doc
HughesPJ.pPrint
display Display a
AutoLeijen = Text -> String
T.unpack
  (Text -> String) -> (a -> Text) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SimpleDoc -> Text
Leijen.displayTStrict
  (SimpleDoc -> Text) -> (a -> SimpleDoc) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> Int -> Doc -> SimpleDoc
Leijen.renderPretty Float
0.4 Int
80
  (Doc -> SimpleDoc) -> (a -> Doc) -> a -> SimpleDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Doc
forall a. Pretty a => a -> Doc
Leijen.pretty

testTask
  :: (m ~ GenericReportT Language (IO ()) IO, Show a, Show b, Show c, Show d)
  => Maybe (Display a)
  -> Language
  -> IO inst
  -> (inst -> LangM' m b)
  -> (inst -> a -> LangM' m c)
  -> (inst -> a -> LangM' m d)
  -> IO a
  -> IO ()
testTask :: forall (m :: * -> *) a b c d inst.
(m ~ GenericReportT Language (IO ()) IO, Show a, Show b, Show c,
 Show d) =>
Maybe (Display a)
-> Language
-> IO inst
-> (inst -> LangM' m b)
-> (inst -> a -> LangM' m c)
-> (inst -> a -> LangM' m d)
-> IO a
-> IO ()
testTask Maybe (Display a)
pretty Language
language IO inst
generate inst -> LangM' m b
f inst -> a -> LangM' m c
partial inst -> a -> LangM' m d
full IO a
getSubmission = do
  inst
inst <- IO inst
generate
  Maybe b
desc <- Language -> LangM' m b -> IO (Maybe b)
forall (m :: * -> *) a.
(m ~ GenericReportT Language (IO ()) IO) =>
Language -> LangM' m a -> IO (Maybe a)
run Language
language (inst -> LangM' m b
f inst
inst)
  Maybe b -> IO ()
forall a. Show a => a -> IO ()
print Maybe b
desc
  a
value <- IO a
getSubmission
  String -> IO ()
putStrLn String
"---- Input ----"
  a -> IO ()
forall a. Show a => a -> IO ()
print a
value
  Maybe (Display a) -> (Display a -> IO ()) -> IO ()
forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe (Display a)
pretty ((Display a -> IO ()) -> IO ()) -> (Display a -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Display a
displayMethod -> do
    String -> IO ()
putStrLn String
"---- Prettified Input ----"
    String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Display a -> a -> String
forall a. Display a -> a -> String
display Display a
displayMethod a
value
  String -> IO ()
putStrLn String
"---- Partial ----"
  Maybe c
partialRes <- Language -> LangM' m c -> IO (Maybe c)
forall (m :: * -> *) a.
(m ~ GenericReportT Language (IO ()) IO) =>
Language -> LangM' m a -> IO (Maybe a)
run Language
language (inst -> a -> LangM' m c
partial inst
inst a
value)
  Maybe c -> IO ()
forall a. Show a => a -> IO ()
print Maybe c
partialRes
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe c -> Bool
forall a. Maybe a -> Bool
isNothing Maybe c
partialRes)
    (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn String
"!!! The following would not be printed in Autotool !!!"
  String -> IO ()
putStrLn String
"---- Complete ----"
  Maybe d
completeRes <- Language -> LangM' m d -> IO (Maybe d)
forall (m :: * -> *) a.
(m ~ GenericReportT Language (IO ()) IO) =>
Language -> LangM' m a -> IO (Maybe a)
run Language
language (inst -> a -> LangM' m d
full inst
inst a
value)
  Maybe d -> IO ()
forall a. Show a => a -> IO ()
print Maybe d
completeRes

checkConfigWith
  :: (m ~ GenericReportT Language (IO ()) IO)
  => Language
  -> config
  -> (config -> LangM m)
  -> IO Bool
checkConfigWith :: forall (m :: * -> *) config.
(m ~ GenericReportT Language (IO ()) IO) =>
Language -> config -> (config -> LangM m) -> IO Bool
checkConfigWith Language
language config
conf config -> LangM m
check = Maybe () -> Bool
forall a. Maybe a -> Bool
isJust (Maybe () -> Bool) -> IO (Maybe ()) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Language -> LangM m -> IO (Maybe ())
forall (m :: * -> *) a.
(m ~ GenericReportT Language (IO ()) IO) =>
Language -> LangM' m a -> IO (Maybe a)
run Language
language (config -> LangM m
check config
conf)

run
  :: (m ~ GenericReportT Language (IO ()) IO)
  => Language
  -> LangM' m a
  -> IO (Maybe a)
run :: forall (m :: * -> *) a.
(m ~ GenericReportT Language (IO ()) IO) =>
Language -> LangM' m a -> IO (Maybe a)
run Language
language LangM' m a
thing = do
  (Maybe a
r, Language -> IO ()
sayThing) <- IO ()
-> (IO () -> IO () -> IO ())
-> GenericLangM Language (GenericReportT Language (IO ()) IO) a
-> IO (Maybe a, Language -> IO ())
forall (m :: * -> *) o l a.
Functor m =>
o
-> (o -> o -> o)
-> GenericLangM l (GenericReportT l o m) a
-> m (Maybe a, l -> o)
runLangMReport (() -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()) IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
(>>) LangM' m a
GenericLangM Language (GenericReportT Language (IO ()) IO) a
thing
  IO () -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Language -> IO ()
sayThing Language
language
  Maybe a -> IO (Maybe a)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
r