{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Hcompta.CLI.Write where

import           Control.Monad (when)
import qualified System.IO as IO
import qualified System.Console.ANSI as ANSI
import           System.Exit (exitWith, ExitCode(..))

import qualified Hcompta.Lib.Leijen as W
import           Hcompta.Lib.Leijen ((<>), ToDoc(..))
import qualified Hcompta.CLI.Context as Context
import           Hcompta.CLI.Context (Context)
import qualified Hcompta.CLI.I18N as I18N

with_color :: Context -> IO.Handle -> IO Bool
with_color context h =
	case Context.color context of
	 Nothing -> IO.hIsTerminalDevice h
	 Just b -> return b

debug :: Context -> String -> IO ()
debug context msg = do
	case Context.verbosity context of
	 v | v >= Context.Verbosity_Debug -> do
		color <- with_color context IO.stderr
		when color $
			ANSI.hSetSGR IO.stderr [ANSI.SetColor ANSI.Foreground ANSI.Dull ANSI.Magenta]
		IO.hPutStr IO.stderr "DEBUG"
		when color $
			ANSI.hSetSGR IO.stderr [ANSI.Reset]
		IO.hPutStr IO.stderr $ concat [": ", msg, "\n"]
	 _ -> return ()

error :: ToDoc Context d => Context -> d -> IO ()
error context msg = do
	case Context.verbosity context of
	 v | v >= Context.Verbosity_Error -> do
		color <- with_color context IO.stderr
		when color $
			ANSI.hSetSGR IO.stderr
			 [ANSI.SetColor ANSI.Foreground ANSI.Dull ANSI.Red]
		W.hPutDoc IO.stderr $
			I18N.render (Context.langs context) I18N.Message_ERROR
		when color $
			ANSI.hSetSGR IO.stderr [ANSI.Reset]
		let doc = toDoc context msg
		W.hPutDoc IO.stderr $
			W.string ":" <> W.space <> doc <> W.line
	 _ -> return ()

fatal :: ToDoc Context d => Context -> d -> IO a
fatal context msg = do
	Hcompta.CLI.Write.error context msg
	exitWith $ ExitFailure 1