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 (when)
   9 import qualified System.IO as IO
  10 import qualified System.Console.ANSI as ANSI
  11 import           System.Exit (exitWith, ExitCode(..))
  12
  13 import qualified Hcompta.Lib.Leijen as W
  14 import           Hcompta.Lib.Leijen ((<>), ToDoc(..))
  15 import qualified Hcompta.CLI.Context as Context
  16 import           Hcompta.CLI.Context (Context)
  17 import qualified Hcompta.CLI.Lang as Lang
  18 import           Hcompta.CLI.Lang (Lang)
  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 Lang 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                         toDoc (Context.lang context) Lang.Message_ERROR
  49                 when color $
  50                         ANSI.hSetSGR IO.stderr [ANSI.Reset]
  51                 let doc = toDoc (Context.lang context) msg
  52                 W.hPutDoc IO.stderr $
  53                         W.string ":" <> W.space <> doc <> W.line
  54          _ -> return ()
  55
  56 fatal :: ToDoc Lang d => Context -> d -> IO a
  57 fatal context msg = do
  58         Hcompta.CLI.Write.error context msg
  59         exitWith $ ExitFailure 1