account directive should preserve virtual/balanced virtual posting type

hledger-lib/Hledger/Data/Posting.hs

@@ -13,6 +13,7 @@ where
 import Data.List
 import Data.Ord
 import Data.Time.Calendar
+import Safe
 import Test.HUnit
 import Text.Printf
 
@@ -66,11 +67,6 @@ isBalancedVirtual p = ptype p == BalancedVirtualPosting
 hasAmount :: Posting -> Bool
 hasAmount = (/= missingamt) . pamount
 
-postingTypeFromAccountName a
-    | head a == '[' && last a == ']' = BalancedVirtualPosting
-    | head a == '(' && last a == ')' = VirtualPosting
-    | otherwise = RegularPosting
-
 accountNamesFromPostings :: [Posting] -> [AccountName]
 accountNamesFromPostings = nub . map paccount
 
@@ -103,6 +99,60 @@ postingsDateSpan [] = DateSpan Nothing Nothing
 postingsDateSpan ps = DateSpan (Just $ postingDate $ head ps') (Just $ addDays 1 $ postingDate $ last ps')
     where ps' = sortBy (comparing postingDate) ps
 
+-- balanced/non-balanced posting indicators
+
+accountNamePostingType :: AccountName -> PostingType
+accountNamePostingType a
+    | null a = RegularPosting
+    | head a == '[' && last a == ']' = BalancedVirtualPosting
+    | head a == '(' && last a == ')' = VirtualPosting
+    | otherwise = RegularPosting
+
+accountNameWithoutPostingType :: AccountName -> AccountName
+accountNameWithoutPostingType a = case accountNamePostingType a of
+                                    BalancedVirtualPosting -> init $ tail a
+                                    VirtualPosting -> init $ tail a
+                                    RegularPosting -> a
+
+accountNameWithPostingType :: PostingType -> AccountName -> AccountName
+accountNameWithPostingType BalancedVirtualPosting a = "["++accountNameWithoutPostingType a++"]"
+accountNameWithPostingType VirtualPosting a = "("++accountNameWithoutPostingType a++")"
+accountNameWithPostingType RegularPosting a = accountNameWithoutPostingType a
+
+-- | Prefix one account name to another, preserving posting type
+-- indicators like concatAccountNames.
+joinAccountNames :: AccountName -> AccountName -> AccountName
+joinAccountNames a b = concatAccountNames $ filter (not . null) [a,b]
+
+-- | Join account names into one. If any of them has () or [] posting type
+-- indicators, these (the first type encountered) will also be applied to
+-- the resulting account name.
+concatAccountNames :: [AccountName] -> AccountName
+concatAccountNames as = accountNameWithPostingType t $ intercalate ":" $ map accountNameWithoutPostingType as
+    where t = headDef RegularPosting $ filter (/= RegularPosting) $ map accountNamePostingType as
+
 tests_Hledger_Data_Posting = TestList [
+
+  "accountNamePostingType" ~: do
+    accountNamePostingType "a" `is` RegularPosting
+    accountNamePostingType "(a)" `is` VirtualPosting
+    accountNamePostingType "[a]" `is` BalancedVirtualPosting
+
+ ,"accountNameWithoutPostingType" ~: do
+    accountNameWithoutPostingType "(a)" `is` "a"
+
+ ,"accountNameWithPostingType" ~: do
+    accountNameWithPostingType VirtualPosting "[a]" `is` "(a)"
+
+ ,"joinAccountNames" ~: do
+    "a" `joinAccountNames` "b:c" `is` "a:b:c"
+    "a" `joinAccountNames` "(b:c)" `is` "(a:b:c)"
+    "[a]" `joinAccountNames` "(b:c)" `is` "[a:b:c]"
+    "" `joinAccountNames` "a" `is` "a"
+
+ ,"concatAccountNames" ~: do
+    concatAccountNames [] `is` ""
+    concatAccountNames ["a","(b)","[c:d]"] `is` "(a:b:c:d)"
+
  ]
 

hledger-lib/Hledger/Data/Types.hs

@@ -147,7 +147,9 @@ type Year = Integer
 data JournalContext = Ctx {
       ctxYear      :: !(Maybe Year)      -- ^ the default year most recently specified with Y
     , ctxCommodity :: !(Maybe Commodity) -- ^ the default commodity most recently specified with D
-    , ctxAccount   :: ![AccountName]     -- ^ the current stack of parent accounts specified by !account
+    , ctxAccount   :: ![AccountName]     -- ^ the current stack of parent accounts/account name components
+                                        --   specified with "account" directive(s). Concatenated, these
+                                        --   are the account prefix prepended to parsed account names.
     } deriving (Read, Show, Eq)
 
 data Journal = Journal {

hledger-lib/Hledger/Read/JournalReader.hs

@@ -448,7 +448,7 @@ ledgerposting = do
   status <- ledgerstatus
   many spacenonewline
   account <- transactionaccountname
-  let (ptype, account') = (postingTypeFromAccountName account, unbracket account)
+  let (ptype, account') = (accountNamePostingType account, unbracket account)
   amount <- postingamount
   many spacenonewline
   comment <- ledgercomment <|> return ""
@@ -456,9 +456,9 @@ ledgerposting = do
   md <- ledgermetadata
   return (Posting status account' amount comment ptype md Nothing)
 
--- qualify with the parent account from parsing context
+-- Prepend any parent account currently in effect.
 transactionaccountname :: GenParser Char JournalContext AccountName
-transactionaccountname = liftM2 (++) getParentAccount ledgeraccountname
+transactionaccountname = liftM2 joinAccountNames getParentAccount ledgeraccountname
 
 -- | Parse an account name. Account names may have single spaces inside
 -- them, and are terminated by two or more spaces. They should have one or

hledger-lib/Hledger/Read/Utils.hs

@@ -14,6 +14,7 @@ import Text.ParserCombinators.Parsec
 
 import Hledger.Data.Types
 import Hledger.Utils
+import Hledger.Data.Posting
 import Hledger.Data.Dates (getCurrentYear)
 import Hledger.Data.Journal (nullctx, nulljournal, journalFinalise)
 
@@ -50,8 +51,7 @@ getCommodity = liftM ctxCommodity getState
 
 pushParentAccount :: String -> GenParser tok JournalContext ()
 pushParentAccount parent = updateState addParentAccount
-    where addParentAccount ctx0 = ctx0 { ctxAccount = normalize parent : ctxAccount ctx0 }
-          normalize = (++ ":") 
+    where addParentAccount ctx0 = ctx0 { ctxAccount = parent : ctxAccount ctx0 }
 
 popParentAccount :: GenParser tok JournalContext ()
 popParentAccount = do ctx0 <- getState
@@ -60,7 +60,7 @@ popParentAccount = do ctx0 <- getState
                         (_:rest) -> setState $ ctx0 { ctxAccount = rest }
 
 getParentAccount :: GenParser tok JournalContext String
-getParentAccount = liftM (concat . reverse . ctxAccount) getState
+getParentAccount = liftM (concatAccountNames . reverse . ctxAccount) getState
 
 -- | Convert a possibly relative, possibly tilde-containing file path to an absolute one.
 -- using the current directory from a parsec source position. ~username is not supported.

hledger/Hledger/Cli.hs

@@ -87,6 +87,13 @@ tests_Hledger_Cli = TestList
                             "2008/12/07 Four\n  outer:why  $-4\n  outer:zed  $4\n" ++
                             "2008/12/07 Five\n  foo  $-5\n  bar  $5\n"
                            )
+
+   ,"account directive should preserve \"virtual\" posting type" ~: do
+      j <- readJournal Nothing "!account test\n2008/12/07 One\n  (from)  $-1\n  (to)  $1\n" >>= either error' return
+      let p = head $ tpostings $ head $ jtxns j
+      assertBool "" $ (paccount p) == "test:from"
+      assertBool "" $ (ptype p) == VirtualPosting
+
    ]
 
   ,"ledgerAccountNames" ~: