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.Eq (Eq)
  11 import           Data.Foldable (Foldable, forM_)
  12 import           Data.List (concat)
  13 import           Data.Maybe (Maybe(..))
  14 import           Data.Ord (Ord(..))
  15 import           Data.String (String)
  16 import           Prelude (($), Bounded(..), IO)
  17 import qualified System.Console.ANSI as ANSI
  18 import           System.Exit (exitWith, ExitCode(..))
  19 import qualified System.IO as IO
  20 import           Text.Show (Show)
  21
  22 import qualified Hcompta.CLI.Context as C
  23 import qualified Hcompta.CLI.Lang as Lang
  24 import           Hcompta.Lib.Leijen ((<>))
  25 import qualified Hcompta.Lib.Leijen as W
  26
  27 with_color :: C.Context -> IO.Handle -> IO Bool
  28 with_color c h =
  29         case C.color c of
  30          Nothing -> IO.hIsTerminalDevice h
  31          Just b  -> return b
  32
  33 debug :: C.Context -> String -> IO ()
  34 debug c msg = do
  35         case C.verbosity c of
  36          v | v >= C.Verbosity_Debug -> do
  37                 color <- with_color c IO.stderr
  38                 when color $ ANSI.hSetSGR IO.stderr
  39                  [ANSI.SetColor ANSI.Foreground ANSI.Dull ANSI.Magenta]
  40                 W.hPutDoc IO.stderr $ C.translate c Lang.Write_Debug
  41                 when color $ ANSI.hSetSGR IO.stderr [ANSI.Reset]
  42                 IO.hPutStr IO.stderr $ concat [": ", msg, "\n"]
  43          _ -> return ()
  44
  45 error :: Lang.Translate msg W.Doc => C.Context -> msg -> IO ()
  46 error c msg = do
  47         case C.verbosity c of
  48          v | v >= C.Verbosity_Error -> do
  49                 color <- with_color c IO.stderr
  50                 when color $ ANSI.hSetSGR IO.stderr
  51                  [ANSI.SetColor ANSI.Foreground ANSI.Dull ANSI.Red]
  52                 W.hPutDoc IO.stderr $ C.translate c Lang.Write_Error
  53                 when color $ ANSI.hSetSGR IO.stderr [ANSI.Reset]
  54                 W.hPutDoc IO.stderr $
  55                         W.string ":" <> W.space <> C.translate c msg <> W.line
  56          _ -> return ()
  57
  58 fatal :: Lang.Translate msg W.Doc => C.Context -> msg -> IO a
  59 fatal c msg = do
  60         error c msg
  61         exitWith $ ExitFailure 1
  62
  63 fatals :: Foldable f => Lang.Translate msg W.Doc => C.Context -> f msg -> IO a
  64 fatals c msgs = do
  65         forM_ msgs $ error c
  66         exitWith $ ExitFailure 1
  67
  68 data Mode
  69  =   Mode_Over
  70  |   Mode_Append
  71  deriving (Eq, Show)
  72 data Style
  73  = Style
  74  { style_pretty :: Bool
  75  }
  76  deriving (Eq, Show)
  77
  78 style :: Style
  79 style =
  80         Style
  81          { style_pretty = True
  82          }
  83
  84 write :: C.Context -> Style -> [(Mode, IO.FilePath)] -> W.Doc -> IO ()
  85 write context sty files doc = do
  86         let out =
  87                 if style_pretty sty
  88                 then W.renderPretty  False 1.0 maxBound doc
  89                 else W.renderCompact False doc
  90         let out_colored =
  91                 if style_pretty sty
  92                 then W.renderPretty  True 1.0 maxBound doc
  93                 else W.renderCompact True doc
  94         let wrt h = do
  95                 color <- with_color context h
  96                 case color of
  97                  True  -> W.displayIO h out_colored
  98                  False -> W.displayIO h out
  99         Data.Foldable.forM_ files $ \(mode, path) ->
 100                 case path of
 101                  "-" -> wrt IO.stdout
 102                  _ ->
 103                         IO.withFile path
 104                          (case mode of
 105                                  Mode_Over   -> IO.WriteMode
 106                                  Mode_Append -> IO.AppendMode)
 107                          wrt