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

A reader for the "timedot" file format.
Example:

@
#DATE
#ACCT  DOTS  # Each dot represents 15m, spaces are ignored
#ACCT  8    # numbers with or without a following h represent hours
#ACCT  5m   # numbers followed by m represent minutes

# on 2/1, 1h was spent on FOSS haskell work, 0.25h on research, etc.
2/1
fos.haskell   .... ..
biz.research  .
inc.client1   .... .... .... .... .... ....

2/2
biz.research  .
inc.client1   .... .... ..

@

-}

--- ** language
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-}

--- ** exports
module Hledger.Read.TimedotReader (
  -- * Reader
  reader,
  -- * Misc other exports
  timedotfilep,
)
where

--- ** imports
import Prelude ()
import "base-compat-batteries" Prelude.Compat
import Control.Monad
import Control.Monad.Except (ExceptT)
import Control.Monad.State.Strict
import Data.Char (isSpace)
import Data.List (foldl')
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time (Day)
import Text.Megaparsec hiding (parse)
import Text.Megaparsec.Char

import Hledger.Data
import Hledger.Read.Common hiding (emptyorcommentlinep)
import Hledger.Utils

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

--- ** reader

reader :: MonadIO m => Reader m
reader :: Reader m
reader = Reader :: forall (m :: * -> *).
StorageFormat
-> [StorageFormat]
-> (InputOpts
    -> StorageFormat -> Text -> ExceptT StorageFormat IO Journal)
-> (MonadIO m => ErroringJournalParser m Journal)
-> Reader m
Reader
  {rFormat :: StorageFormat
rFormat     = StorageFormat
"timedot"
  ,rExtensions :: [StorageFormat]
rExtensions = [StorageFormat
"timedot"]
  ,rReadFn :: InputOpts
-> StorageFormat -> Text -> ExceptT StorageFormat IO Journal
rReadFn     = InputOpts
-> StorageFormat -> Text -> ExceptT StorageFormat IO Journal
parse
  ,rParser :: MonadIO m => ErroringJournalParser m Journal
rParser    = MonadIO m => ErroringJournalParser m Journal
forall (m :: * -> *). JournalParser m Journal
timedotp
  }

-- | Parse and post-process a "Journal" from the timedot format, or give an error.
parse :: InputOpts -> FilePath -> Text -> ExceptT String IO Journal
parse :: InputOpts
-> StorageFormat -> Text -> ExceptT StorageFormat IO Journal
parse = JournalParser IO Journal
-> InputOpts
-> StorageFormat
-> Text
-> ExceptT StorageFormat IO Journal
parseAndFinaliseJournal' JournalParser IO Journal
forall (m :: * -> *). JournalParser m Journal
timedotp

--- ** utilities

traceparse, traceparse' :: String -> TextParser m ()
traceparse :: StorageFormat -> TextParser m ()
traceparse  = TextParser m () -> StorageFormat -> TextParser m ()
forall a b. a -> b -> a
const (TextParser m () -> StorageFormat -> TextParser m ())
-> TextParser m () -> StorageFormat -> TextParser m ()
forall a b. (a -> b) -> a -> b
$ () -> TextParser m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
traceparse' :: StorageFormat -> TextParser m ()
traceparse' = TextParser m () -> StorageFormat -> TextParser m ()
forall a b. a -> b -> a
const (TextParser m () -> StorageFormat -> TextParser m ())
-> TextParser m () -> StorageFormat -> TextParser m ()
forall a b. (a -> b) -> a -> b
$ () -> TextParser m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
-- for debugging:
-- traceparse  s = traceParse (s++"?")
-- traceparse' s = trace s $ return ()

--- ** parsers
{-
Rough grammar for timedot format:

timedot:           preamble day*
preamble:          (emptyline | commentline | orgheading)*
orgheading:        orgheadingprefix restofline
day:               dateline entry* (emptyline | commentline)*
dateline:          orgheadingprefix? date description?
orgheadingprefix:  star+ space+
description:       restofline  ; till semicolon?
entry:          orgheadingprefix? space* singlespaced (doublespace quantity?)?
doublespace:       space space+
quantity:          (dot (dot | space)* | number | number unit)

Date lines and item lines can begin with an org heading prefix, which is ignored.
Org headings before the first date line are ignored, regardless of content.
-}

timedotfilep :: JournalParser m Journal
timedotfilep = JournalParser m Journal
forall (m :: * -> *). JournalParser m Journal
timedotp -- XXX rename export above

timedotp :: JournalParser m ParsedJournal
timedotp :: JournalParser m Journal
timedotp = JournalParser m ()
forall (m :: * -> *). JournalParser m ()
preamblep JournalParser m ()
-> StateT Journal (ParsecT CustomErr Text m) [()]
-> StateT Journal (ParsecT CustomErr Text m) [()]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> JournalParser m ()
-> StateT Journal (ParsecT CustomErr Text m) [()]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many JournalParser m ()
forall (m :: * -> *). JournalParser m ()
dayp StateT Journal (ParsecT CustomErr Text m) [()]
-> JournalParser m () -> JournalParser m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> JournalParser m ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof JournalParser m ()
-> JournalParser m Journal -> JournalParser m Journal
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> JournalParser m Journal
forall s (m :: * -> *). MonadState s m => m s
get

preamblep :: JournalParser m ()
preamblep :: JournalParser m ()
preamblep = do
  ParsecT CustomErr Text m () -> JournalParser m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ParsecT CustomErr Text m () -> JournalParser m ())
-> ParsecT CustomErr Text m () -> JournalParser m ()
forall a b. (a -> b) -> a -> b
$ StorageFormat -> ParsecT CustomErr Text m ()
forall (m :: * -> *). StorageFormat -> TextParser m ()
traceparse StorageFormat
"preamblep"
  JournalParser m ()
-> StateT Journal (ParsecT CustomErr Text m) [()]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many (JournalParser m ()
 -> StateT Journal (ParsecT CustomErr Text m) [()])
-> JournalParser m ()
-> StateT Journal (ParsecT CustomErr Text m) [()]
forall a b. (a -> b) -> a -> b
$ StateT Journal (ParsecT CustomErr Text m) (Day, Text)
-> JournalParser m ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
notFollowedBy StateT Journal (ParsecT CustomErr Text m) (Day, Text)
forall (m :: * -> *). JournalParser m (Day, Text)
datelinep JournalParser m () -> JournalParser m () -> JournalParser m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m 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 () -> JournalParser m ())
-> ParsecT CustomErr Text m () -> JournalParser m ()
forall a b. (a -> b) -> a -> b
$ StorageFormat -> ParsecT CustomErr Text m ()
forall (m :: * -> *). StorageFormat -> TextParser m ()
emptyorcommentlinep StorageFormat
"#;*")
  ParsecT CustomErr Text m () -> JournalParser m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ParsecT CustomErr Text m () -> JournalParser m ())
-> ParsecT CustomErr Text m () -> JournalParser m ()
forall a b. (a -> b) -> a -> b
$ StorageFormat -> ParsecT CustomErr Text m ()
forall (m :: * -> *). StorageFormat -> TextParser m ()
traceparse' StorageFormat
"preamblep"

-- | Parse timedot day entries to zero or more time transactions for that day.
-- @
-- 2020/2/1 optional day description
-- fos.haskell  .... ..
-- biz.research .
-- inc.client1  .... .... .... .... .... ....
-- @
dayp :: JournalParser m ()
dayp :: JournalParser m ()
dayp = StorageFormat -> JournalParser m () -> JournalParser m ()
forall e s (m :: * -> *) a.
MonadParsec e s m =>
StorageFormat -> m a -> m a
label StorageFormat
"timedot day entry" (JournalParser m () -> JournalParser m ())
-> JournalParser m () -> JournalParser m ()
forall a b. (a -> b) -> a -> b
$ do
  ParsecT CustomErr Text m () -> JournalParser m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ParsecT CustomErr Text m () -> JournalParser m ())
-> ParsecT CustomErr Text m () -> JournalParser m ()
forall a b. (a -> b) -> a -> b
$ StorageFormat -> ParsecT CustomErr Text m ()
forall (m :: * -> *). StorageFormat -> TextParser m ()
traceparse StorageFormat
"dayp"
  (Day
d,Text
desc) <- JournalParser m (Day, Text)
forall (m :: * -> *). JournalParser m (Day, Text)
datelinep
  JournalParser m ()
forall (m :: * -> *). JournalParser m ()
commentlinesp
  [Transaction]
ts <- StateT Journal (ParsecT CustomErr Text m) Transaction
-> StateT Journal (ParsecT CustomErr Text m) [Transaction]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many (StateT Journal (ParsecT CustomErr Text m) Transaction
 -> StateT Journal (ParsecT CustomErr Text m) [Transaction])
-> StateT Journal (ParsecT CustomErr Text m) Transaction
-> StateT Journal (ParsecT CustomErr Text m) [Transaction]
forall a b. (a -> b) -> a -> b
$ StateT Journal (ParsecT CustomErr Text m) Transaction
forall (m :: * -> *). JournalParser m Transaction
entryp StateT Journal (ParsecT CustomErr Text m) Transaction
-> JournalParser m ()
-> StateT Journal (ParsecT CustomErr Text m) Transaction
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* JournalParser m ()
forall (m :: * -> *). JournalParser m ()
commentlinesp
  (Journal -> Journal) -> JournalParser m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' ((Journal -> Journal) -> JournalParser m ())
-> (Journal -> Journal) -> JournalParser m ()
forall a b. (a -> b) -> a -> b
$ [Transaction] -> Journal -> Journal
addTransactions ([Transaction] -> Journal -> Journal)
-> [Transaction] -> Journal -> Journal
forall a b. (a -> b) -> a -> b
$ (Transaction -> Transaction) -> [Transaction] -> [Transaction]
forall a b. (a -> b) -> [a] -> [b]
map (\Transaction
t -> Transaction
t{tdate :: Day
tdate=Day
d, tdescription :: Text
tdescription=Text
desc}) [Transaction]
ts
  ParsecT CustomErr Text m () -> JournalParser m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ParsecT CustomErr Text m () -> JournalParser m ())
-> ParsecT CustomErr Text m () -> JournalParser m ()
forall a b. (a -> b) -> a -> b
$ StorageFormat -> ParsecT CustomErr Text m ()
forall (m :: * -> *). StorageFormat -> TextParser m ()
traceparse' StorageFormat
"dayp"
  where
    addTransactions :: [Transaction] -> Journal -> Journal
    addTransactions :: [Transaction] -> Journal -> Journal
addTransactions [Transaction]
ts Journal
j = (Journal -> (Journal -> Journal) -> Journal)
-> Journal -> [Journal -> Journal] -> Journal
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (((Journal -> Journal) -> Journal -> Journal)
-> Journal -> (Journal -> Journal) -> Journal
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Journal -> Journal) -> Journal -> Journal
forall a b. (a -> b) -> a -> b
($)) Journal
j ((Transaction -> Journal -> Journal)
-> [Transaction] -> [Journal -> Journal]
forall a b. (a -> b) -> [a] -> [b]
map Transaction -> Journal -> Journal
addTransaction [Transaction]
ts)

datelinep :: JournalParser m (Day,Text)
datelinep :: JournalParser m (Day, Text)
datelinep = 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
$ StorageFormat -> ParsecT CustomErr Text m ()
forall (m :: * -> *). StorageFormat -> TextParser m ()
traceparse StorageFormat
"datelinep"
  ParsecT CustomErr Text m (Maybe ())
-> StateT Journal (ParsecT CustomErr Text m) (Maybe ())
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ParsecT CustomErr Text m (Maybe ())
 -> StateT Journal (ParsecT CustomErr Text m) (Maybe ()))
-> ParsecT CustomErr Text m (Maybe ())
-> StateT Journal (ParsecT CustomErr Text m) (Maybe ())
forall a b. (a -> b) -> a -> b
$ ParsecT CustomErr Text m () -> ParsecT CustomErr Text m (Maybe ())
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional ParsecT CustomErr Text m ()
forall (m :: * -> *). ParsecT CustomErr Text m ()
orgheadingprefixp
  Day
d <- JournalParser m Day
forall (m :: * -> *). JournalParser m Day
datep
  StorageFormat
desc <- StorageFormat -> StorageFormat
strip (StorageFormat -> StorageFormat)
-> StateT Journal (ParsecT CustomErr Text m) StorageFormat
-> StateT Journal (ParsecT CustomErr Text m) StorageFormat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT CustomErr Text m StorageFormat
-> StateT Journal (ParsecT CustomErr Text m) StorageFormat
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift ParsecT CustomErr Text m StorageFormat
forall (m :: * -> *). TextParser m StorageFormat
restofline
  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
$ StorageFormat -> ParsecT CustomErr Text m ()
forall (m :: * -> *). StorageFormat -> TextParser m ()
traceparse' StorageFormat
"datelinep"
  (Day, Text) -> JournalParser m (Day, Text)
forall (m :: * -> *) a. Monad m => a -> m a
return (Day
d, StorageFormat -> Text
T.pack StorageFormat
desc)

-- | Zero or more empty lines or hash/semicolon comment lines
-- or org headlines which do not start a new day.
commentlinesp :: JournalParser m ()
commentlinesp :: JournalParser m ()
commentlinesp = do
  ParsecT CustomErr Text m () -> JournalParser m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ParsecT CustomErr Text m () -> JournalParser m ())
-> ParsecT CustomErr Text m () -> JournalParser m ()
forall a b. (a -> b) -> a -> b
$ StorageFormat -> ParsecT CustomErr Text m ()
forall (m :: * -> *). StorageFormat -> TextParser m ()
traceparse StorageFormat
"commentlinesp"
  StateT Journal (ParsecT CustomErr Text m) [()]
-> JournalParser m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (StateT Journal (ParsecT CustomErr Text m) [()]
 -> JournalParser m ())
-> StateT Journal (ParsecT CustomErr Text m) [()]
-> JournalParser m ()
forall a b. (a -> b) -> a -> b
$ JournalParser m ()
-> StateT Journal (ParsecT CustomErr Text m) [()]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many (JournalParser m ()
 -> StateT Journal (ParsecT CustomErr Text m) [()])
-> JournalParser m ()
-> StateT Journal (ParsecT CustomErr Text m) [()]
forall a b. (a -> b) -> a -> b
$ JournalParser m () -> JournalParser m ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (JournalParser m () -> JournalParser m ())
-> JournalParser m () -> JournalParser m ()
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 () -> JournalParser m ())
-> ParsecT CustomErr Text m () -> JournalParser m ()
forall a b. (a -> b) -> a -> b
$ StorageFormat -> ParsecT CustomErr Text m ()
forall (m :: * -> *). StorageFormat -> TextParser m ()
emptyorcommentlinep StorageFormat
"#;"

-- orgnondatelinep :: JournalParser m ()
-- orgnondatelinep = do
--   lift $ traceparse "orgnondatelinep"
--   lift orgheadingprefixp
--   notFollowedBy datelinep
--   void $ lift restofline
--   lift $ traceparse' "orgnondatelinep"

orgheadingprefixp :: ParsecT CustomErr Text m ()
orgheadingprefixp = do
  -- traceparse "orgheadingprefixp"
  ParsecT CustomErr Text m Char -> ParsecT CustomErr Text m ()
forall (m :: * -> *) a. MonadPlus m => m a -> m ()
skipSome (Token Text -> ParsecT CustomErr Text m (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'*') ParsecT CustomErr Text m ()
-> ParsecT CustomErr Text m () -> ParsecT CustomErr Text m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ParsecT CustomErr Text m ()
forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT CustomErr s m ()
skipNonNewlineSpaces1

-- | Parse a single timedot entry to one (dateless) transaction.
-- @
-- fos.haskell  .... ..
-- @
entryp :: JournalParser m Transaction
entryp :: JournalParser m Transaction
entryp = 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
$ StorageFormat -> ParsecT CustomErr Text m ()
forall (m :: * -> *). StorageFormat -> TextParser m ()
traceparse StorageFormat
"entryp"
  GenericSourcePos
pos <- 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
<$> StateT Journal (ParsecT CustomErr Text m) SourcePos
forall s e (m :: * -> *).
(TraversableStream s, MonadParsec e s m) =>
m SourcePos
getSourcePos
  StateT Journal (ParsecT CustomErr Text m) (Day, Text)
-> StateT Journal (ParsecT CustomErr Text m) ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
notFollowedBy StateT Journal (ParsecT CustomErr Text m) (Day, Text)
forall (m :: * -> *). JournalParser m (Day, Text)
datelinep
  ParsecT CustomErr Text m (Maybe ())
-> StateT Journal (ParsecT CustomErr Text m) (Maybe ())
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ParsecT CustomErr Text m (Maybe ())
 -> StateT Journal (ParsecT CustomErr Text m) (Maybe ()))
-> ParsecT CustomErr Text m (Maybe ())
-> StateT Journal (ParsecT CustomErr Text m) (Maybe ())
forall a b. (a -> b) -> a -> b
$ ParsecT CustomErr Text m () -> ParsecT CustomErr Text m (Maybe ())
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (ParsecT CustomErr Text m ()
 -> ParsecT CustomErr Text m (Maybe ()))
-> ParsecT CustomErr Text m ()
-> ParsecT CustomErr Text m (Maybe ())
forall a b. (a -> b) -> a -> b
$ [ParsecT CustomErr Text m ()] -> ParsecT CustomErr Text m ()
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice [ParsecT CustomErr Text m ()
forall (m :: * -> *). ParsecT CustomErr Text m ()
orgheadingprefixp, ParsecT CustomErr Text m ()
forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT CustomErr s m ()
skipNonNewlineSpaces1]
  Text
a <- JournalParser m Text
forall (m :: * -> *). JournalParser m Text
modifiedaccountnamep
  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 ~ Char) =>
ParsecT CustomErr s m ()
skipNonNewlineSpaces
  Quantity
hours <-
    StateT Journal (ParsecT CustomErr Text m) Quantity
-> StateT Journal (ParsecT CustomErr Text m) Quantity
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (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
followingcommentp JournalParser m Text
-> StateT Journal (ParsecT CustomErr Text m) Quantity
-> StateT Journal (ParsecT CustomErr Text m) Quantity
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Quantity -> StateT Journal (ParsecT CustomErr Text m) Quantity
forall (m :: * -> *) a. Monad m => a -> m a
return Quantity
0)
    StateT Journal (ParsecT CustomErr Text m) Quantity
-> StateT Journal (ParsecT CustomErr Text m) Quantity
-> StateT Journal (ParsecT CustomErr Text m) Quantity
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (StateT Journal (ParsecT CustomErr Text m) Quantity
forall (m :: * -> *). JournalParser m Quantity
durationp StateT Journal (ParsecT CustomErr Text m) Quantity
-> JournalParser m Text
-> StateT Journal (ParsecT CustomErr Text m) Quantity
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<*
         (JournalParser m Text -> JournalParser m Text
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (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
followingcommentp) JournalParser m Text
-> JournalParser m Text -> JournalParser m Text
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (StateT Journal (ParsecT CustomErr Text m) Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
newline StateT Journal (ParsecT CustomErr Text m) Char
-> JournalParser m Text -> JournalParser m Text
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Text -> JournalParser m Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
"")))
  let t :: Transaction
t = Transaction
nulltransaction{
        tsourcepos :: GenericSourcePos
tsourcepos = GenericSourcePos
pos,
        tstatus :: Status
tstatus    = Status
Cleared,
        tpostings :: [Posting]
tpostings  = [
          Posting
nullposting{paccount :: Text
paccount=Text
a
                     ,pamount :: MixedAmount
pamount=[Amount] -> MixedAmount
Mixed [AmountPrecision -> Amount -> Amount
amountSetPrecision (Word8 -> AmountPrecision
Precision Word8
2) (Amount -> Amount) -> Amount -> Amount
forall a b. (a -> b) -> a -> b
$ Quantity -> Amount
num Quantity
hours]  -- don't assume hours; do set precision to 2
                     ,ptype :: PostingType
ptype=PostingType
VirtualPosting
                     ,ptransaction :: Maybe Transaction
ptransaction=Transaction -> Maybe Transaction
forall a. a -> Maybe a
Just Transaction
t
                     }
          ]
        }
  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
$ StorageFormat -> ParsecT CustomErr Text m ()
forall (m :: * -> *). StorageFormat -> TextParser m ()
traceparse' StorageFormat
"entryp"
  Transaction -> JournalParser m Transaction
forall (m :: * -> *) a. Monad m => a -> m a
return Transaction
t

durationp :: JournalParser m Quantity
durationp :: JournalParser m Quantity
durationp = 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
$ StorageFormat -> ParsecT CustomErr Text m ()
forall (m :: * -> *). StorageFormat -> TextParser m ()
traceparse StorageFormat
"durationp"
  JournalParser m Quantity -> JournalParser m Quantity
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try JournalParser m Quantity
forall (m :: * -> *). JournalParser m Quantity
numericquantityp JournalParser m Quantity
-> JournalParser m Quantity -> JournalParser m Quantity
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> JournalParser m Quantity
forall (m :: * -> *). JournalParser m Quantity
dotquantityp
    -- <* traceparse' "durationp"

-- | Parse a duration of seconds, minutes, hours, days, weeks, months or years,
-- written as a decimal number followed by s, m, h, d, w, mo or y, assuming h
-- if there is no unit. Returns the duration as hours, assuming
-- 1m = 60s, 1h = 60m, 1d = 24h, 1w = 7d, 1mo = 30d, 1y=365d.
-- @
-- 1.5
-- 1.5h
-- 90m
-- @
numericquantityp :: JournalParser m Quantity
numericquantityp :: JournalParser m Quantity
numericquantityp = do
  -- lift $ traceparse "numericquantityp"
  (Quantity
q, Word8
_, Maybe Char
_, Maybe DigitGroupStyle
_) <- ParsecT
  CustomErr
  Text
  m
  (Quantity, Word8, Maybe Char, Maybe DigitGroupStyle)
-> StateT
     Journal
     (ParsecT CustomErr Text m)
     (Quantity, Word8, Maybe Char, Maybe DigitGroupStyle)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ParsecT
   CustomErr
   Text
   m
   (Quantity, Word8, Maybe Char, Maybe DigitGroupStyle)
 -> StateT
      Journal
      (ParsecT CustomErr Text m)
      (Quantity, Word8, Maybe Char, Maybe DigitGroupStyle))
-> ParsecT
     CustomErr
     Text
     m
     (Quantity, Word8, Maybe Char, Maybe DigitGroupStyle)
-> StateT
     Journal
     (ParsecT CustomErr Text m)
     (Quantity, Word8, Maybe Char, Maybe DigitGroupStyle)
forall a b. (a -> b) -> a -> b
$ Maybe AmountStyle
-> ParsecT
     CustomErr
     Text
     m
     (Quantity, Word8, Maybe Char, Maybe DigitGroupStyle)
forall (m :: * -> *).
Maybe AmountStyle
-> TextParser
     m (Quantity, Word8, Maybe Char, Maybe DigitGroupStyle)
numberp Maybe AmountStyle
forall a. Maybe a
Nothing
  Maybe Text
msymbol <- StateT Journal (ParsecT CustomErr Text m) Text
-> StateT Journal (ParsecT CustomErr Text m) (Maybe Text)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (StateT Journal (ParsecT CustomErr Text m) Text
 -> StateT Journal (ParsecT CustomErr Text m) (Maybe Text))
-> StateT Journal (ParsecT CustomErr Text m) Text
-> StateT Journal (ParsecT CustomErr Text m) (Maybe Text)
forall a b. (a -> b) -> a -> b
$ [StateT Journal (ParsecT CustomErr Text m) Text]
-> StateT Journal (ParsecT CustomErr Text m) Text
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice ([StateT Journal (ParsecT CustomErr Text m) Text]
 -> StateT Journal (ParsecT CustomErr Text m) Text)
-> [StateT Journal (ParsecT CustomErr Text m) Text]
-> StateT Journal (ParsecT CustomErr Text m) Text
forall a b. (a -> b) -> a -> b
$ ((Text, Quantity)
 -> StateT Journal (ParsecT CustomErr Text m) Text)
-> [(Text, Quantity)]
-> [StateT Journal (ParsecT CustomErr Text m) Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> StateT Journal (ParsecT CustomErr Text m) Text
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string (Text -> StateT Journal (ParsecT CustomErr Text m) Text)
-> ((Text, Quantity) -> Text)
-> (Text, Quantity)
-> StateT Journal (ParsecT CustomErr Text m) Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Quantity) -> Text
forall a b. (a, b) -> a
fst) [(Text, Quantity)]
timeUnits
  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 ~ Char) =>
ParsecT CustomErr s m ()
skipNonNewlineSpaces
  let q' :: Quantity
q' =
        case Maybe Text
msymbol of
          Maybe Text
Nothing  -> Quantity
q
          Just Text
sym ->
            case Text -> [(Text, Quantity)] -> Maybe Quantity
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
sym [(Text, Quantity)]
timeUnits of
              Just Quantity
mult -> Quantity
q Quantity -> Quantity -> Quantity
forall a. Num a => a -> a -> a
* Quantity
mult
              Maybe Quantity
Nothing   -> Quantity
q  -- shouldn't happen.. ignore
  Quantity -> JournalParser m Quantity
forall (m :: * -> *) a. Monad m => a -> m a
return Quantity
q'

-- (symbol, equivalent in hours).
timeUnits :: [(Text, Quantity)]
timeUnits =
  [(Text
"s",Quantity
2.777777777777778e-4)
  ,(Text
"mo",Quantity
5040) -- before "m"
  ,(Text
"m",Quantity
1.6666666666666666e-2)
  ,(Text
"h",Quantity
1)
  ,(Text
"d",Quantity
24)
  ,(Text
"w",Quantity
168)
  ,(Text
"y",Quantity
61320)
  ]

-- | Parse a quantity written as a line of dots, each representing 0.25.
-- @
-- .... ..
-- @
dotquantityp :: JournalParser m Quantity
dotquantityp :: JournalParser m Quantity
dotquantityp = do
  -- lift $ traceparse "dotquantityp"
  StorageFormat
dots <- (Char -> Bool) -> StorageFormat -> StorageFormat
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not(Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Char -> Bool
isSpace) (StorageFormat -> StorageFormat)
-> StateT Journal (ParsecT CustomErr Text m) StorageFormat
-> StateT Journal (ParsecT CustomErr Text m) StorageFormat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT Journal (ParsecT CustomErr Text m) Char
-> StateT Journal (ParsecT CustomErr Text m) StorageFormat
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many ([Token Text]
-> StateT Journal (ParsecT CustomErr Text m) (Token Text)
forall (f :: * -> *) e s (m :: * -> *).
(Foldable f, MonadParsec e s m) =>
f (Token s) -> m (Token s)
oneOf (StorageFormat
". " :: [Char]))
  Quantity -> JournalParser m Quantity
forall (m :: * -> *) a. Monad m => a -> m a
return (Quantity -> JournalParser m Quantity)
-> Quantity -> JournalParser m Quantity
forall a b. (a -> b) -> a -> b
$ Int -> Quantity
forall a b. (Integral a, Num b) => a -> b
fromIntegral (StorageFormat -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length StorageFormat
dots) Quantity -> Quantity -> Quantity
forall a. Fractional a => a -> a -> a
/ Quantity
4

-- | XXX new comment line parser, move to Hledger.Read.Common.emptyorcommentlinep
-- Parse empty lines, all-blank lines, and lines beginning with any of the provided
-- comment-beginning characters.
emptyorcommentlinep :: [Char] -> TextParser m ()
emptyorcommentlinep :: StorageFormat -> TextParser m ()
emptyorcommentlinep StorageFormat
cs =
  StorageFormat -> TextParser m () -> TextParser m ()
forall e s (m :: * -> *) a.
MonadParsec e s m =>
StorageFormat -> m a -> m a
label (StorageFormat
"empty line or comment line beginning with "StorageFormat -> StorageFormat -> StorageFormat
forall a. [a] -> [a] -> [a]
++StorageFormat
cs) (TextParser m () -> TextParser m ())
-> TextParser m () -> TextParser m ()
forall a b. (a -> b) -> a -> b
$ do
    StorageFormat -> TextParser m ()
forall (m :: * -> *). StorageFormat -> TextParser m ()
traceparse StorageFormat
"emptyorcommentlinep" -- XXX possible to combine label and traceparse ?
    TextParser m ()
forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT CustomErr s m ()
skipNonNewlineSpaces
    ParsecT CustomErr Text m Char -> TextParser m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ParsecT CustomErr Text m Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
newline TextParser m () -> TextParser m () -> TextParser m ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT CustomErr Text m (Tokens Text) -> TextParser m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void ParsecT CustomErr Text m (Tokens Text)
commentp
    StorageFormat -> TextParser m ()
forall (m :: * -> *). StorageFormat -> TextParser m ()
traceparse' StorageFormat
"emptyorcommentlinep"
    where
      commentp :: ParsecT CustomErr Text m (Tokens Text)
commentp = do
        [ParsecT CustomErr Text m StorageFormat]
-> ParsecT CustomErr Text m StorageFormat
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice ((Char -> ParsecT CustomErr Text m StorageFormat)
-> StorageFormat -> [ParsecT CustomErr Text m StorageFormat]
forall a b. (a -> b) -> [a] -> [b]
map (ParsecT CustomErr Text m Char
-> ParsecT CustomErr Text m StorageFormat
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some(ParsecT CustomErr Text m Char
 -> ParsecT CustomErr Text m StorageFormat)
-> (Char -> ParsecT CustomErr Text m Char)
-> Char
-> ParsecT CustomErr Text m StorageFormat
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Char -> ParsecT CustomErr Text m Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char) StorageFormat
cs)
        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 (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/=Char
'\n') ParsecT CustomErr Text m (Tokens Text)
-> ParsecT CustomErr Text m Char
-> ParsecT CustomErr Text m (Tokens Text)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT CustomErr Text m Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
newline