]> Git — Sourcephile - comptalang.git/blob - lcc/Hcompta/LCC/Read.hs
Add Compta to the symantics.
[comptalang.git] / lcc / Hcompta / LCC / Read.hs
1 {-# LANGUAGE AllowAmbiguousTypes #-}
2 {-# LANGUAGE DataKinds #-}
3 {-# LANGUAGE GADTs #-}
4 {-# LANGUAGE UndecidableInstances #-}
5 {-# LANGUAGE UndecidableSuperClasses #-}
6 {-# OPTIONS_GHC -fno-warn-orphans #-}
7 module Hcompta.LCC.Read where
8
9 import Control.Applicative ((<*))
10 import Control.Monad (Monad(..))
11 import Data.Char (Char)
12 import Data.Either (Either(..))
13 import Data.Eq (Eq)
14 import Data.Function (($))
15 import Data.Functor ((<$>))
16 import Data.Map.Strict (Map)
17 import Data.Monoid (Monoid(..))
18 import Data.Semigroup (Semigroup(..))
19 import Data.Text (Text)
20 import Data.Typeable (Typeable)
21 import System.FilePath (FilePath)
22 import System.IO (IO)
23 import Text.Show (Show)
24 import qualified Data.ByteString as BS
25 import qualified Data.Map.Strict as Map
26 import qualified Data.Strict as S
27 import qualified Data.Text.Encoding as Enc
28 import qualified System.FilePath as FilePath
29 import qualified Text.Megaparsec as P
30
31 import Language.Symantic.Grammar
32 import qualified Language.Symantic as Sym
33 import Language.Symantic.Lib ()
34
35 import Hcompta.LCC.Journal
36 import Hcompta.LCC.Compta
37 import Hcompta.LCC.Posting
38 import Hcompta.LCC.Transaction
39 import Hcompta.LCC.Sym.Compta ()
40
41 import Hcompta.LCC.Grammar
42 import Hcompta.LCC.Megaparsec ()
43 import qualified Hcompta.LCC.Lib.Strict as S
44
45 import qualified Control.Monad.Classes as MC
46
47 read ::
48 forall ss src j e m a.
49 Source src =>
50 Monoid j =>
51 Sym.Inj_Name2Type ss =>
52 Sym.Inj_Modules src ss =>
53 m ~ S.StateT (Context_Read src j) (S.StateT (Context_Sym src ss) IO) =>
54 e ~ P.ParseError Char P.Dec =>
55 CF (P.ParsecT P.Dec Text m) a ->
56 FilePath -> Text ->
57 IO ((Either e a, Context_Read src j), Context_Sym src ss)
58 read g fp inp =
59 S.runState context_sym $
60 S.runState context_read $
61 P.runParserT (unCF $ g <* eoi) (FilePath.normalise fp) inp
62
63 readFile :: FilePath -> (FilePath -> Text -> IO a) -> IO a
64 readFile fp f = do
65 content <- Enc.decodeUtf8 <$> BS.readFile fp
66 f fp content
67
68 readJournal ::
69 forall src ss j g.
70 g ~ P.ParsecT P.Dec Text (S.StateT (Context_Read src j) (S.StateT (Context_Sym src ss) IO)) =>
71 Monoid j =>
72 Source src =>
73 Show src =>
74 Inj_Source (Sym.AST_Type src) src =>
75 Inj_Source (Sym.KindK src) src =>
76 Inj_Source (Sym.TypeVT src) src =>
77 Gram_Source src g =>
78 Sym.Gram_Term_Atoms src ss g =>
79 Sym.Inj_Name2Type ss =>
80 Sym.Inj_Modules src ss =>
81 FilePath ->
82 (Transaction -> j -> j) ->
83 IO (( Either (P.ParseError Char P.Dec)
84 (S.Either [At src (Error_Compta src)]
85 (CanonFile, Journal j))
86 , Context_Read src j )
87 , Context_Sym src ss )
88 readJournal path consTxn = readFile path $ read $ g_compta @ss consTxn
89
90 readCompta ::
91 forall src ss' ss j g.
92 ss ~ (Sym.Proxy (Compta src ss') ': ss') =>
93 g ~ P.ParsecT P.Dec Text
94 (S.StateT (Context_Read src j)
95 (S.StateT (Context_Sym src ss)
96 IO)) =>
97 j ~ Map Date [Transaction] =>
98 Monoid j =>
99 Source src =>
100 Show src =>
101 Inj_Source (Sym.AST_Type src) src =>
102 Inj_Source (Sym.KindK src) src =>
103 Inj_Source (Sym.TypeVT src) src =>
104 Gram_Source src g =>
105 Sym.Gram_Term_Atoms src ss g =>
106 Sym.Inj_Name2Type ss =>
107 Typeable ss' =>
108 Typeable src =>
109 Sym.Inj_Modules src ss =>
110 FilePath ->
111 -- (Transaction -> j -> j) ->
112 IO (Either (Error_Read src) (Compta src ss' j, [At src Warning_Compta]))
113 readCompta path = do
114 ((r, ctxRead), ctxSym) <-
115 readFile path $ read $
116 g_compta @ss (\t -> Map.insertWith (<>) (transaction_date t) [t])
117 return $ case r of
118 Left err -> Left $ Error_Read_Syntax err
119 Right r' ->
120 case r' of
121 S.Left err -> Left $ Error_Read_Semantic err
122 S.Right _r'' -> Right $ (,context_read_warnings ctxRead) Compta
123 { compta_journals = context_read_journals ctxRead
124 , compta_chart = context_read_chart ctxRead
125 , compta_style_amounts = context_read_style_amounts ctxRead
126 , compta_modules = context_sym_modules ctxSym
127 , compta_terms = context_sym_terms ctxSym
128 }
129
130 -- * Type 'Error_Read'
131 data Error_Read src
132 = Error_Read_Syntax (P.ParseError Char P.Dec)
133 | Error_Read_Semantic [At src (Error_Compta src)]
134 deriving (Eq, Show)
135
136 {-
137 readFile
138 :: (Consable c j, Monoid j)
139 => Context_Read c j
140 -> FilePath
141 -> ExceptT [R.Error Error_Read] IO (Journal j)
142 readFile ctx path =
143 ExceptT
144 (Exn.catch
145 (Right <$> Text.IO.readFile path) $
146 \ko -> return $ Left $
147 [R.Error_Custom (R.initialPos path) $
148 Error_Read_reading_file path ko])
149 >>= liftIO . R.runParserTWithError
150 (read_journal path) ctx path
151 >>= \x -> case x of
152 Left ko -> throwE $ ko
153 Right ok -> ExceptT $ return $ Right ok
154 -}