{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE UndecidableSuperClasses #-}
import Data.Char (Char)
import Data.Either (Either(..))
import Data.Eq (Eq)
-import Data.Function (($), (.))
-import Data.Functor (Functor(..), (<$>))
-import Data.Map.Strict (Map)
+import Data.Function (($), flip)
+import Data.Functor ((<$>))
import Data.Maybe (Maybe(..))
-import Data.Monoid (Monoid(..))
+-- import Data.Monoid (Monoid(..))
import Data.Semigroup (Semigroup(..))
import Data.Text (Text)
-import Data.Typeable (Typeable, eqT)
+import Data.Typeable
+import Data.Void (Void)
import System.FilePath (FilePath)
import System.IO (IO, hPrint, stderr)
import Text.Show (Show(..))
import Prelude (error)
+import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.ByteString as BS
import qualified Data.Map.Strict as Map
import qualified Data.Strict as S
import qualified Data.Text.Encoding as Enc
import qualified System.FilePath as FilePath
import qualified Text.Megaparsec as P
+-- import qualified Control.Monad.Trans.State.Strict as SS
+import Control.Monad.IO.Class (MonadIO(..))
-import Language.Symantic.Grammar
+import Language.Symantic.Grammar hiding (Source)
import qualified Language.Symantic as Sym
import Language.Symantic.Lib ()
import Hcompta.LCC.Journal
import Hcompta.LCC.Compta
-import Hcompta.LCC.Posting
import Hcompta.LCC.Transaction
import Hcompta.LCC.IO
--- import Hcompta.LCC.Sym.Compta ()
import Hcompta.LCC.Read.Compta
import Hcompta.LCC.Read.Megaparsec
import qualified Hcompta.LCC.Lib.Strict as S
import qualified Hcompta as H
--- import qualified Control.Monad.Classes as MC
-
read ::
forall ss src e m j a.
- Source src =>
+ Sym.Source src =>
Sym.ImportTypes ss =>
Sym.ModulesTyInj ss =>
Sym.ModulesInj src ss =>
- m ~ S.StateT (Context_Read src) (S.StateT (Context_Sym src ss) IO) =>
- e ~ P.ParseError Char P.Dec =>
+ m ~ S.StateT (Context_Read src) (S.StateT (State_Sym src ss) IO) =>
+ e ~ P.ParseError Char Void =>
Typeable j =>
H.Zeroable j =>
- (Transaction -> j -> j) ->
- CF (P.ParsecT P.Dec Text m) a ->
+ (Transaction src -> j -> j) ->
+ CF (P.ParsecT Void Text m) a ->
FilePath -> Text ->
- IO ((Either e a, Context_Read src), Context_Sym src ss)
+ IO ((Either e a, Context_Read src), State_Sym src ss)
read consTxn g fp inp =
- S.runState context_sym $
+ S.runState state_sym $
+ S.runState (context_read consTxn) $
+ P.runParserT (unCF $ g <* eoi) (FilePath.normalise fp) inp
+
+readWithSym ::
+ forall src e m j a.
+ Sym.Source src =>
+ m ~ S.StateT (Context_Read src) IO =>
+ e ~ P.ParseError Char Void =>
+ Typeable j =>
+ H.Zeroable j =>
+ (Transaction src -> j -> j) ->
+ CF (P.ParsecT Void Text m) a ->
+ FilePath -> Text ->
+ IO (Either e a, Context_Read src)
+readWithSym consTxn g fp inp =
S.runState (context_read consTxn) $
P.runParserT (unCF $ g <* eoi) (FilePath.normalise fp) inp
-readFile :: FilePath -> (FilePath -> Text -> IO a) -> IO a
+readFile :: MonadIO m => FilePath -> (FilePath -> Text -> m a) -> m a
readFile fp f = do
- content <- Enc.decodeUtf8 <$> BS.readFile fp
+ content <- Enc.decodeUtf8 <$> liftIO (BS.readFile fp)
f fp content
-{-
-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)
-instance Functor (ComptaG src ss) where
- fmap f (ComptaG m) = ComptaG (fmap f m)
-instance Applicative (ComptaG src ss) where
- pure a = ComptaG (pure a)
- ComptaG f <*> ComptaG a = ComptaG (f <*> a)
-instance Monad (ComptaG src ss) where
- return = pure
- ComptaG m >>= f = ComptaG (m >>= \a -> case f a of ComptaG b -> b)
--}
-readJournal ::
- forall src ss j g.
- g ~ P.ParsecT P.Dec Text (S.StateT (Context_Read src) (S.StateT (Context_Sym src ss) IO)) =>
- Source src =>
- Show src =>
- SourceInj (Sym.AST_Type src) src =>
- SourceInj (Sym.KindK src) src =>
- SourceInj (Sym.TypeVT src) src =>
- Gram_Source src g =>
- Sym.Gram_Term_Atoms src ss g =>
- Sym.ImportTypes ss =>
- Sym.ModulesTyInj ss =>
- Sym.ModulesInj src ss =>
- Typeable j =>
- H.Zeroable j =>
- FilePath ->
- (Transaction -> j -> j) ->
- IO (( Either (P.ParseError Char P.Dec)
- (S.Either [At src (Error_Compta src)] CanonFile)
- , Context_Read src )
- , Context_Sym src ss )
-readJournal path consTxn = readFile path $ read consTxn $ g_compta @ss
+instance
+ ( Gram_Source src (P.ParsecT Void Text (S.StateT (Context_Read src) IO))
+ , Typeable src
+ , Show src
+ ) => FromFile (LCC src) where
+ fromFile (PathFile p) =
+ readLCC @src p >>= \case
+ Left err -> error $ show err
+ Right (a, warns) -> do
+ liftIO $ hPrint stderr warns
+ return a
-readCompta ::
- forall src ss j.
- Comptable src ss =>
- Show src =>
- Typeable j =>
- H.Zeroable j =>
- (Transaction -> j -> j) ->
+readLCC ::
+ forall src.
+ Gram_Source src (P.ParsecT Void Text (S.StateT (Context_Read src) IO)) =>
+ Sym.Source src =>
+ Typeable src =>
FilePath ->
- IO (Either (Error_Read src) (Compta src ss j, [At src Warning_Compta]))
-readCompta consTxn path = do
- ((r, Context_Read{context_read_journals=(compta_journals::Journals j'), ..}), Context_Sym{..}) <-
- readFile path (read @(Sym.Proxy (Compta src ss) ': ss) @src consTxn $ g_compta @(Sym.Proxy (Compta src ss) ': ss) @src)
- return $ case r of
- Left err -> Left $ Error_Read_Syntax err
- Right r' | Just (Sym.Refl :: j Sym.:~: j') <- eqT ->
- case r' of
+ IO (Either (Error_Read src) (LCC src, [At src Warning_Compta]))
+readLCC path = do
+ (r, Context_Read{context_read_journals=(lcc_journals::Journals src j), ..}) <-
+ readFile path $ readWithSym @src consTransactions $ g_compta @src
+ case r of
+ Left err -> return $ Left $ Error_Read_Syntax err
+ Right r' | Just (Sym.Refl :: Transactions src Sym.:~: j) <- eqT ->
+ return $ case r' of
S.Left err -> Left $ Error_Read_Semantic err
- S.Right _r'' -> Right $ (,context_read_warnings) Compta
- { compta_journals
- , compta_chart = context_read_chart
- , compta_style_amounts = context_read_style_amounts
- , compta_modules = context_sym_modules
- , compta_terms = context_sym_terms
+ S.Right _r'' -> Right $ (,context_read_warnings) LCC
+ { lcc_journals
+ , lcc_chart = context_read_chart
+ , lcc_style = context_read_style_amounts
+ , lcc_base = NonEmpty.head context_read_canonfiles
}
+ Right _r' -> do
+ hPrint stderr $ typeRep (Proxy @Transactions)
+ hPrint stderr $ typeRep (Proxy @j)
+ error "[BUG] readLCC"
+
+
+
+
+
+
+
-consTransactions :: Transaction -> Map Date [Transaction] -> Map Date [Transaction]
+
+
+
+
+
+
+
+{-
+consTransactions :: Transaction src -> Map Date [Transaction src] -> Map Date [Transaction src]
consTransactions t = Map.insertWith (<>) (transaction_date t) [t]
+-}
+consTransactions :: Transaction src -> Transactions src -> Transactions src
+consTransactions t (Transactions ts) = Transactions $ Map.insertWith (flip (<>)) (transaction_date t) [t] ts
+
+{-
type ComptaT src ss =
- P.ParsecT P.Dec Text
+ P.ParsecT Void Text
(S.StateT (Context_Read src)
- (S.StateT (Context_Sym src (Sym.Proxy (Compta src ss) ': ss))
+ (S.StateT (State_Sym src ({-Sym.Proxy (Compta src ss) ':-} ss))
IO))
-type Comptable src ss =
- ( Source src
- , Show src
- , SourceInj (Sym.AST_Type src) src
- , SourceInj (Sym.KindK src) src
- , SourceInj (Sym.TypeVT src) src
- , Gram_Source src (ComptaT src ss)
- , Sym.Gram_Term_Atoms src (Sym.Proxy (Compta src ss) ': ss) (ComptaT src ss)
- -- , Sym.Gram_Term_AtomsFor src (Sym.Proxy (Compta src ss) : ss) (ComptaT src ss j) (Compta src ss)
- -- , Sym.Gram_Term_AtomsR src (Sym.Proxy (Compta src ss) : ss) ss (ComptaT src ss j)
- -- (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)
- , Sym.ImportTypes (Sym.Proxy (Compta src ss) ': ss)
- , Sym.ModulesTyInj (Sym.Proxy (Compta src ss) ': ss)
- , Sym.ModulesInj src (Sym.Proxy (Compta src ss) ': ss)
- , Typeable ss
- , Typeable src
- )
-instance Comptable src ss =>
+instance Loadable src ss =>
FromFile (Compta src ss (Map Date [Transaction])) where
fromFile (PathFile p) =
- readCompta consTransactions p >>= \case
+ readLCC consTransactions p >>= \case
Left err -> error $ show err
Right (a, warns) -> do
hPrint stderr warns
return a
+-}
-- * Type 'Error_Read'
data Error_Read src
- = Error_Read_Syntax (P.ParseError Char P.Dec)
+ = Error_Read_Syntax (P.ParseError Char Void)
| Error_Read_Semantic [At src (Error_Compta src)]
deriving (Eq, Show)
{-
-readFile
+fromFile
:: (Consable c j, Monoid j)
=> Context_Read c j
-> FilePath
-> ExceptT [R.Error Error_Read] IO (Journal j)
-readFile ctx path =
+fromFile ctx path =
ExceptT
(Exn.catch
- (Right <$> Text.IO.readFile path) $
+ (Right <$> Text.IO.fromFile path) $
\ko -> return $ Left $
[R.Error_Custom (R.initialPos path) $
Error_Read_reading_file path ko])
Left ko -> throwE $ ko
Right ok -> ExceptT $ return $ Right ok
-}
+
+
+{-
+readLCC ::
+ forall src ss.
+ Loadable src ss =>
+ Sym.NameTyOf (Code src ss) =>
+ Sym.FixityOf (Code src ss) =>
+ Sym.ClassInstancesFor (Code src ss) =>
+ Sym.TypeInstancesFor (Code src ss) =>
+ Sym.ModuleFor src (Sym.Proxy (Code src ss) : ss) (Code src ss) =>
+ Sym.ModulesInj src (Sym.Proxy (Code src ss) : ss) =>
+ Show src =>
+ FilePath ->
+ IO (Either (Error_Read src) (LCC, [At src Warning_Compta]))
+readLCC path = do
+ ((r, Context_Read{context_read_journals=(lcc_journals::Journals j), ..}), State_Sym{..}) <-
+ fromFile path (read @(Sym.Proxy (Code src ss) ': ss) @src consTransactions $
+ g_compta @(Sym.Proxy (Code src ss) ': ss) @src)
+ return $ case r of
+ Left err -> Left $ Error_Read_Syntax err
+ Right r' | Just (Sym.Refl :: Transactions Sym.:~: j) <- eqT ->
+ case r' of
+ S.Left err -> Left $ Error_Read_Semantic err
+ S.Right _r'' -> Right $ (,context_read_warnings) LCC
+ { lcc_journals
+ , lcc_chart = context_read_chart
+ , lcc_style = context_read_style_amounts
+ -- , lcc_modules = context_sym_modules
+ -- , lcc_terms = context_sym_terms
+ }
+-}
+{-
+newtype ComptaG src ss a = ComptaG (forall j. P.ParsecT Void Text (S.StateT (Context_Read src j) (S.StateT (State_Sym src ss) IO)) a)
+instance Functor (ComptaG src ss) where
+ fmap f (ComptaG m) = ComptaG (fmap f m)
+instance Applicative (ComptaG src ss) where
+ pure a = ComptaG (pure a)
+ ComptaG f <*> ComptaG a = ComptaG (f <*> a)
+instance Monad (ComptaG src ss) where
+ return = pure
+ ComptaG m >>= f = ComptaG (m >>= \a -> case f a of ComptaG b -> b)
+-}
+
+{-
+readJournal ::
+ forall src ss j g.
+ g ~ P.ParsecT Void Text (S.StateT (Context_Read src) (S.StateT (State_Sym src ss) IO)) =>
+ Source src =>
+ Show src =>
+ SourceInj (Sym.AST_Type src) src =>
+ SourceInj (Sym.KindK src) src =>
+ SourceInj (Sym.TypeVT src) src =>
+ Gram_Source src g =>
+ Sym.Gram_Term_Atoms src ss g =>
+ Sym.ImportTypes ss =>
+ Sym.ModulesTyInj ss =>
+ Sym.ModulesInj src ss =>
+ Typeable j =>
+ H.Zeroable j =>
+ FilePath ->
+ (Transaction -> j -> j) ->
+ IO (( Either (P.ParseError Char Void)
+ (S.Either [At src (Error_Compta src)] CanonFile)
+ , Context_Read src )
+ , State_Sym src ss )
+readJournal path consTxn = fromFile path $ read consTxn $ g_compta @ss
+
+type Loadable src ss =
+ ( Sym.Source src
+ , Show src
+ , SourceInj (Sym.AST_Type src) src
+ , SourceInj (Sym.KindK src) src
+ , SourceInj (Sym.TypeVT src) src
+ , Gram_Source src (P.ParsecT Void Text (S.StateT (Context_Read src)
+ (S.StateT (State_Sym src (Sym.Proxy (Code src ss) ': ss)) IO)))
+ , Sym.Gram_Term_Atoms src (Sym.Proxy (Code src ss) ': ss)
+ (P.ParsecT Void Text (S.StateT (Context_Read src)
+ (S.StateT (State_Sym src (Sym.Proxy (Code src ss) ': ss)) IO)))
+ -- , Gram_Source src (ComptaT src ss)
+ -- , Sym.Gram_Term_Atoms src ({-Sym.Proxy (Compta src ss) ':-} ss) (ComptaT src ss)
+ -- , Sym.Gram_Term_AtomsFor src (Sym.Proxy (Compta src ss) : ss) (ComptaT src ss j) (Compta src ss)
+ -- , Sym.Gram_Term_AtomsR src (Sym.Proxy (Compta src ss) : ss) ss (ComptaT src ss j)
+ -- (P.ParsecT Void Text (S.StateT (Context_Read src j) (S.StateT (State_Sym src (Sym.Proxy (Compta src ss) : ss)) IO))) (Compta src ss)
+ , Sym.ImportTypes (Sym.Proxy (Code src ss) ': ss)
+ , Sym.ModulesTyInj (Sym.Proxy (Code src ss) ': ss)
+ , Sym.ModulesInj src (Sym.Proxy (Code src ss) ': ss)
+ , Typeable ss
+ , Typeable src
+ )
+-}