lcc/Hcompta/LCC/Read.hs

   1 {-# LANGUAGE AllowAmbiguousTypes #-}
   2 {-# LANGUAGE DataKinds #-}
   3 {-# LANGUAGE GADTs #-}
   4 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
   5 {-# LANGUAGE RecordWildCards #-}
   6 {-# LANGUAGE UndecidableInstances #-}
   7 {-# LANGUAGE UndecidableSuperClasses #-}
   8 {-# OPTIONS_GHC -fno-warn-orphans #-}
   9 module Hcompta.LCC.Read
  10  ( module Hcompta.LCC.Read
  11  , module Hcompta.LCC.Read.Compta
  12  , module Hcompta.LCC.Read.Megaparsec
  13  ) where
  14
  15 import Control.Applicative (Applicative(..), (<*))
  16 import Control.Monad (Monad(..))
  17 import Data.Char (Char)
  18 import Data.Either (Either(..))
  19 import Data.Eq (Eq)
  20 import Data.Function (($), (.))
  21 import Data.Functor (Functor(..), (<$>))
  22 import Data.Map.Strict (Map)
  23 import Data.Maybe (Maybe(..))
  24 import Data.Monoid (Monoid(..))
  25 import Data.Semigroup (Semigroup(..))
  26 import Data.Text (Text)
  27 import Data.Typeable (Typeable, eqT)
  28 import System.FilePath (FilePath)
  29 import System.IO (IO, hPrint, stderr)
  30 import Text.Show (Show(..))
  31 import Prelude (error)
  32 import qualified Data.ByteString as BS
  33 import qualified Data.Map.Strict as Map
  34 import qualified Data.Strict as S
  35 import qualified Data.Text.Encoding as Enc
  36 import qualified System.FilePath as FilePath
  37 import qualified Text.Megaparsec as P
  38
  39 import Language.Symantic.Grammar
  40 import qualified Language.Symantic as Sym
  41 import Language.Symantic.Lib ()
  42
  43 import Hcompta.LCC.Journal
  44 import Hcompta.LCC.Compta
  45 import Hcompta.LCC.Posting
  46 import Hcompta.LCC.Transaction
  47 import Hcompta.LCC.IO
  48 -- import Hcompta.LCC.Sym.Compta ()
  49
  50 import Hcompta.LCC.Read.Compta
  51 import Hcompta.LCC.Read.Megaparsec
  52 import qualified Hcompta.LCC.Lib.Strict as S
  53 import qualified Hcompta as H
  54
  55 -- import qualified Control.Monad.Classes as MC
  56
  57 read ::
  58  forall ss src e m j a.
  59  Source src =>
  60  Sym.ImportTypes ss =>
  61  Sym.ModulesTyInj ss =>
  62  Sym.ModulesInj src ss =>
  63  m ~ S.StateT (Context_Read src) (S.StateT (Context_Sym src ss) IO) =>
  64  e ~ P.ParseError Char P.Dec =>
  65  Typeable j =>
  66  H.Zeroable j =>
  67  (Transaction -> j -> j) ->
  68  CF (P.ParsecT P.Dec Text m) a ->
  69  FilePath -> Text ->
  70  IO ((Either e a, Context_Read src), Context_Sym src ss)
  71 read consTxn g fp inp =
  72         S.runState context_sym $
  73         S.runState (context_read consTxn) $
  74         P.runParserT (unCF $ g <* eoi) (FilePath.normalise fp) inp
  75
  76 readFile :: FilePath -> (FilePath -> Text -> IO a) -> IO a
  77 readFile fp f = do
  78         content <- Enc.decodeUtf8 <$> BS.readFile fp
  79         f fp content
  80
  81 {-
  82 newtype ComptaG src ss a = ComptaG (forall j. P.ParsecT P.Dec Text (S.StateT (Context_Read src j) (S.StateT (Context_Sym src ss) IO)) a)
  83 instance Functor     (ComptaG src ss) where
  84         fmap f (ComptaG m) = ComptaG (fmap f m)
  85 instance Applicative (ComptaG src ss) where
  86         pure a = ComptaG (pure a)
  87         ComptaG f <*> ComptaG a = ComptaG (f <*> a)
  88 instance Monad (ComptaG src ss) where
  89         return = pure
  90         ComptaG m >>= f = ComptaG (m >>= \a -> case f a of ComptaG b -> b)
  91 -}
  92
  93 readJournal ::
  94  forall src ss j g.
  95  g ~ P.ParsecT P.Dec Text (S.StateT (Context_Read src) (S.StateT (Context_Sym src ss) IO)) =>
  96  Source src =>
  97  Show src =>
  98  SourceInj (Sym.AST_Type src) src =>
  99  SourceInj (Sym.KindK src) src =>
 100  SourceInj (Sym.TypeVT src) src =>
 101  Gram_Source src g =>
 102  Sym.Gram_Term_Atoms src ss g =>
 103  Sym.ImportTypes ss =>
 104  Sym.ModulesTyInj ss =>
 105  Sym.ModulesInj src ss =>
 106  Typeable j =>
 107  H.Zeroable j =>
 108  FilePath ->
 109  (Transaction -> j -> j) ->
 110  IO (( Either (P.ParseError Char P.Dec)
 111               (S.Either [At src (Error_Compta src)] CanonFile)
 112      , Context_Read src )
 113     , Context_Sym src ss )
 114 readJournal path consTxn = readFile path $ read consTxn $ g_compta @ss
 115
 116 readCompta ::
 117  forall src ss j.
 118  Comptable src ss =>
 119  Show src =>
 120  Typeable j =>
 121  H.Zeroable j =>
 122  (Transaction -> j -> j) ->
 123  FilePath ->
 124  IO (Either (Error_Read src) (Compta src ss j, [At src Warning_Compta]))
 125 readCompta consTxn path = do
 126         ((r, Context_Read{context_read_journals=(compta_journals::Journals j'), ..}), Context_Sym{..}) <-
 127                 readFile path (read @(Sym.Proxy (Compta src ss) ': ss) @src consTxn $ g_compta @(Sym.Proxy (Compta src ss) ': ss) @src)
 128         return $ case r of
 129          Left err -> Left $ Error_Read_Syntax err
 130          Right r' | Just (Sym.Refl :: j Sym.:~: j') <- eqT ->
 131                 case r' of
 132                  S.Left err -> Left $ Error_Read_Semantic err
 133                  S.Right _r'' -> Right $ (,context_read_warnings) Compta
 134                          { compta_journals
 135                          , compta_chart         = context_read_chart
 136                          , compta_style_amounts = context_read_style_amounts
 137                          , compta_modules       = context_sym_modules
 138                          , compta_terms         = context_sym_terms
 139                          }
 140
 141 consTransactions :: Transaction -> Map Date [Transaction] -> Map Date [Transaction]
 142 consTransactions t = Map.insertWith (<>) (transaction_date t) [t]
 143
 144 type ComptaT src ss =
 145  P.ParsecT P.Dec Text
 146            (S.StateT (Context_Read src)
 147                      (S.StateT (Context_Sym src (Sym.Proxy (Compta src ss) ': ss))
 148                                IO))
 149
 150 type Comptable src ss =
 151  ( Source src
 152  , Show src
 153  , SourceInj (Sym.AST_Type src) src
 154  , SourceInj (Sym.KindK src) src
 155  , SourceInj (Sym.TypeVT src) src
 156  , Gram_Source src (ComptaT src ss)
 157  , Sym.Gram_Term_Atoms src (Sym.Proxy (Compta src ss) ': ss) (ComptaT src ss)
 158  -- , Sym.Gram_Term_AtomsFor src (Sym.Proxy (Compta src ss) : ss) (ComptaT src ss j) (Compta src ss)
 159  -- , Sym.Gram_Term_AtomsR   src (Sym.Proxy (Compta src ss) : ss) ss (ComptaT src ss j)
 160    -- (P.ParsecT P.Dec Text (S.StateT (Context_Read src j) (S.StateT (Context_Sym src (Sym.Proxy (Compta src ss) : ss)) IO))) (Compta src ss)
 161  , Sym.ImportTypes         (Sym.Proxy (Compta src ss) ': ss)
 162  , Sym.ModulesTyInj        (Sym.Proxy (Compta src ss) ': ss)
 163  , Sym.ModulesInj src      (Sym.Proxy (Compta src ss) ': ss)
 164  , Typeable ss
 165  , Typeable src
 166  )
 167
 168 instance Comptable src ss =>
 169          FromFile (Compta src ss (Map Date [Transaction])) where
 170         fromFile (PathFile p) =
 171                 readCompta consTransactions p >>= \case
 172                  Left err -> error $ show err
 173                  Right (a, warns) -> do
 174                         hPrint stderr warns
 175                         return a
 176
 177 -- * Type 'Error_Read'
 178 data Error_Read src
 179  =   Error_Read_Syntax   (P.ParseError Char P.Dec)
 180  |   Error_Read_Semantic [At src (Error_Compta src)]
 181  deriving (Eq, Show)
 182
 183 {-
 184 readFile
 185  :: (Consable c j, Monoid j)
 186  => Context_Read c j
 187  -> FilePath
 188  -> ExceptT [R.Error Error_Read] IO (Journal j)
 189 readFile ctx path =
 190         ExceptT
 191          (Exn.catch
 192                  (Right <$> Text.IO.readFile path) $
 193                  \ko -> return $ Left $
 194                          [R.Error_Custom (R.initialPos path) $
 195                                 Error_Read_reading_file path ko])
 196         >>= liftIO . R.runParserTWithError
 197          (read_journal path) ctx path
 198         >>= \x -> case x of
 199          Left  ko -> throwE $ ko
 200          Right ok -> ExceptT $ return $ Right ok
 201 -}