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.Name2TypeInj ss =>
  52  Sym.ModulesInj 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  SourceInj (Sym.AST_Type src) src =>
  75  SourceInj (Sym.KindK src) src =>
  76  SourceInj (Sym.TypeVT src) src =>
  77  Gram_Source src g =>
  78  Sym.Gram_Term_Atoms src ss g =>
  79  Sym.Name2TypeInj ss =>
  80  Sym.ModulesInj 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  SourceInj (Sym.AST_Type src) src =>
 102  SourceInj (Sym.KindK src) src =>
 103  SourceInj (Sym.TypeVT src) src =>
 104  Gram_Source src g =>
 105  Sym.Gram_Term_Atoms src ss g =>
 106  Sym.Name2TypeInj ss =>
 107  Typeable ss' =>
 108  Typeable src =>
 109  Sym.ModulesInj 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 -}