1 {-# LANGUAGE NoMonomorphismRestriction#-}
    2 {-|
    3 
    4 'AccountName's are strings like @assets:cash:petty@.
    5 From a set of these we derive the account hierarchy.
    6 
    7 -}
    8 
    9 module Ledger.AccountName
   10 where
   11 import Ledger.Utils
   12 import Ledger.Types
   13 import Data.Map ((!), fromList, Map)
   14 import qualified Data.Map as M
   15 
   16 
   17 
   18 -- change to use a different separator for nested accounts
   19 acctsepchar = ':'
   20 
   21 accountNameComponents :: AccountName -> [String]
   22 accountNameComponents = splitAtElement acctsepchar
   23 
   24 accountNameFromComponents :: [String] -> AccountName
   25 accountNameFromComponents = concat . intersperse [acctsepchar]
   26 
   27 accountLeafName :: AccountName -> String
   28 accountLeafName = last . accountNameComponents
   29 
   30 accountNameLevel :: AccountName -> Int
   31 accountNameLevel "" = 0
   32 accountNameLevel a = (length $ filter (==acctsepchar) a) + 1
   33 
   34 -- | ["a:b:c","d:e"] -> ["a","a:b","a:b:c","d","d:e"]
   35 expandAccountNames :: [AccountName] -> [AccountName]
   36 expandAccountNames as = nub $ concat $ map expand as
   37     where expand as = map accountNameFromComponents (tail $ inits $ accountNameComponents as)
   38 
   39 -- | ["a:b:c","d:e"] -> ["a","d"]
   40 topAccountNames :: [AccountName] -> [AccountName]
   41 topAccountNames as = [a | a <- expandAccountNames as, accountNameLevel a == 1]
   42 
   43 parentAccountName :: AccountName -> AccountName
   44 parentAccountName a = accountNameFromComponents $ init $ accountNameComponents a
   45 
   46 parentAccountNames :: AccountName -> [AccountName]
   47 parentAccountNames a = parentAccountNames' $ parentAccountName a
   48     where
   49       parentAccountNames' "" = []
   50       parentAccountNames' a = [a] ++ (parentAccountNames' $ parentAccountName a)
   51 
   52 isAccountNamePrefixOf :: AccountName -> AccountName -> Bool
   53 p `isAccountNamePrefixOf` s = ((p ++ [acctsepchar] ) `isPrefixOf` s)
   54 
   55 isSubAccountNameOf :: AccountName -> AccountName -> Bool
   56 s `isSubAccountNameOf` p = 
   57     (p `isAccountNamePrefixOf` s) && (accountNameLevel s == (accountNameLevel p + 1))
   58 
   59 -- | From a list of account names, select those which are direct
   60 -- subaccounts of the given account name.
   61 subAccountNamesFrom :: [AccountName] -> AccountName -> [AccountName]
   62 subAccountNamesFrom accts a = filter (`isSubAccountNameOf` a) accts
   63 
   64 -- | Convert a list of account names to a tree.
   65 accountNameTreeFrom :: [AccountName] -> Tree AccountName
   66 accountNameTreeFrom = accountNameTreeFrom1
   67 
   68 accountNameTreeFrom1 accts = 
   69     Node "top" (accounttreesfrom (topAccountNames accts))
   70         where
   71           accounttreesfrom :: [AccountName] -> [Tree AccountName]
   72           accounttreesfrom [] = []
   73           accounttreesfrom as = [Node a (accounttreesfrom $ subs a) | a <- as]
   74           subs = subAccountNamesFrom (expandAccountNames accts)
   75 
   76 accountNameTreeFrom2 accts = 
   77    Node "top" $ unfoldForest (\a -> (a, subs a)) $ topAccountNames accts
   78         where
   79           subs = subAccountNamesFrom allaccts
   80           allaccts = expandAccountNames accts
   81           -- subs' a = subsmap ! a
   82           -- subsmap :: Map AccountName [AccountName]
   83           -- subsmap = Data.Map.fromList [(a, subAccountNamesFrom allaccts a) | a <- allaccts]
   84 
   85 accountNameTreeFrom3 accts = 
   86     Node "top" $ forestfrom allaccts $ topAccountNames accts
   87         where
   88           -- drop accts from the list of potential subs as we add them to the tree
   89           forestfrom :: [AccountName] -> [AccountName] -> Forest AccountName
   90           forestfrom subaccts accts = 
   91               [let subaccts' = subaccts \\ accts in Node a $ forestfrom subaccts' (subAccountNamesFrom subaccts' a) | a <- accts]
   92           allaccts = expandAccountNames accts
   93           
   94 
   95 -- a more efficient tree builder from Cale Gibbard
   96 newtype Tree' a = T (Map a (Tree' a))
   97   deriving (Show, Eq, Ord)
   98 
   99 mergeTrees :: (Ord a) => Tree' a -> Tree' a -> Tree' a
  100 mergeTrees (T m) (T m') = T (M.unionWith mergeTrees m m')
  101 
  102 emptyTree = T M.empty
  103 
  104 pathtree :: [a] -> Tree' a
  105 pathtree []     = T M.empty
  106 pathtree (x:xs) = T (M.singleton x (pathtree xs))
  107 
  108 fromPaths :: (Ord a) => [[a]] -> Tree' a
  109 fromPaths = foldl' mergeTrees emptyTree . map pathtree
  110 
  111 -- the above, but trying to build Tree directly
  112 
  113 -- mergeTrees' :: (Ord a) => Tree a -> Tree a -> Tree a
  114 -- mergeTrees' (Node m ms) (Node m' ms') = Node undefined (ms `union` ms')
  115 
  116 -- emptyTree' = Node "top" []
  117 
  118 -- pathtree' :: [a] -> Tree a
  119 -- pathtree' []     = Node undefined []
  120 -- pathtree' (x:xs) = Node x [pathtree' xs]
  121 
  122 -- fromPaths' :: (Ord a) => [[a]] -> Tree a
  123 -- fromPaths' = foldl' mergeTrees' emptyTree' . map pathtree'
  124 
  125 
  126 -- converttree :: [AccountName] -> Tree' AccountName -> [Tree AccountName]
  127 -- converttree parents (T m) = [Node (accountNameFromComponents $ parents ++ [a]) (converttree (parents++[a]) b) | (a,b) <- M.toList m]
  128 
  129 -- accountNameTreeFrom4 :: [AccountName] -> Tree AccountName
  130 -- accountNameTreeFrom4 accts = Node "top" (converttree [] $ fromPaths $ map accountNameComponents accts)
  131 
  132 converttree :: Tree' AccountName -> [Tree AccountName]
  133 converttree (T m) = [Node a (converttree b) | (a,b) <- M.toList m]
  134 
  135 expandTreeNames :: Tree AccountName -> Tree AccountName
  136 expandTreeNames (Node x ts) = Node x (map (treemap (\n -> accountNameFromComponents [x,n]) . expandTreeNames) ts)
  137 
  138 accountNameTreeFrom4 :: [AccountName] -> Tree AccountName
  139 accountNameTreeFrom4 = Node "top" . map expandTreeNames . converttree . fromPaths . map accountNameComponents
  140 
  141 
  142 -- | Elide an account name to fit in the specified width.
  143 -- From the ledger 2.6 news:
  144 -- 
  145 -- @
  146 --   What Ledger now does is that if an account name is too long, it will
  147 --   start abbreviating the first parts of the account name down to two
  148 --   letters in length.  If this results in a string that is still too
  149 --   long, the front will be elided -- not the end.  For example:
  150 --
  151 --     Expenses:Cash           ; OK, not too long
  152 --     Ex:Wednesday:Cash       ; "Expenses" was abbreviated to fit
  153 --     Ex:We:Afternoon:Cash    ; "Expenses" and "Wednesday" abbreviated
  154 --     ; Expenses:Wednesday:Afternoon:Lunch:Snack:Candy:Chocolate:Cash
  155 --     ..:Af:Lu:Sn:Ca:Ch:Cash  ; Abbreviated and elided!
  156 -- @
  157 elideAccountName :: Int -> AccountName -> AccountName
  158 elideAccountName width s = 
  159     elideLeft width $ accountNameFromComponents $ elideparts width [] $ accountNameComponents s
  160       where
  161         elideparts :: Int -> [String] -> [String] -> [String]
  162         elideparts width done ss
  163           | (length $ accountNameFromComponents $ done++ss) <= width = done++ss
  164           | length ss > 1 = elideparts width (done++[take 2 $ head ss]) (tail ss)
  165           | otherwise = done++ss
  166 
  167