lcc/Hcompta/LCC/Read.hs

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