lcc/Hcompta/LCC/Read.hs

   1 {-# LANGUAGE AllowAmbiguousTypes #-}
   2 {-# LANGUAGE DataKinds #-}
   3 {-# LANGUAGE GADTs #-}
   4 {-# LANGUAGE RecordWildCards #-}
   5 {-# LANGUAGE UndecidableInstances #-}
   6 {-# LANGUAGE UndecidableSuperClasses #-}
   7 {-# OPTIONS_GHC -fno-warn-orphans #-}
   8 module Hcompta.LCC.Read
   9  ( module Hcompta.LCC.Read
  10  , module Hcompta.LCC.Read.Compta
  11  , module Hcompta.LCC.Read.Megaparsec
  12  ) where
  13
  14 import Control.Applicative (Applicative(..), (<*))
  15 import Control.Monad (Monad(..))
  16 import Data.Char (Char)
  17 import Data.Either (Either(..))
  18 import Data.Eq (Eq)
  19 import Data.Function (($), flip)
  20 import Data.Functor ((<$>))
  21 import Data.Maybe (Maybe(..))
  22 -- import Data.Monoid (Monoid(..))
  23 import Data.Semigroup (Semigroup(..))
  24 import Data.Text (Text)
  25 import Data.Typeable
  26 import System.FilePath (FilePath)
  27 import System.IO (IO, hPrint, stderr)
  28 import Text.Show (Show(..))
  29 import Prelude (error)
  30 import qualified Data.List.NonEmpty as NonEmpty
  31 import qualified Data.ByteString as BS
  32 import qualified Data.Map.Strict as Map
  33 import qualified Data.Strict as S
  34 import qualified Data.Text.Encoding as Enc
  35 import qualified System.FilePath as FilePath
  36 import qualified Text.Megaparsec as P
  37 -- import qualified Control.Monad.Trans.State.Strict as SS
  38 import Control.Monad.IO.Class (MonadIO(..))
  39
  40 import Language.Symantic.Grammar hiding (Source)
  41 import qualified Language.Symantic as Sym
  42 import Language.Symantic.Lib ()
  43
  44 import Hcompta.LCC.Journal
  45 import Hcompta.LCC.Compta
  46 import Hcompta.LCC.Transaction
  47 import Hcompta.LCC.IO
  48
  49 import Hcompta.LCC.Read.Compta
  50 import Hcompta.LCC.Read.Megaparsec
  51 import qualified Hcompta.LCC.Lib.Strict as S
  52 import qualified Hcompta as H
  53
  54 read ::
  55  forall ss src e m j a.
  56  Sym.Source src =>
  57  Sym.ImportTypes ss =>
  58  Sym.ModulesTyInj ss =>
  59  Sym.ModulesInj src ss =>
  60  m ~ S.StateT (Context_Read src) (S.StateT (State_Sym src ss) IO) =>
  61  e ~ P.ParseError Char P.Dec =>
  62  Typeable j =>
  63  H.Zeroable j =>
  64  (Transaction src -> j -> j) ->
  65  CF (P.ParsecT P.Dec Text m) a ->
  66  FilePath -> Text ->
  67  IO ((Either e a, Context_Read src), State_Sym src ss)
  68 read consTxn g fp inp =
  69         S.runState state_sym $
  70         S.runState (context_read consTxn) $
  71         P.runParserT (unCF $ g <* eoi) (FilePath.normalise fp) inp
  72
  73 readWithSym ::
  74  forall src e m j a.
  75  Sym.Source src =>
  76  m ~ S.StateT (Context_Read src) IO =>
  77  e ~ P.ParseError Char P.Dec =>
  78  Typeable j =>
  79  H.Zeroable j =>
  80  (Transaction src -> j -> j) ->
  81  CF (P.ParsecT P.Dec Text m) a ->
  82  FilePath -> Text ->
  83  IO (Either e a, Context_Read src)
  84 readWithSym consTxn g fp inp =
  85         S.runState (context_read consTxn) $
  86         P.runParserT (unCF $ g <* eoi) (FilePath.normalise fp) inp
  87
  88 readFile :: MonadIO m => FilePath -> (FilePath -> Text -> m a) -> m a
  89 readFile fp f = do
  90         content <- Enc.decodeUtf8 <$> liftIO (BS.readFile fp)
  91         f fp content
  92
  93
  94 instance
  95  ( Gram_Source src (P.ParsecT P.Dec Text (S.StateT (Context_Read src) IO))
  96  , Typeable src
  97  , Show src
  98  ) => FromFile (LCC src) where
  99         fromFile (PathFile p) =
 100                 readLCC @src p >>= \case
 101                  Left err -> error $ show err
 102                  Right (a, warns) -> do
 103                         liftIO $ hPrint stderr warns
 104                         return a
 105
 106 readLCC ::
 107  forall src.
 108  Gram_Source src (P.ParsecT P.Dec Text (S.StateT (Context_Read src) IO)) =>
 109  Sym.Source src =>
 110  Typeable src =>
 111  FilePath ->
 112  IO (Either (Error_Read src) (LCC src, [At src Warning_Compta]))
 113 readLCC path = do
 114         (r, Context_Read{context_read_journals=(lcc_journals::Journals src j), ..}) <-
 115                 readFile path $ readWithSym @src consTransactions $ g_compta @src
 116         case r of
 117          Left err -> return $ Left $ Error_Read_Syntax err
 118          Right r' | Just (Sym.Refl :: Transactions src Sym.:~: j) <- eqT ->
 119                 return $ case r' of
 120                  S.Left err -> Left $ Error_Read_Semantic err
 121                  S.Right _r'' -> Right $ (,context_read_warnings) LCC
 122                          { lcc_journals
 123                          , lcc_chart = context_read_chart
 124                          , lcc_style = context_read_style_amounts
 125                          , lcc_base  = NonEmpty.head context_read_canonfiles
 126                          }
 127          Right _r' -> do
 128                 hPrint stderr $ typeRep (Proxy @Transactions)
 129                 hPrint stderr $ typeRep (Proxy @j)
 130                 error "[BUG] readLCC"
 131
 132
 133
 134
 135
 136
 137
 138
 139
 140
 141
 142
 143
 144
 145
 146 {-
 147 consTransactions :: Transaction src -> Map Date [Transaction src] -> Map Date [Transaction src]
 148 consTransactions t = Map.insertWith (<>) (transaction_date t) [t]
 149 -}
 150 consTransactions :: Transaction src -> Transactions src -> Transactions src
 151 consTransactions t (Transactions ts) = Transactions $ Map.insertWith (flip (<>)) (transaction_date t) [t] ts
 152
 153 {-
 154
 155 type ComptaT src ss =
 156  P.ParsecT P.Dec Text
 157            (S.StateT (Context_Read src)
 158                      (S.StateT (State_Sym src ({-Sym.Proxy (Compta src ss) ':-} ss))
 159                                IO))
 160
 161
 162 instance Loadable src ss =>
 163          FromFile (Compta src ss (Map Date [Transaction])) where
 164         fromFile (PathFile p) =
 165                 readLCC consTransactions p >>= \case
 166                  Left err -> error $ show err
 167                  Right (a, warns) -> do
 168                         hPrint stderr warns
 169                         return a
 170 -}
 171
 172 -- * Type 'Error_Read'
 173 data Error_Read src
 174  =   Error_Read_Syntax   (P.ParseError Char P.Dec)
 175  |   Error_Read_Semantic [At src (Error_Compta src)]
 176  deriving (Eq, Show)
 177
 178 {-
 179 fromFile
 180  :: (Consable c j, Monoid j)
 181  => Context_Read c j
 182  -> FilePath
 183  -> ExceptT [R.Error Error_Read] IO (Journal j)
 184 fromFile ctx path =
 185         ExceptT
 186          (Exn.catch
 187                  (Right <$> Text.IO.fromFile path) $
 188                  \ko -> return $ Left $
 189                          [R.Error_Custom (R.initialPos path) $
 190                                 Error_Read_reading_file path ko])
 191         >>= liftIO . R.runParserTWithError
 192          (read_journal path) ctx path
 193         >>= \x -> case x of
 194          Left  ko -> throwE $ ko
 195          Right ok -> ExceptT $ return $ Right ok
 196 -}
 197
 198
 199 {-
 200 readLCC ::
 201  forall src ss.
 202  Loadable src ss =>
 203  Sym.NameTyOf (Code src ss) =>
 204  Sym.FixityOf (Code src ss) =>
 205  Sym.ClassInstancesFor (Code src ss) =>
 206  Sym.TypeInstancesFor (Code src ss) =>
 207  Sym.ModuleFor src (Sym.Proxy (Code src ss) : ss) (Code src ss) =>
 208  Sym.ModulesInj src (Sym.Proxy (Code src ss) : ss) =>
 209  Show src =>
 210  FilePath ->
 211  IO (Either (Error_Read src) (LCC, [At src Warning_Compta]))
 212 readLCC path = do
 213         ((r, Context_Read{context_read_journals=(lcc_journals::Journals j), ..}), State_Sym{..}) <-
 214                 fromFile path (read @(Sym.Proxy (Code src ss) ': ss) @src consTransactions $
 215                         g_compta @(Sym.Proxy (Code src ss) ': ss) @src)
 216         return $ case r of
 217          Left err -> Left $ Error_Read_Syntax err
 218          Right r' | Just (Sym.Refl :: Transactions Sym.:~: j) <- eqT ->
 219                 case r' of
 220                  S.Left err -> Left $ Error_Read_Semantic err
 221                  S.Right _r'' -> Right $ (,context_read_warnings) LCC
 222                          { lcc_journals
 223                          , lcc_chart = context_read_chart
 224                          , lcc_style = context_read_style_amounts
 225                          -- , lcc_modules       = context_sym_modules
 226                          -- , lcc_terms         = context_sym_terms
 227                          }
 228 -}
 229 {-
 230 newtype ComptaG src ss a = ComptaG (forall j. P.ParsecT P.Dec Text (S.StateT (Context_Read src j) (S.StateT (State_Sym src ss) IO)) a)
 231 instance Functor     (ComptaG src ss) where
 232         fmap f (ComptaG m) = ComptaG (fmap f m)
 233 instance Applicative (ComptaG src ss) where
 234         pure a = ComptaG (pure a)
 235         ComptaG f <*> ComptaG a = ComptaG (f <*> a)
 236 instance Monad (ComptaG src ss) where
 237         return = pure
 238         ComptaG m >>= f = ComptaG (m >>= \a -> case f a of ComptaG b -> b)
 239 -}
 240
 241 {-
 242 readJournal ::
 243  forall src ss j g.
 244  g ~ P.ParsecT P.Dec Text (S.StateT (Context_Read src) (S.StateT (State_Sym src ss) IO)) =>
 245  Source src =>
 246  Show src =>
 247  SourceInj (Sym.AST_Type src) src =>
 248  SourceInj (Sym.KindK src) src =>
 249  SourceInj (Sym.TypeVT src) src =>
 250  Gram_Source src g =>
 251  Sym.Gram_Term_Atoms src ss g =>
 252  Sym.ImportTypes ss =>
 253  Sym.ModulesTyInj ss =>
 254  Sym.ModulesInj src ss =>
 255  Typeable j =>
 256  H.Zeroable j =>
 257  FilePath ->
 258  (Transaction -> j -> j) ->
 259  IO (( Either (P.ParseError Char P.Dec)
 260               (S.Either [At src (Error_Compta src)] CanonFile)
 261      , Context_Read src )
 262     , State_Sym src ss )
 263 readJournal path consTxn = fromFile path $ read consTxn $ g_compta @ss
 264
 265 type Loadable src ss =
 266  ( Sym.Source src
 267  , Show src
 268  , SourceInj (Sym.AST_Type src) src
 269  , SourceInj (Sym.KindK src) src
 270  , SourceInj (Sym.TypeVT src) src
 271  , Gram_Source src (P.ParsecT P.Dec Text (S.StateT (Context_Read src)
 272                                          (S.StateT (State_Sym src (Sym.Proxy (Code src ss) ': ss)) IO)))
 273  , Sym.Gram_Term_Atoms src (Sym.Proxy (Code src ss) ': ss)
 274                            (P.ParsecT P.Dec Text (S.StateT (Context_Read src)
 275                                                  (S.StateT (State_Sym src (Sym.Proxy (Code src ss) ': ss)) IO)))
 276  -- , Gram_Source src (ComptaT src ss)
 277  -- , Sym.Gram_Term_Atoms src ({-Sym.Proxy (Compta src ss) ':-} ss) (ComptaT src ss)
 278  -- , Sym.Gram_Term_AtomsFor src (Sym.Proxy (Compta src ss) : ss) (ComptaT src ss j) (Compta src ss)
 279  -- , Sym.Gram_Term_AtomsR   src (Sym.Proxy (Compta src ss) : ss) ss (ComptaT src ss j)
 280    -- (P.ParsecT P.Dec Text (S.StateT (Context_Read src j) (S.StateT (State_Sym src (Sym.Proxy (Compta src ss) : ss)) IO))) (Compta src ss)
 281  , Sym.ImportTypes    (Sym.Proxy (Code src ss) ': ss)
 282  , Sym.ModulesTyInj   (Sym.Proxy (Code src ss) ': ss)
 283  , Sym.ModulesInj src (Sym.Proxy (Code src ss) ': ss)
 284  , Typeable ss
 285  , Typeable src
 286  )
 287 -}