cli/Hcompta/CLI/Write.hs

   1 {-# LANGUAGE FlexibleContexts #-}
   2 {-# LANGUAGE FlexibleInstances #-}
   3 {-# LANGUAGE MultiParamTypeClasses #-}
   4 {-# LANGUAGE OverloadedStrings #-}
   5 {-# LANGUAGE TemplateHaskell #-}
   6 {-# OPTIONS_GHC -fno-warn-orphans #-}
   7 module Hcompta.CLI.Write where
   8
   9 import           Control.Monad (when)
  10 import qualified System.IO as IO
  11 import qualified System.Console.ANSI as ANSI
  12 import           System.Exit (exitWith, ExitCode(..))
  13
  14 import qualified Hcompta.Lib.Leijen as W
  15 import           Hcompta.Lib.Leijen ((<>), ToDoc(..))
  16 import qualified Hcompta.CLI.Context as Context
  17 import           Hcompta.CLI.Context (Context)
  18 import qualified Hcompta.CLI.I18N as I18N
  19
  20 with_color :: Context -> IO.Handle -> IO Bool
  21 with_color context h =
  22         case Context.color context of
  23          Nothing -> IO.hIsTerminalDevice h
  24          Just b -> return b
  25
  26 debug :: Context -> String -> IO ()
  27 debug context msg = do
  28         case Context.verbosity context of
  29          v | v >= Context.Verbosity_Debug -> do
  30                 color <- with_color context IO.stderr
  31                 when color $
  32                         ANSI.hSetSGR IO.stderr [ANSI.SetColor ANSI.Foreground ANSI.Dull ANSI.Magenta]
  33                 IO.hPutStr IO.stderr "DEBUG"
  34                 when color $
  35                         ANSI.hSetSGR IO.stderr [ANSI.Reset]
  36                 IO.hPutStr IO.stderr $ concat [": ", msg, "\n"]
  37          _ -> return ()
  38
  39 error :: ToDoc Context d => Context -> d -> IO ()
  40 error context msg = do
  41         case Context.verbosity context of
  42          v | v >= Context.Verbosity_Error -> do
  43                 color <- with_color context IO.stderr
  44                 when color $
  45                         ANSI.hSetSGR IO.stderr
  46                          [ANSI.SetColor ANSI.Foreground ANSI.Dull ANSI.Red]
  47                 W.hPutDoc IO.stderr $
  48                         I18N.render (Context.langs context) I18N.Message_ERROR
  49                 when color $
  50                         ANSI.hSetSGR IO.stderr [ANSI.Reset]
  51                 let doc = toDoc context msg
  52                 W.hPutDoc IO.stderr $
  53                         W.string ":" <> W.space <> doc <> W.line
  54          _ -> return ()
  55
  56 fatal :: ToDoc Context d => Context -> d -> IO a
  57 fatal context msg = do
  58         Hcompta.CLI.Write.error context msg
  59         exitWith $ ExitFailure 1