-import Data.List
-import Language.Symantic.Parsing as Sym
+import Control.Applicative
import Data.Either
-import Data.String
+import Data.Functor.Compose
import Data.Functor.Identity
-import Text.Megaparsec
-import Control.Applicative
+import Data.List
+import Data.String
import Prelude
-import qualified Hcompta as H
-import Data.Functor.Compose
+import System.IO (IO)
+import Text.Megaparsec
import qualified Data.MonoTraversable as MT
import qualified Data.Text.Lazy as TL
import qualified Data.Text.Lazy.IO as TL
-:set -XFlexibleContexts
-:set -XOverloadedStrings
+import qualified System.IO as IO
+
+import qualified Language.Symantic.Document as D
+import qualified Hcompta as H
+
+:m Hcompta.LCC as LCC
+
+:set -Wno-type-defaults
, module Hcompta.LCC.Amount
, module Hcompta.LCC.Chart
, module Hcompta.LCC.Compta
+ , module Hcompta.LCC.Document
, module Hcompta.LCC.Grammar
, module Hcompta.LCC.Journal
, module Hcompta.LCC.Name
, module Hcompta.LCC.Read
, module Hcompta.LCC.Tag
, module Hcompta.LCC.Transaction
- , module Hcompta.LCC.Write
) where
import Hcompta.LCC.Account
import Hcompta.LCC.Amount
import Hcompta.LCC.Chart
import Hcompta.LCC.Compta
+import Hcompta.LCC.Document
import Hcompta.LCC.Grammar
import Hcompta.LCC.Journal
import Hcompta.LCC.Name
import Hcompta.LCC.Read
import Hcompta.LCC.Tag
import Hcompta.LCC.Transaction
-import Hcompta.LCC.Write
--- /dev/null
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE NoMonomorphismRestriction #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
+module Hcompta.LCC.Document where
+
+-- import Control.Monad (Monad)
+-- import Data.Time.LocalTime (TimeZone(..))
+-- import GHC.Integer.Logarithms (integerLogBase#)
+-- import qualified Control.Monad.Classes as MC
+-- import qualified Control.Monad.Trans.Reader as R
+-- import qualified Data.Time.Calendar as Time
+-- import qualified Data.Time.LocalTime as Time
+-- import qualified Hcompta.LCC.Lib.Strict as S
+-- import qualified Text.WalderLeijen.ANSI.Text as W
+import Control.Monad (Monad(..))
+import Data.Bool
+import Data.Char (Char)
+import Data.Decimal
+import Data.Eq (Eq(..))
+import Data.Foldable (Foldable(..))
+import Data.Function (($), (.), flip, id)
+import Data.Functor ((<$>))
+import Data.Functor.Compose (Compose(..))
+import Data.Maybe (Maybe(..), maybe)
+import Data.Ord (Ord(..))
+import Data.Semigroup (Semigroup(..))
+import Data.Tuple (fst)
+import GHC.Exts (Int(..))
+import Prelude (Integer, Num(..), RealFrac(..), Show(..), Integral(..), fromIntegral)
+import qualified Data.ByteString as BS
+import qualified Data.Char as Char
+import qualified Data.List as List
+import qualified Data.Map.Strict as Map
+import qualified Data.MonoTraversable as MT
+import qualified Data.NonNull as NonNull
+import qualified Data.Strict as S
+import qualified Data.Text as Text
+import qualified Data.Text.Encoding as Enc
+import qualified Data.TreeMap.Strict as TreeMap
+
+import qualified Language.Symantic.Document as D
+
+import qualified Hcompta as H
+
+import Hcompta.LCC.Account
+import Hcompta.LCC.Amount
+import Hcompta.LCC.Chart
+import Hcompta.LCC.Journal
+import Hcompta.LCC.Name
+import Hcompta.LCC.Posting
+import Hcompta.LCC.Tag
+import Hcompta.LCC.Transaction
+import Hcompta.LCC.Grammar
+import Hcompta.LCC.Compta
+
+-- import Debug.Trace (trace)
+-- dbg msg x = trace (msg <> " = " <> show x) x
+
+-- * Type 'Context_Write'
+data Context_Write
+ = Context_Write
+ { context_write_account_ref :: Bool
+ , context_write_amounts :: Style_Amounts
+ , context_write_width_acct_amt :: Int
+ }
+
+context_write :: Context_Write
+context_write =
+ Context_Write
+ { context_write_account_ref = True
+ , context_write_amounts = Style_Amounts Map.empty
+ , context_write_width_acct_amt = 0
+ }
+
+-- * Document 'Date'
+d_date dat =
+ let (y, mo, d) = H.date_gregorian dat in
+ (if y == 0 then D.empty else D.integer y <> sep char_ymd_sep) <>
+ int2 mo <>
+ sep char_ymd_sep <> int2 d <>
+ (case H.date_tod dat of
+ (0, 0, 0) -> D.empty
+ (h, m, s) ->
+ sep '_' <> int2 h <>
+ sep ':' <> int2 m <>
+ (case s of
+ 0 -> D.empty
+ _ -> sep ':' <>
+ (if s < 10 then D.charH '0' else D.empty) <>
+ D.integer ((truncate s::Integer))))
+ where
+ int2 i = (if i < 10 then D.charH '0' else D.empty) <> D.int i
+ sep = D.blacker . D.charH
+
+-- * Document 'Account'
+d_account (acct::Account) =
+ (`MT.ofoldMap` acct) $ \a ->
+ D.blacker (D.charH char_account_sep) <>
+ d_account_section a
+w_account = D.width . D.dim . d_account
+
+d_account_section = D.textH . unName
+
+-- ** Document 'Account_Ref'
+d_account_ref (Tag_Path path) =
+ D.catH $
+ (:) (op $ D.charH char_account_tag_prefix) $
+ List.intersperse
+ (op $ D.charH char_tag_sep)
+ (D.textH . unName <$> NonNull.toNullable path)
+ where op = D.yellower
+w_account_ref = D.width . D.dim . d_account_ref
+
+-- ** Document 'Account_Tag'
+d_account_tag (Account_Tag (Tag (Tag_Path path) (Tag_Data value))) =
+ D.catH (
+ (:) (op $ D.charH char_account_tag_prefix) $
+ List.intersperse
+ (op $ D.charH char_tag_sep)
+ (D.textH . unName <$> NonNull.toNullable path) ) <>
+ if Text.null value
+ then D.empty
+ else
+ op (D.charH char_tag_data_prefix) <>
+ D.textH value
+ where op = D.yellower
+
+-- * Document 'Amount'
+d_amount
+ ( sty@(Style_Amount
+ { style_amount_unit_side=uside
+ , style_amount_unit_spaced=uspaced
+ })
+ , Amount u q ) =
+ case uside of
+ S.Just L ->
+ d_unit u <>
+ case uspaced of
+ S.Just True | u /= H.unit_empty -> D.space
+ _ -> D.empty
+ _ -> D.empty
+ <> d_quantity (sty, q)
+ <> case uside of
+ S.Just R ->
+ (case uspaced of
+ S.Just True | u /= H.unit_empty -> D.space
+ _ -> D.empty) <>
+ d_unit u
+ S.Nothing ->
+ (case uspaced of
+ S.Just True | u /= H.unit_empty -> D.space
+ _ -> D.empty) <>
+ d_unit u
+ _ -> D.empty
+w_amount = D.width . D.dim . d_amount
+
+-- * Document 'Unit'
+d_unit u =
+ let t = H.unit_text u in
+ D.yellow $
+ if Text.all
+ (\c -> case Char.generalCategory c of
+ Char.CurrencySymbol -> True
+ Char.LowercaseLetter -> True
+ Char.ModifierLetter -> True
+ Char.OtherLetter -> True
+ Char.TitlecaseLetter -> True
+ Char.UppercaseLetter -> True
+ _ -> False
+ ) t
+ then D.textH t
+ else D.dquote $ D.textH t
+
+-- * Document 'Quantity'
+d_quantity
+ ( Style_Amount
+ { style_amount_fractioning
+ , style_amount_grouping_integral
+ , style_amount_grouping_fractional
+ }
+ , qty ) = do
+ let Decimal e n = qty
+ let num = show $ abs n
+ let sign = D.bold $ D.yellow $ D.textH (if n < 0 then "-" else "")
+ if e == 0
+ then sign <> D.bold (D.blue $ D.stringH num)
+ else do
+ let num_len = List.length num
+ let padded =
+ List.concat
+ [ List.replicate (fromIntegral e + 1 - num_len) '0'
+ , num
+ -- , replicate (fromIntegral precision - fromIntegral e) '0'
+ ]
+ let (int, frac) = List.splitAt (max 1 (num_len - fromIntegral e)) padded
+ let default_fractioning =
+ List.head $
+ del_grouping_sep style_amount_grouping_integral $
+ del_grouping_sep style_amount_grouping_fractional $
+ ['.', ',']
+ sign <>
+ D.bold (D.blue $
+ D.stringH (S.maybe id
+ (\g -> List.reverse . group g . List.reverse)
+ style_amount_grouping_integral $ int) <>
+ D.yellow (D.charH (S.fromMaybe default_fractioning style_amount_fractioning)) <>
+ D.stringH (S.maybe id group style_amount_grouping_fractional frac))
+ where
+ group :: Style_Amount_Grouping -> [Char] -> [Char]
+ group (Style_Amount_Grouping sep sizes_) =
+ List.concat . List.reverse .
+ List.map List.reverse . fst .
+ List.foldl'
+ (flip (\digit x -> case x of
+ ([], sizes) -> ([[digit]], sizes)
+ (digits:groups, []) -> ((digit:digits):groups, [])
+ (digits:groups, curr_sizes@(size:sizes)) ->
+ if List.length digits < size
+ then ( (digit:digits):groups, curr_sizes)
+ else ([digit]:[sep]:digits:groups, if List.null sizes then curr_sizes else sizes)
+ ))
+ ([], sizes_)
+ del_grouping_sep grouping =
+ case grouping of
+ S.Just (Style_Amount_Grouping sep _) -> List.delete sep
+ _ -> id
+
+-- * Document 'Comment'
+d_comment (Comment com) =
+ D.cyan $
+ D.charH char_comment_prefix
+ <> (case Text.uncons com of
+ Just (c, _) | not $ Char.isSpace c -> D.space
+ _ -> D.empty)
+ <> D.textH com
+
+d_comments prefix =
+ D.catH .
+ List.intersperse D.eol .
+ List.map (\c -> prefix <> d_comment c)
+
+-- * Document 'Posting'
+d_posting ctx
+ Posting
+ { posting_account
+ , posting_account_ref
+ , posting_amounts
+ , posting_comments
+ -- , posting_dates
+ -- , posting_tags
+ } =
+ let d_indent = D.spaces 2 in
+ d_indent <>
+ let (doc_acct, w_acct) =
+ case posting_account_ref of
+ S.Just (a S.:!: sa) | context_write_account_ref ctx ->
+ ( d_account_ref a <> S.maybe D.empty d_account sa
+ , w_account_ref a + S.maybe 0 w_account sa )
+ _ -> (d_account posting_account, w_account posting_account) in
+ (case posting_amounts of
+ Amounts amts | Map.null amts -> doc_acct
+ Amounts amts ->
+ maybe D.empty id $
+ Map.foldlWithKey
+ (\mdoc unit qty -> Just $
+ let amt = styled_amount (context_write_amounts ctx) $ Amount unit qty in
+ let pad = max 0 $ context_write_width_acct_amt ctx - (w_acct + w_amount amt) in
+ (case mdoc of
+ Nothing -> D.empty
+ Just doc -> doc <> D.eol <> d_indent) <>
+ doc_acct <> D.spaces pad <> D.space <> d_amount amt
+ ) Nothing amts) <>
+ (case posting_comments of
+ [] -> D.empty
+ [c] -> D.space <> d_comment c
+ _ -> D.eol <> d_comments (d_indent <> D.space) posting_comments)
+w_posting ctx = D.width . D.dim . d_posting ctx
+
+-- * Document 'Transaction'
+d_transaction ctx
+ t@Transaction
+ { transaction_comments
+ , transaction_dates
+ , transaction_wording = Wording transaction_wording
+ , transaction_postings = Postings transaction_postings
+ , transaction_tags = Transaction_Tags (Tags tags)
+ } =
+ let ctx' = ctx { context_write_width_acct_amt =
+ let w = context_write_width_acct_amt ctx in
+ if w == 0
+ then w_postings_acct_amt ctx t
+ else w } in
+ D.catH (
+ List.intersperse
+ (D.charH char_transaction_date_sep)
+ (d_date <$> NonNull.toNullable transaction_dates)) <>
+ (case transaction_wording of
+ "" -> D.empty
+ _ -> D.space <> D.magenta (D.textH transaction_wording)) <>
+ D.eol <>
+ (case transaction_comments of
+ [] -> D.empty
+ _ -> d_comments D.space transaction_comments <> D.eol) <>
+ TreeMap.foldr_with_Path
+ (\path -> flip $
+ foldr (\value -> (<>) (D.spaces 2 <>
+ d_transaction_tag (Transaction_Tag (Tag (Tag_Path path) value)) <> D.eol)))
+ D.empty tags <>
+ D.catV (d_posting ctx' <$> Compose transaction_postings)
+
+d_transactions ctx j =
+ let ctx' = ctx{context_write_width_acct_amt =
+ foldr (max . w_postings_acct_amt ctx) 0 j} in
+ maybe D.empty id $
+ foldr (\t mdoc -> Just $
+ d_transaction ctx' t <>
+ case mdoc of
+ Nothing -> D.eol
+ Just doc -> D.eol <> D.eol <> doc
+ ) Nothing j
+
+-- w_postings ctx = MT.ofoldr (max . w_posting ctx) 0
+-- | Return the width of given 'Postings',
+-- considering only 'Account's and 'Amount's (not indentation, 'Comment's, nor 'Posting_Tag's).
+w_postings_acct_amt :: H.Get Postings a => Context_Write -> a -> Int
+w_postings_acct_amt ctx =
+ MT.ofoldr (\Posting
+ { posting_account
+ , posting_account_ref
+ , posting_amounts
+ } -> max $
+ let w_acct =
+ case posting_account_ref of
+ S.Just (a S.:!: sa) | context_write_account_ref ctx ->
+ w_account_ref a + S.maybe 0 w_account sa
+ _ -> w_account posting_account in
+ let w_amt =
+ case posting_amounts of
+ Amounts amts | Map.null amts -> 0
+ Amounts amts ->
+ Map.foldrWithKey
+ (\unit qty -> max $
+ let amt = styled_amount (context_write_amounts ctx) $ Amount unit qty in
+ w_amount amt)
+ 1 amts in
+ w_acct + w_amt
+ ) 0 .
+ H.get @Postings
+
+-- ** Document 'Transaction_Tag'
+d_transaction_tag (Transaction_Tag (Tag (Tag_Path path) (Tag_Data value))) =
+ D.catH (
+ (:) (op $ D.charH char_tag_prefix) $
+ List.intersperse
+ (op $ D.charH char_tag_sep)
+ (d_transaction_tag_section <$> NonNull.toNullable path)) <>
+ if Text.null value
+ then D.empty
+ else op (D.charH char_tag_data_prefix) <> D.textH value
+ where
+ op = D.yellower
+
+d_transaction_tag_section = D.bold . D.textH . unName
+
+-- * Document 'Journal'
+d_journal ctx jnl =
+ d_transactions ctx $
+ Compose $ journal_content jnl
+
+-- * Document 'Journals'
+d_journals ctx (Journals js) =
+ Map.foldl
+ (\doc j@Journal{journal_file=PathFile jf, journal_content=jc} ->
+ doc <>
+ d_comment (Comment $ Text.pack jf) <> D.eol <>
+ if null jc then D.empty else (D.eol <> d_journal ctx j)
+ ) D.empty js
+
+-- * Document 'Chart'
+d_chart =
+ TreeMap.foldl_with_Path
+ (\doc acct (Account_Tags (Tags ca)) ->
+ doc <>
+ d_account (H.get acct) <> D.eol <>
+ TreeMap.foldl_with_Path
+ (\doc' tp tvs ->
+ doc' <>
+ foldl'
+ (\doc'' tv ->
+ doc'' <> D.spaces 2 <>
+ d_account_tag (Account_Tag (Tag (Tag_Path tp) tv)) <>
+ D.eol)
+ D.empty
+ tvs)
+ D.empty
+ ca
+ ) D.empty .
+ chart_accounts
+
+-- * Document 'Terms'
+d_terms (ts::Terms) =
+ Map.foldl (\doc t -> doc <> D.text t <> D.eol) D.empty ts
+
+-- * Document 'Compta'
+d_compta ctx Compta
+ { compta_journals=js
+ , compta_chart=c@Chart{chart_accounts=ca}
+ , compta_style_amounts=amts
+ , compta_terms=ts
+ } =
+ (if null ts then D.empty else (d_terms ts <> D.eol)) <>
+ (if TreeMap.null ca then D.empty else (d_chart c <> D.eol)) <>
+ d_journals ctx{context_write_amounts=context_write_amounts ctx <> amts} js
+
+-- * Document 'SourcePos'
+d_sourcepos (SourcePos p (PosFile l) (PosFile c)) = do
+ content <- Enc.decodeUtf8 <$> BS.readFile p
+ let ls = Text.lines content
+ let ll = max 1 $ l - size_ctx
+ let qs =
+ List.take (intFrom $ (l - ll) + 1 + size_ctx) $
+ List.drop (intFrom $ ll-1) ls
+ let ns = show <$> List.take (List.length qs) [ll..]
+ let max_len_n = maximum $ 0 : (List.length <$> ns)
+ let ns' = (<$> ns) $ \n ->
+ List.replicate (max_len_n - List.length n) ' ' <> n
+ let quote =
+ D.catV $
+ List.zipWith (\(n, sn) q ->
+ D.spaces 2 <> D.blacker (D.stringH sn) <>
+ D.spaces 2 <> (if n == l then mark q else D.textH q)
+ ) (List.zip [ll..] ns') qs
+ return $ quote <> D.eol
+ where
+ size_ctx = 2
+ intFrom = fromInteger . toInteger
+ mark q =
+ let (b, a) = Text.splitAt (intFrom c - 1) q in
+ D.textH b <>
+ case Text.uncons a of
+ Nothing -> D.red D.space
+ Just (a0, a') -> D.red (D.charH a0) <> D.textH a'
import qualified System.Environment as Env
-- import qualified Text.Megaparsec as P
+import qualified Language.Symantic.Document as Doc
-- import Language.Symantic.Grammar
-- import Language.Symantic as Sym
-- import qualified Language.Symantic.Lib as Sym
import Hcompta.LCC.Megaparsec (showParseError)
-- import Hcompta.LCC.Grammar
import Hcompta.LCC.Read
-import Hcompta.LCC.Write
+import Hcompta.LCC.Document
-- import Control.Applicative (Applicative(..))
-- import Data.Functor (Functor(..))
readCompta @SRC @SS arg >>= \case
Left (Error_Read_Syntax err) ->
showParseError err >>=
- writeIO style_write stderr
+ (`Doc.ansiIO` stderr)
Left (Error_Read_Semantic err) -> error $ show err
Right r -> do
-- print r
- writeIO style_write stdout $
- write_compta context_write r
+ (`Doc.ansiIO` stdout) $
+ d_compta context_write r
printError :: Show err => Either err a -> IO a
printError (Left err) = error $ show err
import qualified System.Directory as IO
import qualified Text.Megaparsec as P
import qualified Text.Megaparsec.Prim as P
-import qualified Text.WalderLeijen.ANSI.Text as W
import Language.Symantic.Grammar as Sym
import qualified Language.Symantic as Sym
+import qualified Language.Symantic.Document as D
import Hcompta.LCC.Amount
import Hcompta.LCC.Chart
import Hcompta.LCC.Posting
import Hcompta.LCC.Journal
import Hcompta.LCC.Grammar as LCC
-import Hcompta.LCC.Write
+import Hcompta.LCC.Document
import Debug.Trace (trace)
import Data.Semigroup ((<>))
showParseError ::
( Ord t
, P.ShowToken t
- , P.ShowErrorComponent e )
- => P.ParseError t e
- -> IO W.Doc
+ , P.ShowErrorComponent e
+ , D.Doc_Text d
+ , D.Doc_Color d
+ , D.Doc_Decoration d
+ ) => P.ParseError t e -> IO d
showParseError err = do
let (pos:|_) = P.errorPos err
- q <- write_sourcepos $ sourcePos pos
- return $ W.vcat
- [ W.strict_text (Text.pack $ sourcePosStackPretty $ P.errorPos err) W.<> ":"
- , W.strict_text $ Text.pack $ parseErrorTextPretty err
+ q <- d_sourcepos $ sourcePos pos
+ return $ D.catV
+ [ D.stringH (sourcePosStackPretty $ P.errorPos err) <> ":"
+ , D.stringH $ parseErrorTextPretty err
, q
]
-- | Transforms list of error messages into their textual representation.
-
messageItemsPretty :: P.ShowErrorComponent a => String -> Set a -> String
messageItemsPretty prefix ts
| Set.null ts = ""
import Control.DeepSeq (NFData(..))
import Data.Data (Data(..))
import Data.Eq (Eq(..))
-import Data.Function (($), (.), flip)
+import Data.Function (($), (.), flip, id)
import Data.Functor ((<$>))
import Data.Functor.Compose (Compose(..))
import Data.Map.Strict (Map)
import qualified Hcompta as H
-import Hcompta.LCC.Account
-import Hcompta.LCC.Amount
-import Hcompta.LCC.Tag
+import Hcompta.LCC.Account
+import Hcompta.LCC.Amount
+import Hcompta.LCC.Tag
deriving instance (Data a, Data b) => Data (S.Pair a b)
instance (NFData a, NFData b) => NFData (S.Pair a b) where
deriving (Data, Eq, NFData, Ord, Show, Typeable)
unPostings :: Postings -> Map Account [Posting]
unPostings (Postings ps) = ps
+type instance H.Postings H.:@ Postings = Postings
+instance H.Get Postings Postings where
+ get = id
instance H.Postings Postings
instance Semigroup Postings where
Postings x <> Postings y =
ofoldr1Ex f = MT.ofoldr1Ex f . transaction_postings
ofoldl1Ex' f = MT.ofoldl1Ex' f . transaction_postings
+type instance H.Postings H.:@ Transaction = Postings
+instance H.Get Postings Transaction where
+ get = transaction_postings
+
type instance H.Date H.:@ Transaction = Date
instance H.GetI H.Date Transaction where
getI_ _ = NonNull.head . transaction_dates
+++ /dev/null
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MagicHash #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE NamedFieldPuns #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE TypeFamilies #-}
-module Hcompta.LCC.Write where
-
--- import Control.Monad (Monad)
--- import Data.Time.LocalTime (TimeZone(..))
--- import qualified Control.Monad.Classes as MC
--- import qualified Control.Monad.Trans.Reader as R
--- import qualified Data.Time.Calendar as Time
--- import qualified Data.Time.LocalTime as Time
-import Data.Bool
-import Data.Char (Char)
-import Data.Decimal
-import Data.Eq (Eq(..))
-import Data.Foldable (Foldable(..))
-import Data.Function (($), (.), flip, id)
-import Control.Monad (Monad(..))
-import Data.Functor ((<$>))
-import Data.Functor.Compose (Compose(..))
-import Data.Maybe (Maybe(..))
-import Data.Monoid ((<>))
-import Data.Ord (Ord(..))
-import Data.Tuple (fst)
-import GHC.Exts (Int(..))
-import GHC.Integer.Logarithms (integerLogBase#)
-import Prelude (Bounded(..), Integer, Num(..), RealFrac(..), Show(..), Integral(..), fromIntegral)
-import System.IO (IO, Handle)
-import Text.WalderLeijen.ANSI.Text (Doc)
-import qualified Data.Char as Char
-import qualified Data.List as List
-import qualified Data.Map.Strict as Map
-import qualified Data.MonoTraversable as MT
-import qualified Data.NonNull as NonNull
-import qualified Data.Strict as S
-import qualified Data.Text as Text
-import qualified Data.Text.Lazy as TL
-import qualified Data.TreeMap.Strict as TreeMap
-import qualified Text.WalderLeijen.ANSI.Text as W
-import qualified Data.ByteString as BS
-import qualified Data.Text.Encoding as Enc
-
-import qualified Hcompta as H
-
-import Hcompta.LCC.Account
-import Hcompta.LCC.Amount
-import Hcompta.LCC.Chart
-import Hcompta.LCC.Journal
-import Hcompta.LCC.Name
-import Hcompta.LCC.Posting
-import Hcompta.LCC.Tag
-import Hcompta.LCC.Transaction
-import Hcompta.LCC.Grammar
-import Hcompta.LCC.Compta
--- import qualified Hcompta.LCC.Lib.Strict as S
-
--- * Write 'Date'
-write_date :: Date -> Doc
-write_date dat =
- let (y, mo, d) = H.date_gregorian dat in
- (if y == 0 then W.empty else W.integer y <> sep char_ymd_sep) <>
- doc_int2 mo <>
- sep char_ymd_sep <> doc_int2 d <>
- (case H.date_tod dat of
- (0, 0, 0) -> W.empty
- (h, m, s) ->
- sep '_' <> doc_int2 h <>
- sep ':' <> doc_int2 m <>
- (case s of
- 0 -> W.empty
- _ -> sep ':' <>
- (if s < 10 then W.char '0' else W.empty) <>
- W.strict_text (Text.pack $ show $ (truncate s::Integer)))) {-<>
- (case tz_min of
- 0 -> W.empty
- _ | tz_name /= "" -> W.space <> do W.strict_text $ Text.pack tz_name
- _ -> W.space <> do W.strict_text $ Text.pack $ Time.timeZoneOffsetString tz)
- -}
- where
- doc_int2 :: Int -> Doc
- doc_int2 i = if i < 10 then W.char '0' <> W.int i else W.int i
- sep :: Char -> Doc
- sep = gray . W.char
-
-width_date :: Date -> Int
-width_date dat = do
- let (y, _, _) = H.date_gregorian dat
- (case y of
- 0 -> 0
- _ ->
- (if y < 0 then 1 else 0) -- sign
- + (1 + (I# (integerLogBase# 10 (abs y)))) -- year
- + 1) -- -
- + 2 -- month
- + 1 -- -
- + 2 -- dom
- + (case H.date_tod dat of
- (0, 0, 0) -> 0
- (_, _, s) ->
- 1 -- _
- + 2 -- hour
- + 1 -- :
- + 2 -- min
- + (case s of
- 0 -> 0
- _ -> 1 + 2 -- : sec
- )
- )
-
--- * Write 'Account'
-write_account :: Account -> Doc
-write_account =
- MT.ofoldMap $ \a ->
- gray (W.char char_account_sep) <>
- write_account_section a
-
-write_account_section :: Account_Section -> Doc
-write_account_section = W.strict_text . unName
-
-width_account :: Account -> Int
-width_account =
- MT.ofoldl'
- (\acc -> (1 +) . (acc +) . Text.length . unName)
- 0
-
--- ** Write 'Account_Ref'
-write_account_ref :: Tag_Path -> Doc
-write_account_ref (Tag_Path path) =
- W.hcat $
- (:) (op $ W.char char_account_tag_prefix) $
- List.intersperse
- (op $ W.char char_tag_sep)
- (W.strict_text . unName <$> NonNull.toNullable path)
- where op = W.bold . W.dullyellow
-
-width_account_ref :: Tag_Path -> Int
-width_account_ref (Tag_Path anch) =
- MT.ofoldl'
- (\acc -> (1 +) . (acc +) . MT.olength)
- 0 anch
-
--- ** Write 'Account_Tag'
-write_account_tag :: Account_Tag -> Doc
-write_account_tag (Account_Tag (Tag (Tag_Path path) (Tag_Data value))) =
- W.hcat (
- (:) (op $ W.char char_account_tag_prefix) $
- List.intersperse
- (op $ W.char char_tag_sep)
- (W.strict_text . unName <$> NonNull.toNullable path) ) <>
- if Text.null value
- then W.empty
- else
- op (W.char char_tag_data_prefix) <>
- W.strict_text value
- where op = W.bold . W.dullyellow
-
--- * Write 'Amount'
-write_amount :: Styled_Amount Amount -> Doc
-write_amount
- ( sty@(Style_Amount
- { style_amount_unit_side
- , style_amount_unit_spaced
- })
- , amt ) =
- let unt = amount_unit amt in
- case style_amount_unit_side of
- S.Just L ->
- write_unit unt <>
- case style_amount_unit_spaced of
- S.Just True | unt /= H.unit_empty -> W.space
- _ -> W.empty
- _ -> W.empty
- <> write_quantity (sty, amount_quantity amt)
- <> case style_amount_unit_side of
- (S.Just R) ->
- (case style_amount_unit_spaced of
- S.Just True | unt /= H.unit_empty -> W.space
- _ -> W.empty) <>
- write_unit unt
- S.Nothing ->
- (case style_amount_unit_spaced of
- S.Just True | unt /= H.unit_empty -> W.space
- _ -> W.empty) <>
- write_unit unt
- _ -> W.empty
-
-width_amount :: Styled_Amount Amount -> Int
-width_amount (sty@(Style_Amount { style_amount_unit_spaced }), amt) =
- let unit = amount_unit amt in
- width_unit unit
- + (case style_amount_unit_spaced of
- S.Just True | unit /= H.unit_empty -> 1
- _ -> 0)
- + width_quantity sty (amount_quantity amt)
-
--- * Write 'Unit'
-write_unit :: Unit -> Doc
-write_unit u =
- let t = H.unit_text u in
- W.yellow $
- if Text.all
- (\c -> case Char.generalCategory c of
- Char.CurrencySymbol -> True
- Char.LowercaseLetter -> True
- Char.ModifierLetter -> True
- Char.OtherLetter -> True
- Char.TitlecaseLetter -> True
- Char.UppercaseLetter -> True
- _ -> False
- ) t
- then W.strict_text t
- else W.hcat $ W.strict_text <$> ["\"", t, "\""]
-
-width_unit :: Unit -> Int
-width_unit u =
- let t = H.unit_text u in
- Text.length t +
- if Text.all
- (\c -> case Char.generalCategory c of
- Char.CurrencySymbol -> True
- Char.LowercaseLetter -> True
- Char.ModifierLetter -> True
- Char.OtherLetter -> True
- Char.TitlecaseLetter -> True
- Char.UppercaseLetter -> True
- _ -> False) t
- then 0
- else 2
-
--- * Write 'Quantity'
-write_quantity :: Styled_Amount Quantity -> Doc
-write_quantity
- ( Style_Amount
- { style_amount_fractioning
- , style_amount_grouping_integral
- , style_amount_grouping_fractional
- }
- , qty ) = do
- let Decimal e n = qty
- let num = show $ abs $ n
- let sign = W.bold $ W.yellow $ W.strict_text (if n < 0 then "-" else "")
- if e == 0
- then sign <> W.bold (W.blue $ W.strict_text $ Text.pack num)
- else do
- let num_len = List.length num
- let padded =
- List.concat
- [ List.replicate (fromIntegral e + 1 - num_len) '0'
- , num
- -- , replicate (fromIntegral precision - fromIntegral e) '0'
- ]
- let (int, frac) = List.splitAt (max 1 (num_len - fromIntegral e)) padded
- let default_fractioning =
- List.head $
- del_grouping_sep style_amount_grouping_integral $
- del_grouping_sep style_amount_grouping_fractional $
- ['.', ',']
- sign <>
- W.bold (W.blue $
- W.text (TL.pack $ S.maybe id
- (\g -> List.reverse . group g . List.reverse)
- style_amount_grouping_integral $ int) <>
- W.yellow (W.char (S.fromMaybe default_fractioning style_amount_fractioning)) <>
- W.text (TL.pack $ S.maybe id group style_amount_grouping_fractional frac))
- where
- group :: Style_Amount_Grouping -> [Char] -> [Char]
- group (Style_Amount_Grouping sep sizes_) =
- List.concat . List.reverse .
- List.map List.reverse . fst .
- List.foldl'
- (flip (\digit x -> case x of
- ([], sizes) -> ([[digit]], sizes)
- (digits:groups, []) -> ((digit:digits):groups, [])
- (digits:groups, curr_sizes@(size:sizes)) ->
- if List.length digits < size
- then ( (digit:digits):groups, curr_sizes)
- else ([digit]:[sep]:digits:groups, if List.null sizes then curr_sizes else sizes)
- ))
- ([], sizes_)
- del_grouping_sep grouping =
- case grouping of
- S.Just (Style_Amount_Grouping sep _) -> List.delete sep
- _ -> id
-
-width_quantity :: Style_Amount -> Quantity -> Int
-width_quantity Style_Amount
- { style_amount_grouping_integral
- , style_amount_grouping_fractional
- } qty =
- let Decimal e n = qty in
- let sign_len = if n < 0 then 1 else 0 in
- let fractioning_len = if e > 0 then 1 else 0 in
- let num_len = if n == 0 then 0 else (1 +) $ I# (integerLogBase# 10 (abs n)) in
- let pad_left_len = max 0 (fromIntegral e + 1 - num_len) in
- -- let pad_right_len = max 0 (fromIntegral precision - fromIntegral e) in
- let padded_len = pad_left_len + num_len {-+ pad_right_len-} in
- let int_len = max 1 (num_len - fromIntegral e) in
- let frac_len = max 0 (padded_len - int_len) in
- ( sign_len
- + fractioning_len
- + padded_len
- + S.maybe 0 (group int_len) style_amount_grouping_integral
- + S.maybe 0 (group frac_len) style_amount_grouping_fractional
- )
- where
- group :: Int -> Style_Amount_Grouping -> Int
- group num_len (Style_Amount_Grouping _sep sizes_) =
- if num_len <= 0
- then 0
- else loop 0 num_len sizes_
- where
- loop :: Int -> Int -> [Int] -> Int
- loop pad len x =
- case x of
- [] -> 0
- sizes@[size] ->
- let l = len - size in
- if l <= 0 then pad
- else loop (pad + 1) l sizes
- size:sizes ->
- let l = len - size in
- if l <= 0 then pad
- else loop (pad + 1) l sizes
-
--- * Write 'Comment'
-write_comment :: Comment -> Doc
-write_comment (Comment com) =
- W.cyan $
- W.char char_comment_prefix
- <> (case Text.uncons com of
- Just (c, _) | not $ Char.isSpace c -> W.space
- _ -> W.empty)
- <> W.strict_text com
-
-write_comments :: Doc -> [Comment] -> Doc
-write_comments prefix =
- W.hcat .
- List.intersperse W.line .
- List.map (\c -> prefix <> write_comment c)
-
--- * Write 'Posting'
-write_posting
- :: Context_Write
- -> Posting -> Doc
-write_posting ctx
- Posting
- { posting_account
- , posting_account_ref
- , posting_amounts
- , posting_comments=cmts
- -- , posting_dates
- -- , posting_tags
- } =
- W.string " " <>
- let (doc_acct, wi_acct) =
- case posting_account_ref of
- S.Just (a S.:!: sa) | context_write_account_ref ctx ->
- ( write_account_ref a <> S.maybe W.empty write_account sa
- , width_account_ref a + S.maybe 0 width_account sa )
- _ ->
- ( write_account posting_account
- , width_account posting_account ) in
- (case posting_amounts of
- Amounts amts | Map.null amts -> doc_acct
- Amounts amts ->
- Map.foldlWithKey
- (\doc unit qty ->
- let amt = styled_amount (context_write_amounts ctx) $ Amount unit qty in
- let wi_amt = width_amount amt in
- doc <>
- (if W.is_empty doc then W.empty else W.line <> W.string " ") <>
- doc_acct <>
- W.fill (context_write_max_posting_width ctx - (wi_acct + wi_amt)) W.space <>
- write_amount amt
- ) W.empty amts) <>
- (case cmts of
- [] -> W.empty
- [c] -> W.space <> write_comment c
- _ -> W.line <> write_comments (W.text " ") cmts)
-
--- ** Type 'Widths_Posting'
-type Widths_Posting = Int
-
-widths_postings
- :: Context_Write
- -> Postings
- -> Widths_Posting
-widths_postings ctx (Postings ps) =
- foldr (\p -> max $
- ((case posting_account_ref p of
- S.Just (a S.:!: sa) | context_write_account_ref ctx ->
- width_account_ref a +
- S.maybe 0 width_account sa
- _ -> width_account (posting_account p)
- ) +) $
- (\len -> if len > 0 then 1 + len else len) $
- Map.foldrWithKey
- (\unit qty -> max $
- width_amount $
- styled_amount (context_write_amounts ctx) $
- Amount unit qty)
- 0 (unAmounts $ posting_amounts p)
- ) 0
- (Compose ps)
-
--- * Write 'Transaction'
-write_transaction
- :: Context_Write
- -> Transaction -> Doc
-write_transaction ctx
- t@Transaction
- { transaction_comments
- , transaction_dates
- , transaction_wording = Wording transaction_wording
- , transaction_postings = Postings transaction_postings
- , transaction_tags = Transaction_Tags (Tags tags)
- } =
- let ctx' = ctx { context_write_max_posting_width =
- let wi = context_write_max_posting_width ctx in
- if wi == 0
- then widths_transaction ctx t
- else wi } in
- W.hcat (
- List.intersperse
- (W.char char_transaction_date_sep)
- (write_date <$> NonNull.toNullable transaction_dates)) <>
- (case transaction_wording of
- "" -> W.empty
- _ -> W.space <> W.dullmagenta (W.strict_text transaction_wording)) <>
- W.line <>
- (case transaction_comments of
- [] -> W.empty
- _ -> write_comments W.space transaction_comments <> W.line) <>
- TreeMap.foldr_with_Path
- (\path -> flip $
- foldr (\value -> (<>) (W.string " " <>
- write_transaction_tag (Transaction_Tag (Tag (Tag_Path path) value)) <> W.line)))
- W.empty tags <>
- W.intercalate W.line
- (W.vsep . (write_posting ctx' <$>))
- transaction_postings
-
-write_transactions
- :: Foldable j
- => Context_Write
- -> j Transaction -> Doc
-write_transactions ctx j =
- let ctx' = ctx{context_write_max_posting_width =
- foldr (max . widths_transaction ctx) 0 j} in
- foldr (\t doc ->
- write_transaction ctx' t <>
- (if W.is_empty doc then W.line else W.line <> W.line <> doc)
- ) W.empty j
-
--- ** Type 'Widths_Transaction'
-type Widths_Transaction = Widths_Posting
-
-widths_transaction :: Context_Write -> Transaction -> Widths_Posting
-widths_transaction ctx
- Transaction
- { transaction_postings
- } =
- foldr
- (max . widths_postings ctx)
- 0 [ transaction_postings ]
-
--- ** Write 'Transaction_Tag'
-write_transaction_tag :: Transaction_Tag -> Doc
-write_transaction_tag (Transaction_Tag (Tag (Tag_Path path) (Tag_Data value))) =
- W.hcat (
- (:) (W.bold $ W.dullyellow $ W.char char_tag_prefix) $
- List.intersperse
- (op $ W.char char_tag_sep)
- (write_transaction_tag_section <$> NonNull.toNullable path)) <>
- if Text.null value
- then W.empty
- else
- op (W.char char_tag_data_prefix) <>
- W.strict_text value
- where
- op = W.bold . W.yellow
-
-write_transaction_tag_section :: Name -> Doc
-write_transaction_tag_section = W.bold . W.strict_text . unName
-
--- * Write 'Journal'
-write_journal :: Foldable j => Context_Write -> Journal (j [Transaction]) -> Doc
-write_journal ctx jnl =
- write_transactions ctx $
- Compose $ journal_content jnl
-
--- * Write 'Journals'
-write_journals :: Foldable j => Context_Write -> Journals (j [Transaction]) -> Doc
-write_journals ctx (Journals js) =
- Map.foldl
- (\doc j@Journal{journal_file=PathFile jf, journal_content=jc} ->
- doc <>
- write_comment (Comment $ Text.pack jf) <> W.line <>
- if null jc then W.empty else (W.line <> write_journal ctx j)
- ) W.empty js
-
--- * Write 'Chart'
-write_chart :: Chart -> Doc
-write_chart =
- TreeMap.foldl_with_Path
- (\doc acct (Account_Tags (Tags ca)) ->
- doc <>
- write_account (H.get acct) <> W.line <>
- TreeMap.foldl_with_Path
- (\dd tp tvs ->
- dd <>
- foldl'
- (\ddd tv ->
- ddd <> W.string " " <>
- write_account_tag (Account_Tag (Tag (Tag_Path tp) tv)) <>
- W.line)
- W.empty
- tvs)
- W.empty
- ca
- ) W.empty .
- chart_accounts
-
--- * Write 'Terms'
-
-write_terms :: Terms -> Doc
-write_terms ts =
- Map.foldl
- (\doc t ->
- doc <>
- W.strict_text t <>
- W.line
- ) W.empty ts
-
--- * Write 'Compta'
-write_compta :: Context_Write -> Compta src ss -> Doc
-write_compta ctx Compta
- { compta_journals=js
- , compta_chart=c@Chart{chart_accounts=ca}
- , compta_style_amounts=amts
- , compta_terms=ts
- } =
- (if null ts then W.empty else (write_terms ts <> W.line)) <>
- (if TreeMap.null ca then W.empty else (write_chart c <> W.line)) <>
- write_journals ctx{context_write_amounts=context_write_amounts ctx <> amts} js
-
--- * Write 'SourcePos'
-write_sourcepos :: SourcePos -> IO Doc
-write_sourcepos (SourcePos p (PosFile l) (PosFile c)) = do
- content <- Enc.decodeUtf8 <$> BS.readFile p
- let ls = Text.lines content
- let ll = max 1 $ l - size_ctx
- let qs =
- List.take (intFrom $ (l - ll) + 1 + size_ctx) $
- List.drop (intFrom $ ll-1) ls
- let ns = show <$> List.take (List.length qs) [ll..]
- let max_len_n = maximum $ List.length <$> ns
- let ns' = (<$> ns) $ \n ->
- List.replicate (max_len_n - List.length n) ' ' <> n
- let quote =
- W.vcat $
- List.zipWith (\(n, sn) q ->
- " " <> gray (W.strict_text (Text.pack sn)) <>
- " " <> (if n == l then mark q else W.strict_text q)
- ) (List.zip [ll..] ns') qs
- return $ quote <> W.line
- where
- size_ctx = 2
- intFrom = fromInteger . toInteger
- mark q =
- let (b, a) = Text.splitAt (intFrom c - 1) q in
- W.strict_text b <>
- case Text.uncons a of
- Nothing -> red " "
- Just (a0, a') -> red (W.char a0) <> W.strict_text a'
-
-gray :: Doc -> Doc
-gray = W.bold . W.dullblack
-
-red :: Doc -> Doc
-red = W.onred
-
-
--- Type 'Context_Write'
-data Context_Write
- = Context_Write
- { context_write_account_ref :: Bool
- , context_write_amounts :: Style_Amounts
- , context_write_max_posting_width :: Int
- }
-
-context_write :: Context_Write
-context_write =
- Context_Write
- { context_write_account_ref = True
- , context_write_amounts = Style_Amounts Map.empty
- , context_write_max_posting_width = 0
- }
-
-{-
-type Style_Anchor = Bool
-type instance MC.CanDo (S.ReaderT Context_Write m) (MC.EffReader Context_Write) = 'True
-instance Monad m => MC.MonadReaderN 'MC.Zero Context_Write (S.ReaderT Context_Write m) where
- askN _px = S.ReaderT R.ask
-type instance MC.CanDo (S.ReaderT Context_Write m) (MC.EffReader Style_Anchor) = 'True
-instance Monad m => MC.MonadReaderN 'MC.Zero Style_Anchor (S.ReaderT Context_Write m) where
- askN _px = S.ReaderT $ R.asks $ Style_Anchor . context_write_account_ref
--}
-
--- * Type 'Style_Write'
-data Style_Write
- = Style_Write
- { style_write_align :: Bool
- , style_write_color :: Bool
- }
-style_write :: Style_Write
-style_write =
- Style_Write
- { style_write_align = True
- , style_write_color = True
- }
-
--- * Write
-write :: Style_Write -> Doc -> TL.Text
-write Style_Write
- { style_write_color
- , style_write_align } =
- W.displayT .
- if style_write_align
- then W.renderPretty style_write_color 1.0 maxBound
- else W.renderCompact style_write_color
-
-writeIO :: Style_Write -> Handle -> Doc -> IO ()
-writeIO Style_Write
- { style_write_color
- , style_write_align
- } handle doc =
- W.displayIO handle $
- if style_write_align
- then W.renderPretty style_write_color 1.0 maxBound doc
- else W.renderCompact style_write_color doc
Hcompta.LCC.Amount
Hcompta.LCC.Chart
Hcompta.LCC.Compta
+ Hcompta.LCC.Document
Hcompta.LCC.Grammar
Hcompta.LCC.Journal
Hcompta.LCC.Lib.FilePath
Hcompta.LCC.Sym.Zipper
Hcompta.LCC.Tag
Hcompta.LCC.Transaction
- Hcompta.LCC.Write
build-depends:
base >= 4.6 && < 5
, ansi-terminal >= 0.4 && < 0.7
, directory
, filepath
, hcompta-lib
- , integer-gmp
, mono-traversable
, monad-classes
, megaparsec
, safe-exceptions
, strict
, symantic
+ , symantic-document
, symantic-grammar
, symantic-lib
, text
, transformers >= 0.4 && < 0.6
-- NOTE: needed for Control.Monad.Trans.Except
, treemap
- , walderleijen-ansi-text
, unix
-- , fingertree
-- , parsec >= 3.1.2 && < 4
LambdaCase
MultiParamTypeClasses
NamedFieldPuns
+ NoImplicitPrelude
OverloadedStrings
PatternGuards
PolyKinds
, safe-exceptions
, semigroups
, symantic
+ , symantic-document
, symantic-lib
, symantic-grammar
, strict
- , symantic
-- , template-haskell
, text
, time
, transformers >= 0.4 && < 0.6
-- NOTE: needed for Control.Monad.Trans.Except
, treemap
- , walderleijen-ansi-text
Executable load
extensions:
LambdaCase
MultiParamTypeClasses
NamedFieldPuns
+ NoImplicitPrelude
OverloadedStrings
PatternGuards
PolyKinds
, safe-exceptions
, semigroups
, symantic
+ , symantic-document
, symantic-lib
, symantic-grammar
, strict
- , symantic
-- , template-haskell
, text
, time
, transformers >= 0.4 && < 0.6
-- NOTE: needed for Control.Monad.Trans.Except
, treemap
- , walderleijen-ansi-text
-- Test-Suite hcompta-cli-test
-- type: exitcode-stdio-1.0
-- , semigroups
-- , strict
-- , symantic
+-- , symantic-document
-- , symantic-grammar
-- , symantic-lib
-- , tasty >= 0.11
-- , time
-- , transformers >= 0.4 && < 0.6
-- , treemap
--- , walderleijen-ansi-text
extra-dep: true
- location: '/home/julm/work/pad/informatique/symantic/6/symantic'
extra-dep: true
+- location: '/home/julm/work/pad/informatique/symantic/6/symantic-document'
+ extra-dep: true
- location: '/home/julm/work/pad/informatique/symantic/6/symantic-grammar'
extra-dep: true
- location: '/home/julm/work/pad/informatique/symantic/6/symantic-lib'
sourcephile / git / comptalang.git / commitdiff