{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-}
module Hledger.Read.TimedotReader (
reader,
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.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
reader :: MonadIO m => Reader m
reader = Reader
{rFormat = "timedot"
,rExtensions = ["timedot"]
,rReadFn = parse
,rParser = timedotp
}
parse :: InputOpts -> FilePath -> Text -> ExceptT String IO Journal
parse = parseAndFinaliseJournal' timedotp
traceparse, traceparse' :: String -> TextParser m ()
traceparse = const $ return ()
traceparse' = const $ return ()
timedotfilep = timedotp
timedotp :: JournalParser m ParsedJournal
timedotp = preamblep >> many dayp >> eof >> get
preamblep :: JournalParser m ()
preamblep = do
lift $ traceparse "preamblep"
many $ notFollowedBy datelinep >> (lift $ emptyorcommentlinep "#;*")
lift $ traceparse' "preamblep"
dayp :: JournalParser m ()
dayp = label "timedot day entry" $ do
lift $ traceparse "dayp"
(d,desc) <- datelinep
commentlinesp
ts <- many $ entryp <* commentlinesp
modify' $ addTransactions $ map (\t -> t{tdate=d, tdescription=desc}) ts
lift $ traceparse' "dayp"
where
addTransactions :: [Transaction] -> Journal -> Journal
addTransactions ts j = foldl' (flip ($)) j (map addTransaction ts)
datelinep :: JournalParser m (Day,Text)
datelinep = do
lift $ traceparse "datelinep"
lift $ optional orgheadingprefixp
d <- datep
desc <- strip <$> lift restofline
lift $ traceparse' "datelinep"
return (d, T.pack desc)
commentlinesp :: JournalParser m ()
commentlinesp = do
lift $ traceparse "commentlinesp"
void $ many $ try $ lift $ emptyorcommentlinep "#;"
orgheadingprefixp = do
skipSome (char '*') >> skipNonNewlineSpaces1
entryp :: JournalParser m Transaction
entryp = do
lift $ traceparse "entryp"
pos <- genericSourcePos <$> getSourcePos
notFollowedBy datelinep
lift $ optional $ choice [orgheadingprefixp, skipNonNewlineSpaces1]
a <- modifiedaccountnamep
lift skipNonNewlineSpaces
hours <-
try (lift followingcommentp >> return 0)
<|> (durationp <*
(try (lift followingcommentp) <|> (newline >> return "")))
let t = nulltransaction{
tsourcepos = pos,
tstatus = Cleared,
tpostings = [
nullposting{paccount=a
,pamount=Mixed [setAmountPrecision (Precision 2) $ num hours]
,ptype=VirtualPosting
,ptransaction=Just t
}
]
}
lift $ traceparse' "entryp"
return t
durationp :: JournalParser m Quantity
durationp = do
lift $ traceparse "durationp"
try numericquantityp <|> dotquantityp
numericquantityp :: JournalParser m Quantity
numericquantityp = do
(q, _, _, _) <- lift $ numberp Nothing
msymbol <- optional $ choice $ map (string . fst) timeUnits
lift skipNonNewlineSpaces
let q' =
case msymbol of
Nothing -> q
Just sym ->
case lookup sym timeUnits of
Just mult -> q * mult
Nothing -> q
return q'
timeUnits =
[("s",2.777777777777778e-4)
,("mo",5040)
,("m",1.6666666666666666e-2)
,("h",1)
,("d",24)
,("w",168)
,("y",61320)
]
dotquantityp :: JournalParser m Quantity
dotquantityp = do
dots <- filter (not.isSpace) <$> many (oneOf (". " :: [Char]))
return $ fromIntegral (length dots) / 4
emptyorcommentlinep :: [Char] -> TextParser m ()
emptyorcommentlinep cs =
label ("empty line or comment line beginning with "++cs) $ do
traceparse "emptyorcommentlinep"
skipNonNewlineSpaces
void newline <|> void commentp
traceparse' "emptyorcommentlinep"
where
commentp = do
choice (map (some.char) cs)
takeWhileP Nothing (/='\n') <* newline