{-# 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, App(..))
import           Hcompta.Model.Amount (Amount, Unit)

import qualified Hcompta.Format.Ledger.Write as Ledger.Write
import qualified Hcompta.CLI.Lib.Shakespeare.Leijen as I18N

I18N.mkMessage "App" "i18n" ("en")

instance I18N.ToMessage Unit where
	toMessage = Ledger.Write.unit
instance I18N.ToMessage Amount where
	toMessage = Ledger.Write.amount

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.renderMessage App (Context.langs context) I18N_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