module Hledger.Read (
tests_Hledger_Read,
readJournalFile,
readJournal,
journalFromPathAndString,
ledgeraccountname,
myJournalPath,
myJournal,
someamount,
journalenvvar,
journaldefaultfilename,
requireJournalFile,
ensureJournalFile,
)
where
import Control.Monad.Error
import Data.Either (partitionEithers)
import Data.List
import Safe (headDef)
import System.Directory (doesFileExist, getHomeDirectory)
import System.Environment (getEnv)
import System.Exit (exitFailure)
import System.FilePath ((</>))
import System.IO (IOMode(..), withFile, stderr)
import Test.HUnit
import Text.Printf
import Hledger.Data.Dates (getCurrentDay)
import Hledger.Data.Types (Journal(..), Reader(..))
import Hledger.Data.Journal (nullctx)
import Hledger.Read.JournalReader as JournalReader
import Hledger.Read.TimelogReader as TimelogReader
import Hledger.Utils
import Prelude hiding (getContents, writeFile)
import Hledger.Utils.UTF8 (getContents, hGetContents, writeFile)
journalenvvar = "LEDGER_FILE"
journalenvvar2 = "LEDGER"
journaldefaultfilename = ".hledger.journal"
readers :: [Reader]
readers = [
JournalReader.reader
,TimelogReader.reader
]
formats = map rFormat readers
readerForFormat :: String -> Maybe Reader
readerForFormat s | null rs = Nothing
| otherwise = Just $ head rs
where
rs = filter ((s==).rFormat) readers :: [Reader]
journalFromPathAndString :: Maybe String -> FilePath -> String -> IO (Either String Journal)
journalFromPathAndString format fp s = do
let readers' = case format of Just f -> case readerForFormat f of Just r -> [r]
Nothing -> []
Nothing -> readers
(errors, journals) <- partitionEithers `fmap` mapM tryReader readers'
case journals of j:_ -> return $ Right j
_ -> return $ Left $ errMsg errors
where
tryReader r = (runErrorT . (rParser r) fp) s
errMsg [] = unknownFormatMsg
errMsg es = printf "could not parse %s data in %s\n%s" (rFormat r) fp e
where (r,e) = headDef (head readers, head es) $ filter detects $ zip readers es
detects (r,_) = (rDetector r) fp s
unknownFormatMsg = printf "could not parse %sdata in %s" (fmt formats) fp
where fmt [] = ""
fmt [f] = f ++ " "
fmt fs = intercalate ", " (init fs) ++ " or " ++ last fs ++ " "
readJournalFile :: Maybe String -> FilePath -> IO (Either String Journal)
readJournalFile format "-" = getContents >>= journalFromPathAndString format "(stdin)"
readJournalFile format f = do
requireJournalFile f
withFile f ReadMode $ \h -> hGetContents h >>= journalFromPathAndString format f
requireJournalFile :: FilePath -> IO ()
requireJournalFile f = do
exists <- doesFileExist f
when (not exists) $ do
hPrintf stderr "The hledger journal file \"%s\" was not found.\n" f
hPrintf stderr "Please create it first, eg with hledger add, hledger web, or a text editor.\n"
hPrintf stderr "Or, specify an existing journal file with -f or LEDGER_FILE.\n"
exitFailure
ensureJournalFile :: FilePath -> IO ()
ensureJournalFile f = do
exists <- doesFileExist f
when (not exists) $ do
hPrintf stderr "Creating hledger journal file \"%s\".\n" f
newJournalContent >>= writeFile f
newJournalContent :: IO String
newJournalContent = do
d <- getCurrentDay
return $ printf "; journal created %s by hledger\n" (show d)
readJournal :: Maybe String -> String -> IO (Either String Journal)
readJournal format s = journalFromPathAndString format "(string)" s
myJournalPath :: IO String
myJournalPath = do
s <- envJournalPath
if null s then defaultJournalPath else return s
where
envJournalPath = getEnv journalenvvar `catch` (\_ -> getEnv journalenvvar2 `catch` (\_ -> return ""))
defaultJournalPath = do
home <- getHomeDirectory `catch` (\_ -> return "")
return $ home </> journaldefaultfilename
myJournal :: IO Journal
myJournal = myJournalPath >>= readJournalFile Nothing >>= either error' return
tests_Hledger_Read = TestList
[
tests_Hledger_Read_JournalReader,
tests_Hledger_Read_TimelogReader,
"journalFile" ~: do
assertBool "journalFile should parse an empty file" (isRight $ parseWithCtx nullctx JournalReader.journalFile "")
jE <- readJournal Nothing ""
either error' (assertBool "journalFile parsing an empty file should give an empty journal" . null . jtxns) jE
]