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