]> Git — Sourcephile - comptalang.git/blob - lcc/Hcompta/LCC/Read.hs
Remove cli/
[comptalang.git] / lcc / Hcompta / LCC / Read.hs
1 {-# LANGUAGE AllowAmbiguousTypes #-}
2 {-# LANGUAGE DataKinds #-}
3 {-# LANGUAGE GADTs #-}
4 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
5 {-# LANGUAGE RecordWildCards #-}
6 {-# LANGUAGE UndecidableInstances #-}
7 {-# LANGUAGE UndecidableSuperClasses #-}
8 {-# OPTIONS_GHC -fno-warn-orphans #-}
9 module Hcompta.LCC.Read
10 ( module Hcompta.LCC.Read
11 , module Hcompta.LCC.Read.Compta
12 , module Hcompta.LCC.Read.Megaparsec
13 ) where
14
15 import Control.Applicative (Applicative(..), (<*))
16 import Control.Monad (Monad(..))
17 import Data.Char (Char)
18 import Data.Either (Either(..))
19 import Data.Eq (Eq)
20 import Data.Function (($), (.))
21 import Data.Functor (Functor(..), (<$>))
22 import Data.Map.Strict (Map)
23 import Data.Maybe (Maybe(..))
24 import Data.Monoid (Monoid(..))
25 import Data.Semigroup (Semigroup(..))
26 import Data.Text (Text)
27 import Data.Typeable (Typeable, eqT)
28 import System.FilePath (FilePath)
29 import System.IO (IO, hPrint, stderr)
30 import Text.Show (Show(..))
31 import Prelude (error)
32 import qualified Data.ByteString as BS
33 import qualified Data.Map.Strict as Map
34 import qualified Data.Strict as S
35 import qualified Data.Text.Encoding as Enc
36 import qualified System.FilePath as FilePath
37 import qualified Text.Megaparsec as P
38
39 import Language.Symantic.Grammar
40 import qualified Language.Symantic as Sym
41 import Language.Symantic.Lib ()
42
43 import Hcompta.LCC.Journal
44 import Hcompta.LCC.Compta
45 import Hcompta.LCC.Posting
46 import Hcompta.LCC.Transaction
47 import Hcompta.LCC.IO
48 -- import Hcompta.LCC.Sym.Compta ()
49
50 import Hcompta.LCC.Read.Compta
51 import Hcompta.LCC.Read.Megaparsec
52 import qualified Hcompta.LCC.Lib.Strict as S
53 import qualified Hcompta as H
54
55 -- import qualified Control.Monad.Classes as MC
56
57 read ::
58 forall ss src e m j a.
59 Source src =>
60 Sym.ImportTypes ss =>
61 Sym.ModulesTyInj ss =>
62 Sym.ModulesInj src ss =>
63 m ~ S.StateT (Context_Read src) (S.StateT (Context_Sym src ss) IO) =>
64 e ~ P.ParseError Char P.Dec =>
65 Typeable j =>
66 H.Zeroable j =>
67 (Transaction -> j -> j) ->
68 CF (P.ParsecT P.Dec Text m) a ->
69 FilePath -> Text ->
70 IO ((Either e a, Context_Read src), Context_Sym src ss)
71 read consTxn g fp inp =
72 S.runState context_sym $
73 S.runState (context_read consTxn) $
74 P.runParserT (unCF $ g <* eoi) (FilePath.normalise fp) inp
75
76 readFile :: FilePath -> (FilePath -> Text -> IO a) -> IO a
77 readFile fp f = do
78 content <- Enc.decodeUtf8 <$> BS.readFile fp
79 f fp content
80
81 {-
82 newtype ComptaG src ss a = ComptaG (forall j. P.ParsecT P.Dec Text (S.StateT (Context_Read src j) (S.StateT (Context_Sym src ss) IO)) a)
83 instance Functor (ComptaG src ss) where
84 fmap f (ComptaG m) = ComptaG (fmap f m)
85 instance Applicative (ComptaG src ss) where
86 pure a = ComptaG (pure a)
87 ComptaG f <*> ComptaG a = ComptaG (f <*> a)
88 instance Monad (ComptaG src ss) where
89 return = pure
90 ComptaG m >>= f = ComptaG (m >>= \a -> case f a of ComptaG b -> b)
91 -}
92
93 readJournal ::
94 forall src ss j g.
95 g ~ P.ParsecT P.Dec Text (S.StateT (Context_Read src) (S.StateT (Context_Sym src ss) IO)) =>
96 Source src =>
97 Show src =>
98 SourceInj (Sym.AST_Type src) src =>
99 SourceInj (Sym.KindK src) src =>
100 SourceInj (Sym.TypeVT src) src =>
101 Gram_Source src g =>
102 Sym.Gram_Term_Atoms src ss g =>
103 Sym.ImportTypes ss =>
104 Sym.ModulesTyInj ss =>
105 Sym.ModulesInj src ss =>
106 Typeable j =>
107 H.Zeroable j =>
108 FilePath ->
109 (Transaction -> j -> j) ->
110 IO (( Either (P.ParseError Char P.Dec)
111 (S.Either [At src (Error_Compta src)] CanonFile)
112 , Context_Read src )
113 , Context_Sym src ss )
114 readJournal path consTxn = readFile path $ read consTxn $ g_compta @ss
115
116 readCompta ::
117 forall src ss j.
118 Comptable src ss =>
119 Show src =>
120 Typeable j =>
121 H.Zeroable j =>
122 (Transaction -> j -> j) ->
123 FilePath ->
124 IO (Either (Error_Read src) (Compta src ss j, [At src Warning_Compta]))
125 readCompta consTxn path = do
126 ((r, Context_Read{context_read_journals=(compta_journals::Journals j'), ..}), Context_Sym{..}) <-
127 readFile path (read @(Sym.Proxy (Compta src ss) ': ss) @src consTxn $ g_compta @(Sym.Proxy (Compta src ss) ': ss) @src)
128 return $ case r of
129 Left err -> Left $ Error_Read_Syntax err
130 Right r' | Just (Sym.Refl :: j Sym.:~: j') <- eqT ->
131 case r' of
132 S.Left err -> Left $ Error_Read_Semantic err
133 S.Right _r'' -> Right $ (,context_read_warnings) Compta
134 { compta_journals
135 , compta_chart = context_read_chart
136 , compta_style_amounts = context_read_style_amounts
137 , compta_modules = context_sym_modules
138 , compta_terms = context_sym_terms
139 }
140
141 consTransactions :: Transaction -> Map Date [Transaction] -> Map Date [Transaction]
142 consTransactions t = Map.insertWith (<>) (transaction_date t) [t]
143
144 type ComptaT src ss =
145 P.ParsecT P.Dec Text
146 (S.StateT (Context_Read src)
147 (S.StateT (Context_Sym src (Sym.Proxy (Compta src ss) ': ss))
148 IO))
149
150 type Comptable src ss =
151 ( Source src
152 , Show src
153 , SourceInj (Sym.AST_Type src) src
154 , SourceInj (Sym.KindK src) src
155 , SourceInj (Sym.TypeVT src) src
156 , Gram_Source src (ComptaT src ss)
157 , Sym.Gram_Term_Atoms src (Sym.Proxy (Compta src ss) ': ss) (ComptaT src ss)
158 -- , Sym.Gram_Term_AtomsFor src (Sym.Proxy (Compta src ss) : ss) (ComptaT src ss j) (Compta src ss)
159 -- , Sym.Gram_Term_AtomsR src (Sym.Proxy (Compta src ss) : ss) ss (ComptaT src ss j)
160 -- (P.ParsecT P.Dec Text (S.StateT (Context_Read src j) (S.StateT (Context_Sym src (Sym.Proxy (Compta src ss) : ss)) IO))) (Compta src ss)
161 , Sym.ImportTypes (Sym.Proxy (Compta src ss) ': ss)
162 , Sym.ModulesTyInj (Sym.Proxy (Compta src ss) ': ss)
163 , Sym.ModulesInj src (Sym.Proxy (Compta src ss) ': ss)
164 , Typeable ss
165 , Typeable src
166 )
167
168 instance Comptable src ss =>
169 FromFile (Compta src ss (Map Date [Transaction])) where
170 fromFile (PathFile p) =
171 readCompta consTransactions p >>= \case
172 Left err -> error $ show err
173 Right (a, warns) -> do
174 hPrint stderr warns
175 return a
176
177 -- * Type 'Error_Read'
178 data Error_Read src
179 = Error_Read_Syntax (P.ParseError Char P.Dec)
180 | Error_Read_Semantic [At src (Error_Compta src)]
181 deriving (Eq, Show)
182
183 {-
184 readFile
185 :: (Consable c j, Monoid j)
186 => Context_Read c j
187 -> FilePath
188 -> ExceptT [R.Error Error_Read] IO (Journal j)
189 readFile ctx path =
190 ExceptT
191 (Exn.catch
192 (Right <$> Text.IO.readFile path) $
193 \ko -> return $ Left $
194 [R.Error_Custom (R.initialPos path) $
195 Error_Read_reading_file path ko])
196 >>= liftIO . R.runParserTWithError
197 (read_journal path) ctx path
198 >>= \x -> case x of
199 Left ko -> throwE $ ko
200 Right ok -> ExceptT $ return $ Right ok
201 -}