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))
 106 readCompta path = do
 107         ((r, ctxRead), ctxSym) <- readFile path $ read $ g_journal @ss (\t -> Map.insertWith (<>) (transaction_date t) [t])
 108         return $ case r of
 109          Left err -> Left $ Error_Read_Syntax err
 110          Right r' ->
 111                 case r' of
 112                  S.Left err -> Left $ Error_Read_Semantic err
 113                  S.Right _r'' -> Right $ Compta
 114                          { compta_journals      = context_read_journals      ctxRead
 115                          , compta_chart         = context_read_chart         ctxRead
 116                          , compta_style_amounts = context_read_style_amounts ctxRead
 117                          , compta_modules       = context_sym_modules        ctxSym
 118                          , compta_terms         = context_sym_terms          ctxSym
 119                          }
 120
 121 -- * Type 'Error_Read'
 122 data Error_Read src
 123  =   Error_Read_Syntax   (P.ParseError Char P.Dec)
 124  |   Error_Read_Semantic [At src (Error_Journal src)]
 125  deriving (Eq, Show)
 126
 127 {-
 128 readFile
 129  :: (Consable c j, Monoid j)
 130  => Context_Read c j
 131  -> FilePath
 132  -> ExceptT [R.Error Error_Read] IO (Journal j)
 133 readFile ctx path =
 134         ExceptT
 135          (Exn.catch
 136                  (Right <$> Text.IO.readFile path) $
 137                  \ko -> return $ Left $
 138                          [R.Error_Custom (R.initialPos path) $
 139                                 Error_Read_reading_file path ko])
 140         >>= liftIO . R.runParserTWithError
 141          (read_journal path) ctx path
 142         >>= \x -> case x of
 143          Left  ko -> throwE $ ko
 144          Right ok -> ExceptT $ return $ Right ok
 145 -}