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