]> Git — Sourcephile - comptalang.git/blob - cli/Hcompta/CLI/Write.hs
Ajout : Lib.TreeMap.Zipper : en prévision de collectes « à la XSLT » sur Chart.
[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.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