{-|

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 OverloadedStrings, PackageImports #-}

module Hledger.Read.TimedotReader (
  -- * Reader
  reader,
  -- * Misc other exports
  timedotfilep,
)
where
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.Maybe
import Data.Text (Text)
import Text.Megaparsec hiding (parse)
import Text.Megaparsec.Char

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

-- easier to toggle this here sometimes
-- import qualified Hledger.Utils (parsertrace)
-- parsertrace = Hledger.Utils.parsertrace
traceParse :: Monad m => a -> m a
traceParse :: a -> m a
traceParse = a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return

reader :: Reader
reader :: Reader
reader = Reader :: StorageFormat
-> [StorageFormat]
-> (InputOpts
    -> StorageFormat -> Text -> ExceptT StorageFormat IO Journal)
-> Bool
-> Reader
Reader
  {rFormat :: StorageFormat
rFormat     = "timedot"
  ,rExtensions :: [StorageFormat]
rExtensions = ["timedot"]
  ,rParser :: InputOpts
-> StorageFormat -> Text -> ExceptT StorageFormat IO Journal
rParser     = InputOpts
-> StorageFormat -> Text -> ExceptT StorageFormat IO Journal
parse
  ,rExperimental :: Bool
rExperimental = Bool
False
  }

-- | 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
timedotfilep

timedotfilep :: JournalParser m ParsedJournal
timedotfilep :: JournalParser m Journal
timedotfilep = do StateT Journal (ParsecT CustomErr Text m) ()
-> StateT Journal (ParsecT CustomErr Text m) [()]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many StateT Journal (ParsecT CustomErr Text m) ()
forall (m :: * -> *). JournalParser m ()
timedotfileitemp
                  StateT Journal (ParsecT CustomErr Text m) ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof
                  JournalParser m Journal
forall s (m :: * -> *). MonadState s m => m s
get
    where
      timedotfileitemp :: JournalParser m ()
      timedotfileitemp :: JournalParser m ()
timedotfileitemp = do
        StorageFormat
-> StateT Journal (ParsecT CustomErr Text m) StorageFormat
forall (m :: * -> *) a. Monad m => a -> m a
traceParse "timedotfileitemp"
        [JournalParser m ()] -> JournalParser m ()
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice [
          JournalParser m () -> JournalParser m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (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 ()
forall (m :: * -> *). TextParser m ()
emptyorcommentlinep
         ,JournalParser m [Transaction]
forall (m :: * -> *). JournalParser m [Transaction]
timedotdayp JournalParser m [Transaction]
-> ([Transaction] -> JournalParser m ()) -> JournalParser m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ts :: [Transaction]
ts -> (Journal -> Journal) -> JournalParser m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' ([Transaction] -> Journal -> Journal
addTransactions [Transaction]
ts)
         ] JournalParser m () -> StorageFormat -> JournalParser m ()
forall e s (m :: * -> *) a.
MonadParsec e s m =>
m a -> StorageFormat -> m a
<?> "timedot day entry, or default year or comment line or blank line"

addTransactions :: [Transaction] -> Journal -> Journal
addTransactions :: [Transaction] -> Journal -> Journal
addTransactions ts :: [Transaction]
ts j :: 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)

-- | Parse timedot day entries to zero or more time transactions for that day.
-- @
-- 2/1
-- fos.haskell  .... ..
-- biz.research .
-- inc.client1  .... .... .... .... .... ....
-- @
timedotdayp :: JournalParser m [Transaction]
timedotdayp :: JournalParser m [Transaction]
timedotdayp = do
  StorageFormat
-> StateT Journal (ParsecT CustomErr Text m) StorageFormat
forall (m :: * -> *) a. Monad m => a -> m a
traceParse " timedotdayp"
  Day
d <- JournalParser m Day
forall (m :: * -> *). JournalParser m Day
datep JournalParser m Day
-> StateT Journal (ParsecT CustomErr Text m) ()
-> JournalParser m Day
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* 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 (m :: * -> *). TextParser m ()
eolof
  [Transaction]
es <- [Maybe Transaction] -> [Transaction]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe Transaction] -> [Transaction])
-> StateT Journal (ParsecT CustomErr Text m) [Maybe Transaction]
-> JournalParser m [Transaction]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT Journal (ParsecT CustomErr Text m) (Maybe Transaction)
-> StateT Journal (ParsecT CustomErr Text m) [Maybe Transaction]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many (Maybe Transaction -> () -> Maybe Transaction
forall a b. a -> b -> a
const Maybe Transaction
forall a. Maybe a
Nothing (() -> Maybe Transaction)
-> StateT Journal (ParsecT CustomErr Text m) ()
-> StateT Journal (ParsecT CustomErr Text m) (Maybe Transaction)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT Journal (ParsecT CustomErr Text m) ()
-> StateT Journal (ParsecT CustomErr Text m) ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (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 (m :: * -> *). TextParser m ()
emptyorcommentlinep) StateT Journal (ParsecT CustomErr Text m) (Maybe Transaction)
-> StateT Journal (ParsecT CustomErr Text m) (Maybe Transaction)
-> StateT Journal (ParsecT CustomErr Text m) (Maybe Transaction)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
                            Transaction -> Maybe Transaction
forall a. a -> Maybe a
Just (Transaction -> Maybe Transaction)
-> StateT Journal (ParsecT CustomErr Text m) Transaction
-> StateT Journal (ParsecT CustomErr Text m) (Maybe Transaction)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (JournalParser m Day -> StateT Journal (ParsecT CustomErr Text m) ()
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
notFollowedBy JournalParser m Day
forall (m :: * -> *). JournalParser m Day
datep StateT Journal (ParsecT CustomErr Text m) ()
-> StateT Journal (ParsecT CustomErr Text m) Transaction
-> StateT Journal (ParsecT CustomErr Text m) Transaction
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> StateT Journal (ParsecT CustomErr Text m) Transaction
forall (m :: * -> *). JournalParser m Transaction
timedotentryp))
  [Transaction] -> JournalParser m [Transaction]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Transaction] -> JournalParser m [Transaction])
-> [Transaction] -> JournalParser m [Transaction]
forall a b. (a -> b) -> a -> b
$ (Transaction -> Transaction) -> [Transaction] -> [Transaction]
forall a b. (a -> b) -> [a] -> [b]
map (\t :: Transaction
t -> Transaction
t{tdate :: Day
tdate=Day
d}) [Transaction]
es -- <$> many timedotentryp

-- | Parse a single timedot entry to one (dateless) transaction.
-- @
-- fos.haskell  .... ..
-- @
timedotentryp :: JournalParser m Transaction
timedotentryp :: JournalParser m Transaction
timedotentryp = do
  StorageFormat
-> StateT Journal (ParsecT CustomErr Text m) StorageFormat
forall (m :: * -> *) a. Monad m => a -> m a
traceParse "  timedotentryp"
  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 e s (m :: * -> *). MonadParsec e s m => m SourcePos
getSourcePos
  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 Char -> ParsecT CustomErr Text m ()
forall (m :: * -> *) a. MonadPlus m => m a -> m ()
skipMany ParsecT CustomErr Text m Char
forall s (m :: * -> *).
(Stream s, Char ~ Token s) =>
ParsecT CustomErr s m Char
spacenonewline)
  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 Char -> ParsecT CustomErr Text m ()
forall (m :: * -> *) a. MonadPlus m => m a -> m ()
skipMany ParsecT CustomErr Text m Char
forall s (m :: * -> *).
(Stream s, Char ~ Token s) =>
ParsecT CustomErr s m Char
spacenonewline)
  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 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
timedotdurationp 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 "")))
  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 [Int -> Amount -> Amount
setAmountPrecision 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
                     }
          ]
        }
  Transaction -> JournalParser m Transaction
forall (m :: * -> *) a. Monad m => a -> m a
return Transaction
t

timedotdurationp :: JournalParser m Quantity
timedotdurationp :: JournalParser m Quantity
timedotdurationp = 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
timedotnumericp 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
timedotdotsp

-- | 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
-- @
timedotnumericp :: JournalParser m Quantity
timedotnumericp :: JournalParser m Quantity
timedotnumericp = do
  (q :: Quantity
q, _, _, _) <- ParsecT
  CustomErr Text m (Quantity, Int, Maybe Char, Maybe DigitGroupStyle)
-> StateT
     Journal
     (ParsecT CustomErr Text m)
     (Quantity, Int, Maybe Char, Maybe DigitGroupStyle)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ParsecT
   CustomErr Text m (Quantity, Int, Maybe Char, Maybe DigitGroupStyle)
 -> StateT
      Journal
      (ParsecT CustomErr Text m)
      (Quantity, Int, Maybe Char, Maybe DigitGroupStyle))
-> ParsecT
     CustomErr Text m (Quantity, Int, Maybe Char, Maybe DigitGroupStyle)
-> StateT
     Journal
     (ParsecT CustomErr Text m)
     (Quantity, Int, Maybe Char, Maybe DigitGroupStyle)
forall a b. (a -> b) -> a -> b
$ Maybe AmountStyle
-> ParsecT
     CustomErr Text m (Quantity, Int, Maybe Char, Maybe DigitGroupStyle)
forall (m :: * -> *).
Maybe AmountStyle
-> TextParser m (Quantity, Int, 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 Char -> ParsecT CustomErr Text m ()
forall (m :: * -> *) a. MonadPlus m => m a -> m ()
skipMany ParsecT CustomErr Text m Char
forall s (m :: * -> *).
(Stream s, Char ~ Token s) =>
ParsecT CustomErr s m Char
spacenonewline)
  let q' :: Quantity
q' =
        case Maybe Text
msymbol of
          Nothing  -> Quantity
q
          Just sym :: 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 mult :: Quantity
mult -> Quantity
q Quantity -> Quantity -> Quantity
forall a. Num a => a -> a -> a
* Quantity
mult
              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 =
  [("s",2.777777777777778e-4)
  ,("mo",5040) -- before "m"
  ,("m",1.6666666666666666e-2)
  ,("h",1)
  ,("d",24)
  ,("w",168)
  ,("y",61320)
  ]

-- | Parse a quantity written as a line of dots, each representing 0.25.
-- @
-- .... ..
-- @
timedotdotsp :: JournalParser m Quantity
timedotdotsp :: JournalParser m Quantity
timedotdotsp = do
  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 (". " :: [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
$ (Quantity -> Quantity -> Quantity
forall a. Fractional a => a -> a -> a
/4) (Quantity -> Quantity) -> Quantity -> Quantity
forall a b. (a -> b) -> a -> b
$ Int -> Quantity
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Quantity) -> Int -> Quantity
forall a b. (a -> b) -> a -> b
$ StorageFormat -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length StorageFormat
dots