--- * -*- outline-regexp:"--- \\*"; -*-
--- ** doc
-- In Emacs, use TAB on lines beginning with "-- *" to collapse/expand sections.
{-|

File reading/parsing utilities used by multiple readers, and a good
amount of the parsers for journal format, to avoid import cycles
when JournalReader imports other readers.

Some of these might belong in Hledger.Read.JournalReader or Hledger.Read.

-}

--- ** language
{-# LANGUAGE BangPatterns        #-}
{-# LANGUAGE CPP                 #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE NoMonoLocalBinds    #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE PackageImports      #-}
{-# LANGUAGE Rank2Types          #-}
{-# LANGUAGE RecordWildCards     #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections       #-}
{-# LANGUAGE TypeFamilies        #-}

--- ** exports
module Hledger.Read.Common (
  Reader (..),
  InputOpts (..),
  definputopts,
  rawOptsToInputOpts,

  -- * parsing utilities
  runTextParser,
  rtp,
  runJournalParser,
  rjp,
  runErroringJournalParser,
  rejp,
  genericSourcePos,
  journalSourcePos,
  parseAndFinaliseJournal,
  parseAndFinaliseJournal',
  journalFinalise,
  journalCheckAccountsDeclared,
  journalCheckCommoditiesDeclared,
  journalCheckPayeesDeclared,
  setYear,
  getYear,
  setDefaultCommodityAndStyle,
  getDefaultCommodityAndStyle,
  getDefaultAmountStyle,
  getAmountStyle,
  addDeclaredAccountType,
  pushParentAccount,
  popParentAccount,
  getParentAccount,
  addAccountAlias,
  getAccountAliases,
  clearAccountAliases,
  journalAddFile,

  -- * parsers
  -- ** transaction bits
  statusp,
  codep,
  descriptionp,

  -- ** dates
  datep,
  datetimep,
  secondarydatep,

  -- ** account names
  modifiedaccountnamep,
  accountnamep,

  -- ** account aliases
  accountaliasp,

  -- ** amounts
  spaceandamountormissingp,
  amountp,
  amountp',
  mamountp',
  commoditysymbolp,
  priceamountp,
  balanceassertionp,
  lotpricep,
  numberp,
  fromRawNumber,
  rawnumberp,

  -- ** comments
  multilinecommentp,
  emptyorcommentlinep,

  followingcommentp,
  transactioncommentp,
  postingcommentp,

  -- ** bracketed dates
  bracketeddatetagsp,

  -- ** misc
  singlespacedtextp,
  singlespacedtextsatisfyingp,
  singlespacep,
  skipNonNewlineSpaces,
  skipNonNewlineSpaces1,
  aliasesFromOpts,

  -- * tests
  tests_Common,
)
where

--- ** imports
import Prelude ()
import "base-compat-batteries" Prelude.Compat hiding (fail, readFile)
import Control.Applicative.Permutations (runPermutation, toPermutationWithDefault)
import qualified "base-compat-batteries" Control.Monad.Fail.Compat as Fail (fail)
import Control.Monad.Except (ExceptT(..), runExceptT, throwError)
import Control.Monad.State.Strict hiding (fail)
import Data.Bifunctor (bimap, second)
import Data.Char (digitToInt, isDigit, isSpace)
import Data.Decimal (DecimalRaw (Decimal), Decimal)
import Data.Default (Default(..))
import Data.Function ((&))
import Data.Functor.Identity (Identity)
import "base-compat-batteries" Data.List.Compat
import Data.List.NonEmpty (NonEmpty(..))
import Data.Maybe (catMaybes, fromMaybe, isJust, listToMaybe)
import qualified Data.Map as M
import qualified Data.Semigroup as Sem
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time.Calendar (Day, fromGregorianValid, toGregorian)
import Data.Time.LocalTime (LocalTime(..), TimeOfDay(..))
import Data.Word (Word8)
import System.Time (getClockTime)
import Text.Megaparsec
import Text.Megaparsec.Char (char, char', digitChar, newline, string)
import Text.Megaparsec.Char.Lexer (decimal)
import Text.Megaparsec.Custom
  (FinalParseError, attachSource, customErrorBundlePretty,
  finalErrorBundlePretty, parseErrorAt, parseErrorAtRegion)

import Hledger.Data
import Hledger.Utils
import Safe (headMay)
import Text.Printf (printf)

--- ** doctest setup
-- $setup
-- >>> :set -XOverloadedStrings

--- ** types

-- main types; a few more below

-- | A hledger journal reader is a triple of storage format name, a
-- detector of that format, and a parser from that format to Journal.
-- The type variable m appears here so that rParserr can hold a
-- journal parser, which depends on it.
data Reader m = Reader {

     -- The canonical name of the format handled by this reader
     Reader m -> StorageFormat
rFormat   :: StorageFormat

     -- The file extensions recognised as containing this format
    ,Reader m -> [StorageFormat]
rExtensions :: [String]

     -- The entry point for reading this format, accepting input options, file
     -- path for error messages and file contents, producing an exception-raising IO
     -- action that produces a journal or error message.
    ,Reader m
-> InputOpts
-> StorageFormat
-> Text
-> ExceptT StorageFormat IO Journal
rReadFn   :: InputOpts -> FilePath -> Text -> ExceptT String IO Journal

     -- The actual megaparsec parser called by the above, in case
     -- another parser (includedirectivep) wants to use it directly.
    ,Reader m -> MonadIO m => ErroringJournalParser m Journal
rParser :: MonadIO m => ErroringJournalParser m ParsedJournal
    }

instance Show (Reader m) where show :: Reader m -> StorageFormat
show Reader m
r = Reader m -> StorageFormat
forall (m :: * -> *). Reader m -> StorageFormat
rFormat Reader m
r StorageFormat -> ShowS
forall a. [a] -> [a] -> [a]
++ StorageFormat
" reader"

-- $setup

-- | Various options to use when reading journal files.
-- Similar to CliOptions.inputflags, simplifies the journal-reading functions.
data InputOpts = InputOpts {
     -- files_             :: [FilePath]
     InputOpts -> Maybe StorageFormat
mformat_           :: Maybe StorageFormat  -- ^ a file/storage format to try, unless overridden
                                                --   by a filename prefix. Nothing means try all.
    ,InputOpts -> Maybe StorageFormat
mrules_file_       :: Maybe FilePath       -- ^ a conversion rules file to use (when reading CSV)
    ,InputOpts -> [StorageFormat]
aliases_           :: [String]             -- ^ account name aliases to apply
    ,InputOpts -> Bool
anon_              :: Bool                 -- ^ do light anonymisation/obfuscation of the data
    ,InputOpts -> Bool
ignore_assertions_ :: Bool                 -- ^ don't check balance assertions
    ,InputOpts -> Bool
new_               :: Bool                 -- ^ read only new transactions since this file was last read
    ,InputOpts -> Bool
new_save_          :: Bool                 -- ^ save latest new transactions state for next time
    ,InputOpts -> StorageFormat
pivot_             :: String               -- ^ use the given field's value as the account name
    ,InputOpts -> Bool
auto_              :: Bool                 -- ^ generate automatic postings when journal is parsed
    ,InputOpts -> Maybe (Map Text AmountStyle)
commoditystyles_   :: Maybe (M.Map CommoditySymbol AmountStyle) -- ^ optional commodity display styles affecting all files
    ,InputOpts -> Bool
strict_            :: Bool                 -- ^ do extra error checking (eg, all posted accounts are declared)
 } deriving (Int -> InputOpts -> ShowS
[InputOpts] -> ShowS
InputOpts -> StorageFormat
(Int -> InputOpts -> ShowS)
-> (InputOpts -> StorageFormat)
-> ([InputOpts] -> ShowS)
-> Show InputOpts
forall a.
(Int -> a -> ShowS)
-> (a -> StorageFormat) -> ([a] -> ShowS) -> Show a
showList :: [InputOpts] -> ShowS
$cshowList :: [InputOpts] -> ShowS
show :: InputOpts -> StorageFormat
$cshow :: InputOpts -> StorageFormat
showsPrec :: Int -> InputOpts -> ShowS
$cshowsPrec :: Int -> InputOpts -> ShowS
Show)

instance Default InputOpts where def :: InputOpts
def = InputOpts
definputopts

definputopts :: InputOpts
definputopts :: InputOpts
definputopts = InputOpts :: Maybe StorageFormat
-> Maybe StorageFormat
-> [StorageFormat]
-> Bool
-> Bool
-> Bool
-> Bool
-> StorageFormat
-> Bool
-> Maybe (Map Text AmountStyle)
-> Bool
-> InputOpts
InputOpts
    { mformat_ :: Maybe StorageFormat
mformat_           = Maybe StorageFormat
forall a. Maybe a
Nothing
    , mrules_file_ :: Maybe StorageFormat
mrules_file_       = Maybe StorageFormat
forall a. Maybe a
Nothing
    , aliases_ :: [StorageFormat]
aliases_           = []
    , anon_ :: Bool
anon_              = Bool
False
    , ignore_assertions_ :: Bool
ignore_assertions_ = Bool
False
    , new_ :: Bool
new_               = Bool
False
    , new_save_ :: Bool
new_save_          = Bool
True
    , pivot_ :: StorageFormat
pivot_             = StorageFormat
""
    , auto_ :: Bool
auto_              = Bool
False
    , commoditystyles_ :: Maybe (Map Text AmountStyle)
commoditystyles_   = Maybe (Map Text AmountStyle)
forall a. Maybe a
Nothing
    , strict_ :: Bool
strict_            = Bool
False
    }

rawOptsToInputOpts :: RawOpts -> InputOpts
rawOptsToInputOpts :: RawOpts -> InputOpts
rawOptsToInputOpts RawOpts
rawopts = InputOpts :: Maybe StorageFormat
-> Maybe StorageFormat
-> [StorageFormat]
-> Bool
-> Bool
-> Bool
-> Bool
-> StorageFormat
-> Bool
-> Maybe (Map Text AmountStyle)
-> Bool
-> InputOpts
InputOpts{
   -- files_             = listofstringopt "file" rawopts
   mformat_ :: Maybe StorageFormat
mformat_           = Maybe StorageFormat
forall a. Maybe a
Nothing
  ,mrules_file_ :: Maybe StorageFormat
mrules_file_       = StorageFormat -> RawOpts -> Maybe StorageFormat
maybestringopt StorageFormat
"rules-file" RawOpts
rawopts
  ,aliases_ :: [StorageFormat]
aliases_           = StorageFormat -> RawOpts -> [StorageFormat]
listofstringopt StorageFormat
"alias" RawOpts
rawopts
  ,anon_ :: Bool
anon_              = StorageFormat -> RawOpts -> Bool
boolopt StorageFormat
"anon" RawOpts
rawopts
  ,ignore_assertions_ :: Bool
ignore_assertions_ = StorageFormat -> RawOpts -> Bool
boolopt StorageFormat
"ignore-assertions" RawOpts
rawopts
  ,new_ :: Bool
new_               = StorageFormat -> RawOpts -> Bool
boolopt StorageFormat
"new" RawOpts
rawopts
  ,new_save_ :: Bool
new_save_          = Bool
True
  ,pivot_ :: StorageFormat
pivot_             = StorageFormat -> RawOpts -> StorageFormat
stringopt StorageFormat
"pivot" RawOpts
rawopts
  ,auto_ :: Bool
auto_              = StorageFormat -> RawOpts -> Bool
boolopt StorageFormat
"auto" RawOpts
rawopts
  ,commoditystyles_ :: Maybe (Map Text AmountStyle)
commoditystyles_   = Maybe (Map Text AmountStyle)
forall a. Maybe a
Nothing
  ,strict_ :: Bool
strict_            = StorageFormat -> RawOpts -> Bool
boolopt StorageFormat
"strict" RawOpts
rawopts
  }

--- ** parsing utilities

-- | Run a text parser in the identity monad. See also: parseWithState.
runTextParser, rtp
  :: TextParser Identity a -> Text -> Either (ParseErrorBundle Text CustomErr) a
runTextParser :: TextParser Identity a
-> Text -> Either (ParseErrorBundle Text CustomErr) a
runTextParser TextParser Identity a
p Text
t =  TextParser Identity a
-> StorageFormat
-> Text
-> Either (ParseErrorBundle Text CustomErr) a
forall e s a.
Parsec e s a
-> StorageFormat -> s -> Either (ParseErrorBundle s e) a
runParser TextParser Identity a
p StorageFormat
"" Text
t
rtp :: TextParser Identity a
-> Text -> Either (ParseErrorBundle Text CustomErr) a
rtp = TextParser Identity a
-> Text -> Either (ParseErrorBundle Text CustomErr) a
forall a.
TextParser Identity a
-> Text -> Either (ParseErrorBundle Text CustomErr) a
runTextParser

-- | Run a journal parser in some monad. See also: parseWithState.
runJournalParser, rjp
  :: Monad m
  => JournalParser m a -> Text -> m (Either (ParseErrorBundle Text CustomErr) a)
runJournalParser :: JournalParser m a
-> Text -> m (Either (ParseErrorBundle Text CustomErr) a)
runJournalParser JournalParser m a
p Text
t = ParsecT CustomErr Text m a
-> StorageFormat
-> Text
-> m (Either (ParseErrorBundle Text CustomErr) a)
forall (m :: * -> *) e s a.
Monad m =>
ParsecT e s m a
-> StorageFormat -> s -> m (Either (ParseErrorBundle s e) a)
runParserT (JournalParser m a -> Journal -> ParsecT CustomErr Text m a
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT JournalParser m a
p Journal
nulljournal) StorageFormat
"" Text
t
rjp :: JournalParser m a
-> Text -> m (Either (ParseErrorBundle Text CustomErr) a)
rjp = JournalParser m a
-> Text -> m (Either (ParseErrorBundle Text CustomErr) a)
forall (m :: * -> *) a.
Monad m =>
JournalParser m a
-> Text -> m (Either (ParseErrorBundle Text CustomErr) a)
runJournalParser

-- | Run an erroring journal parser in some monad. See also: parseWithState.
runErroringJournalParser, rejp
  :: Monad m
  => ErroringJournalParser m a
  -> Text
  -> m (Either FinalParseError (Either (ParseErrorBundle Text CustomErr) a))
runErroringJournalParser :: ErroringJournalParser m a
-> Text
-> m (Either
        FinalParseError (Either (ParseErrorBundle Text CustomErr) a))
runErroringJournalParser ErroringJournalParser m a
p Text
t =
  ExceptT
  FinalParseError m (Either (ParseErrorBundle Text CustomErr) a)
-> m (Either
        FinalParseError (Either (ParseErrorBundle Text CustomErr) a))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT
   FinalParseError m (Either (ParseErrorBundle Text CustomErr) a)
 -> m (Either
         FinalParseError (Either (ParseErrorBundle Text CustomErr) a)))
-> ExceptT
     FinalParseError m (Either (ParseErrorBundle Text CustomErr) a)
-> m (Either
        FinalParseError (Either (ParseErrorBundle Text CustomErr) a))
forall a b. (a -> b) -> a -> b
$ ParsecT CustomErr Text (ExceptT FinalParseError m) a
-> StorageFormat
-> Text
-> ExceptT
     FinalParseError m (Either (ParseErrorBundle Text CustomErr) a)
forall (m :: * -> *) e s a.
Monad m =>
ParsecT e s m a
-> StorageFormat -> s -> m (Either (ParseErrorBundle s e) a)
runParserT (ErroringJournalParser m a
-> Journal -> ParsecT CustomErr Text (ExceptT FinalParseError m) a
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT ErroringJournalParser m a
p Journal
nulljournal) StorageFormat
"" Text
t
rejp :: ErroringJournalParser m a
-> Text
-> m (Either
        FinalParseError (Either (ParseErrorBundle Text CustomErr) a))
rejp = ErroringJournalParser m a
-> Text
-> m (Either
        FinalParseError (Either (ParseErrorBundle Text CustomErr) a))
forall (m :: * -> *) a.
Monad m =>
ErroringJournalParser m a
-> Text
-> m (Either
        FinalParseError (Either (ParseErrorBundle Text CustomErr) a))
runErroringJournalParser

genericSourcePos :: SourcePos -> GenericSourcePos
genericSourcePos :: SourcePos -> GenericSourcePos
genericSourcePos SourcePos
p = StorageFormat -> Int -> Int -> GenericSourcePos
GenericSourcePos (SourcePos -> StorageFormat
sourceName SourcePos
p) (Pos -> Int
unPos (Pos -> Int) -> Pos -> Int
forall a b. (a -> b) -> a -> b
$ SourcePos -> Pos
sourceLine SourcePos
p) (Pos -> Int
unPos (Pos -> Int) -> Pos -> Int
forall a b. (a -> b) -> a -> b
$ SourcePos -> Pos
sourceColumn SourcePos
p)

-- | Construct a generic start & end line parse position from start and end megaparsec SourcePos's.
journalSourcePos :: SourcePos -> SourcePos -> GenericSourcePos
journalSourcePos :: SourcePos -> SourcePos -> GenericSourcePos
journalSourcePos SourcePos
p SourcePos
p' = StorageFormat -> (Int, Int) -> GenericSourcePos
JournalSourcePos (SourcePos -> StorageFormat
sourceName SourcePos
p) (Pos -> Int
unPos (Pos -> Int) -> Pos -> Int
forall a b. (a -> b) -> a -> b
$ SourcePos -> Pos
sourceLine SourcePos
p, Int
line')
    where line' :: Int
line' | (Pos -> Int
unPos (Pos -> Int) -> Pos -> Int
forall a b. (a -> b) -> a -> b
$ SourcePos -> Pos
sourceColumn SourcePos
p') Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 = Pos -> Int
unPos (SourcePos -> Pos
sourceLine SourcePos
p') Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
                | Bool
otherwise = Pos -> Int
unPos (Pos -> Int) -> Pos -> Int
forall a b. (a -> b) -> a -> b
$ SourcePos -> Pos
sourceLine SourcePos
p' -- might be at end of file withat last new-line

-- | Given a parser to ParsedJournal, input options, file path and
-- content: run the parser on the content, and finalise the result to
-- get a Journal; or throw an error.
parseAndFinaliseJournal :: ErroringJournalParser IO ParsedJournal -> InputOpts
                           -> FilePath -> Text -> ExceptT String IO Journal
parseAndFinaliseJournal :: ErroringJournalParser IO Journal
-> InputOpts
-> StorageFormat
-> Text
-> ExceptT StorageFormat IO Journal
parseAndFinaliseJournal ErroringJournalParser IO Journal
parser InputOpts
iopts StorageFormat
f Text
txt = do
  Integer
y <- IO Integer -> ExceptT StorageFormat IO Integer
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Integer
getCurrentYear
  let initJournal :: Journal
initJournal = Journal
nulljournal{ jparsedefaultyear :: Maybe Integer
jparsedefaultyear = Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
y, jincludefilestack :: [StorageFormat]
jincludefilestack = [StorageFormat
f] }
  Either
  FinalParseError (Either (ParseErrorBundle Text CustomErr) Journal)
eep <- IO
  (Either
     FinalParseError (Either (ParseErrorBundle Text CustomErr) Journal))
-> ExceptT
     StorageFormat
     IO
     (Either
        FinalParseError (Either (ParseErrorBundle Text CustomErr) Journal))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO
   (Either
      FinalParseError (Either (ParseErrorBundle Text CustomErr) Journal))
 -> ExceptT
      StorageFormat
      IO
      (Either
         FinalParseError
         (Either (ParseErrorBundle Text CustomErr) Journal)))
-> IO
     (Either
        FinalParseError (Either (ParseErrorBundle Text CustomErr) Journal))
-> ExceptT
     StorageFormat
     IO
     (Either
        FinalParseError (Either (ParseErrorBundle Text CustomErr) Journal))
forall a b. (a -> b) -> a -> b
$ ExceptT
  FinalParseError
  IO
  (Either (ParseErrorBundle Text CustomErr) Journal)
-> IO
     (Either
        FinalParseError (Either (ParseErrorBundle Text CustomErr) Journal))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT
   FinalParseError
   IO
   (Either (ParseErrorBundle Text CustomErr) Journal)
 -> IO
      (Either
         FinalParseError
         (Either (ParseErrorBundle Text CustomErr) Journal)))
-> ExceptT
     FinalParseError
     IO
     (Either (ParseErrorBundle Text CustomErr) Journal)
-> IO
     (Either
        FinalParseError (Either (ParseErrorBundle Text CustomErr) Journal))
forall a b. (a -> b) -> a -> b
$ ParsecT CustomErr Text (ExceptT FinalParseError IO) Journal
-> StorageFormat
-> Text
-> ExceptT
     FinalParseError
     IO
     (Either (ParseErrorBundle Text CustomErr) Journal)
forall (m :: * -> *) e s a.
Monad m =>
ParsecT e s m a
-> StorageFormat -> s -> m (Either (ParseErrorBundle s e) a)
runParserT (ErroringJournalParser IO Journal
-> Journal
-> ParsecT CustomErr Text (ExceptT FinalParseError IO) Journal
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT ErroringJournalParser IO Journal
parser Journal
initJournal) StorageFormat
f Text
txt
  -- TODO: urgh.. clean this up somehow
  case Either
  FinalParseError (Either (ParseErrorBundle Text CustomErr) Journal)
eep of
    Left FinalParseError
finalParseError -> StorageFormat -> ExceptT StorageFormat IO Journal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (StorageFormat -> ExceptT StorageFormat IO Journal)
-> StorageFormat -> ExceptT StorageFormat IO Journal
forall a b. (a -> b) -> a -> b
$ FinalParseErrorBundle' CustomErr -> StorageFormat
finalErrorBundlePretty (FinalParseErrorBundle' CustomErr -> StorageFormat)
-> FinalParseErrorBundle' CustomErr -> StorageFormat
forall a b. (a -> b) -> a -> b
$ StorageFormat
-> Text -> FinalParseError -> FinalParseErrorBundle' CustomErr
forall e.
StorageFormat
-> Text -> FinalParseError' e -> FinalParseErrorBundle' e
attachSource StorageFormat
f Text
txt FinalParseError
finalParseError
    Right Either (ParseErrorBundle Text CustomErr) Journal
ep -> case Either (ParseErrorBundle Text CustomErr) Journal
ep of
                  Left ParseErrorBundle Text CustomErr
e   -> StorageFormat -> ExceptT StorageFormat IO Journal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (StorageFormat -> ExceptT StorageFormat IO Journal)
-> StorageFormat -> ExceptT StorageFormat IO Journal
forall a b. (a -> b) -> a -> b
$ ParseErrorBundle Text CustomErr -> StorageFormat
customErrorBundlePretty ParseErrorBundle Text CustomErr
e
                  Right Journal
pj -> InputOpts
-> StorageFormat
-> Text
-> Journal
-> ExceptT StorageFormat IO Journal
journalFinalise InputOpts
iopts StorageFormat
f Text
txt Journal
pj

-- | Like parseAndFinaliseJournal but takes a (non-Erroring) JournalParser.
-- Also, applies command-line account aliases before finalising.
-- Used for timeclock/timedot.
-- TODO: get rid of this, use parseAndFinaliseJournal instead
parseAndFinaliseJournal' :: JournalParser IO ParsedJournal -> InputOpts
                           -> FilePath -> Text -> ExceptT String IO Journal
parseAndFinaliseJournal' :: JournalParser IO Journal
-> InputOpts
-> StorageFormat
-> Text
-> ExceptT StorageFormat IO Journal
parseAndFinaliseJournal' JournalParser IO Journal
parser InputOpts
iopts StorageFormat
f Text
txt = do
  Integer
y <- IO Integer -> ExceptT StorageFormat IO Integer
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Integer
getCurrentYear
  let initJournal :: Journal
initJournal = Journal
nulljournal
        { jparsedefaultyear :: Maybe Integer
jparsedefaultyear = Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
y
        , jincludefilestack :: [StorageFormat]
jincludefilestack = [StorageFormat
f] }
  Either (ParseErrorBundle Text CustomErr) Journal
ep <- IO (Either (ParseErrorBundle Text CustomErr) Journal)
-> ExceptT
     StorageFormat IO (Either (ParseErrorBundle Text CustomErr) Journal)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either (ParseErrorBundle Text CustomErr) Journal)
 -> ExceptT
      StorageFormat
      IO
      (Either (ParseErrorBundle Text CustomErr) Journal))
-> IO (Either (ParseErrorBundle Text CustomErr) Journal)
-> ExceptT
     StorageFormat IO (Either (ParseErrorBundle Text CustomErr) Journal)
forall a b. (a -> b) -> a -> b
$ ParsecT CustomErr Text IO Journal
-> StorageFormat
-> Text
-> IO (Either (ParseErrorBundle Text CustomErr) Journal)
forall (m :: * -> *) e s a.
Monad m =>
ParsecT e s m a
-> StorageFormat -> s -> m (Either (ParseErrorBundle s e) a)
runParserT (JournalParser IO Journal
-> Journal -> ParsecT CustomErr Text IO Journal
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT JournalParser IO Journal
parser Journal
initJournal) StorageFormat
f Text
txt
  -- see notes above
  case Either (ParseErrorBundle Text CustomErr) Journal
ep of
    Left ParseErrorBundle Text CustomErr
e   -> StorageFormat -> ExceptT StorageFormat IO Journal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (StorageFormat -> ExceptT StorageFormat IO Journal)
-> StorageFormat -> ExceptT StorageFormat IO Journal
forall a b. (a -> b) -> a -> b
$ ParseErrorBundle Text CustomErr -> StorageFormat
customErrorBundlePretty ParseErrorBundle Text CustomErr
e
    Right Journal
pj -> 
      -- apply any command line account aliases. Can fail with a bad replacement pattern.
      case [AccountAlias] -> Journal -> Either StorageFormat Journal
journalApplyAliases (InputOpts -> [AccountAlias]
aliasesFromOpts InputOpts
iopts) Journal
pj of
        Left StorageFormat
e    -> StorageFormat -> ExceptT StorageFormat IO Journal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError StorageFormat
e
        Right Journal
pj' -> InputOpts
-> StorageFormat
-> Text
-> Journal
-> ExceptT StorageFormat IO Journal
journalFinalise InputOpts
iopts StorageFormat
f Text
txt Journal
pj'

-- | Post-process a Journal that has just been parsed or generated, in this order:
--
-- - apply canonical amount styles,
--
-- - save misc info and reverse transactions into their original parse order,
--
-- - evaluate balance assignments and balance each transaction,
--
-- - apply transaction modifiers (auto postings) if enabled,
--
-- - check balance assertions if enabled.
--
-- - infer transaction-implied market prices from transaction prices
--
journalFinalise :: InputOpts -> FilePath -> Text -> ParsedJournal -> ExceptT String IO Journal
journalFinalise :: InputOpts
-> StorageFormat
-> Text
-> Journal
-> ExceptT StorageFormat IO Journal
journalFinalise InputOpts{Bool
auto_ :: Bool
auto_ :: InputOpts -> Bool
auto_,Bool
ignore_assertions_ :: Bool
ignore_assertions_ :: InputOpts -> Bool
ignore_assertions_,Maybe (Map Text AmountStyle)
commoditystyles_ :: Maybe (Map Text AmountStyle)
commoditystyles_ :: InputOpts -> Maybe (Map Text AmountStyle)
commoditystyles_,Bool
strict_ :: Bool
strict_ :: InputOpts -> Bool
strict_} StorageFormat
f Text
txt Journal
pj = do
  ClockTime
t <- IO ClockTime -> ExceptT StorageFormat IO ClockTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ClockTime
getClockTime
  Day
d <- IO Day -> ExceptT StorageFormat IO Day
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Day
getCurrentDay
  let pj' :: Journal
pj' =
        Journal
pj{jglobalcommoditystyles :: Map Text AmountStyle
jglobalcommoditystyles=Map Text AmountStyle
-> Maybe (Map Text AmountStyle) -> Map Text AmountStyle
forall a. a -> Maybe a -> a
fromMaybe Map Text AmountStyle
forall k a. Map k a
M.empty Maybe (Map Text AmountStyle)
commoditystyles_}  -- save any global commodity styles
        Journal -> (Journal -> Journal) -> Journal
forall a b. a -> (a -> b) -> b
& (StorageFormat, Text) -> Journal -> Journal
journalAddFile (StorageFormat
f, Text
txt)  -- save the main file's info
        Journal -> (Journal -> Journal) -> Journal
forall a b. a -> (a -> b) -> b
& ClockTime -> Journal -> Journal
journalSetLastReadTime ClockTime
t -- save the last read time
        Journal -> (Journal -> Journal) -> Journal
forall a b. a -> (a -> b) -> b
& Journal -> Journal
journalReverse -- convert all lists to the order they were parsed

  -- If in strict mode, check all postings are to declared accounts
  case if Bool
strict_ then Journal -> Either StorageFormat ()
journalCheckAccountsDeclared Journal
pj' else () -> Either StorageFormat ()
forall a b. b -> Either a b
Right () of
    Left StorageFormat
e   -> StorageFormat -> ExceptT StorageFormat IO Journal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError StorageFormat
e
    Right () ->

      -- and using declared commodities
      case if Bool
strict_ then Journal -> Either StorageFormat ()
journalCheckCommoditiesDeclared Journal
pj' else () -> Either StorageFormat ()
forall a b. b -> Either a b
Right () of
        Left StorageFormat
e   -> StorageFormat -> ExceptT StorageFormat IO Journal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError StorageFormat
e
        Right () ->

          -- Infer and apply canonical styles for each commodity (or throw an error).
          -- This affects transaction balancing/assertions/assignments, so needs to be done early.
          case Journal -> Either StorageFormat Journal
journalApplyCommodityStyles Journal
pj' of
            Left StorageFormat
e     -> StorageFormat -> ExceptT StorageFormat IO Journal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError StorageFormat
e
            Right Journal
pj'' -> (StorageFormat -> ExceptT StorageFormat IO Journal)
-> (Journal -> ExceptT StorageFormat IO Journal)
-> Either StorageFormat Journal
-> ExceptT StorageFormat IO Journal
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either StorageFormat -> ExceptT StorageFormat IO Journal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError Journal -> ExceptT StorageFormat IO Journal
forall (m :: * -> *) a. Monad m => a -> m a
return (Either StorageFormat Journal -> ExceptT StorageFormat IO Journal)
-> Either StorageFormat Journal -> ExceptT StorageFormat IO Journal
forall a b. (a -> b) -> a -> b
$
              Journal
pj''
              Journal
-> (Journal -> Either StorageFormat Journal)
-> Either StorageFormat Journal
forall a b. a -> (a -> b) -> b
& (if Bool -> Bool
not Bool
auto_ Bool -> Bool -> Bool
|| [TransactionModifier] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (Journal -> [TransactionModifier]
jtxnmodifiers Journal
pj'')
                then
                  -- Auto postings are not active.
                  -- Balance all transactions and maybe check balance assertions.
                  Bool -> Journal -> Either StorageFormat Journal
journalBalanceTransactions (Bool -> Bool
not Bool
ignore_assertions_)
                else \Journal
j -> do  -- Either monad
                  -- Auto postings are active.
                  -- Balance all transactions without checking balance assertions,
                  Journal
j' <- Bool -> Journal -> Either StorageFormat Journal
journalBalanceTransactions Bool
False Journal
j
                  -- then add the auto postings
                  -- (Note adding auto postings after balancing means #893b fails;
                  -- adding them before balancing probably means #893a, #928, #938 fail.)
                  case Day -> Journal -> Either StorageFormat Journal
journalModifyTransactions Day
d Journal
j' of
                    Left StorageFormat
e -> StorageFormat -> Either StorageFormat Journal
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError StorageFormat
e
                    Right Journal
j'' -> do
                      -- then apply commodity styles once more, to style the auto posting amounts. (XXX inefficient ?)
                      Journal
j''' <- Journal -> Either StorageFormat Journal
journalApplyCommodityStyles Journal
j''
                      -- then check balance assertions.
                      Bool -> Journal -> Either StorageFormat Journal
journalBalanceTransactions (Bool -> Bool
not Bool
ignore_assertions_) Journal
j'''
                )
            ExceptT StorageFormat IO Journal
-> (ExceptT StorageFormat IO Journal
    -> ExceptT StorageFormat IO Journal)
-> ExceptT StorageFormat IO Journal
forall a b. a -> (a -> b) -> b
& (Journal -> Journal)
-> ExceptT StorageFormat IO Journal
-> ExceptT StorageFormat IO Journal
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Journal -> Journal
journalInferMarketPricesFromTransactions  -- infer market prices from commodity-exchanging transactions

-- | Check that all the journal's transactions have payees declared with
-- payee directives, returning an error message otherwise.
journalCheckPayeesDeclared :: Journal -> Either String ()
journalCheckPayeesDeclared :: Journal -> Either StorageFormat ()
journalCheckPayeesDeclared Journal
j = [Either StorageFormat ()] -> Either StorageFormat ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ ([Either StorageFormat ()] -> Either StorageFormat ())
-> [Either StorageFormat ()] -> Either StorageFormat ()
forall a b. (a -> b) -> a -> b
$ (Transaction -> Either StorageFormat ())
-> [Transaction] -> [Either StorageFormat ()]
forall a b. (a -> b) -> [a] -> [b]
map Transaction -> Either StorageFormat ()
checkpayee ([Transaction] -> [Either StorageFormat ()])
-> [Transaction] -> [Either StorageFormat ()]
forall a b. (a -> b) -> a -> b
$ Journal -> [Transaction]
jtxns Journal
j
  where
    checkpayee :: Transaction -> Either StorageFormat ()
checkpayee Transaction
t
      | Text
p Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
ps = () -> Either StorageFormat ()
forall a b. b -> Either a b
Right ()
      | Bool
otherwise = StorageFormat -> Either StorageFormat ()
forall a b. a -> Either a b
Left (StorageFormat -> Either StorageFormat ())
-> StorageFormat -> Either StorageFormat ()
forall a b. (a -> b) -> a -> b
$
          StorageFormat
-> StorageFormat -> StorageFormat -> Text -> StorageFormat
forall r. PrintfType r => StorageFormat -> r
printf StorageFormat
"undeclared payee \"%s\"\nat: %s\n\n%s"
            (Text -> StorageFormat
T.unpack Text
p)
            (GenericSourcePos -> StorageFormat
showGenericSourcePos (GenericSourcePos -> StorageFormat)
-> GenericSourcePos -> StorageFormat
forall a b. (a -> b) -> a -> b
$ Transaction -> GenericSourcePos
tsourcepos Transaction
t)
            (Text -> Text -> Text -> Text
linesPrepend2 Text
"> " Text
"  " (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>Text
"\n") (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
textChomp (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Transaction -> Text
showTransaction Transaction
t)
      where
        p :: Text
p  = Transaction -> Text
transactionPayee Transaction
t
        ps :: [Text]
ps = Journal -> [Text]
journalPayeesDeclared Journal
j

-- | Check that all the journal's postings are to accounts declared with
-- account directives, returning an error message otherwise.
journalCheckAccountsDeclared :: Journal -> Either String ()
journalCheckAccountsDeclared :: Journal -> Either StorageFormat ()
journalCheckAccountsDeclared Journal
j = [Either StorageFormat ()] -> Either StorageFormat ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ ([Either StorageFormat ()] -> Either StorageFormat ())
-> [Either StorageFormat ()] -> Either StorageFormat ()
forall a b. (a -> b) -> a -> b
$ (Posting -> Either StorageFormat ())
-> [Posting] -> [Either StorageFormat ()]
forall a b. (a -> b) -> [a] -> [b]
map Posting -> Either StorageFormat ()
checkacct ([Posting] -> [Either StorageFormat ()])
-> [Posting] -> [Either StorageFormat ()]
forall a b. (a -> b) -> a -> b
$ Journal -> [Posting]
journalPostings Journal
j
  where
    checkacct :: Posting -> Either StorageFormat ()
checkacct Posting{Text
paccount :: Posting -> Text
paccount :: Text
paccount,Maybe Transaction
ptransaction :: Posting -> Maybe Transaction
ptransaction :: Maybe Transaction
ptransaction}
      | Text
paccount Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
as = () -> Either StorageFormat ()
forall a b. b -> Either a b
Right ()
      | Bool
otherwise = StorageFormat -> Either StorageFormat ()
forall a b. a -> Either a b
Left (StorageFormat -> Either StorageFormat ())
-> StorageFormat -> Either StorageFormat ()
forall a b. (a -> b) -> a -> b
$
          (StorageFormat -> ShowS
forall r. PrintfType r => StorageFormat -> r
printf StorageFormat
"undeclared account \"%s\"\n" (Text -> StorageFormat
T.unpack Text
paccount))
          StorageFormat -> ShowS
forall a. [a] -> [a] -> [a]
++ case Maybe Transaction
ptransaction of
              Maybe Transaction
Nothing -> StorageFormat
""
              Just Transaction
t  -> StorageFormat -> StorageFormat -> Text -> StorageFormat
forall r. PrintfType r => StorageFormat -> r
printf StorageFormat
"in transaction at: %s\n\n%s"
                          (GenericSourcePos -> StorageFormat
showGenericSourcePos (GenericSourcePos -> StorageFormat)
-> GenericSourcePos -> StorageFormat
forall a b. (a -> b) -> a -> b
$ Transaction -> GenericSourcePos
tsourcepos Transaction
t)
                          (Text -> Text -> Text
linesPrepend Text
"  " (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>Text
"\n") (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
textChomp (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Transaction -> Text
showTransaction Transaction
t)
      where
        as :: [Text]
as = Journal -> [Text]
journalAccountNamesDeclared Journal
j

-- | Check that all the commodities used in this journal's postings have been declared
-- by commodity directives, returning an error message otherwise.
journalCheckCommoditiesDeclared :: Journal -> Either String ()
journalCheckCommoditiesDeclared :: Journal -> Either StorageFormat ()
journalCheckCommoditiesDeclared Journal
j = 
  [Either StorageFormat ()] -> Either StorageFormat ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ ([Either StorageFormat ()] -> Either StorageFormat ())
-> [Either StorageFormat ()] -> Either StorageFormat ()
forall a b. (a -> b) -> a -> b
$ (Posting -> Either StorageFormat ())
-> [Posting] -> [Either StorageFormat ()]
forall a b. (a -> b) -> [a] -> [b]
map Posting -> Either StorageFormat ()
checkcommodities ([Posting] -> [Either StorageFormat ()])
-> [Posting] -> [Either StorageFormat ()]
forall a b. (a -> b) -> a -> b
$ Journal -> [Posting]
journalPostings Journal
j
  where
    checkcommodities :: Posting -> Either StorageFormat ()
checkcommodities Posting{[Tag]
Maybe Day
Maybe Transaction
Maybe Posting
Maybe BalanceAssertion
Text
Status
PostingType
MixedAmount
poriginal :: Posting -> Maybe Posting
pbalanceassertion :: Posting -> Maybe BalanceAssertion
ptags :: Posting -> [Tag]
ptype :: Posting -> PostingType
pcomment :: Posting -> Text
pamount :: Posting -> MixedAmount
pstatus :: Posting -> Status
pdate2 :: Posting -> Maybe Day
pdate :: Posting -> Maybe Day
poriginal :: Maybe Posting
ptransaction :: Maybe Transaction
pbalanceassertion :: Maybe BalanceAssertion
ptags :: [Tag]
ptype :: PostingType
pcomment :: Text
pamount :: MixedAmount
paccount :: Text
pstatus :: Status
pdate2 :: Maybe Day
pdate :: Maybe Day
ptransaction :: Posting -> Maybe Transaction
paccount :: Posting -> Text
..} =
      case Maybe Text
mfirstundeclaredcomm of
        Maybe Text
Nothing -> () -> Either StorageFormat ()
forall a b. b -> Either a b
Right ()
        Just Text
c  -> StorageFormat -> Either StorageFormat ()
forall a b. a -> Either a b
Left (StorageFormat -> Either StorageFormat ())
-> StorageFormat -> Either StorageFormat ()
forall a b. (a -> b) -> a -> b
$
          (StorageFormat -> ShowS
forall r. PrintfType r => StorageFormat -> r
printf StorageFormat
"undeclared commodity \"%s\"\n" (Text -> StorageFormat
T.unpack Text
c))
          StorageFormat -> ShowS
forall a. [a] -> [a] -> [a]
++ case Maybe Transaction
ptransaction of
              Maybe Transaction
Nothing -> StorageFormat
""
              Just Transaction
t  -> StorageFormat -> StorageFormat -> Text -> StorageFormat
forall r. PrintfType r => StorageFormat -> r
printf StorageFormat
"in transaction at: %s\n\n%s"
                          (GenericSourcePos -> StorageFormat
showGenericSourcePos (GenericSourcePos -> StorageFormat)
-> GenericSourcePos -> StorageFormat
forall a b. (a -> b) -> a -> b
$ Transaction -> GenericSourcePos
tsourcepos Transaction
t)
                          (Text -> Text -> Text
linesPrepend Text
"  " (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>Text
"\n") (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
textChomp (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Transaction -> Text
showTransaction Transaction
t)
      where
        mfirstundeclaredcomm :: Maybe Text
mfirstundeclaredcomm =
          [Text] -> Maybe Text
forall a. [a] -> Maybe a
headMay ([Text] -> Maybe Text) -> [Text] -> Maybe Text
forall a b. (a -> b) -> a -> b
$ (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Text -> Bool) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
cs)) ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ [Maybe Text] -> [Text]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe Text] -> [Text]) -> [Maybe Text] -> [Text]
forall a b. (a -> b) -> a -> b
$
          (Amount -> Text
acommodity (Amount -> Text)
-> (BalanceAssertion -> Amount) -> BalanceAssertion -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BalanceAssertion -> Amount
baamount (BalanceAssertion -> Text) -> Maybe BalanceAssertion -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe BalanceAssertion
pbalanceassertion) Maybe Text -> [Maybe Text] -> [Maybe Text]
forall a. a -> [a] -> [a]
:
          ((Amount -> Maybe Text) -> [Amount] -> [Maybe Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> (Amount -> Text) -> Amount -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Amount -> Text
acommodity) ([Amount] -> [Maybe Text])
-> ([Amount] -> [Amount]) -> [Amount] -> [Maybe Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Amount -> Bool) -> [Amount] -> [Amount]
forall a. (a -> Bool) -> [a] -> [a]
filter (Amount -> Amount -> Bool
forall a. Eq a => a -> a -> Bool
/= Amount
missingamt) ([Amount] -> [Maybe Text]) -> [Amount] -> [Maybe Text]
forall a b. (a -> b) -> a -> b
$ MixedAmount -> [Amount]
amounts MixedAmount
pamount)
        cs :: [Text]
cs = Journal -> [Text]
journalCommoditiesDeclared Journal
j


setYear :: Year -> JournalParser m ()
setYear :: Integer -> JournalParser m ()
setYear Integer
y = (Journal -> Journal) -> JournalParser m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (\Journal
j -> Journal
j{jparsedefaultyear :: Maybe Integer
jparsedefaultyear=Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
y})

getYear :: JournalParser m (Maybe Year)
getYear :: JournalParser m (Maybe Integer)
getYear = (Journal -> Maybe Integer)
-> StateT Journal (ParsecT CustomErr Text m) Journal
-> JournalParser m (Maybe Integer)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Journal -> Maybe Integer
jparsedefaultyear StateT Journal (ParsecT CustomErr Text m) Journal
forall s (m :: * -> *). MonadState s m => m s
get

-- | Get the decimal mark that has been specified for parsing, if any
-- (eg by the CSV decimal-mark rule, or possibly a future journal directive).
-- Return it as an AmountStyle that amount parsers can use.
getDecimalMarkStyle :: JournalParser m (Maybe AmountStyle)
getDecimalMarkStyle :: JournalParser m (Maybe AmountStyle)
getDecimalMarkStyle = do
  Journal{Maybe DecimalMark
jparsedecimalmark :: Journal -> Maybe DecimalMark
jparsedecimalmark :: Maybe DecimalMark
jparsedecimalmark} <- StateT Journal (ParsecT CustomErr Text m) Journal
forall s (m :: * -> *). MonadState s m => m s
get
  let mdecmarkStyle :: Maybe AmountStyle
mdecmarkStyle = Maybe AmountStyle
-> (DecimalMark -> Maybe AmountStyle)
-> Maybe DecimalMark
-> Maybe AmountStyle
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Maybe AmountStyle
forall a. Maybe a
Nothing (\DecimalMark
c -> AmountStyle -> Maybe AmountStyle
forall a. a -> Maybe a
Just (AmountStyle -> Maybe AmountStyle)
-> AmountStyle -> Maybe AmountStyle
forall a b. (a -> b) -> a -> b
$ AmountStyle
amountstyle{asdecimalpoint :: Maybe DecimalMark
asdecimalpoint=DecimalMark -> Maybe DecimalMark
forall a. a -> Maybe a
Just DecimalMark
c}) Maybe DecimalMark
jparsedecimalmark
  Maybe AmountStyle -> JournalParser m (Maybe AmountStyle)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe AmountStyle
mdecmarkStyle

setDefaultCommodityAndStyle :: (CommoditySymbol,AmountStyle) -> JournalParser m ()
setDefaultCommodityAndStyle :: (Text, AmountStyle) -> JournalParser m ()
setDefaultCommodityAndStyle (Text, AmountStyle)
cs = (Journal -> Journal) -> JournalParser m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (\Journal
j -> Journal
j{jparsedefaultcommodity :: Maybe (Text, AmountStyle)
jparsedefaultcommodity=(Text, AmountStyle) -> Maybe (Text, AmountStyle)
forall a. a -> Maybe a
Just (Text, AmountStyle)
cs})

getDefaultCommodityAndStyle :: JournalParser m (Maybe (CommoditySymbol,AmountStyle))
getDefaultCommodityAndStyle :: JournalParser m (Maybe (Text, AmountStyle))
getDefaultCommodityAndStyle = Journal -> Maybe (Text, AmountStyle)
jparsedefaultcommodity (Journal -> Maybe (Text, AmountStyle))
-> StateT Journal (ParsecT CustomErr Text m) Journal
-> JournalParser m (Maybe (Text, AmountStyle))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` StateT Journal (ParsecT CustomErr Text m) Journal
forall s (m :: * -> *). MonadState s m => m s
get

-- | Get amount style associated with default currency.
--
-- Returns 'AmountStyle' used to defined by a latest default commodity directive
-- prior to current position within this file or its parents.
getDefaultAmountStyle :: JournalParser m (Maybe AmountStyle)
getDefaultAmountStyle :: JournalParser m (Maybe AmountStyle)
getDefaultAmountStyle = ((Text, AmountStyle) -> AmountStyle)
-> Maybe (Text, AmountStyle) -> Maybe AmountStyle
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text, AmountStyle) -> AmountStyle
forall a b. (a, b) -> b
snd (Maybe (Text, AmountStyle) -> Maybe AmountStyle)
-> StateT
     Journal (ParsecT CustomErr Text m) (Maybe (Text, AmountStyle))
-> JournalParser m (Maybe AmountStyle)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT
  Journal (ParsecT CustomErr Text m) (Maybe (Text, AmountStyle))
forall (m :: * -> *). JournalParser m (Maybe (Text, AmountStyle))
getDefaultCommodityAndStyle

-- | Get the 'AmountStyle' declared by the most recently parsed (in the current or parent files,
-- prior to the current position) commodity directive for the given commodity, if any.
getAmountStyle :: CommoditySymbol -> JournalParser m (Maybe AmountStyle)
getAmountStyle :: Text -> JournalParser m (Maybe AmountStyle)
getAmountStyle Text
commodity = do
  Journal{Map Text Commodity
jcommodities :: Journal -> Map Text Commodity
jcommodities :: Map Text Commodity
jcommodities} <- StateT Journal (ParsecT CustomErr Text m) Journal
forall s (m :: * -> *). MonadState s m => m s
get
  let mspecificStyle :: Maybe AmountStyle
mspecificStyle = Text -> Map Text Commodity -> Maybe Commodity
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
commodity Map Text Commodity
jcommodities Maybe Commodity
-> (Commodity -> Maybe AmountStyle) -> Maybe AmountStyle
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Commodity -> Maybe AmountStyle
cformat
  Maybe AmountStyle
mdefaultStyle <- ((Text, AmountStyle) -> AmountStyle)
-> Maybe (Text, AmountStyle) -> Maybe AmountStyle
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text, AmountStyle) -> AmountStyle
forall a b. (a, b) -> b
snd (Maybe (Text, AmountStyle) -> Maybe AmountStyle)
-> StateT
     Journal (ParsecT CustomErr Text m) (Maybe (Text, AmountStyle))
-> JournalParser m (Maybe AmountStyle)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT
  Journal (ParsecT CustomErr Text m) (Maybe (Text, AmountStyle))
forall (m :: * -> *). JournalParser m (Maybe (Text, AmountStyle))
getDefaultCommodityAndStyle
  Maybe AmountStyle -> JournalParser m (Maybe AmountStyle)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe AmountStyle -> JournalParser m (Maybe AmountStyle))
-> Maybe AmountStyle -> JournalParser m (Maybe AmountStyle)
forall a b. (a -> b) -> a -> b
$ [AmountStyle] -> Maybe AmountStyle
forall a. [a] -> Maybe a
listToMaybe ([AmountStyle] -> Maybe AmountStyle)
-> [AmountStyle] -> Maybe AmountStyle
forall a b. (a -> b) -> a -> b
$ [Maybe AmountStyle] -> [AmountStyle]
forall a. [Maybe a] -> [a]
catMaybes [Maybe AmountStyle
mspecificStyle, Maybe AmountStyle
mdefaultStyle]

addDeclaredAccountType :: AccountName -> AccountType -> JournalParser m ()
addDeclaredAccountType :: Text -> AccountType -> JournalParser m ()
addDeclaredAccountType Text
acct AccountType
atype =
  (Journal -> Journal) -> JournalParser m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (\Journal
j -> Journal
j{jdeclaredaccounttypes :: Map AccountType [Text]
jdeclaredaccounttypes = ([Text] -> [Text] -> [Text])
-> AccountType
-> [Text]
-> Map AccountType [Text]
-> Map AccountType [Text]
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
(++) AccountType
atype [Text
acct] (Journal -> Map AccountType [Text]
jdeclaredaccounttypes Journal
j)})

pushParentAccount :: AccountName -> JournalParser m ()
pushParentAccount :: Text -> JournalParser m ()
pushParentAccount Text
acct = (Journal -> Journal) -> JournalParser m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (\Journal
j -> Journal
j{jparseparentaccounts :: [Text]
jparseparentaccounts = Text
acct Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: Journal -> [Text]
jparseparentaccounts Journal
j})

popParentAccount :: JournalParser m ()
popParentAccount :: JournalParser m ()
popParentAccount = do
  Journal
j <- StateT Journal (ParsecT CustomErr Text m) Journal
forall s (m :: * -> *). MonadState s m => m s
get
  case Journal -> [Text]
jparseparentaccounts Journal
j of
    []       -> ErrorItem (Token Text) -> JournalParser m ()
forall e s (m :: * -> *) a.
MonadParsec e s m =>
ErrorItem (Token s) -> m a
unexpected (NonEmpty DecimalMark -> ErrorItem DecimalMark
forall t. NonEmpty t -> ErrorItem t
Tokens (DecimalMark
'E' DecimalMark -> StorageFormat -> NonEmpty DecimalMark
forall a. a -> [a] -> NonEmpty a
:| StorageFormat
"nd of apply account block with no beginning"))
    (Text
_:[Text]
rest) -> Journal -> JournalParser m ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put Journal
j{jparseparentaccounts :: [Text]
jparseparentaccounts=[Text]
rest}

getParentAccount :: JournalParser m AccountName
getParentAccount :: JournalParser m Text
getParentAccount = (Journal -> Text)
-> StateT Journal (ParsecT CustomErr Text m) Journal
-> JournalParser m Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Text] -> Text
concatAccountNames ([Text] -> Text) -> (Journal -> [Text]) -> Journal -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> [Text]
forall a. [a] -> [a]
reverse ([Text] -> [Text]) -> (Journal -> [Text]) -> Journal -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Journal -> [Text]
jparseparentaccounts) StateT Journal (ParsecT CustomErr Text m) Journal
forall s (m :: * -> *). MonadState s m => m s
get

addAccountAlias :: MonadState Journal m => AccountAlias -> m ()
addAccountAlias :: AccountAlias -> m ()
addAccountAlias AccountAlias
a = (Journal -> Journal) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (\(j :: Journal
j@Journal{[StorageFormat]
[(StorageFormat, Text)]
[(Text, AccountDeclarationInfo)]
[(Text, PayeeDeclarationInfo)]
[Text]
[MarketPrice]
[PriceDirective]
[TimeclockEntry]
[PeriodicTransaction]
[TransactionModifier]
[Transaction]
[AccountAlias]
Maybe DecimalMark
Maybe Integer
Maybe (Text, AmountStyle)
Text
Map Text Commodity
Map Text AmountStyle
Map AccountType [Text]
ClockTime
jlastreadtime :: Journal -> ClockTime
jfiles :: Journal -> [(StorageFormat, Text)]
jfinalcommentlines :: Journal -> Text
jperiodictxns :: Journal -> [PeriodicTransaction]
jinferredmarketprices :: Journal -> [MarketPrice]
jpricedirectives :: Journal -> [PriceDirective]
jinferredcommodities :: Journal -> Map Text AmountStyle
jdeclaredaccounts :: Journal -> [(Text, AccountDeclarationInfo)]
jdeclaredpayees :: Journal -> [(Text, PayeeDeclarationInfo)]
jparsetimeclockentries :: Journal -> [TimeclockEntry]
jparsealiases :: Journal -> [AccountAlias]
jlastreadtime :: ClockTime
jfiles :: [(StorageFormat, Text)]
jfinalcommentlines :: Text
jtxns :: [Transaction]
jperiodictxns :: [PeriodicTransaction]
jtxnmodifiers :: [TransactionModifier]
jinferredmarketprices :: [MarketPrice]
jpricedirectives :: [PriceDirective]
jinferredcommodities :: Map Text AmountStyle
jcommodities :: Map Text Commodity
jglobalcommoditystyles :: Map Text AmountStyle
jdeclaredaccounttypes :: Map AccountType [Text]
jdeclaredaccounts :: [(Text, AccountDeclarationInfo)]
jdeclaredpayees :: [(Text, PayeeDeclarationInfo)]
jincludefilestack :: [StorageFormat]
jparsetimeclockentries :: [TimeclockEntry]
jparsealiases :: [AccountAlias]
jparseparentaccounts :: [Text]
jparsedecimalmark :: Maybe DecimalMark
jparsedefaultcommodity :: Maybe (Text, AmountStyle)
jparsedefaultyear :: Maybe Integer
jparseparentaccounts :: Journal -> [Text]
jdeclaredaccounttypes :: Journal -> Map AccountType [Text]
jcommodities :: Journal -> Map Text Commodity
jparsedefaultcommodity :: Journal -> Maybe (Text, AmountStyle)
jparsedecimalmark :: Journal -> Maybe DecimalMark
jtxns :: Journal -> [Transaction]
jtxnmodifiers :: Journal -> [TransactionModifier]
jglobalcommoditystyles :: Journal -> Map Text AmountStyle
jincludefilestack :: Journal -> [StorageFormat]
jparsedefaultyear :: Journal -> Maybe Integer
..}) -> Journal
j{jparsealiases :: [AccountAlias]
jparsealiases=AccountAlias
aAccountAlias -> [AccountAlias] -> [AccountAlias]
forall a. a -> [a] -> [a]
:[AccountAlias]
jparsealiases})

getAccountAliases :: MonadState Journal m => m [AccountAlias]
getAccountAliases :: m [AccountAlias]
getAccountAliases = (Journal -> [AccountAlias]) -> m Journal -> m [AccountAlias]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Journal -> [AccountAlias]
jparsealiases m Journal
forall s (m :: * -> *). MonadState s m => m s
get

clearAccountAliases :: MonadState Journal m => m ()
clearAccountAliases :: m ()
clearAccountAliases = (Journal -> Journal) -> m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (\Journal
j -> Journal
j{jparsealiases :: [AccountAlias]
jparsealiases=[]})

-- getTransactionCount :: MonadState Journal m =>  m Integer
-- getTransactionCount = fmap jparsetransactioncount get
--
-- setTransactionCount :: MonadState Journal m => Integer -> m ()
-- setTransactionCount i = modify' (\j -> j{jparsetransactioncount=i})
--
-- -- | Increment the transaction index by one and return the new value.
-- incrementTransactionCount :: MonadState Journal m => m Integer
-- incrementTransactionCount = do
--   modify' (\j -> j{jparsetransactioncount=jparsetransactioncount j + 1})
--   getTransactionCount

journalAddFile :: (FilePath,Text) -> Journal -> Journal
journalAddFile :: (StorageFormat, Text) -> Journal -> Journal
journalAddFile (StorageFormat, Text)
f j :: Journal
j@Journal{jfiles :: Journal -> [(StorageFormat, Text)]
jfiles=[(StorageFormat, Text)]
fs} = Journal
j{jfiles :: [(StorageFormat, Text)]
jfiles=[(StorageFormat, Text)]
fs[(StorageFormat, Text)]
-> [(StorageFormat, Text)] -> [(StorageFormat, Text)]
forall a. [a] -> [a] -> [a]
++[(StorageFormat, Text)
f]}
  -- append, unlike the other fields, even though we do a final reverse,
  -- to compensate for additional reversal due to including/monoid-concatting

-- A version of `match` that is strict in the returned text
match' :: TextParser m a -> TextParser m (Text, a)
match' :: TextParser m a -> TextParser m (Text, a)
match' TextParser m a
p = do
  (!Text
txt, a
p) <- TextParser m a -> ParsecT CustomErr Text m (Tokens Text, a)
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> m (Tokens s, a)
match TextParser m a
p
  (Text, a) -> TextParser m (Text, a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
txt, a
p)

--- ** parsers
--- *** transaction bits

statusp :: TextParser m Status
statusp :: TextParser m Status
statusp =
  [TextParser m Status] -> TextParser m Status
forall (m :: * -> *) a. [TextParser m a] -> TextParser m a
choice'
    [ ParsecT CustomErr Text m ()
forall s (m :: * -> *).
(Stream s, Token s ~ DecimalMark) =>
ParsecT CustomErr s m ()
skipNonNewlineSpaces ParsecT CustomErr Text m ()
-> ParsecT CustomErr Text m DecimalMark
-> ParsecT CustomErr Text m DecimalMark
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Token Text -> ParsecT CustomErr Text m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ DecimalMark) =>
Token s -> m (Token s)
char DecimalMark
Token Text
'*' ParsecT CustomErr Text m DecimalMark
-> TextParser m Status -> TextParser m Status
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Status -> TextParser m Status
forall (m :: * -> *) a. Monad m => a -> m a
return Status
Cleared
    , ParsecT CustomErr Text m ()
forall s (m :: * -> *).
(Stream s, Token s ~ DecimalMark) =>
ParsecT CustomErr s m ()
skipNonNewlineSpaces ParsecT CustomErr Text m ()
-> ParsecT CustomErr Text m DecimalMark
-> ParsecT CustomErr Text m DecimalMark
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Token Text -> ParsecT CustomErr Text m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ DecimalMark) =>
Token s -> m (Token s)
char DecimalMark
Token Text
'!' ParsecT CustomErr Text m DecimalMark
-> TextParser m Status -> TextParser m Status
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Status -> TextParser m Status
forall (m :: * -> *) a. Monad m => a -> m a
return Status
Pending
    , Status -> TextParser m Status
forall (m :: * -> *) a. Monad m => a -> m a
return Status
Unmarked
    ]

codep :: TextParser m Text
codep :: TextParser m Text
codep = Text -> TextParser m Text -> TextParser m Text
forall (m :: * -> *) a. Alternative m => a -> m a -> m a
option Text
"" (TextParser m Text -> TextParser m Text)
-> TextParser m Text -> TextParser m Text
forall a b. (a -> b) -> a -> b
$ do
  ParsecT CustomErr Text m DecimalMark
-> ParsecT CustomErr Text m DecimalMark
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (ParsecT CustomErr Text m DecimalMark
 -> ParsecT CustomErr Text m DecimalMark)
-> ParsecT CustomErr Text m DecimalMark
-> ParsecT CustomErr Text m DecimalMark
forall a b. (a -> b) -> a -> b
$ do
    ParsecT CustomErr Text m ()
forall s (m :: * -> *).
(Stream s, Token s ~ DecimalMark) =>
ParsecT CustomErr s m ()
skipNonNewlineSpaces1
    Token Text -> ParsecT CustomErr Text m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ DecimalMark) =>
Token s -> m (Token s)
char DecimalMark
Token Text
'('
  Text
code <- Maybe StorageFormat
-> (Token Text -> Bool) -> ParsecT CustomErr Text m (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe StorageFormat -> (Token s -> Bool) -> m (Tokens s)
takeWhileP Maybe StorageFormat
forall a. Maybe a
Nothing ((Token Text -> Bool) -> ParsecT CustomErr Text m (Tokens Text))
-> (Token Text -> Bool) -> ParsecT CustomErr Text m (Tokens Text)
forall a b. (a -> b) -> a -> b
$ \Token Text
c -> DecimalMark
Token Text
c DecimalMark -> DecimalMark -> Bool
forall a. Eq a => a -> a -> Bool
/= DecimalMark
')' Bool -> Bool -> Bool
&& DecimalMark
Token Text
c DecimalMark -> DecimalMark -> Bool
forall a. Eq a => a -> a -> Bool
/= DecimalMark
'\n'
  Token Text -> ParsecT CustomErr Text m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ DecimalMark) =>
Token s -> m (Token s)
char DecimalMark
Token Text
')' ParsecT CustomErr Text m DecimalMark
-> StorageFormat -> ParsecT CustomErr Text m DecimalMark
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> StorageFormat -> m a
<?> StorageFormat
"closing bracket ')' for transaction code"
  Text -> TextParser m Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
code

descriptionp :: TextParser m Text
descriptionp :: TextParser m Text
descriptionp = Maybe StorageFormat
-> (Token Text -> Bool) -> ParsecT CustomErr Text m (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe StorageFormat -> (Token s -> Bool) -> m (Tokens s)
takeWhileP Maybe StorageFormat
forall a. Maybe a
Nothing (Bool -> Bool
not (Bool -> Bool) -> (DecimalMark -> Bool) -> DecimalMark -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DecimalMark -> Bool
semicolonOrNewline)
  where semicolonOrNewline :: DecimalMark -> Bool
semicolonOrNewline DecimalMark
c = DecimalMark
c DecimalMark -> DecimalMark -> Bool
forall a. Eq a => a -> a -> Bool
== DecimalMark
';' Bool -> Bool -> Bool
|| DecimalMark
c DecimalMark -> DecimalMark -> Bool
forall a. Eq a => a -> a -> Bool
== DecimalMark
'\n'

--- *** dates

-- | Parse a date in YYYY-MM-DD format.
-- Slash (/) and period (.) are also allowed as separators.
-- The year may be omitted if a default year has been set.
-- Leading zeroes may be omitted.
datep :: JournalParser m Day
datep :: JournalParser m Day
datep = do
  Maybe Integer
mYear <- JournalParser m (Maybe Integer)
forall (m :: * -> *). JournalParser m (Maybe Integer)
getYear
  ParsecT CustomErr Text m Day -> JournalParser m Day
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ParsecT CustomErr Text m Day -> JournalParser m Day)
-> ParsecT CustomErr Text m Day -> JournalParser m Day
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> ParsecT CustomErr Text m Day
forall (m :: * -> *). Maybe Integer -> TextParser m Day
datep' Maybe Integer
mYear

datep' :: Maybe Year -> TextParser m Day
datep' :: Maybe Integer -> TextParser m Day
datep' Maybe Integer
mYear = do
    Int
startOffset <- ParsecT CustomErr Text m Int
forall e s (m :: * -> *). MonadParsec e s m => m Int
getOffset
    Either Integer Int
d1 <- TextParser m (Either Integer Int)
forall (m :: * -> *). TextParser m (Either Integer Int)
yearorintp TextParser m (Either Integer Int)
-> StorageFormat -> TextParser m (Either Integer Int)
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> StorageFormat -> m a
<?> StorageFormat
"year or month"
    DecimalMark
sep <- TextParser m DecimalMark
forall (m :: * -> *). TextParser m DecimalMark
datesepchar TextParser m DecimalMark
-> StorageFormat -> TextParser m DecimalMark
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> StorageFormat -> m a
<?> StorageFormat
"date separator"
    Int
d2 <- ParsecT CustomErr Text m Int
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ DecimalMark, Num a) =>
m a
decimal ParsecT CustomErr Text m Int
-> StorageFormat -> ParsecT CustomErr Text m Int
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> StorageFormat -> m a
<?> StorageFormat
"month or day"
    case Either Integer Int
d1 of
         Left Integer
y  -> Int -> Integer -> DecimalMark -> Int -> TextParser m Day
forall (m :: * -> *).
Int -> Integer -> DecimalMark -> Int -> TextParser m Day
fullDate Int
startOffset Integer
y DecimalMark
sep Int
d2
         Right Int
m -> Int
-> Maybe Integer -> Int -> DecimalMark -> Int -> TextParser m Day
forall (m :: * -> *).
Int
-> Maybe Integer -> Int -> DecimalMark -> Int -> TextParser m Day
partialDate Int
startOffset Maybe Integer
mYear Int
m DecimalMark
sep Int
d2
    TextParser m Day -> StorageFormat -> TextParser m Day
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> StorageFormat -> m a
<?> StorageFormat
"full or partial date"
  where
    fullDate :: Int -> Year -> Char -> Month -> TextParser m Day
    fullDate :: Int -> Integer -> DecimalMark -> Int -> TextParser m Day
fullDate Int
startOffset Integer
year DecimalMark
sep1 Int
month = do
      DecimalMark
sep2 <- (Token Text -> Bool) -> ParsecT CustomErr Text m (Token Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy DecimalMark -> Bool
Token Text -> Bool
isDateSepChar ParsecT CustomErr Text m DecimalMark
-> StorageFormat -> ParsecT CustomErr Text m DecimalMark
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> StorageFormat -> m a
<?> StorageFormat
"date separator"
      Int
day <- ParsecT CustomErr Text m Int
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ DecimalMark, Num a) =>
m a
decimal ParsecT CustomErr Text m Int
-> StorageFormat -> ParsecT CustomErr Text m Int
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> StorageFormat -> m a
<?> StorageFormat
"day"
      Int
endOffset <- ParsecT CustomErr Text m Int
forall e s (m :: * -> *). MonadParsec e s m => m Int
getOffset
      let dateStr :: StorageFormat
dateStr = Integer -> StorageFormat
forall a. Show a => a -> StorageFormat
show Integer
year StorageFormat -> ShowS
forall a. [a] -> [a] -> [a]
++ [DecimalMark
sep1] StorageFormat -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> StorageFormat
forall a. Show a => a -> StorageFormat
show Int
month StorageFormat -> ShowS
forall a. [a] -> [a] -> [a]
++ [DecimalMark
sep2] StorageFormat -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> StorageFormat
forall a. Show a => a -> StorageFormat
show Int
day

      Bool -> ParsecT CustomErr Text m () -> ParsecT CustomErr Text m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DecimalMark
sep1 DecimalMark -> DecimalMark -> Bool
forall a. Eq a => a -> a -> Bool
/= DecimalMark
sep2) (ParsecT CustomErr Text m () -> ParsecT CustomErr Text m ())
-> ParsecT CustomErr Text m () -> ParsecT CustomErr Text m ()
forall a b. (a -> b) -> a -> b
$ CustomErr -> ParsecT CustomErr Text m ()
forall e s (m :: * -> *) a. MonadParsec e s m => e -> m a
customFailure (CustomErr -> ParsecT CustomErr Text m ())
-> CustomErr -> ParsecT CustomErr Text m ()
forall a b. (a -> b) -> a -> b
$ Int -> Int -> StorageFormat -> CustomErr
parseErrorAtRegion Int
startOffset Int
endOffset (StorageFormat -> CustomErr) -> StorageFormat -> CustomErr
forall a b. (a -> b) -> a -> b
$
        StorageFormat
"invalid date: separators are different, should be the same"

      case Integer -> Int -> Int -> Maybe Day
fromGregorianValid Integer
year Int
month Int
day of
        Maybe Day
Nothing -> CustomErr -> TextParser m Day
forall e s (m :: * -> *) a. MonadParsec e s m => e -> m a
customFailure (CustomErr -> TextParser m Day) -> CustomErr -> TextParser m Day
forall a b. (a -> b) -> a -> b
$ Int -> Int -> StorageFormat -> CustomErr
parseErrorAtRegion Int
startOffset Int
endOffset (StorageFormat -> CustomErr) -> StorageFormat -> CustomErr
forall a b. (a -> b) -> a -> b
$
                     StorageFormat
"well-formed but invalid date: " StorageFormat -> ShowS
forall a. [a] -> [a] -> [a]
++ StorageFormat
dateStr
        Just Day
date -> Day -> TextParser m Day
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Day -> TextParser m Day) -> Day -> TextParser m Day
forall a b. (a -> b) -> a -> b
$! Day
date

    partialDate :: Int -> Maybe Year -> Month -> Char -> MonthDay -> TextParser m Day
    partialDate :: Int
-> Maybe Integer -> Int -> DecimalMark -> Int -> TextParser m Day
partialDate Int
startOffset Maybe Integer
mYear Int
month DecimalMark
sep Int
day = do
      Int
endOffset <- ParsecT CustomErr Text m Int
forall e s (m :: * -> *). MonadParsec e s m => m Int
getOffset
      case Maybe Integer
mYear of
        Just Integer
year ->
          case Integer -> Int -> Int -> Maybe Day
fromGregorianValid Integer
year Int
month Int
day of
            Maybe Day
Nothing -> CustomErr -> TextParser m Day
forall e s (m :: * -> *) a. MonadParsec e s m => e -> m a
customFailure (CustomErr -> TextParser m Day) -> CustomErr -> TextParser m Day
forall a b. (a -> b) -> a -> b
$ Int -> Int -> StorageFormat -> CustomErr
parseErrorAtRegion Int
startOffset Int
endOffset (StorageFormat -> CustomErr) -> StorageFormat -> CustomErr
forall a b. (a -> b) -> a -> b
$
                        StorageFormat
"well-formed but invalid date: " StorageFormat -> ShowS
forall a. [a] -> [a] -> [a]
++ StorageFormat
dateStr
            Just Day
date -> Day -> TextParser m Day
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Day -> TextParser m Day) -> Day -> TextParser m Day
forall a b. (a -> b) -> a -> b
$! Day
date
          where dateStr :: StorageFormat
dateStr = Integer -> StorageFormat
forall a. Show a => a -> StorageFormat
show Integer
year StorageFormat -> ShowS
forall a. [a] -> [a] -> [a]
++ [DecimalMark
sep] StorageFormat -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> StorageFormat
forall a. Show a => a -> StorageFormat
show Int
month StorageFormat -> ShowS
forall a. [a] -> [a] -> [a]
++ [DecimalMark
sep] StorageFormat -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> StorageFormat
forall a. Show a => a -> StorageFormat
show Int
day

        Maybe Integer
Nothing -> CustomErr -> TextParser m Day
forall e s (m :: * -> *) a. MonadParsec e s m => e -> m a
customFailure (CustomErr -> TextParser m Day) -> CustomErr -> TextParser m Day
forall a b. (a -> b) -> a -> b
$ Int -> Int -> StorageFormat -> CustomErr
parseErrorAtRegion Int
startOffset Int
endOffset (StorageFormat -> CustomErr) -> StorageFormat -> CustomErr
forall a b. (a -> b) -> a -> b
$
          StorageFormat
"partial date "StorageFormat -> ShowS
forall a. [a] -> [a] -> [a]
++StorageFormat
dateStrStorageFormat -> ShowS
forall a. [a] -> [a] -> [a]
++StorageFormat
" found, but the current year is unknown"
          where dateStr :: StorageFormat
dateStr = Int -> StorageFormat
forall a. Show a => a -> StorageFormat
show Int
month StorageFormat -> ShowS
forall a. [a] -> [a] -> [a]
++ [DecimalMark
sep] StorageFormat -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> StorageFormat
forall a. Show a => a -> StorageFormat
show Int
day

{-# INLINABLE datep' #-}

-- | Parse a date and time in YYYY-MM-DD HH:MM[:SS][+-ZZZZ] format.
-- Slash (/) and period (.) are also allowed as date separators.
-- The year may be omitted if a default year has been set.
-- Seconds are optional.
-- The timezone is optional and ignored (the time is always interpreted as a local time).
-- Leading zeroes may be omitted (except in a timezone).
datetimep :: JournalParser m LocalTime
datetimep :: JournalParser m LocalTime
datetimep = do
  Maybe Integer
mYear <- JournalParser m (Maybe Integer)
forall (m :: * -> *). JournalParser m (Maybe Integer)
getYear
  ParsecT CustomErr Text m LocalTime -> JournalParser m LocalTime
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ParsecT CustomErr Text m LocalTime -> JournalParser m LocalTime)
-> ParsecT CustomErr Text m LocalTime -> JournalParser m LocalTime
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> ParsecT CustomErr Text m LocalTime
forall (m :: * -> *). Maybe Integer -> TextParser m LocalTime
datetimep' Maybe Integer
mYear

datetimep' :: Maybe Year -> TextParser m LocalTime
datetimep' :: Maybe Integer -> TextParser m LocalTime
datetimep' Maybe Integer
mYear = do
  Day
day <- Maybe Integer -> TextParser m Day
forall (m :: * -> *). Maybe Integer -> TextParser m Day
datep' Maybe Integer
mYear
  ParsecT CustomErr Text m ()
forall s (m :: * -> *).
(Stream s, Token s ~ DecimalMark) =>
ParsecT CustomErr s m ()
skipNonNewlineSpaces1
  TimeOfDay
time <- TextParser m TimeOfDay
forall (m :: * -> *). TextParser m TimeOfDay
timeOfDay
  ParsecT CustomErr Text m StorageFormat
-> ParsecT CustomErr Text m (Maybe StorageFormat)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional ParsecT CustomErr Text m StorageFormat
forall (m :: * -> *). TextParser m StorageFormat
timeZone -- ignoring time zones
  LocalTime -> TextParser m LocalTime
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LocalTime -> TextParser m LocalTime)
-> LocalTime -> TextParser m LocalTime
forall a b. (a -> b) -> a -> b
$ Day -> TimeOfDay -> LocalTime
LocalTime Day
day TimeOfDay
time

  where
    timeOfDay :: TextParser m TimeOfDay
    timeOfDay :: TextParser m TimeOfDay
timeOfDay = do
      Int
off1 <- ParsecT CustomErr Text m Int
forall e s (m :: * -> *). MonadParsec e s m => m Int
getOffset
      Int
h' <- ParsecT CustomErr Text m Int
forall (m :: * -> *). TextParser m Int
twoDigitDecimal ParsecT CustomErr Text m Int
-> StorageFormat -> ParsecT CustomErr Text m Int
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> StorageFormat -> m a
<?> StorageFormat
"hour"
      Int
off2 <- ParsecT CustomErr Text m Int
forall e s (m :: * -> *). MonadParsec e s m => m Int
getOffset
      Bool -> ParsecT CustomErr Text m () -> ParsecT CustomErr Text m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
h' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0 Bool -> Bool -> Bool
&& Int
h' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
23) (ParsecT CustomErr Text m () -> ParsecT CustomErr Text m ())
-> ParsecT CustomErr Text m () -> ParsecT CustomErr Text m ()
forall a b. (a -> b) -> a -> b
$ CustomErr -> ParsecT CustomErr Text m ()
forall e s (m :: * -> *) a. MonadParsec e s m => e -> m a
customFailure (CustomErr -> ParsecT CustomErr Text m ())
-> CustomErr -> ParsecT CustomErr Text m ()
forall a b. (a -> b) -> a -> b
$
        Int -> Int -> StorageFormat -> CustomErr
parseErrorAtRegion Int
off1 Int
off2 StorageFormat
"invalid time (bad hour)"

      Token Text -> ParsecT CustomErr Text m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ DecimalMark) =>
Token s -> m (Token s)
char DecimalMark
Token Text
':' ParsecT CustomErr Text m DecimalMark
-> StorageFormat -> ParsecT CustomErr Text m DecimalMark
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> StorageFormat -> m a
<?> StorageFormat
"':' (hour-minute separator)"
      Int
off3 <- ParsecT CustomErr Text m Int
forall e s (m :: * -> *). MonadParsec e s m => m Int
getOffset
      Int
m' <- ParsecT CustomErr Text m Int
forall (m :: * -> *). TextParser m Int
twoDigitDecimal ParsecT CustomErr Text m Int
-> StorageFormat -> ParsecT CustomErr Text m Int
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> StorageFormat -> m a
<?> StorageFormat
"minute"
      Int
off4 <- ParsecT CustomErr Text m Int
forall e s (m :: * -> *). MonadParsec e s m => m Int
getOffset
      Bool -> ParsecT CustomErr Text m () -> ParsecT CustomErr Text m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
m' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0 Bool -> Bool -> Bool
&& Int
m' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
59) (ParsecT CustomErr Text m () -> ParsecT CustomErr Text m ())
-> ParsecT CustomErr Text m () -> ParsecT CustomErr Text m ()
forall a b. (a -> b) -> a -> b
$ CustomErr -> ParsecT CustomErr Text m ()
forall e s (m :: * -> *) a. MonadParsec e s m => e -> m a
customFailure (CustomErr -> ParsecT CustomErr Text m ())
-> CustomErr -> ParsecT CustomErr Text m ()
forall a b. (a -> b) -> a -> b
$
        Int -> Int -> StorageFormat -> CustomErr
parseErrorAtRegion Int
off3 Int
off4 StorageFormat
"invalid time (bad minute)"

      Int
s' <- Int -> ParsecT CustomErr Text m Int -> ParsecT CustomErr Text m Int
forall (m :: * -> *) a. Alternative m => a -> m a -> m a
option Int
0 (ParsecT CustomErr Text m Int -> ParsecT CustomErr Text m Int)
-> ParsecT CustomErr Text m Int -> ParsecT CustomErr Text m Int
forall a b. (a -> b) -> a -> b
$ do
        Token Text -> ParsecT CustomErr Text m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ DecimalMark) =>
Token s -> m (Token s)
char DecimalMark
Token Text
':' ParsecT CustomErr Text m DecimalMark
-> StorageFormat -> ParsecT CustomErr Text m DecimalMark
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> StorageFormat -> m a
<?> StorageFormat
"':' (minute-second separator)"
        Int
off5 <- ParsecT CustomErr Text m Int
forall e s (m :: * -> *). MonadParsec e s m => m Int
getOffset
        Int
s' <- ParsecT CustomErr Text m Int
forall (m :: * -> *). TextParser m Int
twoDigitDecimal ParsecT CustomErr Text m Int
-> StorageFormat -> ParsecT CustomErr Text m Int
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> StorageFormat -> m a
<?> StorageFormat
"second"
        Int
off6 <- ParsecT CustomErr Text m Int
forall e s (m :: * -> *). MonadParsec e s m => m Int
getOffset
        Bool -> ParsecT CustomErr Text m () -> ParsecT CustomErr Text m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
s' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0 Bool -> Bool -> Bool
&& Int
s' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
59) (ParsecT CustomErr Text m () -> ParsecT CustomErr Text m ())
-> ParsecT CustomErr Text m () -> ParsecT CustomErr Text m ()
forall a b. (a -> b) -> a -> b
$ CustomErr -> ParsecT CustomErr Text m ()
forall e s (m :: * -> *) a. MonadParsec e s m => e -> m a
customFailure (CustomErr -> ParsecT CustomErr Text m ())
-> CustomErr -> ParsecT CustomErr Text m ()
forall a b. (a -> b) -> a -> b
$
          Int -> Int -> StorageFormat -> CustomErr
parseErrorAtRegion Int
off5 Int
off6 StorageFormat
"invalid time (bad second)"
          -- we do not support leap seconds
        Int -> ParsecT CustomErr Text m Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure Int
s'

      TimeOfDay -> TextParser m TimeOfDay
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TimeOfDay -> TextParser m TimeOfDay)
-> TimeOfDay -> TextParser m TimeOfDay
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Pico -> TimeOfDay
TimeOfDay Int
h' Int
m' (Int -> Pico
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
s')

    twoDigitDecimal :: TextParser m Int
    twoDigitDecimal :: TextParser m Int
twoDigitDecimal = do
      Int
d1 <- DecimalMark -> Int
digitToInt (DecimalMark -> Int)
-> ParsecT CustomErr Text m DecimalMark -> TextParser m Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT CustomErr Text m DecimalMark
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ DecimalMark) =>
m (Token s)
digitChar
      Int
d2 <- DecimalMark -> Int
digitToInt (DecimalMark -> Int)
-> ParsecT CustomErr Text m DecimalMark -> TextParser m Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ParsecT CustomErr Text m DecimalMark
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ DecimalMark) =>
m (Token s)
digitChar ParsecT CustomErr Text m DecimalMark
-> StorageFormat -> ParsecT CustomErr Text m DecimalMark
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> StorageFormat -> m a
<?> StorageFormat
"a second digit")
      Int -> TextParser m Int
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int -> TextParser m Int) -> Int -> TextParser m Int
forall a b. (a -> b) -> a -> b
$ Int
d1Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
10 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
d2

    timeZone :: TextParser m String
    timeZone :: TextParser m StorageFormat
timeZone = do
      DecimalMark
plusminus <- (Token Text -> Bool) -> ParsecT CustomErr Text m (Token Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy ((Token Text -> Bool) -> ParsecT CustomErr Text m (Token Text))
-> (Token Text -> Bool) -> ParsecT CustomErr Text m (Token Text)
forall a b. (a -> b) -> a -> b
$ \Token Text
c -> DecimalMark
Token Text
c DecimalMark -> DecimalMark -> Bool
forall a. Eq a => a -> a -> Bool
== DecimalMark
'-' Bool -> Bool -> Bool
|| DecimalMark
Token Text
c DecimalMark -> DecimalMark -> Bool
forall a. Eq a => a -> a -> Bool
== DecimalMark
'+'
      StorageFormat
fourDigits <- Int
-> ParsecT CustomErr Text m DecimalMark
-> TextParser m StorageFormat
forall (m :: * -> *) a. Monad m => Int -> m a -> m [a]
count Int
4 (ParsecT CustomErr Text m DecimalMark
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ DecimalMark) =>
m (Token s)
digitChar ParsecT CustomErr Text m DecimalMark
-> StorageFormat -> ParsecT CustomErr Text m DecimalMark
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> StorageFormat -> m a
<?> StorageFormat
"a digit (for a time zone)")
      StorageFormat -> TextParser m StorageFormat
forall (f :: * -> *) a. Applicative f => a -> f a
pure (StorageFormat -> TextParser m StorageFormat)
-> StorageFormat -> TextParser m StorageFormat
forall a b. (a -> b) -> a -> b
$ DecimalMark
plusminusDecimalMark -> ShowS
forall a. a -> [a] -> [a]
:StorageFormat
fourDigits

secondarydatep :: Day -> TextParser m Day
secondarydatep :: Day -> TextParser m Day
secondarydatep Day
primaryDate = Token Text -> ParsecT CustomErr Text m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ DecimalMark) =>
Token s -> m (Token s)
char DecimalMark
Token Text
'=' ParsecT CustomErr Text m DecimalMark
-> TextParser m Day -> TextParser m Day
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Maybe Integer -> TextParser m Day
forall (m :: * -> *). Maybe Integer -> TextParser m Day
datep' (Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
primaryYear)
  where primaryYear :: Integer
primaryYear = (Integer, Int, Int) -> Integer
forall a b c. (a, b, c) -> a
first3 ((Integer, Int, Int) -> Integer) -> (Integer, Int, Int) -> Integer
forall a b. (a -> b) -> a -> b
$ Day -> (Integer, Int, Int)
toGregorian Day
primaryDate

-- | Parse a year number or an Int. Years must contain at least four
-- digits.
yearorintp :: TextParser m (Either Year Int)
yearorintp :: TextParser m (Either Integer Int)
yearorintp = do
    Text
yearOrMonth <- Maybe StorageFormat
-> (Token Text -> Bool) -> ParsecT CustomErr Text m (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe StorageFormat -> (Token s -> Bool) -> m (Tokens s)
takeWhile1P (StorageFormat -> Maybe StorageFormat
forall a. a -> Maybe a
Just StorageFormat
"digit") DecimalMark -> Bool
Token Text -> Bool
isDigit
    let n :: Integer
n = Text -> Integer
readDecimal Text
yearOrMonth
    Either Integer Int -> TextParser m (Either Integer Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Integer Int -> TextParser m (Either Integer Int))
-> Either Integer Int -> TextParser m (Either Integer Int)
forall a b. (a -> b) -> a -> b
$ if Text -> Int
T.length Text
yearOrMonth Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
4 then Integer -> Either Integer Int
forall a b. a -> Either a b
Left Integer
n else Int -> Either Integer Int
forall a b. b -> Either a b
Right (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
n)

--- *** account names

-- | Parse an account name (plus one following space if present),
-- then apply any parent account prefix and/or account aliases currently in effect,
-- in that order. (Ie first add the parent account prefix, then rewrite with aliases).
-- This calls error if any account alias with an invalid regular expression exists.
modifiedaccountnamep :: JournalParser m AccountName
modifiedaccountnamep :: JournalParser m Text
modifiedaccountnamep = do
  Text
parent  <- JournalParser m Text
forall (m :: * -> *). JournalParser m Text
getParentAccount
  [AccountAlias]
aliases <- StateT Journal (ParsecT CustomErr Text m) [AccountAlias]
forall (m :: * -> *). MonadState Journal m => m [AccountAlias]
getAccountAliases
  -- off1    <- getOffset
  Text
a       <- ParsecT CustomErr Text m Text -> JournalParser m Text
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ParsecT CustomErr Text m Text
forall (m :: * -> *). TextParser m Text
accountnamep
  -- off2    <- getOffset
  -- XXX or accountNameApplyAliasesMemo ? doesn't seem to make a difference (retest that function)
  case [AccountAlias] -> Text -> Either StorageFormat Text
accountNameApplyAliases [AccountAlias]
aliases (Text -> Either StorageFormat Text)
-> Text -> Either StorageFormat Text
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Text
joinAccountNames Text
parent Text
a of
    Right Text
a' -> Text -> JournalParser m Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> JournalParser m Text) -> Text -> JournalParser m Text
forall a b. (a -> b) -> a -> b
$! Text
a'
    -- should not happen, regexaliasp will have displayed a better error already:
    -- (XXX why does customFailure cause error to be displayed there, but not here ?)
    -- Left e  -> customFailure $! parseErrorAtRegion off1 off2 err
    Left StorageFormat
e   -> StorageFormat -> JournalParser m Text
forall a. StorageFormat -> a
error' StorageFormat
err  -- PARTIAL:
      where
        err :: StorageFormat
err = StorageFormat
"problem in account alias applied to "StorageFormat -> ShowS
forall a. [a] -> [a] -> [a]
++Text -> StorageFormat
T.unpack Text
aStorageFormat -> ShowS
forall a. [a] -> [a] -> [a]
++StorageFormat
": "StorageFormat -> ShowS
forall a. [a] -> [a] -> [a]
++StorageFormat
e

-- | Parse an account name, plus one following space if present.
-- Account names have one or more parts separated by the account separator character,
-- and are terminated by two or more spaces (or end of input).
-- Each part is at least one character long, may have single spaces inside it,
-- and starts with a non-whitespace.
-- Note, this means "{account}", "%^!" and ";comment" are all accepted
-- (parent parsers usually prevent/consume the last).
-- It should have required parts to start with an alphanumeric;
-- for now it remains as-is for backwards compatibility.
accountnamep :: TextParser m AccountName
accountnamep :: TextParser m Text
accountnamep = TextParser m Text
forall (m :: * -> *). TextParser m Text
singlespacedtextp


-- | Parse any text beginning with a non-whitespace character, until a
-- double space or the end of input.
-- TODO including characters which normally start a comment (;#) - exclude those ? 
singlespacedtextp :: TextParser m T.Text
singlespacedtextp :: TextParser m Text
singlespacedtextp = (DecimalMark -> Bool) -> TextParser m Text
forall (m :: * -> *). (DecimalMark -> Bool) -> TextParser m Text
singlespacedtextsatisfyingp (Bool -> DecimalMark -> Bool
forall a b. a -> b -> a
const Bool
True)

-- | Similar to 'singlespacedtextp', except that the text must only contain
-- characters satisfying the given predicate.
singlespacedtextsatisfyingp :: (Char -> Bool) -> TextParser m T.Text
singlespacedtextsatisfyingp :: (DecimalMark -> Bool) -> TextParser m Text
singlespacedtextsatisfyingp DecimalMark -> Bool
pred = do
  Text
firstPart <- TextParser m Text
ParsecT CustomErr Text m (Tokens Text)
partp
  [Text]
otherParts <- TextParser m Text -> ParsecT CustomErr Text m [Text]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many (TextParser m Text -> ParsecT CustomErr Text m [Text])
-> TextParser m Text -> ParsecT CustomErr Text m [Text]
forall a b. (a -> b) -> a -> b
$ TextParser m Text -> TextParser m Text
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (TextParser m Text -> TextParser m Text)
-> TextParser m Text -> TextParser m Text
forall a b. (a -> b) -> a -> b
$ TextParser m ()
forall (m :: * -> *). TextParser m ()
singlespacep TextParser m () -> TextParser m Text -> TextParser m Text
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> TextParser m Text
ParsecT CustomErr Text m (Tokens Text)
partp
  Text -> TextParser m Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> TextParser m Text) -> Text -> TextParser m Text
forall a b. (a -> b) -> a -> b
$! [Text] -> Text
T.unwords ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ Text
firstPart Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
otherParts
  where
    partp :: ParsecT CustomErr Text m (Tokens Text)
partp = Maybe StorageFormat
-> (Token Text -> Bool) -> ParsecT CustomErr Text m (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe StorageFormat -> (Token s -> Bool) -> m (Tokens s)
takeWhile1P Maybe StorageFormat
forall a. Maybe a
Nothing (\Token Text
c -> DecimalMark -> Bool
pred DecimalMark
Token Text
c Bool -> Bool -> Bool
&& Bool -> Bool
not (DecimalMark -> Bool
isSpace DecimalMark
Token Text
c))

-- | Parse one non-newline whitespace character that is not followed by another one.
singlespacep :: TextParser m ()
singlespacep :: TextParser m ()
singlespacep = ParsecT CustomErr Text m DecimalMark
forall s (m :: * -> *).
(Stream s, DecimalMark ~ Token s) =>
ParsecT CustomErr s m DecimalMark
spacenonewline ParsecT CustomErr Text m DecimalMark
-> TextParser m () -> TextParser m ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT CustomErr Text m DecimalMark -> TextParser m ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
notFollowedBy ParsecT CustomErr Text m DecimalMark
forall s (m :: * -> *).
(Stream s, DecimalMark ~ Token s) =>
ParsecT CustomErr s m DecimalMark
spacenonewline

--- *** amounts

-- | Parse whitespace then an amount, with an optional left or right
-- currency symbol and optional price, or return the special
-- "missing" marker amount.
spaceandamountormissingp :: JournalParser m MixedAmount
spaceandamountormissingp :: JournalParser m MixedAmount
spaceandamountormissingp =
  MixedAmount
-> JournalParser m MixedAmount -> JournalParser m MixedAmount
forall (m :: * -> *) a. Alternative m => a -> m a -> m a
option MixedAmount
missingmixedamt (JournalParser m MixedAmount -> JournalParser m MixedAmount)
-> JournalParser m MixedAmount -> JournalParser m MixedAmount
forall a b. (a -> b) -> a -> b
$ JournalParser m MixedAmount -> JournalParser m MixedAmount
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (JournalParser m MixedAmount -> JournalParser m MixedAmount)
-> JournalParser m MixedAmount -> JournalParser m MixedAmount
forall a b. (a -> b) -> a -> b
$ do
    ParsecT CustomErr Text m ()
-> StateT Journal (ParsecT CustomErr Text m) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ParsecT CustomErr Text m ()
 -> StateT Journal (ParsecT CustomErr Text m) ())
-> ParsecT CustomErr Text m ()
-> StateT Journal (ParsecT CustomErr Text m) ()
forall a b. (a -> b) -> a -> b
$ ParsecT CustomErr Text m ()
forall s (m :: * -> *).
(Stream s, Token s ~ DecimalMark) =>
ParsecT CustomErr s m ()
skipNonNewlineSpaces1
    [Amount] -> MixedAmount
Mixed ([Amount] -> MixedAmount)
-> (Amount -> [Amount]) -> Amount -> MixedAmount
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Amount -> [Amount] -> [Amount]
forall a. a -> [a] -> [a]
:[]) (Amount -> MixedAmount)
-> StateT Journal (ParsecT CustomErr Text m) Amount
-> JournalParser m MixedAmount
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT Journal (ParsecT CustomErr Text m) Amount
forall (m :: * -> *). JournalParser m Amount
amountp

-- | Parse a single-commodity amount, with optional symbol on the left
-- or right, followed by, in any order: an optional transaction price,
-- an optional ledger-style lot price, and/or an optional ledger-style
-- lot date. A lot price and lot date will be ignored.
--
-- To parse the amount's quantity (number) we need to know which character 
-- represents a decimal mark. We find it in one of three ways:
--
-- 1. If a decimal mark has been set explicitly in the journal parse state, 
--    we use that
--
-- 2. Or if the journal has a commodity declaration for the amount's commodity,
--    we get the decimal mark from  that
--
-- 3. Otherwise we will parse any valid decimal mark appearing in the
--    number, as long as the number appears well formed.
--
-- Note 3 is the default zero-config case; it means we automatically handle
-- files with any supported decimal mark, but it also allows different decimal marks
-- in  different amounts, which is a bit too loose. There's an open issue.
amountp :: JournalParser m Amount
amountp :: JournalParser m Amount
amountp = StorageFormat -> JournalParser m Amount -> JournalParser m Amount
forall e s (m :: * -> *) a.
MonadParsec e s m =>
StorageFormat -> m a -> m a
label StorageFormat
"amount" (JournalParser m Amount -> JournalParser m Amount)
-> JournalParser m Amount -> JournalParser m Amount
forall a b. (a -> b) -> a -> b
$ do
  let 
    spaces :: StateT Journal (ParsecT CustomErr Text m) ()
spaces = ParsecT CustomErr Text m ()
-> StateT Journal (ParsecT CustomErr Text m) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ParsecT CustomErr Text m ()
 -> StateT Journal (ParsecT CustomErr Text m) ())
-> ParsecT CustomErr Text m ()
-> StateT Journal (ParsecT CustomErr Text m) ()
forall a b. (a -> b) -> a -> b
$ ParsecT CustomErr Text m ()
forall s (m :: * -> *).
(Stream s, Token s ~ DecimalMark) =>
ParsecT CustomErr s m ()
skipNonNewlineSpaces
  Amount
amount <- JournalParser m Amount
forall (m :: * -> *). JournalParser m Amount
amountwithoutpricep JournalParser m Amount
-> StateT Journal (ParsecT CustomErr Text m) ()
-> JournalParser m Amount
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* StateT Journal (ParsecT CustomErr Text m) ()
forall (m :: * -> *). StateT Journal (ParsecT CustomErr Text m) ()
spaces
  (Maybe AmountPrice
mprice, Maybe ()
_elotprice, Maybe ()
_elotdate) <- Permutation
  (StateT Journal (ParsecT CustomErr Text m))
  (Maybe AmountPrice, Maybe (), Maybe ())
-> StateT
     Journal
     (ParsecT CustomErr Text m)
     (Maybe AmountPrice, Maybe (), Maybe ())
forall (m :: * -> *) a. Alternative m => Permutation m a -> m a
runPermutation (Permutation
   (StateT Journal (ParsecT CustomErr Text m))
   (Maybe AmountPrice, Maybe (), Maybe ())
 -> StateT
      Journal
      (ParsecT CustomErr Text m)
      (Maybe AmountPrice, Maybe (), Maybe ()))
-> Permutation
     (StateT Journal (ParsecT CustomErr Text m))
     (Maybe AmountPrice, Maybe (), Maybe ())
-> StateT
     Journal
     (ParsecT CustomErr Text m)
     (Maybe AmountPrice, Maybe (), Maybe ())
forall a b. (a -> b) -> a -> b
$
    (,,) (Maybe AmountPrice
 -> Maybe () -> Maybe () -> (Maybe AmountPrice, Maybe (), Maybe ()))
-> Permutation
     (StateT Journal (ParsecT CustomErr Text m)) (Maybe AmountPrice)
-> Permutation
     (StateT Journal (ParsecT CustomErr Text m))
     (Maybe () -> Maybe () -> (Maybe AmountPrice, Maybe (), Maybe ()))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe AmountPrice
-> StateT Journal (ParsecT CustomErr Text m) (Maybe AmountPrice)
-> Permutation
     (StateT Journal (ParsecT CustomErr Text m)) (Maybe AmountPrice)
forall (m :: * -> *) a.
Alternative m =>
a -> m a -> Permutation m a
toPermutationWithDefault Maybe AmountPrice
forall a. Maybe a
Nothing (AmountPrice -> Maybe AmountPrice
forall a. a -> Maybe a
Just (AmountPrice -> Maybe AmountPrice)
-> StateT Journal (ParsecT CustomErr Text m) AmountPrice
-> StateT Journal (ParsecT CustomErr Text m) (Maybe AmountPrice)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Amount -> StateT Journal (ParsecT CustomErr Text m) AmountPrice
forall (m :: * -> *). Amount -> JournalParser m AmountPrice
priceamountp Amount
amount StateT Journal (ParsecT CustomErr Text m) (Maybe AmountPrice)
-> StateT Journal (ParsecT CustomErr Text m) ()
-> StateT Journal (ParsecT CustomErr Text m) (Maybe AmountPrice)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* StateT Journal (ParsecT CustomErr Text m) ()
forall (m :: * -> *). StateT Journal (ParsecT CustomErr Text m) ()
spaces)
         Permutation
  (StateT Journal (ParsecT CustomErr Text m))
  (Maybe () -> Maybe () -> (Maybe AmountPrice, Maybe (), Maybe ()))
-> Permutation
     (StateT Journal (ParsecT CustomErr Text m)) (Maybe ())
-> Permutation
     (StateT Journal (ParsecT CustomErr Text m))
     (Maybe () -> (Maybe AmountPrice, Maybe (), Maybe ()))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe ()
-> StateT Journal (ParsecT CustomErr Text m) (Maybe ())
-> Permutation
     (StateT Journal (ParsecT CustomErr Text m)) (Maybe ())
forall (m :: * -> *) a.
Alternative m =>
a -> m a -> Permutation m a
toPermutationWithDefault Maybe ()
forall a. Maybe a
Nothing (() -> Maybe ()
forall a. a -> Maybe a
Just (() -> Maybe ())
-> StateT Journal (ParsecT CustomErr Text m) ()
-> StateT Journal (ParsecT CustomErr Text m) (Maybe ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT Journal (ParsecT CustomErr Text m) ()
forall (m :: * -> *). StateT Journal (ParsecT CustomErr Text m) ()
lotpricep StateT Journal (ParsecT CustomErr Text m) (Maybe ())
-> StateT Journal (ParsecT CustomErr Text m) ()
-> StateT Journal (ParsecT CustomErr Text m) (Maybe ())
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* StateT Journal (ParsecT CustomErr Text m) ()
forall (m :: * -> *). StateT Journal (ParsecT CustomErr Text m) ()
spaces)
         Permutation
  (StateT Journal (ParsecT CustomErr Text m))
  (Maybe () -> (Maybe AmountPrice, Maybe (), Maybe ()))
-> Permutation
     (StateT Journal (ParsecT CustomErr Text m)) (Maybe ())
-> Permutation
     (StateT Journal (ParsecT CustomErr Text m))
     (Maybe AmountPrice, Maybe (), Maybe ())
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe ()
-> StateT Journal (ParsecT CustomErr Text m) (Maybe ())
-> Permutation
     (StateT Journal (ParsecT CustomErr Text m)) (Maybe ())
forall (m :: * -> *) a.
Alternative m =>
a -> m a -> Permutation m a
toPermutationWithDefault Maybe ()
forall a. Maybe a
Nothing (() -> Maybe ()
forall a. a -> Maybe a
Just (() -> Maybe ())
-> StateT Journal (ParsecT CustomErr Text m) ()
-> StateT Journal (ParsecT CustomErr Text m) (Maybe ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT Journal (ParsecT CustomErr Text m) ()
forall (m :: * -> *). StateT Journal (ParsecT CustomErr Text m) ()
lotdatep StateT Journal (ParsecT CustomErr Text m) (Maybe ())
-> StateT Journal (ParsecT CustomErr Text m) ()
-> StateT Journal (ParsecT CustomErr Text m) (Maybe ())
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* StateT Journal (ParsecT CustomErr Text m) ()
forall (m :: * -> *). StateT Journal (ParsecT CustomErr Text m) ()
spaces)
  Amount -> JournalParser m Amount
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Amount -> JournalParser m Amount)
-> Amount -> JournalParser m Amount
forall a b. (a -> b) -> a -> b
$ Amount
amount { aprice :: Maybe AmountPrice
aprice = Maybe AmountPrice
mprice }

amountpnolotpricesp :: JournalParser m Amount
amountpnolotpricesp :: JournalParser m Amount
amountpnolotpricesp = StorageFormat -> JournalParser m Amount -> JournalParser m Amount
forall e s (m :: * -> *) a.
MonadParsec e s m =>
StorageFormat -> m a -> m a
label StorageFormat
"amount" (JournalParser m Amount -> JournalParser m Amount)
-> JournalParser m Amount -> JournalParser m Amount
forall a b. (a -> b) -> a -> b
$ do
  let spaces :: StateT Journal (ParsecT CustomErr Text m) ()
spaces = ParsecT CustomErr Text m ()
-> StateT Journal (ParsecT CustomErr Text m) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ParsecT CustomErr Text m ()
 -> StateT Journal (ParsecT CustomErr Text m) ())
-> ParsecT CustomErr Text m ()
-> StateT Journal (ParsecT CustomErr Text m) ()
forall a b. (a -> b) -> a -> b
$ ParsecT CustomErr Text m ()
forall s (m :: * -> *).
(Stream s, Token s ~ DecimalMark) =>
ParsecT CustomErr s m ()
skipNonNewlineSpaces
  Amount
amount <- JournalParser m Amount
forall (m :: * -> *). JournalParser m Amount
amountwithoutpricep
  StateT Journal (ParsecT CustomErr Text m) ()
forall (m :: * -> *). StateT Journal (ParsecT CustomErr Text m) ()
spaces
  Maybe AmountPrice
mprice <- StateT Journal (ParsecT CustomErr Text m) AmountPrice
-> StateT Journal (ParsecT CustomErr Text m) (Maybe AmountPrice)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (StateT Journal (ParsecT CustomErr Text m) AmountPrice
 -> StateT Journal (ParsecT CustomErr Text m) (Maybe AmountPrice))
-> StateT Journal (ParsecT CustomErr Text m) AmountPrice
-> StateT Journal (ParsecT CustomErr Text m) (Maybe AmountPrice)
forall a b. (a -> b) -> a -> b
$ Amount -> StateT Journal (ParsecT CustomErr Text m) AmountPrice
forall (m :: * -> *). Amount -> JournalParser m AmountPrice
priceamountp Amount
amount StateT Journal (ParsecT CustomErr Text m) AmountPrice
-> StateT Journal (ParsecT CustomErr Text m) ()
-> StateT Journal (ParsecT CustomErr Text m) AmountPrice
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* StateT Journal (ParsecT CustomErr Text m) ()
forall (m :: * -> *). StateT Journal (ParsecT CustomErr Text m) ()
spaces
  Amount -> JournalParser m Amount
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Amount -> JournalParser m Amount)
-> Amount -> JournalParser m Amount
forall a b. (a -> b) -> a -> b
$ Amount
amount { aprice :: Maybe AmountPrice
aprice = Maybe AmountPrice
mprice }

amountwithoutpricep :: JournalParser m Amount
amountwithoutpricep :: JournalParser m Amount
amountwithoutpricep = do
  (Bool
mult, Decimal -> Decimal
sign) <- ParsecT CustomErr Text m (Bool, Decimal -> Decimal)
-> StateT
     Journal (ParsecT CustomErr Text m) (Bool, Decimal -> Decimal)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ParsecT CustomErr Text m (Bool, Decimal -> Decimal)
 -> StateT
      Journal (ParsecT CustomErr Text m) (Bool, Decimal -> Decimal))
-> ParsecT CustomErr Text m (Bool, Decimal -> Decimal)
-> StateT
     Journal (ParsecT CustomErr Text m) (Bool, Decimal -> Decimal)
forall a b. (a -> b) -> a -> b
$ (,) (Bool -> (Decimal -> Decimal) -> (Bool, Decimal -> Decimal))
-> ParsecT CustomErr Text m Bool
-> ParsecT
     CustomErr
     Text
     m
     ((Decimal -> Decimal) -> (Bool, Decimal -> Decimal))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT CustomErr Text m Bool
forall (m :: * -> *). TextParser m Bool
multiplierp ParsecT
  CustomErr
  Text
  m
  ((Decimal -> Decimal) -> (Bool, Decimal -> Decimal))
-> ParsecT CustomErr Text m (Decimal -> Decimal)
-> ParsecT CustomErr Text m (Bool, Decimal -> Decimal)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT CustomErr Text m (Decimal -> Decimal)
forall a (m :: * -> *). Num a => TextParser m (a -> a)
signp
  Bool -> (Decimal -> Decimal) -> JournalParser m Amount
forall (m :: * -> *).
Bool -> (Decimal -> Decimal) -> JournalParser m Amount
leftsymbolamountp Bool
mult Decimal -> Decimal
sign JournalParser m Amount
-> JournalParser m Amount -> JournalParser m Amount
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Bool -> (Decimal -> Decimal) -> JournalParser m Amount
forall (m :: * -> *).
Bool -> (Decimal -> Decimal) -> JournalParser m Amount
rightornosymbolamountp Bool
mult Decimal -> Decimal
sign

  where

  leftsymbolamountp :: Bool -> (Decimal -> Decimal) -> JournalParser m Amount
  leftsymbolamountp :: Bool -> (Decimal -> Decimal) -> JournalParser m Amount
leftsymbolamountp Bool
mult Decimal -> Decimal
sign = StorageFormat -> JournalParser m Amount -> JournalParser m Amount
forall e s (m :: * -> *) a.
MonadParsec e s m =>
StorageFormat -> m a -> m a
label StorageFormat
"amount" (JournalParser m Amount -> JournalParser m Amount)
-> JournalParser m Amount -> JournalParser m Amount
forall a b. (a -> b) -> a -> b
$ do
    Text
c <- ParsecT CustomErr Text m Text
-> StateT Journal (ParsecT CustomErr Text m) Text
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ParsecT CustomErr Text m Text
forall (m :: * -> *). TextParser m Text
commoditysymbolp
    Maybe AmountStyle
mdecmarkStyle <- JournalParser m (Maybe AmountStyle)
forall (m :: * -> *). JournalParser m (Maybe AmountStyle)
getDecimalMarkStyle
    Maybe AmountStyle
mcommodityStyle <- Text -> JournalParser m (Maybe AmountStyle)
forall (m :: * -> *). Text -> JournalParser m (Maybe AmountStyle)
getAmountStyle Text
c
    -- XXX amounts of this commodity in periodic transaction rules and auto posting rules ? #1461
    let suggestedStyle :: Maybe AmountStyle
suggestedStyle = Maybe AmountStyle
mdecmarkStyle Maybe AmountStyle -> Maybe AmountStyle -> Maybe AmountStyle
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe AmountStyle
mcommodityStyle
    Bool
commodityspaced <- ParsecT CustomErr Text m Bool
-> StateT Journal (ParsecT CustomErr Text m) Bool
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ParsecT CustomErr Text m Bool
forall s (m :: * -> *).
(Stream s, Token s ~ DecimalMark) =>
ParsecT CustomErr s m Bool
skipNonNewlineSpaces'
    Decimal -> Decimal
sign2 <- ParsecT CustomErr Text m (Decimal -> Decimal)
-> StateT Journal (ParsecT CustomErr Text m) (Decimal -> Decimal)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ParsecT CustomErr Text m (Decimal -> Decimal)
 -> StateT Journal (ParsecT CustomErr Text m) (Decimal -> Decimal))
-> ParsecT CustomErr Text m (Decimal -> Decimal)
-> StateT Journal (ParsecT CustomErr Text m) (Decimal -> Decimal)
forall a b. (a -> b) -> a -> b
$ ParsecT CustomErr Text m (Decimal -> Decimal)
forall a (m :: * -> *). Num a => TextParser m (a -> a)
signp
    Int
offBeforeNum <- StateT Journal (ParsecT CustomErr Text m) Int
forall e s (m :: * -> *). MonadParsec e s m => m Int
getOffset
    Either AmbiguousNumber RawNumber
ambiguousRawNum <- ParsecT CustomErr Text m (Either AmbiguousNumber RawNumber)
-> StateT
     Journal
     (ParsecT CustomErr Text m)
     (Either AmbiguousNumber RawNumber)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ParsecT CustomErr Text m (Either AmbiguousNumber RawNumber)
forall (m :: * -> *).
TextParser m (Either AmbiguousNumber RawNumber)
rawnumberp
    Maybe Integer
mExponent <- ParsecT CustomErr Text m (Maybe Integer)
-> StateT Journal (ParsecT CustomErr Text m) (Maybe Integer)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ParsecT CustomErr Text m (Maybe Integer)
 -> StateT Journal (ParsecT CustomErr Text m) (Maybe Integer))
-> ParsecT CustomErr Text m (Maybe Integer)
-> StateT Journal (ParsecT CustomErr Text m) (Maybe Integer)
forall a b. (a -> b) -> a -> b
$ ParsecT CustomErr Text m Integer
-> ParsecT CustomErr Text m (Maybe Integer)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (ParsecT CustomErr Text m Integer
 -> ParsecT CustomErr Text m (Maybe Integer))
-> ParsecT CustomErr Text m Integer
-> ParsecT CustomErr Text m (Maybe Integer)
forall a b. (a -> b) -> a -> b
$ ParsecT CustomErr Text m Integer
-> ParsecT CustomErr Text m Integer
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try ParsecT CustomErr Text m Integer
forall (m :: * -> *). TextParser m Integer
exponentp
    Int
offAfterNum <- StateT Journal (ParsecT CustomErr Text m) Int
forall e s (m :: * -> *). MonadParsec e s m => m Int
getOffset
    let numRegion :: (Int, Int)
numRegion = (Int
offBeforeNum, Int
offAfterNum)
    (Decimal
q,AmountPrecision
prec,Maybe DecimalMark
mdec,Maybe DigitGroupStyle
mgrps) <- ParsecT
  CustomErr
  Text
  m
  (Decimal, AmountPrecision, Maybe DecimalMark,
   Maybe DigitGroupStyle)
-> StateT
     Journal
     (ParsecT CustomErr Text m)
     (Decimal, AmountPrecision, Maybe DecimalMark,
      Maybe DigitGroupStyle)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ParsecT
   CustomErr
   Text
   m
   (Decimal, AmountPrecision, Maybe DecimalMark,
    Maybe DigitGroupStyle)
 -> StateT
      Journal
      (ParsecT CustomErr Text m)
      (Decimal, AmountPrecision, Maybe DecimalMark,
       Maybe DigitGroupStyle))
-> ParsecT
     CustomErr
     Text
     m
     (Decimal, AmountPrecision, Maybe DecimalMark,
      Maybe DigitGroupStyle)
-> StateT
     Journal
     (ParsecT CustomErr Text m)
     (Decimal, AmountPrecision, Maybe DecimalMark,
      Maybe DigitGroupStyle)
forall a b. (a -> b) -> a -> b
$ (Int, Int)
-> Maybe AmountStyle
-> Either AmbiguousNumber RawNumber
-> Maybe Integer
-> ParsecT
     CustomErr
     Text
     m
     (Decimal, AmountPrecision, Maybe DecimalMark,
      Maybe DigitGroupStyle)
forall (m :: * -> *).
(Int, Int)
-> Maybe AmountStyle
-> Either AmbiguousNumber RawNumber
-> Maybe Integer
-> TextParser
     m
     (Decimal, AmountPrecision, Maybe DecimalMark,
      Maybe DigitGroupStyle)
interpretNumber (Int, Int)
numRegion Maybe AmountStyle
suggestedStyle Either AmbiguousNumber RawNumber
ambiguousRawNum Maybe Integer
mExponent
    let s :: AmountStyle
s = AmountStyle
amountstyle{ascommodityside :: Side
ascommodityside=Side
L, ascommodityspaced :: Bool
ascommodityspaced=Bool
commodityspaced, asprecision :: AmountPrecision
asprecision=AmountPrecision
prec, asdecimalpoint :: Maybe DecimalMark
asdecimalpoint=Maybe DecimalMark
mdec, asdigitgroups :: Maybe DigitGroupStyle
asdigitgroups=Maybe DigitGroupStyle
mgrps}
    Amount -> JournalParser m Amount
forall (m :: * -> *) a. Monad m => a -> m a
return (Amount -> JournalParser m Amount)
-> Amount -> JournalParser m Amount
forall a b. (a -> b) -> a -> b
$ Amount
nullamt{acommodity :: Text
acommodity=Text
c, aquantity :: Decimal
aquantity=Decimal -> Decimal
sign (Decimal -> Decimal
sign2 Decimal
q), aismultiplier :: Bool
aismultiplier=Bool
mult, astyle :: AmountStyle
astyle=AmountStyle
s, aprice :: Maybe AmountPrice
aprice=Maybe AmountPrice
forall a. Maybe a
Nothing}

  rightornosymbolamountp :: Bool -> (Decimal -> Decimal) -> JournalParser m Amount
  rightornosymbolamountp :: Bool -> (Decimal -> Decimal) -> JournalParser m Amount
rightornosymbolamountp Bool
mult Decimal -> Decimal
sign = StorageFormat -> JournalParser m Amount -> JournalParser m Amount
forall e s (m :: * -> *) a.
MonadParsec e s m =>
StorageFormat -> m a -> m a
label StorageFormat
"amount" (JournalParser m Amount -> JournalParser m Amount)
-> JournalParser m Amount -> JournalParser m Amount
forall a b. (a -> b) -> a -> b
$ do
    Int
offBeforeNum <- StateT Journal (ParsecT CustomErr Text m) Int
forall e s (m :: * -> *). MonadParsec e s m => m Int
getOffset
    Either AmbiguousNumber RawNumber
ambiguousRawNum <- ParsecT CustomErr Text m (Either AmbiguousNumber RawNumber)
-> StateT
     Journal
     (ParsecT CustomErr Text m)
     (Either AmbiguousNumber RawNumber)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ParsecT CustomErr Text m (Either AmbiguousNumber RawNumber)
forall (m :: * -> *).
TextParser m (Either AmbiguousNumber RawNumber)
rawnumberp
    Maybe Integer
mExponent <- ParsecT CustomErr Text m (Maybe Integer)
-> StateT Journal (ParsecT CustomErr Text m) (Maybe Integer)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ParsecT CustomErr Text m (Maybe Integer)
 -> StateT Journal (ParsecT CustomErr Text m) (Maybe Integer))
-> ParsecT CustomErr Text m (Maybe Integer)
-> StateT Journal (ParsecT CustomErr Text m) (Maybe Integer)
forall a b. (a -> b) -> a -> b
$ ParsecT CustomErr Text m Integer
-> ParsecT CustomErr Text m (Maybe Integer)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (ParsecT CustomErr Text m Integer
 -> ParsecT CustomErr Text m (Maybe Integer))
-> ParsecT CustomErr Text m Integer
-> ParsecT CustomErr Text m (Maybe Integer)
forall a b. (a -> b) -> a -> b
$ ParsecT CustomErr Text m Integer
-> ParsecT CustomErr Text m Integer
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try ParsecT CustomErr Text m Integer
forall (m :: * -> *). TextParser m Integer
exponentp
    Int
offAfterNum <- StateT Journal (ParsecT CustomErr Text m) Int
forall e s (m :: * -> *). MonadParsec e s m => m Int
getOffset
    let numRegion :: (Int, Int)
numRegion = (Int
offBeforeNum, Int
offAfterNum)
    Maybe (Bool, Text)
mSpaceAndCommodity <- ParsecT CustomErr Text m (Maybe (Bool, Text))
-> StateT Journal (ParsecT CustomErr Text m) (Maybe (Bool, Text))
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ParsecT CustomErr Text m (Maybe (Bool, Text))
 -> StateT Journal (ParsecT CustomErr Text m) (Maybe (Bool, Text)))
-> ParsecT CustomErr Text m (Maybe (Bool, Text))
-> StateT Journal (ParsecT CustomErr Text m) (Maybe (Bool, Text))
forall a b. (a -> b) -> a -> b
$ ParsecT CustomErr Text m (Bool, Text)
-> ParsecT CustomErr Text m (Maybe (Bool, Text))
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (ParsecT CustomErr Text m (Bool, Text)
 -> ParsecT CustomErr Text m (Maybe (Bool, Text)))
-> ParsecT CustomErr Text m (Bool, Text)
-> ParsecT CustomErr Text m (Maybe (Bool, Text))
forall a b. (a -> b) -> a -> b
$ ParsecT CustomErr Text m (Bool, Text)
-> ParsecT CustomErr Text m (Bool, Text)
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (ParsecT CustomErr Text m (Bool, Text)
 -> ParsecT CustomErr Text m (Bool, Text))
-> ParsecT CustomErr Text m (Bool, Text)
-> ParsecT CustomErr Text m (Bool, Text)
forall a b. (a -> b) -> a -> b
$ (,) (Bool -> Text -> (Bool, Text))
-> ParsecT CustomErr Text m Bool
-> ParsecT CustomErr Text m (Text -> (Bool, Text))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT CustomErr Text m Bool
forall s (m :: * -> *).
(Stream s, Token s ~ DecimalMark) =>
ParsecT CustomErr s m Bool
skipNonNewlineSpaces' ParsecT CustomErr Text m (Text -> (Bool, Text))
-> ParsecT CustomErr Text m Text
-> ParsecT CustomErr Text m (Bool, Text)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT CustomErr Text m Text
forall (m :: * -> *). TextParser m Text
commoditysymbolp
    case Maybe (Bool, Text)
mSpaceAndCommodity of
      -- right symbol amount
      Just (Bool
commodityspaced, Text
c) -> do
        Maybe AmountStyle
mdecmarkStyle <- JournalParser m (Maybe AmountStyle)
forall (m :: * -> *). JournalParser m (Maybe AmountStyle)
getDecimalMarkStyle
        Maybe AmountStyle
mcommodityStyle <- Text -> JournalParser m (Maybe AmountStyle)
forall (m :: * -> *). Text -> JournalParser m (Maybe AmountStyle)
getAmountStyle Text
c
        -- XXX amounts of this commodity in periodic transaction rules and auto posting rules ? #1461
        let msuggestedStyle :: Maybe AmountStyle
msuggestedStyle = Maybe AmountStyle
mdecmarkStyle Maybe AmountStyle -> Maybe AmountStyle -> Maybe AmountStyle
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe AmountStyle
mcommodityStyle
        (Decimal
q,AmountPrecision
prec,Maybe DecimalMark
mdec,Maybe DigitGroupStyle
mgrps) <- ParsecT
  CustomErr
  Text
  m
  (Decimal, AmountPrecision, Maybe DecimalMark,
   Maybe DigitGroupStyle)
-> StateT
     Journal
     (ParsecT CustomErr Text m)
     (Decimal, AmountPrecision, Maybe DecimalMark,
      Maybe DigitGroupStyle)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ParsecT
   CustomErr
   Text
   m
   (Decimal, AmountPrecision, Maybe DecimalMark,
    Maybe DigitGroupStyle)
 -> StateT
      Journal
      (ParsecT CustomErr Text m)
      (Decimal, AmountPrecision, Maybe DecimalMark,
       Maybe DigitGroupStyle))
-> ParsecT
     CustomErr
     Text
     m
     (Decimal, AmountPrecision, Maybe DecimalMark,
      Maybe DigitGroupStyle)
-> StateT
     Journal
     (ParsecT CustomErr Text m)
     (Decimal, AmountPrecision, Maybe DecimalMark,
      Maybe DigitGroupStyle)
forall a b. (a -> b) -> a -> b
$ (Int, Int)
-> Maybe AmountStyle
-> Either AmbiguousNumber RawNumber
-> Maybe Integer
-> ParsecT
     CustomErr
     Text
     m
     (Decimal, AmountPrecision, Maybe DecimalMark,
      Maybe DigitGroupStyle)
forall (m :: * -> *).
(Int, Int)
-> Maybe AmountStyle
-> Either AmbiguousNumber RawNumber
-> Maybe Integer
-> TextParser
     m
     (Decimal, AmountPrecision, Maybe DecimalMark,
      Maybe DigitGroupStyle)
interpretNumber (Int, Int)
numRegion Maybe AmountStyle
msuggestedStyle Either AmbiguousNumber RawNumber
ambiguousRawNum Maybe Integer
mExponent
        let s :: AmountStyle
s = AmountStyle
amountstyle{ascommodityside :: Side
ascommodityside=Side
R, ascommodityspaced :: Bool
ascommodityspaced=Bool
commodityspaced, asprecision :: AmountPrecision
asprecision=AmountPrecision
prec, asdecimalpoint :: Maybe DecimalMark
asdecimalpoint=Maybe DecimalMark
mdec, asdigitgroups :: Maybe DigitGroupStyle
asdigitgroups=Maybe DigitGroupStyle
mgrps}
        Amount -> JournalParser m Amount
forall (m :: * -> *) a. Monad m => a -> m a
return (Amount -> JournalParser m Amount)
-> Amount -> JournalParser m Amount
forall a b. (a -> b) -> a -> b
$ Amount
nullamt{acommodity :: Text
acommodity=Text
c, aquantity :: Decimal
aquantity=Decimal -> Decimal
sign Decimal
q, aismultiplier :: Bool
aismultiplier=Bool
mult, astyle :: AmountStyle
astyle=AmountStyle
s, aprice :: Maybe AmountPrice
aprice=Maybe AmountPrice
forall a. Maybe a
Nothing}
      -- no symbol amount
      Maybe (Bool, Text)
Nothing -> do
        -- look for a number style to use when parsing, based on
        -- these things we've already parsed, in this order of preference:
        Maybe AmountStyle
mdecmarkStyle   <- JournalParser m (Maybe AmountStyle)
forall (m :: * -> *). JournalParser m (Maybe AmountStyle)
getDecimalMarkStyle   -- a decimal-mark CSV rule
        Maybe AmountStyle
mcommodityStyle <- Text -> JournalParser m (Maybe AmountStyle)
forall (m :: * -> *). Text -> JournalParser m (Maybe AmountStyle)
getAmountStyle Text
""     -- a commodity directive for the no-symbol commodity
        Maybe AmountStyle
mdefaultStyle   <- JournalParser m (Maybe AmountStyle)
forall (m :: * -> *). JournalParser m (Maybe AmountStyle)
getDefaultAmountStyle -- a D default commodity directive
        -- XXX no-symbol amounts in periodic transaction rules and auto posting rules ? #1461
        let msuggestedStyle :: Maybe AmountStyle
msuggestedStyle = Maybe AmountStyle
mdecmarkStyle Maybe AmountStyle -> Maybe AmountStyle -> Maybe AmountStyle
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe AmountStyle
mcommodityStyle Maybe AmountStyle -> Maybe AmountStyle -> Maybe AmountStyle
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe AmountStyle
mdefaultStyle
        (Decimal
q,AmountPrecision
prec,Maybe DecimalMark
mdec,Maybe DigitGroupStyle
mgrps) <- ParsecT
  CustomErr
  Text
  m
  (Decimal, AmountPrecision, Maybe DecimalMark,
   Maybe DigitGroupStyle)
-> StateT
     Journal
     (ParsecT CustomErr Text m)
     (Decimal, AmountPrecision, Maybe DecimalMark,
      Maybe DigitGroupStyle)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ParsecT
   CustomErr
   Text
   m
   (Decimal, AmountPrecision, Maybe DecimalMark,
    Maybe DigitGroupStyle)
 -> StateT
      Journal
      (ParsecT CustomErr Text m)
      (Decimal, AmountPrecision, Maybe DecimalMark,
       Maybe DigitGroupStyle))
-> ParsecT
     CustomErr
     Text
     m
     (Decimal, AmountPrecision, Maybe DecimalMark,
      Maybe DigitGroupStyle)
-> StateT
     Journal
     (ParsecT CustomErr Text m)
     (Decimal, AmountPrecision, Maybe DecimalMark,
      Maybe DigitGroupStyle)
forall a b. (a -> b) -> a -> b
$ (Int, Int)
-> Maybe AmountStyle
-> Either AmbiguousNumber RawNumber
-> Maybe Integer
-> ParsecT
     CustomErr
     Text
     m
     (Decimal, AmountPrecision, Maybe DecimalMark,
      Maybe DigitGroupStyle)
forall (m :: * -> *).
(Int, Int)
-> Maybe AmountStyle
-> Either AmbiguousNumber RawNumber
-> Maybe Integer
-> TextParser
     m
     (Decimal, AmountPrecision, Maybe DecimalMark,
      Maybe DigitGroupStyle)
interpretNumber (Int, Int)
numRegion Maybe AmountStyle
msuggestedStyle Either AmbiguousNumber RawNumber
ambiguousRawNum Maybe Integer
mExponent
        -- if a default commodity has been set, apply it and its style to this amount
        -- (unless it's a multiplier in an automated posting)
        Maybe (Text, AmountStyle)
defcs <- JournalParser m (Maybe (Text, AmountStyle))
forall (m :: * -> *). JournalParser m (Maybe (Text, AmountStyle))
getDefaultCommodityAndStyle
        let (Text
c,AmountStyle
s) = case (Bool
mult, Maybe (Text, AmountStyle)
defcs) of
              (Bool
False, Just (Text
defc,AmountStyle
defs)) -> (Text
defc, AmountStyle
defs{asprecision :: AmountPrecision
asprecision=AmountPrecision -> AmountPrecision -> AmountPrecision
forall a. Ord a => a -> a -> a
max (AmountStyle -> AmountPrecision
asprecision AmountStyle
defs) AmountPrecision
prec})
              (Bool, Maybe (Text, AmountStyle))
_ -> (Text
"", AmountStyle
amountstyle{asprecision :: AmountPrecision
asprecision=AmountPrecision
prec, asdecimalpoint :: Maybe DecimalMark
asdecimalpoint=Maybe DecimalMark
mdec, asdigitgroups :: Maybe DigitGroupStyle
asdigitgroups=Maybe DigitGroupStyle
mgrps})
        Amount -> JournalParser m Amount
forall (m :: * -> *) a. Monad m => a -> m a
return (Amount -> JournalParser m Amount)
-> Amount -> JournalParser m Amount
forall a b. (a -> b) -> a -> b
$ Amount
nullamt{acommodity :: Text
acommodity=Text
c, aquantity :: Decimal
aquantity=Decimal -> Decimal
sign Decimal
q, aismultiplier :: Bool
aismultiplier=Bool
mult, astyle :: AmountStyle
astyle=AmountStyle
s, aprice :: Maybe AmountPrice
aprice=Maybe AmountPrice
forall a. Maybe a
Nothing}

  -- For reducing code duplication. Doesn't parse anything. Has the type
  -- of a parser only in order to throw parse errors (for convenience).
  interpretNumber
    :: (Int, Int) -- offsets
    -> Maybe AmountStyle
    -> Either AmbiguousNumber RawNumber
    -> Maybe Integer
    -> TextParser m (Quantity, AmountPrecision, Maybe Char, Maybe DigitGroupStyle)
  interpretNumber :: (Int, Int)
-> Maybe AmountStyle
-> Either AmbiguousNumber RawNumber
-> Maybe Integer
-> TextParser
     m
     (Decimal, AmountPrecision, Maybe DecimalMark,
      Maybe DigitGroupStyle)
interpretNumber (Int, Int)
posRegion Maybe AmountStyle
msuggestedStyle Either AmbiguousNumber RawNumber
ambiguousNum Maybe Integer
mExp =
    let rawNum :: RawNumber
rawNum = (AmbiguousNumber -> RawNumber)
-> (RawNumber -> RawNumber)
-> Either AmbiguousNumber RawNumber
-> RawNumber
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe AmountStyle -> AmbiguousNumber -> RawNumber
disambiguateNumber Maybe AmountStyle
msuggestedStyle) RawNumber -> RawNumber
forall a. a -> a
id Either AmbiguousNumber RawNumber
ambiguousNum
    in  case RawNumber
-> Maybe Integer
-> Either
     StorageFormat
     (Decimal, Word8, Maybe DecimalMark, Maybe DigitGroupStyle)
fromRawNumber RawNumber
rawNum Maybe Integer
mExp of
          Left StorageFormat
errMsg -> CustomErr
-> TextParser
     m
     (Decimal, AmountPrecision, Maybe DecimalMark,
      Maybe DigitGroupStyle)
forall e s (m :: * -> *) a. MonadParsec e s m => e -> m a
customFailure (CustomErr
 -> TextParser
      m
      (Decimal, AmountPrecision, Maybe DecimalMark,
       Maybe DigitGroupStyle))
-> CustomErr
-> TextParser
     m
     (Decimal, AmountPrecision, Maybe DecimalMark,
      Maybe DigitGroupStyle)
forall a b. (a -> b) -> a -> b
$
                           (Int -> Int -> StorageFormat -> CustomErr)
-> (Int, Int) -> StorageFormat -> CustomErr
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Int -> Int -> StorageFormat -> CustomErr
parseErrorAtRegion (Int, Int)
posRegion StorageFormat
errMsg
          Right (Decimal
q,Word8
p,Maybe DecimalMark
d,Maybe DigitGroupStyle
g) -> (Decimal, AmountPrecision, Maybe DecimalMark,
 Maybe DigitGroupStyle)
-> TextParser
     m
     (Decimal, AmountPrecision, Maybe DecimalMark,
      Maybe DigitGroupStyle)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Decimal
q, Word8 -> AmountPrecision
Precision Word8
p, Maybe DecimalMark
d, Maybe DigitGroupStyle
g)

-- | Parse an amount from a string, or get an error.
amountp' :: String -> Amount
amountp' :: StorageFormat -> Amount
amountp' StorageFormat
s =
  case Parsec CustomErr Text Amount
-> StorageFormat
-> Text
-> Either (ParseErrorBundle Text CustomErr) Amount
forall e s a.
Parsec e s a
-> StorageFormat -> s -> Either (ParseErrorBundle s e) a
runParser (StateT Journal (ParsecT CustomErr Text Identity) Amount
-> Journal -> Parsec CustomErr Text Amount
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (StateT Journal (ParsecT CustomErr Text Identity) Amount
forall (m :: * -> *). JournalParser m Amount
amountp StateT Journal (ParsecT CustomErr Text Identity) Amount
-> StateT Journal (ParsecT CustomErr Text Identity) ()
-> StateT Journal (ParsecT CustomErr Text Identity) Amount
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* StateT Journal (ParsecT CustomErr Text Identity) ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof) Journal
nulljournal) StorageFormat
"" (StorageFormat -> Text
T.pack StorageFormat
s) of
    Right Amount
amt -> Amount
amt
    Left ParseErrorBundle Text CustomErr
err  -> StorageFormat -> Amount
forall a. StorageFormat -> a
error' (StorageFormat -> Amount) -> StorageFormat -> Amount
forall a b. (a -> b) -> a -> b
$ ParseErrorBundle Text CustomErr -> StorageFormat
forall a. Show a => a -> StorageFormat
show ParseErrorBundle Text CustomErr
err  -- PARTIAL: XXX should throwError

-- | Parse a mixed amount from a string, or get an error.
mamountp' :: String -> MixedAmount
mamountp' :: StorageFormat -> MixedAmount
mamountp' = [Amount] -> MixedAmount
Mixed ([Amount] -> MixedAmount)
-> (StorageFormat -> [Amount]) -> StorageFormat -> MixedAmount
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Amount -> [Amount] -> [Amount]
forall a. a -> [a] -> [a]
:[]) (Amount -> [Amount])
-> (StorageFormat -> Amount) -> StorageFormat -> [Amount]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StorageFormat -> Amount
amountp'

-- | Parse a minus or plus sign followed by zero or more spaces,
-- or nothing, returning a function that negates or does nothing.
signp :: Num a => TextParser m (a -> a)
signp :: TextParser m (a -> a)
signp = ((Token Text -> ParsecT CustomErr Text m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ DecimalMark) =>
Token s -> m (Token s)
char DecimalMark
Token Text
'-' ParsecT CustomErr Text m DecimalMark
-> TextParser m (a -> a) -> TextParser m (a -> a)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (a -> a) -> TextParser m (a -> a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure a -> a
forall a. Num a => a -> a
negate TextParser m (a -> a)
-> TextParser m (a -> a) -> TextParser m (a -> a)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Token Text -> ParsecT CustomErr Text m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ DecimalMark) =>
Token s -> m (Token s)
char DecimalMark
Token Text
'+' ParsecT CustomErr Text m DecimalMark
-> TextParser m (a -> a) -> TextParser m (a -> a)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (a -> a) -> TextParser m (a -> a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure a -> a
forall a. a -> a
id) TextParser m (a -> a)
-> ParsecT CustomErr Text m () -> TextParser m (a -> a)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT CustomErr Text m ()
forall s (m :: * -> *).
(Stream s, Token s ~ DecimalMark) =>
ParsecT CustomErr s m ()
skipNonNewlineSpaces) TextParser m (a -> a)
-> TextParser m (a -> a) -> TextParser m (a -> a)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (a -> a) -> TextParser m (a -> a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure a -> a
forall a. a -> a
id

multiplierp :: TextParser m Bool
multiplierp :: TextParser m Bool
multiplierp = Bool -> TextParser m Bool -> TextParser m Bool
forall (m :: * -> *) a. Alternative m => a -> m a -> m a
option Bool
False (TextParser m Bool -> TextParser m Bool)
-> TextParser m Bool -> TextParser m Bool
forall a b. (a -> b) -> a -> b
$ Token Text -> ParsecT CustomErr Text m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ DecimalMark) =>
Token s -> m (Token s)
char DecimalMark
Token Text
'*' ParsecT CustomErr Text m DecimalMark
-> TextParser m Bool -> TextParser m Bool
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Bool -> TextParser m Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True

commoditysymbolp :: TextParser m CommoditySymbol
commoditysymbolp :: TextParser m Text
commoditysymbolp =
  TextParser m Text
forall (m :: * -> *). TextParser m Text
quotedcommoditysymbolp TextParser m Text -> TextParser m Text -> TextParser m Text
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> TextParser m Text
forall (m :: * -> *). TextParser m Text
simplecommoditysymbolp TextParser m Text -> StorageFormat -> TextParser m Text
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> StorageFormat -> m a
<?> StorageFormat
"commodity symbol"

quotedcommoditysymbolp :: TextParser m CommoditySymbol
quotedcommoditysymbolp :: TextParser m Text
quotedcommoditysymbolp =
  ParsecT CustomErr Text m DecimalMark
-> ParsecT CustomErr Text m DecimalMark
-> TextParser m Text
-> TextParser m Text
forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between (Token Text -> ParsecT CustomErr Text m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ DecimalMark) =>
Token s -> m (Token s)
char DecimalMark
Token Text
'"') (Token Text -> ParsecT CustomErr Text m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ DecimalMark) =>
Token s -> m (Token s)
char DecimalMark
Token Text
'"') (TextParser m Text -> TextParser m Text)
-> TextParser m Text -> TextParser m Text
forall a b. (a -> b) -> a -> b
$ Maybe StorageFormat
-> (Token Text -> Bool) -> ParsecT CustomErr Text m (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe StorageFormat -> (Token s -> Bool) -> m (Tokens s)
takeWhile1P Maybe StorageFormat
forall a. Maybe a
Nothing DecimalMark -> Bool
Token Text -> Bool
f
  where f :: DecimalMark -> Bool
f DecimalMark
c = DecimalMark
c DecimalMark -> DecimalMark -> Bool
forall a. Eq a => a -> a -> Bool
/= DecimalMark
';' Bool -> Bool -> Bool
&& DecimalMark
c DecimalMark -> DecimalMark -> Bool
forall a. Eq a => a -> a -> Bool
/= DecimalMark
'\n' Bool -> Bool -> Bool
&& DecimalMark
c DecimalMark -> DecimalMark -> Bool
forall a. Eq a => a -> a -> Bool
/= DecimalMark
'\"'

simplecommoditysymbolp :: TextParser m CommoditySymbol
simplecommoditysymbolp :: TextParser m Text
simplecommoditysymbolp = Maybe StorageFormat
-> (Token Text -> Bool) -> ParsecT CustomErr Text m (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe StorageFormat -> (Token s -> Bool) -> m (Tokens s)
takeWhile1P Maybe StorageFormat
forall a. Maybe a
Nothing (Bool -> Bool
not (Bool -> Bool) -> (DecimalMark -> Bool) -> DecimalMark -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DecimalMark -> Bool
isNonsimpleCommodityChar)

priceamountp :: Amount -> JournalParser m AmountPrice
priceamountp :: Amount -> JournalParser m AmountPrice
priceamountp Amount
baseAmt = StorageFormat
-> JournalParser m AmountPrice -> JournalParser m AmountPrice
forall e s (m :: * -> *) a.
MonadParsec e s m =>
StorageFormat -> m a -> m a
label StorageFormat
"transaction price" (JournalParser m AmountPrice -> JournalParser m AmountPrice)
-> JournalParser m AmountPrice -> JournalParser m AmountPrice
forall a b. (a -> b) -> a -> b
$ do
  -- https://www.ledger-cli.org/3.0/doc/ledger3.html#Virtual-posting-costs
  Bool
parenthesised <- Bool
-> StateT Journal (ParsecT CustomErr Text m) Bool
-> StateT Journal (ParsecT CustomErr Text m) Bool
forall (m :: * -> *) a. Alternative m => a -> m a -> m a
option Bool
False (StateT Journal (ParsecT CustomErr Text m) Bool
 -> StateT Journal (ParsecT CustomErr Text m) Bool)
-> StateT Journal (ParsecT CustomErr Text m) Bool
-> StateT Journal (ParsecT CustomErr Text m) Bool
forall a b. (a -> b) -> a -> b
$ Token Text
-> StateT Journal (ParsecT CustomErr Text m) (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ DecimalMark) =>
Token s -> m (Token s)
char DecimalMark
Token Text
'(' StateT Journal (ParsecT CustomErr Text m) DecimalMark
-> StateT Journal (ParsecT CustomErr Text m) Bool
-> StateT Journal (ParsecT CustomErr Text m) Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> StateT Journal (ParsecT CustomErr Text m) Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  Token Text
-> StateT Journal (ParsecT CustomErr Text m) (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ DecimalMark) =>
Token s -> m (Token s)
char DecimalMark
Token Text
'@'
  Bool
totalPrice <- Token Text
-> StateT Journal (ParsecT CustomErr Text m) (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ DecimalMark) =>
Token s -> m (Token s)
char DecimalMark
Token Text
'@' StateT Journal (ParsecT CustomErr Text m) DecimalMark
-> StateT Journal (ParsecT CustomErr Text m) Bool
-> StateT Journal (ParsecT CustomErr Text m) Bool
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Bool -> StateT Journal (ParsecT CustomErr Text m) Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True StateT Journal (ParsecT CustomErr Text m) Bool
-> StateT Journal (ParsecT CustomErr Text m) Bool
-> StateT Journal (ParsecT CustomErr Text m) Bool
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Bool -> StateT Journal (ParsecT CustomErr Text m) Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
  Bool
-> StateT Journal (ParsecT CustomErr Text m) ()
-> StateT Journal (ParsecT CustomErr Text m) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
parenthesised (StateT Journal (ParsecT CustomErr Text m) ()
 -> StateT Journal (ParsecT CustomErr Text m) ())
-> StateT Journal (ParsecT CustomErr Text m) ()
-> StateT Journal (ParsecT CustomErr Text m) ()
forall a b. (a -> b) -> a -> b
$ StateT Journal (ParsecT CustomErr Text m) DecimalMark
-> StateT Journal (ParsecT CustomErr Text m) ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (StateT Journal (ParsecT CustomErr Text m) DecimalMark
 -> StateT Journal (ParsecT CustomErr Text m) ())
-> StateT Journal (ParsecT CustomErr Text m) DecimalMark
-> StateT Journal (ParsecT CustomErr Text m) ()
forall a b. (a -> b) -> a -> b
$ Token Text
-> StateT Journal (ParsecT CustomErr Text m) (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ DecimalMark) =>
Token s -> m (Token s)
char DecimalMark
Token Text
')'

  ParsecT CustomErr Text m ()
-> StateT Journal (ParsecT CustomErr Text m) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ParsecT CustomErr Text m ()
forall s (m :: * -> *).
(Stream s, Token s ~ DecimalMark) =>
ParsecT CustomErr s m ()
skipNonNewlineSpaces
  Amount
priceAmount <- JournalParser m Amount
forall (m :: * -> *). JournalParser m Amount
amountwithoutpricep -- <?> "unpriced amount (specifying a price)"

  let amtsign' :: Decimal
amtsign' = Decimal -> Decimal
forall a. Num a => a -> a
signum (Decimal -> Decimal) -> Decimal -> Decimal
forall a b. (a -> b) -> a -> b
$ Amount -> Decimal
aquantity Amount
baseAmt
      amtsign :: Decimal
amtsign  = if Decimal
amtsign' Decimal -> Decimal -> Bool
forall a. Eq a => a -> a -> Bool
== Decimal
0 then Decimal
1 else Decimal
amtsign'

  AmountPrice -> JournalParser m AmountPrice
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AmountPrice -> JournalParser m AmountPrice)
-> AmountPrice -> JournalParser m AmountPrice
forall a b. (a -> b) -> a -> b
$ if Bool
totalPrice
            then Amount -> AmountPrice
TotalPrice Amount
priceAmount{aquantity :: Decimal
aquantity=Decimal
amtsign Decimal -> Decimal -> Decimal
forall a. Num a => a -> a -> a
* Amount -> Decimal
aquantity Amount
priceAmount}
            else Amount -> AmountPrice
UnitPrice  Amount
priceAmount


balanceassertionp :: JournalParser m BalanceAssertion
balanceassertionp :: JournalParser m BalanceAssertion
balanceassertionp = do
  GenericSourcePos
sourcepos <- SourcePos -> GenericSourcePos
genericSourcePos (SourcePos -> GenericSourcePos)
-> StateT Journal (ParsecT CustomErr Text m) SourcePos
-> StateT Journal (ParsecT CustomErr Text m) GenericSourcePos
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT CustomErr Text m SourcePos
-> StateT Journal (ParsecT CustomErr Text m) SourcePos
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ParsecT CustomErr Text m SourcePos
forall s e (m :: * -> *).
(TraversableStream s, MonadParsec e s m) =>
m SourcePos
getSourcePos
  Token Text
-> StateT Journal (ParsecT CustomErr Text m) (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ DecimalMark) =>
Token s -> m (Token s)
char DecimalMark
Token Text
'='
  Bool
istotal <- (Maybe DecimalMark -> Bool)
-> StateT Journal (ParsecT CustomErr Text m) (Maybe DecimalMark)
-> StateT Journal (ParsecT CustomErr Text m) Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe DecimalMark -> Bool
forall a. Maybe a -> Bool
isJust (StateT Journal (ParsecT CustomErr Text m) (Maybe DecimalMark)
 -> StateT Journal (ParsecT CustomErr Text m) Bool)
-> StateT Journal (ParsecT CustomErr Text m) (Maybe DecimalMark)
-> StateT Journal (ParsecT CustomErr Text m) Bool
forall a b. (a -> b) -> a -> b
$ StateT Journal (ParsecT CustomErr Text m) DecimalMark
-> StateT Journal (ParsecT CustomErr Text m) (Maybe DecimalMark)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (StateT Journal (ParsecT CustomErr Text m) DecimalMark
 -> StateT Journal (ParsecT CustomErr Text m) (Maybe DecimalMark))
-> StateT Journal (ParsecT CustomErr Text m) DecimalMark
-> StateT Journal (ParsecT CustomErr Text m) (Maybe DecimalMark)
forall a b. (a -> b) -> a -> b
$ StateT Journal (ParsecT CustomErr Text m) DecimalMark
-> StateT Journal (ParsecT CustomErr Text m) DecimalMark
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (StateT Journal (ParsecT CustomErr Text m) DecimalMark
 -> StateT Journal (ParsecT CustomErr Text m) DecimalMark)
-> StateT Journal (ParsecT CustomErr Text m) DecimalMark
-> StateT Journal (ParsecT CustomErr Text m) DecimalMark
forall a b. (a -> b) -> a -> b
$ Token Text
-> StateT Journal (ParsecT CustomErr Text m) (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ DecimalMark) =>
Token s -> m (Token s)
char DecimalMark
Token Text
'='
  Bool
isinclusive <- (Maybe DecimalMark -> Bool)
-> StateT Journal (ParsecT CustomErr Text m) (Maybe DecimalMark)
-> StateT Journal (ParsecT CustomErr Text m) Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe DecimalMark -> Bool
forall a. Maybe a -> Bool
isJust (StateT Journal (ParsecT CustomErr Text m) (Maybe DecimalMark)
 -> StateT Journal (ParsecT CustomErr Text m) Bool)
-> StateT Journal (ParsecT CustomErr Text m) (Maybe DecimalMark)
-> StateT Journal (ParsecT CustomErr Text m) Bool
forall a b. (a -> b) -> a -> b
$ StateT Journal (ParsecT CustomErr Text m) DecimalMark
-> StateT Journal (ParsecT CustomErr Text m) (Maybe DecimalMark)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (StateT Journal (ParsecT CustomErr Text m) DecimalMark
 -> StateT Journal (ParsecT CustomErr Text m) (Maybe DecimalMark))
-> StateT Journal (ParsecT CustomErr Text m) DecimalMark
-> StateT Journal (ParsecT CustomErr Text m) (Maybe DecimalMark)
forall a b. (a -> b) -> a -> b
$ StateT Journal (ParsecT CustomErr Text m) DecimalMark
-> StateT Journal (ParsecT CustomErr Text m) DecimalMark
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (StateT Journal (ParsecT CustomErr Text m) DecimalMark
 -> StateT Journal (ParsecT CustomErr Text m) DecimalMark)
-> StateT Journal (ParsecT CustomErr Text m) DecimalMark
-> StateT Journal (ParsecT CustomErr Text m) DecimalMark
forall a b. (a -> b) -> a -> b
$ Token Text
-> StateT Journal (ParsecT CustomErr Text m) (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ DecimalMark) =>
Token s -> m (Token s)
char DecimalMark
Token Text
'*'
  ParsecT CustomErr Text m ()
-> StateT Journal (ParsecT CustomErr Text m) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ParsecT CustomErr Text m ()
forall s (m :: * -> *).
(Stream s, Token s ~ DecimalMark) =>
ParsecT CustomErr s m ()
skipNonNewlineSpaces
  -- this amount can have a price; balance assertions ignore it,
  -- but balance assignments will use it
  Amount
a <- JournalParser m Amount
forall (m :: * -> *). JournalParser m Amount
amountpnolotpricesp JournalParser m Amount -> StorageFormat -> JournalParser m Amount
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> StorageFormat -> m a
<?> StorageFormat
"amount (for a balance assertion or assignment)"
  BalanceAssertion -> JournalParser m BalanceAssertion
forall (m :: * -> *) a. Monad m => a -> m a
return BalanceAssertion :: Amount -> Bool -> Bool -> GenericSourcePos -> BalanceAssertion
BalanceAssertion
    { baamount :: Amount
baamount    = Amount
a
    , batotal :: Bool
batotal     = Bool
istotal
    , bainclusive :: Bool
bainclusive = Bool
isinclusive
    , baposition :: GenericSourcePos
baposition  = GenericSourcePos
sourcepos
    }

-- Parse a Ledger-style fixed {=UNITPRICE} or non-fixed {UNITPRICE}
-- or fixed {{=TOTALPRICE}} or non-fixed {{TOTALPRICE}} lot price,
-- and ignore it.
-- https://www.ledger-cli.org/3.0/doc/ledger3.html#Fixing-Lot-Prices .
lotpricep :: JournalParser m ()
lotpricep :: JournalParser m ()
lotpricep = StorageFormat -> JournalParser m () -> JournalParser m ()
forall e s (m :: * -> *) a.
MonadParsec e s m =>
StorageFormat -> m a -> m a
label StorageFormat
"ledger-style lot price" (JournalParser m () -> JournalParser m ())
-> JournalParser m () -> JournalParser m ()
forall a b. (a -> b) -> a -> b
$ do
  Token Text
-> StateT Journal (ParsecT CustomErr Text m) (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ DecimalMark) =>
Token s -> m (Token s)
char DecimalMark
Token Text
'{'
  Bool
doublebrace <- Bool
-> StateT Journal (ParsecT CustomErr Text m) Bool
-> StateT Journal (ParsecT CustomErr Text m) Bool
forall (m :: * -> *) a. Alternative m => a -> m a -> m a
option Bool
False (StateT Journal (ParsecT CustomErr Text m) Bool
 -> StateT Journal (ParsecT CustomErr Text m) Bool)
-> StateT Journal (ParsecT CustomErr Text m) Bool
-> StateT Journal (ParsecT CustomErr Text m) Bool
forall a b. (a -> b) -> a -> b
$ Token Text
-> StateT Journal (ParsecT CustomErr Text m) (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ DecimalMark) =>
Token s -> m (Token s)
char DecimalMark
Token Text
'{' StateT Journal (ParsecT CustomErr Text m) DecimalMark
-> StateT Journal (ParsecT CustomErr Text m) Bool
-> StateT Journal (ParsecT CustomErr Text m) Bool
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> StateT Journal (ParsecT CustomErr Text m) Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  Bool
_fixed <- (Maybe DecimalMark -> Bool)
-> StateT Journal (ParsecT CustomErr Text m) (Maybe DecimalMark)
-> StateT Journal (ParsecT CustomErr Text m) Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Maybe DecimalMark -> Bool
forall a. Maybe a -> Bool
isJust (StateT Journal (ParsecT CustomErr Text m) (Maybe DecimalMark)
 -> StateT Journal (ParsecT CustomErr Text m) Bool)
-> StateT Journal (ParsecT CustomErr Text m) (Maybe DecimalMark)
-> StateT Journal (ParsecT CustomErr Text m) Bool
forall a b. (a -> b) -> a -> b
$ StateT Journal (ParsecT CustomErr Text m) DecimalMark
-> StateT Journal (ParsecT CustomErr Text m) (Maybe DecimalMark)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (StateT Journal (ParsecT CustomErr Text m) DecimalMark
 -> StateT Journal (ParsecT CustomErr Text m) (Maybe DecimalMark))
-> StateT Journal (ParsecT CustomErr Text m) DecimalMark
-> StateT Journal (ParsecT CustomErr Text m) (Maybe DecimalMark)
forall a b. (a -> b) -> a -> b
$ ParsecT CustomErr Text m () -> JournalParser m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ParsecT CustomErr Text m ()
forall s (m :: * -> *).
(Stream s, Token s ~ DecimalMark) =>
ParsecT CustomErr s m ()
skipNonNewlineSpaces JournalParser m ()
-> StateT Journal (ParsecT CustomErr Text m) DecimalMark
-> StateT Journal (ParsecT CustomErr Text m) DecimalMark
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Token Text
-> StateT Journal (ParsecT CustomErr Text m) (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ DecimalMark) =>
Token s -> m (Token s)
char DecimalMark
Token Text
'='
  ParsecT CustomErr Text m () -> JournalParser m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ParsecT CustomErr Text m ()
forall s (m :: * -> *).
(Stream s, Token s ~ DecimalMark) =>
ParsecT CustomErr s m ()
skipNonNewlineSpaces
  Amount
_a <- JournalParser m Amount
forall (m :: * -> *). JournalParser m Amount
amountwithoutpricep
  ParsecT CustomErr Text m () -> JournalParser m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ParsecT CustomErr Text m ()
forall s (m :: * -> *).
(Stream s, Token s ~ DecimalMark) =>
ParsecT CustomErr s m ()
skipNonNewlineSpaces
  Token Text
-> StateT Journal (ParsecT CustomErr Text m) (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ DecimalMark) =>
Token s -> m (Token s)
char DecimalMark
Token Text
'}'
  Bool -> JournalParser m () -> JournalParser m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
doublebrace) (JournalParser m () -> JournalParser m ())
-> JournalParser m () -> JournalParser m ()
forall a b. (a -> b) -> a -> b
$ StateT Journal (ParsecT CustomErr Text m) DecimalMark
-> JournalParser m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (StateT Journal (ParsecT CustomErr Text m) DecimalMark
 -> JournalParser m ())
-> StateT Journal (ParsecT CustomErr Text m) DecimalMark
-> JournalParser m ()
forall a b. (a -> b) -> a -> b
$ Token Text
-> StateT Journal (ParsecT CustomErr Text m) (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ DecimalMark) =>
Token s -> m (Token s)
char DecimalMark
Token Text
'}'
  () -> JournalParser m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- Parse a Ledger-style lot date [DATE], and ignore it.
-- https://www.ledger-cli.org/3.0/doc/ledger3.html#Fixing-Lot-Prices .
lotdatep :: JournalParser m ()
lotdatep :: JournalParser m ()
lotdatep = (do
  Token Text
-> StateT Journal (ParsecT CustomErr Text m) (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ DecimalMark) =>
Token s -> m (Token s)
char DecimalMark
Token Text
'['
  ParsecT CustomErr Text m () -> JournalParser m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ParsecT CustomErr Text m ()
forall s (m :: * -> *).
(Stream s, Token s ~ DecimalMark) =>
ParsecT CustomErr s m ()
skipNonNewlineSpaces
  Day
_d <- JournalParser m Day
forall (m :: * -> *). JournalParser m Day
datep
  ParsecT CustomErr Text m () -> JournalParser m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ParsecT CustomErr Text m ()
forall s (m :: * -> *).
(Stream s, Token s ~ DecimalMark) =>
ParsecT CustomErr s m ()
skipNonNewlineSpaces
  Token Text
-> StateT Journal (ParsecT CustomErr Text m) (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ DecimalMark) =>
Token s -> m (Token s)
char DecimalMark
Token Text
']'
  () -> JournalParser m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  ) JournalParser m () -> StorageFormat -> JournalParser m ()
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> StorageFormat -> m a
<?> StorageFormat
"ledger-style lot date"

-- | Parse a string representation of a number for its value and display
-- attributes.
--
-- Some international number formats are accepted, eg either period or comma
-- may be used for the decimal mark, and the other of these may be used for
-- separating digit groups in the integer part. See
-- http://en.wikipedia.org/wiki/Decimal_separator for more examples.
--
-- This returns: the parsed numeric value, the precision (number of digits
-- seen following the decimal mark), the decimal mark character used if any,
-- and the digit group style if any.
--
numberp :: Maybe AmountStyle -> TextParser m (Quantity, Word8, Maybe Char, Maybe DigitGroupStyle)
numberp :: Maybe AmountStyle
-> TextParser
     m (Decimal, Word8, Maybe DecimalMark, Maybe DigitGroupStyle)
numberp Maybe AmountStyle
suggestedStyle = StorageFormat
-> TextParser
     m (Decimal, Word8, Maybe DecimalMark, Maybe DigitGroupStyle)
-> TextParser
     m (Decimal, Word8, Maybe DecimalMark, Maybe DigitGroupStyle)
forall e s (m :: * -> *) a.
MonadParsec e s m =>
StorageFormat -> m a -> m a
label StorageFormat
"number" (TextParser
   m (Decimal, Word8, Maybe DecimalMark, Maybe DigitGroupStyle)
 -> TextParser
      m (Decimal, Word8, Maybe DecimalMark, Maybe DigitGroupStyle))
-> TextParser
     m (Decimal, Word8, Maybe DecimalMark, Maybe DigitGroupStyle)
-> TextParser
     m (Decimal, Word8, Maybe DecimalMark, Maybe DigitGroupStyle)
forall a b. (a -> b) -> a -> b
$ do
    -- a number is an optional sign followed by a sequence of digits possibly
    -- interspersed with periods, commas, or both
    -- dbgparse 0 "numberp"
    Decimal -> Decimal
sign <- TextParser m (Decimal -> Decimal)
forall a (m :: * -> *). Num a => TextParser m (a -> a)
signp
    RawNumber
rawNum <- (AmbiguousNumber -> RawNumber)
-> (RawNumber -> RawNumber)
-> Either AmbiguousNumber RawNumber
-> RawNumber
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe AmountStyle -> AmbiguousNumber -> RawNumber
disambiguateNumber Maybe AmountStyle
suggestedStyle) RawNumber -> RawNumber
forall a. a -> a
id (Either AmbiguousNumber RawNumber -> RawNumber)
-> ParsecT CustomErr Text m (Either AmbiguousNumber RawNumber)
-> ParsecT CustomErr Text m RawNumber
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT CustomErr Text m (Either AmbiguousNumber RawNumber)
forall (m :: * -> *).
TextParser m (Either AmbiguousNumber RawNumber)
rawnumberp
    Maybe Integer
mExp <- ParsecT CustomErr Text m Integer
-> ParsecT CustomErr Text m (Maybe Integer)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (ParsecT CustomErr Text m Integer
 -> ParsecT CustomErr Text m (Maybe Integer))
-> ParsecT CustomErr Text m Integer
-> ParsecT CustomErr Text m (Maybe Integer)
forall a b. (a -> b) -> a -> b
$ ParsecT CustomErr Text m Integer
-> ParsecT CustomErr Text m Integer
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (ParsecT CustomErr Text m Integer
 -> ParsecT CustomErr Text m Integer)
-> ParsecT CustomErr Text m Integer
-> ParsecT CustomErr Text m Integer
forall a b. (a -> b) -> a -> b
$ ParsecT CustomErr Text m Integer
forall (m :: * -> *). TextParser m Integer
exponentp
    StorageFormat -> Maybe AmountStyle -> Maybe AmountStyle
forall a. Show a => StorageFormat -> a -> a
dbg7 StorageFormat
"numberp suggestedStyle" Maybe AmountStyle
suggestedStyle Maybe AmountStyle
-> ParsecT CustomErr Text m () -> ParsecT CustomErr Text m ()
`seq` () -> ParsecT CustomErr Text m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    case StorageFormat
-> Either
     StorageFormat
     (Decimal, Word8, Maybe DecimalMark, Maybe DigitGroupStyle)
-> Either
     StorageFormat
     (Decimal, Word8, Maybe DecimalMark, Maybe DigitGroupStyle)
forall a. Show a => StorageFormat -> a -> a
dbg7 StorageFormat
"numberp quantity,precision,mdecimalpoint,mgrps"
           (Either
   StorageFormat
   (Decimal, Word8, Maybe DecimalMark, Maybe DigitGroupStyle)
 -> Either
      StorageFormat
      (Decimal, Word8, Maybe DecimalMark, Maybe DigitGroupStyle))
-> Either
     StorageFormat
     (Decimal, Word8, Maybe DecimalMark, Maybe DigitGroupStyle)
-> Either
     StorageFormat
     (Decimal, Word8, Maybe DecimalMark, Maybe DigitGroupStyle)
forall a b. (a -> b) -> a -> b
$ RawNumber
-> Maybe Integer
-> Either
     StorageFormat
     (Decimal, Word8, Maybe DecimalMark, Maybe DigitGroupStyle)
fromRawNumber RawNumber
rawNum Maybe Integer
mExp of
      Left StorageFormat
errMsg -> StorageFormat
-> TextParser
     m (Decimal, Word8, Maybe DecimalMark, Maybe DigitGroupStyle)
forall (m :: * -> *) a. MonadFail m => StorageFormat -> m a
Fail.fail StorageFormat
errMsg
      Right (Decimal
q, Word8
p, Maybe DecimalMark
d, Maybe DigitGroupStyle
g) -> (Decimal, Word8, Maybe DecimalMark, Maybe DigitGroupStyle)
-> TextParser
     m (Decimal, Word8, Maybe DecimalMark, Maybe DigitGroupStyle)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Decimal -> Decimal
sign Decimal
q, Word8
p, Maybe DecimalMark
d, Maybe DigitGroupStyle
g)

exponentp :: TextParser m Integer
exponentp :: TextParser m Integer
exponentp = Token Text -> ParsecT CustomErr Text m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ DecimalMark) =>
Token s -> m (Token s)
char' DecimalMark
Token Text
'e' ParsecT CustomErr Text m DecimalMark
-> ParsecT CustomErr Text m (Integer -> Integer)
-> ParsecT CustomErr Text m (Integer -> Integer)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT CustomErr Text m (Integer -> Integer)
forall a (m :: * -> *). Num a => TextParser m (a -> a)
signp ParsecT CustomErr Text m (Integer -> Integer)
-> TextParser m Integer -> TextParser m Integer
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TextParser m Integer
forall e s (m :: * -> *) a.
(MonadParsec e s m, Token s ~ DecimalMark, Num a) =>
m a
decimal TextParser m Integer -> StorageFormat -> TextParser m Integer
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> StorageFormat -> m a
<?> StorageFormat
"exponent"

-- | Interpret a raw number as a decimal number.
--
-- Returns:
-- - the decimal number
-- - the precision (number of digits after the decimal point)
-- - the decimal point character, if any
-- - the digit group style, if any (digit group character and sizes of digit groups)
fromRawNumber
  :: RawNumber
  -> Maybe Integer
  -> Either String
            (Quantity, Word8, Maybe Char, Maybe DigitGroupStyle)
fromRawNumber :: RawNumber
-> Maybe Integer
-> Either
     StorageFormat
     (Decimal, Word8, Maybe DecimalMark, Maybe DigitGroupStyle)
fromRawNumber (WithSeparators DecimalMark
_ [DigitGrp]
_ Maybe (DecimalMark, DigitGrp)
_) (Just Integer
_) =
    StorageFormat
-> Either
     StorageFormat
     (Decimal, Word8, Maybe DecimalMark, Maybe DigitGroupStyle)
forall a b. a -> Either a b
Left StorageFormat
"invalid number: digit separators and exponents may not be used together"
fromRawNumber RawNumber
raw Maybe Integer
mExp = do
    (Decimal
quantity, Word8
precision) <- Integer
-> DigitGrp -> DigitGrp -> Either StorageFormat (Decimal, Word8)
toQuantity (Integer -> Maybe Integer -> Integer
forall a. a -> Maybe a -> a
fromMaybe Integer
0 Maybe Integer
mExp) (RawNumber -> DigitGrp
digitGroup RawNumber
raw) (RawNumber -> DigitGrp
decimalGroup RawNumber
raw)
    (Decimal, Word8, Maybe DecimalMark, Maybe DigitGroupStyle)
-> Either
     StorageFormat
     (Decimal, Word8, Maybe DecimalMark, Maybe DigitGroupStyle)
forall (m :: * -> *) a. Monad m => a -> m a
return (Decimal
quantity, Word8
precision, RawNumber -> Maybe DecimalMark
mDecPt RawNumber
raw, RawNumber -> Maybe DigitGroupStyle
digitGroupStyle RawNumber
raw)
  where
    toQuantity :: Integer -> DigitGrp -> DigitGrp -> Either String (Quantity, Word8)
    toQuantity :: Integer
-> DigitGrp -> DigitGrp -> Either StorageFormat (Decimal, Word8)
toQuantity Integer
e DigitGrp
preDecimalGrp DigitGrp
postDecimalGrp
      | Integer
precision Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0   = (Decimal, Word8) -> Either StorageFormat (Decimal, Word8)
forall a b. b -> Either a b
Right (Word8 -> Integer -> Decimal
forall i. Word8 -> i -> DecimalRaw i
Decimal Word8
0 (Integer
digitGrpNum Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
10Integer -> Integer -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^(-Integer
precision)), Word8
0)
      | Integer
precision Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
256 = (Decimal, Word8) -> Either StorageFormat (Decimal, Word8)
forall a b. b -> Either a b
Right (Word8 -> Integer -> Decimal
forall i. Word8 -> i -> DecimalRaw i
Decimal Word8
precision8 Integer
digitGrpNum, Word8
precision8)
      | Bool
otherwise = StorageFormat -> Either StorageFormat (Decimal, Word8)
forall a b. a -> Either a b
Left StorageFormat
"invalid number: numbers with more than 255 decimal places are currently not supported"
      where
        digitGrpNum :: Integer
digitGrpNum = DigitGrp -> Integer
digitGroupNumber (DigitGrp -> Integer) -> DigitGrp -> Integer
forall a b. (a -> b) -> a -> b
$ DigitGrp
preDecimalGrp DigitGrp -> DigitGrp -> DigitGrp
forall a. Semigroup a => a -> a -> a
<> DigitGrp
postDecimalGrp
        precision :: Integer
precision   = Word -> Integer
forall a. Integral a => a -> Integer
toInteger (DigitGrp -> Word
digitGroupLength DigitGrp
postDecimalGrp) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
e
        precision8 :: Word8
precision8  = Integer -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
precision :: Word8

    mDecPt :: RawNumber -> Maybe DecimalMark
mDecPt (NoSeparators DigitGrp
_ Maybe (DecimalMark, DigitGrp)
mDecimals)           = (DecimalMark, DigitGrp) -> DecimalMark
forall a b. (a, b) -> a
fst ((DecimalMark, DigitGrp) -> DecimalMark)
-> Maybe (DecimalMark, DigitGrp) -> Maybe DecimalMark
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (DecimalMark, DigitGrp)
mDecimals
    mDecPt (WithSeparators DecimalMark
_ [DigitGrp]
_ Maybe (DecimalMark, DigitGrp)
mDecimals)       = (DecimalMark, DigitGrp) -> DecimalMark
forall a b. (a, b) -> a
fst ((DecimalMark, DigitGrp) -> DecimalMark)
-> Maybe (DecimalMark, DigitGrp) -> Maybe DecimalMark
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (DecimalMark, DigitGrp)
mDecimals
    decimalGroup :: RawNumber -> DigitGrp
decimalGroup (NoSeparators DigitGrp
_ Maybe (DecimalMark, DigitGrp)
mDecimals)     = DigitGrp
-> ((DecimalMark, DigitGrp) -> DigitGrp)
-> Maybe (DecimalMark, DigitGrp)
-> DigitGrp
forall b a. b -> (a -> b) -> Maybe a -> b
maybe DigitGrp
forall a. Monoid a => a
mempty (DecimalMark, DigitGrp) -> DigitGrp
forall a b. (a, b) -> b
snd Maybe (DecimalMark, DigitGrp)
mDecimals
    decimalGroup (WithSeparators DecimalMark
_ [DigitGrp]
_ Maybe (DecimalMark, DigitGrp)
mDecimals) = DigitGrp
-> ((DecimalMark, DigitGrp) -> DigitGrp)
-> Maybe (DecimalMark, DigitGrp)
-> DigitGrp
forall b a. b -> (a -> b) -> Maybe a -> b
maybe DigitGrp
forall a. Monoid a => a
mempty (DecimalMark, DigitGrp) -> DigitGrp
forall a b. (a, b) -> b
snd Maybe (DecimalMark, DigitGrp)
mDecimals
    digitGroup :: RawNumber -> DigitGrp
digitGroup (NoSeparators DigitGrp
digitGrp Maybe (DecimalMark, DigitGrp)
_)        = DigitGrp
digitGrp
    digitGroup (WithSeparators DecimalMark
_ [DigitGrp]
digitGrps Maybe (DecimalMark, DigitGrp)
_)   = [DigitGrp] -> DigitGrp
forall a. Monoid a => [a] -> a
mconcat [DigitGrp]
digitGrps
    digitGroupStyle :: RawNumber -> Maybe DigitGroupStyle
digitGroupStyle (NoSeparators DigitGrp
_ Maybe (DecimalMark, DigitGrp)
_)          = Maybe DigitGroupStyle
forall a. Maybe a
Nothing
    digitGroupStyle (WithSeparators DecimalMark
sep [DigitGrp]
grps Maybe (DecimalMark, DigitGrp)
_) = DigitGroupStyle -> Maybe DigitGroupStyle
forall a. a -> Maybe a
Just (DigitGroupStyle -> Maybe DigitGroupStyle)
-> ([Word8] -> DigitGroupStyle) -> [Word8] -> Maybe DigitGroupStyle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DecimalMark -> [Word8] -> DigitGroupStyle
DigitGroups DecimalMark
sep ([Word8] -> Maybe DigitGroupStyle)
-> [Word8] -> Maybe DigitGroupStyle
forall a b. (a -> b) -> a -> b
$ [DigitGrp] -> [Word8]
groupSizes [DigitGrp]
grps

    -- Outputs digit group sizes from least significant to most significant
    groupSizes :: [DigitGrp] -> [Word8]
    groupSizes :: [DigitGrp] -> [Word8]
groupSizes [DigitGrp]
digitGrps = [Word8] -> [Word8]
forall a. [a] -> [a]
reverse ([Word8] -> [Word8]) -> [Word8] -> [Word8]
forall a b. (a -> b) -> a -> b
$ case (DigitGrp -> Word8) -> [DigitGrp] -> [Word8]
forall a b. (a -> b) -> [a] -> [b]
map (Word -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word -> Word8) -> (DigitGrp -> Word) -> DigitGrp -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DigitGrp -> Word
digitGroupLength) [DigitGrp]
digitGrps of
      (Word8
a:Word8
b:[Word8]
cs) | Word8
a Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< Word8
b -> Word8
bWord8 -> [Word8] -> [Word8]
forall a. a -> [a] -> [a]
:[Word8]
cs
      [Word8]
gs               -> [Word8]
gs

disambiguateNumber :: Maybe AmountStyle -> AmbiguousNumber -> RawNumber
disambiguateNumber :: Maybe AmountStyle -> AmbiguousNumber -> RawNumber
disambiguateNumber Maybe AmountStyle
msuggestedStyle (AmbiguousNumber DigitGrp
grp1 DecimalMark
sep DigitGrp
grp2) =
  -- If present, use the suggested style to disambiguate;
  -- otherwise, assume that the separator is a decimal point where possible.
  if DecimalMark -> Bool
isDecimalMark DecimalMark
sep Bool -> Bool -> Bool
&&
     Bool -> (AmountStyle -> Bool) -> Maybe AmountStyle -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (DecimalMark
sep DecimalMark -> AmountStyle -> Bool
`isValidDecimalBy`) Maybe AmountStyle
msuggestedStyle
  then DigitGrp -> Maybe (DecimalMark, DigitGrp) -> RawNumber
NoSeparators DigitGrp
grp1 ((DecimalMark, DigitGrp) -> Maybe (DecimalMark, DigitGrp)
forall a. a -> Maybe a
Just (DecimalMark
sep, DigitGrp
grp2))
  else DecimalMark
-> [DigitGrp] -> Maybe (DecimalMark, DigitGrp) -> RawNumber
WithSeparators DecimalMark
sep [DigitGrp
grp1, DigitGrp
grp2] Maybe (DecimalMark, DigitGrp)
forall a. Maybe a
Nothing
  where
    isValidDecimalBy :: Char -> AmountStyle -> Bool
    isValidDecimalBy :: DecimalMark -> AmountStyle -> Bool
isValidDecimalBy DecimalMark
c = \case
      AmountStyle{asdecimalpoint :: AmountStyle -> Maybe DecimalMark
asdecimalpoint = Just DecimalMark
d} -> DecimalMark
d DecimalMark -> DecimalMark -> Bool
forall a. Eq a => a -> a -> Bool
== DecimalMark
c
      AmountStyle{asdigitgroups :: AmountStyle -> Maybe DigitGroupStyle
asdigitgroups = Just (DigitGroups DecimalMark
g [Word8]
_)} -> DecimalMark
g DecimalMark -> DecimalMark -> Bool
forall a. Eq a => a -> a -> Bool
/= DecimalMark
c
      AmountStyle{asprecision :: AmountStyle -> AmountPrecision
asprecision = Precision Word8
0} -> Bool
False
      AmountStyle
_ -> Bool
True

-- | Parse and interpret the structure of a number without external hints.
-- Numbers are digit strings, possibly separated into digit groups by one
-- of two types of separators. (1) Numbers may optionally have a decimal
-- mark, which may be either a period or comma. (2) Numbers may
-- optionally contain digit group marks, which must all be either a
-- period, a comma, or a space.
--
-- It is our task to deduce the characters used as decimal mark and
-- digit group mark, based on the allowed syntax. For instance, we
-- make use of the fact that a decimal mark can occur at most once and
-- must be to the right of all digit group marks.
--
-- >>> parseTest rawnumberp "1,234,567.89"
-- Right (WithSeparators ',' ["1","234","567"] (Just ('.',"89")))
-- >>> parseTest rawnumberp "1,000"
-- Left (AmbiguousNumber "1" ',' "000")
-- >>> parseTest rawnumberp "1 000"
-- Right (WithSeparators ' ' ["1","000"] Nothing)
--
rawnumberp :: TextParser m (Either AmbiguousNumber RawNumber)
rawnumberp :: TextParser m (Either AmbiguousNumber RawNumber)
rawnumberp = StorageFormat
-> TextParser m (Either AmbiguousNumber RawNumber)
-> TextParser m (Either AmbiguousNumber RawNumber)
forall e s (m :: * -> *) a.
MonadParsec e s m =>
StorageFormat -> m a -> m a
label StorageFormat
"number" (TextParser m (Either AmbiguousNumber RawNumber)
 -> TextParser m (Either AmbiguousNumber RawNumber))
-> TextParser m (Either AmbiguousNumber RawNumber)
-> TextParser m (Either AmbiguousNumber RawNumber)
forall a b. (a -> b) -> a -> b
$ do
  Either AmbiguousNumber RawNumber
rawNumber <- (RawNumber -> Either AmbiguousNumber RawNumber)
-> ParsecT CustomErr Text m RawNumber
-> TextParser m (Either AmbiguousNumber RawNumber)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RawNumber -> Either AmbiguousNumber RawNumber
forall a b. b -> Either a b
Right ParsecT CustomErr Text m RawNumber
forall (m :: * -> *). TextParser m RawNumber
leadingDecimalPt TextParser m (Either AmbiguousNumber RawNumber)
-> TextParser m (Either AmbiguousNumber RawNumber)
-> TextParser m (Either AmbiguousNumber RawNumber)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> TextParser m (Either AmbiguousNumber RawNumber)
forall (m :: * -> *).
TextParser m (Either AmbiguousNumber RawNumber)
leadingDigits

  -- Guard against mistyped numbers
  Maybe DecimalMark
mExtraDecimalSep <- ParsecT CustomErr Text m DecimalMark
-> ParsecT CustomErr Text m (Maybe DecimalMark)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (ParsecT CustomErr Text m DecimalMark
 -> ParsecT CustomErr Text m (Maybe DecimalMark))
-> ParsecT CustomErr Text m DecimalMark
-> ParsecT CustomErr Text m (Maybe DecimalMark)
forall a b. (a -> b) -> a -> b
$ ParsecT CustomErr Text m DecimalMark
-> ParsecT CustomErr Text m DecimalMark
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
lookAhead (ParsecT CustomErr Text m DecimalMark
 -> ParsecT CustomErr Text m DecimalMark)
-> ParsecT CustomErr Text m DecimalMark
-> ParsecT CustomErr Text m DecimalMark
forall a b. (a -> b) -> a -> b
$ (Token Text -> Bool) -> ParsecT CustomErr Text m (Token Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy DecimalMark -> Bool
Token Text -> Bool
isDecimalMark
  Bool -> ParsecT CustomErr Text m () -> ParsecT CustomErr Text m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe DecimalMark -> Bool
forall a. Maybe a -> Bool
isJust Maybe DecimalMark
mExtraDecimalSep) (ParsecT CustomErr Text m () -> ParsecT CustomErr Text m ())
-> ParsecT CustomErr Text m () -> ParsecT CustomErr Text m ()
forall a b. (a -> b) -> a -> b
$
    StorageFormat -> ParsecT CustomErr Text m ()
forall (m :: * -> *) a. MonadFail m => StorageFormat -> m a
Fail.fail StorageFormat
"invalid number (invalid use of separator)"

  Maybe Int
mExtraFragment <- ParsecT CustomErr Text m Int
-> ParsecT CustomErr Text m (Maybe Int)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (ParsecT CustomErr Text m Int
 -> ParsecT CustomErr Text m (Maybe Int))
-> ParsecT CustomErr Text m Int
-> ParsecT CustomErr Text m (Maybe Int)
forall a b. (a -> b) -> a -> b
$ ParsecT CustomErr Text m Int -> ParsecT CustomErr Text m Int
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
lookAhead (ParsecT CustomErr Text m Int -> ParsecT CustomErr Text m Int)
-> ParsecT CustomErr Text m Int -> ParsecT CustomErr Text m Int
forall a b. (a -> b) -> a -> b
$ ParsecT CustomErr Text m Int -> ParsecT CustomErr Text m Int
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (ParsecT CustomErr Text m Int -> ParsecT CustomErr Text m Int)
-> ParsecT CustomErr Text m Int -> ParsecT CustomErr Text m Int
forall a b. (a -> b) -> a -> b
$
    Token Text -> ParsecT CustomErr Text m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ DecimalMark) =>
Token s -> m (Token s)
char DecimalMark
Token Text
' ' ParsecT CustomErr Text m DecimalMark
-> ParsecT CustomErr Text m Int -> ParsecT CustomErr Text m Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT CustomErr Text m Int
forall e s (m :: * -> *). MonadParsec e s m => m Int
getOffset ParsecT CustomErr Text m Int
-> ParsecT CustomErr Text m DecimalMark
-> ParsecT CustomErr Text m Int
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT CustomErr Text m DecimalMark
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ DecimalMark) =>
m (Token s)
digitChar
  case Maybe Int
mExtraFragment of
    Just Int
off -> CustomErr -> ParsecT CustomErr Text m ()
forall e s (m :: * -> *) a. MonadParsec e s m => e -> m a
customFailure (CustomErr -> ParsecT CustomErr Text m ())
-> CustomErr -> ParsecT CustomErr Text m ()
forall a b. (a -> b) -> a -> b
$
                  Int -> StorageFormat -> CustomErr
parseErrorAt Int
off StorageFormat
"invalid number (excessive trailing digits)"
    Maybe Int
Nothing -> () -> ParsecT CustomErr Text m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

  Either AmbiguousNumber RawNumber
-> TextParser m (Either AmbiguousNumber RawNumber)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either AmbiguousNumber RawNumber
 -> TextParser m (Either AmbiguousNumber RawNumber))
-> Either AmbiguousNumber RawNumber
-> TextParser m (Either AmbiguousNumber RawNumber)
forall a b. (a -> b) -> a -> b
$ StorageFormat
-> Either AmbiguousNumber RawNumber
-> Either AmbiguousNumber RawNumber
forall a. Show a => StorageFormat -> a -> a
dbg7 StorageFormat
"rawnumberp" Either AmbiguousNumber RawNumber
rawNumber
  where

  leadingDecimalPt :: TextParser m RawNumber
  leadingDecimalPt :: TextParser m RawNumber
leadingDecimalPt = do
    DecimalMark
decPt <- (Token Text -> Bool) -> ParsecT CustomErr Text m (Token Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy DecimalMark -> Bool
Token Text -> Bool
isDecimalMark
    DigitGrp
decGrp <- TextParser m DigitGrp
forall (m :: * -> *). TextParser m DigitGrp
digitgroupp
    RawNumber -> TextParser m RawNumber
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RawNumber -> TextParser m RawNumber)
-> RawNumber -> TextParser m RawNumber
forall a b. (a -> b) -> a -> b
$ DigitGrp -> Maybe (DecimalMark, DigitGrp) -> RawNumber
NoSeparators DigitGrp
forall a. Monoid a => a
mempty ((DecimalMark, DigitGrp) -> Maybe (DecimalMark, DigitGrp)
forall a. a -> Maybe a
Just (DecimalMark
decPt, DigitGrp
decGrp))

  leadingDigits :: TextParser m (Either AmbiguousNumber RawNumber)
  leadingDigits :: TextParser m (Either AmbiguousNumber RawNumber)
leadingDigits = do
    DigitGrp
grp1 <- TextParser m DigitGrp
forall (m :: * -> *). TextParser m DigitGrp
digitgroupp
    DigitGrp -> TextParser m (Either AmbiguousNumber RawNumber)
forall (m :: * -> *).
DigitGrp -> TextParser m (Either AmbiguousNumber RawNumber)
withSeparators DigitGrp
grp1 TextParser m (Either AmbiguousNumber RawNumber)
-> TextParser m (Either AmbiguousNumber RawNumber)
-> TextParser m (Either AmbiguousNumber RawNumber)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (RawNumber -> Either AmbiguousNumber RawNumber)
-> ParsecT CustomErr Text m RawNumber
-> TextParser m (Either AmbiguousNumber RawNumber)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RawNumber -> Either AmbiguousNumber RawNumber
forall a b. b -> Either a b
Right (DigitGrp -> ParsecT CustomErr Text m RawNumber
forall (m :: * -> *). DigitGrp -> TextParser m RawNumber
trailingDecimalPt DigitGrp
grp1)
                        TextParser m (Either AmbiguousNumber RawNumber)
-> TextParser m (Either AmbiguousNumber RawNumber)
-> TextParser m (Either AmbiguousNumber RawNumber)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Either AmbiguousNumber RawNumber
-> TextParser m (Either AmbiguousNumber RawNumber)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RawNumber -> Either AmbiguousNumber RawNumber
forall a b. b -> Either a b
Right (RawNumber -> Either AmbiguousNumber RawNumber)
-> RawNumber -> Either AmbiguousNumber RawNumber
forall a b. (a -> b) -> a -> b
$ DigitGrp -> Maybe (DecimalMark, DigitGrp) -> RawNumber
NoSeparators DigitGrp
grp1 Maybe (DecimalMark, DigitGrp)
forall a. Maybe a
Nothing)

  withSeparators :: DigitGrp -> TextParser m (Either AmbiguousNumber RawNumber)
  withSeparators :: DigitGrp -> TextParser m (Either AmbiguousNumber RawNumber)
withSeparators DigitGrp
grp1 = do
    (DecimalMark
sep, DigitGrp
grp2) <- ParsecT CustomErr Text m (DecimalMark, DigitGrp)
-> ParsecT CustomErr Text m (DecimalMark, DigitGrp)
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (ParsecT CustomErr Text m (DecimalMark, DigitGrp)
 -> ParsecT CustomErr Text m (DecimalMark, DigitGrp))
-> ParsecT CustomErr Text m (DecimalMark, DigitGrp)
-> ParsecT CustomErr Text m (DecimalMark, DigitGrp)
forall a b. (a -> b) -> a -> b
$ (,) (DecimalMark -> DigitGrp -> (DecimalMark, DigitGrp))
-> ParsecT CustomErr Text m DecimalMark
-> ParsecT CustomErr Text m (DigitGrp -> (DecimalMark, DigitGrp))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Token Text -> Bool) -> ParsecT CustomErr Text m (Token Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy DecimalMark -> Bool
Token Text -> Bool
isDigitSeparatorChar ParsecT CustomErr Text m (DigitGrp -> (DecimalMark, DigitGrp))
-> ParsecT CustomErr Text m DigitGrp
-> ParsecT CustomErr Text m (DecimalMark, DigitGrp)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT CustomErr Text m DigitGrp
forall (m :: * -> *). TextParser m DigitGrp
digitgroupp
    [DigitGrp]
grps <- ParsecT CustomErr Text m DigitGrp
-> ParsecT CustomErr Text m [DigitGrp]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many (ParsecT CustomErr Text m DigitGrp
 -> ParsecT CustomErr Text m [DigitGrp])
-> ParsecT CustomErr Text m DigitGrp
-> ParsecT CustomErr Text m [DigitGrp]
forall a b. (a -> b) -> a -> b
$ ParsecT CustomErr Text m DigitGrp
-> ParsecT CustomErr Text m DigitGrp
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (ParsecT CustomErr Text m DigitGrp
 -> ParsecT CustomErr Text m DigitGrp)
-> ParsecT CustomErr Text m DigitGrp
-> ParsecT CustomErr Text m DigitGrp
forall a b. (a -> b) -> a -> b
$ Token Text -> ParsecT CustomErr Text m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ DecimalMark) =>
Token s -> m (Token s)
char DecimalMark
Token Text
sep ParsecT CustomErr Text m DecimalMark
-> ParsecT CustomErr Text m DigitGrp
-> ParsecT CustomErr Text m DigitGrp
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT CustomErr Text m DigitGrp
forall (m :: * -> *). TextParser m DigitGrp
digitgroupp

    let digitGroups :: [DigitGrp]
digitGroups = DigitGrp
grp1 DigitGrp -> [DigitGrp] -> [DigitGrp]
forall a. a -> [a] -> [a]
: DigitGrp
grp2 DigitGrp -> [DigitGrp] -> [DigitGrp]
forall a. a -> [a] -> [a]
: [DigitGrp]
grps
    (RawNumber -> Either AmbiguousNumber RawNumber)
-> ParsecT CustomErr Text m RawNumber
-> TextParser m (Either AmbiguousNumber RawNumber)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RawNumber -> Either AmbiguousNumber RawNumber
forall a b. b -> Either a b
Right (DecimalMark -> [DigitGrp] -> ParsecT CustomErr Text m RawNumber
forall (m :: * -> *).
DecimalMark -> [DigitGrp] -> TextParser m RawNumber
withDecimalPt DecimalMark
sep [DigitGrp]
digitGroups)
      TextParser m (Either AmbiguousNumber RawNumber)
-> TextParser m (Either AmbiguousNumber RawNumber)
-> TextParser m (Either AmbiguousNumber RawNumber)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Either AmbiguousNumber RawNumber
-> TextParser m (Either AmbiguousNumber RawNumber)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DigitGrp
-> DecimalMark
-> DigitGrp
-> [DigitGrp]
-> Either AmbiguousNumber RawNumber
withoutDecimalPt DigitGrp
grp1 DecimalMark
sep DigitGrp
grp2 [DigitGrp]
grps)

  withDecimalPt :: Char -> [DigitGrp] -> TextParser m RawNumber
  withDecimalPt :: DecimalMark -> [DigitGrp] -> TextParser m RawNumber
withDecimalPt DecimalMark
digitSep [DigitGrp]
digitGroups = do
    DecimalMark
decPt <- (Token Text -> Bool) -> ParsecT CustomErr Text m (Token Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy ((Token Text -> Bool) -> ParsecT CustomErr Text m (Token Text))
-> (Token Text -> Bool) -> ParsecT CustomErr Text m (Token Text)
forall a b. (a -> b) -> a -> b
$ \Token Text
c -> DecimalMark -> Bool
isDecimalMark DecimalMark
Token Text
c Bool -> Bool -> Bool
&& DecimalMark
Token Text
c DecimalMark -> DecimalMark -> Bool
forall a. Eq a => a -> a -> Bool
/= DecimalMark
digitSep
    DigitGrp
decDigitGrp <- DigitGrp
-> ParsecT CustomErr Text m DigitGrp
-> ParsecT CustomErr Text m DigitGrp
forall (m :: * -> *) a. Alternative m => a -> m a -> m a
option DigitGrp
forall a. Monoid a => a
mempty ParsecT CustomErr Text m DigitGrp
forall (m :: * -> *). TextParser m DigitGrp
digitgroupp

    RawNumber -> TextParser m RawNumber
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RawNumber -> TextParser m RawNumber)
-> RawNumber -> TextParser m RawNumber
forall a b. (a -> b) -> a -> b
$ DecimalMark
-> [DigitGrp] -> Maybe (DecimalMark, DigitGrp) -> RawNumber
WithSeparators DecimalMark
digitSep [DigitGrp]
digitGroups ((DecimalMark, DigitGrp) -> Maybe (DecimalMark, DigitGrp)
forall a. a -> Maybe a
Just (DecimalMark
decPt, DigitGrp
decDigitGrp))

  withoutDecimalPt
    :: DigitGrp
    -> Char
    -> DigitGrp
    -> [DigitGrp]
    -> Either AmbiguousNumber RawNumber
  withoutDecimalPt :: DigitGrp
-> DecimalMark
-> DigitGrp
-> [DigitGrp]
-> Either AmbiguousNumber RawNumber
withoutDecimalPt DigitGrp
grp1 DecimalMark
sep DigitGrp
grp2 [DigitGrp]
grps
    | [DigitGrp] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [DigitGrp]
grps Bool -> Bool -> Bool
&& DecimalMark -> Bool
isDecimalMark DecimalMark
sep =
        AmbiguousNumber -> Either AmbiguousNumber RawNumber
forall a b. a -> Either a b
Left (AmbiguousNumber -> Either AmbiguousNumber RawNumber)
-> AmbiguousNumber -> Either AmbiguousNumber RawNumber
forall a b. (a -> b) -> a -> b
$ DigitGrp -> DecimalMark -> DigitGrp -> AmbiguousNumber
AmbiguousNumber DigitGrp
grp1 DecimalMark
sep DigitGrp
grp2
    | Bool
otherwise = RawNumber -> Either AmbiguousNumber RawNumber
forall a b. b -> Either a b
Right (RawNumber -> Either AmbiguousNumber RawNumber)
-> RawNumber -> Either AmbiguousNumber RawNumber
forall a b. (a -> b) -> a -> b
$ DecimalMark
-> [DigitGrp] -> Maybe (DecimalMark, DigitGrp) -> RawNumber
WithSeparators DecimalMark
sep (DigitGrp
grp1DigitGrp -> [DigitGrp] -> [DigitGrp]
forall a. a -> [a] -> [a]
:DigitGrp
grp2DigitGrp -> [DigitGrp] -> [DigitGrp]
forall a. a -> [a] -> [a]
:[DigitGrp]
grps) Maybe (DecimalMark, DigitGrp)
forall a. Maybe a
Nothing

  trailingDecimalPt :: DigitGrp -> TextParser m RawNumber
  trailingDecimalPt :: DigitGrp -> TextParser m RawNumber
trailingDecimalPt DigitGrp
grp1 = do
    DecimalMark
decPt <- (Token Text -> Bool) -> ParsecT CustomErr Text m (Token Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy DecimalMark -> Bool
Token Text -> Bool
isDecimalMark
    RawNumber -> TextParser m RawNumber
forall (f :: * -> *) a. Applicative f => a -> f a
pure (RawNumber -> TextParser m RawNumber)
-> RawNumber -> TextParser m RawNumber
forall a b. (a -> b) -> a -> b
$ DigitGrp -> Maybe (DecimalMark, DigitGrp) -> RawNumber
NoSeparators DigitGrp
grp1 ((DecimalMark, DigitGrp) -> Maybe (DecimalMark, DigitGrp)
forall a. a -> Maybe a
Just (DecimalMark
decPt, DigitGrp
forall a. Monoid a => a
mempty))

isDigitSeparatorChar :: Char -> Bool
isDigitSeparatorChar :: DecimalMark -> Bool
isDigitSeparatorChar DecimalMark
c = DecimalMark -> Bool
isDecimalMark DecimalMark
c Bool -> Bool -> Bool
|| DecimalMark
c DecimalMark -> DecimalMark -> Bool
forall a. Eq a => a -> a -> Bool
== DecimalMark
' '

-- | Some kinds of number literal we might parse.
data RawNumber
  = NoSeparators   DigitGrp (Maybe (Char, DigitGrp))
    -- ^ A number with no digit group marks (eg 100),
    --   or with a leading or trailing comma or period
    --   which (apparently) we interpret as a decimal mark (like 100. or .100)
  | WithSeparators Char [DigitGrp] (Maybe (Char, DigitGrp))
    -- ^ A number with identifiable digit group marks
    --   (eg 1,000,000 or 1,000.50 or 1 000)
  deriving (Int -> RawNumber -> ShowS
[RawNumber] -> ShowS
RawNumber -> StorageFormat
(Int -> RawNumber -> ShowS)
-> (RawNumber -> StorageFormat)
-> ([RawNumber] -> ShowS)
-> Show RawNumber
forall a.
(Int -> a -> ShowS)
-> (a -> StorageFormat) -> ([a] -> ShowS) -> Show a
showList :: [RawNumber] -> ShowS
$cshowList :: [RawNumber] -> ShowS
show :: RawNumber -> StorageFormat
$cshow :: RawNumber -> StorageFormat
showsPrec :: Int -> RawNumber -> ShowS
$cshowsPrec :: Int -> RawNumber -> ShowS
Show, RawNumber -> RawNumber -> Bool
(RawNumber -> RawNumber -> Bool)
-> (RawNumber -> RawNumber -> Bool) -> Eq RawNumber
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RawNumber -> RawNumber -> Bool
$c/= :: RawNumber -> RawNumber -> Bool
== :: RawNumber -> RawNumber -> Bool
$c== :: RawNumber -> RawNumber -> Bool
Eq)

-- | Another kind of number literal: this one contains either a digit
-- group separator or a decimal mark, we're not sure which (eg 1,000 or 100.50).
data AmbiguousNumber = AmbiguousNumber DigitGrp Char DigitGrp
  deriving (Int -> AmbiguousNumber -> ShowS
[AmbiguousNumber] -> ShowS
AmbiguousNumber -> StorageFormat
(Int -> AmbiguousNumber -> ShowS)
-> (AmbiguousNumber -> StorageFormat)
-> ([AmbiguousNumber] -> ShowS)
-> Show AmbiguousNumber
forall a.
(Int -> a -> ShowS)
-> (a -> StorageFormat) -> ([a] -> ShowS) -> Show a
showList :: [AmbiguousNumber] -> ShowS
$cshowList :: [AmbiguousNumber] -> ShowS
show :: AmbiguousNumber -> StorageFormat
$cshow :: AmbiguousNumber -> StorageFormat
showsPrec :: Int -> AmbiguousNumber -> ShowS
$cshowsPrec :: Int -> AmbiguousNumber -> ShowS
Show, AmbiguousNumber -> AmbiguousNumber -> Bool
(AmbiguousNumber -> AmbiguousNumber -> Bool)
-> (AmbiguousNumber -> AmbiguousNumber -> Bool)
-> Eq AmbiguousNumber
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AmbiguousNumber -> AmbiguousNumber -> Bool
$c/= :: AmbiguousNumber -> AmbiguousNumber -> Bool
== :: AmbiguousNumber -> AmbiguousNumber -> Bool
$c== :: AmbiguousNumber -> AmbiguousNumber -> Bool
Eq)

-- | Description of a single digit group in a number literal.
-- "Thousands" is one well known digit grouping, but there are others.
data DigitGrp = DigitGrp {
  DigitGrp -> Word
digitGroupLength :: !Word,    -- ^ The number of digits in this group.
                                -- This is Word to avoid the need to do overflow
                                -- checking for the Semigroup instance of DigitGrp.
  DigitGrp -> Integer
digitGroupNumber :: !Integer  -- ^ The natural number formed by this group's digits. This should always be positive.
} deriving (DigitGrp -> DigitGrp -> Bool
(DigitGrp -> DigitGrp -> Bool)
-> (DigitGrp -> DigitGrp -> Bool) -> Eq DigitGrp
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DigitGrp -> DigitGrp -> Bool
$c/= :: DigitGrp -> DigitGrp -> Bool
== :: DigitGrp -> DigitGrp -> Bool
$c== :: DigitGrp -> DigitGrp -> Bool
Eq)

-- | A custom show instance, showing digit groups as the parser saw them.
instance Show DigitGrp where
  show :: DigitGrp -> StorageFormat
show (DigitGrp Word
len Integer
num) = StorageFormat
"\"" StorageFormat -> ShowS
forall a. [a] -> [a] -> [a]
++ StorageFormat
padding StorageFormat -> ShowS
forall a. [a] -> [a] -> [a]
++ StorageFormat
numStr StorageFormat -> ShowS
forall a. [a] -> [a] -> [a]
++ StorageFormat
"\""
    where numStr :: StorageFormat
numStr = Integer -> StorageFormat
forall a. Show a => a -> StorageFormat
show Integer
num
          padding :: StorageFormat
padding = Integer -> DecimalMark -> StorageFormat
forall i a. Integral i => i -> a -> [a]
genericReplicate (Word -> Integer
forall a. Integral a => a -> Integer
toInteger Word
len Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Int -> Integer
forall a. Integral a => a -> Integer
toInteger (StorageFormat -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length StorageFormat
numStr)) DecimalMark
'0'

instance Sem.Semigroup DigitGrp where
  DigitGrp Word
l1 Integer
n1 <> :: DigitGrp -> DigitGrp -> DigitGrp
<> DigitGrp Word
l2 Integer
n2 = Word -> Integer -> DigitGrp
DigitGrp (Word
l1 Word -> Word -> Word
forall a. Num a => a -> a -> a
+ Word
l2) (Integer
n1 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
10Integer -> Word -> Integer
forall a b. (Num a, Integral b) => a -> b -> a
^Word
l2 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
n2)

instance Monoid DigitGrp where
  mempty :: DigitGrp
mempty = Word -> Integer -> DigitGrp
DigitGrp Word
0 Integer
0
  mappend :: DigitGrp -> DigitGrp -> DigitGrp
mappend = DigitGrp -> DigitGrp -> DigitGrp
forall a. Semigroup a => a -> a -> a
(Sem.<>)

digitgroupp :: TextParser m DigitGrp
digitgroupp :: TextParser m DigitGrp
digitgroupp = StorageFormat -> TextParser m DigitGrp -> TextParser m DigitGrp
forall e s (m :: * -> *) a.
MonadParsec e s m =>
StorageFormat -> m a -> m a
label StorageFormat
"digits"
            (TextParser m DigitGrp -> TextParser m DigitGrp)
-> TextParser m DigitGrp -> TextParser m DigitGrp
forall a b. (a -> b) -> a -> b
$ Text -> DigitGrp
makeGroup (Text -> DigitGrp)
-> ParsecT CustomErr Text m Text -> TextParser m DigitGrp
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe StorageFormat
-> (Token Text -> Bool) -> ParsecT CustomErr Text m (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe StorageFormat -> (Token s -> Bool) -> m (Tokens s)
takeWhile1P (StorageFormat -> Maybe StorageFormat
forall a. a -> Maybe a
Just StorageFormat
"digit") DecimalMark -> Bool
Token Text -> Bool
isDigit
  where
    makeGroup :: Text -> DigitGrp
makeGroup = (Word -> Integer -> DigitGrp) -> (Word, Integer) -> DigitGrp
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Word -> Integer -> DigitGrp
DigitGrp ((Word, Integer) -> DigitGrp)
-> (Text -> (Word, Integer)) -> Text -> DigitGrp
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Word, Integer) -> DecimalMark -> (Word, Integer))
-> (Word, Integer) -> Text -> (Word, Integer)
forall a. (a -> DecimalMark -> a) -> a -> Text -> a
T.foldl' (Word, Integer) -> DecimalMark -> (Word, Integer)
forall a b. (Num a, Num b) => (a, b) -> DecimalMark -> (a, b)
step (Word
0, Integer
0)
    step :: (a, b) -> DecimalMark -> (a, b)
step (!a
l, !b
a) DecimalMark
c = (a
la -> a -> a
forall a. Num a => a -> a -> a
+a
1, b
ab -> b -> b
forall a. Num a => a -> a -> a
*b
10 b -> b -> b
forall a. Num a => a -> a -> a
+ Int -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral (DecimalMark -> Int
digitToInt DecimalMark
c))

--- *** comments

multilinecommentp :: TextParser m ()
multilinecommentp :: TextParser m ()
multilinecommentp = TextParser m ()
startComment TextParser m () -> TextParser m () -> TextParser m ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> TextParser m ()
anyLine TextParser m () -> TextParser m () -> TextParser m ()
forall (m :: * -> *) a end. MonadPlus m => m a -> m end -> m end
`skipManyTill` TextParser m ()
endComment
  where
    startComment :: TextParser m ()
startComment = Tokens Text -> ParsecT CustomErr Text m (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"comment" ParsecT CustomErr Text m Text -> TextParser m () -> TextParser m ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> TextParser m ()
forall (m :: * -> *). TextParser m ()
trailingSpaces
    endComment :: TextParser m ()
endComment = TextParser m ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof TextParser m () -> TextParser m () -> TextParser m ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Tokens Text -> ParsecT CustomErr Text m (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"end comment" ParsecT CustomErr Text m Text -> TextParser m () -> TextParser m ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> TextParser m ()
forall (m :: * -> *). TextParser m ()
trailingSpaces

    trailingSpaces :: ParsecT CustomErr Text m ()
trailingSpaces = ParsecT CustomErr Text m ()
forall s (m :: * -> *).
(Stream s, Token s ~ DecimalMark) =>
ParsecT CustomErr s m ()
skipNonNewlineSpaces ParsecT CustomErr Text m ()
-> ParsecT CustomErr Text m DecimalMark
-> ParsecT CustomErr Text m ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT CustomErr Text m DecimalMark
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ DecimalMark) =>
m (Token s)
newline
    anyLine :: TextParser m ()
anyLine = ParsecT CustomErr Text m DecimalMark -> TextParser m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT CustomErr Text m DecimalMark -> TextParser m ())
-> ParsecT CustomErr Text m DecimalMark -> TextParser m ()
forall a b. (a -> b) -> a -> b
$ Maybe StorageFormat
-> (Token Text -> Bool) -> ParsecT CustomErr Text m (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe StorageFormat -> (Token s -> Bool) -> m (Tokens s)
takeWhileP Maybe StorageFormat
forall a. Maybe a
Nothing (\Token Text
c -> DecimalMark
Token Text
c DecimalMark -> DecimalMark -> Bool
forall a. Eq a => a -> a -> Bool
/= DecimalMark
'\n') ParsecT CustomErr Text m (Tokens Text)
-> ParsecT CustomErr Text m DecimalMark
-> ParsecT CustomErr Text m DecimalMark
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT CustomErr Text m DecimalMark
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ DecimalMark) =>
m (Token s)
newline

{-# INLINABLE multilinecommentp #-}

-- | A blank or comment line in journal format: a line that's empty or
-- containing only whitespace or whose first non-whitespace character
-- is semicolon, hash, or star.
emptyorcommentlinep :: TextParser m ()
emptyorcommentlinep :: TextParser m ()
emptyorcommentlinep = do
  TextParser m ()
forall s (m :: * -> *).
(Stream s, Token s ~ DecimalMark) =>
ParsecT CustomErr s m ()
skipNonNewlineSpaces
  TextParser m ()
forall (m :: * -> *). TextParser m ()
skiplinecommentp TextParser m () -> TextParser m () -> TextParser m ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT CustomErr Text m DecimalMark -> TextParser m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ParsecT CustomErr Text m DecimalMark
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ DecimalMark) =>
m (Token s)
newline
  where
    skiplinecommentp :: TextParser m ()
    skiplinecommentp :: TextParser m ()
skiplinecommentp = do
      (Token Text -> Bool) -> ParsecT CustomErr Text m (Token Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
(Token s -> Bool) -> m (Token s)
satisfy ((Token Text -> Bool) -> ParsecT CustomErr Text m (Token Text))
-> (Token Text -> Bool) -> ParsecT CustomErr Text m (Token Text)
forall a b. (a -> b) -> a -> b
$ \Token Text
c -> DecimalMark
Token Text
c DecimalMark -> DecimalMark -> Bool
forall a. Eq a => a -> a -> Bool
== DecimalMark
';' Bool -> Bool -> Bool
|| DecimalMark
Token Text
c DecimalMark -> DecimalMark -> Bool
forall a. Eq a => a -> a -> Bool
== DecimalMark
'#' Bool -> Bool -> Bool
|| DecimalMark
Token Text
c DecimalMark -> DecimalMark -> Bool
forall a. Eq a => a -> a -> Bool
== DecimalMark
'*'
      ParsecT CustomErr Text m Text -> TextParser m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT CustomErr Text m Text -> TextParser m ())
-> ParsecT CustomErr Text m Text -> TextParser m ()
forall a b. (a -> b) -> a -> b
$ Maybe StorageFormat
-> (Token Text -> Bool) -> ParsecT CustomErr Text m (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe StorageFormat -> (Token s -> Bool) -> m (Tokens s)
takeWhileP Maybe StorageFormat
forall a. Maybe a
Nothing (\Token Text
c -> DecimalMark
Token Text
c DecimalMark -> DecimalMark -> Bool
forall a. Eq a => a -> a -> Bool
/= DecimalMark
'\n')
      ParsecT CustomErr Text m DecimalMark
-> ParsecT CustomErr Text m (Maybe DecimalMark)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional ParsecT CustomErr Text m DecimalMark
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ DecimalMark) =>
m (Token s)
newline
      () -> TextParser m ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

{-# INLINABLE emptyorcommentlinep #-}

-- A parser combinator for parsing (possibly multiline) comments
-- following journal items.
--
-- Several journal items may be followed by comments, which begin with
-- semicolons and extend to the end of the line. Such comments may span
-- multiple lines, but comment lines below the journal item must be
-- preceded by leading whitespace.
--
-- This parser combinator accepts a parser that consumes all input up
-- until the next newline. This parser should extract the "content" from
-- comments. The resulting parser returns this content plus the raw text
-- of the comment itself.
--
-- See followingcommentp for tests.
--
followingcommentp' :: (Monoid a, Show a) => TextParser m a -> TextParser m (Text, a)
followingcommentp' :: TextParser m a -> TextParser m (Text, a)
followingcommentp' TextParser m a
contentp = do
  ParsecT CustomErr Text m ()
forall s (m :: * -> *).
(Stream s, Token s ~ DecimalMark) =>
ParsecT CustomErr s m ()
skipNonNewlineSpaces
  -- there can be 0 or 1 sameLine
  [(Text, a)]
sameLine <- ParsecT CustomErr Text m () -> ParsecT CustomErr Text m ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try ParsecT CustomErr Text m ()
forall (m :: * -> *). TextParser m ()
headerp ParsecT CustomErr Text m ()
-> ParsecT CustomErr Text m [(Text, a)]
-> ParsecT CustomErr Text m [(Text, a)]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (((Text, a) -> [(Text, a)] -> [(Text, a)]
forall a. a -> [a] -> [a]
:[]) ((Text, a) -> [(Text, a)])
-> TextParser m (Text, a) -> ParsecT CustomErr Text m [(Text, a)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TextParser m a -> TextParser m (Text, a)
forall (m :: * -> *) a. TextParser m a -> TextParser m (Text, a)
match' TextParser m a
contentp) ParsecT CustomErr Text m [(Text, a)]
-> ParsecT CustomErr Text m [(Text, a)]
-> ParsecT CustomErr Text m [(Text, a)]
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [(Text, a)] -> ParsecT CustomErr Text m [(Text, a)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
  ()
_ <- ParsecT CustomErr Text m ()
forall (m :: * -> *). TextParser m ()
eolof
  -- there can be 0 or more nextLines
  [(Text, a)]
nextLines <- TextParser m (Text, a) -> ParsecT CustomErr Text m [(Text, a)]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many (TextParser m (Text, a) -> ParsecT CustomErr Text m [(Text, a)])
-> TextParser m (Text, a) -> ParsecT CustomErr Text m [(Text, a)]
forall a b. (a -> b) -> a -> b
$
    ParsecT CustomErr Text m () -> ParsecT CustomErr Text m ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (ParsecT CustomErr Text m ()
forall s (m :: * -> *).
(Stream s, Token s ~ DecimalMark) =>
ParsecT CustomErr s m ()
skipNonNewlineSpaces1 ParsecT CustomErr Text m ()
-> ParsecT CustomErr Text m () -> ParsecT CustomErr Text m ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT CustomErr Text m ()
forall (m :: * -> *). TextParser m ()
headerp) ParsecT CustomErr Text m ()
-> TextParser m (Text, a) -> TextParser m (Text, a)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> TextParser m a -> TextParser m (Text, a)
forall (m :: * -> *) a. TextParser m a -> TextParser m (Text, a)
match' TextParser m a
contentp TextParser m (Text, a)
-> ParsecT CustomErr Text m () -> TextParser m (Text, a)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT CustomErr Text m ()
forall (m :: * -> *). TextParser m ()
eolof
  let
    -- if there's just a next-line comment, insert an empty same-line comment
    -- so the next-line comment doesn't get rendered as a same-line comment.
    sameLine' :: [(Text, a)]
sameLine' | [(Text, a)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Text, a)]
sameLine Bool -> Bool -> Bool
&& Bool -> Bool
not ([(Text, a)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Text, a)]
nextLines) = [(Text
"",a
forall a. Monoid a => a
mempty)]
              | Bool
otherwise = [(Text, a)]
sameLine
    ([Text]
texts, [a]
contents) = [(Text, a)] -> ([Text], [a])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Text, a)] -> ([Text], [a])) -> [(Text, a)] -> ([Text], [a])
forall a b. (a -> b) -> a -> b
$ [(Text, a)]
sameLine' [(Text, a)] -> [(Text, a)] -> [(Text, a)]
forall a. [a] -> [a] -> [a]
++ [(Text, a)]
nextLines
    strippedCommentText :: Text
strippedCommentText = [Text] -> Text
T.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
T.strip [Text]
texts
    commentContent :: a
commentContent = [a] -> a
forall a. Monoid a => [a] -> a
mconcat [a]
contents
  (Text, a) -> TextParser m (Text, a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
strippedCommentText, a
commentContent)

  where
    headerp :: ParsecT CustomErr Text m ()
headerp = Token Text -> ParsecT CustomErr Text m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ DecimalMark) =>
Token s -> m (Token s)
char DecimalMark
Token Text
';' ParsecT CustomErr Text m DecimalMark
-> ParsecT CustomErr Text m () -> ParsecT CustomErr Text m ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ParsecT CustomErr Text m ()
forall s (m :: * -> *).
(Stream s, Token s ~ DecimalMark) =>
ParsecT CustomErr s m ()
skipNonNewlineSpaces

{-# INLINABLE followingcommentp' #-}

-- | Parse the text of a (possibly multiline) comment following a journal item.
--
-- >>> rtp followingcommentp ""   -- no comment
-- Right ""
-- >>> rtp followingcommentp ";"    -- just a (empty) same-line comment. newline is added
-- Right "\n"
-- >>> rtp followingcommentp ";  \n"
-- Right "\n"
-- >>> rtp followingcommentp ";\n ;\n"  -- a same-line and a next-line comment
-- Right "\n\n"
-- >>> rtp followingcommentp "\n ;\n"  -- just a next-line comment. Insert an empty same-line comment so the next-line comment doesn't become a same-line comment.
-- Right "\n\n"
--
followingcommentp :: TextParser m Text
followingcommentp :: TextParser m Text
followingcommentp =
  (Text, ()) -> Text
forall a b. (a, b) -> a
fst ((Text, ()) -> Text)
-> ParsecT CustomErr Text m (Text, ()) -> TextParser m Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TextParser m () -> ParsecT CustomErr Text m (Text, ())
forall a (m :: * -> *).
(Monoid a, Show a) =>
TextParser m a -> TextParser m (Text, a)
followingcommentp' (TextParser m Text -> TextParser m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (TextParser m Text -> TextParser m ())
-> TextParser m Text -> TextParser m ()
forall a b. (a -> b) -> a -> b
$ Maybe StorageFormat
-> (Token Text -> Bool) -> ParsecT CustomErr Text m (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe StorageFormat -> (Token s -> Bool) -> m (Tokens s)
takeWhileP Maybe StorageFormat
forall a. Maybe a
Nothing (DecimalMark -> DecimalMark -> Bool
forall a. Eq a => a -> a -> Bool
/= DecimalMark
'\n'))  -- XXX support \r\n ?
{-# INLINABLE followingcommentp #-}


-- | Parse a transaction comment and extract its tags.
--
-- The first line of a transaction may be followed by comments, which
-- begin with semicolons and extend to the end of the line. Transaction
-- comments may span multiple lines, but comment lines below the
-- transaction must be preceded by leading whitespace.
--
-- 2000/1/1 ; a transaction comment starting on the same line ...
--   ; extending to the next line
--   account1  $1
--   account2
--
-- Tags are name-value pairs.
--
-- >>> let getTags (_,tags) = tags
-- >>> let parseTags = fmap getTags . rtp transactioncommentp
--
-- >>> parseTags "; name1: val1, name2:all this is value2"
-- Right [("name1","val1"),("name2","all this is value2")]
--
-- A tag's name must be immediately followed by a colon, without
-- separating whitespace. The corresponding value consists of all the text
-- following the colon up until the next colon or newline, stripped of
-- leading and trailing whitespace.
--
transactioncommentp :: TextParser m (Text, [Tag])
transactioncommentp :: TextParser m (Text, [Tag])
transactioncommentp = TextParser m [Tag] -> TextParser m (Text, [Tag])
forall a (m :: * -> *).
(Monoid a, Show a) =>
TextParser m a -> TextParser m (Text, a)
followingcommentp' TextParser m [Tag]
forall (m :: * -> *). TextParser m [Tag]
commenttagsp
{-# INLINABLE transactioncommentp #-}

commenttagsp :: TextParser m [Tag]
commenttagsp :: TextParser m [Tag]
commenttagsp = do
  Text
tagName <- (Text -> Text)
-> ParsecT CustomErr Text m Text -> ParsecT CustomErr Text m Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Text] -> Text
forall a. [a] -> a
last ([Text] -> Text) -> (Text -> [Text]) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DecimalMark -> Bool) -> Text -> [Text]
T.split DecimalMark -> Bool
isSpace)
            (ParsecT CustomErr Text m Text -> ParsecT CustomErr Text m Text)
-> ParsecT CustomErr Text m Text -> ParsecT CustomErr Text m Text
forall a b. (a -> b) -> a -> b
$ Maybe StorageFormat
-> (Token Text -> Bool) -> ParsecT CustomErr Text m (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe StorageFormat -> (Token s -> Bool) -> m (Tokens s)
takeWhileP Maybe StorageFormat
forall a. Maybe a
Nothing (\Token Text
c -> DecimalMark
Token Text
c DecimalMark -> DecimalMark -> Bool
forall a. Eq a => a -> a -> Bool
/= DecimalMark
':' Bool -> Bool -> Bool
&& DecimalMark
Token Text
c DecimalMark -> DecimalMark -> Bool
forall a. Eq a => a -> a -> Bool
/= DecimalMark
'\n')
  Text -> TextParser m [Tag]
forall (m :: * -> *). Text -> TextParser m [Tag]
atColon Text
tagName TextParser m [Tag] -> TextParser m [Tag] -> TextParser m [Tag]
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [Tag] -> TextParser m [Tag]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [] -- if not ':', then either '\n' or EOF

  where
    atColon :: Text -> TextParser m [Tag]
    atColon :: Text -> TextParser m [Tag]
atColon Text
name = Token Text -> ParsecT CustomErr Text m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ DecimalMark) =>
Token s -> m (Token s)
char DecimalMark
Token Text
':' ParsecT CustomErr Text m DecimalMark
-> TextParser m [Tag] -> TextParser m [Tag]
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> do
      if Text -> Bool
T.null Text
name
        then TextParser m [Tag]
forall (m :: * -> *). TextParser m [Tag]
commenttagsp
        else do
          ParsecT CustomErr Text m ()
forall s (m :: * -> *).
(Stream s, Token s ~ DecimalMark) =>
ParsecT CustomErr s m ()
skipNonNewlineSpaces
          Text
val <- TextParser m Text
forall (m :: * -> *). TextParser m Text
tagValue
          let tag :: Tag
tag = (Text
name, Text
val)
          (Tag
tagTag -> [Tag] -> [Tag]
forall a. a -> [a] -> [a]
:) ([Tag] -> [Tag]) -> TextParser m [Tag] -> TextParser m [Tag]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TextParser m [Tag]
forall (m :: * -> *). TextParser m [Tag]
commenttagsp

    tagValue :: TextParser m Text
    tagValue :: TextParser m Text
tagValue = do
      Text
val <- Text -> Text
T.strip (Text -> Text) -> TextParser m Text -> TextParser m Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe StorageFormat
-> (Token Text -> Bool) -> ParsecT CustomErr Text m (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe StorageFormat -> (Token s -> Bool) -> m (Tokens s)
takeWhileP Maybe StorageFormat
forall a. Maybe a
Nothing (\Token Text
c -> DecimalMark
Token Text
c DecimalMark -> DecimalMark -> Bool
forall a. Eq a => a -> a -> Bool
/= DecimalMark
',' Bool -> Bool -> Bool
&& DecimalMark
Token Text
c DecimalMark -> DecimalMark -> Bool
forall a. Eq a => a -> a -> Bool
/= DecimalMark
'\n')
      Maybe DecimalMark
_ <- ParsecT CustomErr Text m DecimalMark
-> ParsecT CustomErr Text m (Maybe DecimalMark)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (ParsecT CustomErr Text m DecimalMark
 -> ParsecT CustomErr Text m (Maybe DecimalMark))
-> ParsecT CustomErr Text m DecimalMark
-> ParsecT CustomErr Text m (Maybe DecimalMark)
forall a b. (a -> b) -> a -> b
$ Token Text -> ParsecT CustomErr Text m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ DecimalMark) =>
Token s -> m (Token s)
char DecimalMark
Token Text
','
      Text -> TextParser m Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
val

{-# INLINABLE commenttagsp #-}


-- | Parse a posting comment and extract its tags and dates.
--
-- Postings may be followed by comments, which begin with semicolons and
-- extend to the end of the line. Posting comments may span multiple
-- lines, but comment lines below the posting must be preceded by
-- leading whitespace.
--
-- 2000/1/1
--   account1  $1 ; a posting comment starting on the same line ...
--   ; extending to the next line
--
--   account2
--   ; a posting comment beginning on the next line
--
-- Tags are name-value pairs.
--
-- >>> let getTags (_,tags,_,_) = tags
-- >>> let parseTags = fmap getTags . rtp (postingcommentp Nothing)
--
-- >>> parseTags "; name1: val1, name2:all this is value2"
-- Right [("name1","val1"),("name2","all this is value2")]
--
-- A tag's name must be immediately followed by a colon, without
-- separating whitespace. The corresponding value consists of all the text
-- following the colon up until the next colon or newline, stripped of
-- leading and trailing whitespace.
--
-- Posting dates may be expressed with "date"/"date2" tags or with
-- bracketed date syntax. Posting dates will inherit their year from the
-- transaction date if the year is not specified. We throw parse errors on
-- invalid dates.
--
-- >>> let getDates (_,_,d1,d2) = (d1, d2)
-- >>> let parseDates = fmap getDates . rtp (postingcommentp (Just 2000))
--
-- >>> parseDates "; date: 1/2, date2: 1999/12/31"
-- Right (Just 2000-01-02,Just 1999-12-31)
-- >>> parseDates "; [1/2=1999/12/31]"
-- Right (Just 2000-01-02,Just 1999-12-31)
--
-- Example: tags, date tags, and bracketed dates
-- >>> rtp (postingcommentp (Just 2000)) "; a:b, date:3/4, [=5/6]"
-- Right ("a:b, date:3/4, [=5/6]\n",[("a","b"),("date","3/4")],Just 2000-03-04,Just 2000-05-06)
--
-- Example: extraction of dates from date tags ignores trailing text
-- >>> rtp (postingcommentp (Just 2000)) "; date:3/4=5/6"
-- Right ("date:3/4=5/6\n",[("date","3/4=5/6")],Just 2000-03-04,Nothing)
--
postingcommentp
  :: Maybe Year -> TextParser m (Text, [Tag], Maybe Day, Maybe Day)
postingcommentp :: Maybe Integer -> TextParser m (Text, [Tag], Maybe Day, Maybe Day)
postingcommentp Maybe Integer
mYear = do
  (Text
commentText, ([Tag]
tags, [DateTag]
dateTags)) <-
    TextParser m ([Tag], [DateTag])
-> TextParser m (Text, ([Tag], [DateTag]))
forall a (m :: * -> *).
(Monoid a, Show a) =>
TextParser m a -> TextParser m (Text, a)
followingcommentp' (Maybe Integer -> TextParser m ([Tag], [DateTag])
forall (m :: * -> *).
Maybe Integer -> TextParser m ([Tag], [DateTag])
commenttagsanddatesp Maybe Integer
mYear)
  let mdate :: Maybe Day
mdate  = (DateTag -> Day) -> Maybe DateTag -> Maybe Day
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DateTag -> Day
forall a b. (a, b) -> b
snd (Maybe DateTag -> Maybe Day) -> Maybe DateTag -> Maybe Day
forall a b. (a -> b) -> a -> b
$ (DateTag -> Bool) -> [DateTag] -> Maybe DateTag
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
==Text
"date") (Text -> Bool) -> (DateTag -> Text) -> DateTag -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.DateTag -> Text
forall a b. (a, b) -> a
fst) [DateTag]
dateTags
      mdate2 :: Maybe Day
mdate2 = (DateTag -> Day) -> Maybe DateTag -> Maybe Day
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DateTag -> Day
forall a b. (a, b) -> b
snd (Maybe DateTag -> Maybe Day) -> Maybe DateTag -> Maybe Day
forall a b. (a -> b) -> a -> b
$ (DateTag -> Bool) -> [DateTag] -> Maybe DateTag
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
==Text
"date2")(Text -> Bool) -> (DateTag -> Text) -> DateTag -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.DateTag -> Text
forall a b. (a, b) -> a
fst) [DateTag]
dateTags
  (Text, [Tag], Maybe Day, Maybe Day)
-> TextParser m (Text, [Tag], Maybe Day, Maybe Day)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
commentText, [Tag]
tags, Maybe Day
mdate, Maybe Day
mdate2)
{-# INLINABLE postingcommentp #-}


commenttagsanddatesp
  :: Maybe Year -> TextParser m ([Tag], [DateTag])
commenttagsanddatesp :: Maybe Integer -> TextParser m ([Tag], [DateTag])
commenttagsanddatesp Maybe Integer
mYear = do
  (Text
txt, [DateTag]
dateTags) <- ParsecT CustomErr Text m [DateTag]
-> ParsecT CustomErr Text m (Tokens Text, [DateTag])
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> m (Tokens s, a)
match (ParsecT CustomErr Text m [DateTag]
 -> ParsecT CustomErr Text m (Tokens Text, [DateTag]))
-> ParsecT CustomErr Text m [DateTag]
-> ParsecT CustomErr Text m (Tokens Text, [DateTag])
forall a b. (a -> b) -> a -> b
$ DecimalMark -> ParsecT CustomErr Text m [DateTag]
forall (m :: * -> *). DecimalMark -> TextParser m [DateTag]
readUpTo DecimalMark
':'
  -- next char is either ':' or '\n' (or EOF)
  let tagName :: Text
tagName = [Text] -> Text
forall a. [a] -> a
last ((DecimalMark -> Bool) -> Text -> [Text]
T.split DecimalMark -> Bool
isSpace Text
txt)
  ((([Tag], [DateTag]) -> ([Tag], [DateTag]))
-> TextParser m ([Tag], [DateTag])
-> TextParser m ([Tag], [DateTag])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap((([Tag], [DateTag]) -> ([Tag], [DateTag]))
 -> TextParser m ([Tag], [DateTag])
 -> TextParser m ([Tag], [DateTag]))
-> (([DateTag] -> [DateTag])
    -> ([Tag], [DateTag]) -> ([Tag], [DateTag]))
-> ([DateTag] -> [DateTag])
-> TextParser m ([Tag], [DateTag])
-> TextParser m ([Tag], [DateTag])
forall b c a. (b -> c) -> (a -> b) -> a -> c
.([DateTag] -> [DateTag])
-> ([Tag], [DateTag]) -> ([Tag], [DateTag])
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second) ([DateTag]
dateTags[DateTag] -> [DateTag] -> [DateTag]
forall a. [a] -> [a] -> [a]
++) (Text -> TextParser m ([Tag], [DateTag])
forall (m :: * -> *). Text -> TextParser m ([Tag], [DateTag])
atColon Text
tagName) TextParser m ([Tag], [DateTag])
-> TextParser m ([Tag], [DateTag])
-> TextParser m ([Tag], [DateTag])
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ([Tag], [DateTag]) -> TextParser m ([Tag], [DateTag])
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], [DateTag]
dateTags) -- if not ':', then either '\n' or EOF

  where
    readUpTo :: Char -> TextParser m [DateTag]
    readUpTo :: DecimalMark -> TextParser m [DateTag]
readUpTo DecimalMark
end = do
      ParsecT CustomErr Text m Text -> ParsecT CustomErr Text m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT CustomErr Text m Text -> ParsecT CustomErr Text m ())
-> ParsecT CustomErr Text m Text -> ParsecT CustomErr Text m ()
forall a b. (a -> b) -> a -> b
$ Maybe StorageFormat
-> (Token Text -> Bool) -> ParsecT CustomErr Text m (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe StorageFormat -> (Token s -> Bool) -> m (Tokens s)
takeWhileP Maybe StorageFormat
forall a. Maybe a
Nothing (\Token Text
c -> DecimalMark
Token Text
c DecimalMark -> DecimalMark -> Bool
forall a. Eq a => a -> a -> Bool
/= DecimalMark
end Bool -> Bool -> Bool
&& DecimalMark
Token Text
c DecimalMark -> DecimalMark -> Bool
forall a. Eq a => a -> a -> Bool
/= DecimalMark
'\n' Bool -> Bool -> Bool
&& DecimalMark
Token Text
c DecimalMark -> DecimalMark -> Bool
forall a. Eq a => a -> a -> Bool
/= DecimalMark
'[')
      -- if not '[' then ':' or '\n' or EOF
      TextParser m [DateTag] -> TextParser m [DateTag]
forall (m :: * -> *).
TextParser m [DateTag] -> TextParser m [DateTag]
atBracket (DecimalMark -> TextParser m [DateTag]
forall (m :: * -> *). DecimalMark -> TextParser m [DateTag]
readUpTo DecimalMark
end) TextParser m [DateTag]
-> TextParser m [DateTag] -> TextParser m [DateTag]
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [DateTag] -> TextParser m [DateTag]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

    atBracket :: TextParser m [DateTag] -> TextParser m [DateTag]
    atBracket :: TextParser m [DateTag] -> TextParser m [DateTag]
atBracket TextParser m [DateTag]
cont = do
      -- Uses the fact that bracketed date-tags cannot contain newlines
      [DateTag]
dateTags <- [DateTag] -> TextParser m [DateTag] -> TextParser m [DateTag]
forall (m :: * -> *) a. Alternative m => a -> m a -> m a
option [] (TextParser m [DateTag] -> TextParser m [DateTag])
-> TextParser m [DateTag] -> TextParser m [DateTag]
forall a b. (a -> b) -> a -> b
$ TextParser m [DateTag] -> TextParser m [DateTag]
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
lookAhead (Maybe Integer -> TextParser m [DateTag]
forall (m :: * -> *). Maybe Integer -> TextParser m [DateTag]
bracketeddatetagsp Maybe Integer
mYear)
      DecimalMark
_ <- Token Text -> ParsecT CustomErr Text m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ DecimalMark) =>
Token s -> m (Token s)
char DecimalMark
Token Text
'['
      [DateTag]
dateTags' <- TextParser m [DateTag]
cont
      [DateTag] -> TextParser m [DateTag]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([DateTag] -> TextParser m [DateTag])
-> [DateTag] -> TextParser m [DateTag]
forall a b. (a -> b) -> a -> b
$ [DateTag]
dateTags [DateTag] -> [DateTag] -> [DateTag]
forall a. [a] -> [a] -> [a]
++ [DateTag]
dateTags'

    atColon :: Text -> TextParser m ([Tag], [DateTag])
    atColon :: Text -> TextParser m ([Tag], [DateTag])
atColon Text
name = Token Text -> ParsecT CustomErr Text m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ DecimalMark) =>
Token s -> m (Token s)
char DecimalMark
Token Text
':' ParsecT CustomErr Text m DecimalMark
-> TextParser m ([Tag], [DateTag])
-> TextParser m ([Tag], [DateTag])
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> do
      ParsecT CustomErr Text m ()
forall s (m :: * -> *).
(Stream s, Token s ~ DecimalMark) =>
ParsecT CustomErr s m ()
skipNonNewlineSpaces
      ([Tag]
tags, [DateTag]
dateTags) <- case Text
name of
        Text
""      -> ([Tag], [DateTag]) -> TextParser m ([Tag], [DateTag])
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], [])
        Text
"date"  -> Text -> TextParser m ([Tag], [DateTag])
forall (m :: * -> *). Text -> TextParser m ([Tag], [DateTag])
dateValue Text
name
        Text
"date2" -> Text -> TextParser m ([Tag], [DateTag])
forall (m :: * -> *). Text -> TextParser m ([Tag], [DateTag])
dateValue Text
name
        Text
_       -> Text -> TextParser m ([Tag], [DateTag])
forall (m :: * -> *). Text -> TextParser m ([Tag], [DateTag])
tagValue Text
name
      Maybe DecimalMark
_ <- ParsecT CustomErr Text m DecimalMark
-> ParsecT CustomErr Text m (Maybe DecimalMark)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (ParsecT CustomErr Text m DecimalMark
 -> ParsecT CustomErr Text m (Maybe DecimalMark))
-> ParsecT CustomErr Text m DecimalMark
-> ParsecT CustomErr Text m (Maybe DecimalMark)
forall a b. (a -> b) -> a -> b
$ Token Text -> ParsecT CustomErr Text m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ DecimalMark) =>
Token s -> m (Token s)
char DecimalMark
Token Text
','
      ([Tag] -> [Tag])
-> ([DateTag] -> [DateTag])
-> ([Tag], [DateTag])
-> ([Tag], [DateTag])
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap ([Tag]
tags[Tag] -> [Tag] -> [Tag]
forall a. [a] -> [a] -> [a]
++) ([DateTag]
dateTags[DateTag] -> [DateTag] -> [DateTag]
forall a. [a] -> [a] -> [a]
++) (([Tag], [DateTag]) -> ([Tag], [DateTag]))
-> TextParser m ([Tag], [DateTag])
-> TextParser m ([Tag], [DateTag])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Integer -> TextParser m ([Tag], [DateTag])
forall (m :: * -> *).
Maybe Integer -> TextParser m ([Tag], [DateTag])
commenttagsanddatesp Maybe Integer
mYear

    dateValue :: Text -> TextParser m ([Tag], [DateTag])
    dateValue :: Text -> TextParser m ([Tag], [DateTag])
dateValue Text
name = do
      (Text
txt, (Day
date, [DateTag]
dateTags)) <- TextParser m (Day, [DateTag])
-> TextParser m (Text, (Day, [DateTag]))
forall (m :: * -> *) a. TextParser m a -> TextParser m (Text, a)
match' (TextParser m (Day, [DateTag])
 -> TextParser m (Text, (Day, [DateTag])))
-> TextParser m (Day, [DateTag])
-> TextParser m (Text, (Day, [DateTag]))
forall a b. (a -> b) -> a -> b
$ do
        Day
date <- Maybe Integer -> TextParser m Day
forall (m :: * -> *). Maybe Integer -> TextParser m Day
datep' Maybe Integer
mYear
        [DateTag]
dateTags <- DecimalMark -> TextParser m [DateTag]
forall (m :: * -> *). DecimalMark -> TextParser m [DateTag]
readUpTo DecimalMark
','
        (Day, [DateTag]) -> TextParser m (Day, [DateTag])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Day
date, [DateTag]
dateTags)
      let val :: Text
val = Text -> Text
T.strip Text
txt
      ([Tag], [DateTag]) -> TextParser m ([Tag], [DateTag])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (([Tag], [DateTag]) -> TextParser m ([Tag], [DateTag]))
-> ([Tag], [DateTag]) -> TextParser m ([Tag], [DateTag])
forall a b. (a -> b) -> a -> b
$ ( [(Text
name, Text
val)]
             , (Text
name, Day
date) DateTag -> [DateTag] -> [DateTag]
forall a. a -> [a] -> [a]
: [DateTag]
dateTags )

    tagValue :: Text -> TextParser m ([Tag], [DateTag])
    tagValue :: Text -> TextParser m ([Tag], [DateTag])
tagValue Text
name = do
      (Text
txt, [DateTag]
dateTags) <- TextParser m [DateTag] -> TextParser m (Text, [DateTag])
forall (m :: * -> *) a. TextParser m a -> TextParser m (Text, a)
match' (TextParser m [DateTag] -> TextParser m (Text, [DateTag]))
-> TextParser m [DateTag] -> TextParser m (Text, [DateTag])
forall a b. (a -> b) -> a -> b
$ DecimalMark -> TextParser m [DateTag]
forall (m :: * -> *). DecimalMark -> TextParser m [DateTag]
readUpTo DecimalMark
','
      let val :: Text
val = Text -> Text
T.strip Text
txt
      ([Tag], [DateTag]) -> TextParser m ([Tag], [DateTag])
forall (f :: * -> *) a. Applicative f => a -> f a
pure (([Tag], [DateTag]) -> TextParser m ([Tag], [DateTag]))
-> ([Tag], [DateTag]) -> TextParser m ([Tag], [DateTag])
forall a b. (a -> b) -> a -> b
$ ( [(Text
name, Text
val)]
             , [DateTag]
dateTags )

{-# INLINABLE commenttagsanddatesp #-}

-- | Parse Ledger-style bracketed posting dates ([DATE=DATE2]), as
-- "date" and/or "date2" tags. Anything that looks like an attempt at
-- this (a square-bracketed sequence of 0123456789/-.= containing at
-- least one digit and one date separator) is also parsed, and will
-- throw an appropriate error.
--
-- The dates are parsed in full here so that errors are reported in
-- the right position. A missing year in DATE can be inferred if a
-- default date is provided. A missing year in DATE2 will be inferred
-- from DATE.
--
-- >>> either (Left . customErrorBundlePretty) Right $ rtp (bracketeddatetagsp Nothing) "[2016/1/2=3/4]"
-- Right [("date",2016-01-02),("date2",2016-03-04)]
--
-- >>> either (Left . customErrorBundlePretty) Right $ rtp (bracketeddatetagsp Nothing) "[1]"
-- Left ...not a bracketed date...
--
-- >>> either (Left . customErrorBundlePretty) Right $ rtp (bracketeddatetagsp Nothing) "[2016/1/32]"
-- Left ...1:2:...well-formed but invalid date: 2016/1/32...
--
-- >>> either (Left . customErrorBundlePretty) Right $ rtp (bracketeddatetagsp Nothing) "[1/31]"
-- Left ...1:2:...partial date 1/31 found, but the current year is unknown...
--
-- >>> either (Left . customErrorBundlePretty) Right $ rtp (bracketeddatetagsp Nothing) "[0123456789/-.=/-.=]"
-- Left ...1:13:...expecting month or day...
--
bracketeddatetagsp
  :: Maybe Year -> TextParser m [(TagName, Day)]
bracketeddatetagsp :: Maybe Integer -> TextParser m [DateTag]
bracketeddatetagsp Maybe Integer
mYear1 = do
  -- dbgparse 0 "bracketeddatetagsp"
  ParsecT CustomErr Text m () -> ParsecT CustomErr Text m ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (ParsecT CustomErr Text m () -> ParsecT CustomErr Text m ())
-> ParsecT CustomErr Text m () -> ParsecT CustomErr Text m ()
forall a b. (a -> b) -> a -> b
$ do
    Text
s <- ParsecT CustomErr Text m Text -> ParsecT CustomErr Text m Text
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
lookAhead
       (ParsecT CustomErr Text m Text -> ParsecT CustomErr Text m Text)
-> ParsecT CustomErr Text m Text -> ParsecT CustomErr Text m Text
forall a b. (a -> b) -> a -> b
$ ParsecT CustomErr Text m DecimalMark
-> ParsecT CustomErr Text m DecimalMark
-> ParsecT CustomErr Text m Text
-> ParsecT CustomErr Text m Text
forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between (Token Text -> ParsecT CustomErr Text m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ DecimalMark) =>
Token s -> m (Token s)
char DecimalMark
Token Text
'[') (Token Text -> ParsecT CustomErr Text m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ DecimalMark) =>
Token s -> m (Token s)
char DecimalMark
Token Text
']')
       (ParsecT CustomErr Text m Text -> ParsecT CustomErr Text m Text)
-> ParsecT CustomErr Text m Text -> ParsecT CustomErr Text m Text
forall a b. (a -> b) -> a -> b
$ Maybe StorageFormat
-> (Token Text -> Bool) -> ParsecT CustomErr Text m (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe StorageFormat -> (Token s -> Bool) -> m (Tokens s)
takeWhile1P Maybe StorageFormat
forall a. Maybe a
Nothing DecimalMark -> Bool
Token Text -> Bool
isBracketedDateChar
    Bool -> ParsecT CustomErr Text m () -> ParsecT CustomErr Text m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ((DecimalMark -> Bool) -> Text -> Bool
T.any DecimalMark -> Bool
isDigit Text
s Bool -> Bool -> Bool
&& (DecimalMark -> Bool) -> Text -> Bool
T.any DecimalMark -> Bool
isDateSepChar Text
s) (ParsecT CustomErr Text m () -> ParsecT CustomErr Text m ())
-> ParsecT CustomErr Text m () -> ParsecT CustomErr Text m ()
forall a b. (a -> b) -> a -> b
$
      StorageFormat -> ParsecT CustomErr Text m ()
forall (m :: * -> *) a. MonadFail m => StorageFormat -> m a
Fail.fail StorageFormat
"not a bracketed date"
  -- Looks sufficiently like a bracketed date to commit to parsing a date

  ParsecT CustomErr Text m DecimalMark
-> ParsecT CustomErr Text m DecimalMark
-> TextParser m [DateTag]
-> TextParser m [DateTag]
forall (m :: * -> *) open close a.
Applicative m =>
m open -> m close -> m a -> m a
between (Token Text -> ParsecT CustomErr Text m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ DecimalMark) =>
Token s -> m (Token s)
char DecimalMark
Token Text
'[') (Token Text -> ParsecT CustomErr Text m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ DecimalMark) =>
Token s -> m (Token s)
char DecimalMark
Token Text
']') (TextParser m [DateTag] -> TextParser m [DateTag])
-> TextParser m [DateTag] -> TextParser m [DateTag]
forall a b. (a -> b) -> a -> b
$ do
    Maybe Day
md1 <- ParsecT CustomErr Text m Day
-> ParsecT CustomErr Text m (Maybe Day)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (ParsecT CustomErr Text m Day
 -> ParsecT CustomErr Text m (Maybe Day))
-> ParsecT CustomErr Text m Day
-> ParsecT CustomErr Text m (Maybe Day)
forall a b. (a -> b) -> a -> b
$ Maybe Integer -> ParsecT CustomErr Text m Day
forall (m :: * -> *). Maybe Integer -> TextParser m Day
datep' Maybe Integer
mYear1

    let mYear2 :: Maybe Integer
mYear2 = (Day -> Integer) -> Maybe Day -> Maybe Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Day -> Integer
readYear Maybe Day
md1 Maybe Integer -> Maybe Integer -> Maybe Integer
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe Integer
mYear1
    Maybe Day
md2 <- ParsecT CustomErr Text m Day
-> ParsecT CustomErr Text m (Maybe Day)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (ParsecT CustomErr Text m Day
 -> ParsecT CustomErr Text m (Maybe Day))
-> ParsecT CustomErr Text m Day
-> ParsecT CustomErr Text m (Maybe Day)
forall a b. (a -> b) -> a -> b
$ Token Text -> ParsecT CustomErr Text m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ DecimalMark) =>
Token s -> m (Token s)
char DecimalMark
Token Text
'=' ParsecT CustomErr Text m DecimalMark
-> ParsecT CustomErr Text m Day -> ParsecT CustomErr Text m Day
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Maybe Integer -> ParsecT CustomErr Text m Day
forall (m :: * -> *). Maybe Integer -> TextParser m Day
datep' Maybe Integer
mYear2

    [DateTag] -> TextParser m [DateTag]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([DateTag] -> TextParser m [DateTag])
-> [DateTag] -> TextParser m [DateTag]
forall a b. (a -> b) -> a -> b
$ [Maybe DateTag] -> [DateTag]
forall a. [Maybe a] -> [a]
catMaybes [(Text
"date",) (Day -> DateTag) -> Maybe Day -> Maybe DateTag
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Day
md1, (Text
"date2",) (Day -> DateTag) -> Maybe Day -> Maybe DateTag
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Day
md2]

  where
    readYear :: Day -> Integer
readYear = (Integer, Int, Int) -> Integer
forall a b c. (a, b, c) -> a
first3 ((Integer, Int, Int) -> Integer)
-> (Day -> (Integer, Int, Int)) -> Day -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Day -> (Integer, Int, Int)
toGregorian
    isBracketedDateChar :: DecimalMark -> Bool
isBracketedDateChar DecimalMark
c = DecimalMark -> Bool
isDigit DecimalMark
c Bool -> Bool -> Bool
|| DecimalMark -> Bool
isDateSepChar DecimalMark
c Bool -> Bool -> Bool
|| DecimalMark
c DecimalMark -> DecimalMark -> Bool
forall a. Eq a => a -> a -> Bool
== DecimalMark
'='

{-# INLINABLE bracketeddatetagsp #-}

-- | Get the account name aliases from options, if any.
aliasesFromOpts :: InputOpts -> [AccountAlias]
aliasesFromOpts :: InputOpts -> [AccountAlias]
aliasesFromOpts = (StorageFormat -> AccountAlias)
-> [StorageFormat] -> [AccountAlias]
forall a b. (a -> b) -> [a] -> [b]
map (\StorageFormat
a -> Either (ParseErrorBundle Text CustomErr) AccountAlias
-> AccountAlias
forall t e a.
(Show t, Show (Token t), Show e) =>
Either (ParseErrorBundle t e) a -> a
fromparse (Either (ParseErrorBundle Text CustomErr) AccountAlias
 -> AccountAlias)
-> Either (ParseErrorBundle Text CustomErr) AccountAlias
-> AccountAlias
forall a b. (a -> b) -> a -> b
$ Parsec CustomErr Text AccountAlias
-> StorageFormat
-> Text
-> Either (ParseErrorBundle Text CustomErr) AccountAlias
forall e s a.
Parsec e s a
-> StorageFormat -> s -> Either (ParseErrorBundle s e) a
runParser Parsec CustomErr Text AccountAlias
forall (m :: * -> *). TextParser m AccountAlias
accountaliasp (StorageFormat
"--alias "StorageFormat -> ShowS
forall a. [a] -> [a] -> [a]
++ShowS
quoteIfNeeded StorageFormat
a) (Text -> Either (ParseErrorBundle Text CustomErr) AccountAlias)
-> Text -> Either (ParseErrorBundle Text CustomErr) AccountAlias
forall a b. (a -> b) -> a -> b
$ StorageFormat -> Text
T.pack StorageFormat
a)
                  ([StorageFormat] -> [AccountAlias])
-> (InputOpts -> [StorageFormat]) -> InputOpts -> [AccountAlias]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InputOpts -> [StorageFormat]
aliases_

accountaliasp :: TextParser m AccountAlias
accountaliasp :: TextParser m AccountAlias
accountaliasp = TextParser m AccountAlias
forall (m :: * -> *). TextParser m AccountAlias
regexaliasp TextParser m AccountAlias
-> TextParser m AccountAlias -> TextParser m AccountAlias
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> TextParser m AccountAlias
forall (m :: * -> *). TextParser m AccountAlias
basicaliasp

basicaliasp :: TextParser m AccountAlias
basicaliasp :: TextParser m AccountAlias
basicaliasp = do
  -- dbgparse 0 "basicaliasp"
  StorageFormat
old <- ShowS
rstrip ShowS
-> ParsecT CustomErr Text m StorageFormat
-> ParsecT CustomErr Text m StorageFormat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ParsecT CustomErr Text m DecimalMark
-> ParsecT CustomErr Text m StorageFormat
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some (ParsecT CustomErr Text m DecimalMark
 -> ParsecT CustomErr Text m StorageFormat)
-> ParsecT CustomErr Text m DecimalMark
-> ParsecT CustomErr Text m StorageFormat
forall a b. (a -> b) -> a -> b
$ [Token Text] -> ParsecT CustomErr Text m (Token Text)
forall (f :: * -> *) e s (m :: * -> *).
(Foldable f, MonadParsec e s m) =>
f (Token s) -> m (Token s)
noneOf (StorageFormat
"=" :: [Char]))
  Token Text -> ParsecT CustomErr Text m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ DecimalMark) =>
Token s -> m (Token s)
char DecimalMark
Token Text
'='
  ParsecT CustomErr Text m ()
forall s (m :: * -> *).
(Stream s, Token s ~ DecimalMark) =>
ParsecT CustomErr s m ()
skipNonNewlineSpaces
  StorageFormat
new <- ShowS
rstrip ShowS
-> ParsecT CustomErr Text m StorageFormat
-> ParsecT CustomErr Text m StorageFormat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT CustomErr Text m DecimalMark
forall e s (m :: * -> *). MonadParsec e s m => m (Token s)
anySingle ParsecT CustomErr Text m DecimalMark
-> ParsecT CustomErr Text m ()
-> ParsecT CustomErr Text m StorageFormat
forall (m :: * -> *) a end. MonadPlus m => m a -> m end -> m [a]
`manyTill` ParsecT CustomErr Text m ()
forall (m :: * -> *). TextParser m ()
eolof  -- eol in journal, eof in command lines, normally
  AccountAlias -> TextParser m AccountAlias
forall (m :: * -> *) a. Monad m => a -> m a
return (AccountAlias -> TextParser m AccountAlias)
-> AccountAlias -> TextParser m AccountAlias
forall a b. (a -> b) -> a -> b
$ Text -> Text -> AccountAlias
BasicAlias (StorageFormat -> Text
T.pack StorageFormat
old) (StorageFormat -> Text
T.pack StorageFormat
new)

regexaliasp :: TextParser m AccountAlias
regexaliasp :: TextParser m AccountAlias
regexaliasp = do
  -- dbgparse 0 "regexaliasp"
  Token Text -> ParsecT CustomErr Text m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ DecimalMark) =>
Token s -> m (Token s)
char DecimalMark
Token Text
'/'
  Int
off1 <- ParsecT CustomErr Text m Int
forall e s (m :: * -> *). MonadParsec e s m => m Int
getOffset
  StorageFormat
re <- ParsecT CustomErr Text m DecimalMark
-> ParsecT CustomErr Text m StorageFormat
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some (ParsecT CustomErr Text m DecimalMark
 -> ParsecT CustomErr Text m StorageFormat)
-> ParsecT CustomErr Text m DecimalMark
-> ParsecT CustomErr Text m StorageFormat
forall a b. (a -> b) -> a -> b
$ [Token Text] -> ParsecT CustomErr Text m (Token Text)
forall (f :: * -> *) e s (m :: * -> *).
(Foldable f, MonadParsec e s m) =>
f (Token s) -> m (Token s)
noneOf (StorageFormat
"/\n\r" :: [Char]) -- paranoid: don't try to read past line end
  Int
off2 <- ParsecT CustomErr Text m Int
forall e s (m :: * -> *). MonadParsec e s m => m Int
getOffset
  Token Text -> ParsecT CustomErr Text m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ DecimalMark) =>
Token s -> m (Token s)
char DecimalMark
Token Text
'/'
  ParsecT CustomErr Text m ()
forall s (m :: * -> *).
(Stream s, Token s ~ DecimalMark) =>
ParsecT CustomErr s m ()
skipNonNewlineSpaces
  Token Text -> ParsecT CustomErr Text m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ DecimalMark) =>
Token s -> m (Token s)
char DecimalMark
Token Text
'='
  ParsecT CustomErr Text m ()
forall s (m :: * -> *).
(Stream s, Token s ~ DecimalMark) =>
ParsecT CustomErr s m ()
skipNonNewlineSpaces
  StorageFormat
repl <- ParsecT CustomErr Text m DecimalMark
forall e s (m :: * -> *). MonadParsec e s m => m (Token s)
anySingle ParsecT CustomErr Text m DecimalMark
-> ParsecT CustomErr Text m ()
-> ParsecT CustomErr Text m StorageFormat
forall (m :: * -> *) a end. MonadPlus m => m a -> m end -> m [a]
`manyTill` ParsecT CustomErr Text m ()
forall (m :: * -> *). TextParser m ()
eolof
  case Text -> Either StorageFormat Regexp
toRegexCI (Text -> Either StorageFormat Regexp)
-> Text -> Either StorageFormat Regexp
forall a b. (a -> b) -> a -> b
$ StorageFormat -> Text
T.pack StorageFormat
re of
    Right Regexp
r -> AccountAlias -> TextParser m AccountAlias
forall (m :: * -> *) a. Monad m => a -> m a
return (AccountAlias -> TextParser m AccountAlias)
-> AccountAlias -> TextParser m AccountAlias
forall a b. (a -> b) -> a -> b
$! Regexp -> StorageFormat -> AccountAlias
RegexAlias Regexp
r StorageFormat
repl
    Left StorageFormat
e  -> CustomErr -> TextParser m AccountAlias
forall e s (m :: * -> *) a. MonadParsec e s m => e -> m a
customFailure (CustomErr -> TextParser m AccountAlias)
-> CustomErr -> TextParser m AccountAlias
forall a b. (a -> b) -> a -> b
$! Int -> Int -> StorageFormat -> CustomErr
parseErrorAtRegion Int
off1 Int
off2 StorageFormat
e

--- ** tests

tests_Common :: TestTree
tests_Common = StorageFormat -> [TestTree] -> TestTree
tests StorageFormat
"Common" [

   StorageFormat -> [TestTree] -> TestTree
tests StorageFormat
"amountp" [
    StorageFormat -> Assertion -> TestTree
test StorageFormat
"basic"                  (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$ StateT Journal (ParsecT CustomErr Text IO) Amount
-> Text -> Amount -> Assertion
forall a st.
(HasCallStack, Eq a, Show a, Default st) =>
StateT st (ParsecT CustomErr Text IO) a -> Text -> a -> Assertion
assertParseEq StateT Journal (ParsecT CustomErr Text IO) Amount
forall (m :: * -> *). JournalParser m Amount
amountp Text
"$47.18"     (Decimal -> Amount
usd Decimal
47.18)
   ,StorageFormat -> Assertion -> TestTree
test StorageFormat
"ends with decimal mark" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$ StateT Journal (ParsecT CustomErr Text IO) Amount
-> Text -> Amount -> Assertion
forall a st.
(HasCallStack, Eq a, Show a, Default st) =>
StateT st (ParsecT CustomErr Text IO) a -> Text -> a -> Assertion
assertParseEq StateT Journal (ParsecT CustomErr Text IO) Amount
forall (m :: * -> *). JournalParser m Amount
amountp Text
"$1."        (Decimal -> Amount
usd Decimal
1  Amount -> AmountPrecision -> Amount
`withPrecision` Word8 -> AmountPrecision
Precision Word8
0)
   ,StorageFormat -> Assertion -> TestTree
test StorageFormat
"unit price"             (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$ StateT Journal (ParsecT CustomErr Text IO) Amount
-> Text -> Amount -> Assertion
forall a st.
(HasCallStack, Eq a, Show a, Default st) =>
StateT st (ParsecT CustomErr Text IO) a -> Text -> a -> Assertion
assertParseEq StateT Journal (ParsecT CustomErr Text IO) Amount
forall (m :: * -> *). JournalParser m Amount
amountp Text
"$10 @ €0.5"
      -- not precise enough:
      -- (usd 10 `withPrecision` 0 `at` (eur 0.5 `withPrecision` 1)) -- `withStyle` asdecimalpoint=Just '.'
      Amount
amount{
         acommodity :: Text
acommodity=Text
"$"
        ,aquantity :: Decimal
aquantity=Decimal
10 -- need to test internal precision with roundTo ? I think not
        ,astyle :: AmountStyle
astyle=AmountStyle
amountstyle{asprecision :: AmountPrecision
asprecision=Word8 -> AmountPrecision
Precision Word8
0, asdecimalpoint :: Maybe DecimalMark
asdecimalpoint=Maybe DecimalMark
forall a. Maybe a
Nothing}
        ,aprice :: Maybe AmountPrice
aprice=AmountPrice -> Maybe AmountPrice
forall a. a -> Maybe a
Just (AmountPrice -> Maybe AmountPrice)
-> AmountPrice -> Maybe AmountPrice
forall a b. (a -> b) -> a -> b
$ Amount -> AmountPrice
UnitPrice (Amount -> AmountPrice) -> Amount -> AmountPrice
forall a b. (a -> b) -> a -> b
$
          Amount
amount{
             acommodity :: Text
acommodity=Text
"€"
            ,aquantity :: Decimal
aquantity=Decimal
0.5
            ,astyle :: AmountStyle
astyle=AmountStyle
amountstyle{asprecision :: AmountPrecision
asprecision=Word8 -> AmountPrecision
Precision Word8
1, asdecimalpoint :: Maybe DecimalMark
asdecimalpoint=DecimalMark -> Maybe DecimalMark
forall a. a -> Maybe a
Just DecimalMark
'.'}
            }
        }
   ,StorageFormat -> Assertion -> TestTree
test StorageFormat
"total price"            (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$ StateT Journal (ParsecT CustomErr Text IO) Amount
-> Text -> Amount -> Assertion
forall a st.
(HasCallStack, Eq a, Show a, Default st) =>
StateT st (ParsecT CustomErr Text IO) a -> Text -> a -> Assertion
assertParseEq StateT Journal (ParsecT CustomErr Text IO) Amount
forall (m :: * -> *). JournalParser m Amount
amountp Text
"$10 @@ €5"
      Amount
amount{
         acommodity :: Text
acommodity=Text
"$"
        ,aquantity :: Decimal
aquantity=Decimal
10
        ,astyle :: AmountStyle
astyle=AmountStyle
amountstyle{asprecision :: AmountPrecision
asprecision=Word8 -> AmountPrecision
Precision Word8
0, asdecimalpoint :: Maybe DecimalMark
asdecimalpoint=Maybe DecimalMark
forall a. Maybe a
Nothing}
        ,aprice :: Maybe AmountPrice
aprice=AmountPrice -> Maybe AmountPrice
forall a. a -> Maybe a
Just (AmountPrice -> Maybe AmountPrice)
-> AmountPrice -> Maybe AmountPrice
forall a b. (a -> b) -> a -> b
$ Amount -> AmountPrice
TotalPrice (Amount -> AmountPrice) -> Amount -> AmountPrice
forall a b. (a -> b) -> a -> b
$
          Amount
amount{
             acommodity :: Text
acommodity=Text
"€"
            ,aquantity :: Decimal
aquantity=Decimal
5
            ,astyle :: AmountStyle
astyle=AmountStyle
amountstyle{asprecision :: AmountPrecision
asprecision=Word8 -> AmountPrecision
Precision Word8
0, asdecimalpoint :: Maybe DecimalMark
asdecimalpoint=Maybe DecimalMark
forall a. Maybe a
Nothing}
            }
        }
   ,StorageFormat -> Assertion -> TestTree
test StorageFormat
"unit price, parenthesised" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$ StateT Journal (ParsecT CustomErr Text IO) Amount
-> Text -> Assertion
forall a st.
(HasCallStack, Eq a, Show a, Default st) =>
StateT st (ParsecT CustomErr Text IO) a -> Text -> Assertion
assertParse StateT Journal (ParsecT CustomErr Text IO) Amount
forall (m :: * -> *). JournalParser m Amount
amountp Text
"$10 (@) €0.5"
   ,StorageFormat -> Assertion -> TestTree
test StorageFormat
"total price, parenthesised" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$ StateT Journal (ParsecT CustomErr Text IO) Amount
-> Text -> Assertion
forall a st.
(HasCallStack, Eq a, Show a, Default st) =>
StateT st (ParsecT CustomErr Text IO) a -> Text -> Assertion
assertParse StateT Journal (ParsecT CustomErr Text IO) Amount
forall (m :: * -> *). JournalParser m Amount
amountp Text
"$10 (@@) €0.5"
   ]

  ,let p :: JournalParser
  IO (Decimal, Word8, Maybe DecimalMark, Maybe DigitGroupStyle)
p = ParsecT
  CustomErr
  Text
  IO
  (Decimal, Word8, Maybe DecimalMark, Maybe DigitGroupStyle)
-> JournalParser
     IO (Decimal, Word8, Maybe DecimalMark, Maybe DigitGroupStyle)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Maybe AmountStyle
-> ParsecT
     CustomErr
     Text
     IO
     (Decimal, Word8, Maybe DecimalMark, Maybe DigitGroupStyle)
forall (m :: * -> *).
Maybe AmountStyle
-> TextParser
     m (Decimal, Word8, Maybe DecimalMark, Maybe DigitGroupStyle)
numberp Maybe AmountStyle
forall a. Maybe a
Nothing) :: JournalParser IO (Quantity, Word8, Maybe Char, Maybe DigitGroupStyle) in
   StorageFormat -> Assertion -> TestTree
test StorageFormat
"numberp" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$ do
     JournalParser
  IO (Decimal, Word8, Maybe DecimalMark, Maybe DigitGroupStyle)
-> Text
-> (Decimal, Word8, Maybe DecimalMark, Maybe DigitGroupStyle)
-> Assertion
forall a st.
(HasCallStack, Eq a, Show a, Default st) =>
StateT st (ParsecT CustomErr Text IO) a -> Text -> a -> Assertion
assertParseEq JournalParser
  IO (Decimal, Word8, Maybe DecimalMark, Maybe DigitGroupStyle)
p Text
"0"          (Decimal
0, Word8
0, Maybe DecimalMark
forall a. Maybe a
Nothing, Maybe DigitGroupStyle
forall a. Maybe a
Nothing)
     JournalParser
  IO (Decimal, Word8, Maybe DecimalMark, Maybe DigitGroupStyle)
-> Text
-> (Decimal, Word8, Maybe DecimalMark, Maybe DigitGroupStyle)
-> Assertion
forall a st.
(HasCallStack, Eq a, Show a, Default st) =>
StateT st (ParsecT CustomErr Text IO) a -> Text -> a -> Assertion
assertParseEq JournalParser
  IO (Decimal, Word8, Maybe DecimalMark, Maybe DigitGroupStyle)
p Text
"1"          (Decimal
1, Word8
0, Maybe DecimalMark
forall a. Maybe a
Nothing, Maybe DigitGroupStyle
forall a. Maybe a
Nothing)
     JournalParser
  IO (Decimal, Word8, Maybe DecimalMark, Maybe DigitGroupStyle)
-> Text
-> (Decimal, Word8, Maybe DecimalMark, Maybe DigitGroupStyle)
-> Assertion
forall a st.
(HasCallStack, Eq a, Show a, Default st) =>
StateT st (ParsecT CustomErr Text IO) a -> Text -> a -> Assertion
assertParseEq JournalParser
  IO (Decimal, Word8, Maybe DecimalMark, Maybe DigitGroupStyle)
p Text
"1.1"        (Decimal
1.1, Word8
1, DecimalMark -> Maybe DecimalMark
forall a. a -> Maybe a
Just DecimalMark
'.', Maybe DigitGroupStyle
forall a. Maybe a
Nothing)
     JournalParser
  IO (Decimal, Word8, Maybe DecimalMark, Maybe DigitGroupStyle)
-> Text
-> (Decimal, Word8, Maybe DecimalMark, Maybe DigitGroupStyle)
-> Assertion
forall a st.
(HasCallStack, Eq a, Show a, Default st) =>
StateT st (ParsecT CustomErr Text IO) a -> Text -> a -> Assertion
assertParseEq JournalParser
  IO (Decimal, Word8, Maybe DecimalMark, Maybe DigitGroupStyle)
p Text
"1,000.1"    (Decimal
1000.1, Word8
1, DecimalMark -> Maybe DecimalMark
forall a. a -> Maybe a
Just DecimalMark
'.', DigitGroupStyle -> Maybe DigitGroupStyle
forall a. a -> Maybe a
Just (DigitGroupStyle -> Maybe DigitGroupStyle)
-> DigitGroupStyle -> Maybe DigitGroupStyle
forall a b. (a -> b) -> a -> b
$ DecimalMark -> [Word8] -> DigitGroupStyle
DigitGroups DecimalMark
',' [Word8
3])
     JournalParser
  IO (Decimal, Word8, Maybe DecimalMark, Maybe DigitGroupStyle)
-> Text
-> (Decimal, Word8, Maybe DecimalMark, Maybe DigitGroupStyle)
-> Assertion
forall a st.
(HasCallStack, Eq a, Show a, Default st) =>
StateT st (ParsecT CustomErr Text IO) a -> Text -> a -> Assertion
assertParseEq JournalParser
  IO (Decimal, Word8, Maybe DecimalMark, Maybe DigitGroupStyle)
p Text
"1.00.000,1" (Decimal
100000.1, Word8
1, DecimalMark -> Maybe DecimalMark
forall a. a -> Maybe a
Just DecimalMark
',', DigitGroupStyle -> Maybe DigitGroupStyle
forall a. a -> Maybe a
Just (DigitGroupStyle -> Maybe DigitGroupStyle)
-> DigitGroupStyle -> Maybe DigitGroupStyle
forall a b. (a -> b) -> a -> b
$ DecimalMark -> [Word8] -> DigitGroupStyle
DigitGroups DecimalMark
'.' [Word8
3,Word8
2])
     JournalParser
  IO (Decimal, Word8, Maybe DecimalMark, Maybe DigitGroupStyle)
-> Text
-> (Decimal, Word8, Maybe DecimalMark, Maybe DigitGroupStyle)
-> Assertion
forall a st.
(HasCallStack, Eq a, Show a, Default st) =>
StateT st (ParsecT CustomErr Text IO) a -> Text -> a -> Assertion
assertParseEq JournalParser
  IO (Decimal, Word8, Maybe DecimalMark, Maybe DigitGroupStyle)
p Text
"1,000,000"  (Decimal
1000000, Word8
0, Maybe DecimalMark
forall a. Maybe a
Nothing, DigitGroupStyle -> Maybe DigitGroupStyle
forall a. a -> Maybe a
Just (DigitGroupStyle -> Maybe DigitGroupStyle)
-> DigitGroupStyle -> Maybe DigitGroupStyle
forall a b. (a -> b) -> a -> b
$ DecimalMark -> [Word8] -> DigitGroupStyle
DigitGroups DecimalMark
',' [Word8
3,Word8
3])  -- could be simplified to [3]
     JournalParser
  IO (Decimal, Word8, Maybe DecimalMark, Maybe DigitGroupStyle)
-> Text
-> (Decimal, Word8, Maybe DecimalMark, Maybe DigitGroupStyle)
-> Assertion
forall a st.
(HasCallStack, Eq a, Show a, Default st) =>
StateT st (ParsecT CustomErr Text IO) a -> Text -> a -> Assertion
assertParseEq JournalParser
  IO (Decimal, Word8, Maybe DecimalMark, Maybe DigitGroupStyle)
p Text
"1."         (Decimal
1, Word8
0, DecimalMark -> Maybe DecimalMark
forall a. a -> Maybe a
Just DecimalMark
'.', Maybe DigitGroupStyle
forall a. Maybe a
Nothing)
     JournalParser
  IO (Decimal, Word8, Maybe DecimalMark, Maybe DigitGroupStyle)
-> Text
-> (Decimal, Word8, Maybe DecimalMark, Maybe DigitGroupStyle)
-> Assertion
forall a st.
(HasCallStack, Eq a, Show a, Default st) =>
StateT st (ParsecT CustomErr Text IO) a -> Text -> a -> Assertion
assertParseEq JournalParser
  IO (Decimal, Word8, Maybe DecimalMark, Maybe DigitGroupStyle)
p Text
"1,"         (Decimal
1, Word8
0, DecimalMark -> Maybe DecimalMark
forall a. a -> Maybe a
Just DecimalMark
',', Maybe DigitGroupStyle
forall a. Maybe a
Nothing)
     JournalParser
  IO (Decimal, Word8, Maybe DecimalMark, Maybe DigitGroupStyle)
-> Text
-> (Decimal, Word8, Maybe DecimalMark, Maybe DigitGroupStyle)
-> Assertion
forall a st.
(HasCallStack, Eq a, Show a, Default st) =>
StateT st (ParsecT CustomErr Text IO) a -> Text -> a -> Assertion
assertParseEq JournalParser
  IO (Decimal, Word8, Maybe DecimalMark, Maybe DigitGroupStyle)
p Text
".1"         (Decimal
0.1, Word8
1, DecimalMark -> Maybe DecimalMark
forall a. a -> Maybe a
Just DecimalMark
'.', Maybe DigitGroupStyle
forall a. Maybe a
Nothing)
     JournalParser
  IO (Decimal, Word8, Maybe DecimalMark, Maybe DigitGroupStyle)
-> Text
-> (Decimal, Word8, Maybe DecimalMark, Maybe DigitGroupStyle)
-> Assertion
forall a st.
(HasCallStack, Eq a, Show a, Default st) =>
StateT st (ParsecT CustomErr Text IO) a -> Text -> a -> Assertion
assertParseEq JournalParser
  IO (Decimal, Word8, Maybe DecimalMark, Maybe DigitGroupStyle)
p Text
",1"         (Decimal
0.1, Word8
1, DecimalMark -> Maybe DecimalMark
forall a. a -> Maybe a
Just DecimalMark
',', Maybe DigitGroupStyle
forall a. Maybe a
Nothing)
     JournalParser
  IO (Decimal, Word8, Maybe DecimalMark, Maybe DigitGroupStyle)
-> StorageFormat -> StorageFormat -> Assertion
forall a st.
(HasCallStack, Eq a, Show a, Default st) =>
StateT st (ParsecT CustomErr Text IO) a
-> StorageFormat -> StorageFormat -> Assertion
assertParseError JournalParser
  IO (Decimal, Word8, Maybe DecimalMark, Maybe DigitGroupStyle)
p StorageFormat
"" StorageFormat
""
     JournalParser
  IO (Decimal, Word8, Maybe DecimalMark, Maybe DigitGroupStyle)
-> StorageFormat -> StorageFormat -> Assertion
forall a st.
(HasCallStack, Eq a, Show a, Default st) =>
StateT st (ParsecT CustomErr Text IO) a
-> StorageFormat -> StorageFormat -> Assertion
assertParseError JournalParser
  IO (Decimal, Word8, Maybe DecimalMark, Maybe DigitGroupStyle)
p StorageFormat
"1,000.000,1" StorageFormat
""
     JournalParser
  IO (Decimal, Word8, Maybe DecimalMark, Maybe DigitGroupStyle)
-> StorageFormat -> StorageFormat -> Assertion
forall a st.
(HasCallStack, Eq a, Show a, Default st) =>
StateT st (ParsecT CustomErr Text IO) a
-> StorageFormat -> StorageFormat -> Assertion
assertParseError JournalParser
  IO (Decimal, Word8, Maybe DecimalMark, Maybe DigitGroupStyle)
p StorageFormat
"1.000,000.1" StorageFormat
""
     JournalParser
  IO (Decimal, Word8, Maybe DecimalMark, Maybe DigitGroupStyle)
-> StorageFormat -> StorageFormat -> Assertion
forall a st.
(HasCallStack, Eq a, Show a, Default st) =>
StateT st (ParsecT CustomErr Text IO) a
-> StorageFormat -> StorageFormat -> Assertion
assertParseError JournalParser
  IO (Decimal, Word8, Maybe DecimalMark, Maybe DigitGroupStyle)
p StorageFormat
"1,000.000.1" StorageFormat
""
     JournalParser
  IO (Decimal, Word8, Maybe DecimalMark, Maybe DigitGroupStyle)
-> StorageFormat -> StorageFormat -> Assertion
forall a st.
(HasCallStack, Eq a, Show a, Default st) =>
StateT st (ParsecT CustomErr Text IO) a
-> StorageFormat -> StorageFormat -> Assertion
assertParseError JournalParser
  IO (Decimal, Word8, Maybe DecimalMark, Maybe DigitGroupStyle)
p StorageFormat
"1,,1" StorageFormat
""
     JournalParser
  IO (Decimal, Word8, Maybe DecimalMark, Maybe DigitGroupStyle)
-> StorageFormat -> StorageFormat -> Assertion
forall a st.
(HasCallStack, Eq a, Show a, Default st) =>
StateT st (ParsecT CustomErr Text IO) a
-> StorageFormat -> StorageFormat -> Assertion
assertParseError JournalParser
  IO (Decimal, Word8, Maybe DecimalMark, Maybe DigitGroupStyle)
p StorageFormat
"1..1" StorageFormat
""
     JournalParser
  IO (Decimal, Word8, Maybe DecimalMark, Maybe DigitGroupStyle)
-> StorageFormat -> StorageFormat -> Assertion
forall a st.
(HasCallStack, Eq a, Show a, Default st) =>
StateT st (ParsecT CustomErr Text IO) a
-> StorageFormat -> StorageFormat -> Assertion
assertParseError JournalParser
  IO (Decimal, Word8, Maybe DecimalMark, Maybe DigitGroupStyle)
p StorageFormat
".1," StorageFormat
""
     JournalParser
  IO (Decimal, Word8, Maybe DecimalMark, Maybe DigitGroupStyle)
-> StorageFormat -> StorageFormat -> Assertion
forall a st.
(HasCallStack, Eq a, Show a, Default st) =>
StateT st (ParsecT CustomErr Text IO) a
-> StorageFormat -> StorageFormat -> Assertion
assertParseError JournalParser
  IO (Decimal, Word8, Maybe DecimalMark, Maybe DigitGroupStyle)
p StorageFormat
",1." StorageFormat
""
     JournalParser
  IO (Decimal, Word8, Maybe DecimalMark, Maybe DigitGroupStyle)
-> Text
-> (Decimal, Word8, Maybe DecimalMark, Maybe DigitGroupStyle)
-> Assertion
forall a st.
(HasCallStack, Eq a, Show a, Default st) =>
StateT st (ParsecT CustomErr Text IO) a -> Text -> a -> Assertion
assertParseEq    JournalParser
  IO (Decimal, Word8, Maybe DecimalMark, Maybe DigitGroupStyle)
p Text
"1.555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555" (Decimal
1.555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555, Word8
255, DecimalMark -> Maybe DecimalMark
forall a. a -> Maybe a
Just DecimalMark
'.', Maybe DigitGroupStyle
forall a. Maybe a
Nothing)
     JournalParser
  IO (Decimal, Word8, Maybe DecimalMark, Maybe DigitGroupStyle)
-> StorageFormat -> StorageFormat -> Assertion
forall a st.
(HasCallStack, Eq a, Show a, Default st) =>
StateT st (ParsecT CustomErr Text IO) a
-> StorageFormat -> StorageFormat -> Assertion
assertParseError JournalParser
  IO (Decimal, Word8, Maybe DecimalMark, Maybe DigitGroupStyle)
p StorageFormat
"1.5555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555555" StorageFormat
""

  ,StorageFormat -> [TestTree] -> TestTree
tests StorageFormat
"spaceandamountormissingp" [
     StorageFormat -> Assertion -> TestTree
test StorageFormat
"space and amount" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$ StateT Journal (ParsecT CustomErr Text IO) MixedAmount
-> Text -> MixedAmount -> Assertion
forall a st.
(HasCallStack, Eq a, Show a, Default st) =>
StateT st (ParsecT CustomErr Text IO) a -> Text -> a -> Assertion
assertParseEq StateT Journal (ParsecT CustomErr Text IO) MixedAmount
forall (m :: * -> *). JournalParser m MixedAmount
spaceandamountormissingp Text
" $47.18" ([Amount] -> MixedAmount
Mixed [Decimal -> Amount
usd Decimal
47.18])
    ,StorageFormat -> Assertion -> TestTree
test StorageFormat
"empty string" (Assertion -> TestTree) -> Assertion -> TestTree
forall a b. (a -> b) -> a -> b
$ StateT Journal (ParsecT CustomErr Text IO) MixedAmount
-> Text -> MixedAmount -> Assertion
forall a st.
(HasCallStack, Eq a, Show a, Default st) =>
StateT st (ParsecT CustomErr Text IO) a -> Text -> a -> Assertion
assertParseEq StateT Journal (ParsecT CustomErr Text IO) MixedAmount
forall (m :: * -> *). JournalParser m MixedAmount
spaceandamountormissingp Text
"" MixedAmount
missingmixedamt
    -- ,test "just space" $ assertParseEq spaceandamountormissingp " " missingmixedamt  -- XXX should it ?
    -- ,test "just amount" $ assertParseError spaceandamountormissingp "$47.18" ""  -- succeeds, consuming nothing
    ]

  ]