{-|
Utilities used throughout hledger, or needed low in the module hierarchy.
These are the bottom of hledger's module graph.
-}

module Hledger.Utils (

  -- * Functions
  applyN,
  mapM',
  sequence',
  curry2,
  uncurry2,
  curry3,
  uncurry3,
  curry4,
  uncurry4,

  -- * Lists
  maximum',
  maximumStrict,
  minimumStrict,
  splitAtElement,
  sumStrict,

  -- * Trees
  treeLeaves,

  -- * Tuples
  first3,
  second3,
  third3,
  first4,
  second4,
  third4,
  fourth4,
  first5,
  second5,
  third5,
  fourth5,
  fifth5,
  first6,
  second6,
  third6,
  fourth6,
  fifth6,
  sixth6,

  -- * Misc
  multicol,
  numDigitsInt,
  makeHledgerClassyLenses,

  -- * Other
  module Hledger.Utils.Debug,
  module Hledger.Utils.Parse,
  module Hledger.Utils.IO,
  module Hledger.Utils.Regex,
  module Hledger.Utils.String,
  module Hledger.Utils.Text,

  -- * Tests
  tests_Utils,
  module Hledger.Utils.Test,

)
where

import Data.Char (toLower)
import Data.List (intersperse)
import Data.List.Extra (chunksOf, foldl', foldl1', uncons, unsnoc)
import qualified Data.Set as Set
import qualified Data.Text as T (pack, unpack)
import Data.Tree (foldTree, Tree (Node, subForest))
import Language.Haskell.TH (DecsQ, Name, mkName, nameBase)
import Lens.Micro ((&), (.~))
import Lens.Micro.TH (DefName(TopName), lensClass, lensField, makeLensesWith, classyRules)

import Hledger.Utils.Debug
import Hledger.Utils.Parse
import Hledger.Utils.IO
import Hledger.Utils.Regex
import Hledger.Utils.String
import Hledger.Utils.Text
import Hledger.Utils.Test


-- Functions

-- | Apply a function the specified number of times,
-- which should be > 0 (otherwise does nothing).
-- Possibly uses O(n) stack ?
applyN :: Int -> (a -> a) -> a -> a
applyN :: forall a. Int -> (a -> a) -> a -> a
applyN Int
n a -> a
f | Int
n forall a. Ord a => a -> a -> Bool
< Int
1     = forall a. a -> a
id
           | Bool
otherwise = (forall a. [a] -> Int -> a
!! Int
n) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> a) -> a -> [a]
iterate a -> a
f
-- from protolude, compare
-- applyN :: Int -> (a -> a) -> a -> a
-- applyN n f = X.foldr (.) identity (X.replicate n f)

-- | Like mapM but uses sequence'.
{-# INLINABLE mapM' #-}
mapM' :: Monad f => (a -> f b) -> [a] -> f [b]
mapM' :: forall (f :: * -> *) a b. Monad f => (a -> f b) -> [a] -> f [b]
mapM' a -> f b
f = forall (f :: * -> *) a. Monad f => [f a] -> f [a]
sequence' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map a -> f b
f

-- | This is a version of sequence based on difference lists. It is
-- slightly faster but we mostly use it because it uses the heap
-- instead of the stack. This has the advantage that Neil Mitchell’s
-- trick of limiting the stack size to discover space leaks doesn’t
-- show this as a false positive.
{-# INLINABLE sequence' #-}
sequence' :: Monad f => [f a] -> f [a]
sequence' :: forall (f :: * -> *) a. Monad f => [f a] -> f [a]
sequence' [f a]
ms = do
  [a] -> [a]
h <- forall {m :: * -> *} {a} {c}.
Monad m =>
([a] -> c) -> [m a] -> m ([a] -> c)
go forall a. a -> a
id [f a]
ms
  forall (m :: * -> *) a. Monad m => a -> m a
return ([a] -> [a]
h [])
  where
    go :: ([a] -> c) -> [m a] -> m ([a] -> c)
go [a] -> c
h [] = forall (m :: * -> *) a. Monad m => a -> m a
return [a] -> c
h
    go [a] -> c
h (m a
m:[m a]
ms') = do
      a
x <- m a
m
      ([a] -> c) -> [m a] -> m ([a] -> c)
go ([a] -> c
h forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a
x forall a. a -> [a] -> [a]
:)) [m a]
ms'

curry2 :: ((a, b) -> c) -> a -> b -> c
curry2 :: forall a b c. ((a, b) -> c) -> a -> b -> c
curry2 (a, b) -> c
f a
x b
y = (a, b) -> c
f (a
x, b
y)

uncurry2 :: (a -> b -> c) -> (a, b) -> c
uncurry2 :: forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry2 a -> b -> c
f (a
x, b
y) = a -> b -> c
f a
x b
y

curry3 :: ((a, b, c) -> d) -> a -> b -> c -> d
curry3 :: forall a b c d. ((a, b, c) -> d) -> a -> b -> c -> d
curry3 (a, b, c) -> d
f a
x b
y c
z = (a, b, c) -> d
f (a
x, b
y, c
z)

uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d
uncurry3 :: forall a b c d. (a -> b -> c -> d) -> (a, b, c) -> d
uncurry3 a -> b -> c -> d
f (a
x, b
y, c
z) = a -> b -> c -> d
f a
x b
y c
z

curry4 :: ((a, b, c, d) -> e) -> a -> b -> c -> d -> e
curry4 :: forall a b c d e. ((a, b, c, d) -> e) -> a -> b -> c -> d -> e
curry4 (a, b, c, d) -> e
f a
w b
x c
y d
z = (a, b, c, d) -> e
f (a
w, b
x, c
y, d
z)

uncurry4 :: (a -> b -> c -> d -> e) -> (a, b, c, d) -> e
uncurry4 :: forall a b c d e. (a -> b -> c -> d -> e) -> (a, b, c, d) -> e
uncurry4 a -> b -> c -> d -> e
f (a
w, b
x, c
y, d
z) = a -> b -> c -> d -> e
f a
w b
x c
y d
z

-- Lists

-- | Total version of maximum, for integral types, giving 0 for an empty list.
maximum' :: Integral a => [a] -> a
maximum' :: forall a. Integral a => [a] -> a
maximum' [] = a
0
maximum' [a]
xs = forall a. Ord a => [a] -> a
maximumStrict [a]
xs

-- | Strict version of maximum that doesn’t leak space
{-# INLINABLE maximumStrict #-}
maximumStrict :: Ord a => [a] -> a
maximumStrict :: forall a. Ord a => [a] -> a
maximumStrict = forall a. (a -> a -> a) -> [a] -> a
foldl1' forall a. Ord a => a -> a -> a
max

-- | Strict version of minimum that doesn’t leak space
{-# INLINABLE minimumStrict #-}
minimumStrict :: Ord a => [a] -> a
minimumStrict :: forall a. Ord a => [a] -> a
minimumStrict = forall a. (a -> a -> a) -> [a] -> a
foldl1' forall a. Ord a => a -> a -> a
min

splitAtElement :: Eq a => a -> [a] -> [[a]]
splitAtElement :: forall a. Eq a => a -> [a] -> [[a]]
splitAtElement a
x [a]
l =
  case [a]
l of
    []          -> []
    a
e:[a]
es | a
eforall a. Eq a => a -> a -> Bool
==a
x -> [a] -> [[a]]
split [a]
es
    [a]
es          -> [a] -> [[a]]
split [a]
es
  where
    split :: [a] -> [[a]]
split [a]
es = let ([a]
first,[a]
rest) = forall a. (a -> Bool) -> [a] -> ([a], [a])
break (a
xforall a. Eq a => a -> a -> Bool
==) [a]
es
               in [a]
first forall a. a -> [a] -> [a]
: forall a. Eq a => a -> [a] -> [[a]]
splitAtElement a
x [a]
rest

-- | Strict version of sum that doesn’t leak space
{-# INLINABLE sumStrict #-}
sumStrict :: Num a => [a] -> a
sumStrict :: forall a. Num a => [a] -> a
sumStrict = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall a. Num a => a -> a -> a
(+) a
0

-- Trees

-- | Get the leaves of this tree as a list. 
-- The topmost node ("root" in hledger account trees) is not counted as a leaf.
treeLeaves :: Tree a -> [a]
treeLeaves :: forall a. Tree a -> [a]
treeLeaves Node{subForest :: forall a. Tree a -> [Tree a]
subForest=[]} = []
treeLeaves Tree a
t = forall a b. (a -> [b] -> b) -> Tree a -> b
foldTree (\a
a [[a]]
bs -> (if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[a]]
bs then (a
aforall a. a -> [a] -> [a]
:) else forall a. a -> a
id) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[a]]
bs) Tree a
t

-- Tuples

first3 :: (a, b, c) -> a
first3  (a
x,b
_,c
_) = a
x
second3 :: (a, b, c) -> b
second3 (a
_,b
x,c
_) = b
x
third3 :: (a, b, c) -> c
third3  (a
_,b
_,c
x) = c
x

first4 :: (a, b, c, d) -> a
first4  (a
x,b
_,c
_,d
_) = a
x
second4 :: (a, b, c, d) -> b
second4 (a
_,b
x,c
_,d
_) = b
x
third4 :: (a, b, c, d) -> c
third4  (a
_,b
_,c
x,d
_) = c
x
fourth4 :: (a, b, c, d) -> d
fourth4 (a
_,b
_,c
_,d
x) = d
x

first5 :: (a, b, c, d, e) -> a
first5  (a
x,b
_,c
_,d
_,e
_) = a
x
second5 :: (a, b, c, d, e) -> b
second5 (a
_,b
x,c
_,d
_,e
_) = b
x
third5 :: (a, b, c, d, e) -> c
third5  (a
_,b
_,c
x,d
_,e
_) = c
x
fourth5 :: (a, b, c, d, e) -> d
fourth5 (a
_,b
_,c
_,d
x,e
_) = d
x
fifth5 :: (a, b, c, d, e) -> e
fifth5  (a
_,b
_,c
_,d
_,e
x) = e
x

first6 :: (a, b, c, d, e, f) -> a
first6  (a
x,b
_,c
_,d
_,e
_,f
_) = a
x
second6 :: (a, b, c, d, e, f) -> b
second6 (a
_,b
x,c
_,d
_,e
_,f
_) = b
x
third6 :: (a, b, c, d, e, f) -> c
third6  (a
_,b
_,c
x,d
_,e
_,f
_) = c
x
fourth6 :: (a, b, c, d, e, f) -> d
fourth6 (a
_,b
_,c
_,d
x,e
_,f
_) = d
x
fifth6 :: (a, b, c, d, e, f) -> e
fifth6  (a
_,b
_,c
_,d
_,e
x,f
_) = e
x
sixth6 :: (a, b, c, d, e, f) -> f
sixth6  (a
_,b
_,c
_,d
_,e
_,f
x) = f
x

-- Misc

-- | Convert a list of strings to a multi-line multi-column list
-- fitting within the given width. Not wide character aware.
multicol :: Int -> [String] -> String
multicol :: Int -> [String] -> String
multicol Int
_ [] = []
multicol Int
width [String]
strs =
  let
    maxwidth :: Int
maxwidth = forall a. Integral a => [a] -> a
maximum' forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
strs
    numcols :: Int
numcols = forall a. Ord a => a -> a -> a
min (forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
strs) (Int
width forall a. Integral a => a -> a -> a
`div` (Int
maxwidthforall a. Num a => a -> a -> a
+Int
2))
    itemspercol :: Int
itemspercol = forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
strs forall a. Integral a => a -> a -> a
`div` Int
numcols
    colitems :: [[String]]
colitems = forall a. Partial => Int -> [a] -> [[a]]
chunksOf Int
itemspercol [String]
strs
    cols :: [String]
cols = forall a b. (a -> b) -> [a] -> [b]
map [String] -> String
unlines [[String]]
colitems
    sep :: String
sep = String
" "
  in
    Text -> String
T.unpack forall a b. (a -> b) -> a -> b
$ [Text] -> Text
textConcatBottomPadded forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall a. a -> [a] -> [a]
intersperse String
sep [String]
cols

-- | Find the number of digits of an 'Int'.
{-# INLINE numDigitsInt #-}
numDigitsInt :: Integral a => Int -> a
numDigitsInt :: forall a. Integral a => Int -> a
numDigitsInt Int
n
    | Int
n forall a. Eq a => a -> a -> Bool
== forall a. Bounded a => a
minBound = a
19  -- negate minBound is out of the range of Int
    | Int
n forall a. Ord a => a -> a -> Bool
< Int
0         = forall {a} {a}. (Num a, Integral a) => a -> a
go (forall a. Num a => a -> a
negate Int
n)
    | Bool
otherwise     = forall {a} {a}. (Num a, Integral a) => a -> a
go Int
n
  where
    go :: a -> a
go a
a | a
a forall a. Ord a => a -> a -> Bool
< a
10                 = a
1
         | a
a forall a. Ord a => a -> a -> Bool
< a
100                = a
2
         | a
a forall a. Ord a => a -> a -> Bool
< a
1000               = a
3
         | a
a forall a. Ord a => a -> a -> Bool
< a
10000              = a
4
         | a
a forall a. Ord a => a -> a -> Bool
>= a
10000000000000000 = a
16 forall a. Num a => a -> a -> a
+ a -> a
go (a
a forall a. Integral a => a -> a -> a
`quot` a
10000000000000000)
         | a
a forall a. Ord a => a -> a -> Bool
>= a
100000000         = a
8  forall a. Num a => a -> a -> a
+ a -> a
go (a
a forall a. Integral a => a -> a -> a
`quot` a
100000000)
         | Bool
otherwise              = a
4  forall a. Num a => a -> a -> a
+ a -> a
go (a
a forall a. Integral a => a -> a -> a
`quot` a
10000)

-- | Make classy lenses for Hledger options fields.
-- This is intended to be used with BalancingOpts, InputOpt, ReportOpts,
-- ReportSpec, and CliOpts.
-- When run on X, it will create a typeclass named HasX (except for ReportOpts,
-- which will be named HasReportOptsNoUpdate) containing all the lenses for that type.
-- If the field name starts with an underscore, the lens name will be created
-- by stripping the underscore from the front on the name. If the field name ends with
-- an underscore, the field name ends with an underscore, the lens name will be
-- mostly created by stripping the underscore, but a few names for which this
-- would create too many conflicts instead have a second underscore appended.
-- ReportOpts fields for which updating them requires updating the query in
-- ReportSpec are instead names by dropping the trailing underscore and
-- appending NoUpdate to the name, e.g. querystring_ -> querystringNoUpdate.
--
-- There are a few reasons for the complicated rules.
-- - We have some legacy field names ending in an underscore (e.g. value_)
--   which we want to temporarily accommodate, before eventually switching to
--   a more modern style (e.g. _rsReportOpts)
-- - Certain fields in ReportOpts need to update the enclosing ReportSpec when
--   they are updated, and it is a common programming error to forget to do
--   this. We append NoUpdate to those lenses which will not update the
--   enclosing field, and reserve the shorter name for manually define lenses
--   (or at least something lens-like) which will update the ReportSpec.
-- cf. the lengthy discussion here and in surrounding comments:
-- https://github.com/simonmichael/hledger/pull/1545#issuecomment-881974554
makeHledgerClassyLenses :: Name -> DecsQ
makeHledgerClassyLenses :: Name -> DecsQ
makeHledgerClassyLenses Name
x = forall a b c. (a -> b -> c) -> b -> a -> c
flip LensRules -> Name -> DecsQ
makeLensesWith Name
x forall a b. (a -> b) -> a -> b
$ LensRules
classyRules
    forall a b. a -> (a -> b) -> b
& Lens' LensRules (Name -> [Name] -> Name -> [DefName])
lensField forall s t a b. ASetter s t a b -> b -> s -> t
.~ (\Name
_ [Name]
_ Name
n -> String -> [DefName]
fieldName forall a b. (a -> b) -> a -> b
$ Name -> String
nameBase Name
n)
    forall a b. a -> (a -> b) -> b
& Lens' LensRules (Name -> Maybe (Name, Name))
lensClass forall s t a b. ASetter s t a b -> b -> s -> t
.~ (String -> Maybe (Name, Name)
className forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> String
nameBase)
  where
    fieldName :: String -> [DefName]
fieldName String
n | Just (Char
'_', String
name) <- forall a. [a] -> Maybe (a, [a])
uncons String
n   = [Name -> DefName
TopName (String -> Name
mkName String
name)]
                | Just (String
name, Char
'_') <- forall a. [a] -> Maybe ([a], a)
unsnoc String
n,
                  String
name forall a. Ord a => a -> Set a -> Bool
`Set.member` Set String
queryFields  = [Name -> DefName
TopName (String -> Name
mkName forall a b. (a -> b) -> a -> b
$ String
name forall a. [a] -> [a] -> [a]
++ String
"NoUpdate")]
                | Just (String
name, Char
'_') <- forall a. [a] -> Maybe ([a], a)
unsnoc String
n,
                  String
name forall a. Ord a => a -> Set a -> Bool
`Set.member` Set String
commonFields = [Name -> DefName
TopName (String -> Name
mkName forall a b. (a -> b) -> a -> b
$ String
name forall a. [a] -> [a] -> [a]
++ String
"__")]
                | Just (String
name, Char
'_') <- forall a. [a] -> Maybe ([a], a)
unsnoc String
n   = [Name -> DefName
TopName (String -> Name
mkName String
name)]
                | Bool
otherwise                      = []

    -- Fields which would cause too many conflicts if we exposed lenses with these names.
    commonFields :: Set String
commonFields = forall a. Ord a => [a] -> Set a
Set.fromList
        [ String
"empty", String
"drop", String
"color", String
"transpose"  -- ReportOpts
        , String
"anon", String
"new", String
"auto"                  -- InputOpts
        , String
"rawopts", String
"file", String
"debug", String
"width"    -- CliOpts
        ]

    -- When updating some fields of ReportOpts within a ReportSpec, we need to
    -- update the rsQuery term as well. To do this we implement a special
    -- HasReportOpts class with some special behaviour. We therefore give the
    -- basic lenses a special NoUpdate name to avoid conflicts.
    className :: String -> Maybe (Name, Name)
className String
"ReportOpts" = forall a. a -> Maybe a
Just (String -> Name
mkName String
"HasReportOptsNoUpdate", String -> Name
mkName String
"reportOptsNoUpdate")
    className (Char
x':String
xs)       = forall a. a -> Maybe a
Just (String -> Name
mkName (String
"Has" forall a. [a] -> [a] -> [a]
++ Char
x'forall a. a -> [a] -> [a]
:String
xs), String -> Name
mkName (Char -> Char
toLower Char
x' forall a. a -> [a] -> [a]
: String
xs))
    className []           = forall a. Maybe a
Nothing

    -- Fields of ReportOpts which need to update the Query when they are updated.
    queryFields :: Set String
queryFields = forall a. Ord a => [a] -> Set a
Set.fromList [String
"period", String
"statuses", String
"depth", String
"date2", String
"real", String
"querystring"]

tests_Utils :: TestTree
tests_Utils = String -> [TestTree] -> TestTree
testGroup String
"Utils" [
  TestTree
tests_Text
  ]