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, App(..))
  18 import           Hcompta.Model.Amount (Amount, Unit)
  19
  20 import qualified Hcompta.Format.Ledger.Write as Ledger.Write
  21 import qualified Hcompta.CLI.Lib.Shakespeare.Leijen as I18N
  22
  23 I18N.mkMessage "App" "i18n" ("en")
  24
  25 instance I18N.ToMessage Unit where
  26         toMessage = Ledger.Write.unit
  27 instance I18N.ToMessage Amount where
  28         toMessage = Ledger.Write.amount
  29
  30 with_color :: Context -> IO.Handle -> IO Bool
  31 with_color context h =
  32         case Context.color context of
  33          Nothing -> IO.hIsTerminalDevice h
  34          Just b -> return b
  35
  36 debug :: Context -> String -> IO ()
  37 debug context msg = do
  38         case Context.verbosity context of
  39          v | v >= Context.Verbosity_Debug -> do
  40                 color <- with_color context IO.stderr
  41                 when color $
  42                         ANSI.hSetSGR IO.stderr [ANSI.SetColor ANSI.Foreground ANSI.Dull ANSI.Magenta]
  43                 IO.hPutStr IO.stderr "DEBUG"
  44                 when color $
  45                         ANSI.hSetSGR IO.stderr [ANSI.Reset]
  46                 IO.hPutStr IO.stderr $ concat [": ", msg, "\n"]
  47          _ -> return ()
  48
  49 error :: ToDoc Context d => Context -> d -> IO ()
  50 error context msg = do
  51         case Context.verbosity context of
  52          v | v >= Context.Verbosity_Error -> do
  53                 color <- with_color context IO.stderr
  54                 when color $
  55                         ANSI.hSetSGR IO.stderr
  56                          [ANSI.SetColor ANSI.Foreground ANSI.Dull ANSI.Red]
  57                 W.hPutDoc IO.stderr $
  58                         I18N.renderMessage App (Context.langs context) I18N_ERROR
  59                 when color $
  60                         ANSI.hSetSGR IO.stderr [ANSI.Reset]
  61                 let doc = toDoc context msg
  62                 W.hPutDoc IO.stderr $
  63                         W.string ":" <> W.space <> doc <> W.line
  64          _ -> return ()
  65
  66 fatal :: ToDoc Context d => Context -> d -> IO a
  67 fatal context msg = do
  68         Hcompta.CLI.Write.error context msg
  69         exitWith $ ExitFailure 1