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