clean up and combine I/O and parsing under Hledger.Read.*

This facilitates adding readers for new data formats. Timelog parsing is temporarily broken.

Hledger/Cli/Commands/Add.hs

@@ -8,6 +8,7 @@ A history-aware add command to help with data entry.
 module Hledger.Cli.Commands.Add
 where
 import Hledger.Data
+import Hledger.Read.Journal (someamount)
 import Hledger.Cli.Options
 import Hledger.Cli.Commands.Register (showRegisterReport)
 #if __GLASGOW_HASKELL__ <= 610
@@ -19,7 +20,7 @@ import System.IO ( stderr, hFlush, hPutStrLn, hPutStr )
 #endif
 import System.IO.Error
 import Text.ParserCombinators.Parsec
-import Hledger.Cli.Utils (journalFromStringWithOpts)
+import Hledger.Cli.Utils (readJournalWithOpts)
 import qualified Data.Foldable as Foldable (find)
 
 -- | Read ledger transactions from the terminal, prompting for each field,
@@ -157,7 +158,7 @@ appendToJournalFile Journal{filepath=f, jtext=t} s =
 registerFromString :: String -> IO String
 registerFromString s = do
   now <- getCurrentLocalTime
-  l <- journalFromStringWithOpts [] s
+  l <- readJournalWithOpts [] s
   return $ showRegisterReport opts (optsToFilterSpec opts [] now) l
     where opts = [Empty]
 

Hledger/Cli/Commands/Convert.hs

@@ -8,7 +8,8 @@ import Hledger.Cli.Options (Opt(Debug))
 import Hledger.Cli.Version (versionstr)
 import Hledger.Data.Types (Journal,AccountName,Transaction(..),Posting(..),PostingType(..))
 import Hledger.Data.Utils (strip, spacenonewline, restofline, parseWithCtx, assertParse, assertParseEqual)
-import Hledger.Data.Parse (someamount, emptyCtx, ledgeraccountname)
+import Hledger.Read.Common (emptyCtx)
+import Hledger.Read.Journal (someamount,ledgeraccountname)
 import Hledger.Data.Amount (nullmixedamt)
 import Safe (atDef, maximumDef)
 import System.IO (stderr)

Hledger/Cli/Commands/Register.hs

@@ -19,6 +19,7 @@ import Hledger.Cli.Options
 import Prelude hiding ( putStr )
 import System.IO.UTF8
 #endif
+import Text.ParserCombinators.Parsec
 
 
 -- | Print a register report.
@@ -71,6 +72,28 @@ displayExprMatches :: Maybe String -> Posting -> Bool
 displayExprMatches Nothing  _ = True
 displayExprMatches (Just d) p = (fromparse $ parsewith datedisplayexpr d) p
                         
+-- | Parse a hledger display expression, which is a simple date test like
+-- "d>[DATE]" or "d<=[DATE]", and return a "Posting"-matching predicate.
+datedisplayexpr :: GenParser Char st (Posting -> Bool)
+datedisplayexpr = do
+  char 'd'
+  op <- compareop
+  char '['
+  (y,m,d) <- smartdate
+  char ']'
+  let date    = parsedate $ printf "%04s/%02s/%02s" y m d
+      test op = return $ (`op` date) . postingDate
+  case op of
+    "<"  -> test (<)
+    "<=" -> test (<=)
+    "="  -> test (==)
+    "==" -> test (==)
+    ">=" -> test (>=)
+    ">"  -> test (>)
+    _    -> mzero
+ where
+  compareop = choice $ map (try . string) ["<=",">=","==","<","=",">"]
+
 -- XXX confusing, refactor
 -- | Given a date span (representing a reporting interval) and a list of
 -- postings within it: aggregate the postings so there is only one per

Hledger/Cli/Commands/Web.hs

@@ -36,6 +36,7 @@ import Hledger.Cli.Commands.Histogram
 import Hledger.Cli.Commands.Print
 import Hledger.Cli.Commands.Register
 import Hledger.Data
+import Hledger.Read
 import Hledger.Cli.Options hiding (value)
 #ifdef MAKE
 import Paths_hledger_make (getDataFileName)
@@ -114,7 +115,7 @@ journalFileModifiedTime Journal{filepath=f}
 
 reload :: Journal -> IO Journal
 reload Journal{filepath=f} = do
-  j' <- readJournal f
+  j' <- readJournalFile f
   putValue "hledger" "journal" j'
   return j'
             

Hledger/Cli/Main.hs

@@ -20,7 +20,7 @@ You can use the command line:
 or ghci:
 
 > $ ghci hledger
-> > j <- readJournal "data/sample.journal"
+> > j <- readJournalFile "data/sample.journal"
 > > register [] ["income","expenses"] j
 > 2008/01/01 income               income:salary                   $-1          $-1
 > 2008/06/01 gift                 income:gifts                    $-1          $-2

Hledger/Cli/Options.hs

@@ -8,7 +8,7 @@ where
 import System.Console.GetOpt
 import System.Environment
 import Hledger.Cli.Version (timeprogname)
-import Hledger.Data.IO (myLedgerPath,myTimelogPath)
+import Hledger.Read (myLedgerPath,myTimelogPath)
 import Hledger.Data.Utils
 import Hledger.Data.Types
 import Hledger.Data.Dates

Hledger/Cli/Tests.hs

@@ -35,6 +35,8 @@ import System.Time (ClockTime(TOD))
 
 import Hledger.Cli.Commands.All
 import Hledger.Data  -- including testing utils in Hledger.Data.Utils
+import Hledger.Read.Common (emptyCtx)
+import Hledger.Read (someamount,readJournal)
 import Hledger.Cli.Options
 import Hledger.Cli.Utils
 
@@ -61,8 +63,8 @@ tests = TestList [
    tests_Hledger_Commands,
 
    "account directive" ~:
-   let sameParse str1 str2 = do j1 <- journalFromString str1
+   let sameParse str1 str2 = do j1 <- readJournal str1
-                                j2 <- journalFromString str2
+                                j2 <- readJournal str2
                                 j1 `is` j2{filereadtime=filereadtime j1, jtext=jtext j1}
    in TestList
    [
@@ -229,7 +231,7 @@ tests = TestList [
     ]
 
    ,"balance report with cost basis" ~: do
-      j <- journalFromString $ unlines
+      j <- readJournal $ unlines
              [""
              ,"2008/1/1 test           "
              ,"  a:b          10h @ $50"
@@ -244,7 +246,7 @@ tests = TestList [
         ]
 
    ,"balance report elides zero-balance root account(s)" ~: do
-      l <- journalFromStringWithOpts []
+      l <- readJournalWithOpts []
              (unlines
               ["2008/1/1 one"
               ,"  test:a  1"
@@ -372,15 +374,10 @@ tests = TestList [
     "assets:bank" `isSubAccountNameOf` "my assets" `is` False
 
   ,"default year" ~: do
-    rl <- journalFromString defaultyear_ledger_str
+    rl <- readJournal defaultyear_ledger_str
     tdate (head $ jtxns rl) `is` fromGregorian 2009 1 1
     return ()
 
-  ,"ledgerFile" ~: do
-    assertBool "ledgerFile should parse an empty file" (isRight $ parseWithCtx emptyCtx ledgerFile "")
-    r <- journalFromString "" -- don't know how to get it from ledgerFile
-    assertBool "ledgerFile parsing an empty file should give an empty ledger" $ null $ jtxns r
-
   ,"normaliseMixedAmount" ~: do
      normaliseMixedAmount (Mixed []) ~?= Mixed [nullamt]
 
@@ -468,7 +465,7 @@ tests = TestList [
   ,"register report with cleared option" ~:
    do 
     let opts = [Cleared]
-    l <- journalFromStringWithOpts opts sample_ledger_str
+    l <- readJournalWithOpts opts sample_ledger_str
     showRegisterReport opts (optsToFilterSpec opts [] t1) l `is` unlines
      ["2008/06/03 eat & shop           expenses:food                    $1           $1"
      ,"                                expenses:supplies                $1           $2"
@@ -480,7 +477,7 @@ tests = TestList [
   ,"register report with uncleared option" ~:
    do 
     let opts = [UnCleared]
-    l <- journalFromStringWithOpts opts sample_ledger_str
+    l <- readJournalWithOpts opts sample_ledger_str
     showRegisterReport opts (optsToFilterSpec opts [] t1) l `is` unlines
      ["2008/01/01 income               assets:bank:checking             $1           $1"
      ,"                                income:salary                   $-1            0"
@@ -492,7 +489,7 @@ tests = TestList [
 
   ,"register report sorts by date" ~:
    do 
-    l <- journalFromStringWithOpts [] $ unlines
+    l <- readJournalWithOpts [] $ unlines
         ["2008/02/02 a"
         ,"  b  1"
         ,"  c"
@@ -577,14 +574,14 @@ tests = TestList [
   ,"show hours" ~: show (hours 1) ~?= "1.0h"
 
   ,"unicode in balance layout" ~: do
-    l <- journalFromStringWithOpts []
+    l <- readJournalWithOpts []
       "2009/01/01 * медвежья шкура\n  расходы:покупки  100\n  актив:наличные\n"
     showBalanceReport [] (optsToFilterSpec [] [] t1) l `is` unlines
       ["                -100  актив:наличные"
       ,"                 100  расходы:покупки"]
 
   ,"unicode in register layout" ~: do
-    l <- journalFromStringWithOpts []
+    l <- readJournalWithOpts []
       "2009/01/01 * медвежья шкура\n  расходы:покупки  100\n  актив:наличные\n"
     showRegisterReport [] (optsToFilterSpec [] [] t1) l `is` unlines
       ["2009/01/01 медвежья шкура       расходы:покупки                 100          100"
@@ -673,8 +670,8 @@ tests = TestList [
 date1 = parsedate "2008/11/26"
 t1 = LocalTime date1 midday
 
-sampleledger = journalFromStringWithOpts [] sample_ledger_str
+sampleledger = readJournalWithOpts [] sample_ledger_str
-sampleledgerwithopts opts _ = journalFromStringWithOpts opts sample_ledger_str
+sampleledgerwithopts opts _ = readJournalWithOpts opts sample_ledger_str
 
 sample_ledger_str = unlines
  ["; A sample ledger file."
@@ -1078,5 +1075,5 @@ journalWithAmounts as =
         ""
         (TOD 0 0)
         ""
-    where parse = fromparse . parseWithCtx emptyCtx postingamount . (" "++)
+    where parse = fromparse . parseWithCtx emptyCtx someamount
 

Hledger/Cli/Utils.hs

@@ -1,7 +1,7 @@
 {-# LANGUAGE CPP #-}
 {-|
 
-Utilities for top-level modules and ghci. See also Hledger.Data.IO and
+Utilities for top-level modules and ghci. See also Hledger.Read and
 Hledger.Data.Utils.
 
 -}
@@ -9,27 +9,21 @@ Hledger.Data.Utils.
 module Hledger.Cli.Utils
     (
      withJournalDo,
-     journalFromStringWithOpts,
+     readJournalWithOpts,
      openBrowserOn
     )
 where
-import Control.Monad.Error
 import Hledger.Data
+import Hledger.Read
 import Hledger.Cli.Options (Opt(..),journalFilePathFromOpts) -- ,optsToFilterSpec)
 import System.Directory (doesFileExist)
-import System.IO (stderr)
-#if __GLASGOW_HASKELL__ <= 610
-import System.IO.UTF8 (hPutStrLn)
-#else
-import System.IO (hPutStrLn)
-#endif
 import System.Exit
-import System.Process (readProcessWithExitCode)
 import System.Info (os)
+import System.Process (readProcessWithExitCode)
 
 
 -- | Parse the user's specified journal file and run a hledger command on
--- it, or report a parse error. This function makes the whole thing go.
+-- it, or throw an error.
 withJournalDo :: [Opt] -> [String] -> String -> ([Opt] -> [String] -> Journal -> IO ()) -> IO ()
 withJournalDo opts args cmdname cmd = do
   -- We kludgily read the file before parsing to grab the full text, unless
@@ -42,13 +36,12 @@ withJournalDo opts args cmdname cmd = do
       runcmd = cmd opts args . costify
   if creating
    then runcmd nulljournal
-   else (runErrorT . parseJournalFile) f >>= either parseerror runcmd
+   else readJournalFile f >>= runcmd
-    where parseerror e = hPutStrLn stderr e >> exitWith (ExitFailure 1)
 
 -- | Get a journal from the given string and options, or throw an error.
-journalFromStringWithOpts :: [Opt] -> String -> IO Journal
+readJournalWithOpts :: [Opt] -> String -> IO Journal
-journalFromStringWithOpts opts s = do
+readJournalWithOpts opts s = do
-    j <- journalFromString s
+    j <- readJournal s
     let cost = CostBasis `elem` opts
     return $ (if cost then journalConvertAmountsToCost else id) j
 

hledger-lib/Hledger/Data.hs

@@ -12,10 +12,8 @@ module Hledger.Data (
                module Hledger.Data.Amount,
                module Hledger.Data.Commodity,
                module Hledger.Data.Dates,
-               module Hledger.Data.IO,
                module Hledger.Data.Transaction,
                module Hledger.Data.Ledger,
-               module Hledger.Data.Parse,
                module Hledger.Data.Journal,
                module Hledger.Data.Posting,
                module Hledger.Data.TimeLog,
@@ -29,10 +27,8 @@ import Hledger.Data.AccountName
 import Hledger.Data.Amount
 import Hledger.Data.Commodity
 import Hledger.Data.Dates
-import Hledger.Data.IO
 import Hledger.Data.Transaction
 import Hledger.Data.Ledger
-import Hledger.Data.Parse
 import Hledger.Data.Journal
 import Hledger.Data.Posting
 import Hledger.Data.TimeLog
@@ -46,10 +42,8 @@ tests_Hledger_Data = TestList
      Hledger.Data.Amount.tests_Amount
     -- ,Hledger.Data.Commodity.tests_Commodity
     ,Hledger.Data.Dates.tests_Dates
-    -- ,Hledger.Data.IO.tests_IO
     ,Hledger.Data.Transaction.tests_Transaction
     -- ,Hledger.Data.Hledger.Data.tests_Hledger.Data
-    ,Hledger.Data.Parse.tests_Parse
     -- ,Hledger.Data.Journal.tests_Journal
     -- ,Hledger.Data.Posting.tests_Posting
     ,Hledger.Data.TimeLog.tests_TimeLog

hledger-lib/Hledger/Data/Journal.hs

@@ -15,6 +15,7 @@ import Hledger.Data.Utils
 import Hledger.Data.Types
 import Hledger.Data.AccountName
 import Hledger.Data.Amount
+import Hledger.Data.Dates (nulldatespan)
 import Hledger.Data.Transaction (ledgerTransactionWithDate)
 import Hledger.Data.Posting
 import Hledger.Data.TimeLog
@@ -43,6 +44,18 @@ nulljournal = Journal { jmodifiertxns = []
                       , jtext = ""
                       }
 
+nullfilterspec = FilterSpec {
+     datespan=nulldatespan
+    ,cleared=Nothing
+    ,real=False
+    ,empty=False
+    ,costbasis=False
+    ,acctpats=[]
+    ,descpats=[]
+    ,whichdate=ActualDate
+    ,depth=Nothing
+    }
+
 addTransaction :: Transaction -> Journal -> Journal
 addTransaction t l0 = l0 { jtxns = t : jtxns l0 }
 

hledger-lib/Hledger/Read.hs

@@ -1,21 +1,39 @@
 {-# LANGUAGE CPP #-}
 {-| 
-Utilities for doing I/O with ledger files.
+
+Read hledger data from various data formats, and related utilities.
+
 -}
 
-module Hledger.Data.IO
+module Hledger.Read (
+       tests_Hledger_Read,
+       module Hledger.Read.Common,
+       Hledger.Read.Journal.someamount,
+       readJournalFile,
+       readJournal,
+       myLedgerPath,
+       myTimelogPath,
+       myJournal,
+       myTimelog,
+)
 where
+import Hledger.Data.Types (Journal(..))
+import Hledger.Data.Utils
+import Hledger.Read.Common
+import qualified Hledger.Read.Journal (parseJournal,parseJournalFile,ledgerFile,someamount,tests_Journal)
+import qualified Hledger.Read.Timelog (tests_Timelog) --parseJournal
+
 import Control.Monad.Error
-import Hledger.Data.Parse (parseJournal)
-import Hledger.Data.Types (FilterSpec(..),WhichDate(..),Journal(..))
-import Hledger.Data.Dates (nulldatespan)
 import System.Directory (getHomeDirectory)
 import System.Environment (getEnv)
-#if __GLASGOW_HASKELL__ <= 610
-import Prelude hiding (readFile)
-import System.IO.UTF8
-#endif
 import System.FilePath ((</>))
+import System.Exit
+import System.IO (stderr)
+#if __GLASGOW_HASKELL__ <= 610
+import System.IO.UTF8 (hPutStrLn)
+#else
+import System.IO (hPutStrLn)
+#endif
 
 
 ledgerenvvar           = "LEDGER"
@@ -23,18 +41,6 @@ timelogenvvar          = "TIMELOG"
 ledgerdefaultfilename  = ".ledger"
 timelogdefaultfilename = ".timelog"
 
-nullfilterspec = FilterSpec {
-     datespan=nulldatespan
-    ,cleared=Nothing
-    ,real=False
-    ,empty=False
-    ,costbasis=False
-    ,acctpats=[]
-    ,descpats=[]
-    ,whichdate=ActualDate
-    ,depth=Nothing
-    }
-
 -- | Get the user's default ledger file path.
 myLedgerPath :: IO String
 myLedgerPath = 
@@ -53,23 +59,22 @@ myTimelogPath =
 
 -- | Read the user's default journal file, or give an error.
 myJournal :: IO Journal
-myJournal = myLedgerPath >>= readJournal
+myJournal = myLedgerPath >>= readJournalFile
 
 -- | Read the user's default timelog file, or give an error.
 myTimelog :: IO Journal
-myTimelog = myTimelogPath >>= readJournal
+myTimelog = myTimelogPath >>= readJournalFile
 
 -- | Read a journal from this file, or throw an error.
-readJournal :: FilePath -> IO Journal
+readJournalFile :: FilePath -> IO Journal
-readJournal f = do
+readJournalFile f =
-  s <- readFile f
+  (runErrorT . Hledger.Read.Journal.parseJournalFile) f >>= either printerror return
-  j <- journalFromString s
+  where printerror e = hPutStrLn stderr e >> exitWith (ExitFailure 1)
-  return j{filepath=f}
 
--- | Read a Journal from the given string, using the current time as
+-- | Read a Journal from this string, or throw an error.
--- reference time, or throw an error.
+readJournal :: String -> IO Journal
-journalFromString :: String -> IO Journal
+readJournal s =
-journalFromString s = liftM (either error id) $ runErrorT $ parseJournal "(from string)" s
+  (runErrorT . Hledger.Read.Journal.parseJournal "(from string)") s >>= either error return
 
 -- -- | Expand ~ in a file path (does not handle ~name).
 -- tildeExpand :: FilePath -> IO FilePath
@@ -82,3 +87,14 @@ journalFromString s = liftM (either error id) $ runErrorT $ parseJournal "(from
 -- --                                return (homeDirectory pw ++ path)
 -- tildeExpand xs           =  return xs
 
+tests_Hledger_Read = TestList
+  [
+
+   "ledgerFile" ~: do
+    assertBool "ledgerFile should parse an empty file" (isRight $ parseWithCtx emptyCtx Hledger.Read.Journal.ledgerFile "")
+    r <- readJournal "" -- don't know how to get it from ledgerFile
+    assertBool "ledgerFile parsing an empty file should give an empty ledger" $ null $ jtxns r
+
+  ,Hledger.Read.Journal.tests_Journal
+  ,Hledger.Read.Timelog.tests_Timelog
+  ]

hledger-lib/Hledger/Read/Common.hs

@@ -0,0 +1,60 @@
+{-|
+
+Common utilities for hledger data readers, such as the context (state)
+that is kept while parsing a journal.
+
+-}
+
+module Hledger.Read.Common
+where
+
+import Control.Monad.Error
+import Data.List
+import Hledger.Data.Types (Journal)
+import Text.ParserCombinators.Parsec
+import System.Directory (getHomeDirectory)
+import System.FilePath(takeDirectory,combine)
+
+
+-- | A JournalUpdate is some transformation of a "Journal". It can do I/O
+-- or raise an error.
+type JournalUpdate = ErrorT String IO (Journal -> Journal)
+
+-- | Some context kept during parsing.
+data LedgerFileCtx = Ctx {
+      ctxYear     :: !(Maybe Integer)  -- ^ the default year most recently specified with Y
+    , ctxCommod   :: !(Maybe String)   -- ^ I don't know
+    , ctxAccount  :: ![String]         -- ^ the current stack of parent accounts specified by !account
+    } deriving (Read, Show)
+
+emptyCtx :: LedgerFileCtx
+emptyCtx = Ctx { ctxYear = Nothing, ctxCommod = Nothing, ctxAccount = [] }
+
+setYear :: Integer -> GenParser tok LedgerFileCtx ()
+setYear y = updateState (\ctx -> ctx{ctxYear=Just y})
+
+getYear :: GenParser tok LedgerFileCtx (Maybe Integer)
+getYear = liftM ctxYear getState
+
+pushParentAccount :: String -> GenParser tok LedgerFileCtx ()
+pushParentAccount parent = updateState addParentAccount
+    where addParentAccount ctx0 = ctx0 { ctxAccount = normalize parent : ctxAccount ctx0 }
+          normalize = (++ ":") 
+
+popParentAccount :: GenParser tok LedgerFileCtx ()
+popParentAccount = do ctx0 <- getState
+                      case ctxAccount ctx0 of
+                        [] -> unexpected "End of account block with no beginning"
+                        (_:rest) -> setState $ ctx0 { ctxAccount = rest }
+
+getParentAccount :: GenParser tok LedgerFileCtx String
+getParentAccount = liftM (concat . reverse . ctxAccount) getState
+
+expandPath :: (MonadIO m) => SourcePos -> FilePath -> m FilePath
+expandPath pos fp = liftM mkRelative (expandHome fp)
+  where
+    mkRelative = combine (takeDirectory (sourceName pos))
+    expandHome inname | "~/" `isPrefixOf` inname = do homedir <- liftIO getHomeDirectory
+                                                      return $ homedir ++ drop 1 inname
+                      | otherwise                = return inname
+

hledger-lib/Hledger/Read/Journal.hs

@@ -1,9 +1,9 @@
 {-# LANGUAGE CPP #-}
 {-|
 
-Parsers for hledger's journal file format and the timelog file format.
+A reader for hledger's (and c++ ledger's) journal file format.
 
-Here is the ledger grammar from the ledger 2.5 manual:
+From the ledger 2.5 manual:
 
 @
 The ledger file format is quite simple, but also very flexible. It supports
@@ -101,50 +101,18 @@ i, o, b, h
            timelog files.
 @
 
-Here is the timelog grammar from timeclock.el 2.6:
-
-@
-A timelog contains data in the form of a single entry per line.
-Each entry has the form:
-
-  CODE YYYY/MM/DD HH:MM:SS [COMMENT]
-
-CODE is one of: b, h, i, o or O.  COMMENT is optional when the code is
-i, o or O.  The meanings of the codes are:
-
-  b  Set the current time balance, or \"time debt\".  Useful when
-     archiving old log data, when a debt must be carried forward.
-     The COMMENT here is the number of seconds of debt.
-
-  h  Set the required working time for the given day.  This must
-     be the first entry for that day.  The COMMENT in this case is
-     the number of hours in this workday.  Floating point amounts
-     are allowed.
-
-  i  Clock in.  The COMMENT in this case should be the name of the
-     project worked on.
-
-  o  Clock out.  COMMENT is unnecessary, but can be used to provide
-     a description of how the period went, for example.
-
-  O  Final clock out.  Whatever project was being worked on, it is
-     now finished.  Useful for creating summary reports.
-@
-
-Example:
-
-@
-i 2007/03/10 12:26:00 hledger
-o 2007/03/10 17:26:02
-@
-
 -}
 
-module Hledger.Data.Parse
+module Hledger.Read.Journal {- (
+       parseJournal,
+       parseJournalFile,
+       someamount,
+       emptyCtx,
+       ledgeraccountname
+) -}
 where
 import Control.Monad.Error (ErrorT(..), MonadIO, liftIO, throwError, catchError)
 import Text.ParserCombinators.Parsec
-import System.Directory
 #if __GLASGOW_HASKELL__ <= 610
 import Prelude hiding (readFile, putStr, putStrLn, print, getContents)
 import System.IO.UTF8
@@ -158,52 +126,10 @@ import Hledger.Data.Transaction
 import Hledger.Data.Posting
 import Hledger.Data.Journal
 import Hledger.Data.Commodity (dollars,dollar,unknown,nonsimplecommoditychars)
-import System.FilePath(takeDirectory,combine)
+import Hledger.Read.Common
 import System.Time (getClockTime)
 
 
--- | A JournalUpdate is some transformation of a "Journal". It can do I/O
--- or raise an error.
-type JournalUpdate = ErrorT String IO (Journal -> Journal)
-
--- | Some context kept during parsing.
-data LedgerFileCtx = Ctx {
-      ctxYear     :: !(Maybe Integer)  -- ^ the default year most recently specified with Y
-    , ctxCommod   :: !(Maybe String)   -- ^ I don't know
-    , ctxAccount  :: ![String]         -- ^ the current stack of parent accounts specified by !account
-    } deriving (Read, Show)
-
-emptyCtx :: LedgerFileCtx
-emptyCtx = Ctx { ctxYear = Nothing, ctxCommod = Nothing, ctxAccount = [] }
-
-setYear :: Integer -> GenParser tok LedgerFileCtx ()
-setYear y = updateState (\ctx -> ctx{ctxYear=Just y})
-
-getYear :: GenParser tok LedgerFileCtx (Maybe Integer)
-getYear = liftM ctxYear getState
-
-pushParentAccount :: String -> GenParser tok LedgerFileCtx ()
-pushParentAccount parent = updateState addParentAccount
-    where addParentAccount ctx0 = ctx0 { ctxAccount = normalize parent : ctxAccount ctx0 }
-          normalize = (++ ":") 
-
-popParentAccount :: GenParser tok LedgerFileCtx ()
-popParentAccount = do ctx0 <- getState
-                      case ctxAccount ctx0 of
-                        [] -> unexpected "End of account block with no beginning"
-                        (_:rest) -> setState $ ctx0 { ctxAccount = rest }
-
-getParentAccount :: GenParser tok LedgerFileCtx String
-getParentAccount = liftM (concat . reverse . ctxAccount) getState
-
-expandPath :: (MonadIO m) => SourcePos -> FilePath -> m FilePath
-expandPath pos fp = liftM mkRelative (expandHome fp)
-  where
-    mkRelative = combine (takeDirectory (sourceName pos))
-    expandHome inname | "~/" `isPrefixOf` inname = do homedir <- liftIO getHomeDirectory
-                                                      return $ homedir ++ drop 1 inname
-                      | otherwise                = return inname
-
 -- let's get to it
 
 -- | Parse and post-process a journal file or timelog file to a "Journal",
@@ -212,8 +138,9 @@ parseJournalFile :: FilePath -> ErrorT String IO Journal
 parseJournalFile "-" = liftIO getContents >>= parseJournal "-"
 parseJournalFile f   = liftIO (readFile f) >>= parseJournal f
 
--- | Parse and post-process a "Journal" from a string, saving the provided
+-- | Parse and post-process a "Journal" from hledger's journal file
--- file path and the current time, or give an error.
+-- format, saving the provided file path and the current time, or give an
+-- error.
 parseJournal :: FilePath -> String -> ErrorT String IO Journal
 parseJournal f s = do
   tc <- liftIO getClockTime
@@ -243,7 +170,6 @@ ledgerFile = do items <- many ledgerItem
                           , ledgerTagDirective
                           , ledgerEndTagDirective
                           , emptyLine >> return (return id)
-                          , liftM (return . addTimeLogEntry)  timelogentry
                           ] <?> "ledger transaction, timelog entry, or directive"
 
 emptyLine :: GenParser Char st ()
@@ -610,40 +536,7 @@ numberpartsstartingwithpoint = do
   return ("",frac)
                      
 
--- | Parse a timelog entry.
+tests_Journal = TestList [
-timelogentry :: GenParser Char LedgerFileCtx TimeLogEntry
-timelogentry = do
-  code <- oneOf "bhioO"
-  many1 spacenonewline
-  datetime <- ledgerdatetime
-  comment <- optionMaybe (many1 spacenonewline >> liftM2 (++) getParentAccount restofline)
-  return $ TimeLogEntry (read [code]) datetime (fromMaybe "" comment)
-
-
--- | Parse a hledger display expression, which is a simple date test like
--- "d>[DATE]" or "d<=[DATE]", and return a "Posting"-matching predicate.
-datedisplayexpr :: GenParser Char st (Posting -> Bool)
-datedisplayexpr = do
-  char 'd'
-  op <- compareop
-  char '['
-  (y,m,d) <- smartdate
-  char ']'
-  let date    = parsedate $ printf "%04s/%02s/%02s" y m d
-      test op = return $ (`op` date) . postingDate
-  case op of
-    "<"  -> test (<)
-    "<=" -> test (<=)
-    "="  -> test (==)
-    "==" -> test (==)
-    ">=" -> test (>=)
-    ">"  -> test (>)
-    _    -> mzero
-
-compareop = choice $ map (try . string) ["<=",">=","==","<","=",">"]
-
-
-tests_Parse = TestList [
 
    "ledgerTransaction" ~: do
     assertParseEqual (parseWithCtx emptyCtx ledgerTransaction entry1_str) entry1
@@ -739,4 +632,3 @@ entry1 =
      [Posting False "expenses:food:groceries" (Mixed [dollars 47.18]) "" RegularPosting Nothing, 
       Posting False "assets:checking" (Mixed [dollars (-47.18)]) "" RegularPosting Nothing] ""
 
-

hledger-lib/Hledger/Read/Timelog.hs

@@ -0,0 +1,95 @@
+{-# LANGUAGE CPP #-}
+{-|
+
+A reader for the timelog file format generated by timeclock.el.
+
+From timeclock.el 2.6:
+
+@
+A timelog contains data in the form of a single entry per line.
+Each entry has the form:
+
+  CODE YYYY/MM/DD HH:MM:SS [COMMENT]
+
+CODE is one of: b, h, i, o or O.  COMMENT is optional when the code is
+i, o or O.  The meanings of the codes are:
+
+  b  Set the current time balance, or \"time debt\".  Useful when
+     archiving old log data, when a debt must be carried forward.
+     The COMMENT here is the number of seconds of debt.
+
+  h  Set the required working time for the given day.  This must
+     be the first entry for that day.  The COMMENT in this case is
+     the number of hours in this workday.  Floating point amounts
+     are allowed.
+
+  i  Clock in.  The COMMENT in this case should be the name of the
+     project worked on.
+
+  o  Clock out.  COMMENT is unnecessary, but can be used to provide
+     a description of how the period went, for example.
+
+  O  Final clock out.  Whatever project was being worked on, it is
+     now finished.  Useful for creating summary reports.
+@
+
+Example:
+
+@
+i 2007/03/10 12:26:00 hledger
+o 2007/03/10 17:26:02
+@
+
+-}
+
+module Hledger.Read.Timelog {- (
+       parseJournal,
+       parseJournalFile
+) -}
+where
+import Control.Monad.Error (ErrorT(..), MonadIO, liftIO, throwError)
+import Text.ParserCombinators.Parsec
+import System.Time (getClockTime)
+import Hledger.Data
+import Hledger.Read.Common (LedgerFileCtx,JournalUpdate,emptyCtx,getParentAccount)
+import Hledger.Read.Journal hiding (parseJournal, parseJournalFile)
+
+
+-- | Parse and post-process a "Journal" from timeclock.el's timelog
+-- format, saving the provided file path and the current time, or give an
+-- error.
+parseJournal :: FilePath -> String -> ErrorT String IO Journal
+parseJournal f s = do
+  tc <- liftIO getClockTime
+  tl <- liftIO getCurrentLocalTime
+  case runParser timelogFile emptyCtx f s of
+    Right m  -> liftM (journalFinalise tc tl f s) $ m `ap` return nulljournal
+    Left err -> throwError $ show err -- XXX raises an uncaught exception if we have a parsec user error, eg from many ?
+
+timelogFile :: GenParser Char LedgerFileCtx JournalUpdate
+timelogFile = do items <- many timelogItem
+                 eof
+                 return $ liftM (foldr (.) id) $ sequence items
+    where 
+      -- As all ledger line types can be distinguished by the first
+      -- character, excepting transactions versus empty (blank or
+      -- comment-only) lines, can use choice w/o try
+      timelogItem = choice [ ledgerExclamationDirective
+                          , liftM (return . addHistoricalPrice) ledgerHistoricalPrice
+                          , ledgerDefaultYear
+                          , emptyLine >> return (return id)
+                          , liftM (return . addTimeLogEntry)  timelogentry
+                          ] <?> "timelog entry, or default year or historical price directive"
+
+-- | Parse a timelog entry.
+timelogentry :: GenParser Char LedgerFileCtx TimeLogEntry
+timelogentry = do
+  code <- oneOf "bhioO"
+  many1 spacenonewline
+  datetime <- ledgerdatetime
+  comment <- optionMaybe (many1 spacenonewline >> liftM2 (++) getParentAccount restofline)
+  return $ TimeLogEntry (read [code]) datetime (fromMaybe "" comment)
+
+tests_Timelog = TestList [
+ ]
+

hledger-lib/hledger-lib.cabal

@@ -32,15 +32,17 @@ library
                   Hledger.Data.Amount
                   Hledger.Data.Commodity
                   Hledger.Data.Dates
-                  Hledger.Data.IO
                   Hledger.Data.Transaction
                   Hledger.Data.Journal
                   Hledger.Data.Ledger
                   Hledger.Data.Posting
-                  Hledger.Data.Parse
                   Hledger.Data.TimeLog
                   Hledger.Data.Types
                   Hledger.Data.Utils
+                  Hledger.Read
+                  Hledger.Read.Common
+                  Hledger.Read.Journal
+                  Hledger.Read.Timelog
   Build-Depends:
                   base >= 3 && < 5
                  ,containers