import Data.Semigroup (Semigroup(..))
import Data.Tuple (fst, uncurry)
import GHC.Exts (Int(..))
-import Prelude (Integer, Num(..), RealFrac(..), Show(..), Integral(..), fromIntegral)
+import Prelude (Integer, Num(..), RealFrac(..), Show(..), Integral(..), fromIntegral, toInteger)
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.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.Text.Encoding as Enc
import qualified Data.TreeMap.Strict as TreeMap
+import qualified Language.Symantic.Document.Term.Dimension as Dim
import qualified Language.Symantic.Document as D
import qualified Language.Symantic.Grammar as G
import qualified Language.Symantic as Sym
class Writeable d a where
write :: a -> d
-widthWrite :: Writeable D.Dim a => a -> Int
-widthWrite = D.width . D.dim . write
+widthWrite :: Writeable Dim.Dimension a => a -> Int
+widthWrite a =
+ case Dim.dim_width $ Dim.dim $ write a of
+ D.Nat i -> fromInteger i
-- 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
+-- * Type 'Reader'
+data Reader
+ = Reader
+ { reader_account_ref :: Bool
+ , reader_amounts :: Style_Amounts
+ , reader_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
+inh :: Reader
+inh =
+ Reader
+ { reader_account_ref = True
+ , reader_amounts = Style_Amounts Map.empty
+ , reader_width_acct_amt = 0
}
-instance (D.Doc_Text d, D.Doc_Color d) =>
+instance (D.Textable d, D.Colorable d, D.Indentable d) =>
Writeable d Date where
write dat =
let (y, mo, d) = H.gregorianOf dat in
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) =>
+instance (D.Textable d, D.Colorable d, D.Indentable d, Monoid d) =>
Writeable d Account where
write acct =
(`MT.ofoldMap` acct) $ \a ->
D.blacker (D.charH G.char_account_sep) <>
write a
-instance D.Doc_Text d =>
+instance D.Textable d =>
Writeable d NameAccount where
write = D.textH . unName
-instance (D.Doc_Text d, D.Doc_Color d) =>
+instance (D.Textable d, D.Colorable d, D.Indentable d) =>
Writeable d Tag_Path where
write (Tag_Path path) =
D.catH $
(:) (D.yellower $ D.charH G.char_account_tag_prefix) $
- L.intersperse
+ List.intersperse
(D.yellower $ D.charH G.char_tag_sep)
(D.textH . unName <$> NonNull.toNullable path)
-instance (D.Doc_Text d, D.Doc_Color d) =>
+instance (D.Textable d, D.Colorable d, D.Indentable d) =>
Writeable 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
+ List.intersperse
(D.yellower $ D.charH G.char_tag_sep)
(D.textH . unName <$> NonNull.toNullable path) ) <>
if T.null value
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) =>
+instance (D.Textable d, D.Colorable d, D.Indentable d, D.Decorable d) =>
Writeable d (Styled_Amount Amount) where
write
( sty@Style_Amount
_ -> D.empty) <>
write u
_ -> D.empty
-instance (D.Doc_Text d, D.Doc_Color d, D.Doc_Decoration d) =>
- Writeable (Context_Write -> d) Amount where
- write amt ctx =
- write (styled_amount (context_write_amounts ctx) amt)
-instance (D.Doc_Text d, D.Doc_Color d, D.Doc_Decoration d, Monoid d) =>
- Writeable (Context_Write -> d) Amounts where
- write (Amounts amts) ctx =
+instance (D.Textable d, D.Colorable d, D.Indentable d, D.Decorable d) =>
+ Writeable (Reader -> d) Amount where
+ write amt ro =
+ write (styled_amount (reader_amounts ro) amt)
+instance (D.Textable d, D.Colorable d, D.Indentable d, D.Decorable d, Monoid d) =>
+ Writeable (Reader -> d) Amounts where
+ write (Amounts amts) ro =
mconcat $
- L.intersperse " + " $
- ((`write` ctx) <$>) $
+ List.intersperse " + " $
+ ((`write` ro) <$>) $
uncurry Amount <$> Map.toList amts
-instance (D.Doc_Text d, D.Doc_Color d, D.Doc_Decoration d) =>
+instance (D.Textable d, D.Colorable d, D.Indentable d, D.Decorable d) =>
Writeable d Unit where
write (Unit t) =
D.yellower $
_ -> 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) =>
+ else D.between (D.charH '"') (D.charH '"') $ D.textH t
+instance (D.Textable d, D.Colorable d, D.Indentable d, D.Decorable d) =>
Writeable d (Styled_Amount Quantity) where
write
( Style_Amount
if e == 0
then sign <> D.bold (D.blue $ D.stringH num)
else do
- let num_len = L.length num
+ let num_len = List.length num
let padded =
- L.concat
- [ L.replicate (fromIntegral e + 1 - num_len) '0'
+ List.concat
+ [ List.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 (int, frac) = List.splitAt (max 1 (num_len - fromIntegral e)) padded
let default_fractioning =
- L.head $
+ 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 -> L.reverse . group g . L.reverse)
+ (\g -> List.reverse . group g . List.reverse)
style_amount_grouping_integral $ int) <>
D.yellower (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'
+ 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 L.length digits < size
+ if List.length digits < size
then ( (digit:digits):groups, curr_sizes)
- else ([digit]:[sep]:digits:groups, if L.null sizes then curr_sizes else 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 _) -> L.delete sep
+ S.Just (Style_Amount_Grouping sep _) -> List.delete sep
_ -> id
-instance (D.Doc_Text d, D.Doc_Color d) =>
+instance (D.Textable d, D.Colorable d, D.Indentable d) =>
Writeable d Comment where
write (Comment com) =
D.cyan $
Just (c, _) | not $ Char.isSpace c -> D.space
_ -> D.empty)
<> D.textH com
-instance (D.Doc_Text d, D.Doc_Color d) =>
+instance (D.Textable d, D.Colorable d, D.Indentable d) =>
Writeable d (d, [Comment]) where
write (prefix, com) =
D.catH $
- L.intersperse D.eol $
+ List.intersperse D.newline $
(\c -> prefix <> write c) <$> com
-instance (D.Doc_Text d, D.Doc_Color d, D.Doc_Decoration d, Monoid d) =>
- Writeable d (Context_Write, Posting src) where
- write (ctx, Posting
+instance (D.Textable d, D.Colorable d, D.Indentable d, D.Decorable d, Monoid d) =>
+ Writeable d (Reader, Posting src) where
+ write (ro, Posting
{ posting_account
, posting_account_ref
, posting_amounts
d_indent <>
let (d_acct, w_acct) =
case posting_account_ref of
- S.Just (a S.:!: sa) | context_write_account_ref ctx ->
+ S.Just (a S.:!: sa) | reader_account_ref ro ->
( write a <> S.maybe D.empty write sa
, widthWrite a + S.maybe 0 widthWrite sa )
_ -> (write posting_account, widthWrite posting_account) in
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
+ let amt = styled_amount (reader_amounts ro) $ Amount unit qty in
+ let pad = max 0 $ reader_width_acct_amt ro - (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
+ Just doc -> doc <> D.newline <> d_indent) <>
+ d_acct <> D.stringH ( List.replicate (pad) '_') <> D.space <> write amt
+ <> D.space <> D.stringH (show (reader_width_acct_amt ro, w_acct, widthWrite 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) =>
- Writeable d (Context_Write, Transaction src) where
- write (ctx,
+ _ -> D.newline <> write (d_indent <> D.space :: d, posting_comments))
+instance (D.Textable d, D.Colorable d, D.Indentable d, D.Decorable d, Monoid d) =>
+ Writeable d (Reader, Transaction src) where
+ write (ro,
txn@Transaction
{ transaction_comments
, transaction_dates
, 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
+ List.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 <>
+ D.newline <>
(case transaction_comments of
[] -> D.empty
- _ -> write (D.space :: d, transaction_comments) <> D.eol) <>
+ _ -> write (D.space :: d, transaction_comments) <> D.newline) <>
TreeMap.foldrWithPath
(\path -> flip $
foldr (\value -> (<>) (D.spaces 2 <>
- write (Transaction_Tag (Tag (Tag_Path path) value)) <> D.eol)))
+ write (Transaction_Tag (Tag (Tag_Path path) value)) <> D.newline)))
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) =>
- Writeable d (Context_Write, Transactions src) where
- write (ctx, Transactions txns) =
- let ctx' = ctx{context_write_width_acct_amt =
- foldr (max . w_Transaction ctx) 0 $ Compose txns} in
+ D.catV (write . (ro',) <$> Compose transaction_postings)
+ where
+ ro' = ro
+ { reader_width_acct_amt =
+ case reader_width_acct_amt ro of
+ 0 -> w_Transaction ro txn
+ w -> w
+ }
+instance (D.Textable d, D.Colorable d, D.Indentable d, D.Decorable d, Monoid d) =>
+ Writeable d (Reader, Transactions src) where
+ write (ro, Transactions txns) =
+ let ro' = ro{reader_width_acct_amt =
+ foldr (max . w_Transaction ro) 0 $ Compose txns} in
fromMaybe D.empty $
foldl (\mdoc txn -> Just $
- write (ctx', txn) <>
+ write (ro', txn) <>
case mdoc of
- Nothing -> D.eol
- Just doc -> D.eol <> D.eol <> doc
+ Nothing -> D.newline
+ Just doc -> D.newline <> D.newline <> doc
) Nothing (Compose txns)
-instance (D.Doc_Text d, D.Doc_Color d, D.Doc_Decoration d, Monoid d) =>
+instance (D.Textable d, D.Colorable d, D.Indentable d, D.Decorable d, Monoid d) =>
Writeable 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
+ List.intersperse
(D.yellower $ D.charH G.char_tag_sep)
(D.bold . D.textH . unName <$> NonNull.toNullable path)) <>
if T.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, Writeable d (ctx, j)) =>
- Writeable d (ctx, Journal src j) where
- write (ctx, Journal
+instance (D.Textable d, D.Colorable d, D.Indentable d, D.Decorable d, Monoid d, Writeable d (ro, j)) =>
+ Writeable d (ro, Journal src j) where
+ write (ro, Journal
{ journal_content
, journal_terms
, journal_chart
}) =
- (if null journal_terms then D.empty else (write journal_terms <> D.eol)) <>
- (if H.null journal_chart then D.empty else (write journal_chart <> D.eol)) <>
- write (ctx, journal_content)
-instance (D.Doc_Text d, D.Doc_Color d, D.Doc_Decoration d, Monoid d, Writeable d (ctx, j)) =>
- Writeable d (ctx, Journals src j) where
- write (ctx, Journals js) =
+ (if null journal_terms then D.empty else (write journal_terms <> D.newline)) <>
+ (if H.null journal_chart then D.empty else (write journal_chart <> D.newline)) <>
+ write (ro, journal_content)
+instance (D.Textable d, D.Colorable d, D.Indentable d, D.Decorable d, Monoid d, Writeable d (ro, j)) =>
+ Writeable d (ro, Journals src j) where
+ write (ro, Journals js) =
Map.foldl
(\doc j@Journal{journal_file=PathFile jf} ->
doc <>
- write (Comment $ T.pack jf) <> D.eol <>
- D.eol <> write (ctx, j)
+ write (Comment $ T.pack jf) <> D.newline <>
+ D.newline <> write (ro, j)
) D.empty js
-instance (D.Doc_Text d, D.Doc_Color d, D.Doc_Decoration d, Monoid d) =>
+instance (D.Textable d, D.Colorable d, D.Indentable d, D.Decorable d, Monoid d) =>
Writeable d Chart where
write =
TreeMap.foldlWithPath
(\doc acct (Account_Tags (Tags ca)) ->
doc <>
- write (H.to acct :: Account) <> D.eol <>
+ write (H.to acct :: Account) <> D.newline <>
TreeMap.foldlWithPath
(\doc' tp tvs ->
doc' <>
(\doc'' tv ->
doc'' <> D.spaces 2 <>
write (Account_Tag (Tag (Tag_Path tp) tv)) <>
- D.eol)
+ D.newline)
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) =>
+instance (D.Textable d, D.Colorable d, D.Indentable d, D.Decorable d, Monoid d) =>
Writeable d (Terms src) where
- write = Map.foldlWithKey (\doc n (G.At _src t) -> doc <> write n <> D.space <> D.text t <> D.eol) D.empty
-instance (D.Doc_Text d, D.Doc_Color d) => Writeable d (Sym.Mod Sym.NameTe) where
+ write = Map.foldlWithKey (\doc n (G.At _src t) -> doc <> write n <> D.space <> D.text t <> D.newline) D.empty
+instance (D.Textable d, D.Colorable d, D.Indentable d) =>
+ Writeable d (Sym.Mod Sym.NameTe) where
write (ms `Sym.Mod` Sym.NameTe n) =
D.catH $
- L.intersperse (D.charH '.') $
+ List.intersperse (D.charH '.') $
((\(Sym.NameMod m) -> D.textH m) <$> ms) <>
[(if isOp n then id else D.yellower) $ D.text n]
where
isOp = T.all $ \case '_' -> True; '\'' -> True; c -> Char.isAlphaNum c
-instance (D.Doc_Text d, D.Doc_Color d, D.Doc_Decoration d, Monoid d) => Writeable d (Context_Write, LCC src) where
- write (ctx, LCC
+instance (D.Textable d, D.Colorable d, D.Indentable d, D.Decorable d, Monoid d) =>
+ Writeable d (Reader, LCC src) where
+ write (ro, LCC
{ lcc_journals = js
, lcc_style = amts
}) =
- write (ctx{context_write_amounts = context_write_amounts ctx <> amts}, js)
-instance (D.Doc_Text d, D.Doc_Color d, D.Doc_Decoration d, Monoid d) => Writeable (Context_Write -> d) (LCC src) where
+ write (ro{reader_amounts = reader_amounts ro <> amts}, js)
+instance (D.Textable d, D.Colorable d, D.Indentable d, D.Decorable d, Monoid d) =>
+ Writeable (Reader -> d) (LCC src) where
write LCC
{ lcc_journals = js
, lcc_style = amts
- } ctx =
- write (ctx{context_write_amounts = context_write_amounts ctx <> amts}, js)
+ } ro =
+ write (ro{reader_amounts = reader_amounts ro <> amts}, js)
{-
-instance (D.Doc_Text d, D.Doc_Color d, D.Doc_Decoration d, Monoid d, Writeable d (Context_Write, j)) =>
- Writeable d (Context_Write, Compta src ss j) where
- write (ctx, Compta
+instance (D.Textable d, D.Colorable d, D.Indentable d, D.Decorable d, Monoid d, Writeable d (Reader, j)) =>
+ Writeable d (Reader, Compta src ss j) where
+ write (ro, 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)
+ (if null terms then D.empty else (write terms <> D.newline)) <>
+ (if TreeMap.null ca then D.empty else (write c <> D.newline)) <>
+ write (ro{reader_amounts = reader_amounts ro <> amts}, js)
-}
-instance (D.Doc_Text d, D.Doc_Color d, D.Doc_Decoration d) =>
+instance (D.Textable d, D.Colorable d, D.Indentable d, D.Decorable d) =>
Writeable (IO d) SourcePos where
write (SourcePos p (PosFile l) (PosFile c)) = do
content <- Enc.decodeUtf8 <$> BS.readFile p
let ls = T.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)
+ 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 ->
- L.replicate (max_len_n - L.length n) ' ' <> n
+ List.replicate (max_len_n - List.length n) ' ' <> n
let quote =
D.catV $
- L.zipWith (\(n, sn) q ->
+ 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)
- ) (L.zip [ll..] ns') qs
- return $ quote <> D.eol
+ ) (List.zip [ll..] ns') qs
+ return $ quote <> D.newline
where
size_ctx = 2
intFrom = fromInteger . toInteger
-- | 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 src -> Int
--- w_Postings ctx = MT.ofoldr (max . widthWrite ctx) 0
-w_Transaction ctx =
+w_Transaction :: Reader -> Transaction src -> Int
+-- w_Postings ro = MT.ofoldr (max . widthWrite ro) 0
+w_Transaction ro =
MT.ofoldr (\Posting
{ posting_account
, posting_account_ref
} -> max $
let w_Acct =
case posting_account_ref of
- S.Just (a S.:!: sa) | context_write_account_ref ctx ->
+ S.Just (a S.:!: sa) | reader_account_ref ro ->
widthWrite a + S.maybe 0 widthWrite sa
_ -> widthWrite posting_account in
let w_Amt =
Amounts amts ->
Map.foldrWithKey
(\unit qty -> max $
- let amt = styled_amount (context_write_amounts ctx) $ Amount unit qty in
+ let amt = styled_amount (reader_amounts ro) $ Amount unit qty in
widthWrite amt)
1 amts in
w_Acct + w_Amt
import Data.Semigroup (Semigroup(..))
import Data.Text (Text)
import Data.Tuple (curry)
-import Prelude (($), (.), Int, Integral(..), Num(..), fromIntegral, id, zipWith)
+import Prelude (($), (.), Int, Integral(..), Num(..), fromIntegral, id, zipWith, toInteger)
import Text.Show (Show)
import qualified Data.List as L
import qualified Data.Text as T
import Hcompta.LCC.Write.Compta
import qualified Language.Symantic.Document as D
+import qualified Language.Symantic.Document.Term.Dimension as Dim
--- * Type 'TablePlain'
-type TablePlain d = [ColumnPlain d]
+-- * Type 'Table'
+type Table d = [Column d]
-instance (D.Doc_Text d, D.Doc_Color d) => Writeable d (TablePlain d) where
+instance (D.Textable d, D.Colorable d, D.Indentable d) => Writeable d (Table d) where
write cols' =
let cols = refreshWidthCol <$> cols' in
- let rows = L.transpose $ columnPlain_rows <$> cols in
- let has_title = any (not . T.null . columnPlain_title) cols in
+ let rows = L.transpose $ column_rows <$> cols in
+ let has_title = any (not . T.null . column_title) cols in
let titles :: d = D.catH $ L.intersperse (d_sep '|') $ d_title <$> cols in
D.catV (
(if has_title then (:) titles else id) $
D.catH $
L.intersperse (D.space <> d_sep '|') $
((D.space <>) <$>) $
- zipWith (curry $ alignCellPlain Nothing) cols row
+ zipWith (curry $ alignCell Nothing) cols row
) <>
- (case cols of { [] -> D.empty; _ -> D.eol })
+ (case cols of { [] -> D.empty; _ -> D.newline })
where
- refreshWidthCol col@ColumnPlain{columnPlain_width=w} =
+ refreshWidthCol col@Column{column_width=w} =
if w == 0
- then col{columnPlain_width = widthCol col}
+ then col{column_width = widthCol col}
else col
where
- widthCol :: ColumnPlain d -> Int
- widthCol ColumnPlain
- { columnPlain_title
- , columnPlain_rows } =
- max (T.length columnPlain_title) $
- foldr (max . cellPlain_width) 0 columnPlain_rows
- d_title :: ColumnPlain d -> d
- d_title col@ColumnPlain{columnPlain_title} = do
+ widthCol :: Column d -> Int
+ widthCol Column
+ { column_title
+ , column_rows } =
+ max (T.length column_title) $
+ foldr (max . cell_width) 0 column_rows
+ d_title :: Column d -> d
+ d_title col@Column{column_title} = do
let pad len = D.blacker $ D.text $ T.pack $ L.replicate len '_'
- alignCellPlain (Just pad) (col, CellPlain
- { cellPlain_width = T.length columnPlain_title
- , cellPlain_content = d_under <> d_underline columnPlain_title <> d_under
- , cellPlain_align = Just AlignPlainC
+ alignCell (Just pad) (col, Cell
+ { cell_width = T.length column_title
+ , cell_content = d_under <> d_underline column_title <> d_under
+ , cell_align = Just AlignC
})
d_sep = D.blacker . D.charH
d_under = d_sep '_'
' ' -> d_under
c -> D.charH c
- alignCellPlain ::
- D.Doc_Text d =>
- D.Doc_Color d =>
+ alignCell ::
+ D.Textable d =>
+ D.Colorable d => D.Indentable d =>
Maybe (Int -> d) ->
- (ColumnPlain d, CellPlain d) -> d
- alignCellPlain may_padding
- ( ColumnPlain{columnPlain_align, columnPlain_width}
- , CellPlain{cellPlain_width, cellPlain_content, cellPlain_align} ) =
- let pad = columnPlain_width - cellPlain_width in
- case columnPlain_align `fromMaybe` cellPlain_align of
- AlignPlainL -> cellPlain_content <> padding pad
- AlignPlainC -> padding half <> cellPlain_content <> padding (pad - half)
+ (Column d, Cell d) -> d
+ alignCell may_padding
+ ( Column{column_align, column_width}
+ , Cell{cell_width, cell_content, cell_align} ) =
+ let pad = column_width - cell_width in
+ case column_align `fromMaybe` cell_align of
+ AlignL -> cell_content <> padding pad
+ AlignC -> padding half <> cell_content <> padding (pad - half)
where half = fromInteger $ quot (toInteger pad) 2
- AlignPlainR -> padding pad <> cellPlain_content
- where padding = D.spaces `fromMaybe` may_padding
- alignCellPlain _filling
- ( ColumnPlain{columnPlain_width}
- , CellPlain_Line{cellPlain_pad} ) =
+ AlignR -> padding pad <> cell_content
+ where padding = (D.spaces . D.Nat . toInteger) `fromMaybe` may_padding
+ alignCell _filling
+ ( Column{column_width}
+ , Cell_Line{cell_pad} ) =
D.blacker $ D.ltextH $
- TL.replicate (fromIntegral columnPlain_width) $
- TL.singleton cellPlain_pad
-
--- ** Class 'TablePlainOf'
-class TablePlainOf a d where
- tablePlainOf :: a -> TablePlain d
-
--- * Type 'ColumnPlain'
-data ColumnPlain d
- = ColumnPlain
- { columnPlain_title :: Text
- , columnPlain_align :: AlignPlain
- , columnPlain_width :: Int
- , columnPlain_rows :: [CellPlain d]
+ TL.replicate (fromIntegral column_width) $
+ TL.singleton cell_pad
+
+-- ** Class 'TableOf'
+class TableOf a d where
+ tableOf :: a -> Table d
+
+-- * Type 'Column'
+data Column d
+ = Column
+ { column_title :: Text
+ , column_align :: Align
+ , column_width :: Int
+ , column_rows :: [Cell d]
} deriving (Eq, Show)
-columnPlain :: Text -> AlignPlain -> [CellPlain d] -> ColumnPlain d
-columnPlain t a r =
- ColumnPlain
- { columnPlain_title = t
- , columnPlain_align = a
- , columnPlain_width = 0
- , columnPlain_rows = r
+column :: Text -> Align -> [Cell d] -> Column d
+column t a r =
+ Column
+ { column_title = t
+ , column_align = a
+ , column_width = 0
+ , column_rows = r
}
--- ** Type 'AlignPlain'
-data AlignPlain
- = AlignPlainL
- | AlignPlainC
- | AlignPlainR
+-- ** Type 'Align'
+data Align
+ = AlignL
+ | AlignC
+ | AlignR
deriving (Eq, Show)
--- ** Class 'columnPlainOf'
-class ColumnPlainOf a d where
- columnPlainOf :: a -> ColumnPlain d
-
--- * Type 'CellPlain'
-data CellPlain d
- = CellPlain { cellPlain_align :: Maybe AlignPlain
- , cellPlain_width :: Int
- , cellPlain_content :: d
- }
- | CellPlain_Line { cellPlain_pad :: Char
- , cellPlain_width :: Int
+-- ** Class 'columnOf'
+class ColumnOf a d where
+ columnOf :: a -> Column d
+
+-- * Type 'Cell'
+data Cell d
+ = Cell { cell_align :: Maybe Align
+ , cell_width :: Int
+ , cell_content :: d
+ }
+ | Cell_Line { cell_pad :: Char
+ , cell_width :: Int
}
deriving (Eq, Show)
--- ** Class 'CellPlainOf'
-class CellPlainOf a d where
- cellPlainOf :: a -> CellPlain d
- default cellPlainOf ::
- Writeable D.Dim a =>
+-- ** Class 'CellOf'
+class CellOf a d where
+ cellOf :: a -> Cell d
+ default cellOf ::
+ Writeable Dim.Dimension a =>
Writeable d a =>
- a -> CellPlain d
- cellPlainOf = cellPlain
-
-instance D.Doc_Text d => CellPlainOf () d where
- cellPlainOf () = CellPlain
- { cellPlain_width = 0
- , cellPlain_align = Nothing
- , cellPlain_content = D.empty
+ a -> Cell d
+ cellOf = cell
+
+instance D.Textable d => CellOf () d where
+ cellOf () = Cell
+ { cell_width = 0
+ , cell_align = Nothing
+ , cell_content = D.empty
}
-cellPlain ::
- Writeable D.Dim a =>
+cell ::
+ Writeable Dim.Dimension a =>
Writeable d a =>
- a -> CellPlain d
-cellPlain a =
- CellPlain
- { cellPlain_width = D.width $ D.dim $ write a
- , cellPlain_align = Nothing
- , cellPlain_content = write a
+ a -> Cell d
+cell a =
+ Cell
+ { cell_width = fromIntegral $ D.unNat $ Dim.dim_width $ Dim.dim $ write a
+ , cell_align = Nothing
+ , cell_content = write a
}
{-
-instance ToDoc ColumnPlain CellPlain where
- toDoc = alignCellPlain Nothing
+instance ToDoc Column Cell where
+ toDoc = alignCell Nothing
-- ** Class 'CellOf'
class CellOf context x where
- cellOf :: context -> x -> CellPlain
+ cellOf :: context -> x -> Cell
instance CellOf context x => CellOf context (Maybe x) where
- cellOf ctx = maybe cellPlain (cellOf ctx)
+ cellOf ctx = maybe cell (cellOf ctx)
-- ** Class 'Cell_of_forall_param'
-- for example in a class instance constraint
-- to keep the instance decidable (i.e. avoid UndecidableInstances).
class Cell_of_forall_param f x where
- cellPlain_of_forall_param :: forall m. f m -> x -> CellPlain
+ cell_of_forall_param :: forall m. f m -> x -> Cell
-- instance Cell_of_forall_param f x => CellOf (f m) x where
--- cellOf = cellPlain_of_forall_param
+-- cellOf = cell_of_forall_param
instance Cell_of_forall_param context x => Cell_of_forall_param context (Maybe x) where
- cellPlain_of_forall_param ctx = maybe cellPlain (cellPlain_of_forall_param ctx)
+ cell_of_forall_param ctx = maybe cell (cell_of_forall_param ctx)
-}
import qualified Text.Megaparsec as P
import Language.Symantic as Sym
-import qualified Language.Symantic.Document as D
+import qualified Language.Symantic.Document as Doc
+import qualified Language.Symantic.Document.Term.IO as DocIO
import qualified Language.Symantic.Grammar as G
import qualified Language.Symantic.Lib as Sym
import qualified Hcompta.LCC as LCC
import qualified Hcompta.LCC.Lib.Strict as S
import Hcompta.LCC.Read ()
-import Hcompta.LCC.Write (Writeable(..), context_write)
+import Hcompta.LCC.Write (Writeable(..))
+import Hcompta.LCC.Write as Write
-- dbg :: Show a => String -> a -> a
-- dbg msg x = trace (msg ++ " = " ++ show x) x
Either (Error_Term src) (TermVT src ss '[])
readTe = Sym.readTerm CtxTyZ
--- | Lifted 'D.ansiIO' on 'IO.stdout'. Helper.
-ansiIO :: MonadIO m => D.ANSI_IO -> m ()
-ansiIO = liftIO . (`D.ansiIO` IO.stdout)
+-- | Lifted 'Doc.ansiIO' on 'IO.stdout'. Helper.
+ansiIO :: MonadIO m => DocIO.TermIO -> m ()
+ansiIO = liftIO . DocIO.runTermIO IO.stdout
-- * Type 'Error_Eval'
data Error_Eval src
printTy ::
forall src ss m vs t d.
Source src =>
- D.Doc_Text d =>
- D.Doc_Color d =>
+ Doc.Textable d =>
+ Doc.Colorable d =>
MonadIO m =>
Type src vs t ->
S.StateT (LCC.State_Sym src ss) m d
Sym.config_Doc_Type
{ config_Doc_Type_vars_numbering = False
, config_Doc_Type_imports = impsTy
- } 0 ty <> D.eol
+ } 0 ty <> Doc.newline
printTe :: Source src => MonadIO m => Type src vs a -> a -> m ()
printTe aTy a =
case proveConstraint $ LCC.Sym.tyWriteable
(allocVarsR (lenVars aTy) $ LCC.Sym.tyContext_Write @_ @'[] ~> LCC.Sym.tyANSI_IO) aTy of
- Just Dict -> ansiIO $ write a context_write
+ Just Dict -> ansiIO $ write a Write.inh
Nothing -> liftIO $
case proveConstraint $ Sym.tyShow aTy of
Nothing -> putStrLn $ "No Show instance for type: " <> show aTy
docModules ::
Source src =>
- D.Doc_Text d =>
- D.Doc_Color d =>
- D.Doc_Decoration d =>
+ Doc.Textable d =>
+ Doc.Colorable d =>
+ Doc.Decorable d =>
ReadTe src ss =>
Sym.Imports Sym.NameTy ->
Sym.Modules src ss -> d
docModules imps (Sym.Modules mods) =
Map.foldrWithKey
(\p m doc -> docModule imps p m <> doc)
- D.empty
+ Doc.empty
mods
docModule ::
forall src ss d.
Source src =>
- D.Doc_Text d =>
- D.Doc_Color d =>
- D.Doc_Decoration d =>
+ Doc.Textable d =>
+ Doc.Colorable d =>
+ Doc.Decorable d =>
ReadTe src ss =>
Sym.Imports Sym.NameTy ->
Sym.PathMod -> Sym.Module src ss -> d
} doc ->
docPathTe m n <>
docFixy token_fixity <>
- D.space <> D.bold (D.yellower "::") <> D.space <>
+ Doc.space <> Doc.bold (Doc.yellower "::") <> Doc.space <>
docTokenTerm imps (t Sym.noSource) <>
- D.eol <> doc)
- D.empty
+ Doc.newline <> doc)
+ Doc.empty
docTokenTerm ::
forall src ss d.
Source src =>
- D.Doc_Text d =>
- D.Doc_Color d =>
+ Doc.Textable d =>
+ Doc.Colorable d =>
ReadTe src ss =>
Sym.Imports Sym.NameTy ->
Sym.Token_Term src ss -> d
, config_Doc_Type_imports = imps
} 0 $ Sym.typeOfTerm te
-docFixityInfix :: (D.Doc_Decoration t, D.Doc_Color t, D.Doc_Text t) => Infix -> t
+docFixityInfix :: (Doc.Decorable t, Doc.Colorable t, Doc.Textable t) => Infix -> t
docFixityInfix = \case
- Sym.Infix Nothing 5 -> D.empty
+ Sym.Infix Nothing 5 -> Doc.empty
Sym.Infix a p ->
let docAssoc = \case
Sym.AssocL -> "l"
Sym.AssocR -> "r"
Sym.AssocB Sym.SideL -> "l"
Sym.AssocB Sym.SideR -> "r" in
- D.magenta $ " infix" <> maybe D.empty docAssoc a <>
- D.space <> D.bold (D.bluer (D.int p))
-docFixityPrefix :: (D.Doc_Decoration t, D.Doc_Color t, D.Doc_Text t) => Unifix -> t
-docFixityPrefix p = D.magenta $ " prefix " <> D.bold (D.bluer (D.int $ Sym.unifix_prece p))
-docFixityPostfix :: (D.Doc_Decoration t, D.Doc_Color t, D.Doc_Text t) => Unifix -> t
-docFixityPostfix p = D.magenta $ " postfix " <> D.bold (D.bluer (D.int $ Sym.unifix_prece p))
+ Doc.magenta $ " infix" <> maybe Doc.empty docAssoc a <>
+ Doc.space <> Doc.bold (Doc.bluer (Doc.int p))
+docFixityPrefix :: (Doc.Decorable t, Doc.Colorable t, Doc.Textable t) => Unifix -> t
+docFixityPrefix p = Doc.magenta $ " prefix " <> Doc.bold (Doc.bluer (Doc.int $ Sym.unifix_prece p))
+docFixityPostfix :: (Doc.Decorable t, Doc.Colorable t, Doc.Textable t) => Unifix -> t
+docFixityPostfix p = Doc.magenta $ " postfix " <> Doc.bold (Doc.bluer (Doc.int $ Sym.unifix_prece p))
docPathTe ::
- D.Doc_Text d =>
- D.Doc_Color d =>
+ Doc.Textable d =>
+ Doc.Colorable d =>
PathMod -> NameTe -> d
docPathTe ms (NameTe n) =
- D.catH $
- L.intersperse (D.charH '.') $
- ((\(NameMod m) -> D.textH m) <$> ms) <>
- [(if isOp n then id else D.yellower) $ D.text n]
+ Doc.catH $
+ L.intersperse (Doc.charH '.') $
+ ((\(NameMod m) -> Doc.textH m) <$> ms) <>
+ [(if isOp n then id else Doc.yellower) $ Doc.text n]
where
isOp = T.all $ \case '_' -> True; '\'' -> True; c -> Char.isAlphaNum c
args <- Env.getArgs
let sym@(LCC.State_Sym (impsTy,_modsTy) (_impsTe,patchModsTe -> modsTe)) =
LCC.state_sym @LCC.Sym.SRC @LCC.Sym.SS
- (`D.ansiIO` IO.stderr) $ docModules impsTy modsTe
+ (`Doc.ansiIO` IO.stderr) $ docModules impsTy modsTe
let arg = Text.unwords $ Text.pack <$> args
ast <- printError $ parseTe sym arg
{-
sourcephile / git / comptalang.git / commitdiff