96 lines
		
	
	
		
			3.0 KiB
		
	
	
	
		
			Haskell
		
	
	
	
	
	
			
		
		
	
	
			96 lines
		
	
	
		
			3.0 KiB
		
	
	
	
		
			Haskell
		
	
	
	
	
	
{-|
 | 
						|
Utilities for doing I/O with ledger files.
 | 
						|
-}
 | 
						|
 | 
						|
module Ledger.IO
 | 
						|
where
 | 
						|
import Control.Monad.Error
 | 
						|
import Ledger.Ledger (cacheLedger', nullledger)
 | 
						|
import Ledger.Parse (parseLedger)
 | 
						|
import Ledger.Types (FilterSpec(..),WhichDate(..),Journal(..),Ledger(..))
 | 
						|
import Ledger.Utils (getCurrentLocalTime)
 | 
						|
import Ledger.Dates (nulldatespan)
 | 
						|
import System.Directory (getHomeDirectory)
 | 
						|
import System.Environment (getEnv)
 | 
						|
import System.IO
 | 
						|
import System.FilePath ((</>))
 | 
						|
import System.Time (getClockTime)
 | 
						|
 | 
						|
 | 
						|
ledgerenvvar           = "LEDGER"
 | 
						|
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 = 
 | 
						|
    getEnv ledgerenvvar `catch` 
 | 
						|
               (\_ -> do
 | 
						|
                  home <- getHomeDirectory `catch` (\_ -> return "")
 | 
						|
                  return $ home </> ledgerdefaultfilename)
 | 
						|
  
 | 
						|
-- | Get the user's default timelog file path.
 | 
						|
myTimelogPath :: IO String
 | 
						|
myTimelogPath =
 | 
						|
    getEnv timelogenvvar `catch`
 | 
						|
               (\_ -> do
 | 
						|
                  home <- getHomeDirectory
 | 
						|
                  return $ home </> timelogdefaultfilename)
 | 
						|
 | 
						|
-- | Read the user's default ledger file, or give an error.
 | 
						|
myLedger :: IO Ledger
 | 
						|
myLedger = myLedgerPath >>= readLedger
 | 
						|
 | 
						|
-- | Read the user's default timelog file, or give an error.
 | 
						|
myTimelog :: IO Ledger
 | 
						|
myTimelog = myTimelogPath >>= readLedger
 | 
						|
 | 
						|
-- | Read a ledger from this file, with no filtering, or give an error.
 | 
						|
readLedger :: FilePath -> IO Ledger
 | 
						|
readLedger f = do
 | 
						|
  t <- getClockTime
 | 
						|
  s <- readFile f
 | 
						|
  j <- journalFromString s
 | 
						|
  return $ cacheLedger' $ nullledger{journal=j{filepath=f,filereadtime=t,jtext=s}}
 | 
						|
 | 
						|
-- -- | Read a ledger from this file, filtering according to the filter spec.,
 | 
						|
-- -- | or give an error.
 | 
						|
-- readLedgerWithFilterSpec :: FilterSpec -> FilePath -> IO Ledger
 | 
						|
-- readLedgerWithFilterSpec fspec f = do
 | 
						|
--   s <- readFile f
 | 
						|
--   t <- getClockTime
 | 
						|
--   rl <- journalFromString s
 | 
						|
--   return $ filterAndCacheLedger fspec s rl{filepath=f, filereadtime=t}
 | 
						|
 | 
						|
-- | Read a Journal from the given string, using the current time as
 | 
						|
-- reference time, or give a parse error.
 | 
						|
journalFromString :: String -> IO Journal
 | 
						|
journalFromString s = do
 | 
						|
  t <- getCurrentLocalTime
 | 
						|
  liftM (either error id) $ runErrorT $ parseLedger t "(string)" s
 | 
						|
 | 
						|
-- -- | Expand ~ in a file path (does not handle ~name).
 | 
						|
-- tildeExpand :: FilePath -> IO FilePath
 | 
						|
-- tildeExpand ('~':[])     = getHomeDirectory
 | 
						|
-- tildeExpand ('~':'/':xs) = getHomeDirectory >>= return . (++ ('/':xs))
 | 
						|
-- --handle ~name, requires -fvia-C or ghc 6.8:
 | 
						|
-- --import System.Posix.User
 | 
						|
-- -- tildeExpand ('~':xs)     =  do let (user, path) = span (/= '/') xs
 | 
						|
-- --                                pw <- getUserEntryForName user
 | 
						|
-- --                                return (homeDirectory pw ++ path)
 | 
						|
-- tildeExpand xs           =  return xs
 | 
						|
 |