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.ImportTypes ss =>
  52  Sym.ModulesTyInj ss =>
  53  Sym.ModulesInj src ss =>
  54  m ~ S.StateT (Context_Read src j) (S.StateT (Context_Sym src ss) IO) =>
  55  e ~ P.ParseError Char P.Dec =>
  56  CF (P.ParsecT P.Dec Text m) a ->
  57  FilePath -> Text ->
  58  IO ((Either e a, Context_Read src j), Context_Sym src ss)
  59 read g fp inp =
  60         S.runState context_sym $
  61         S.runState context_read $
  62         P.runParserT (unCF $ g <* eoi) (FilePath.normalise fp) inp
  63
  64 readFile :: FilePath -> (FilePath -> Text -> IO a) -> IO a
  65 readFile fp f = do
  66         content <- Enc.decodeUtf8 <$> BS.readFile fp
  67         f fp content
  68
  69 readJournal ::
  70  forall src ss j g.
  71  g ~ P.ParsecT P.Dec Text (S.StateT (Context_Read src j) (S.StateT (Context_Sym src ss) IO)) =>
  72  Monoid j =>
  73  Source src =>
  74  Show src =>
  75  SourceInj (Sym.AST_Type src) src =>
  76  SourceInj (Sym.KindK src) src =>
  77  SourceInj (Sym.TypeVT src) src =>
  78  Gram_Source src g =>
  79  Sym.Gram_Term_Atoms src ss g =>
  80  Sym.ImportTypes ss =>
  81  Sym.ModulesTyInj ss =>
  82  Sym.ModulesInj src ss =>
  83  FilePath ->
  84  (Transaction -> j -> j) ->
  85  IO (( Either (P.ParseError Char P.Dec)
  86               (S.Either [At src (Error_Compta src)]
  87                         (CanonFile, Journal j))
  88      , Context_Read src j )
  89     , Context_Sym src ss )
  90 readJournal path consTxn = readFile path $ read $ g_compta @ss consTxn
  91
  92 readCompta ::
  93  forall src ss' ss j g.
  94  ss ~ (Sym.Proxy (Compta src ss') ': ss') =>
  95  g ~ P.ParsecT P.Dec Text
  96                (S.StateT (Context_Read src j)
  97                          (S.StateT (Context_Sym src ss)
  98                                    IO)) =>
  99  j ~ Map Date [Transaction] =>
 100  Monoid j =>
 101  Source src =>
 102  Show src =>
 103  SourceInj (Sym.AST_Type src) src =>
 104  SourceInj (Sym.KindK src) src =>
 105  SourceInj (Sym.TypeVT src) src =>
 106  Gram_Source src g =>
 107  Sym.Gram_Term_Atoms src ss g =>
 108  Sym.ImportTypes ss =>
 109  Sym.ModulesTyInj ss =>
 110  Typeable ss' =>
 111  Typeable src =>
 112  Sym.ModulesInj src ss =>
 113  FilePath ->
 114  -- (Transaction -> j -> j) ->
 115  IO (Either (Error_Read src) (Compta src ss' j, [At src Warning_Compta]))
 116 readCompta path = do
 117         ((r, ctxRead), ctxSym) <-
 118                 readFile path $ read $
 119                 g_compta @ss (\t -> Map.insertWith (<>) (transaction_date t) [t])
 120         return $ case r of
 121          Left err -> Left $ Error_Read_Syntax err
 122          Right r' ->
 123                 case r' of
 124                  S.Left err -> Left $ Error_Read_Semantic err
 125                  S.Right _r'' -> Right $ (,context_read_warnings ctxRead) Compta
 126                          { compta_journals      = context_read_journals      ctxRead
 127                          , compta_chart         = context_read_chart         ctxRead
 128                          , compta_style_amounts = context_read_style_amounts ctxRead
 129                          , compta_modules       = context_sym_modules        ctxSym
 130                          , compta_terms         = context_sym_terms          ctxSym
 131                          }
 132
 133 -- * Type 'Error_Read'
 134 data Error_Read src
 135  =   Error_Read_Syntax   (P.ParseError Char P.Dec)
 136  |   Error_Read_Semantic [At src (Error_Compta src)]
 137  deriving (Eq, Show)
 138
 139 {-
 140 readFile
 141  :: (Consable c j, Monoid j)
 142  => Context_Read c j
 143  -> FilePath
 144  -> ExceptT [R.Error Error_Read] IO (Journal j)
 145 readFile ctx path =
 146         ExceptT
 147          (Exn.catch
 148                  (Right <$> Text.IO.readFile path) $
 149                  \ko -> return $ Left $
 150                          [R.Error_Custom (R.initialPos path) $
 151                                 Error_Read_reading_file path ko])
 152         >>= liftIO . R.runParserTWithError
 153          (read_journal path) ctx path
 154         >>= \x -> case x of
 155          Left  ko -> throwE $ ko
 156          Right ok -> ExceptT $ return $ Right ok
 157 -}