From 7f915bb77f29b5339c2f94b84b7cb4a7e5f6574b Mon Sep 17 00:00:00 2001 From: Julien Moutinho <julm+hcompta@autogeree.net> Date: Wed, 12 Jul 2017 15:27:04 +0200 Subject: [PATCH] Gather into Writeable instances. --- lcc/Hcompta/LCC.hs | 6 +- lcc/Hcompta/LCC/Balance.hs | 44 +- lcc/Hcompta/LCC/Document.hs | 432 ----------------- lcc/Hcompta/LCC/Eval.hs | 2 +- lcc/Hcompta/LCC/Load.hs | 5 +- lcc/Hcompta/LCC/Read.hs | 10 +- .../LCC/{Grammar.hs => Read/Compta.hs} | 2 +- lcc/Hcompta/LCC/{ => Read}/Megaparsec.hs | 12 +- lcc/Hcompta/LCC/Sym/Account.hs | 8 +- lcc/Hcompta/LCC/Sym/Addable.hs | 4 +- lcc/Hcompta/LCC/Sym/Amount.hs | 4 +- lcc/Hcompta/LCC/Sym/Balance.hs | 4 +- lcc/Hcompta/LCC/Sym/Chart.hs | 4 +- lcc/Hcompta/LCC/Sym/Compta.hs | 4 +- lcc/Hcompta/LCC/Sym/Date.hs | 2 +- lcc/Hcompta/LCC/Sym/FileSystem.hs | 4 +- lcc/Hcompta/LCC/Sym/Journal.hs | 4 +- lcc/Hcompta/LCC/Sym/Negable.hs | 4 +- lcc/Hcompta/LCC/Sym/Posting.hs | 4 +- lcc/Hcompta/LCC/Sym/Quantity.hs | 6 +- lcc/Hcompta/LCC/Sym/Subable.hs | 4 +- lcc/Hcompta/LCC/Sym/Sumable.hs | 4 +- lcc/Hcompta/LCC/Sym/Transaction.hs | 4 +- lcc/Hcompta/LCC/Sym/Unit.hs | 4 +- lcc/Hcompta/LCC/Sym/Zeroable.hs | 4 +- lcc/Hcompta/LCC/Sym/Zipper.hs | 4 +- lcc/Hcompta/LCC/Write.hs | 5 + lcc/Hcompta/LCC/Write/Compta.hs | 433 ++++++++++++++++++ lcc/hcompta-lcc.cabal | 8 +- 29 files changed, 515 insertions(+), 520 deletions(-) delete mode 100644 lcc/Hcompta/LCC/Document.hs rename lcc/Hcompta/LCC/{Grammar.hs => Read/Compta.hs} (99%) rename lcc/Hcompta/LCC/{ => Read}/Megaparsec.hs (98%) create mode 100644 lcc/Hcompta/LCC/Write.hs create mode 100644 lcc/Hcompta/LCC/Write/Compta.hs diff --git a/lcc/Hcompta/LCC.hs b/lcc/Hcompta/LCC.hs index 969be50..3d99b7c 100644 --- a/lcc/Hcompta/LCC.hs +++ b/lcc/Hcompta/LCC.hs @@ -3,8 +3,6 @@ module Hcompta.LCC , 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.Posting @@ -12,14 +10,13 @@ module Hcompta.LCC , module Hcompta.LCC.Source , 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.Posting @@ -27,3 +24,4 @@ import Hcompta.LCC.Read import Hcompta.LCC.Source import Hcompta.LCC.Tag import Hcompta.LCC.Transaction +import Hcompta.LCC.Write diff --git a/lcc/Hcompta/LCC/Balance.hs b/lcc/Hcompta/LCC/Balance.hs index 990f85a..1bde32f 100644 --- a/lcc/Hcompta/LCC/Balance.hs +++ b/lcc/Hcompta/LCC/Balance.hs @@ -1,10 +1,22 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Hcompta.LCC.Balance where -import Data.Function (flip) +import Data.Ord (Ord) +import Data.Bool (Bool(..)) +import Data.Maybe (Maybe(..)) +import Data.Function (($), flip) import Data.Functor ((<$>)) import Data.Map.Strict (Map) -- import Data.Foldable (Foldable(..)) +-- import Data.Functor.Compose +-- import Data.Function ((.)) +import qualified Data.List as L +import qualified Data.MonoTraversable as MT +import qualified Data.TreeMap.Strict as TM +import qualified Data.Map.Strict as Map + +import qualified Language.Symantic.Document as D import qualified Hcompta as H @@ -14,13 +26,9 @@ import Hcompta.LCC.Posting import Hcompta.LCC.Transaction import Hcompta.LCC.Journal import Hcompta.LCC.Compta -{- -import Data.Functor.Compose -import Data.Function ((.)) --} -import qualified Data.MonoTraversable as MT +-- * Type 'Balance' type Balance = H.Balance NameAccount Unit (H.Polarized Quantity) type BalByAccount = H.BalByAccount NameAccount Unit (H.Polarized Quantity) type BalByUnit = H.BalByUnit NameAccount Unit (H.Polarized Quantity) @@ -43,30 +51,8 @@ instance H.Sumable Balance a => H.Sumable Balance (Compta src ss a) where instance H.Sumable Balance (Map Date [Transaction]) where bal += m = MT.ofoldr (flip (H.+=)) bal m +-- * Class 'Balanceable' type Balanceable = H.Sumable Balance balance :: Balanceable a => a -> Balance balance = H.sum -{- -consBal :: Posting -> Balance -> Balance -consBal = H.consBal - --- type instance H.Postings H.:@ Transaction = Postings --- instance H.Get (H.Balance_Amounts Unit Quantity) [Transaction] where --- get = transaction_postings - -balancePosting :: Posting -> Balance -> Balance -balancePosting = H.consBal -balanceTransaction :: Transaction -> Balance -> Balance -balanceTransaction = H.balance . transaction_postings -balancePostings :: Postings -> Balance -> Balance -balancePostings = H.balance -balanceTransactions :: [Transaction] -> Balance -> Balance -balanceTransactions = flip $ foldr H.balance - -balance :: Journal [Transaction] -> Balance -> Balance -balance = flip $ MT.ofoldr $ flip $ foldr H.balance - --- (Get (Balance_Account acct_sect) post, Get (Balance_Amounts unit qty) post, Addable qty, Ord acct_sect, Ord unit) => post -> Balance acct_sect unit qty -> Balance acct_sect unit qty --- balance_postings :: (post ~ Element posts, MonoFoldable posts, Get (Balance_Account acct_sect) post, Get (Balance_Amounts unit qty) post, Addable qty, Ord acct_sect, Ord unit) => posts -> Balance acct_sect unit qty -> Balance acct_sect unit qty ---} diff --git a/lcc/Hcompta/LCC/Document.hs b/lcc/Hcompta/LCC/Document.hs deleted file mode 100644 index f6e9d54..0000000 --- a/lcc/Hcompta/LCC/Document.hs +++ /dev/null @@ -1,432 +0,0 @@ -{-# LANGUAGE NoMonomorphismRestriction #-} -{-# OPTIONS_GHC -fno-warn-missing-signatures #-} -module Hcompta.LCC.Document where - -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(..), fromMaybe) -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.Compta -import Hcompta.LCC.IO -import Hcompta.LCC.Journal -import Hcompta.LCC.Name -import Hcompta.LCC.Posting -import Hcompta.LCC.Tag -import Hcompta.LCC.Transaction -import qualified Hcompta.LCC.Grammar as G - --- 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.gregorianOf dat in - (if y == 0 then D.empty else D.integer y <> sep G.char_ymd_sep) <> - int2 mo <> - sep G.char_ymd_sep <> int2 d <> - (case H.todOf 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 G.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 G.char_account_tag_prefix) $ - List.intersperse - (op $ D.charH G.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 G.char_account_tag_prefix) $ - List.intersperse - (op $ D.charH G.char_tag_sep) - (D.textH . unName <$> NonNull.toNullable path) ) <> - if Text.null value - then D.empty - else - op (D.charH G.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 | not (H.null u) -> D.space - _ -> D.empty - _ -> D.empty - <> d_quantity (sty, q) - <> case uside of - S.Just R -> - (case uspaced of - S.Just True | not (H.null u) -> D.space - _ -> D.empty) <> - d_unit u - S.Nothing -> - (case uspaced of - S.Just True | not (H.null u) -> D.space - _ -> D.empty) <> - d_unit u - _ -> D.empty -w_amount = D.width . D.dim . d_amount - --- * Document 'Unit' -d_unit (Unit t) = - 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 G.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 -> - fromMaybe D.empty $ - 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 G.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 - fromMaybe D.empty $ - 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 G.char_tag_prefix) $ - List.intersperse - (op $ D.charH G.char_tag_sep) - (d_transaction_tag_section <$> NonNull.toNullable path)) <> - if Text.null value - then D.empty - else op (D.charH G.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.to 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' diff --git a/lcc/Hcompta/LCC/Eval.hs b/lcc/Hcompta/LCC/Eval.hs index 617a002..af4d1e3 100644 --- a/lcc/Hcompta/LCC/Eval.hs +++ b/lcc/Hcompta/LCC/Eval.hs @@ -38,7 +38,7 @@ import qualified Language.Symantic.Lib as Sym import qualified Hcompta.LCC.Sym as LCC.Sym -- import qualified Hcompta.LCC as LCC -import Hcompta.LCC.Megaparsec () +import Hcompta.LCC.Read () -- dbg :: Show a => String -> a -> a -- dbg msg x = trace (msg ++ " = " ++ show x) x diff --git a/lcc/Hcompta/LCC/Load.hs b/lcc/Hcompta/LCC/Load.hs index a9ae1ed..040ae73 100644 --- a/lcc/Hcompta/LCC/Load.hs +++ b/lcc/Hcompta/LCC/Load.hs @@ -18,10 +18,9 @@ import qualified Language.Symantic.Document as Doc import qualified Language.Symantic as Sym import qualified Hcompta.LCC.Sym as LCC.Sym -import Hcompta.LCC.Megaparsec (showParseError) import Hcompta.LCC.Posting (SourcePos) import Hcompta.LCC.Read -import Hcompta.LCC.Document +import Hcompta.LCC.Write import Hcompta.LCC.Compta import Hcompta.LCC.Source import Hcompta.LCC.Sym.Compta () @@ -43,7 +42,7 @@ main = do print warns -- print r (`Doc.ansiIO` stdout) $ - d_compta context_write r + write (context_write, r) printError :: Show err => Either err a -> IO a printError (Left err) = error $ show err diff --git a/lcc/Hcompta/LCC/Read.hs b/lcc/Hcompta/LCC/Read.hs index c47ac69..4f2ed36 100644 --- a/lcc/Hcompta/LCC/Read.hs +++ b/lcc/Hcompta/LCC/Read.hs @@ -6,7 +6,11 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableSuperClasses #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -module Hcompta.LCC.Read where +module Hcompta.LCC.Read + ( module Hcompta.LCC.Read + , module Hcompta.LCC.Read.Compta + , module Hcompta.LCC.Read.Megaparsec + ) where import Control.Applicative (Applicative(..), (<*)) import Control.Monad (Monad(..)) @@ -43,8 +47,8 @@ import Hcompta.LCC.Transaction import Hcompta.LCC.IO -- import Hcompta.LCC.Sym.Compta () -import Hcompta.LCC.Grammar -import Hcompta.LCC.Megaparsec () +import Hcompta.LCC.Read.Compta +import Hcompta.LCC.Read.Megaparsec import qualified Hcompta.LCC.Lib.Strict as S import qualified Hcompta as H diff --git a/lcc/Hcompta/LCC/Grammar.hs b/lcc/Hcompta/LCC/Read/Compta.hs similarity index 99% rename from lcc/Hcompta/LCC/Grammar.hs rename to lcc/Hcompta/LCC/Read/Compta.hs index 6a7f45a..73e2164 100644 --- a/lcc/Hcompta/LCC/Grammar.hs +++ b/lcc/Hcompta/LCC/Read/Compta.hs @@ -2,7 +2,7 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE UndecidableSuperClasses #-} -module Hcompta.LCC.Grammar where +module Hcompta.LCC.Read.Compta where import Control.Applicative (Applicative(..), liftA2) import Control.Monad (Monad(..), void) diff --git a/lcc/Hcompta/LCC/Megaparsec.hs b/lcc/Hcompta/LCC/Read/Megaparsec.hs similarity index 98% rename from lcc/Hcompta/LCC/Megaparsec.hs rename to lcc/Hcompta/LCC/Read/Megaparsec.hs index 94d08ad..06dbb06 100644 --- a/lcc/Hcompta/LCC/Megaparsec.hs +++ b/lcc/Hcompta/LCC/Read/Megaparsec.hs @@ -1,7 +1,7 @@ {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | Symantic and LCC grammar instances for Megaparsec -module Hcompta.LCC.Megaparsec where +module Hcompta.LCC.Read.Megaparsec where import Control.Applicative (Applicative(..)) import Control.Monad (Monad(..)) @@ -17,7 +17,6 @@ import Data.Int (Int) import Data.List ((++)) import Data.List.NonEmpty (NonEmpty(..)) import Data.Maybe (Maybe(..)) -import Data.Monoid (Monoid(..)) import Data.Ord (Ord(..)) import Data.Set (Set) import Data.String (IsString(..), String) @@ -49,14 +48,15 @@ import qualified Language.Symantic.Document as D import Hcompta.LCC.Amount import Hcompta.LCC.Chart import Hcompta.LCC.Compta -import Hcompta.LCC.Document -import Hcompta.LCC.Grammar as LCC +import Hcompta.LCC.Write +import Hcompta.LCC.Read.Compta as LCC import Hcompta.LCC.IO -import Hcompta.LCC.Journal +-- import Hcompta.LCC.Journal import Hcompta.LCC.Posting import Debug.Trace (trace) import Data.Semigroup ((<>)) + dbg :: Show a => [Char] -> a -> a dbg msg x = trace (msg <> " = " <> show x) x @@ -400,7 +400,7 @@ showParseError :: ) => P.ParseError t e -> IO d showParseError err = do let (pos:|_) = P.errorPos err - q <- d_sourcepos $ sourcePos pos + q <- write $ sourcePos pos return $ D.catV [ D.stringH (sourcePosStackPretty $ P.errorPos err) <> ":" , D.stringH $ parseErrorTextPretty err diff --git a/lcc/Hcompta/LCC/Sym/Account.hs b/lcc/Hcompta/LCC/Sym/Account.hs index 6d81fec..c28df8c 100644 --- a/lcc/Hcompta/LCC/Sym/Account.hs +++ b/lcc/Hcompta/LCC/Sym/Account.hs @@ -37,7 +37,7 @@ instance (Sym_Account r1, Sym_Account r2) => Sym_Account (Dup r1 r2) where instance (Sym_Account term, Sym_Lambda term) => Sym_Account (BetaT term) instance NameTyOf Account where - nameTyOf _c = ["LCC"] `Mod` "Account" + nameTyOf _c = ["Account"] `Mod` "Account" instance ClassInstancesFor Account where proveConstraintFor _c (TyApp _ (TyConst _ _ q) c) | Just HRefl <- proj_ConstKiTy @(K Account) @Account c @@ -75,7 +75,7 @@ instance -- Gram_Term_AtomsFor Name . Text.pack <$> some (choice $ unicat <$> [Unicat_Letter]) instance (Source src, SymInj ss Account) => ModuleFor src ss Account where - moduleFor = ["LCC"] `moduleWhere` + moduleFor = ["Account"] `moduleWhere` [ ] @@ -94,7 +94,7 @@ instance Sym_Name View where instance (Sym_Name r1, Sym_Name r2) => Sym_Name (Dup r1 r2) where instance NameTyOf Name where - nameTyOf _c = ["LCC"] `Mod` "Name" + nameTyOf _c = ["Name"] `Mod` "Name" instance ClassInstancesFor Name where proveConstraintFor _c (TyApp _ (TyConst _ _ q) c) | Just HRefl <- proj_ConstKiTy @(K Name) @Name c @@ -111,6 +111,6 @@ instance TypeInstancesFor Name where expandFamFor _c _len _fam _as = Nothing instance Gram_Term_AtomsFor src ss g Name instance (Source src, SymInj ss Name) => ModuleFor src ss Name where - moduleFor = ["LCC"] `moduleWhere` + moduleFor = ["Name"] `moduleWhere` [ ] diff --git a/lcc/Hcompta/LCC/Sym/Addable.hs b/lcc/Hcompta/LCC/Sym/Addable.hs index bf40148..069707a 100644 --- a/lcc/Hcompta/LCC/Sym/Addable.hs +++ b/lcc/Hcompta/LCC/Sym/Addable.hs @@ -25,13 +25,13 @@ instance (Sym_Addable r1, Sym_Addable r2) => Sym_Addable (Dup r1 r2) where instance (Sym_Addable term, Sym_Lambda term) => Sym_Addable (BetaT term) instance NameTyOf Addable where - nameTyOf _c = ["LCC"] `Mod` "Addable" + nameTyOf _c = ["Addable"] `Mod` "Addable" instance FixityOf Addable instance ClassInstancesFor Addable instance TypeInstancesFor Addable instance Gram_Term_AtomsFor src ss g Addable instance (Source src, SymInj ss Addable) => ModuleFor src ss Addable where - moduleFor = ["LCC"] `moduleWhere` + moduleFor = ["Addable"] `moduleWhere` [ "+" `withInfixB` (SideL, 6) := teAddable_add ] diff --git a/lcc/Hcompta/LCC/Sym/Amount.hs b/lcc/Hcompta/LCC/Sym/Amount.hs index 44bf6f8..51b3e4e 100644 --- a/lcc/Hcompta/LCC/Sym/Amount.hs +++ b/lcc/Hcompta/LCC/Sym/Amount.hs @@ -48,7 +48,7 @@ instance (Sym_Amounts r1, Sym_Amounts r2) => Sym_Amounts (Dup r1 r2) where instance (Sym_Amounts term, Sym_Lambda term) => Sym_Amounts (BetaT term) instance NameTyOf Amounts where - nameTyOf _c = ["LCC"] `Mod` "Amounts" + nameTyOf _c = ["Amount"] `Mod` "Amounts" instance ClassInstancesFor Amounts where proveConstraintFor _ (TyApp _ (TyConst _ _ q) c) | Just HRefl <- proj_ConstKiTy @(K Amounts) @Amounts c @@ -64,7 +64,7 @@ instance TypeInstancesFor Amounts instance Gram_Term_AtomsFor meta ss g Amounts instance (Source src, SymInj ss Amounts, SymInj ss Unit) => ModuleFor src ss Amounts where - moduleFor = ["LCC"] `moduleWhere` + moduleFor = ["Amount"] `moduleWhere` [ NameTe n `WithFixity` Fixity1 (mkFixy side 10) := mkAmount nega u | (u, style_amount_unit_side -> S.Just side) <- Map.toList $ diff --git a/lcc/Hcompta/LCC/Sym/Balance.hs b/lcc/Hcompta/LCC/Sym/Balance.hs index 6c32837..767dd4c 100644 --- a/lcc/Hcompta/LCC/Sym/Balance.hs +++ b/lcc/Hcompta/LCC/Sym/Balance.hs @@ -30,7 +30,7 @@ instance (Sym_Balance r1, Sym_Balance r2) => Sym_Balance (Dup r1 r2) where instance (Sym_Balance term, Sym_Lambda term) => Sym_Balance (BetaT term) instance NameTyOf Balance where - nameTyOf _c = ["LCC"] `Mod` "Balance" + nameTyOf _c = ["Balance"] `Mod` "Balance" -- instance FixityOf Balance instance ClassInstancesFor Balance where proveConstraintFor _ (TyApp _ (TyConst _ _ q) b) @@ -42,7 +42,7 @@ instance ClassInstancesFor Balance where instance TypeInstancesFor Balance instance Gram_Term_AtomsFor src ss g Balance instance (Source src, SymInj ss Balance) => ModuleFor src ss Balance where - moduleFor = ["LCC"] `moduleWhere` + moduleFor = ["Balance"] `moduleWhere` [ "balance" := teBalance_balance ] diff --git a/lcc/Hcompta/LCC/Sym/Chart.hs b/lcc/Hcompta/LCC/Sym/Chart.hs index 8f706a4..7372343 100644 --- a/lcc/Hcompta/LCC/Sym/Chart.hs +++ b/lcc/Hcompta/LCC/Sym/Chart.hs @@ -28,7 +28,7 @@ instance (Sym_Chart r1, Sym_Chart r2) => Sym_Chart (Dup r1 r2) where instance (Sym_Chart term, Sym_Lambda term) => Sym_Chart (BetaT term) instance NameTyOf Chart where - nameTyOf _c = ["LCC"] `Mod` "Chart" + nameTyOf _c = ["Chart"] `Mod` "Chart" instance ClassInstancesFor Chart where proveConstraintFor _ (TyApp _ (TyConst _ _ q) a) | Just HRefl <- proj_ConstKiTy @(K Chart) @Chart a @@ -41,7 +41,7 @@ instance TypeInstancesFor Chart where instance Gram_Term_AtomsFor src ss g Chart instance (Source src, SymInj ss Chart) => ModuleFor src ss Chart where - moduleFor = ["LCC"] `moduleWhere` + moduleFor = ["Chart"] `moduleWhere` [ ] diff --git a/lcc/Hcompta/LCC/Sym/Compta.hs b/lcc/Hcompta/LCC/Sym/Compta.hs index 7def199..ba0d4e8 100644 --- a/lcc/Hcompta/LCC/Sym/Compta.hs +++ b/lcc/Hcompta/LCC/Sym/Compta.hs @@ -55,7 +55,7 @@ instance (Sym_Compta r1, Sym_Compta r2) => Sym_Compta (Dup r1 r2) where instance (Sym_Compta term, Sym_Lambda term) => Sym_Compta (BetaT term) instance (Typeable src, Typeable ss) => NameTyOf (Compta src ss) where - nameTyOf _c = ["LCC"] `Mod` "Compta" + nameTyOf _c = ["Compta"] `Mod` "Compta" instance FixityOf (Compta src ss) instance Comptable src ss => ClassInstancesFor (Compta src ss) where @@ -98,7 +98,7 @@ instance , Comptable src ss , SymInj (Proxy (Compta src ss) ': ss) (Compta src ss) ) => ModuleFor src (Proxy (Compta src ss) ': ss) (Compta src ss) where - moduleFor = ["LCC"] `moduleWhere` + moduleFor = ["Compta"] `moduleWhere` [ "chart" := teCompta_chart , "readCompta" := teCompta_readCompta ] diff --git a/lcc/Hcompta/LCC/Sym/Date.hs b/lcc/Hcompta/LCC/Sym/Date.hs index 20e6320..0fd165b 100644 --- a/lcc/Hcompta/LCC/Sym/Date.hs +++ b/lcc/Hcompta/LCC/Sym/Date.hs @@ -21,7 +21,7 @@ instance (Sym_Date r1, Sym_Date r2) => Sym_Date (Dup r1 r2) where instance (Sym_Date term, Sym_Lambda term) => Sym_Date (BetaT term) instance NameTyOf Date where - nameTyOf _c = ["LCC"] `Mod` "Date" + nameTyOf _c = ["Date"] `Mod` "Date" instance ClassInstancesFor Date where proveConstraintFor _ (TyApp _ (TyConst _ _ q) a) | Just HRefl <- proj_ConstKiTy @(K Date) @Date a diff --git a/lcc/Hcompta/LCC/Sym/FileSystem.hs b/lcc/Hcompta/LCC/Sym/FileSystem.hs index fec6479..7b86838 100644 --- a/lcc/Hcompta/LCC/Sym/FileSystem.hs +++ b/lcc/Hcompta/LCC/Sym/FileSystem.hs @@ -36,7 +36,7 @@ instance (Sym_PathFile r1, Sym_PathFile r2) => Sym_PathFile (Dup r1 r2) where instance (Sym_PathFile term, Sym_Lambda term) => Sym_PathFile (BetaT term) instance NameTyOf PathFile where - nameTyOf _c = ["LCC"] `Mod` "PathFile" + nameTyOf _c = ["FS"] `Mod` "PathFile" instance ClassInstancesFor PathFile where proveConstraintFor _ (TyApp _ (TyConst _ _ q) c) | Just HRefl <- proj_ConstKiTy @(K PathFile) @PathFile c @@ -70,7 +70,7 @@ instance -- Gram_Term_AtomsFor g_pathfile_section :: CF g FilePath g_pathfile_section = some (choice $ char '.' : (unicat <$> [Unicat_Letter, Unicat_Number])) instance (Source src, SymInj ss PathFile) => ModuleFor src ss PathFile where - moduleFor = ["LCC", "PathFile"] `moduleWhere` + moduleFor = ["FS", "PathFile"] `moduleWhere` [ ] diff --git a/lcc/Hcompta/LCC/Sym/Journal.hs b/lcc/Hcompta/LCC/Sym/Journal.hs index bb59d1d..beaf501 100644 --- a/lcc/Hcompta/LCC/Sym/Journal.hs +++ b/lcc/Hcompta/LCC/Sym/Journal.hs @@ -53,7 +53,7 @@ instance (Sym_Journal r1, Sym_Journal r2) => Sym_Journal (Dup r1 r2) where instance (Sym_Journal term, Sym_Lambda term) => Sym_Journal (BetaT term) instance NameTyOf Journal where - nameTyOf _c = ["LCC"] `Mod` "Journal" + nameTyOf _c = ["Journal"] `Mod` "Journal" instance FixityOf Journal instance ClassInstancesFor Journal where proveConstraintFor _ (TyApp _ tq@(TyConst _ _ q) (TyApp _ c j)) @@ -69,7 +69,7 @@ instance TypeInstancesFor Journal instance Gram_Term_AtomsFor src ss g Journal instance (Source src, SymInj ss Journal) => ModuleFor src ss Journal where - moduleFor = ["LCC", "Journal"] `moduleWhere` + moduleFor = ["Journal"] `moduleWhere` [ "file" := teJournal_file , "last_read_time" := teJournal_last_read_time , "content" := teJournal_content diff --git a/lcc/Hcompta/LCC/Sym/Negable.hs b/lcc/Hcompta/LCC/Sym/Negable.hs index 4ced187..d14fc0b 100644 --- a/lcc/Hcompta/LCC/Sym/Negable.hs +++ b/lcc/Hcompta/LCC/Sym/Negable.hs @@ -25,13 +25,13 @@ instance (Sym_Negable r1, Sym_Negable r2) => Sym_Negable (Dup r1 r2) where instance (Sym_Negable term, Sym_Lambda term) => Sym_Negable (BetaT term) instance NameTyOf Negable where - nameTyOf _c = ["LCC"] `Mod` "Negable" + nameTyOf _c = ["Negable"] `Mod` "Negable" instance FixityOf Negable instance ClassInstancesFor Negable instance TypeInstancesFor Negable instance Gram_Term_AtomsFor src ss g Negable instance (Source src, SymInj ss Negable) => ModuleFor src ss Negable where - moduleFor = ["LCC"] `moduleWhere` + moduleFor = ["Negable"] `moduleWhere` [ "-" `withPrefix` 10 := teNegable_neg ] diff --git a/lcc/Hcompta/LCC/Sym/Posting.hs b/lcc/Hcompta/LCC/Sym/Posting.hs index 5a89ec5..badeb60 100644 --- a/lcc/Hcompta/LCC/Sym/Posting.hs +++ b/lcc/Hcompta/LCC/Sym/Posting.hs @@ -40,7 +40,7 @@ instance (Sym_Posting r1, Sym_Posting r2) => Sym_Posting (Dup r1 r2) where instance (Sym_Posting term, Sym_Lambda term) => Sym_Posting (BetaT term) instance NameTyOf Posting where - nameTyOf _c = ["LCC"] `Mod` "Posting" + nameTyOf _c = ["Posting"] `Mod` "Posting" instance ClassInstancesFor Posting where proveConstraintFor _ (TyApp _ (TyConst _ _ q) c) | Just HRefl <- proj_ConstKiTy @(K Posting) @Posting c @@ -53,7 +53,7 @@ instance TypeInstancesFor Posting where instance Gram_Term_AtomsFor src ss g Posting instance (Source src, SymInj ss Posting) => ModuleFor src ss Posting where - moduleFor = ["LCC", "Posting"] `moduleWhere` + moduleFor = ["Posting"] `moduleWhere` [ "account" := tePosting_account , "amounts" := tePosting_amounts ] diff --git a/lcc/Hcompta/LCC/Sym/Quantity.hs b/lcc/Hcompta/LCC/Sym/Quantity.hs index 4cf5451..e31b51c 100644 --- a/lcc/Hcompta/LCC/Sym/Quantity.hs +++ b/lcc/Hcompta/LCC/Sym/Quantity.hs @@ -15,7 +15,7 @@ import qualified Data.Text as Text import Hcompta (Addable, Negable, Subable) import Hcompta.LCC.Amount -import Hcompta.LCC.Grammar +import Hcompta.LCC.Read.Compta import Language.Symantic.Grammar as Sym import Language.Symantic @@ -37,7 +37,7 @@ instance (Sym_Quantity r1, Sym_Quantity r2) => Sym_Quantity (Dup r1 r2) where instance (Sym_Quantity term, Sym_Lambda term) => Sym_Quantity (BetaT term) instance NameTyOf Quantity where - nameTyOf _c = ["LCC"] `Mod` "Quantity" + nameTyOf _c = ["Quantity"] `Mod` "Quantity" instance ClassInstancesFor Quantity where proveConstraintFor _c (TyApp _ (TyConst _ _ q) c) | Just HRefl <- proj_ConstKiTy @(K Quantity) @Quantity c @@ -74,7 +74,7 @@ instance -- Gram_Term_AtomsFor -- <*> option [] ((:) <$> char '.' <*> some (choice $ char <$> ['0'..'9'])) ] instance (Source src, SymInj ss Quantity) => ModuleFor src ss Quantity where - moduleFor = ["LCC"] `moduleWhere` + moduleFor = ["Quantity"] `moduleWhere` [ ] diff --git a/lcc/Hcompta/LCC/Sym/Subable.hs b/lcc/Hcompta/LCC/Sym/Subable.hs index c45a9a4..259d609 100644 --- a/lcc/Hcompta/LCC/Sym/Subable.hs +++ b/lcc/Hcompta/LCC/Sym/Subable.hs @@ -25,13 +25,13 @@ instance (Sym_Subable r1, Sym_Subable r2) => Sym_Subable (Dup r1 r2) where instance (Sym_Subable term, Sym_Lambda term) => Sym_Subable (BetaT term) instance NameTyOf Subable where - nameTyOf _c = ["LCC"] `Mod` "Subable" + nameTyOf _c = ["Subable"] `Mod` "Subable" instance FixityOf Subable instance ClassInstancesFor Subable instance TypeInstancesFor Subable instance Gram_Term_AtomsFor src ss g Subable instance (Source src, SymInj ss Subable) => ModuleFor src ss Subable where - moduleFor = ["LCC"] `moduleWhere` + moduleFor = ["Subable"] `moduleWhere` [ "-" `withInfixB` (SideL, 6) := teSubable_sub ] diff --git a/lcc/Hcompta/LCC/Sym/Sumable.hs b/lcc/Hcompta/LCC/Sym/Sumable.hs index 9ddf3c6..a2afbbb 100644 --- a/lcc/Hcompta/LCC/Sym/Sumable.hs +++ b/lcc/Hcompta/LCC/Sym/Sumable.hs @@ -25,13 +25,13 @@ instance (Sym_Sumable r1, Sym_Sumable r2) => Sym_Sumable (Dup r1 r2) where instance (Sym_Sumable term, Sym_Lambda term) => Sym_Sumable (BetaT term) instance NameTyOf Sumable where - nameTyOf _c = ["LCC"] `Mod` "Sumable" + nameTyOf _c = ["Sumable"] `Mod` "Sumable" instance FixityOf Sumable instance ClassInstancesFor Sumable instance TypeInstancesFor Sumable instance Gram_Term_AtomsFor src ss g Sumable instance (Source src, SymInj ss Sumable) => ModuleFor src ss Sumable where - moduleFor = ["LCC"] `moduleWhere` + moduleFor = ["Sumable"] `moduleWhere` [ "+=" `withInfixN` 4 := teSumable_incBy ] diff --git a/lcc/Hcompta/LCC/Sym/Transaction.hs b/lcc/Hcompta/LCC/Sym/Transaction.hs index 4093cd0..6524f6e 100644 --- a/lcc/Hcompta/LCC/Sym/Transaction.hs +++ b/lcc/Hcompta/LCC/Sym/Transaction.hs @@ -51,7 +51,7 @@ instance (Sym_Transaction r1, Sym_Transaction r2) => Sym_Transaction (Dup r1 r2) instance (Sym_Transaction term, Sym_Lambda term) => Sym_Transaction (BetaT term) instance NameTyOf Transaction where - nameTyOf _c = ["LCC"] `Mod` "Transaction" + nameTyOf _c = ["Transaction"] `Mod` "Transaction" instance ClassInstancesFor Transaction where proveConstraintFor _ (TyApp _ (TyConst _ _ q) c) | Just HRefl <- proj_ConstKiTy @(K Transaction) @Transaction c @@ -82,7 +82,7 @@ instance TypeInstancesFor Transaction instance Gram_Term_AtomsFor src ss g Transaction instance (Source src, SymInj ss Transaction) => ModuleFor src ss Transaction where - moduleFor = ["LCC"] `moduleWhere` + moduleFor = ["Transaction"] `moduleWhere` [ "date" := teTransaction_date , "postings" := teTransaction_postings ] diff --git a/lcc/Hcompta/LCC/Sym/Unit.hs b/lcc/Hcompta/LCC/Sym/Unit.hs index 5d04c91..c5bccb9 100644 --- a/lcc/Hcompta/LCC/Sym/Unit.hs +++ b/lcc/Hcompta/LCC/Sym/Unit.hs @@ -31,7 +31,7 @@ instance (Sym_Unit r1, Sym_Unit r2) => Sym_Unit (Dup r1 r2) where instance (Sym_Unit term, Sym_Lambda term) => Sym_Unit (BetaT term) instance NameTyOf Unit where - nameTyOf _c = ["LCC"] `Mod` "Unit" + nameTyOf _c = ["Unit"] `Mod` "Unit" instance ClassInstancesFor Unit where proveConstraintFor _c (TyApp _ (TyConst _ _ q) c) | Just HRefl <- proj_ConstKiTy @(K Unit) @Unit c @@ -44,7 +44,7 @@ instance ClassInstancesFor Unit where instance TypeInstancesFor Unit instance Gram_Term_AtomsFor src ss g Unit instance (Source src, SymInj ss Unit) => ModuleFor src ss Unit where - moduleFor = ["LCC"] `moduleWhere` + moduleFor = ["Unit"] `moduleWhere` [ ] diff --git a/lcc/Hcompta/LCC/Sym/Zeroable.hs b/lcc/Hcompta/LCC/Sym/Zeroable.hs index cce774c..940fea6 100644 --- a/lcc/Hcompta/LCC/Sym/Zeroable.hs +++ b/lcc/Hcompta/LCC/Sym/Zeroable.hs @@ -25,13 +25,13 @@ instance (Sym_Zeroable r1, Sym_Zeroable r2) => Sym_Zeroable (Dup r1 r2) where instance (Sym_Zeroable term, Sym_Lambda term) => Sym_Zeroable (BetaT term) instance NameTyOf Zeroable where - nameTyOf _c = ["LCC"] `Mod` "Zeroable" + nameTyOf _c = ["Zeroable"] `Mod` "Zeroable" instance FixityOf Zeroable instance ClassInstancesFor Zeroable instance TypeInstancesFor Zeroable instance Gram_Term_AtomsFor src ss g Zeroable instance (Source src, SymInj ss Zeroable) => ModuleFor src ss Zeroable where - moduleFor = ["LCC"] `moduleWhere` + moduleFor = ["Zeroable"] `moduleWhere` [ "zero" := teZeroable_zero ] diff --git a/lcc/Hcompta/LCC/Sym/Zipper.hs b/lcc/Hcompta/LCC/Sym/Zipper.hs index b35c96a..f8c5ce2 100644 --- a/lcc/Hcompta/LCC/Sym/Zipper.hs +++ b/lcc/Hcompta/LCC/Sym/Zipper.hs @@ -120,7 +120,7 @@ instance (Sym_Zipper r1, Sym_Zipper r2) => Sym_Zipper (Dup r1 r2) where instance (Sym_Zipper term, Sym_Lambda term) => Sym_Zipper (BetaT term) instance NameTyOf Zipper where - nameTyOf _c = ["LCC", "TreeMap", "Zipper"] `Mod` "Zipper" + nameTyOf _c = ["TreeMap", "Zipper"] `Mod` "Zipper" instance FixityOf Zipper instance ClassInstancesFor Zipper where proveConstraintFor _ (TyApp _ (TyConst _ _ _q) (TyApp _ c _k)) @@ -175,6 +175,6 @@ instance -- Gram_Term_AtomsFor <$> some (choice $ unicat <$> [Unicat_Letter]) -} instance (Source src, SymInj ss Zipper) => ModuleFor src ss Zipper where - moduleFor = ["LCC", "TreeMap", "Zipper"] `moduleWhere` + moduleFor = ["TreeMap", "Zipper"] `moduleWhere` [ ] diff --git a/lcc/Hcompta/LCC/Write.hs b/lcc/Hcompta/LCC/Write.hs new file mode 100644 index 0000000..3408674 --- /dev/null +++ b/lcc/Hcompta/LCC/Write.hs @@ -0,0 +1,5 @@ +module Hcompta.LCC.Write + ( module Hcompta.LCC.Write.Compta + ) where + +import Hcompta.LCC.Write.Compta diff --git a/lcc/Hcompta/LCC/Write/Compta.hs b/lcc/Hcompta/LCC/Write/Compta.hs new file mode 100644 index 0000000..4ff1793 --- /dev/null +++ b/lcc/Hcompta/LCC/Write/Compta.hs @@ -0,0 +1,433 @@ +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +module Hcompta.LCC.Write.Compta where + +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.Map.Strict (Map) +import Data.Maybe (Maybe(..), fromMaybe) +import Data.Monoid (Monoid(..)) +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 System.IO (IO) +import qualified Data.ByteString as BS +import qualified Data.Char as Char +import qualified Data.List as L +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.Compta +import Hcompta.LCC.IO +import Hcompta.LCC.Journal +import Hcompta.LCC.Name +import Hcompta.LCC.Posting +import Hcompta.LCC.Tag +import Hcompta.LCC.Transaction +import qualified Hcompta.LCC.Read.Compta as G + +-- * Class 'Writable' +class Writable d a where + write :: a -> d +-- widthWrite :: forall d a. Writable d a => a -> Integer +widthWrite = D.width . D.dim . write + +-- 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 + } + +instance (D.Doc_Text d, D.Doc_Color d) => + Writable d Date where + write dat = + let (y, mo, d) = H.gregorianOf dat in + (if y == 0 then D.empty else D.integer y <> sep G.char_ymd_sep) <> + int2 mo <> + sep G.char_ymd_sep <> int2 d <> + (case H.todOf 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 +instance (D.Doc_Text d, D.Doc_Color d, Monoid d) => + Writable d Account where + write acct = + (`MT.ofoldMap` acct) $ \a -> + D.blacker (D.charH G.char_account_sep) <> + write a +instance D.Doc_Text d => + Writable d NameAccount where + write = D.textH . unName +instance (D.Doc_Text d, D.Doc_Color d) => + Writable d Tag_Path where + write (Tag_Path path) = + D.catH $ + (:) (D.yellower $ D.charH G.char_account_tag_prefix) $ + L.intersperse + (D.yellower $ D.charH G.char_tag_sep) + (D.textH . unName <$> NonNull.toNullable path) +instance (D.Doc_Text d, D.Doc_Color d) => + Writable d Account_Tag where + write (Account_Tag (Tag (Tag_Path path) (Tag_Data value))) = + D.catH ( + (:) (D.yellower $ D.charH G.char_account_tag_prefix) $ + L.intersperse + (D.yellower $ D.charH G.char_tag_sep) + (D.textH . unName <$> NonNull.toNullable path) ) <> + if Text.null value + then D.empty + else + D.yellower (D.charH G.char_tag_data_prefix) <> + D.textH value +instance (D.Doc_Text d, D.Doc_Color d, D.Doc_Decoration d) => + Writable d (Styled_Amount Amount) where + write + ( sty@Style_Amount + { style_amount_unit_side = uside + , style_amount_unit_spaced = uspaced + } + , Amount u q + ) = + case uside of + S.Just L -> + write u <> + case uspaced of + S.Just True | not (H.null u) -> D.space + _ -> D.empty + _ -> D.empty + <> write (sty, q) + <> case uside of + S.Just R -> + (case uspaced of + S.Just True | not (H.null u) -> D.space + _ -> D.empty) <> + write u + S.Nothing -> + (case uspaced of + S.Just True | not (H.null u) -> D.space + _ -> D.empty) <> + write u + _ -> D.empty +instance (D.Doc_Text d, D.Doc_Color d, D.Doc_Decoration d) => + Writable d Unit where + write (Unit t) = + 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 +instance (D.Doc_Text d, D.Doc_Color d, D.Doc_Decoration d) => + Writable d (Styled_Amount Quantity) where + write + ( 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 = L.length num + let padded = + L.concat + [ L.replicate (fromIntegral e + 1 - num_len) '0' + , num + -- , replicate (fromIntegral precision - fromIntegral e) '0' + ] + let (int, frac) = L.splitAt (max 1 (num_len - fromIntegral e)) padded + let default_fractioning = + L.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 -> L.reverse . group g . L.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_) = + L.concat . L.reverse . + L.map L.reverse . fst . + L.foldl' + (flip (\digit x -> case x of + ([], sizes) -> ([[digit]], sizes) + (digits:groups, []) -> ((digit:digits):groups, []) + (digits:groups, curr_sizes@(size:sizes)) -> + if L.length digits < size + then ( (digit:digits):groups, curr_sizes) + else ([digit]:[sep]:digits:groups, if L.null sizes then curr_sizes else sizes) + )) + ([], sizes_) + del_grouping_sep grouping = + case grouping of + S.Just (Style_Amount_Grouping sep _) -> L.delete sep + _ -> id +instance (D.Doc_Text d, D.Doc_Color d) => + Writable d Comment where + write (Comment com) = + D.cyan $ + D.charH G.char_comment_prefix + <> (case Text.uncons com of + Just (c, _) | not $ Char.isSpace c -> D.space + _ -> D.empty) + <> D.textH com +instance (D.Doc_Text d, D.Doc_Color d) => + Writable d (d, [Comment]) where + write (prefix, com) = + D.catH $ + L.intersperse D.eol $ + (\c -> prefix <> write c) <$> com +instance (D.Doc_Text d, D.Doc_Color d, D.Doc_Decoration d, Monoid d) => + Writable d (Context_Write, Posting) where + write (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 (d_acct, w_acct) = + case posting_account_ref of + S.Just (a S.:!: sa) | context_write_account_ref ctx -> + ( write a <> S.maybe D.empty write sa + , widthWrite a + S.maybe 0 widthWrite sa ) + _ -> (write posting_account, widthWrite posting_account) in + (case posting_amounts of + Amounts amts | Map.null amts -> d_acct + Amounts amts -> + fromMaybe D.empty $ + 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 + widthWrite amt) in + (case mdoc of + Nothing -> D.empty + Just doc -> doc <> D.eol <> d_indent) <> + d_acct <> D.spaces pad <> D.space <> write amt + ) Nothing amts) <> + (case posting_comments of + [] -> D.empty + [c] -> D.space <> write c + _ -> D.eol <> write (d_indent <> D.space :: d, posting_comments)) +instance (D.Doc_Text d, D.Doc_Color d, D.Doc_Decoration d, Monoid d) => + Writable d (Context_Write, Transaction) where + write (ctx, + txn@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_Transaction ctx txn + else w } in + D.catH ( + L.intersperse + (D.charH G.char_transaction_date_sep) + (write <$> 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 + _ -> write (D.space :: d, transaction_comments) <> D.eol) <> + TreeMap.foldr_with_Path + (\path -> flip $ + foldr (\value -> (<>) (D.spaces 2 <> + write (Transaction_Tag (Tag (Tag_Path path) value)) <> D.eol))) + D.empty tags <> + D.catV (write . (ctx',) <$> Compose transaction_postings) +instance (D.Doc_Text d, D.Doc_Color d, D.Doc_Decoration d, Monoid d) => + Writable d (Context_Write, Map Date [Transaction]) where + write (ctx, txns) = + let ctx' = ctx{context_write_width_acct_amt = + foldr (max . w_Transaction ctx) 0 $ Compose txns} in + fromMaybe D.empty $ + foldl (\mdoc txn -> Just $ + write (ctx', txn) <> + case mdoc of + Nothing -> D.eol + Just doc -> D.eol <> D.eol <> doc + ) Nothing (Compose txns) +instance (D.Doc_Text d, D.Doc_Color d, D.Doc_Decoration d, Monoid d) => + Writable d Transaction_Tag where + write (Transaction_Tag (Tag (Tag_Path path) (Tag_Data value))) = + D.catH ( + (:) (D.yellower $ D.charH G.char_tag_prefix) $ + L.intersperse + (D.yellower $ D.charH G.char_tag_sep) + (D.bold . D.textH . unName <$> NonNull.toNullable path)) <> + if Text.null value + then D.empty + else D.yellower (D.charH G.char_tag_data_prefix) <> D.textH value +instance (D.Doc_Text d, D.Doc_Color d, D.Doc_Decoration d, Monoid d, Writable d (ctx, j)) => + Writable d (ctx, Journal j) where + write (ctx, jnl) = write (ctx, journal_content jnl) +instance (D.Doc_Text d, D.Doc_Color d, D.Doc_Decoration d, Monoid d, Writable d (ctx, j)) => + Writable d (ctx, Journals j) where + write (ctx, Journals js) = + Map.foldl + (\doc j@Journal{journal_file=PathFile jf} -> + doc <> + write (Comment $ Text.pack jf) <> D.eol <> + D.eol <> write (ctx, j) + ) D.empty js +instance (D.Doc_Text d, D.Doc_Color d, D.Doc_Decoration d, Monoid d) => + Writable d Chart where + write = + TreeMap.foldl_with_Path + (\doc acct (Account_Tags (Tags ca)) -> + doc <> + write (H.to acct :: Account) <> D.eol <> + TreeMap.foldl_with_Path + (\doc' tp tvs -> + doc' <> + foldl' + (\doc'' tv -> + doc'' <> D.spaces 2 <> + write (Account_Tag (Tag (Tag_Path tp) tv)) <> + D.eol) + D.empty + tvs) + D.empty + ca + ) D.empty . + chart_accounts +instance (D.Doc_Text d, D.Doc_Color d, D.Doc_Decoration d, Monoid d) => + Writable d Terms where + write (ts::Terms) = + Map.foldl (\doc t -> doc <> D.text t <> D.eol) D.empty ts +instance (D.Doc_Text d, D.Doc_Color d, D.Doc_Decoration d, Monoid d, Writable d (Context_Write, j)) => + Writable d (Context_Write, Compta src ss j) where + write (ctx, Compta + { compta_journals = js + , compta_chart = c@Chart{chart_accounts=ca} + , compta_style_amounts = amts + , compta_terms = terms + }) = + (if null terms then D.empty else (write terms <> D.eol)) <> + (if TreeMap.null ca then D.empty else (write c <> D.eol)) <> + write (ctx{context_write_amounts = context_write_amounts ctx <> amts}, js) +instance (D.Doc_Text d, D.Doc_Color d, D.Doc_Decoration d) => + Writable (IO d) SourcePos where + write (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 = + L.take (intFrom $ (l - ll) + 1 + size_ctx) $ + L.drop (intFrom $ ll-1) ls + let ns = show <$> L.take (L.length qs) [ll..] + let max_len_n = maximum $ 0 : (L.length <$> ns) + let ns' = (<$> ns) $ \n -> + L.replicate (max_len_n - L.length n) ' ' <> n + let quote = + D.catV $ + L.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) + ) (L.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' + +-- | Return the width of given 'Postings', +-- considering only 'Account's and 'Amount's (not indentation, 'Comment's, nor 'Posting_Tag's). +w_Transaction :: Context_Write -> Transaction -> Int +-- w_Postings ctx = MT.ofoldr (max . widthWrite ctx) 0 +w_Transaction 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 -> + widthWrite a + S.maybe 0 widthWrite sa + _ -> widthWrite 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 + widthWrite amt) + 1 amts in + w_Acct + w_Amt + ) 0 . + transaction_postings diff --git a/lcc/hcompta-lcc.cabal b/lcc/hcompta-lcc.cabal index 09cee68..269ddc4 100644 --- a/lcc/hcompta-lcc.cabal +++ b/lcc/hcompta-lcc.cabal @@ -83,16 +83,15 @@ Library Hcompta.LCC.Balance Hcompta.LCC.Chart Hcompta.LCC.Compta - Hcompta.LCC.Document - Hcompta.LCC.Grammar Hcompta.LCC.IO Hcompta.LCC.Journal Hcompta.LCC.Lib.FilePath Hcompta.LCC.Lib.Strict - Hcompta.LCC.Megaparsec Hcompta.LCC.Name Hcompta.LCC.Posting Hcompta.LCC.Read + Hcompta.LCC.Read.Compta + Hcompta.LCC.Read.Megaparsec Hcompta.LCC.Source Hcompta.LCC.Sym Hcompta.LCC.Sym.Account @@ -116,6 +115,9 @@ Library Hcompta.LCC.Sym.Zipper Hcompta.LCC.Tag Hcompta.LCC.Transaction + Hcompta.LCC.Write + Hcompta.LCC.Write.Compta + Hcompta.LCC.Write.Table build-depends: base >= 4.6 && < 5 , ansi-terminal >= 0.4 && < 0.7 -- 2.47.0