stack: bump to lts-12.25
[comptalang.git] / lcc / Hcompta / LCC / Read.hs
index 4f2ed36020878e5ecf45bd1e08d88bf91e42b83c..2efdb34bb49ecd638ff8dbe5dc14374a78c9538a 100644 (file)
@@ -1,7 +1,6 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE GADTs #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE UndecidableSuperClasses #-}
@@ -17,179 +16,176 @@ import Control.Monad (Monad(..))
 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])
@@ -199,3 +195,94 @@ readFile ctx path =
         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
+ )
+-}