Render updated tags and make generated/modified tags optional for hledger rewrite

hledger-lib/Hledger/Data/PeriodicTransaction.hs

@@ -21,7 +21,7 @@ import Text.Printf
 import Hledger.Data.Types
 import Hledger.Data.Dates
 import Hledger.Data.Amount
-import Hledger.Data.Posting (post, commentAddTagNextLine)
+import Hledger.Data.Posting (post)
 import Hledger.Data.Transaction
 import Hledger.Utils.UTF8IOCompat (error')
 import Hledger.Utils.Debug
@@ -87,107 +87,84 @@ instance Show PeriodicTransaction where
 --
 -- >>> _ptgen "monthly from 2017/1 to 2017/4"
 -- 2017/01/01
---     ; generated-transaction: ~ monthly from 2017/1 to 2017/4
 --     a           $1.00
 -- <BLANKLINE>
 -- 2017/02/01
---     ; generated-transaction: ~ monthly from 2017/1 to 2017/4
 --     a           $1.00
 -- <BLANKLINE>
 -- 2017/03/01
---     ; generated-transaction: ~ monthly from 2017/1 to 2017/4
 --     a           $1.00
 -- <BLANKLINE>
 --
 -- >>> _ptgen "monthly from 2017/1 to 2017/5"
 -- 2017/01/01
---     ; generated-transaction: ~ monthly from 2017/1 to 2017/5
 --     a           $1.00
 -- <BLANKLINE>
 -- 2017/02/01
---     ; generated-transaction: ~ monthly from 2017/1 to 2017/5
 --     a           $1.00
 -- <BLANKLINE>
 -- 2017/03/01
---     ; generated-transaction: ~ monthly from 2017/1 to 2017/5
 --     a           $1.00
 -- <BLANKLINE>
 -- 2017/04/01
---     ; generated-transaction: ~ monthly from 2017/1 to 2017/5
 --     a           $1.00
 -- <BLANKLINE>
 --
 -- >>> _ptgen "every 2nd day of month from 2017/02 to 2017/04"
 -- 2017/01/02
---     ; generated-transaction: ~ every 2nd day of month from 2017/02 to 2017/04
 --     a           $1.00
 -- <BLANKLINE>
 -- 2017/02/02
---     ; generated-transaction: ~ every 2nd day of month from 2017/02 to 2017/04
 --     a           $1.00
 -- <BLANKLINE>
 -- 2017/03/02
---     ; generated-transaction: ~ every 2nd day of month from 2017/02 to 2017/04
 --     a           $1.00
 -- <BLANKLINE>
 --
 -- >>> _ptgen "every 30th day of month from 2017/1 to 2017/5"
 -- 2016/12/30
---     ; generated-transaction: ~ every 30th day of month from 2017/1 to 2017/5
 --     a           $1.00
 -- <BLANKLINE>
 -- 2017/01/30
---     ; generated-transaction: ~ every 30th day of month from 2017/1 to 2017/5
 --     a           $1.00
 -- <BLANKLINE>
 -- 2017/02/28
---     ; generated-transaction: ~ every 30th day of month from 2017/1 to 2017/5
 --     a           $1.00
 -- <BLANKLINE>
 -- 2017/03/30
---     ; generated-transaction: ~ every 30th day of month from 2017/1 to 2017/5
 --     a           $1.00
 -- <BLANKLINE>
 -- 2017/04/30
---     ; generated-transaction: ~ every 30th day of month from 2017/1 to 2017/5
 --     a           $1.00
 -- <BLANKLINE>
 --
 -- >>> _ptgen "every 2nd Thursday of month from 2017/1 to 2017/4"
 -- 2016/12/08
---     ; generated-transaction: ~ every 2nd Thursday of month from 2017/1 to 2017/4
 --     a           $1.00
 -- <BLANKLINE>
 -- 2017/01/12
---     ; generated-transaction: ~ every 2nd Thursday of month from 2017/1 to 2017/4
 --     a           $1.00
 -- <BLANKLINE>
 -- 2017/02/09
---     ; generated-transaction: ~ every 2nd Thursday of month from 2017/1 to 2017/4
 --     a           $1.00
 -- <BLANKLINE>
 -- 2017/03/09
---     ; generated-transaction: ~ every 2nd Thursday of month from 2017/1 to 2017/4
 --     a           $1.00
 -- <BLANKLINE>
 --
 -- >>> _ptgen "every nov 29th from 2017 to 2019"
 -- 2016/11/29
---     ; generated-transaction: ~ every nov 29th from 2017 to 2019
 --     a           $1.00
 -- <BLANKLINE>
 -- 2017/11/29
---     ; generated-transaction: ~ every nov 29th from 2017 to 2019
 --     a           $1.00
 -- <BLANKLINE>
 -- 2018/11/29
---     ; generated-transaction: ~ every nov 29th from 2017 to 2019
 --     a           $1.00
 -- <BLANKLINE>
 --
 -- >>> _ptgen "2017/1"
 -- 2017/01/01
---     ; generated-transaction: ~ 2017/1
 --     a           $1.00
 -- <BLANKLINE>
 --
@@ -214,21 +191,17 @@ instance Show PeriodicTransaction where
 --  
 -- >>> _ptgenspan "every 3 months from 2019-05" (mkdatespan "2020-02-01" "2020-03-01")
 -- 2020/02/01
---     ; generated-transaction: ~ every 3 months from 2019-05
 --     a           $1.00
 -- <BLANKLINE>
 -- >>> _ptgenspan "every 3 days from 2018" (mkdatespan "2018-01-01" "2018-01-05")
 -- 2018/01/01
---     ; generated-transaction: ~ every 3 days from 2018
 --     a           $1.00
 -- <BLANKLINE>
 -- 2018/01/04
---     ; generated-transaction: ~ every 3 days from 2018
 --     a           $1.00
 -- <BLANKLINE>
 -- >>> _ptgenspan "every 3 days from 2018" (mkdatespan "2018-01-02" "2018-01-05")
 -- 2018/01/04
---     ; generated-transaction: ~ every 3 days from 2018
 --     a           $1.00
 -- <BLANKLINE>
 
@@ -240,10 +213,8 @@ runPeriodicTransaction PeriodicTransaction{..} requestedspan =
            tstatus      = ptstatus
           ,tcode        = ptcode
           ,tdescription = ptdescription
-          ,tcomment     = ptcomment
-                          `commentAddTagNextLine` ("generated-transaction",period)
+          ,tcomment     = ptcomment <> "\n"  -- force all further comments on new lines
           ,ttags        = ("_generated-transaction",period) :
-                          ("generated-transaction" ,period) :
                           pttags
           ,tpostings    = ptpostings
           }

hledger-lib/Hledger/Data/Posting.hs

@@ -375,6 +375,7 @@ commentJoin c1 c2
 -- A space is inserted following the colon, before the value.
 commentAddTag :: Text -> Tag -> Text
 commentAddTag c (t,v)
+  | "\n" `T.isSuffixOf` c = c <> tag -- never chomp last new-line
   | T.null c' = tag
   | otherwise = c' `commentJoin` tag
   where

hledger-lib/Hledger/Data/Testing.hs

@@ -0,0 +1,42 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Hledger.Data.Testing
+where
+
+import Data.Char
+import Data.Text (Text)
+import qualified Data.Text as T
+
+import Test.QuickCheck
+
+import Hledger.Data.Types
+
+newtype ArbTag = ArbTag Tag deriving (Show)
+
+instance Arbitrary ArbTag where
+    arbitrary = do
+        -- See https://hledger.org/journal.html#tags
+        let arbNonSpace = (:[]) <$> (arbitraryPrintableChar `suchThat` (/= ',') `suchThat` (not . isSpace))
+        tagName <- T.pack <$> listOf1 (arbitrary `suchThat` (\c -> isAlphaNum c || c `elem` ['-', '_']))
+        tagValue <- T.pack <$> oneof [
+                              arbNonSpace
+                            , do
+                                lead <- arbNonSpace
+                                middle <- listOf (arbitraryPrintableChar `suchThat` (`notElem` ['\n', ',']))
+                                trail <- arbNonSpace
+                                return (lead ++ middle ++ trail)
+                            ]
+        return $ ArbTag (tagName, tagValue)
+
+
+newtype ArbComment = ArbComment Text deriving (Show)
+
+instance Arbitrary ArbComment where
+    arbitrary = ArbComment <$> oneof [
+                      T.pack <$> arbitrary
+                    , do
+                        cmnt <- T.pack <$> arbitrary
+                        ArbTag (tagName, tagValue) <- arbitrary
+                        return $ cmnt <> "\n" <> tagName <> ": " <> tagValue
+                    ]
+        -- TODO: support tagless comment

hledger-lib/Hledger/Data/Transaction.hs

@@ -187,7 +187,7 @@ showTransactionHelper onelineamounts t =
 -- The first line (unless empty) will have leading space, subsequent lines will have a larger indent.
 renderCommentLines :: Text -> [String]
 renderCommentLines t =
-  case lines $ T.unpack t of
+  case lines $ T.unpack (T.stripEnd t) of
     []      -> []
     [l]     -> [(commentSpace . comment) l]        -- single-line comment
     ("":ls) -> "" : map (lineIndent . comment) ls  -- multi-line comment with empty first line
@@ -576,10 +576,10 @@ tests_Transaction =
            in postingAsLines False False [p] p @?=
               [ "    * a         $1.00  ; pcomment1"
               , "    ; pcomment2"
-              , "    ;   tag3: val3  "
+              , "    ;   tag3: val3"
               , "    * a         2.00h  ; pcomment1"
               , "    ; pcomment2"
-              , "    ;   tag3: val3  "
+              , "    ;   tag3: val3"
               ]
         ]
 

hledger-lib/Hledger/Data/TransactionModifier.hs

@@ -24,7 +24,7 @@ import Hledger.Data.Dates
 import Hledger.Data.Amount
 import Hledger.Data.Transaction
 import Hledger.Query
-import Hledger.Data.Posting (commentJoin, commentAddTag)
+import Hledger.Data.Posting (commentJoin)
 import Hledger.Utils.UTF8IOCompat (error')
 import Hledger.Utils.Debug
 
@@ -43,9 +43,7 @@ modifyTransactions tmods = map applymods
         t' = foldr (flip (.) . transactionModifierToFunction) id tmods t
         taggedt'
           -- PERF: compares txns to see if any modifier had an effect, inefficient ?
-          | t' /= t   = t'{tcomment = tcomment t' `commentAddTag` ("modified","")
-                          ,ttags    = ("modified","") : ttags t'
-                          }
+          | t' /= t   = t'{ttags    = ("_modified","") : ttags t'}
           | otherwise = t'
 
 -- | Converts a 'TransactionModifier' to a 'Transaction'-transforming function,
@@ -57,7 +55,7 @@ modifyTransactions tmods = map applymods
 -- >>> putStr $ showTransaction $ transactionModifierToFunction (TransactionModifier "" ["pong" `post` usd 2]) nulltransaction{tpostings=["ping" `post` usd 1]}
 -- 0000/01/01
 --     ping           $1.00
---     pong           $2.00  ; generated-posting: =
+--     pong           $2.00
 -- <BLANKLINE>
 -- >>> putStr $ showTransaction $ transactionModifierToFunction (TransactionModifier "miss" ["pong" `post` usd 2]) nulltransaction{tpostings=["ping" `post` usd 1]}
 -- 0000/01/01
@@ -66,7 +64,7 @@ modifyTransactions tmods = map applymods
 -- >>> putStr $ showTransaction $ transactionModifierToFunction (TransactionModifier "ping" ["pong" `post` amount{aismultiplier=True, aquantity=3}]) nulltransaction{tpostings=["ping" `post` usd 2]}
 -- 0000/01/01
 --     ping           $2.00
---     pong           $6.00  ; generated-posting: = ping
+--     pong           $6.00
 -- <BLANKLINE>
 --
 transactionModifierToFunction :: TransactionModifier -> (Transaction -> Transaction)
@@ -106,9 +104,7 @@ tmPostingRuleToFunction querytxt pr =
       { pdate    = pdate  pr <|> pdate  p
       , pdate2   = pdate2 pr <|> pdate2 p
       , pamount  = amount' p
-      , pcomment = pcomment pr `commentAddTag` ("generated-posting",qry)
-      , ptags    = ("generated-posting", qry) :
-                   ("_generated-posting",qry) :
+      , ptags    = ("_generated-posting",qry) :
                    ptags pr
       }
   where

hledger-lib/Hledger/Processing/Common.hs

@@ -0,0 +1,72 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE LambdaCase, ViewPatterns #-}
+
+module Hledger.Processing.Common (
+    syncTxn
+)
+where
+
+import Data.List
+import Data.Text (Text)
+import qualified Data.Text as T
+
+import Hledger.Data.Types
+import Hledger.Data.Transaction
+import Hledger.Data.Posting
+import Hledger.Read.Common
+
+-- $setup
+-- >>> import Hledger.Data.Testing
+-- >>> :set -XOverloadedStrings
+-- >>> includes xs = all (`elem` xs)
+
+-- | Synchronize some 'Transaction' metadata backso 'showTransaction' will show it.
+syncTxn :: Transaction -> Transaction
+syncTxn = txnTieKnot . syncTxnComments
+
+-- | Get 'Transaction' and its 'Posting' comments updated if needed.
+-- Note that current behavior is limited only to adding missing tags
+syncTxnComments t = t' where
+    t' = t { tcomment = ttags t `addMissingTags` tcomment t
+           , tpostings = map syncPostingComments $ tpostings t
+           }
+
+-- | Get 'Posting' comments updated if needed.
+-- Note that current behavior is limited only to adding missing tags
+syncPostingComments p = p' where
+    p' = p { pcomment = ptags p `addMissingTags` pcomment p }
+
+-- | Ensure that comment contains all tags
+--
+-- New tag included in updated comment:
+-- prop> \(ArbComment cmnt) (ArbTag tag') -> isDynamicTag tag' || tag' `elem` scanTags (addMissingTags [tag'] cmnt)
+--
+-- All tags from original comment preserved:
+-- prop> \(ArbComment cmnt) (ArbTag tag') -> scanTags (addMissingTags [tag'] cmnt) `includes` scanTags cmnt
+--
+-- Adding existing tags have no effect:
+-- prop> \(ArbComment cmnt) -> scanTags (addMissingTags (scanTags cmnt) cmnt) == cmnt
+-- prop> \(ArbTag tag) -> let cmnt = addMissingTags [tag] "" in addMissingTags [tag] cmnt == cmnt
+addMissingTags :: [Tag] -> Text -> Text
+addMissingTags (nub -> tags) cmnt = foldr (flip commentAddTag) cmnt tags'
+    where
+        tags' = filter isMissing . filter (not . isDynamicTag) $ tags
+        tags0 = scanTags cmnt
+        isMissing = not . (`elem` tags0)
+
+isDynamicTag :: Tag -> Bool
+isDynamicTag = T.isPrefixOf "_" . fst
+
+-- | Get tags from comment
+--
+-- >>> scanTags "abc def\nghi"
+-- []
+-- >>> scanTags "abc:"
+-- [("abc","")]
+-- >>> scanTags "abc def:"
+-- [("def","")]
+-- >>> scanTags "def:, abc: g hi, z"
+-- [("def",""),("abc","g hi")]
+scanTags :: Text -> [Tag]
+scanTags = concatMap scanLine . T.lines  where
+    scanLine = either (const []) id . runTextParser commenttagsp

hledger-lib/Hledger/Read/Common.hs

@@ -87,6 +87,9 @@ module Hledger.Read.Common (
   transactioncommentp,
   postingcommentp,
 
+  -- ** tags
+  commenttagsp,
+
   -- ** bracketed dates
   bracketeddatetagsp,