{-|

Standard imports and utilities which are useful everywhere, or needed low
in the module hierarchy. This is the bottom of hledger's module graph.

-}
{-# LANGUAGE LambdaCase #-}

module Hledger.Utils (---- provide these frequently used modules - or not, for clearer api:
                          -- module Control.Monad,
                          -- module Data.List,
                          -- module Data.Maybe,
                          -- module Data.Time.Calendar,
                          -- module Data.Time.Clock,
                          -- module Data.Time.LocalTime,
                          -- module Data.Tree,
                          -- module Text.RegexPR,
                          -- module Text.Printf,
                          ---- all of this one:
                          module Hledger.Utils,
                          module Hledger.Utils.Debug,
                          module Hledger.Utils.Parse,
                          module Hledger.Utils.Regex,
                          module Hledger.Utils.String,
                          module Hledger.Utils.Text,
                          module Hledger.Utils.Test,
                          -- Debug.Trace.trace,
                          -- module Data.PPrint,
                          -- the rest need to be done in each module I think
                          )
where

import Control.Monad (when)
import Data.Char (toLower)
import Data.FileEmbed (makeRelativeToProject, embedStringFile)
import Data.List.Extra (foldl', foldl1', uncons, unsnoc)
import qualified Data.Set as Set
import Data.Text (Text)
import qualified Data.Text.IO as T
import qualified Data.Text.Lazy.Builder as TB
import Data.Time.Clock (getCurrentTime)
import Data.Time.LocalTime (LocalTime, ZonedTime, getCurrentTimeZone,
                            utcToLocalTime, utcToZonedTime)
import Language.Haskell.TH (DecsQ, Name, mkName, nameBase)
-- import Language.Haskell.TH.Quote (QuasiQuoter(..))
import Language.Haskell.TH.Syntax (Q, Exp)
import Lens.Micro ((&), (.~))
import Lens.Micro.TH (DefName(TopName), lensClass, lensField, makeLensesWith, classyRules)
import System.Console.ANSI (Color,ColorIntensity,ConsoleLayer(..), SGR(..), setSGRCode)
import System.Directory (getHomeDirectory)
import System.FilePath (isRelative, (</>))
import System.IO
  (Handle, IOMode (..), hGetEncoding, hSetEncoding, hSetNewlineMode,
   openFile, stdin, universalNewlineMode, utf8_bom)

import Hledger.Utils.Debug
import Hledger.Utils.Parse
import Hledger.Utils.Regex
import Hledger.Utils.String
import Hledger.Utils.Text
import Hledger.Utils.Test
import Data.Tree (foldTree, Tree (Node, subForest))


-- 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

-- currying

curry2 :: ((a, b) -> c) -> a -> b -> c
curry2 :: ((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 :: (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 :: ((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 :: (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 :: ((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 :: (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

splitAtElement :: Eq a => a -> [a] -> [[a]]
splitAtElement :: a -> [a] -> [[a]]
splitAtElement a
x [a]
l =
  case [a]
l of
    []          -> []
    a
e:[a]
es | a
ea -> a -> Bool
forall 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) = (a -> Bool) -> [a] -> ([a], [a])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (a
xa -> a -> Bool
forall a. Eq a => a -> a -> Bool
==) [a]
es
               in [a]
first [a] -> [[a]] -> [[a]]
forall a. a -> [a] -> [a]
: a -> [a] -> [[a]]
forall a. Eq a => a -> [a] -> [[a]]
splitAtElement a
x [a]
rest

-- 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 :: Show a => Tree a -> [a]
treeLeaves :: Tree a -> [a]
treeLeaves Node{subForest :: forall a. Tree a -> Forest a
subForest=[]} = []
treeLeaves Tree a
t = (a -> [[a]] -> [a]) -> Tree a -> [a]
forall a b. (a -> [b] -> b) -> Tree a -> b
foldTree (\a
a [[a]]
bs -> (if [[a]] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[a]]
bs then (a
aa -> [a] -> [a]
forall a. a -> [a] -> [a]
:) else [a] -> [a]
forall a. a -> a
id) ([a] -> [a]) -> [a] -> [a]
forall a b. (a -> b) -> a -> b
$ [[a]] -> [a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[a]]
bs) Tree a
t

-- text

-- time

getCurrentLocalTime :: IO LocalTime
getCurrentLocalTime :: IO LocalTime
getCurrentLocalTime = do
  UTCTime
t <- IO UTCTime
getCurrentTime
  TimeZone
tz <- IO TimeZone
getCurrentTimeZone
  LocalTime -> IO LocalTime
forall (m :: * -> *) a. Monad m => a -> m a
return (LocalTime -> IO LocalTime) -> LocalTime -> IO LocalTime
forall a b. (a -> b) -> a -> b
$ TimeZone -> UTCTime -> LocalTime
utcToLocalTime TimeZone
tz UTCTime
t

getCurrentZonedTime :: IO ZonedTime
getCurrentZonedTime :: IO ZonedTime
getCurrentZonedTime = do
  UTCTime
t <- IO UTCTime
getCurrentTime
  TimeZone
tz <- IO TimeZone
getCurrentTimeZone
  ZonedTime -> IO ZonedTime
forall (m :: * -> *) a. Monad m => a -> m a
return (ZonedTime -> IO ZonedTime) -> ZonedTime -> IO ZonedTime
forall a b. (a -> b) -> a -> b
$ TimeZone -> UTCTime -> ZonedTime
utcToZonedTime TimeZone
tz UTCTime
t

-- misc

-- | 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 :: Int -> (a -> a) -> a -> a
applyN Int
n a -> a
f | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1     = a -> a
forall a. a -> a
id
           | Bool
otherwise = ([a] -> Int -> a
forall a. [a] -> Int -> a
!! Int
n) ([a] -> a) -> (a -> [a]) -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> a) -> a -> [a]
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)

-- | Convert a possibly relative, possibly tilde-containing file path to an absolute one,
-- given the current directory. ~username is not supported. Leave "-" unchanged.
-- Can raise an error.
expandPath :: FilePath -> FilePath -> IO FilePath -- general type sig for use in reader parsers
expandPath :: FilePath -> FilePath -> IO FilePath
expandPath FilePath
_ FilePath
"-" = FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
"-"
expandPath FilePath
curdir FilePath
p = (if FilePath -> Bool
isRelative FilePath
p then (FilePath
curdir FilePath -> FilePath -> FilePath
</>) else FilePath -> FilePath
forall a. a -> a
id) (FilePath -> FilePath) -> IO FilePath -> IO FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO FilePath
expandHomePath FilePath
p
-- PARTIAL:

-- | Expand user home path indicated by tilde prefix
expandHomePath :: FilePath -> IO FilePath
expandHomePath :: FilePath -> IO FilePath
expandHomePath = \case
    (Char
'~':Char
'/':FilePath
p)  -> (FilePath -> FilePath -> FilePath
</> FilePath
p) (FilePath -> FilePath) -> IO FilePath -> IO FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO FilePath
getHomeDirectory
    (Char
'~':Char
'\\':FilePath
p) -> (FilePath -> FilePath -> FilePath
</> FilePath
p) (FilePath -> FilePath) -> IO FilePath -> IO FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO FilePath
getHomeDirectory
    (Char
'~':FilePath
_)      -> IOError -> IO FilePath
forall a. IOError -> IO a
ioError (IOError -> IO FilePath) -> IOError -> IO FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> IOError
userError FilePath
"~USERNAME in paths is not supported"
    FilePath
p            -> FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
p

-- | Read text from a file,
-- converting any \r\n line endings to \n,,
-- using the system locale's text encoding,
-- ignoring any utf8 BOM prefix (as seen in paypal's 2018 CSV, eg) if that encoding is utf8.
readFilePortably :: FilePath -> IO Text
readFilePortably :: FilePath -> IO Text
readFilePortably FilePath
f =  FilePath -> IOMode -> IO Handle
openFile FilePath
f IOMode
ReadMode IO Handle -> (Handle -> IO Text) -> IO Text
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Handle -> IO Text
readHandlePortably

-- | Like readFilePortably, but read from standard input if the path is "-".
readFileOrStdinPortably :: String -> IO Text
readFileOrStdinPortably :: FilePath -> IO Text
readFileOrStdinPortably FilePath
f = FilePath -> IOMode -> IO Handle
openFileOrStdin FilePath
f IOMode
ReadMode IO Handle -> (Handle -> IO Text) -> IO Text
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Handle -> IO Text
readHandlePortably
  where
    openFileOrStdin :: String -> IOMode -> IO Handle
    openFileOrStdin :: FilePath -> IOMode -> IO Handle
openFileOrStdin FilePath
"-" IOMode
_ = Handle -> IO Handle
forall (m :: * -> *) a. Monad m => a -> m a
return Handle
stdin
    openFileOrStdin FilePath
f IOMode
m   = FilePath -> IOMode -> IO Handle
openFile FilePath
f IOMode
m

readHandlePortably :: Handle -> IO Text
readHandlePortably :: Handle -> IO Text
readHandlePortably Handle
h = do
  Handle -> NewlineMode -> IO ()
hSetNewlineMode Handle
h NewlineMode
universalNewlineMode
  Maybe TextEncoding
menc <- Handle -> IO (Maybe TextEncoding)
hGetEncoding Handle
h
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((TextEncoding -> FilePath) -> Maybe TextEncoding -> Maybe FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TextEncoding -> FilePath
forall a. Show a => a -> FilePath
show Maybe TextEncoding
menc Maybe FilePath -> Maybe FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
"UTF-8") (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$  -- XXX no Eq instance, rely on Show
    Handle -> TextEncoding -> IO ()
hSetEncoding Handle
h TextEncoding
utf8_bom
  Handle -> IO Text
T.hGetContents Handle
h

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

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

-- | Strict version of maximum that doesn’t leak space
{-# INLINABLE maximumStrict #-}
maximumStrict :: Ord a => [a] -> a
maximumStrict :: [a] -> a
maximumStrict = (a -> a -> a) -> [a] -> a
forall a. (a -> a -> a) -> [a] -> a
foldl1' a -> a -> a
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 :: [a] -> a
minimumStrict = (a -> a -> a) -> [a] -> a
forall a. (a -> a -> a) -> [a] -> a
foldl1' a -> a -> a
forall a. Ord a => a -> a -> a
min

-- | 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' :: [f a] -> f [a]
sequence' [f a]
ms = do
  [a] -> [a]
h <- ([a] -> [a]) -> [f a] -> f ([a] -> [a])
forall (m :: * -> *) a c.
Monad m =>
([a] -> c) -> [m a] -> m ([a] -> c)
go [a] -> [a]
forall a. a -> a
id [f a]
ms
  [a] -> f [a]
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 [] = ([a] -> c) -> m ([a] -> c)
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 ([a] -> c) -> ([a] -> [a]) -> [a] -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
:)) [m a]
ms

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

-- | Simpler alias for errorWithoutStackTrace
error' :: String -> a
error' :: FilePath -> a
error' = FilePath -> a
forall a. FilePath -> a
errorWithoutStackTrace

-- | A version of errorWithoutStackTrace that adds a usage hint.
usageError :: String -> a
usageError :: FilePath -> a
usageError = FilePath -> a
forall a. FilePath -> a
error' (FilePath -> a) -> (FilePath -> FilePath) -> FilePath -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" (use -h to see usage)")

-- | Like embedFile, but takes a path relative to the package directory.
-- Similar to embedFileRelative ?
embedFileRelative :: FilePath -> Q Exp
embedFileRelative :: FilePath -> Q Exp
embedFileRelative FilePath
f = FilePath -> Q FilePath
makeRelativeToProject FilePath
f Q FilePath -> (FilePath -> Q Exp) -> Q Exp
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= FilePath -> Q Exp
embedStringFile

-- -- | Like hereFile, but takes a path relative to the package directory.
-- -- Similar to embedFileRelative ?
-- hereFileRelative :: FilePath -> Q Exp
-- hereFileRelative f = makeRelativeToProject f >>= hereFileExp
--   where
--     QuasiQuoter{quoteExp=hereFileExp} = hereFile

-- | Wrap a string in ANSI codes to set and reset foreground colour.
color :: ColorIntensity -> Color -> String -> String
color :: ColorIntensity -> Color -> FilePath -> FilePath
color ColorIntensity
int Color
col FilePath
s = [SGR] -> FilePath
setSGRCode [ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
int Color
col] FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
s FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ [SGR] -> FilePath
setSGRCode []

-- | Wrap a string in ANSI codes to set and reset background colour.
bgColor :: ColorIntensity -> Color -> String -> String
bgColor :: ColorIntensity -> Color -> FilePath -> FilePath
bgColor ColorIntensity
int Color
col FilePath
s = [SGR] -> FilePath
setSGRCode [ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Background ColorIntensity
int Color
col] FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
s FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ [SGR] -> FilePath
setSGRCode []

-- | Wrap a WideBuilder in ANSI codes to set and reset foreground colour.
colorB :: ColorIntensity -> Color -> WideBuilder -> WideBuilder
colorB :: ColorIntensity -> Color -> WideBuilder -> WideBuilder
colorB ColorIntensity
int Color
col (WideBuilder Builder
s Int
w) =
    Builder -> Int -> WideBuilder
WideBuilder (FilePath -> Builder
TB.fromString ([SGR] -> FilePath
setSGRCode [ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
int Color
col]) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
s Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> FilePath -> Builder
TB.fromString ([SGR] -> FilePath
setSGRCode [])) Int
w

-- | Wrap a WideBuilder in ANSI codes to set and reset background colour.
bgColorB :: ColorIntensity -> Color -> WideBuilder -> WideBuilder
bgColorB :: ColorIntensity -> Color -> WideBuilder -> WideBuilder
bgColorB ColorIntensity
int Color
col (WideBuilder Builder
s Int
w) =
    Builder -> Int -> WideBuilder
WideBuilder (FilePath -> Builder
TB.fromString ([SGR] -> FilePath
setSGRCode [ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Background ColorIntensity
int Color
col]) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
s Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> FilePath -> Builder
TB.fromString ([SGR] -> FilePath
setSGRCode [])) Int
w


-- | 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 = (LensRules -> Name -> DecsQ) -> Name -> LensRules -> DecsQ
forall a b c. (a -> b -> c) -> b -> a -> c
flip LensRules -> Name -> DecsQ
makeLensesWith Name
x (LensRules -> DecsQ) -> LensRules -> DecsQ
forall a b. (a -> b) -> a -> b
$ LensRules
classyRules
    LensRules -> (LensRules -> LensRules) -> LensRules
forall a b. a -> (a -> b) -> b
& ((Name -> [Name] -> Name -> [DefName])
 -> Identity (Name -> [Name] -> Name -> [DefName]))
-> LensRules -> Identity LensRules
Lens' LensRules (Name -> [Name] -> Name -> [DefName])
lensField (((Name -> [Name] -> Name -> [DefName])
  -> Identity (Name -> [Name] -> Name -> [DefName]))
 -> LensRules -> Identity LensRules)
-> (Name -> [Name] -> Name -> [DefName]) -> LensRules -> LensRules
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (\Name
_ [Name]
_ Name
n -> FilePath -> [DefName]
fieldName (FilePath -> [DefName]) -> FilePath -> [DefName]
forall a b. (a -> b) -> a -> b
$ Name -> FilePath
nameBase Name
n)
    LensRules -> (LensRules -> LensRules) -> LensRules
forall a b. a -> (a -> b) -> b
& ((Name -> Maybe (Name, Name))
 -> Identity (Name -> Maybe (Name, Name)))
-> LensRules -> Identity LensRules
Lens' LensRules (Name -> Maybe (Name, Name))
lensClass (((Name -> Maybe (Name, Name))
  -> Identity (Name -> Maybe (Name, Name)))
 -> LensRules -> Identity LensRules)
-> (Name -> Maybe (Name, Name)) -> LensRules -> LensRules
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (FilePath -> Maybe (Name, Name)
className (FilePath -> Maybe (Name, Name))
-> (Name -> FilePath) -> Name -> Maybe (Name, Name)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> FilePath
nameBase)
  where
    fieldName :: FilePath -> [DefName]
fieldName FilePath
n | Just (Char
'_', FilePath
name) <- FilePath -> Maybe (Char, FilePath)
forall a. [a] -> Maybe (a, [a])
uncons FilePath
n   = [Name -> DefName
TopName (FilePath -> Name
mkName FilePath
name)]
                | Just (FilePath
name, Char
'_') <- FilePath -> Maybe (FilePath, Char)
forall a. [a] -> Maybe ([a], a)
unsnoc FilePath
n,
                  FilePath
name FilePath -> Set FilePath -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set FilePath
queryFields  = [Name -> DefName
TopName (FilePath -> Name
mkName (FilePath -> Name) -> FilePath -> Name
forall a b. (a -> b) -> a -> b
$ FilePath
name FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"NoUpdate")]
                | Just (FilePath
name, Char
'_') <- FilePath -> Maybe (FilePath, Char)
forall a. [a] -> Maybe ([a], a)
unsnoc FilePath
n,
                  FilePath
name FilePath -> Set FilePath -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set FilePath
commonFields = [Name -> DefName
TopName (FilePath -> Name
mkName (FilePath -> Name) -> FilePath -> Name
forall a b. (a -> b) -> a -> b
$ FilePath
name FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"__")]
                | Just (FilePath
name, Char
'_') <- FilePath -> Maybe (FilePath, Char)
forall a. [a] -> Maybe ([a], a)
unsnoc FilePath
n   = [Name -> DefName
TopName (FilePath -> Name
mkName FilePath
name)]
                | Bool
otherwise                      = []

    -- Fields which would cause too many conflicts if we exposed lenses with these names.
    commonFields :: Set FilePath
commonFields = [FilePath] -> Set FilePath
forall a. Ord a => [a] -> Set a
Set.fromList
        [ FilePath
"empty", FilePath
"drop", FilePath
"color", FilePath
"transpose"  -- ReportOpts
        , FilePath
"anon", FilePath
"new", FilePath
"auto"                  -- InputOpts
        , FilePath
"rawopts", FilePath
"file", FilePath
"debug", FilePath
"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 :: FilePath -> Maybe (Name, Name)
className FilePath
"ReportOpts" = (Name, Name) -> Maybe (Name, Name)
forall a. a -> Maybe a
Just (FilePath -> Name
mkName FilePath
"HasReportOptsNoUpdate", FilePath -> Name
mkName FilePath
"reportOptsNoUpdate")
    className (Char
x:FilePath
xs)       = (Name, Name) -> Maybe (Name, Name)
forall a. a -> Maybe a
Just (FilePath -> Name
mkName (FilePath
"Has" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Char
xChar -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:FilePath
xs), FilePath -> Name
mkName (Char -> Char
toLower Char
x Char -> FilePath -> FilePath
forall a. a -> [a] -> [a]
: FilePath
xs))
    className []           = Maybe (Name, Name)
forall a. Maybe a
Nothing

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

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