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.Lang as Lang
  19 import           Hcompta.CLI.Lang (Lang)
  20
  21 with_color :: Context -> IO.Handle -> IO Bool
  22 with_color context h =
  23         case Context.color context of
  24          Nothing -> IO.hIsTerminalDevice h
  25          Just b -> return b
  26
  27 debug :: Context -> String -> IO ()
  28 debug context msg = do
  29         case Context.verbosity context of
  30          v | v >= Context.Verbosity_Debug -> do
  31                 color <- with_color context IO.stderr
  32                 when color $
  33                         ANSI.hSetSGR IO.stderr [ANSI.SetColor ANSI.Foreground ANSI.Dull ANSI.Magenta]
  34                 IO.hPutStr IO.stderr "DEBUG"
  35                 when color $
  36                         ANSI.hSetSGR IO.stderr [ANSI.Reset]
  37                 IO.hPutStr IO.stderr $ concat [": ", msg, "\n"]
  38          _ -> return ()
  39
  40 error :: ToDoc Lang d => Context -> d -> IO ()
  41 error context msg = do
  42         case Context.verbosity context of
  43          v | v >= Context.Verbosity_Error -> do
  44                 color <- with_color context IO.stderr
  45                 when color $
  46                         ANSI.hSetSGR IO.stderr
  47                          [ANSI.SetColor ANSI.Foreground ANSI.Dull ANSI.Red]
  48                 W.hPutDoc IO.stderr $
  49                         toDoc (Context.lang context) Lang.Message_ERROR
  50                 when color $
  51                         ANSI.hSetSGR IO.stderr [ANSI.Reset]
  52                 let doc = toDoc (Context.lang context) msg
  53                 W.hPutDoc IO.stderr $
  54                         W.string ":" <> W.space <> doc <> W.line
  55          _ -> return ()
  56
  57 fatal :: ToDoc Lang d => Context -> d -> IO a
  58 fatal context msg = do
  59         Hcompta.CLI.Write.error context msg
  60         exitWith $ ExitFailure 1