{-# LANGUAGE NamedFieldPuns    #-}
{-# LANGUAGE OverloadedStrings #-}

module Hledger.Data.JournalChecks.Uniqueleafnames (
  journalCheckUniqueleafnames
)
where

import Data.Function (on)
import Data.List (groupBy, sortBy)
import Data.Text (Text)
import qualified Data.Text as T
import Text.Printf (printf)
import Data.Maybe (fromMaybe)

import Hledger.Data.AccountName (accountLeafName)
import Hledger.Data.Errors (makePostingErrorExcerpt)
import Hledger.Data.Journal (journalPostings, journalAccountNamesUsed)
import Hledger.Data.Posting (isVirtual)
import Hledger.Data.Types

-- | Check that all the journal's postings are to accounts with a unique leaf name.
-- Otherwise, return an error message for the first offending posting.
journalCheckUniqueleafnames :: Journal -> Either String ()
journalCheckUniqueleafnames :: Journal -> Either String ()
journalCheckUniqueleafnames Journal
j = do
  -- find all duplicate leafnames, and the full account names they appear in
  case [(Text, Text)] -> [(Text, [Text])]
forall leaf full.
(Ord leaf, Eq full) =>
[(leaf, full)] -> [(leaf, [full])]
finddupes ([(Text, Text)] -> [(Text, [Text])])
-> [(Text, Text)] -> [(Text, [Text])]
forall a b. (a -> b) -> a -> b
$ Journal -> [(Text, Text)]
journalLeafAndFullAccountNames Journal
j of
    [] -> () -> Either String ()
forall a b. b -> Either a b
Right ()
    [(Text, [Text])]
dupes ->
      -- report the first posting that references one of them (and its position), for now
      (Posting -> Either String ()) -> [Posting] -> Either String ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ([(Text, [Text])] -> Posting -> Either String ()
checkposting [(Text, [Text])]
dupes) ([Posting] -> Either String ()) -> [Posting] -> Either String ()
forall a b. (a -> b) -> a -> b
$ Journal -> [Posting]
journalPostings Journal
j

finddupes :: (Ord leaf, Eq full) => [(leaf, full)] -> [(leaf, [full])]
finddupes :: [(leaf, full)] -> [(leaf, [full])]
finddupes [(leaf, full)]
leafandfullnames = [leaf] -> [[full]] -> [(leaf, [full])]
forall a b. [a] -> [b] -> [(a, b)]
zip [leaf]
dupLeafs [[full]]
dupAccountNames
  where dupLeafs :: [leaf]
dupLeafs = ([(leaf, full)] -> leaf) -> [[(leaf, full)]] -> [leaf]
forall a b. (a -> b) -> [a] -> [b]
map ((leaf, full) -> leaf
forall a b. (a, b) -> a
fst ((leaf, full) -> leaf)
-> ([(leaf, full)] -> (leaf, full)) -> [(leaf, full)] -> leaf
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(leaf, full)] -> (leaf, full)
forall a. [a] -> a
head) [[(leaf, full)]]
d
        dupAccountNames :: [[full]]
dupAccountNames = ([(leaf, full)] -> [full]) -> [[(leaf, full)]] -> [[full]]
forall a b. (a -> b) -> [a] -> [b]
map (((leaf, full) -> full) -> [(leaf, full)] -> [full]
forall a b. (a -> b) -> [a] -> [b]
map (leaf, full) -> full
forall a b. (a, b) -> b
snd) [[(leaf, full)]]
d
        d :: [[(leaf, full)]]
d = [(leaf, full)] -> [[(leaf, full)]]
forall b. [(leaf, b)] -> [[(leaf, b)]]
dupes' [(leaf, full)]
leafandfullnames
        dupes' :: [(leaf, b)] -> [[(leaf, b)]]
dupes' = ([(leaf, b)] -> Bool) -> [[(leaf, b)]] -> [[(leaf, b)]]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1) (Int -> Bool) -> ([(leaf, b)] -> Int) -> [(leaf, b)] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(leaf, b)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length)
          ([[(leaf, b)]] -> [[(leaf, b)]])
-> ([(leaf, b)] -> [[(leaf, b)]]) -> [(leaf, b)] -> [[(leaf, b)]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((leaf, b) -> (leaf, b) -> Bool) -> [(leaf, b)] -> [[(leaf, b)]]
forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy (leaf -> leaf -> Bool
forall a. Eq a => a -> a -> Bool
(==) (leaf -> leaf -> Bool)
-> ((leaf, b) -> leaf) -> (leaf, b) -> (leaf, b) -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (leaf, b) -> leaf
forall a b. (a, b) -> a
fst)
          ([(leaf, b)] -> [[(leaf, b)]])
-> ([(leaf, b)] -> [(leaf, b)]) -> [(leaf, b)] -> [[(leaf, b)]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((leaf, b) -> (leaf, b) -> Ordering) -> [(leaf, b)] -> [(leaf, b)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (leaf -> leaf -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (leaf -> leaf -> Ordering)
-> ((leaf, b) -> leaf) -> (leaf, b) -> (leaf, b) -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (leaf, b) -> leaf
forall a b. (a, b) -> a
fst)

journalLeafAndFullAccountNames :: Journal -> [(Text, AccountName)]
journalLeafAndFullAccountNames :: Journal -> [(Text, Text)]
journalLeafAndFullAccountNames = (Text -> (Text, Text)) -> [Text] -> [(Text, Text)]
forall a b. (a -> b) -> [a] -> [b]
map Text -> (Text, Text)
leafAndAccountName ([Text] -> [(Text, Text)])
-> (Journal -> [Text]) -> Journal -> [(Text, Text)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Journal -> [Text]
journalAccountNamesUsed
  where leafAndAccountName :: Text -> (Text, Text)
leafAndAccountName Text
a = (Text -> Text
accountLeafName Text
a, Text
a)

checkposting :: [(Text,[AccountName])] -> Posting -> Either String ()
checkposting :: [(Text, [Text])] -> Posting -> Either String ()
checkposting [(Text, [Text])]
leafandfullnames p :: Posting
p@Posting{paccount :: Posting -> Text
paccount=Text
a} =
  case [(Text, [Text])
lf | lf :: (Text, [Text])
lf@(Text
_,[Text]
fs) <- [(Text, [Text])]
leafandfullnames, Text
a Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
fs] of
    []             -> () -> Either String ()
forall a b. b -> Either a b
Right ()
    (Text
leaf,[Text]
fulls):[(Text, [Text])]
_ -> String -> Either String ()
forall a b. a -> Either a b
Left (String -> Either String ()) -> String -> Either String ()
forall a b. (a -> b) -> a -> b
$ String
-> String -> Int -> Int -> Int -> Text -> Text -> Text -> String
forall r. PrintfType r => String -> r
printf
      String
"%s:%d:%d-%d:\n%saccount leaf name \"%s\" is not unique\nit is used in account names: %s" 
      String
f Int
l Int
col Int
col2 Text
ex Text
leaf Text
accts
      where
        -- t = fromMaybe nulltransaction ptransaction  -- XXX sloppy
        col :: Int
col  = Int -> ((Int, Maybe Int) -> Int) -> Maybe (Int, Maybe Int) -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 (Int, Maybe Int) -> Int
forall a b. (a, b) -> a
fst Maybe (Int, Maybe Int)
mcols
        col2 :: Int
col2 = Int -> ((Int, Maybe Int) -> Int) -> Maybe (Int, Maybe Int) -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
0 (Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
0 (Maybe Int -> Int)
-> ((Int, Maybe Int) -> Maybe Int) -> (Int, Maybe Int) -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, Maybe Int) -> Maybe Int
forall a b. (a, b) -> b
snd) Maybe (Int, Maybe Int)
mcols
        (String
f,Int
l,Maybe (Int, Maybe Int)
mcols,Text
ex) = Posting
-> (Posting -> Transaction -> Text -> Maybe (Int, Maybe Int))
-> (String, Int, Maybe (Int, Maybe Int), Text)
makePostingErrorExcerpt Posting
p Posting -> Transaction -> Text -> Maybe (Int, Maybe Int)
forall p p. Posting -> p -> p -> Maybe (Int, Maybe Int)
finderrcols
          where
            finderrcols :: Posting -> p -> p -> Maybe (Int, Maybe Int)
finderrcols Posting
p p
_ p
_ = (Int, Maybe Int) -> Maybe (Int, Maybe Int)
forall a. a -> Maybe a
Just (Int
col, Int -> Maybe Int
forall a. a -> Maybe a
Just Int
col2)
              where
                alen :: Int
alen = Text -> Int
T.length (Text -> Int) -> Text -> Int
forall a b. (a -> b) -> a -> b
$ Posting -> Text
paccount Posting
p
                llen :: Int
llen = Text -> Int
T.length (Text -> Int) -> Text -> Int
forall a b. (a -> b) -> a -> b
$ Text -> Text
accountLeafName Text
a
                col :: Int
col = Int
5 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (if Posting -> Bool
isVirtual Posting
p then Int
1 else Int
0) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
alen Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
llen
                col2 :: Int
col2 = Int
col Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
llen Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
        accts :: Text
accts = Text -> [Text] -> Text
T.intercalate Text
", " ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map ((Text
"\""Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>)(Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>Text
"\"")) [Text]
fulls