1 {-# LANGUAGE NoMonomorphismRestriction#-}
    2 {-|
    3 
    4 'AccountName's are strings like @assets:cash:petty@, with multiple
    5 components separated by ':'.  From a set of these we derive the account
    6 hierarchy.
    7 
    8 -}
    9 
   10 module Hledger.Data.AccountName
   11 where
   12 import Data.List
   13 import Data.Map (Map)
   14 import Data.Tree
   15 import Test.HUnit
   16 import Text.Printf
   17 import qualified Data.Map as M
   18 
   19 import Hledger.Data.Types
   20 import Hledger.Utils
   21 
   22 
   23 
   24 -- change to use a different separator for nested accounts
   25 acctsepchar = ':'
   26 
   27 accountNameComponents :: AccountName -> [String]
   28 accountNameComponents = splitAtElement acctsepchar
   29 
   30 accountNameFromComponents :: [String] -> AccountName
   31 accountNameFromComponents = concat . intersperse [acctsepchar]
   32 
   33 accountLeafName :: AccountName -> String
   34 accountLeafName = last . accountNameComponents
   35 
   36 accountNameLevel :: AccountName -> Int
   37 accountNameLevel "" = 0
   38 accountNameLevel a = length (filter (==acctsepchar) a) + 1
   39 
   40 accountNameDrop :: Int -> AccountName -> AccountName
   41 accountNameDrop n = accountNameFromComponents . drop n . accountNameComponents
   42 
   43 -- | ["a:b:c","d:e"] -> ["a","a:b","a:b:c","d","d:e"]
   44 expandAccountNames :: [AccountName] -> [AccountName]
   45 expandAccountNames as = nub $ concatMap expand as
   46     where expand = map accountNameFromComponents . tail . inits . accountNameComponents
   47 
   48 -- | ["a:b:c","d:e"] -> ["a","d"]
   49 topAccountNames :: [AccountName] -> [AccountName]
   50 topAccountNames as = [a | a <- expandAccountNames as, accountNameLevel a == 1]
   51 
   52 parentAccountName :: AccountName -> AccountName
   53 parentAccountName = accountNameFromComponents . init . accountNameComponents
   54 
   55 parentAccountNames :: AccountName -> [AccountName]
   56 parentAccountNames a = parentAccountNames' $ parentAccountName a
   57     where
   58       parentAccountNames' "" = []
   59       parentAccountNames' a = a : parentAccountNames' (parentAccountName a)
   60 
   61 isAccountNamePrefixOf :: AccountName -> AccountName -> Bool
   62 isAccountNamePrefixOf = isPrefixOf . (++ [acctsepchar])
   63 
   64 isSubAccountNameOf :: AccountName -> AccountName -> Bool
   65 s `isSubAccountNameOf` p = 
   66     (p `isAccountNamePrefixOf` s) && (accountNameLevel s == (accountNameLevel p + 1))
   67 
   68 -- | From a list of account names, select those which are direct
   69 -- subaccounts of the given account name.
   70 subAccountNamesFrom :: [AccountName] -> AccountName -> [AccountName]
   71 subAccountNamesFrom accts a = filter (`isSubAccountNameOf` a) accts
   72 
   73 -- | Convert a list of account names to a tree.
   74 accountNameTreeFrom :: [AccountName] -> Tree AccountName
   75 accountNameTreeFrom = accountNameTreeFrom1
   76 
   77 accountNameTreeFrom1 accts = 
   78     Node "top" (accounttreesfrom (topAccountNames accts))
   79         where
   80           accounttreesfrom :: [AccountName] -> [Tree AccountName]
   81           accounttreesfrom [] = []
   82           accounttreesfrom as = [Node a (accounttreesfrom $ subs a) | a <- as]
   83           subs = subAccountNamesFrom (expandAccountNames accts)
   84 
   85 nullaccountnametree = Node "top" []
   86 
   87 accountNameTreeFrom2 accts = 
   88    Node "top" $ unfoldForest (\a -> (a, subs a)) $ topAccountNames accts
   89         where
   90           subs = subAccountNamesFrom allaccts
   91           allaccts = expandAccountNames accts
   92           -- subs' a = subsmap ! a
   93           -- subsmap :: Map AccountName [AccountName]
   94           -- subsmap = Data.Map.fromList [(a, subAccountNamesFrom allaccts a) | a <- allaccts]
   95 
   96 accountNameTreeFrom3 accts = 
   97     Node "top" $ forestfrom allaccts $ topAccountNames accts
   98         where
   99           -- drop accts from the list of potential subs as we add them to the tree
  100           forestfrom :: [AccountName] -> [AccountName] -> Forest AccountName
  101           forestfrom subaccts accts = 
  102               [let subaccts' = subaccts \\ accts in Node a $ forestfrom subaccts' (subAccountNamesFrom subaccts' a) | a <- accts]
  103           allaccts = expandAccountNames accts
  104           
  105 
  106 -- a more efficient tree builder from Cale Gibbard
  107 newtype Tree' a = T (Map a (Tree' a))
  108   deriving (Show, Eq, Ord)
  109 
  110 mergeTrees :: (Ord a) => Tree' a -> Tree' a -> Tree' a
  111 mergeTrees (T m) (T m') = T (M.unionWith mergeTrees m m')
  112 
  113 emptyTree = T M.empty
  114 
  115 pathtree :: [a] -> Tree' a
  116 pathtree []     = T M.empty
  117 pathtree (x:xs) = T (M.singleton x (pathtree xs))
  118 
  119 fromPaths :: (Ord a) => [[a]] -> Tree' a
  120 fromPaths = foldl' mergeTrees emptyTree . map pathtree
  121 
  122 -- the above, but trying to build Tree directly
  123 
  124 -- mergeTrees' :: (Ord a) => Tree a -> Tree a -> Tree a
  125 -- mergeTrees' (Node m ms) (Node m' ms') = Node undefined (ms `union` ms')
  126 
  127 -- emptyTree' = Node "top" []
  128 
  129 -- pathtree' :: [a] -> Tree a
  130 -- pathtree' []     = Node undefined []
  131 -- pathtree' (x:xs) = Node x [pathtree' xs]
  132 
  133 -- fromPaths' :: (Ord a) => [[a]] -> Tree a
  134 -- fromPaths' = foldl' mergeTrees' emptyTree' . map pathtree'
  135 
  136 
  137 -- converttree :: [AccountName] -> Tree' AccountName -> [Tree AccountName]
  138 -- converttree parents (T m) = [Node (accountNameFromComponents $ parents ++ [a]) (converttree (parents++[a]) b) | (a,b) <- M.toList m]
  139 
  140 -- accountNameTreeFrom4 :: [AccountName] -> Tree AccountName
  141 -- accountNameTreeFrom4 accts = Node "top" (converttree [] $ fromPaths $ map accountNameComponents accts)
  142 
  143 converttree :: Tree' AccountName -> [Tree AccountName]
  144 converttree (T m) = [Node a (converttree b) | (a,b) <- M.toList m]
  145 
  146 expandTreeNames :: Tree AccountName -> Tree AccountName
  147 expandTreeNames (Node x ts) = Node x (map (treemap (\n -> accountNameFromComponents [x,n]) . expandTreeNames) ts)
  148 
  149 accountNameTreeFrom4 :: [AccountName] -> Tree AccountName
  150 accountNameTreeFrom4 = Node "top" . map expandTreeNames . converttree . fromPaths . map accountNameComponents
  151 
  152 
  153 -- | Elide an account name to fit in the specified width.
  154 -- From the ledger 2.6 news:
  155 -- 
  156 -- @
  157 --   What Ledger now does is that if an account name is too long, it will
  158 --   start abbreviating the first parts of the account name down to two
  159 --   letters in length.  If this results in a string that is still too
  160 --   long, the front will be elided -- not the end.  For example:
  161 --
  162 --     Expenses:Cash           ; OK, not too long
  163 --     Ex:Wednesday:Cash       ; "Expenses" was abbreviated to fit
  164 --     Ex:We:Afternoon:Cash    ; "Expenses" and "Wednesday" abbreviated
  165 --     ; Expenses:Wednesday:Afternoon:Lunch:Snack:Candy:Chocolate:Cash
  166 --     ..:Af:Lu:Sn:Ca:Ch:Cash  ; Abbreviated and elided!
  167 -- @
  168 elideAccountName :: Int -> AccountName -> AccountName
  169 elideAccountName width s = 
  170     elideLeft width $ accountNameFromComponents $ elideparts width [] $ accountNameComponents s
  171       where
  172         elideparts :: Int -> [String] -> [String] -> [String]
  173         elideparts width done ss
  174           | length (accountNameFromComponents $ done++ss) <= width = done++ss
  175           | length ss > 1 = elideparts width (done++[take 2 $ head ss]) (tail ss)
  176           | otherwise = done++ss
  177 
  178 clipAccountName :: Int -> AccountName -> AccountName
  179 clipAccountName n = accountNameFromComponents . take n . accountNameComponents
  180 
  181 -- | Convert an account name to a regular expression matching it and its subaccounts.
  182 accountNameToAccountRegex :: String -> String
  183 accountNameToAccountRegex "" = ""
  184 accountNameToAccountRegex a = printf "^%s(:|$)" a
  185 
  186 -- | Convert an account name to a regular expression matching it and its subaccounts.
  187 accountNameToAccountOnlyRegex :: String -> String
  188 accountNameToAccountOnlyRegex "" = ""
  189 accountNameToAccountOnlyRegex a = printf "^%s$" a
  190 
  191 -- | Convert an exact account-matching regular expression to a plain account name.
  192 accountRegexToAccountName :: String -> String
  193 accountRegexToAccountName = regexReplace "^\\^(.*?)\\(:\\|\\$\\)$" "\\1"
  194 
  195 -- | Does this string look like an exact account-matching regular expression ?
  196 isAccountRegex  :: String -> Bool
  197 isAccountRegex s = take 1 s == "^" && (take 5 $ reverse s) == ")$|:("
  198 
  199 tests_Hledger_Data_AccountName = TestList
  200  [
  201   "accountNameTreeFrom" ~: do
  202     accountNameTreeFrom ["a"]       `is` Node "top" [Node "a" []]
  203     accountNameTreeFrom ["a","b"]   `is` Node "top" [Node "a" [], Node "b" []]
  204     accountNameTreeFrom ["a","a:b"] `is` Node "top" [Node "a" [Node "a:b" []]]
  205     accountNameTreeFrom ["a:b:c"]   `is` Node "top" [Node "a" [Node "a:b" [Node "a:b:c" []]]]
  206 
  207   ,"expandAccountNames" ~:
  208     expandAccountNames ["assets:cash","assets:checking","expenses:vacation"] `is`
  209      ["assets","assets:cash","assets:checking","expenses","expenses:vacation"]
  210 
  211   ,"isAccountNamePrefixOf" ~: do
  212     "assets" `isAccountNamePrefixOf` "assets" `is` False
  213     "assets" `isAccountNamePrefixOf` "assets:bank" `is` True
  214     "assets" `isAccountNamePrefixOf` "assets:bank:checking" `is` True
  215     "my assets" `isAccountNamePrefixOf` "assets:bank" `is` False
  216 
  217   ,"isSubAccountNameOf" ~: do
  218     "assets" `isSubAccountNameOf` "assets" `is` False
  219     "assets:bank" `isSubAccountNameOf` "assets" `is` True
  220     "assets:bank:checking" `isSubAccountNameOf` "assets" `is` False
  221     "assets:bank" `isSubAccountNameOf` "my assets" `is` False
  222 
  223  ]
  224