1 {-# LANGUAGE RecordWildCards #-}
    2 {-|
    3 Utilities common to hledger journal readers.
    4 -}
    5 
    6 module Hledger.Read.Utils
    7 where
    8 
    9 import Control.Monad.Error
   10 import Data.List
   11 import System.Directory (getHomeDirectory)
   12 import System.FilePath(takeDirectory,combine)
   13 import System.Time (getClockTime)
   14 import Text.ParserCombinators.Parsec
   15 
   16 import Hledger.Data.Types
   17 import Hledger.Utils
   18 import Hledger.Data.Posting
   19 import Hledger.Data.Dates (getCurrentYear)
   20 import Hledger.Data.Journal
   21 
   22 
   23 juSequence :: [JournalUpdate] -> JournalUpdate
   24 juSequence us = liftM (foldr (.) id) $ sequence us
   25 
   26 -- | Given a JournalUpdate-generating parsec parser, file path and data string,
   27 -- parse and post-process a Journal so that it's ready to use, or give an error.
   28 parseJournalWith :: (GenParser Char JournalContext (JournalUpdate,JournalContext)) -> FilePath -> String -> ErrorT String IO Journal
   29 parseJournalWith p f s = do
   30   tc <- liftIO getClockTime
   31   tl <- liftIO getCurrentLocalTime
   32   y <- liftIO getCurrentYear
   33   case runParser p nullctx{ctxYear=Just y} f s of
   34     Right (updates,ctx) -> do
   35                            j <- updates `ap` return nulljournal
   36                            case journalFinalise tc tl f s ctx j of
   37                              Right j'  -> return j'
   38                              Left estr -> throwError estr
   39     Left e -> throwError $ show e
   40 
   41 setYear :: Integer -> GenParser tok JournalContext ()
   42 setYear y = updateState (\ctx -> ctx{ctxYear=Just y})
   43 
   44 getYear :: GenParser tok JournalContext (Maybe Integer)
   45 getYear = liftM ctxYear getState
   46 
   47 setCommodity :: Commodity -> GenParser tok JournalContext ()
   48 setCommodity c = updateState (\ctx -> ctx{ctxCommodity=Just c})
   49 
   50 getCommodity :: GenParser tok JournalContext (Maybe Commodity)
   51 getCommodity = liftM ctxCommodity getState
   52 
   53 pushParentAccount :: String -> GenParser tok JournalContext ()
   54 pushParentAccount parent = updateState addParentAccount
   55     where addParentAccount ctx0 = ctx0 { ctxAccount = parent : ctxAccount ctx0 }
   56 
   57 popParentAccount :: GenParser tok JournalContext ()
   58 popParentAccount = do ctx0 <- getState
   59                       case ctxAccount ctx0 of
   60                         [] -> unexpected "End of account block with no beginning"
   61                         (_:rest) -> setState $ ctx0 { ctxAccount = rest }
   62 
   63 getParentAccount :: GenParser tok JournalContext String
   64 getParentAccount = liftM (concatAccountNames . reverse . ctxAccount) getState
   65 
   66 addAccountAlias :: (AccountName,AccountName) -> GenParser tok JournalContext ()
   67 addAccountAlias a = updateState (\(ctx@Ctx{..}) -> ctx{ctxAliases=a:ctxAliases})
   68 
   69 getAccountAliases :: GenParser tok JournalContext [(AccountName,AccountName)]
   70 getAccountAliases = liftM ctxAliases getState
   71 
   72 clearAccountAliases :: GenParser tok JournalContext ()
   73 clearAccountAliases = updateState (\(ctx@Ctx{..}) -> ctx{ctxAliases=[]})
   74 
   75 -- | Convert a possibly relative, possibly tilde-containing file path to an absolute one.
   76 -- using the current directory from a parsec source position. ~username is not supported.
   77 expandPath :: (MonadIO m) => SourcePos -> FilePath -> m FilePath
   78 expandPath pos fp = liftM mkAbsolute (expandHome fp)
   79   where
   80     mkAbsolute = combine (takeDirectory (sourceName pos))
   81     expandHome inname | "~/" `isPrefixOf` inname = do homedir <- liftIO getHomeDirectory
   82                                                       return $ homedir ++ drop 1 inname
   83                       | otherwise                = return inname
   84 
   85 fileSuffix :: FilePath -> String
   86 fileSuffix = reverse . takeWhile (/='.') . reverse . dropWhile (/='.')