]> Git — Sourcephile - comptalang.git/blob - cli/Hcompta/CLI/Format.hs
Adapte hcompta-cli.
[comptalang.git] / cli / Hcompta / CLI / Format.hs
1 {-# LANGUAGE ConstraintKinds #-}
2 {-# LANGUAGE ExistentialQuantification #-}
3 {-# LANGUAGE FlexibleContexts #-}
4 {-# LANGUAGE FlexibleInstances #-}
5 {-# LANGUAGE MultiParamTypeClasses #-}
6 {-# LANGUAGE NamedFieldPuns #-}
7 {-# LANGUAGE OverloadedStrings #-}
8 {-# LANGUAGE Rank2Types #-}
9 {-# LANGUAGE ScopedTypeVariables #-}
10 {-# LANGUAGE TypeFamilies #-}
11 module Hcompta.CLI.Format where
12
13 import Control.Monad.Trans.Except (runExceptT)
14 import Data.Either (Either(..))
15 import Data.Function (($), (.))
16 import Data.Functor (Functor, (<$>))
17 import Data.Monoid (Monoid(..))
18 import System.IO (FilePath, IO)
19 import Text.Show (Show)
20 import qualified Text.Parsec.Error.Custom as R
21
22 import qualified Hcompta.CLI.Lang as Lang
23 import qualified Text.WalderLeijen.ANSI.Text as W
24
25 import qualified Hcompta.JCC as JCC
26 import qualified Hcompta.Ledger as Ledger
27
28 import Hcompta.Lib.Consable (Consable)
29 import qualified Hcompta.CLI.Lib.Leijen.Table as Leijen.Table
30
31 import Hcompta.CLI.Convert
32
33 -- * Type 'Format'
34
35 data Format jcc ledger
36 = Format_JCC jcc
37 | Format_Ledger ledger
38 deriving (Show)
39 type Formats = Format () ()
40
41 instance
42 ( Convert jcc ledger
43 , Convert ledger jcc
44 , Monoid jcc
45 , Monoid ledger
46 ) => Monoid (Format jcc ledger) where
47 mempty = Format_JCC mempty
48 mappend x y =
49 case x of
50 Format_JCC xj ->
51 Format_JCC $
52 case y of
53 Format_JCC yj -> mappend xj yj
54 Format_Ledger yj -> mappend xj (convert yj)
55 Format_Ledger xj ->
56 Format_Ledger $
57 case y of
58 Format_JCC yj -> mappend xj (convert yj)
59 Format_Ledger yj -> mappend xj yj
60
61 format :: Formats
62 format = Format_JCC ()
63
64 -- * Type family 'Journal_Account'
65 type family Journal_Account (j:: * -> *)
66 type instance Journal_Account JCC.Journal = JCC.Account
67 type instance Journal_Account Ledger.Journal = Ledger.Account
68
69 -- * Type family 'Journal_Account_Section'
70 type family Journal_Account_Section (j:: * -> *)
71 type instance Journal_Account_Section JCC.Journal = JCC.Account_Section
72 type instance Journal_Account_Section Ledger.Journal = Ledger.Account_Section
73
74 -- * Type family 'Journal_Charted'
75 type family Journal_Charted (j:: * -> *) :: * -> *
76 type instance Journal_Charted JCC.Journal = JCC.Charted
77 type instance Journal_Charted Ledger.Journal = Ledger.Charted
78
79 -- * Type family 'Journal_Quantity'
80 type family Journal_Quantity (j:: * -> *)
81 type instance Journal_Quantity JCC.Journal = JCC.Quantity
82 type instance Journal_Quantity Ledger.Journal = Ledger.Quantity
83
84 -- * Type family 'Journal_Unit'
85 type family Journal_Unit (j:: * -> *)
86 type instance Journal_Unit JCC.Journal = JCC.Unit
87 type instance Journal_Unit Ledger.Journal = Ledger.Unit
88
89 -- * Type family 'Journal_Posting'
90 type family Journal_Posting (j:: * -> *)
91 type instance Journal_Posting JCC.Journal = JCC.Posting
92 type instance Journal_Posting Ledger.Journal = Ledger.Posting
93
94 -- * Type family 'Journal_Transaction'
95 type family Journal_Transaction (j:: * -> *)
96 type instance Journal_Transaction JCC.Journal = JCC.Transaction
97 type instance Journal_Transaction Ledger.Journal = Ledger.Transaction
98
99 -- * Class 'Journal'
100
101 class Journal j where
102 type Journal_Format j
103 journal_format
104 :: j -> Journal_Format j
105
106 -- * Class 'Journal_Empty'
107
108 class Journal_Empty j where
109 journal_empty :: Formats -> j
110
111 -- * Class 'Journal_Files'
112
113 class Journal_Files j where
114 journal_files :: forall m. j m -> [FilePath]
115 instance Journal_Files JCC.Journal where
116 journal_files = JCC.journal_files
117 instance Journal_Files Ledger.Journal where
118 journal_files = Ledger.journal_files
119
120 -- * Class 'Journal_Read'
121
122 class Journal_Read (j:: * -> *) where
123 type Journal_Read_Error j
124 type Journal_Read_Transaction j
125 journal_read
126 :: forall c m. (Monoid m, Consable c m)
127 => (Journal_Read_Transaction j -> c)
128 -> FilePath
129 -> IO (Either (Journal_Read_Error j) (j m))
130 instance Journal_Read JCC.Journal where
131 type Journal_Read_Error JCC.Journal
132 = [R.Error JCC.Error_Read]
133 type Journal_Read_Transaction JCC.Journal
134 = JCC.Charted JCC.Transaction
135 journal_read cons =
136 runExceptT . JCC.read_file
137 (JCC.context_read cons JCC.journal)
138 instance Journal_Read Ledger.Journal where
139 type Journal_Read_Error Ledger.Journal
140 = [R.Error Ledger.Error_Read]
141 type Journal_Read_Transaction Ledger.Journal
142 = Ledger.Charted Ledger.Transaction
143 journal_read cons =
144 runExceptT . Ledger.read_file
145 (Ledger.context_read cons Ledger.journal)
146
147 {-
148 -- * Class 'Journal_Chart'
149
150 class Journal_Chart (j:: * -> *) where
151 journal_chart
152 :: forall m. j m
153 -> Chart.Chart (NonEmpty (Journal_Account_Section j))
154 instance Journal_Chart JCC.Journal where
155 journal_chart = JCC.journal_chart
156 instance Journal_Chart Ledger.Journal where
157 journal_chart = Ledger.journal_chart
158 -}
159
160 -- * Class 'Journal_Monoid'
161
162 class Journal_Monoid j where
163 journal_flatten :: j -> j
164 journal_fold :: (j -> a -> a) -> j -> a -> a
165 instance Monoid m => Journal_Monoid (JCC.Journal m) where
166 journal_flatten = JCC.journal_flatten
167 journal_fold = JCC.journal_fold
168 instance Monoid m => Journal_Monoid (Ledger.Journal m) where
169 journal_flatten = Ledger.journal_flatten
170 journal_fold = Ledger.journal_fold
171
172 -- * Class 'Journal_Filter'
173
174 class Functor j => Journal_Filter context j m where
175 journal_filter
176 :: context -> j m -> j m
177
178 -- * Class 'Journal_Functor'
179
180 class Journal_Functor x y where
181 journal_functor_map :: x -> y
182 journal_fmap :: forall j. Functor j => j x -> j y
183 journal_fmap = (journal_functor_map <$>)
184
185 -- * Class 'Journal_Table'
186
187 -- | A class to render a journal
188 -- into 'Leijen.Table.Cell's.
189 class Journal_Leijen_Table_Cells j m where
190 journal_leijen_table_cells
191 :: j m
192 -> [[Leijen.Table.Cell]]
193 -> [[Leijen.Table.Cell]]
194
195
196 -- * Class 'Journal_Wrap'
197
198 -- | A class dedicated to transform a journal
199 -- to another one using existential quantification
200 -- to gather multiple journals under a single type,
201 -- by writing instances between fully monomorphic types,
202 -- which ease a lot meeting the requirements
203 -- of the constraints in the wrap type.
204 class Journal_Wrap j wrap where
205 journal_wrap :: j -> wrap
206
207 class Journal_Content j where
208 journal_content :: forall m. j m -> m
209 instance Journal_Content JCC.Journal where
210 journal_content = JCC.journal_content
211 instance Journal_Content Ledger.Journal where
212 journal_content = Ledger.journal_content
213
214 -- * Type 'Message'
215
216 -- data Journal jnl m = forall j. jnl j => Journal (j m)
217 data Message w = forall msg. Lang.Translate msg w => Message msg
218 instance Lang.Translate (Message W.Doc) W.Doc where
219 translate lang (Message x) = Lang.translate lang x