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

import           Control.Monad (Monad(..), when)
import           Data.Bool
import           Data.Eq (Eq)
import           Data.Foldable (forM_)
import           Data.List (concat)
import           Data.Maybe (Maybe(..))
import           Data.Ord (Ord(..))
import           Data.String (String)
import           Prelude (($), Bounded(..), IO)
import qualified System.Console.ANSI as ANSI
import           System.Exit (exitWith, ExitCode(..))
import qualified System.IO as IO
import           Text.Show (Show)

import qualified Hcompta.CLI.Context as C
import qualified Hcompta.CLI.Lang as Lang
import           Hcompta.Lib.Leijen ((<>))
import qualified Hcompta.Lib.Leijen as W

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

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

error :: Lang.Translate msg W.Doc => C.Context -> msg -> IO ()
error c msg = do
	case C.verbosity c of
	 v | v >= C.Verbosity_Error -> do
		color <- with_color c IO.stderr
		when color $ ANSI.hSetSGR IO.stderr
		 [ANSI.SetColor ANSI.Foreground ANSI.Dull ANSI.Red]
		W.hPutDoc IO.stderr $ C.translate c Lang.Write_Error
		when color $ ANSI.hSetSGR IO.stderr [ANSI.Reset]
		W.hPutDoc IO.stderr $
			W.string ":" <> W.space <> C.translate c msg <> W.line
	 _ -> return ()

fatal :: Lang.Translate msg W.Doc => C.Context -> msg -> IO a
fatal c msg = do
	error c msg
	exitWith $ ExitFailure 1

data Mode
 =   Mode_Over
 |   Mode_Append
 deriving (Eq, Show)
data Style
 = Style
 { style_pretty :: Bool
 }
 deriving (Eq, Show)

style :: Style
style =
	Style
	 { style_pretty = True
	 }

write :: C.Context -> Style -> [(Mode, IO.FilePath)] -> W.Doc -> IO ()
write context sty files doc = do
	let out =
		if style_pretty sty
		then W.renderPretty  False 1.0 maxBound doc
		else W.renderCompact False doc
	let out_colored =
		if style_pretty sty
		then W.renderPretty  True 1.0 maxBound doc
		else W.renderCompact True doc
	let wrt h = do
		color <- with_color context h
		case color of
		 True  -> W.displayIO h out_colored
		 False -> W.displayIO h out
	Data.Foldable.forM_ files $ \(mode, path) ->
		case path of
		 "-" -> wrt IO.stdout
		 _ ->
			IO.withFile path
			 (case mode of
				 Mode_Over   -> IO.WriteMode
				 Mode_Append -> IO.AppendMode)
			 wrt