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 (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 data Mode
  64  =   Mode_Over
  65  |   Mode_Append
  66  deriving (Eq, Show)
  67 data Style
  68  = Style
  69  { style_pretty :: Bool
  70  }
  71  deriving (Eq, Show)
  72
  73 style :: Style
  74 style =
  75         Style
  76          { style_pretty = True
  77          }
  78
  79 write :: C.Context -> Style -> [(Mode, IO.FilePath)] -> W.Doc -> IO ()
  80 write context sty files doc = do
  81         let out =
  82                 if style_pretty sty
  83                 then W.renderPretty  False 1.0 maxBound doc
  84                 else W.renderCompact False doc
  85         let out_colored =
  86                 if style_pretty sty
  87                 then W.renderPretty  True 1.0 maxBound doc
  88                 else W.renderCompact True doc
  89         let wrt h = do
  90                 color <- with_color context h
  91                 case color of
  92                  True  -> W.displayIO h out_colored
  93                  False -> W.displayIO h out
  94         Data.Foldable.forM_ files $ \(mode, path) ->
  95                 case path of
  96                  "-" -> wrt IO.stdout
  97                  _ ->
  98                         IO.withFile path
  99                          (case mode of
 100                                  Mode_Over   -> IO.WriteMode
 101                                  Mode_Append -> IO.AppendMode)
 102                          wrt