{-# LANGUAGE OverloadedStrings #-}
module Hledger.Read.TimedotReader (
reader,
timedotfilep,
)
where
import Control.Monad
import Control.Monad.Except (ExceptT, liftEither)
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 :: forall (m :: * -> *). MonadIO m => Reader m
reader = Reader
{rFormat :: String
rFormat = String
"timedot"
,rExtensions :: [String]
rExtensions = [String
"timedot"]
,rReadFn :: InputOpts -> String -> Text -> ExceptT String IO Journal
rReadFn = InputOpts -> String -> Text -> ExceptT String IO Journal
parse
,rParser :: MonadIO m => ErroringJournalParser m Journal
rParser = forall (m :: * -> *). JournalParser m Journal
timedotp
}
parse :: InputOpts -> FilePath -> Text -> ExceptT String IO Journal
parse :: InputOpts -> String -> Text -> ExceptT String IO Journal
parse InputOpts
iopts String
fp Text
t = ErroringJournalParser IO Journal
-> InputOpts -> String -> Text -> ExceptT String IO Journal
initialiseAndParseJournal forall (m :: * -> *). JournalParser m Journal
timedotp InputOpts
iopts String
fp Text
t
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither forall b c a. (b -> c) -> (a -> b) -> a -> c
. [AccountAlias] -> Journal -> Either String Journal
journalApplyAliases (InputOpts -> [AccountAlias]
aliasesFromOpts InputOpts
iopts)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= InputOpts -> String -> Text -> Journal -> ExceptT String IO Journal
journalFinalise InputOpts
iopts String
fp Text
t
traceparse, traceparse' :: String -> TextParser m ()
traceparse :: forall (m :: * -> *). String -> TextParser m ()
traceparse = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return ()
traceparse' :: forall (m :: * -> *). String -> TextParser m ()
traceparse' = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return ()
timedotfilep :: JournalParser m Journal
timedotfilep = forall (m :: * -> *). JournalParser m Journal
timedotp
timedotp :: JournalParser m ParsedJournal
timedotp :: forall (m :: * -> *). JournalParser m Journal
timedotp = forall (m :: * -> *). JournalParser m ()
preamblep forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many forall (m :: * -> *). JournalParser m ()
dayp forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall e s (m :: * -> *). MonadParsec e s m => m ()
eof forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall s (m :: * -> *). MonadState s m => m s
get
preamblep :: JournalParser m ()
preamblep :: forall (m :: * -> *). JournalParser m ()
preamblep = do
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). String -> TextParser m ()
traceparse String
"preamblep"
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
notFollowedBy forall (m :: * -> *). JournalParser m (Day, Text)
datelinep forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). String -> TextParser m ()
emptyorcommentlinep String
"#;*")
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). String -> TextParser m ()
traceparse' String
"preamblep"
dayp :: JournalParser m ()
dayp :: forall (m :: * -> *). JournalParser m ()
dayp = forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
label String
"timedot day entry" forall a b. (a -> b) -> a -> b
$ do
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). String -> TextParser m ()
traceparse String
"dayp"
(Day
d,Text
desc) <- forall (m :: * -> *). JournalParser m (Day, Text)
datelinep
forall (m :: * -> *). JournalParser m ()
commentlinesp
[Transaction]
ts <- forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). JournalParser m Transaction
entryp forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (m :: * -> *). JournalParser m ()
commentlinesp
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' forall a b. (a -> b) -> a -> b
$ [Transaction] -> Journal -> Journal
addTransactions forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\Transaction
t -> Transaction
t{tdate :: Day
tdate=Day
d, tdescription :: Text
tdescription=Text
desc}) [Transaction]
ts
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). String -> TextParser m ()
traceparse' String
"dayp"
where
addTransactions :: [Transaction] -> Journal -> Journal
addTransactions :: [Transaction] -> Journal -> Journal
addTransactions [Transaction]
ts Journal
j = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> a -> b
($)) Journal
j (forall a b. (a -> b) -> [a] -> [b]
map Transaction -> Journal -> Journal
addTransaction [Transaction]
ts)
datelinep :: JournalParser m (Day,Text)
datelinep :: forall (m :: * -> *). JournalParser m (Day, Text)
datelinep = do
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). String -> TextParser m ()
traceparse String
"datelinep"
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional forall {m :: * -> *}. ParsecT HledgerParseErrorData Text m ()
orgheadingprefixp
Day
d <- forall (m :: * -> *). JournalParser m Day
datep
String
desc <- String -> String
strip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall (m :: * -> *). TextParser m String
restofline
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). String -> TextParser m ()
traceparse' String
"datelinep"
forall (m :: * -> *) a. Monad m => a -> m a
return (Day
d, String -> Text
T.pack String
desc)
commentlinesp :: JournalParser m ()
= do
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). String -> TextParser m ()
traceparse String
"commentlinesp"
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many forall a b. (a -> b) -> a -> b
$ forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try forall a b. (a -> b) -> a -> b
$ forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). String -> TextParser m ()
emptyorcommentlinep String
"#;"
orgheadingprefixp :: ParsecT HledgerParseErrorData Text m ()
orgheadingprefixp = do
forall (m :: * -> *) a. MonadPlus m => m a -> m ()
skipSome (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
'*') forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces1
entryp :: JournalParser m Transaction
entryp :: forall (m :: * -> *). JournalParser m Transaction
entryp = do
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). String -> TextParser m ()
traceparse String
"entryp"
SourcePos
pos <- forall s e (m :: * -> *).
(TraversableStream s, MonadParsec e s m) =>
m SourcePos
getSourcePos
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m ()
notFollowedBy forall (m :: * -> *). JournalParser m (Day, Text)
datelinep
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice [forall {m :: * -> *}. ParsecT HledgerParseErrorData Text m ()
orgheadingprefixp, forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces1]
Text
a <- forall (m :: * -> *). JournalParser m Text
modifiedaccountnamep
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces
Quantity
hours <-
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall (m :: * -> *). TextParser m Text
followingcommentp forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Quantity
0)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall (m :: * -> *). TextParser m Quantity
durationp forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<*
(forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try (forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall (m :: * -> *). TextParser m Text
followingcommentp) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
newline forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return Text
"")))
Maybe (Text, AmountStyle)
mcs <- forall (m :: * -> *). JournalParser m (Maybe (Text, AmountStyle))
getDefaultCommodityAndStyle
let
(Text
c,AmountStyle
s) = case Maybe (Text, AmountStyle)
mcs of
Just (Text
defc,AmountStyle
defs) -> (Text
defc, AmountStyle
defs{asprecision :: AmountPrecision
asprecision=forall a. Ord a => a -> a -> a
max (AmountStyle -> AmountPrecision
asprecision AmountStyle
defs) (Word8 -> AmountPrecision
Precision Word8
2)})
Maybe (Text, AmountStyle)
_ -> (Text
"", AmountStyle
amountstyle{asprecision :: AmountPrecision
asprecision=Word8 -> AmountPrecision
Precision Word8
2})
t :: Transaction
t = Transaction
nulltransaction{
tsourcepos :: (SourcePos, SourcePos)
tsourcepos = (SourcePos
pos, SourcePos
pos),
tstatus :: Status
tstatus = Status
Cleared,
tpostings :: [Posting]
tpostings = [
Posting
nullposting{paccount :: Text
paccount=Text
a
,pamount :: MixedAmount
pamount=Amount -> MixedAmount
mixedAmount forall a b. (a -> b) -> a -> b
$ Amount
nullamt{acommodity :: Text
acommodity=Text
c, aquantity :: Quantity
aquantity=Quantity
hours, astyle :: AmountStyle
astyle=AmountStyle
s}
,ptype :: PostingType
ptype=PostingType
VirtualPosting
,ptransaction :: Maybe Transaction
ptransaction=forall a. a -> Maybe a
Just Transaction
t
}
]
}
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). String -> TextParser m ()
traceparse' String
"entryp"
forall (m :: * -> *) a. Monad m => a -> m a
return Transaction
t
durationp :: TextParser m Quantity
durationp :: forall (m :: * -> *). TextParser m Quantity
durationp = do
forall (m :: * -> *). String -> TextParser m ()
traceparse String
"durationp"
forall e s (m :: * -> *) a. MonadParsec e s m => m a -> m a
try forall (m :: * -> *). TextParser m Quantity
numericquantityp forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *). TextParser m Quantity
dotquantityp
numericquantityp :: TextParser m Quantity
numericquantityp :: forall (m :: * -> *). TextParser m Quantity
numericquantityp = do
(Quantity
q, Word8
_, Maybe Char
_, Maybe DigitGroupStyle
_) <- forall (m :: * -> *).
Maybe AmountStyle
-> TextParser
m (Quantity, Word8, Maybe Char, Maybe DigitGroupStyle)
numberp forall a. Maybe a
Nothing
Maybe (Tokens Text)
msymbol <- forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(Tokens Text, Quantity)]
timeUnits
forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces
let q' :: Quantity
q' =
case Maybe (Tokens Text)
msymbol of
Maybe (Tokens Text)
Nothing -> Quantity
q
Just Tokens Text
sym ->
case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Tokens Text
sym [(Tokens Text, Quantity)]
timeUnits of
Just Quantity
mult -> Quantity
q forall a. Num a => a -> a -> a
* Quantity
mult
Maybe Quantity
Nothing -> Quantity
q
forall (m :: * -> *) a. Monad m => a -> m a
return Quantity
q'
timeUnits :: [(Tokens Text, Quantity)]
timeUnits =
[(Tokens Text
"s",Quantity
2.777777777777778e-4)
,(Tokens Text
"mo",Quantity
5040)
,(Tokens Text
"m",Quantity
1.6666666666666666e-2)
,(Tokens Text
"h",Quantity
1)
,(Tokens Text
"d",Quantity
24)
,(Tokens Text
"w",Quantity
168)
,(Tokens Text
"y",Quantity
61320)
]
dotquantityp :: TextParser m Quantity
dotquantityp :: forall (m :: * -> *). TextParser m Quantity
dotquantityp = do
String
dots <- forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
notforall b c a. (b -> c) -> (a -> b) -> a -> c
.Char -> Bool
isSpace) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many (forall (f :: * -> *) e s (m :: * -> *).
(Foldable f, MonadParsec e s m) =>
f (Token s) -> m (Token s)
oneOf (String
". " :: [Char]))
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall (t :: * -> *) a. Foldable t => t a -> Int
length String
dots) forall a. Fractional a => a -> a -> a
/ Quantity
4
emptyorcommentlinep :: [Char] -> TextParser m ()
String
cs =
forall e s (m :: * -> *) a.
MonadParsec e s m =>
String -> m a -> m a
label (String
"empty line or comment line beginning with "forall a. [a] -> [a] -> [a]
++String
cs) forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *). String -> TextParser m ()
traceparse String
"emptyorcommentlinep"
forall s (m :: * -> *).
(Stream s, Token s ~ Char) =>
ParsecT HledgerParseErrorData s m ()
skipNonNewlineSpaces
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
newline forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (f :: * -> *) a. Functor f => f a -> f ()
void ParsecT HledgerParseErrorData Text m (Tokens Text)
commentp
forall (m :: * -> *). String -> TextParser m ()
traceparse' String
"emptyorcommentlinep"
where
commentp :: ParsecT HledgerParseErrorData Text m (Tokens Text)
commentp = do
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice (forall a b. (a -> b) -> [a] -> [b]
map (forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
someforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char) String
cs)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe String -> (Token s -> Bool) -> m (Tokens s)
takeWhileP forall a. Maybe a
Nothing (forall a. Eq a => a -> a -> Bool
/=Char
'\n') forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
newline