cli/Hcompta/CLI/Write.hs

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