]> Git — Sourcephile - comptalang.git/blob - cli/Hcompta/CLI/Write.hs
Refactor hcompta-lib.
[comptalang.git] / 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