lcc/Hcompta/LCC/Write.hs

   1 {-# LANGUAGE DataKinds #-}
   2 {-# LANGUAGE FlexibleContexts #-}
   3 {-# LANGUAGE FlexibleInstances #-}
   4 {-# LANGUAGE MagicHash #-}
   5 {-# LANGUAGE MultiParamTypeClasses #-}
   6 {-# LANGUAGE NamedFieldPuns #-}
   7 {-# LANGUAGE OverloadedStrings #-}
   8 {-# LANGUAGE ScopedTypeVariables #-}
   9 {-# LANGUAGE TypeFamilies #-}
  10 module Hcompta.LCC.Write where
  11
  12 -- import Control.Monad (Monad)
  13 -- import Data.Time.LocalTime (TimeZone(..))
  14 -- import qualified Control.Monad.Classes as MC
  15 -- import qualified Control.Monad.Trans.Reader as R
  16 -- import qualified Data.Time.Calendar  as Time
  17 -- import qualified Data.Time.LocalTime as Time
  18 import Data.Bool
  19 import Data.Char (Char)
  20 import Data.Decimal
  21 import Data.Eq (Eq(..))
  22 import Data.Foldable (Foldable(..))
  23 import Data.Function (($), (.), flip, id)
  24 import Control.Monad (Monad(..))
  25 import Data.Functor ((<$>))
  26 import Data.Functor.Compose (Compose(..))
  27 import Data.Maybe (Maybe(..))
  28 import Data.Monoid ((<>))
  29 import Data.Ord (Ord(..))
  30 import Data.Tuple (fst)
  31 import GHC.Exts (Int(..))
  32 import GHC.Integer.Logarithms (integerLogBase#)
  33 import Prelude (Bounded(..), Integer, Num(..), RealFrac(..), Show(..), Integral(..), fromIntegral)
  34 import System.IO (IO, Handle)
  35 import Text.WalderLeijen.ANSI.Text (Doc)
  36 import qualified Data.Char as Char
  37 import qualified Data.List as List
  38 import qualified Data.Map.Strict as Map
  39 import qualified Data.MonoTraversable as MT
  40 import qualified Data.NonNull as NonNull
  41 import qualified Data.Strict as S
  42 import qualified Data.Text as Text
  43 import qualified Data.Text.Lazy as TL
  44 import qualified Data.TreeMap.Strict as TreeMap
  45 import qualified Text.WalderLeijen.ANSI.Text as W
  46 import qualified Data.ByteString as BS
  47 import qualified Data.Text.Encoding as Enc
  48
  49 import qualified Hcompta as H
  50
  51 import Hcompta.LCC.Account
  52 import Hcompta.LCC.Amount
  53 import Hcompta.LCC.Chart
  54 import Hcompta.LCC.Journal
  55 import Hcompta.LCC.Name
  56 import Hcompta.LCC.Posting
  57 import Hcompta.LCC.Tag
  58 import Hcompta.LCC.Transaction
  59 import Hcompta.LCC.Grammar
  60 import Hcompta.LCC.Compta
  61 -- import qualified Hcompta.LCC.Lib.Strict as S
  62
  63 -- * Write 'Date'
  64 write_date :: Date -> Doc
  65 write_date dat =
  66         let (y, mo, d) = H.date_gregorian dat in
  67         (if y == 0 then W.empty else W.integer y <> sep char_ymd_sep) <>
  68         doc_int2 mo <>
  69         sep char_ymd_sep <> doc_int2 d <>
  70         (case H.date_tod dat of
  71          (0, 0, 0) -> W.empty
  72          (h, m, s) ->
  73                 sep '_' <> doc_int2 h <>
  74                 sep ':' <> doc_int2 m <>
  75                 (case s of
  76                  0 -> W.empty
  77                  _ -> sep ':' <>
  78                         (if s < 10 then W.char '0' else W.empty) <>
  79                         W.strict_text (Text.pack $ show $ (truncate s::Integer)))) {-<>
  80         (case tz_min of
  81          0 -> W.empty
  82          _ | tz_name /= "" -> W.space <> do W.strict_text $ Text.pack tz_name
  83          _ -> W.space <> do W.strict_text $ Text.pack $ Time.timeZoneOffsetString tz)
  84         -}
  85         where
  86         doc_int2 :: Int -> Doc
  87         doc_int2 i = if i < 10 then W.char '0' <> W.int i else W.int i
  88         sep :: Char -> Doc
  89         sep = gray . W.char
  90
  91 width_date :: Date -> Int
  92 width_date dat = do
  93         let (y, _, _) = H.date_gregorian dat
  94         (case y of
  95          0 -> 0
  96          _ ->
  97                 (if y < 0 then 1 else 0) -- sign
  98                 + (1 + (I# (integerLogBase# 10 (abs y)))) -- year
  99                 + 1) -- -
 100         + 2 -- month
 101         + 1 -- -
 102         + 2 -- dom
 103         + (case H.date_tod dat of
 104          (0, 0, 0) -> 0
 105          (_, _, s) ->
 106                 1 -- _
 107                 + 2 -- hour
 108                 + 1 -- :
 109                 + 2 -- min
 110                 + (case s of
 111                  0 -> 0
 112                  _ -> 1 + 2 -- : sec
 113                 )
 114         )
 115
 116 -- * Write 'Account'
 117 write_account :: Account -> Doc
 118 write_account =
 119         MT.ofoldMap $ \a ->
 120                 gray (W.char char_account_sep) <>
 121                 write_account_section a
 122
 123 write_account_section :: Account_Section -> Doc
 124 write_account_section = W.strict_text . unName
 125
 126 width_account :: Account -> Int
 127 width_account =
 128         MT.ofoldl'
 129          (\acc -> (1 +) . (acc +) . Text.length . unName)
 130          0
 131
 132 -- ** Write 'Account_Ref'
 133 write_account_ref :: Tag_Path -> Doc
 134 write_account_ref (Tag_Path path) =
 135         W.hcat $
 136                 (:) (op $ W.char char_account_tag_prefix) $
 137                 List.intersperse
 138                  (op $ W.char char_tag_sep)
 139                  (W.strict_text . unName <$> NonNull.toNullable path)
 140         where op = W.bold . W.dullyellow
 141
 142 width_account_ref :: Tag_Path -> Int
 143 width_account_ref (Tag_Path anch) =
 144         MT.ofoldl'
 145          (\acc -> (1 +) . (acc +) . MT.olength)
 146          0 anch
 147
 148 -- ** Write 'Account_Tag'
 149 write_account_tag :: Account_Tag -> Doc
 150 write_account_tag (Account_Tag (Tag (Tag_Path path) (Tag_Data value))) =
 151         W.hcat (
 152                 (:) (op $ W.char char_account_tag_prefix) $
 153                 List.intersperse
 154                  (op $ W.char char_tag_sep)
 155                  (W.strict_text . unName <$> NonNull.toNullable path) ) <>
 156         if Text.null value
 157         then W.empty
 158         else
 159                 op (W.char char_tag_data_prefix) <>
 160                 W.strict_text value
 161         where op = W.bold . W.dullyellow
 162
 163 -- * Write 'Amount'
 164 write_amount :: Styled_Amount Amount -> Doc
 165 write_amount
 166  ( sty@(Style_Amount
 167          { style_amount_unit_side
 168          , style_amount_unit_spaced
 169          })
 170  , amt ) =
 171         let unt = amount_unit amt in
 172         case style_amount_unit_side of
 173          S.Just L ->
 174                 write_unit unt <>
 175                 case style_amount_unit_spaced of
 176                  S.Just True | unt /= H.unit_empty -> W.space
 177                  _ -> W.empty
 178          _ -> W.empty
 179         <> write_quantity (sty, amount_quantity amt)
 180         <> case style_amount_unit_side of
 181          (S.Just R) ->
 182                 (case style_amount_unit_spaced of
 183                  S.Just True | unt /= H.unit_empty -> W.space
 184                  _ -> W.empty) <>
 185                 write_unit unt
 186          S.Nothing ->
 187                 (case style_amount_unit_spaced of
 188                  S.Just True | unt /= H.unit_empty -> W.space
 189                  _ -> W.empty) <>
 190                 write_unit unt
 191          _ -> W.empty
 192
 193 width_amount :: Styled_Amount Amount -> Int
 194 width_amount (sty@(Style_Amount { style_amount_unit_spaced }), amt) =
 195         let unit = amount_unit amt in
 196         width_unit unit
 197         + (case style_amount_unit_spaced of
 198                  S.Just True | unit /= H.unit_empty -> 1
 199                  _ -> 0)
 200         + width_quantity sty (amount_quantity amt)
 201
 202 -- * Write 'Unit'
 203 write_unit :: Unit -> Doc
 204 write_unit u =
 205         let t = H.unit_text u in
 206         W.yellow $
 207         if Text.all
 208          (\c -> case Char.generalCategory c of
 209                  Char.CurrencySymbol  -> True
 210                  Char.LowercaseLetter -> True
 211                  Char.ModifierLetter  -> True
 212                  Char.OtherLetter     -> True
 213                  Char.TitlecaseLetter -> True
 214                  Char.UppercaseLetter -> True
 215                  _ -> False
 216          ) t
 217         then W.strict_text t
 218         else W.hcat $ W.strict_text <$> ["\"", t, "\""]
 219
 220 width_unit :: Unit -> Int
 221 width_unit u =
 222         let t = H.unit_text u in
 223         Text.length t +
 224         if Text.all
 225          (\c -> case Char.generalCategory c of
 226                  Char.CurrencySymbol  -> True
 227                  Char.LowercaseLetter -> True
 228                  Char.ModifierLetter  -> True
 229                  Char.OtherLetter     -> True
 230                  Char.TitlecaseLetter -> True
 231                  Char.UppercaseLetter -> True
 232                  _ -> False) t
 233         then 0
 234         else 2
 235
 236 -- * Write 'Quantity'
 237 write_quantity :: Styled_Amount Quantity -> Doc
 238 write_quantity
 239  ( Style_Amount
 240          { style_amount_fractioning
 241          , style_amount_grouping_integral
 242          , style_amount_grouping_fractional
 243          }
 244  , qty ) = do
 245         let Decimal e n = qty
 246         let num = show $ abs $ n
 247         let sign = W.bold $ W.yellow $ W.strict_text (if n < 0 then "-" else "")
 248         if e == 0
 249          then sign <> W.bold (W.blue $ W.strict_text $ Text.pack num)
 250          else do
 251                 let num_len = List.length num
 252                 let padded =
 253                         List.concat
 254                          [ List.replicate (fromIntegral e + 1 - num_len) '0'
 255                          , num
 256                          -- , replicate (fromIntegral precision - fromIntegral e) '0'
 257                          ]
 258                 let (int, frac) = List.splitAt (max 1 (num_len - fromIntegral e)) padded
 259                 let default_fractioning =
 260                         List.head $
 261                         del_grouping_sep style_amount_grouping_integral $
 262                         del_grouping_sep style_amount_grouping_fractional $
 263                         ['.', ',']
 264                 sign <>
 265                  W.bold (W.blue $
 266                         W.text (TL.pack $ S.maybe id
 267                          (\g -> List.reverse . group g . List.reverse)
 268                          style_amount_grouping_integral $ int) <>
 269                         W.yellow (W.char (S.fromMaybe default_fractioning style_amount_fractioning)) <>
 270                         W.text (TL.pack $ S.maybe id group style_amount_grouping_fractional frac))
 271         where
 272         group :: Style_Amount_Grouping -> [Char] -> [Char]
 273         group (Style_Amount_Grouping sep sizes_) =
 274                 List.concat . List.reverse .
 275                 List.map List.reverse . fst .
 276                 List.foldl'
 277                  (flip (\digit x -> case x of
 278                          ([], sizes) -> ([[digit]], sizes)
 279                          (digits:groups, []) -> ((digit:digits):groups, [])
 280                          (digits:groups, curr_sizes@(size:sizes)) ->
 281                                 if List.length digits < size
 282                                 then (      (digit:digits):groups, curr_sizes)
 283                                 else ([digit]:[sep]:digits:groups, if List.null sizes then curr_sizes else sizes)
 284                  ))
 285                  ([], sizes_)
 286         del_grouping_sep grouping =
 287                 case grouping of
 288                  S.Just (Style_Amount_Grouping sep _) -> List.delete sep
 289                  _ -> id
 290
 291 width_quantity :: Style_Amount -> Quantity -> Int
 292 width_quantity Style_Amount
 293  { style_amount_grouping_integral
 294  , style_amount_grouping_fractional
 295  } qty =
 296         let Decimal e n     = qty in
 297         let sign_len        = if n < 0 then 1 else 0 in
 298         let fractioning_len = if e > 0 then 1 else 0 in
 299         let num_len         = if n == 0 then 0 else (1 +) $ I# (integerLogBase# 10 (abs n)) in
 300         let pad_left_len    = max 0 (fromIntegral e + 1 - num_len) in
 301         -- let pad_right_len   = max 0 (fromIntegral precision - fromIntegral e) in
 302         let padded_len      = pad_left_len + num_len {-+ pad_right_len-} in
 303         let int_len         = max 1 (num_len - fromIntegral e) in
 304         let frac_len        = max 0 (padded_len - int_len) in
 305         ( sign_len
 306         + fractioning_len
 307         + padded_len
 308         + S.maybe 0 (group int_len)  style_amount_grouping_integral
 309         + S.maybe 0 (group frac_len) style_amount_grouping_fractional
 310         )
 311         where
 312         group :: Int -> Style_Amount_Grouping -> Int
 313         group num_len (Style_Amount_Grouping _sep sizes_) =
 314                 if num_len <= 0
 315                 then 0
 316                 else loop 0 num_len sizes_
 317                 where
 318                 loop :: Int -> Int -> [Int] -> Int
 319                 loop pad len x =
 320                         case x of
 321                          [] -> 0
 322                          sizes@[size] ->
 323                                 let l = len - size in
 324                                 if l <= 0 then pad
 325                                 else loop (pad + 1) l sizes
 326                          size:sizes ->
 327                                 let l = len - size in
 328                                 if l <= 0 then pad
 329                                 else loop (pad + 1) l sizes
 330
 331 -- * Write 'Comment'
 332 write_comment :: Comment -> Doc
 333 write_comment (Comment com) =
 334         W.cyan $
 335                 W.char char_comment_prefix
 336                 <> (case Text.uncons com of
 337                  Just (c, _) | not $ Char.isSpace c -> W.space
 338                  _ -> W.empty)
 339                 <> W.strict_text com
 340
 341 write_comments :: Doc -> [Comment] -> Doc
 342 write_comments prefix =
 343         W.hcat .
 344         List.intersperse W.line .
 345         List.map (\c -> prefix <> write_comment c)
 346
 347 -- * Write 'Posting'
 348 write_posting
 349  :: Context_Write
 350  -> Posting -> Doc
 351 write_posting ctx
 352  Posting
 353  { posting_account
 354  , posting_account_ref
 355  , posting_amounts
 356  , posting_comments=cmts
 357  -- , posting_dates
 358  -- , posting_tags
 359  } =
 360         W.string "  " <>
 361         let (doc_acct, wi_acct) =
 362                 case posting_account_ref of
 363                  S.Just (a S.:!: sa) | context_write_account_ref ctx ->
 364                         ( write_account_ref a <> S.maybe W.empty write_account sa
 365                         , width_account_ref a +  S.maybe 0       width_account sa )
 366                  _ ->
 367                         ( write_account posting_account
 368                         , width_account posting_account ) in
 369         (case posting_amounts of
 370          Amounts amts | Map.null amts -> doc_acct
 371          Amounts amts ->
 372                 Map.foldlWithKey
 373                  (\doc unit qty ->
 374                         let amt = styled_amount (context_write_amounts ctx) $ Amount unit qty in
 375                         let wi_amt = width_amount amt in
 376                         doc <>
 377                         (if W.is_empty doc then W.empty else W.line <> W.string "  ") <>
 378                         doc_acct <>
 379                         W.fill (context_write_max_posting_width ctx - (wi_acct + wi_amt)) W.space <>
 380                         write_amount amt
 381                  ) W.empty amts) <>
 382         (case cmts of
 383          []  -> W.empty
 384          [c] -> W.space <> write_comment c
 385          _   -> W.line  <> write_comments (W.text "   ") cmts)
 386
 387 -- ** Type 'Widths_Posting'
 388 type Widths_Posting = Int
 389
 390 widths_postings
 391  :: Context_Write
 392  -> Postings
 393  -> Widths_Posting
 394 widths_postings ctx (Postings ps) =
 395         foldr (\p -> max $
 396                 ((case posting_account_ref p of
 397                          S.Just (a S.:!: sa) | context_write_account_ref ctx ->
 398                                 width_account_ref a +
 399                                 S.maybe 0 width_account sa
 400                          _ -> width_account (posting_account p)
 401                  ) +) $
 402                 (\len -> if len > 0 then 1 + len else len) $
 403                 Map.foldrWithKey
 404                  (\unit qty -> max $
 405                         width_amount $
 406                         styled_amount (context_write_amounts ctx) $
 407                         Amount unit qty)
 408                  0 (unAmounts $ posting_amounts p)
 409          ) 0
 410          (Compose ps)
 411
 412 -- * Write 'Transaction'
 413 write_transaction
 414  :: Context_Write
 415  -> Transaction -> Doc
 416 write_transaction ctx
 417  t@Transaction
 418  { transaction_comments
 419  , transaction_dates
 420  , transaction_wording  = Wording transaction_wording
 421  , transaction_postings = Postings transaction_postings
 422  , transaction_tags     = Transaction_Tags (Tags tags)
 423  } =
 424         let ctx' = ctx { context_write_max_posting_width =
 425                 let wi = context_write_max_posting_width ctx in
 426                 if wi == 0
 427                 then widths_transaction ctx t
 428                 else wi } in
 429         W.hcat (
 430                 List.intersperse
 431                  (W.char char_transaction_date_sep)
 432                  (write_date <$> NonNull.toNullable transaction_dates)) <>
 433         (case transaction_wording of
 434          "" -> W.empty
 435          _  -> W.space <> W.dullmagenta (W.strict_text transaction_wording)) <>
 436         W.line <>
 437         (case transaction_comments of
 438          [] -> W.empty
 439          _  -> write_comments W.space transaction_comments <> W.line) <>
 440         TreeMap.foldr_with_Path
 441          (\path -> flip $
 442                 foldr (\value -> (<>) (W.string "  " <>
 443                 write_transaction_tag (Transaction_Tag (Tag (Tag_Path path) value)) <> W.line)))
 444          W.empty tags <>
 445         W.intercalate W.line
 446          (W.vsep . (write_posting ctx' <$>))
 447          transaction_postings
 448
 449 write_transactions
 450  :: Foldable j
 451  => Context_Write
 452  -> j Transaction -> Doc
 453 write_transactions ctx j =
 454         let ctx' = ctx{context_write_max_posting_width =
 455                 foldr (max . widths_transaction ctx) 0 j} in
 456         foldr (\t doc ->
 457                 write_transaction ctx' t <>
 458                 (if W.is_empty doc then W.line else W.line <> W.line <> doc)
 459          ) W.empty j
 460
 461 -- ** Type 'Widths_Transaction'
 462 type Widths_Transaction = Widths_Posting
 463
 464 widths_transaction :: Context_Write -> Transaction -> Widths_Posting
 465 widths_transaction ctx
 466  Transaction
 467  { transaction_postings
 468  } =
 469         foldr
 470          (max . widths_postings ctx)
 471          0 [ transaction_postings ]
 472
 473 -- ** Write 'Transaction_Tag'
 474 write_transaction_tag :: Transaction_Tag -> Doc
 475 write_transaction_tag (Transaction_Tag (Tag (Tag_Path path) (Tag_Data value))) =
 476         W.hcat (
 477                 (:) (W.bold $ W.dullyellow $ W.char char_tag_prefix) $
 478                 List.intersperse
 479                  (op $ W.char char_tag_sep)
 480                  (write_transaction_tag_section <$> NonNull.toNullable path)) <>
 481         if Text.null value
 482         then W.empty
 483         else
 484                 op (W.char char_tag_data_prefix) <>
 485                 W.strict_text value
 486         where
 487         op = W.bold . W.yellow
 488
 489 write_transaction_tag_section :: Name -> Doc
 490 write_transaction_tag_section = W.bold . W.strict_text . unName
 491
 492 -- * Write 'Journal'
 493 write_journal :: Foldable j => Context_Write -> Journal (j [Transaction]) -> Doc
 494 write_journal ctx jnl =
 495         write_transactions ctx $
 496         Compose $ journal_content jnl
 497
 498 -- * Write 'Journals'
 499 write_journals :: Foldable j => Context_Write -> Journals (j [Transaction]) -> Doc
 500 write_journals ctx (Journals js) =
 501         Map.foldl
 502          (\doc j@Journal{journal_file=PathFile jf, journal_content=jc} ->
 503                 doc <>
 504                 write_comment (Comment $ Text.pack jf) <> W.line <>
 505                 if null jc then W.empty else (W.line <> write_journal ctx j)
 506          ) W.empty js
 507
 508 -- * Write 'Chart'
 509 write_chart :: Chart -> Doc
 510 write_chart =
 511         TreeMap.foldl_with_Path
 512          (\doc acct (Account_Tags (Tags ca)) ->
 513                 doc <>
 514                 write_account (H.get acct) <> W.line <>
 515                 TreeMap.foldl_with_Path
 516                  (\dd tp tvs ->
 517                         dd <>
 518                         foldl'
 519                          (\ddd tv ->
 520                                 ddd <> W.string "  " <>
 521                                 write_account_tag (Account_Tag (Tag (Tag_Path tp) tv)) <>
 522                                 W.line)
 523                          W.empty
 524                          tvs)
 525                  W.empty
 526                  ca
 527          ) W.empty .
 528         chart_accounts
 529
 530 -- * Write 'Terms'
 531
 532 write_terms :: Terms -> Doc
 533 write_terms ts =
 534         Map.foldl
 535          (\doc t ->
 536                 doc <>
 537                 W.strict_text t <>
 538                 W.line
 539          ) W.empty ts
 540
 541 -- * Write 'Compta'
 542 write_compta :: Context_Write -> Compta src ss -> Doc
 543 write_compta ctx Compta
 544  { compta_journals=js
 545  , compta_chart=c@Chart{chart_accounts=ca}
 546  , compta_style_amounts=amts
 547  , compta_terms=ts
 548  } =
 549         (if null ts then W.empty else (write_terms ts <> W.line)) <>
 550         (if TreeMap.null ca then W.empty else (write_chart c <> W.line)) <>
 551         write_journals ctx{context_write_amounts=context_write_amounts ctx <> amts} js
 552
 553 -- * Write 'SourcePos'
 554 write_sourcepos :: SourcePos -> IO Doc
 555 write_sourcepos (SourcePos p (PosFile l) (PosFile c)) = do
 556         content <- Enc.decodeUtf8 <$> BS.readFile p
 557         let ls = Text.lines content
 558         let ll = max 1 $ l - size_ctx
 559         let qs =
 560                 List.take (intFrom $ (l - ll) + 1 + size_ctx) $
 561                 List.drop (intFrom $ ll-1) ls
 562         let ns = show <$> List.take (List.length qs) [ll..]
 563         let max_len_n = maximum $ List.length <$> ns
 564         let ns' = (<$> ns) $ \n ->
 565                 List.replicate (max_len_n - List.length n) ' ' <> n
 566         let quote =
 567                 W.vcat $
 568                 List.zipWith (\(n, sn) q ->
 569                         "  " <> gray (W.strict_text (Text.pack sn)) <>
 570                         "  " <> (if n == l then mark q else W.strict_text q)
 571                  ) (List.zip [ll..] ns') qs
 572         return $ quote <> W.line
 573         where
 574         size_ctx = 2
 575         intFrom = fromInteger . toInteger
 576         mark q =
 577                 let (b, a) = Text.splitAt (intFrom c - 1) q in
 578                 W.strict_text b <>
 579                 case Text.uncons a of
 580                  Nothing -> red " "
 581                  Just (a0, a') -> red (W.char a0) <> W.strict_text a'
 582
 583 gray :: Doc -> Doc
 584 gray = W.bold . W.dullblack
 585
 586 red :: Doc -> Doc
 587 red = W.onred
 588
 589
 590 -- Type 'Context_Write'
 591 data Context_Write
 592  =   Context_Write
 593  {   context_write_account_ref       :: Bool
 594  ,   context_write_amounts           :: Style_Amounts
 595  ,   context_write_max_posting_width :: Int
 596  }
 597
 598 context_write :: Context_Write
 599 context_write =
 600         Context_Write
 601          { context_write_account_ref       = True
 602          , context_write_amounts           = Style_Amounts Map.empty
 603          , context_write_max_posting_width = 0
 604          }
 605
 606 {-
 607 type Style_Anchor = Bool
 608 type instance MC.CanDo (S.ReaderT Context_Write m) (MC.EffReader Context_Write) = 'True
 609 instance Monad m => MC.MonadReaderN 'MC.Zero Context_Write (S.ReaderT Context_Write m) where
 610         askN _px = S.ReaderT R.ask
 611 type instance MC.CanDo (S.ReaderT Context_Write m) (MC.EffReader Style_Anchor) = 'True
 612 instance Monad m => MC.MonadReaderN 'MC.Zero Style_Anchor (S.ReaderT Context_Write m) where
 613         askN _px = S.ReaderT $ R.asks $ Style_Anchor . context_write_account_ref
 614 -}
 615
 616 -- * Type 'Style_Write'
 617 data Style_Write
 618  =   Style_Write
 619  {   style_write_align :: Bool
 620  ,   style_write_color :: Bool
 621  }
 622 style_write :: Style_Write
 623 style_write =
 624         Style_Write
 625          { style_write_align = True
 626          , style_write_color = True
 627          }
 628
 629 -- * Write
 630 write :: Style_Write -> Doc -> TL.Text
 631 write Style_Write
 632  { style_write_color
 633  , style_write_align } =
 634         W.displayT .
 635         if style_write_align
 636         then W.renderPretty  style_write_color 1.0 maxBound
 637         else W.renderCompact style_write_color
 638
 639 writeIO :: Style_Write -> Handle -> Doc -> IO ()
 640 writeIO Style_Write
 641  { style_write_color
 642  , style_write_align
 643  } handle doc =
 644         W.displayIO handle $
 645         if style_write_align
 646         then W.renderPretty  style_write_color 1.0 maxBound doc
 647         else W.renderCompact style_write_color doc