lcc/Hcompta/LCC/Read.hs

   1 {-# LANGUAGE DataKinds #-}
   2 {-# LANGUAGE AllowAmbiguousTypes #-}
   3 {-# LANGUAGE DeriveFunctor #-}
   4 {-# LANGUAGE GADTs #-}
   5 {-# LANGUAGE StandaloneDeriving #-}
   6 {-# LANGUAGE UndecidableInstances #-}
   7 {-# OPTIONS_GHC -fno-warn-orphans #-}
   8 -- {-# OPTIONS_GHC -freduction-depth=0 #-}
   9 module Hcompta.LCC.Read where
  10
  11 -- import Data.Functor.Identity (Identity(..))
  12 -- import Data.String (IsString(..))
  13 -- import Data.String (String, fromString)
  14 -- import Debug.Trace
  15 -- import qualified Control.Monad.Classes as MC
  16 import Control.Arrow (left)
  17 import Control.Applicative (Applicative(..), liftA2)
  18 import Control.Monad (Monad(..), void)
  19 import Control.Monad.IO.Class (MonadIO(..))
  20 import Data.Bool
  21 import Data.Char (Char)
  22 import Data.Decimal
  23 import Data.Eq (Eq(..))
  24 import Data.Foldable
  25 import Data.Functor.Compose (Compose(..))
  26 import Data.List.NonEmpty (NonEmpty(..), (<|))
  27 import Data.Map.Strict (Map)
  28 import Data.Maybe (Maybe(..), maybe, isJust)
  29 import Data.Monoid (Monoid(..))
  30 import Data.NonNull (NonNull)
  31 import Data.Ord (Ord(..))
  32 import Data.Semigroup (Semigroup(..))
  33 import Data.Text (Text)
  34 import Data.Time.LocalTime (TimeZone(..))
  35 import Data.Typeable ()
  36 import Language.Symantic.Parsing hiding (LR(..), At(..))
  37 import Prelude (Int, Integer, Num(..), Integral(..), fromIntegral)
  38 import Prelude hiding (any, (^), exp, read)
  39 import System.FilePath ((</>))
  40 import Text.Megaparsec.Pos (SourcePos)
  41 import Text.Show (Show)
  42 import qualified Control.Applicative as Alt
  43 import qualified Control.Exception.Safe as Exn
  44 import qualified Control.Monad.Classes as MC
  45 -- import qualified Control.Monad.Classes.Run as MC
  46 import qualified Control.Monad.Trans.State.Strict as SS
  47 import qualified Data.ByteString as BS
  48 import qualified Data.Char as Char
  49 import qualified Data.List as List
  50 import qualified Data.List.NonEmpty as NonEmpty
  51 import qualified Data.Map.Strict as Map
  52 import qualified Data.NonNull as NonNull
  53 import qualified Data.Strict as S
  54 import qualified Data.Text as Text
  55 import qualified Data.Text.Encoding as Enc
  56 import qualified Data.Time.Calendar  as Time
  57 import qualified Data.Time.LocalTime as Time
  58 import qualified Data.TreeMap.Strict as TreeMap
  59 import qualified Hcompta as H
  60 import qualified Language.Symantic as Sym
  61 -- import qualified Language.Symantic.Lib as Sym
  62 import qualified Language.Symantic.Grammar as Gram
  63 import qualified System.Directory as IO
  64 import qualified System.FilePath as FilePath
  65 import qualified Text.Megaparsec as P
  66 import qualified Text.Megaparsec.Prim as P
  67
  68 import Hcompta.LCC.Account
  69 import Hcompta.LCC.Name
  70 import Hcompta.LCC.Tag
  71 import Hcompta.LCC.Amount
  72 import Hcompta.LCC.Chart
  73 import Hcompta.LCC.Posting
  74 import Hcompta.LCC.Transaction
  75 import Hcompta.LCC.Journal
  76
  77 import qualified Hcompta.LCC.Lib.Strict as S
  78
  79 -- * Type 'Gram_Reader'
  80 class Gram_Reader ctx g where
  81         g_ask        :: g (ctx -> a) -> g a
  82         g_ask_before :: g (ctx -> a) -> g a
  83 deriving instance Gram_Reader ctx g => Gram_Reader ctx (CF g)
  84 instance
  85  ( ParsecC e s
  86  , MC.MonadReader ctx (P.ParsecT e s m)
  87  ) => Gram_Reader ctx (P.ParsecT e s m) where
  88         g_ask g = do
  89                 f <- g
  90                 s <- MC.ask
  91                 return (f s)
  92         g_ask_before g = do
  93                 s <- MC.ask
  94                 f <- g
  95                 return (f s)
  96
  97 -- * Type 'Gram_State'
  98 class Gram_State st g where
  99         g_get   :: g (st -> a) -> g a
 100         g_state :: g (st -> (st, a)) -> g a
 101         g_put   :: g (st, a) -> g a
 102 deriving instance Gram_State st g => Gram_State st (CF g)
 103 instance
 104  ( ParsecC e s
 105  , MC.MonadState st (P.ParsecT e s m)
 106  ) => Gram_State st (P.ParsecT e s m) where
 107         g_get g = do
 108                 f <- g
 109                 s <- MC.get
 110                 return (f s)
 111         g_state g = do
 112                 f <- g
 113                 s <- MC.get
 114                 let (s', a) = f s
 115                 MC.put s'
 116                 return a
 117         g_put g = do
 118                 (s, a) <- g
 119                 MC.put s
 120                 return a
 121
 122 -- * Type 'At'
 123 data At a
 124  =   At
 125  {   atBegin :: !(NonEmpty SourcePos)
 126  ,   atEnd   :: !SourcePos
 127  ,   atItem  :: !a
 128  } deriving (Eq, Functor, Ord, Show)
 129
 130 -- * Type 'Gram_At'
 131 class Gram_At g where
 132         g_at :: g ((err -> At err) -> a) -> g a
 133 deriving instance Gram_At g => Gram_At (CF g)
 134 instance ParsecC e s => Gram_At (P.ParsecT e s m) where
 135         g_at g = do
 136                 ps <- P.statePos <$> P.getParserState
 137                 fa <- g
 138                 p <- P.getPosition
 139                 return $ fa (At ps p)
 140
 141 nonEmpty :: NonNull [a] -> NonEmpty a
 142 nonEmpty n = x :| xs where (x, xs) = NonNull.splitFirst n
 143 nonNull :: NonEmpty a -> NonNull [a]
 144 nonNull n = NonNull.ncons x xs where x :| xs = n
 145
 146 instance Monad m => MC.MonadReaderN 'MC.Zero
 147  (NonEmpty CanonFile)
 148  (S.StateT (Context_Read j) m) where
 149         askN _px = MC.gets $ \(x::Context_Read j) -> context_read_canonfiles x
 150
 151 -- * Type 'ParsecT'
 152 type ParsecC e s = (P.Token s ~ Char, P.Stream s, P.ErrorComponent e)
 153 type instance MC.CanDo (P.ParsecT e s m) (MC.EffState a) = 'False
 154 type instance MC.CanDo (P.ParsecT e s m) (MC.EffReader P.SourcePos) = 'True
 155 type instance MC.CanDo (P.ParsecT e s m) (MC.EffReader (S.Either Exn.IOException CanonFile)) = 'True
 156
 157 instance ParsecC e s => MC.MonadReaderN 'MC.Zero P.SourcePos (P.ParsecT e s m) where
 158         askN _px = P.getPosition
 159 instance ParsecC e s => MC.MonadReaderN 'MC.Zero (NonEmpty P.SourcePos) (P.ParsecT e s m) where
 160         askN _px = P.statePos <$> P.getParserState
 161 instance (ParsecC e s, MonadIO m) => MC.MonadReaderN 'MC.Zero
 162  (S.Either Exn.IOException CanonFile)
 163  (P.ParsecT e s m) where
 164         askN _px = do
 165                 sn <- P.sourceName <$> P.getPosition
 166                 liftIO $ Exn.catch
 167                  (S.Right . CanonFile . PathFile <$> IO.canonicalizePath sn)
 168                  (\exn -> return $ S.Left exn)
 169 -- instance ParsecC e s => IsString (P.ParsecT e s m [Char]) where
 170 --      fromString = P.string
 171 instance ParsecC e s => Gram_Rule (P.ParsecT e s m) where
 172         rule = P.label . Text.unpack
 173 instance ParsecC e s => Gram_Terminal (P.ParsecT e s m) where
 174         any          = P.anyChar
 175         eoi          = P.eof
 176         char         = P.char
 177         string       = P.string
 178         unicat cat   = P.satisfy $ (`elem` cats) . Char.generalCategory
 179                 where cats = unicode_categories cat
 180         range (l, h) = P.satisfy $ \c -> l <= c && c <= h
 181         but (Terminal f) (Terminal p) = Terminal $ P.notFollowedBy (P.try p) *> f
 182 instance ParsecC e s => Alter (P.ParsecT e s m) where
 183         empty  = Alt.empty
 184         (<+>)  = (Alt.<|>)
 185         choice = P.choice
 186         -- choice = foldr ((Alt.<|>) . P.try) Alt.empty
 187         -- choice = foldr (Alt.<|>) Alt.empty
 188 instance ParsecC e s => Try (P.ParsecT e s m) where
 189         try = P.try
 190 instance ParsecC e s => Gram_RegR (P.ParsecT e s m) where
 191         Terminal f .*> Reg x = Reg $ f <*> x
 192 instance ParsecC e s => Gram_RegL (P.ParsecT e s m) where
 193         Reg f <*. Terminal x = Reg $ f <*> x
 194 instance ParsecC e s => App (P.ParsecT e s m)
 195 instance ParsecC e s => Alt (P.ParsecT e s m) where
 196         many       = P.many
 197         some       = P.some
 198         option     = P.option
 199         optional g = P.option Nothing (Just <$> g)
 200 instance ParsecC e s => Gram_CF (P.ParsecT e s m) where
 201         CF f <& Reg p      = CF $ P.lookAhead f <*> p
 202         Reg f &> CF p      = CF $ P.lookAhead f <*> p
 203         CF f `minus` Reg p = CF $ P.notFollowedBy (P.try p) *> f
 204 instance ParsecC e s => Gram_Meta P.SourcePos (P.ParsecT e s m) where
 205         metaG p = do
 206                 pos <- P.getPosition
 207                 ($ pos) <$> p
 208 instance ParsecC e s => Gram_Lexer   (P.ParsecT e s m)
 209 instance ParsecC e s => Gram_Count   (P.ParsecT e s m)
 210 instance ParsecC e s => Gram_Op      (P.ParsecT e s m)
 211 instance ParsecC e s => Gram_Char    (P.ParsecT e s m)
 212 instance ParsecC e s => Gram_Comment (P.ParsecT e s m)
 213 instance ParsecC e s => Gram_Tag     (P.ParsecT e s m)
 214 instance ParsecC e s => Gram_Account (P.ParsecT e s m)
 215 instance ParsecC e s => Gram_Amount  (P.ParsecT e s m)
 216 instance ParsecC e s => Gram_File    (P.ParsecT e s m)
 217 instance -- Gram_Date
 218  ( ParsecC e s
 219  , MC.MonadState Year (P.ParsecT e s m)
 220  ) => Gram_Date (P.ParsecT e s m) where
 221 instance -- Gram_Posting
 222  ( ParsecC e s
 223  , MC.MonadState Chart (P.ParsecT e s m)
 224  , MC.MonadState Style_Amounts (P.ParsecT e s m)
 225  , MC.MonadState (S.Maybe Unit) (P.ParsecT e s m)
 226  ) => Gram_Posting (P.ParsecT e s m)
 227 instance -- Gram_Transaction
 228  ( ParsecC e s
 229  , MC.MonadState (S.Maybe Unit) (P.ParsecT e s m)
 230  , MC.MonadState Chart          (P.ParsecT e s m)
 231  , MC.MonadState Section        (P.ParsecT e s m)
 232  , MC.MonadState Style_Amounts  (P.ParsecT e s m)
 233  , MC.MonadState Year           (P.ParsecT e s m)
 234  ) => Gram_Transaction (P.ParsecT e s m)
 235 instance -- Gram_Chart
 236  ( ParsecC e s
 237  , MC.MonadState Chart   (P.ParsecT e s m)
 238  , MC.MonadState Section (P.ParsecT e s m)
 239  ) => Gram_Chart (P.ParsecT e s m)
 240 instance -- Gram_IO
 241  ( ParsecC e s
 242  , MC.MonadState (S.Maybe Unit) (P.ParsecT e s m)
 243  , MC.MonadState Chart          (P.ParsecT e s m)
 244  , MC.MonadState Style_Amounts  (P.ParsecT e s m)
 245  , MC.MonadState Year           (P.ParsecT e s m)
 246  , P.MonadParsec e Text         (P.ParsecT e s m)
 247  , MonadIO m
 248  ) => Gram_IO (P.ParsecT e s m) where
 249         g_canonfile g = do
 250                 pf@(PathFile fp) <- g
 251                 liftIO $ (pf,) <$> Exn.catch
 252                  (Right . CanonFile . PathFile <$> IO.canonicalizePath fp)
 253                  (return . Left)
 254         g_read g_path g = do
 255                 lr <- g_at $ do
 256                         lr_path <- g_path
 257                         case lr_path of
 258                          S.Left e -> return $ \at -> S.Left $ at e
 259                          S.Right (PathFile fp) ->
 260                                 liftIO $ Exn.catch
 261                                  (const . S.Right . (fp,) . Enc.decodeUtf8 <$> BS.readFile fp)
 262                                  (\exn -> return $ \at -> S.Left $ at $ Error_Journal_Read (PathFile fp) exn)
 263                 case lr of
 264                  S.Left e -> do
 265                         return $ S.Left [e]
 266                  S.Right (fp_new, s_new) -> do
 267                         P.pushPosition $ P.initialPos fp_new
 268                         s_old <- P.getInput; P.setInput s_new
 269
 270                         lr_a <- g
 271                                 {-
 272                                 P.observing g >>= \case
 273                                  Left err -> do
 274                                         MC.put jf_old
 275                                         P.setInput s_old
 276                                         P.popPosition
 277                                         P.updateParserState (\st -> st{P.statePos=P.errorPos $ trace ("ERROR: " <> show err) err})
 278                                         P.failure
 279                                          (P.errorUnexpected err)
 280                                          (P.errorExpected err)
 281                                          (P.errorCustom err)
 282                                  Right a -> return a
 283                                 -}
 284
 285                         P.setInput s_old
 286                         P.popPosition
 287
 288                         return lr_a
 289 instance -- Gram_Journal
 290  ( ParsecC e s
 291  , Sym.Gram_Term_AtomsR Meta is is (P.ParsecT e s m)
 292  , MC.MonadReader (S.Either Exn.IOException CanonFile) (P.ParsecT e s m)
 293  , MC.MonadState (Context_Read j) (P.ParsecT e s m)
 294  , MC.MonadState (Journal j)      (P.ParsecT e s m)
 295  , MC.MonadState (Journals j)     (P.ParsecT e s m)
 296  , MC.MonadState (S.Maybe Unit)   (P.ParsecT e s m)
 297  , MC.MonadState Chart            (P.ParsecT e s m)
 298  , MC.MonadState Section          (P.ParsecT e s m)
 299  , MC.MonadState Style_Amounts    (P.ParsecT e s m)
 300  , MC.MonadState Year             (P.ParsecT e s m)
 301  , MC.MonadState (Env cs is) m
 302  , MC.MonadState (Sym.Tokenizers Meta is) m
 303  , P.MonadParsec e Text           (P.ParsecT e s m)
 304  , MonadIO m
 305  , Monoid j
 306  -- , Show j
 307  , Sym.Inj_Token Meta is (->)
 308  , Sym.Compile cs is
 309  ) => Gram_Journal cs is j (P.ParsecT e s m) where
 310 instance -- Gram_Term
 311  ( ParsecC e s
 312  , Gram.Gram_Meta meta (P.ParsecT e s m)
 313  , MC.MonadState (Sym.Tokenizers meta ts) (P.ParsecT e s m)
 314  , Sym.Gram_Term_AtomsR meta ts ts (P.ParsecT e s m)
 315  ) => Sym.Gram_Term ts meta (P.ParsecT e s m) where
 316         term_tokenizers (Gram.CF mf) = Gram.CF $ mf >>= MC.gets
 317         g_term_abst_args_body (Gram.CF args) (Gram.CF body) = Gram.CF $ do
 318                 as <- args
 319                 bo <- do
 320                         toks :: Sym.Tokenizers meta ts <- MC.get
 321                         MC.put $
 322                                 Sym.Tokenizers
 323                                  { Sym.tokenizers_prefix  = del (Sym.tokenizers_prefix  toks) as
 324                                  , Sym.tokenizers_infix   = del (Sym.tokenizers_infix   toks) as
 325                                  , Sym.tokenizers_postfix = del (Sym.tokenizers_postfix toks) as
 326                                  }
 327                         body <* MC.put toks
 328                 return (as, bo)
 329                 where del = foldr $ \(n, _) -> Map.adjust (Map.delete n) []
 330 instance -- Gram_Error
 331  ParsecC e s =>
 332  Sym.Gram_Error (P.ParsecT e s m) where
 333         term_unError (Gram.CF me) = Gram.CF $ do
 334                 e <- me
 335                 case e of
 336                  Left err -> fail $ show err
 337                  Right a -> return a
 338 instance -- Gram_Meta
 339  ParsecC e s =>
 340  Sym.Gram_Meta Meta (P.ParsecT e s m) where
 341         metaG = (($ ()) <$>)
 342 instance -- Gram_Type
 343  ( ParsecC e s
 344  , Gram_Meta meta (P.ParsecT e s m)
 345  ) => Sym.Gram_Type meta (P.ParsecT e s m)
 346 instance -- Gram_Name
 347  ParsecC e s =>
 348  Sym.Gram_Name (P.ParsecT e s m)
 349 instance -- Gram_Term_Type
 350  ( ParsecC e s
 351  , Gram.Gram_Meta meta (P.ParsecT e s m)
 352  ) => Sym.Gram_Term_Type meta (P.ParsecT e s m)
 353
 354 -- * Type 'Context_Read'
 355 data Context_Read j
 356  =   Context_Read
 357  {   context_read_year          :: !Year
 358  ,   context_read_style_amounts :: !Style_Amounts
 359  ,   context_read_chart         :: !Chart
 360  ,   context_read_unit          :: !(S.Maybe Unit)
 361  ,   context_read_journals      :: !(Journals j)
 362  ,   context_read_journal       :: !(NonEmpty (Journal j))
 363  ,   context_read_canonfiles    :: !(NonEmpty CanonFile)
 364  ,   context_read_warnings      :: ![At Warning_Journal]
 365  ,   context_read_section       :: !Section
 366  } deriving (Eq, Show)
 367
 368 type instance MC.CanDo (S.StateT (Context_Read j) m)
 369                        (MC.EffState (Sym.Tokenizers Meta is)) = 'False
 370
 371 context_read :: Monoid j => Context_Read j
 372 context_read =
 373         Context_Read
 374          { context_read_year          = Year $ H.date_year (H.date_epoch::Date)
 375          , context_read_style_amounts = mempty
 376          , context_read_chart         = mempty
 377          , context_read_unit          = S.Nothing
 378          , context_read_journals      = Journals Map.empty
 379          , context_read_journal       = journal :| []
 380          , context_read_canonfiles    = CanonFile "" :| []
 381          , context_read_warnings      = []
 382          , context_read_section       = Section_Chart
 383          }
 384
 385 -- * Type 'Context_Sym'
 386 data Context_Sym cs is
 387  =   Context_Sym
 388  {   context_sym_tokenizers :: !(Sym.Tokenizers Meta is)
 389  ,   context_sym_env        :: !(Env cs is)
 390  }
 391 type Meta = ()
 392
 393 context_sym
 394  :: Sym.Tokenize Meta is
 395  => Context_Sym cs is
 396 context_sym =
 397         Context_Sym
 398          { context_sym_tokenizers = Sym.tokenizers
 399          , context_sym_env        = Map.empty
 400          }
 401
 402 -- Sym.Tokenizers
 403 type instance MC.CanDo (S.StateT (Context_Sym cs is) m)
 404                        (MC.EffState (Sym.Tokenizers Meta is)) = 'True
 405 instance Monad m => MC.MonadStateN 'MC.Zero (Sym.Tokenizers Meta is) (S.StateT (Context_Sym cs is) m) where
 406         stateN _px f = S.StateT $ SS.state $ \ctx ->
 407                 (\a -> ctx{context_sym_tokenizers = a})
 408                  <$> f (context_sym_tokenizers ctx)
 409
 410 -- Env
 411 type instance MC.CanDo (S.StateT (Context_Read j) m)
 412                        (MC.EffState (Env cs is)) = 'False
 413 type instance MC.CanDo (S.StateT (Context_Sym cs is) m) (MC.EffState (Env cs is)) = 'True
 414 instance Monad m => MC.MonadStateN 'MC.Zero (Env cs is) (S.StateT (Context_Sym cs is) m) where
 415         stateN _px f = S.StateT $ SS.state $ \ctx ->
 416                 (\a -> ctx{context_sym_env = a})
 417                  <$> f (context_sym_env ctx)
 418
 419 -- Context_Read
 420 type instance MC.CanDo (S.StateT (Context_Read j) m)
 421                        (MC.EffState (Context_Read j)) = 'True
 422 instance Monad m => MC.MonadStateN 'MC.Zero (Context_Read j) (S.StateT (Context_Read j) m) where
 423         stateN _px = S.StateT . SS.state
 424 -- S.Maybe Unit
 425 type instance MC.CanDo (S.StateT (Context_Read j) m)
 426                        (MC.EffState (S.Maybe Unit)) = 'True
 427 instance Monad m => MC.MonadStateN 'MC.Zero (S.Maybe Unit) (S.StateT (Context_Read j) m) where
 428         stateN _px f = S.StateT $ SS.state $ \ctx ->
 429                 (\a -> ctx{context_read_unit = a})
 430                  <$> f (context_read_unit ctx)
 431 -- Chart
 432 type instance MC.CanDo (S.StateT (Context_Read j) m)
 433                        (MC.EffState Chart) = 'True
 434 instance Monad m => MC.MonadStateN 'MC.Zero Chart (S.StateT (Context_Read j) m) where
 435         stateN _px f = S.StateT $ SS.state $ \ctx ->
 436                 (\a -> ctx{context_read_chart = a})
 437                  <$> f (context_read_chart ctx)
 438 -- Year
 439 newtype Year = Year (H.Date_Year Date)
 440  deriving (Eq, Show)
 441 type instance MC.CanDo (S.StateT (Context_Read j) m)
 442                        (MC.EffState Year) = 'True
 443 instance Monad m => MC.MonadStateN 'MC.Zero Year (S.StateT (Context_Read j) m) where
 444         stateN _px f = S.StateT $ SS.state $ \ctx ->
 445                 (\a -> ctx{context_read_year = a})
 446                  <$> f (context_read_year ctx)
 447 -- Section
 448 data Section
 449  =   Section_Chart
 450  |   Section_Transaction
 451  deriving (Eq, Show)
 452 type instance MC.CanDo (S.StateT (Context_Read j) m)
 453                        (MC.EffState Section) = 'True
 454 instance Monad m => MC.MonadStateN 'MC.Zero Section (S.StateT (Context_Read j) m) where
 455         stateN _px f = S.StateT $ SS.state $ \ctx ->
 456                 (\a -> ctx{context_read_section = a})
 457                  <$> f (context_read_section ctx)
 458 -- Journals
 459 type instance MC.CanDo (S.StateT (Context_Read j) m)
 460                        (MC.EffState (Journals j)) = 'True
 461 instance Monad m => MC.MonadStateN 'MC.Zero (Journals j) (S.StateT (Context_Read j) m) where
 462         stateN _px f = S.StateT $ SS.state $ \ctx ->
 463                 (\a -> ctx{context_read_journals = a})
 464                  <$> f (context_read_journals ctx)
 465 -- Journal
 466 type instance MC.CanDo (S.StateT (Context_Read j) m)
 467                        (MC.EffState (Journal j)) = 'True
 468 instance Monad m => MC.MonadStateN 'MC.Zero (Journal j) (S.StateT (Context_Read j) m) where
 469         stateN _px f = S.StateT $ SS.state $ \ctx@Context_Read{context_read_journal = j:|js} ->
 470                 (\a -> ctx{context_read_journal = a:|js}) <$> f j
 471 -- * Style_Amounts
 472 type instance MC.CanDo (S.StateT (Context_Read j) m)
 473                        (MC.EffState Style_Amounts) = 'True
 474 instance Monad m => MC.MonadStateN 'MC.Zero Style_Amounts (S.StateT (Context_Read j) m) where
 475         stateN _px f = S.StateT $ SS.state $ \ctx ->
 476                 (\s -> ctx{context_read_style_amounts = s})
 477                  <$> f (context_read_style_amounts ctx)
 478
 479 -- * Type 'Error_Date'
 480 data Error_Date
 481  =   Error_Date_Day_invalid (Integer, Int, Int)
 482  |   Error_Date_TimeOfDay_invalid (Int, Int, Int)
 483  |   Error_Date_TimeZone_unknown Text
 484  deriving (Eq, Show)
 485 -- * Type 'Error_Posting'
 486 data Error_Posting
 487  =   Error_Posting_Account_Ref_unknown Tag_Path
 488  |   Error_Posting_Account_Ref_multiple Tag_Path (Map Account ())
 489  |   Error_Postings_not_equilibrated Postings
 490  deriving (Eq, Show)
 491 -- * Type 'Error_Transaction'
 492 data Error_Transaction
 493  =   Error_Transaction_Date Error_Date
 494  |   Error_Transaction_Posting Error_Posting
 495  |   Error_Transaction_not_equilibrated
 496       Transaction
 497       [( Unit
 498        , H.SumByUnit (NonNull [Account_Section]) (H.Polarized Quantity)
 499        )]
 500  deriving (Eq, Show)
 501 -- * Type 'Error_Chart'
 502 data Error_Chart
 503  =   Error_Chart
 504  deriving (Eq, Show)
 505 -- * Type 'Error_Journal'
 506 data Error_Journal cs is
 507  =   Error_Journal_Transaction Error_Transaction
 508  |   Error_Journal_Read PathFile Exn.IOException
 509  |   Error_Journal_Include_loop CanonFile
 510  |   Error_Journal_Chart Error_Chart
 511  |   Error_Journal_Section Section Section
 512  |   Error_Journal_Term (Sym.Error_Term Meta cs is)
 513 deriving instance Eq_Token Meta is => Eq (Error_Journal cs is)
 514 deriving instance -- Show
 515  ( Show_Token Meta is
 516  , Sym.Show_TyConst cs
 517  ) => Show (Error_Journal cs is)
 518 -- * Type 'Warning_Journal'
 519 data Warning_Journal
 520  =   Warning_Journal_Include_multiple CanonFile
 521  deriving (Eq, Show)
 522
 523 -- * Class 'Gram_IO'
 524 class Gram_IO g where
 525         g_canonfile
 526          :: g PathFile
 527          -> g (PathFile, Either Exn.IOException CanonFile)
 528         g_read
 529          :: g (S.Either (Error_Journal cs is) PathFile)
 530          -> g (S.Either [At (Error_Journal cs is)] (CanonFile, a))
 531          -> g (S.Either [At (Error_Journal cs is)] (CanonFile, a))
 532 deriving instance Gram_IO g => Gram_IO (CF g)
 533
 534 -- * Class 'Gram_Count'
 535 class
 536  ( Applicative g
 537  , Alt g
 538  ) => Gram_Count g where
 539         count :: Int -> CF g a -> CF g [a]
 540         count n p
 541                 | n <= 0    = pure []
 542                 | otherwise = sequenceA $ List.replicate n p
 543         count' :: Int -> Int -> CF g a -> CF g [a]
 544         count' m n p
 545          | n <= 0 || m > n = pure []
 546          | m > 0 = (:) <$> p <*> count' (pred m) (pred n) p
 547          | otherwise =
 548                 let f t ts = maybe [] (:ts) t
 549                 in f <$> optional p <*> count' 0 (pred n) p
 550
 551 -- * Class 'Gram_Char'
 552 class
 553  ( Gram_Lexer g
 554  , Try g
 555  ) => Gram_Char g where
 556         g_eol :: CF g ()
 557         g_eol = rule "EOL" $ void (char '\n') <+> void (string "\r\n")
 558         g_tab :: CF g ()
 559         g_tab = rule "Tab" $ void $ char '\t'
 560         g_space :: CF g Char
 561         g_space = rule "Space" $ char ' '
 562         g_spaces :: CF g Text
 563         g_spaces = Text.pack <$> many g_space
 564         g_spaces1 :: CF g ()
 565         g_spaces1 = void $ some g_space
 566         g_char :: CF g Char
 567         g_char = g_char_passive <+> g_char_active
 568         g_char_passive :: CF g Char
 569         g_char_passive = choice $ unicat <$> [Unicat_Letter, Unicat_Number, Unicat_Mark]
 570         g_char_active :: CF g Char
 571         g_char_active = choice $ unicat <$> [Unicat_Punctuation, Unicat_Symbol]
 572         g_char_attribute :: Reg lr g Char
 573         g_char_attribute = choice $ char <$> "#/:;@~="
 574         g_word :: CF g Text
 575         g_word = rule "Word" $ Text.pack <$> some g_char
 576         g_words :: CF g Text
 577         g_words = Text.concat <$> many (try $ (<>) <$> g_spaces <*> g_word)
 578         g_09 :: CF g Char
 579         g_09 = range ('0', '9')
 580         g_19 :: CF g Char
 581         g_19 = range ('1', '9')
 582         g_sign :: Num int => CF g (int -> int)
 583         g_sign =
 584                 (negate <$ char '-') <+>
 585                 (id     <$ char '+')
 586
 587 -- * Class 'Gram_Date'
 588 class
 589  ( Gram_State Year g
 590  , Gram_At g
 591  , Gram_Char g
 592  , Gram_Count g
 593  , Try g
 594  ) => Gram_Date g where
 595         g_date :: CF g (S.Either (At Error_Date) Date)
 596         g_date = rule "Date" $
 597                 (liftA2 $ \day (tod, tz) ->
 598                         Time.localTimeToUTC tz $
 599                         Time.LocalTime day tod)
 600                  <$> g_ymd
 601                  <*> option
 602                          (S.Right (Time.midnight, Time.utc))
 603                          (liftA2 (,)
 604                                  <$ char '_'
 605                                  <*> g_tod
 606                                  <*> option (S.Right Time.utc) g_timezone)
 607         g_ymd :: CF g (S.Either (At Error_Date) Time.Day)
 608         g_ymd = rule "YMD" $
 609                 g_at $
 610                 try (mk_ymd
 611                  <$> g_year
 612                  <*  char char_ymd_sep
 613                  <*> g_month
 614                  <*  char char_ymd_sep
 615                  <*> g_dom)
 616                 <+>
 617                 mk_ymd
 618                  <$> g_get (pure $ \(Year y) -> y)
 619                  <*> g_month
 620                  <*  char char_ymd_sep
 621                  <*> g_dom
 622                 where
 623                 mk_ymd y m d at =
 624                         case Time.fromGregorianValid y m d of
 625                          Nothing  -> S.Left $ at $ Error_Date_Day_invalid (y, m, d)
 626                          Just day -> S.Right day
 627         g_tod :: CF g (S.Either (At Error_Date) Time.TimeOfDay)
 628         g_tod = rule "TimeOfDay" $
 629                 g_at $
 630                 (\hr (mn, sc) at ->
 631                         case Time.makeTimeOfDayValid hr mn (fromInteger $ toInteger sc) of
 632                          Nothing -> S.Left $ at $ Error_Date_TimeOfDay_invalid (hr, mn, sc)
 633                          Just tod -> S.Right $ tod)
 634                  <$> g_hour
 635                  <*> option (0, 0)
 636                         ((,)
 637                          <$> (char char_tod_sep *> g_minute)
 638                          <*> option 0 (char char_tod_sep *> g_second))
 639         g_year :: CF g Integer
 640         g_year = rule "Year" $
 641                 (\sg y -> sg $ integer_of_digits 10 y)
 642                  <$> option id (negate <$ char '-')
 643                  <*> some g_09
 644         g_month :: CF g Int
 645         g_month = rule "Month" $ int_of_digits 10 <$> count' 1 2 g_09
 646         g_dom :: CF g Int
 647         g_dom = rule "DayOfMonth" $ int_of_digits 10 <$> count' 1 2 g_09
 648         g_hour :: CF g Int
 649         g_hour = rule "Hour" $ int_of_digits 10 <$> count' 1 2 g_09
 650         g_minute :: CF g Int
 651         g_minute = rule "Minute" $ int_of_digits 10 <$> count' 1 2 g_09
 652         g_second :: CF g Int
 653         g_second = rule "Second" $ int_of_digits 10 <$> count' 1 2 g_09
 654
 655         g_timezone :: CF g (S.Either (At Error_Date) TimeZone)
 656         g_timezone = rule "TimeZone" $
 657                 -- DOC: http://www.timeanddate.com/time/zones/
 658                 -- TODO: only a few time zones are suported below.
 659                 -- TODO: check the timeZoneSummerOnly values
 660                 (S.Right <$> g_timezone_digits) <+>
 661                 (g_at $ read_tz <$ char '_' <*> some (range ('A', 'Z')))
 662                 where
 663                 read_tz n at = case n of
 664                  "AST"  -> S.Right $ TimeZone (- 4 * 60) False n
 665                  "ADT"  -> S.Right $ TimeZone (- 3 * 60) True  n
 666                  "A"    -> S.Right $ TimeZone (- 1 * 60) False n
 667                  "BST"  -> S.Right $ TimeZone (-11 * 60) False n
 668                  "BDT"  -> S.Right $ TimeZone (-10 * 60) True  n
 669                  "CET"  -> S.Right $ TimeZone (  1 * 60) True  n
 670                  "CEST" -> S.Right $ TimeZone (  2 * 60) False n
 671                  "CST"  -> S.Right $ TimeZone (- 6 * 60) False n
 672                  "CDT"  -> S.Right $ TimeZone (- 5 * 60) True  n
 673                  "EST"  -> S.Right $ TimeZone (- 5 * 60) False n
 674                  "EDT"  -> S.Right $ TimeZone (- 4 * 60) True  n
 675                  "GMT"  -> S.Right $ TimeZone    0       False n
 676                  "HST"  -> S.Right $ TimeZone (-10 * 60) False n
 677                  "HDT"  -> S.Right $ TimeZone (- 9 * 60) True  n
 678                  "MST"  -> S.Right $ TimeZone (- 7 * 60) False n
 679                  "MDT"  -> S.Right $ TimeZone (- 6 * 60) True  n
 680                  "M"    -> S.Right $ TimeZone (-12 * 60) False n
 681                  "NST"  -> S.Right $ TimeZone (- 3 * 60 - 30) False n
 682                  "N"    -> S.Right $ TimeZone (  1 * 60) False n
 683                  "PST"  -> S.Right $ TimeZone (- 8 * 60) False n
 684                  "PDT"  -> S.Right $ TimeZone (- 7 * 60) True  n
 685                  "YST"  -> S.Right $ TimeZone (- 9 * 60) False n
 686                  "YDT"  -> S.Right $ TimeZone (- 8 * 60) True  n
 687                  "Y"    -> S.Right $ TimeZone ( 12 * 60) False n
 688                  "Z"    -> S.Right $ TimeZone    0       False n
 689                  _      -> S.Left  $ at $ Error_Date_TimeZone_unknown (Text.pack n)
 690         g_timezone_digits :: CF g TimeZone
 691         g_timezone_digits = do
 692                 (\sg hr mn ->
 693                         let tz =
 694                                 TimeZone
 695                                  { timeZoneMinutes    = sg $ hr * 60 + mn
 696                                  , timeZoneSummerOnly = False
 697                                  , timeZoneName       = Time.timeZoneOffsetString tz
 698                                  }
 699                         in tz)
 700                  <$> g_sign
 701                  <*> g_hour
 702                  <*> option 0 (optional (char char_tod_sep) *> g_minute)
 703
 704 -- * Class 'Gram_Tag'
 705 class
 706  ( Gram_Char g
 707  , Gram_Terminal g
 708  , Try g
 709  ) => Gram_Tag g where
 710         g_tag :: CF g Tag
 711         g_tag = Tag
 712                  <$  char char_tag_prefix
 713                  <*> g_tag_path
 714                  <*> option (Tag_Data "")
 715                          ( try $ g_spaces
 716                          *> char char_tag_data_prefix
 717                          *> g_spaces
 718                          *> g_tag_value )
 719         g_tag_path :: CF g Tag_Path
 720         g_tag_path =
 721                 (\x xs -> Tag_Path $ NonNull.ncons x xs)
 722                  <$> g_tag_section
 723                  <*> many (try $ char char_tag_sep *> g_tag_section)
 724         g_tag_section :: CF g Tag_Path_Section
 725         g_tag_section =
 726                 Name . Text.pack
 727                  <$> some (g_char `minus` g_char_attribute)
 728         g_tag_value :: CF g Tag_Data
 729         g_tag_value = Tag_Data <$> g_words
 730
 731 -- * Class 'Gram_Comment'
 732 class
 733  ( Gram_Terminal g
 734  , Gram_Char g
 735  ) => Gram_Comment g where
 736         g_comment :: CF g Comment
 737         g_comment = rule "Comment" $
 738                 Comment <$ char ';' <* g_spaces <*> g_words
 739
 740 -- * Class 'Gram_Account'
 741 class
 742  ( Gram_At g
 743  , Gram_Char g
 744  , Gram_Lexer g
 745  , Gram_Tag g
 746  , Try g
 747  ) => Gram_Account g where
 748         g_account_section :: CF g Account_Section
 749         g_account_section =
 750                 Name . Text.pack
 751                  <$> some (g_char `minus` g_char_attribute)
 752         g_account :: CF g Account
 753         g_account = rule "Account" $
 754                 Account . NonNull.impureNonNull
 755                  <$> some (try $ char '/' *> g_account_section)
 756         g_account_tag :: CF g Account_Tag
 757         g_account_tag =
 758                 (Account_Tag <$>) $
 759                 Tag
 760                  <$  char char_account_tag_prefix
 761                  <*> g_tag_path
 762                  <*> option (Tag_Data "")
 763                          (try $ g_spaces
 764                          *> char char_tag_data_prefix
 765                          *> g_spaces
 766                          *> g_tag_value )
 767         g_account_tag_path :: CF g Tag_Path
 768         g_account_tag_path = rule "Tag_Path" $
 769                 char char_account_tag_prefix
 770                  *> g_tag_path
 771         {-
 772         g_anchor_section :: CF g Anchor_Section
 773         g_anchor_section = rule "Anchor_Section" $
 774                 Name . Text.pack
 775                  <$> some (g_char `minus` g_char_attribute)
 776         -}
 777
 778 -- * Class 'Gram_Amount'
 779 class
 780  ( Gram_Char g
 781  , Gram_Terminal g
 782  ) => Gram_Amount g where
 783         g_unit :: CF g Unit
 784         g_unit = rule "Unit" $
 785                 Unit . Text.singleton
 786                  <$> unicat (Unicat Char.CurrencySymbol)
 787         g_quantity :: CF g (Quantity, Style_Amount)
 788         g_quantity = rule "Quantity" $
 789                 (\(i, f, fr, gi, gf) ->
 790                         let int  = concat i in
 791                         let frac = concat f in
 792                         let precision = length frac in
 793                         -- guard (precision <= 255)
 794                         let mantissa = integer_of_digits 10 $ int <> frac in
 795                         ( Decimal
 796                                  (fromIntegral precision)
 797                                  mantissa
 798                         , mempty
 799                                  { style_amount_fractioning=fr
 800                                  , style_amount_grouping_integral=gi
 801                                  , style_amount_grouping_fractional=gf
 802                                  }
 803                         ))
 804                  <$> choice (try <$>
 805                          [ g_qty '_' ',' '_' <* (pure () `minus` choice (char <$> ",._"))
 806                          , g_qty '_' '.' '_' <* (pure () `minus` choice (char <$> ",._"))
 807                          , g_qty ',' '.' '_' <* (pure () `minus` choice (char <$> ",._"))
 808                          , g_qty '.' ',' '_' <* (pure () `minus` choice (char <$> ",._"))
 809                          ])
 810         g_qty
 811          :: Char -- ^ Integral grouping separator.
 812          -> Char -- ^ Fractioning separator.
 813          -> Char -- ^ Fractional grouping separator.
 814          -> CF g
 815          ( [String] -- integral
 816          , [String] -- fractional
 817          , S.Maybe Style_Amount_Fractioning -- fractioning
 818          , S.Maybe Style_Amount_Grouping -- grouping_integral
 819          , S.Maybe Style_Amount_Grouping -- grouping_fractional
 820          )
 821         g_qty int_group_sep frac_sep frac_group_sep = do
 822                 (\int mf ->
 823                         case mf of
 824                          Nothing ->
 825                                 ( int
 826                                 , []
 827                                 , S.Nothing
 828                                 , grouping_of_digits int_group_sep int
 829                                 , S.Nothing
 830                                 )
 831                          Just (fractioning, frac) ->
 832                                 ( int
 833                                 , frac
 834                                 , S.Just fractioning
 835                                 , grouping_of_digits int_group_sep int
 836                                 , grouping_of_digits frac_group_sep $ List.reverse frac
 837                                 ))
 838                  <$> ((:)
 839                          <$> some g_09
 840                          <*> option [] (many $ try $ char int_group_sep *> some g_09))
 841                  <*> option Nothing (Just <$> ((,)
 842                          <$> char frac_sep
 843                          <*> ((:)
 844                                  <$> many g_09
 845                                  <*> option [] (many $ try $ char frac_group_sep *> some g_09))))
 846                 where
 847                         grouping_of_digits :: Char -> [String] -> S.Maybe Style_Amount_Grouping
 848                         grouping_of_digits group_sep digits =
 849                                 case digits of
 850                                  []  -> S.Nothing
 851                                  [_] -> S.Nothing
 852                                  _   -> S.Just $
 853                                         Style_Amount_Grouping group_sep $
 854                                         canonicalize_grouping $
 855                                         length <$> digits
 856                         canonicalize_grouping :: [Int] -> [Int]
 857                         canonicalize_grouping groups =
 858                                 foldl' -- NOTE: remove duplicates at beginning and reverse.
 859                                  (\acc l0 -> case acc of
 860                                          l1:_ -> if l0 == l1 then acc else l0:acc
 861                                          _ -> l0:acc) [] $
 862                                 case groups of -- NOTE: keep only longer at beginning.
 863                                  l0:l1:t -> if l0 > l1 then groups else l1:t
 864                                  _ -> groups
 865
 866         g_amount :: CF g (Styled_Amount Amount)
 867         g_amount = rule "Amount" $ g_amount_minus <+> g_amount_plus
 868         g_amount_minus :: CF g (Styled_Amount Amount)
 869         g_amount_minus =
 870                 char '-' *> (
 871                         mk_amount L
 872                          <$> ((,) <$> g_unit <*> g_spaces)
 873                          <*> g_quantity
 874                         <+>
 875                         flip (mk_amount R)
 876                          <$> g_quantity
 877                          <*> option ("", H.unit_empty)
 878                                  (try $ flip (,) <$> g_spaces <*> g_unit) )
 879                 <+>
 880                 try (mk_amount L
 881                  <$> ((,) <$> g_unit <*> g_spaces)
 882                  <*  char '-'
 883                  <*> g_quantity)
 884                 where
 885                 mk_amount :: LR -> (Unit, Text) -> (Quantity, Style_Amount) -> (Style_Amount, Amount)
 886                 mk_amount side (unit, sp) (qty, sty) =
 887                         ( case unit of
 888                          Unit "" -> sty
 889                          _ -> sty
 890                                 { style_amount_unit_side   = S.Just side
 891                                 , style_amount_unit_spaced = S.Just $ not $ Text.null sp
 892                                 }
 893                         , Amount
 894                                 { amount_quantity = negate qty
 895                                 , amount_unit     = unit
 896                                 }
 897                         )
 898         g_amount_plus :: CF g (Styled_Amount Amount)
 899         g_amount_plus =
 900                 char '+' *> (
 901                         mk_amount L
 902                          <$> ((,) <$> g_unit <*> g_spaces)
 903                          <*> g_quantity
 904                         <+>
 905                         flip (mk_amount R)
 906                          <$> g_quantity
 907                          <*> option ("", H.unit_empty)
 908                                  (try $ flip (,) <$> g_spaces <*> g_unit) )
 909                 <+>
 910                 mk_amount L
 911                  <$> ((,) <$> g_unit <*> g_spaces)
 912                  <*  optional (char '+')
 913                  <*> g_quantity
 914                 <+>
 915                 flip (mk_amount R)
 916                  <$> g_quantity
 917                  <*> option ("", H.unit_empty)
 918                          (try $ flip (,) <$> g_spaces <*> g_unit)
 919                 where
 920                 mk_amount :: LR -> (Unit, Text) -> (Quantity, Style_Amount) -> (Style_Amount, Amount)
 921                 mk_amount side (unit, sp) (qty, sty) =
 922                         ( case unit of
 923                          Unit "" -> sty
 924                          _ -> sty
 925                                 { style_amount_unit_side   = S.Just side
 926                                 , style_amount_unit_spaced = S.Just $ not $ Text.null sp
 927                                 }
 928                         , Amount
 929                                 { amount_quantity = qty
 930                                 , amount_unit     = unit
 931                                 }
 932                         )
 933
 934 -- * Class 'Gram_Posting'
 935 class
 936  ( Gram_Account g
 937  , Gram_Amount g
 938  , Gram_Char g
 939  , Gram_Comment g
 940  , Gram_Reader P.SourcePos g
 941  , Gram_State (S.Maybe Unit) g
 942  , Gram_State Chart g
 943  , Gram_State Style_Amounts g
 944  , Gram_Terminal g
 945  ) => Gram_Posting g where
 946         g_postings :: CF g (S.Either (At Error_Posting) [Posting])
 947         g_postings =
 948                 fmap sequenceA $
 949                 many $ try $
 950                         many (try $ g_spaces *> g_eol) *>
 951                         g_spaces1 *> g_posting
 952         g_posting :: CF g (S.Either (At Error_Posting) Posting)
 953         g_posting = rule "Posting" $
 954                 g_state $ g_get $ g_ask_before $
 955                 (\lr_acct
 956                  may_amt attrs
 957                   posting_sourcepos ctx_unit
 958                  (Style_Amounts ctx_stys) -> do
 959                         let (posting_tags, posting_comments) = attrs
 960                         let (stys, posting_amounts) =
 961                                 case may_amt of
 962                                  Nothing -> (Style_Amounts ctx_stys, mempty)
 963                                  Just (sty, amt) ->
 964                                         let ctx =
 965                                                 Style_Amounts $
 966                                                 Map.insertWith (flip (<>))
 967                                                  (amount_unit amt)
 968                                                  sty ctx_stys in
 969                                         let unit =
 970                                                 case amount_unit amt of
 971                                                  u | u == H.unit_empty -> S.fromMaybe u ctx_unit
 972                                                  u -> u in
 973                                         (ctx,) $
 974                                                 Amounts $
 975                                                 Map.singleton unit $
 976                                                 amount_quantity amt
 977                         (stys,) $ do
 978                                 (posting_account, posting_account_ref) <- lr_acct
 979                                 S.Right $
 980                                         Posting
 981                                          { posting_account
 982                                          , posting_account_ref
 983                                          , posting_amounts
 984                                          , posting_tags
 985                                          , posting_comments
 986                                          , posting_dates = []
 987                                          , posting_sourcepos
 988                                          })
 989                  <$> g_posting_account
 990                  <*> optional (try $ g_spaces1 *> g_amount)
 991                  <*> g_posting_attrs
 992         g_posting_account
 993          :: CF g (S.Either (At Error_Posting)
 994                            (Account, S.Maybe (S.Pair Tag_Path (S.Maybe Account))))
 995         g_posting_account = rule "Posting_Account" $
 996                 (S.Right . (, S.Nothing) <$> g_account) <+>
 997                 (mk_posting_account
 998                          <$> (g_at $ g_get $ expand_tag_path <$> g_account_tag_path)
 999                          <*> option S.Nothing (S.Just <$> g_account))
1000                 where
1001                 mk_posting_account path acct =
1002                         (\(p, a) ->
1003                                 (,)
1004                                  (S.maybe a (a <>) acct)
1005                                  (S.Just (p S.:!: acct)) )
1006                          <$> path
1007                 expand_tag_path tag chart at =
1008                         case Map.lookup tag $ chart_tags chart of
1009                          Just accts | Map.size accts > 0 ->
1010                                 if Map.size accts == 1
1011                                 then
1012                                         let acct = fst $ Map.elemAt 0 accts in
1013                                         S.Right (tag, acct)
1014                                 else S.Left $ at $ Error_Posting_Account_Ref_multiple tag accts
1015                          _ ->  S.Left $ at $ Error_Posting_Account_Ref_unknown tag
1016         g_posting_tag :: CF g Posting_Tag
1017         g_posting_tag = rule "Posting_Tag" $ Posting_Tag <$> g_tag
1018         g_posting_attrs :: CF g (Posting_Tags, [Comment])
1019         g_posting_attrs =
1020                 foldr ($) mempty . Compose
1021                  <$> (many $ try $
1022                         many (try $ g_spaces *> g_eol *> g_spaces1) *>
1023                         some (try $
1024                                 g_spaces *>
1025                                 choice
1026                                  [ add_tag     <$> g_posting_tag
1027                                  , add_comment <$> g_comment
1028                                  ]))
1029                 where
1030                 add_tag (Posting_Tag (Tag (Tag_Path p) v)) =
1031                         \(Posting_Tags (Tags tags), cmts) ->
1032                                 ( Posting_Tags (Tags (TreeMap.insert (<>) p [v] tags))
1033                                 , cmts )
1034                 add_comment c =
1035                         \(tags, cmts) ->
1036                                 (tags, c:cmts)
1037
1038 -- * Class 'Gram_Transaction'
1039 class
1040  ( Gram_Account g
1041  , Gram_Amount g
1042  , Gram_Char g
1043  , Gram_Comment g
1044  , Gram_Date g
1045  , Gram_Posting g
1046  , Gram_Terminal g
1047  , Gram_State Section g
1048  ) => Gram_Transaction g where
1049         g_transaction :: CF g (S.Either (At Error_Transaction) Transaction)
1050         g_transaction = rule "Transaction" $
1051                 g_put $ ((Section_Transaction,) <$>) $
1052                 g_state $ (update_year <$>) $
1053                 g_at $ g_ask_before $
1054                 (\lr_date
1055                  transaction_wording
1056                  ( transaction_tags
1057                  , transaction_comments )
1058                  lr_posts
1059                  transaction_sourcepos at -> do
1060                         date  <- fmap Error_Transaction_Date    `S.left` lr_date
1061                         posts <- fmap Error_Transaction_Posting `S.left` lr_posts
1062                         let postsByAcct = postings_by_account posts
1063                         let txn =
1064                                 Transaction
1065                                  { transaction_tags
1066                                  , transaction_comments
1067                                  , transaction_dates = NonNull.ncons date []
1068                                  , transaction_wording
1069                                  , transaction_postings = Postings postsByAcct
1070                                  , transaction_sourcepos
1071                                  }
1072                         case H.equilibrium postsByAcct of
1073                          (_, Left ko) -> S.Left $ at $ Error_Transaction_not_equilibrated txn ko
1074                          (_bal, Right ok) -> S.Right txn{transaction_postings = Postings ok}
1075                  )
1076                  <$> g_date
1077                  <*  g_spaces1
1078                  <*> g_wording
1079                  <*> g_transaction_attrs
1080                  <*> g_postings
1081                 where
1082                 update_year lr_txn y =
1083                         (,lr_txn) $
1084                         case lr_txn of
1085                          S.Right txn -> Year $ H.date_year $ NonNull.head $ transaction_dates txn
1086                          _ -> y
1087         g_wording :: CF g Wording
1088         g_wording = rule "Wording" $
1089                 Wording . Text.concat
1090                  <$> many (try $
1091                         (<>)
1092                          <$> g_spaces
1093                          <*> (Text.pack
1094                                  <$> some (g_char `minus` char char_tag_prefix)))
1095         g_transaction_tag :: CF g Transaction_Tag
1096         g_transaction_tag = rule "Transaction_Tag" $ Transaction_Tag <$> g_tag
1097         g_transaction_attrs :: CF g (Transaction_Tags, [Comment])
1098         g_transaction_attrs =
1099                 foldr ($) mempty
1100                  <$> many (
1101                         choice (try <$>
1102                          [ add_tag     <$ many (try $ g_spaces *> g_eol *> g_spaces1) <*> g_transaction_tag
1103                          , add_comment <$ many (try $ g_spaces *> g_eol *> g_spaces)  <*> g_comment
1104                          ]))
1105                 where
1106                 add_tag (Transaction_Tag (Tag (Tag_Path p) v)) =
1107                         \(Transaction_Tags (Tags tags), cmts) ->
1108                                 ( Transaction_Tags (Tags (TreeMap.insert (<>) p [v] tags))
1109                                 , cmts )
1110                 add_comment c =
1111                         \(tags, cmts) ->
1112                                 (tags, c:cmts)
1113
1114 -- * Class 'Gram_File'
1115 class
1116  ( Gram_Char g
1117  , Gram_Rule g
1118  , Gram_Terminal g
1119  , Try g
1120  ) => Gram_File g where
1121         g_pathfile :: CF g PathFile
1122         g_pathfile = rule "PathFile" $
1123                 PathFile . concat
1124                  <$> some (try $ (:) <$> char '/' <*> some (g_char `minus` char '/'))
1125
1126 -- * Class 'Gram_Chart'
1127 class
1128  ( Gram_Account g
1129  , Gram_At g
1130  , Gram_Comment g
1131  , Gram_Lexer g
1132  , Gram_State Chart g
1133  , Gram_State Section g
1134  , Try g
1135  ) => Gram_Chart g where
1136         g_chart_entry :: CF g (S.Either (At (Error_Journal cs is)) Chart)
1137         g_chart_entry = rule "Chart" $
1138                 g_get $ g_at $
1139                 (\acct attrs at section ->
1140                         let (tags, tags2, _comments) = attrs in
1141                         if case section of
1142                                  Section_Transaction -> False
1143                                  Section_Chart -> True
1144                         then S.Right
1145                                 Chart
1146                                  { chart_accounts = TreeMap.singleton (H.get acct) tags
1147                                  , chart_tags     = Map.singleton acct () <$ tags2
1148                                  }
1149                         else S.Left $ at $ Error_Journal_Section section Section_Chart
1150                  )
1151                  <$> g_account
1152                  <*> g_chart_attrs
1153         g_chart_attrs :: CF g (Account_Tags, Map Tag_Path (), [Comment])
1154         g_chart_attrs =
1155                 foldr ($) mempty
1156                  <$> (many $ try $
1157                         many (try $ g_spaces *> g_eol) *>
1158                         choice
1159                          [ add_tag     <$ g_spaces1 <*> g_account_tag
1160                          , add_comment <$ g_spaces  <*> g_comment
1161                          ])
1162                 where
1163                 add_tag (Account_Tag (Tag (Tag_Path p) v)) =
1164                         \(Account_Tags (Tags tags), tags2, cmts) ->
1165                                 ( Account_Tags (Tags (TreeMap.insert (<>) p [v] tags))
1166                                 , Map.insert (Tag_Path p) () tags2
1167                                 , cmts )
1168                 add_comment c =
1169                         \(tags, tags2, cmts) ->
1170                                 (tags, tags2, c:cmts)
1171
1172 {-
1173 tokenizer :: forall is m.
1174  ( Inj_Tokens Meta is [Proxy (->), Proxy Integer]
1175  , Sym.Gram_Term is Meta (P.ParsecT P.Dec Text (SS.StateT (Sym.Tokenizers Meta is) m))
1176  , Sym.Tokenize Meta is
1177  , Monad m
1178  ) => Text -> m (Either (P.ParseError Char P.Dec) (EToken Meta is))
1179 tokenizer inp =
1180         -- runIdentity $
1181         MC.evalStateStrict (Sym.tokenizers::Sym.Tokenizers Meta is) $
1182         P.runParserT g "" inp
1183         where g = Gram.unCF $ Sym.g_term <* Gram.eoi
1184 -}
1185
1186 -- * Class 'Gram_Term'
1187 class
1188  ( Sym.Gram_Term is Meta g
1189  , Sym.Compile cs is
1190  , Sym.Inj_Token Meta is (->)
1191  , Gram_At g
1192  , Gram_State (Env cs is) g
1193  ) => Gram_Term cs is {-meta-} g where
1194         g_term
1195          :: CF g ( Sym.TeName
1196                  , Either (At (Sym.Error_Term Meta cs is))
1197                           (Sym.ETerm cs is) )
1198         g_term =
1199                 g_at $ g_get $
1200                 (\n v env at ->
1201                         (n,) $
1202                         (at `left`) $
1203                         Sym.closeContext $
1204                         Sym.withContext (Map.toList (env::Env cs is)) $
1205                         Sym.compileO v
1206                  )
1207                  <$> Sym.g_term_name
1208                  -- TODO: <*> many Sym.term_abst_decl
1209                  <*  Sym.symbol "="
1210                  <*> Sym.g_term
1211
1212 instance -- Gram_Term
1213  ( ParsecC e s
1214  , MC.MonadState (Sym.Tokenizers Meta is) m
1215  , MC.MonadState (Env cs is) m
1216  , P.MonadParsec e Text (P.ParsecT e s m)
1217  , Sym.Gram_Term_AtomsR Meta is is (P.ParsecT e s m)
1218  , Sym.Compile cs is
1219  , Sym.Inj_Token Meta is (->)
1220  , Monad m
1221  ) => Gram_Term cs is (P.ParsecT e s m) where
1222
1223 -- ** Type 'Env'
1224 type Env cs is = Map Sym.TeName (Sym.ETerm cs is)
1225
1226 -- * Class 'Gram_Journal'
1227 class
1228  ( Gram_Account g
1229  , Gram_At g
1230  , Gram_Chart g
1231  , Gram_File g
1232  , Gram_IO g
1233  , Gram_Lexer g
1234  , Gram_Reader (S.Either Exn.IOException CanonFile) g
1235  , Gram_State (Context_Read j) g
1236  , Gram_State (Journal j) g
1237  , Gram_State (Journals j) g
1238  , Gram_State (Env cs is) g
1239  , Gram_Transaction g
1240  , Gram_Term cs is g
1241  , Sym.Compile cs is
1242  , Sym.Inj_Token Meta is (->)
1243  , Try g
1244  , Monoid j
1245  ) => Gram_Journal cs is j g where
1246         g_journal
1247          :: (Transaction -> j -> j)
1248          -> CF g (S.Either [At (Error_Journal cs is)]
1249                            (CanonFile, Journal j))
1250         g_journal cons_txn = rule "Journal" $
1251                 g_state $ g_ask_before $
1252                 mk_journal
1253                  <$> (g_state $ g_at $ g_ask_before $ g_ask_before $ pure init_journal)
1254                  <*> many (choice
1255                          [ g_state $ mk_include <$> g_include @cs @is cons_txn
1256                          -- NOTE: g_include must be the first choice
1257                          -- in order to have Megaparsec reporting the errors
1258                          -- of the included journal.
1259                          , g_state $ mk_transaction <$> g_transaction
1260                          , g_state $ mk_chart <$> g_chart_entry
1261                          , g_state $ mk_term <$> g_term
1262                          , [] <$ try (g_spaces <* g_eol)
1263                          ])
1264                 where
1265                 init_journal
1266                  P.SourcePos{P.sourceName=jf} lr_cf at
1267                  (ctx@Context_Read
1268                          { context_read_journals   = Journals js
1269                          , context_read_journal    = jnls
1270                          , context_read_canonfiles = cfs
1271                          }::Context_Read j) =
1272                         case lr_cf of
1273                          S.Left e -> (ctx, S.Left $ at $ Error_Journal_Read (PathFile jf) e)
1274                          S.Right cf ->
1275                                 let jnl = journal{journal_file=PathFile jf} in
1276                                 (,S.Right ())
1277                                 ctx
1278                                  { context_read_journals   = Journals $ Map.insert cf jnl js
1279                                  , context_read_journal    = jnl <| jnls
1280                                  , context_read_canonfiles = cf <| cfs
1281                                  }
1282                 mk_journal err errs
1283                  P.SourcePos{P.sourceName=jf}
1284                  (ctx@Context_Read
1285                          { context_read_journals   = Journals js
1286                          , context_read_journal    = jnl :| jnls
1287                          , context_read_canonfiles = cf :| cfs
1288                          }::Context_Read j) =
1289                         case concat $ S.either (pure . pure) (const []) err <> errs of
1290                          [] ->
1291                                 let jnl' = jnl{journal_file=PathFile jf} in
1292                                 (,S.Right (cf, jnl'))
1293                                 ctx
1294                                  { context_read_journals   = Journals $ Map.insert cf jnl' js
1295                                  , context_read_journal    = NonEmpty.fromList jnls
1296                                  , context_read_canonfiles = NonEmpty.fromList cfs
1297                                  }
1298                          es -> (ctx, S.Left es)
1299                 mk_transaction lr_txn jnl@Journal{journal_content=j} =
1300                         case lr_txn of
1301                          S.Left err  -> (jnl, [Error_Journal_Transaction <$> err])
1302                          S.Right txn -> (jnl{ journal_content = txn `cons_txn` j }, [])
1303                 mk_include lr_inc (jnl::Journal j) =
1304                         case lr_inc of
1305                          S.Left errs -> (jnl, errs)
1306                          S.Right (cf, _inc) -> (jnl{ journal_includes = journal_includes jnl <> [cf] }, [])
1307                 mk_chart lr_ch chart =
1308                         case lr_ch of
1309                          S.Left err -> (chart, [err])
1310                          S.Right ch -> (chart <> ch, [])
1311                 mk_term (n, lr_te) terms =
1312                         case lr_te of
1313                          Left err -> (terms, [Error_Journal_Term <$> err])
1314                          Right (te::Sym.ETerm cs is) -> (insert_term n te terms, [])
1315                         where
1316                         insert_term
1317                          :: Sym.TeName
1318                          -> Sym.ETerm cs is
1319                          -> Env cs is
1320                          -> Env cs is
1321                         insert_term = Map.insert
1322         g_include
1323          :: (Transaction -> j -> j)
1324          -> CF g (S.Either [At (Error_Journal cs is)]
1325                            (CanonFile, Journal j))
1326         g_include cons_txn = rule "Include" $
1327                 g_read g_path (g_journal @cs @is cons_txn <* eoi)
1328                 where
1329                 g_path =
1330                         g_state $ g_at $ check_path
1331                          <$> (g_canonfile $ g_ask_before $ fmap mk_path $
1332                                 (\d (PathFile p) -> PathFile $ d:p)
1333                                  <$> char '.' <*> g_pathfile)
1334                 mk_path (PathFile fp) P.SourcePos{P.sourceName=fp_old} =
1335                         PathFile $
1336                         FilePath.normalise $
1337                         FilePath.takeDirectory fp_old </> fp
1338                 check_path (fp, lr_cf) at
1339                  (ctx@Context_Read
1340                          { context_read_journals   = Journals js
1341                          , context_read_canonfiles = cfs
1342                          , context_read_warnings   = warns
1343                          }::Context_Read j) =
1344                         case lr_cf of
1345                          Left e -> (ctx, S.Left $ Error_Journal_Read fp e)
1346                          Right cf ->
1347                                 if cf `Map.member` js
1348                                 then
1349                                         if cf `elem` cfs
1350                                         then (ctx, S.Left $ Error_Journal_Include_loop cf)
1351                                         else
1352                                                 (,S.Right fp) $
1353                                                 if isJust $ (`List.find` warns) $ \case
1354                                                  At{atItem=Warning_Journal_Include_multiple cf'} -> cf' `elem` cf<|cfs
1355                                                 then ctx
1356                                                 else ctx
1357                                                  { context_read_warnings =
1358                                                         at (Warning_Journal_Include_multiple cf) : warns }
1359                                 else (ctx, S.Right fp)
1360
1361 -- * Integers
1362
1363 -- | Return the 'Integer' obtained by multiplying the given digits
1364 --   with the power of the given base respective to their rank.
1365 integer_of_digits
1366  :: Integer -- ^ Base.
1367  -> String  -- ^ Digits (MUST be recognised by 'Char.digitToInt').
1368  -> Integer
1369 integer_of_digits base =
1370         foldl' (\x d -> base*x + toInteger (Char.digitToInt d)) 0
1371
1372 -- | Return the 'Int' obtained by multiplying the given digits
1373 --   with the power of the given base respective to their rank.
1374 int_of_digits
1375  :: Int -- ^ Base.
1376  -> String -- ^ Digits (MUST be recognised by 'Char.digitToInt').
1377  -> Int
1378 int_of_digits base =
1379         foldl' (\x d -> base*x + Char.digitToInt d) 0
1380
1381 -- * Chars
1382 char_account_sep :: Char
1383 char_account_sep = '/'
1384 char_account_tag_prefix :: Char
1385 char_account_tag_prefix = '~'
1386 char_ymd_sep :: Char
1387 char_ymd_sep = '-'
1388 char_tod_sep :: Char
1389 char_tod_sep = ':'
1390 char_comment_prefix :: Char
1391 char_comment_prefix = ';'
1392 char_tag_prefix :: Char
1393 char_tag_prefix = '#'
1394 char_tag_sep :: Char
1395 char_tag_sep = ':'
1396 char_tag_data_prefix :: Char
1397 char_tag_data_prefix = '='
1398 char_transaction_date_sep :: Char
1399 char_transaction_date_sep = '='
1400
1401 read
1402  :: forall is j cs e m a.
1403  ( Monoid j
1404  , Gram_File (P.ParsecT P.Dec Text m)
1405  , Sym.Tokenize Meta is
1406  , m ~ S.StateT (Context_Read j) (S.StateT (Context_Sym cs is) IO)
1407  , e ~ P.ParseError Char P.Dec
1408  , cs ~ Sym.TyConsts_of_Ifaces is
1409  )
1410  => CF (P.ParsecT P.Dec Text m) a
1411  -> FilePath
1412  -> Text
1413  -> IO ((Either e a, Context_Read j), Context_Sym cs is)
1414 read g fp inp =
1415         S.runState context_sym $
1416         S.runState context_read $
1417         P.runParserT (unCF $ g <* eoi) (FilePath.normalise fp) inp
1418
1419 read_file :: FilePath -> (FilePath -> Text -> IO a) -> IO a
1420 read_file fp f = do
1421         content <- Enc.decodeUtf8 <$> BS.readFile fp
1422         f fp content
1423
1424
1425 {-
1426 read_file
1427  :: (Consable c j, Monoid j)
1428  => Context_Read c j
1429  -> FilePath
1430  -> ExceptT [R.Error Error_Read] IO (Journal j)
1431 read_file ctx path =
1432         ExceptT
1433          (Exn.catch
1434                  (Right <$> Text.IO.readFile path) $
1435                  \ko -> return $ Left $
1436                          [R.Error_Custom (R.initialPos path) $
1437                                 Error_Read_reading_file path ko])
1438         >>= liftIO . R.runParserTWithError
1439          (read_journal path) ctx path
1440         >>= \x -> case x of
1441          Left  ko -> throwE $ ko
1442          Right ok -> ExceptT $ return $ Right ok
1443 -}