{-|

Check and show the status of the hledger installation.

-}
{-
Old design notes:

## Goals
- Make getting started with hledger and PTA easier and quicker, to
  (a) make this practical for more people (non techies, busy techies..)
  (b) free up more time and energy for learning and doing PTA and finance

Subgoals:
- Reduce the special knowledge and docs needed after install, to get a standard setup working (especially on windows)
- Help with discovery and setup of advanced quality of life terminal features
- Assist with setting up a first or new journal file
- Deliver relevant install/setup/config expertise more efficiently, freeing up dev and support time

## Design
Why a built in command and not a shell script, haskell script, or docs ?
So it is available and runs reliably anywhere a hledger executable runs, and so it can detect more context-specific advice.
(Optionally use shell or haskell scripts for prototyping, if that's helpful)

## Setup checks
Somewhat ordered.
These deal with the complexities of terminals, the shell, GHC, hledger, and the user's machine, locale, and data.
Initially just informational hints.
Later, add automated or interactive diagnosis and repair attempts,
and semi-persistent state (invalidated at suitable times).
These checks are a necessary evil/stopgap; long term, automate/replace/remove them whenever possible.

-}

-- {-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
-- {-# LANGUAGE NamedFieldPuns #-}
-- {-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}

{-# OPTIONS_GHC -Wno-name-shadowing #-}
{-# OPTIONS_GHC -Wno-unused-top-binds #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE RecordWildCards #-}
-- {-# OPTIONS_GHC -Wno-unused-matches #-}

module Hledger.Cli.Commands.Setup (
  setupmode
 ,setup
)
where

import Control.Exception
import Control.Monad
-- import qualified Data.ByteString as B
import Data.Char
import Data.Default (def)
import Data.List
import qualified Data.Map as M
import Data.Maybe
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Network.HTTP.Client
import Network.HTTP.Types (statusCode, hLocation)
import Network.HTTP.Req as R
import Safe
import System.Directory
import System.Environment (lookupEnv)
import System.Exit
import System.FilePath
import System.Info
import System.Process
import Text.Printf (printf)

import Hledger hiding (setupPager)
import Hledger.Cli.CliOptions
import Hledger.Cli.Conf
import Hledger.Cli.Version
import System.IO (localeEncoding)


setupmode :: Mode RawOpts
setupmode = String
-> [Flag RawOpts]
-> [(String, [Flag RawOpts])]
-> [Flag RawOpts]
-> ([Arg RawOpts], Maybe (Arg RawOpts))
-> Mode RawOpts
hledgerCommandMode
  $(embedFileRelative "Hledger/Cli/Commands/Setup.txt")
  []
  [(String, [Flag RawOpts])
generalflagsgroup3]
  []
  ([], Maybe (Arg RawOpts)
forall a. Maybe a
Nothing)


{- | Test and print the status of various aspects of the hledger installation.
May also show extra info and hints on how to fix problems.
The goal is to detect and show as much useful information as possible,
and to complete this task reliably regardless of what we find,
without premature termination or misformatting.

The tests are grouped into setup* routines, so named because they might do more
than just test in future.

This is the second version of setup. If it finds that the currently
running hledger is not the one installed in PATH (by comparing --version output),
it refuses to proceed further until that has been done.
This means it can rely on all the latest features and use the hledger API
within this process, simplifying things greatly.
-}
setup :: CliOpts -> Journal -> IO ()
setup :: CliOpts -> Journal -> IO ()
setup _opts :: CliOpts
_opts@CliOpts{rawopts_ :: CliOpts -> RawOpts
rawopts_=RawOpts
_rawopts, reportspec_ :: CliOpts -> ReportSpec
reportspec_=ReportSpec
_rspec} Journal
_ignoredj = do
  -- This command is not given a journal and should not use _ignoredj;
  -- instead read it ourselves when we are ready.
  String -> IO ()
putStrLn String
"Checking your hledger setup.."
  Bool
color <- IO Bool
useColorOnStdout
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
color (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ 
    String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Legend: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " [
       String -> String
good    String
"good"
      ,String -> String
neutral String
"neutral"
      ,String -> String
warning String
"unknown"
      ,String -> String
bad     String
"warning"
      ]
  Maybe (Either String Conf)
meconf <- IO (Maybe (Either String Conf))
setupHledger
  Maybe (Either String Conf) -> IO ()
forall {a}. Maybe (Either a Conf) -> IO ()
setupTerminal Maybe (Either String Conf)
meconf
  Maybe (Either String Conf) -> IO ()
forall {a}. Maybe (Either a Conf) -> IO ()
setupJournal Maybe (Either String Conf)
meconf
  String -> IO ()
putStr String
"\n"

------------------------------------------------------------------------------

-- Returns Nothing if no config file was found,
-- or Just the read error or config if it was found.
setupHledger :: IO (Maybe (Either String Conf))
setupHledger :: IO (Maybe (Either String Conf))
setupHledger = do
  String -> IO ()
pgroup String
"hledger"

  String -> IO ()
pdesc String
"is a released version ?"
  if Version -> Bool
isReleaseVersion (Version -> Bool) -> Version -> Bool
forall a b. (a -> b) -> a -> b
$ HledgerBinaryInfo -> Version
hbinPackageVersion HledgerBinaryInfo
binaryinfo
  then YNU -> String -> IO ()
p YNU
Y String
prognameandversion
  else YNU -> String -> IO ()
i YNU
N String
prognameandversion

  String -> IO ()
pdesc String
"is up to date ?"
  Either String String
elatestversionnumstr <- IO (Either String String)
getLatestHledgerVersion
  case Either String String
elatestversionnumstr of
    Left String
e -> YNU -> String -> IO ()
p YNU
U (String
"couldn't read " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
latestHledgerVersionUrlStr String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" , " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
e)
    Right String
latestversionnumstr ->
      case String -> Maybe Version
toVersion String
latestversionnumstr of
        Maybe Version
Nothing -> YNU -> String -> IO ()
p YNU
U String
"couldn't parse latest version number"
        Just Version
latestversion -> YNU -> String -> IO ()
p
          (if HledgerBinaryInfo -> Version
hbinPackageVersion HledgerBinaryInfo
binaryinfo Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
>= Version
latestversion then YNU
Y else YNU
N)
          (Version -> String
showVersion (HledgerBinaryInfo -> Version
hbinPackageVersion HledgerBinaryInfo
binaryinfo) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" installed, latest is " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
latestversionnumstr)

  String -> IO ()
pdesc String
"is a native binary for this machine ?"
  case HledgerBinaryInfo -> Maybe String
hbinArch HledgerBinaryInfo
binaryinfo of
    Maybe String
Nothing -> YNU -> String -> IO ()
p YNU
U (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"couldn't detect this binary's architecture"
    Just String
a | String
a String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
arch -> YNU -> String -> IO ()
p YNU
N (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"binary is for " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
a String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", system is " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
arch String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", may run slowly"
    Just String
a -> YNU -> String -> IO ()
p YNU
Y String
a

  String -> IO ()
pdesc String
"is installed in PATH ?"
  [String]
pathexes  <- String -> IO [String]
findExecutables String
progname
  let msg :: String
msg = String
"To see more, please install this hledger in PATH and run hledger setup again."
  case [String]
pathexes of
    [] -> YNU -> String -> IO ()
p YNU
N String
msg IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
forall a. IO a
exitFailure
    String
exe:[String]
_ -> do
      Either String String
eerrout <- [[String]] -> IO (Either String String)
tryHledgerArgs [[String
"--version", String
"--no-conf"], [String
"--version"]]
      case Either String String
eerrout of
        Left  String
err -> YNU -> String -> IO ()
p YNU
U (String
progname String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" --version failed: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
err) IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
forall a. IO a
exitFailure
        Right String
out -> do
          case String -> Either String HledgerBinaryInfo
parseHledgerVersion String
out of
            Left  String
_ -> YNU -> String -> IO ()
p YNU
U (String
"couldn't parse " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
progname String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" --version: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
rstrip String
out) IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
forall a. IO a
exitFailure
            Right HledgerBinaryInfo
pathbin -> do
              let pathversion :: String
pathversion = HledgerBinaryInfo -> String
hbinVersionOutput HledgerBinaryInfo
pathbin
              if String
pathversion String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
prognameandversion
              then YNU -> String -> IO ()
p YNU
N ([String] -> String
unlines [
                 String
""
                ,String
"found in PATH: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
exe
                ,String
"PATH hledger is: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
pathversion
                ,String
"this hledger is: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
prognameandversion
                ,String
msg
                ]) IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
forall a. IO a
exitFailure
              else YNU -> String -> IO ()
p YNU
Y String
exe

  String -> IO ()
pdesc String
"has a system text encoding configured ?"
  let encoding :: TextEncoding
encoding = TextEncoding
localeEncoding  -- the initial system encoding
  if (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (TextEncoding -> String
forall a. Show a => a -> String
show TextEncoding
encoding) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"ascii"
  then YNU -> String -> IO ()
p YNU
N (TextEncoding -> String
forall a. Show a => a -> String
show TextEncoding
encoding String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", please configure an encoding for non-ascii data")
  else YNU -> String -> IO ()
p YNU
Y (TextEncoding -> String
forall a. Show a => a -> String
show TextEncoding
encoding String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", data files should use this encoding")

  -- pdesc "can handle UTF-8 text ?"
  -- let
  --   eAcuteUtf8   = B.pack [0xC3, 0xA9]
  --   eAcuteLatin1 = B.pack [0xE9]
  -- case T.decodeUtf8' eAcuteUtf8 of
  --   Left _  -> p N "hledger's docs and examples use UTF-8"
  --   Right t -> p Y (T.unpack t)

  -- pdesc "can report text decoding failures ?"
  -- i U (T.unpack $ T.decodeUtf8 eAcuteLatin1)

  String -> IO ()
pdesc String
"has a user config file ? (optional)"
  Maybe String
muf <- IO (Maybe String)
activeUserConfFile
  let
    (YNU
ok, String
msg) = case Maybe String
muf of
      Just String
f  -> (YNU
Y, String
f)
      Maybe String
Nothing -> (YNU
N, String
"")
  YNU -> String -> IO ()
i YNU
ok String
msg

  String -> IO ()
pdesc String
"current directory has a local config ?"
  Maybe String
mlf <- IO (Maybe String)
activeLocalConfFile
  let
    (YNU
ok, String
msg) = case Maybe String
mlf of
      Just String
f  -> (YNU
Y, String
f) -- <> if isJust muf then " (masking user config)" else "")
      Maybe String
Nothing -> (YNU
N, String
"")
  YNU -> String -> IO ()
i YNU
ok String
msg

  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe String -> Bool
forall a. Maybe a -> Bool
isJust Maybe String
muf Bool -> Bool -> Bool
&& Maybe String -> Bool
forall a. Maybe a -> Bool
isJust Maybe String
mlf) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    String -> IO ()
pdesc String
"local config is masking user config ?"
    YNU -> String -> IO ()
i YNU
Y String
""

  if (Maybe String -> Bool
forall a. Maybe a -> Bool
isJust Maybe String
muf Bool -> Bool -> Bool
|| Maybe String -> Bool
forall a. Maybe a -> Bool
isJust Maybe String
mlf) then do
    String -> IO ()
pdesc String
"the config file is readable ?"
    Either String (Conf, Maybe String)
econf <- RawOpts -> IO (Either String (Conf, Maybe String))
getConf RawOpts
forall a. Default a => a
def
    case Either String (Conf, Maybe String)
econf of
      Left String
e -> YNU -> String -> IO ()
p YNU
N String
e IO ()
-> IO (Maybe (Either String Conf))
-> IO (Maybe (Either String Conf))
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe (Either String Conf) -> IO (Maybe (Either String Conf))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String Conf -> Maybe (Either String Conf)
forall a. a -> Maybe a
Just (Either String Conf -> Maybe (Either String Conf))
-> Either String Conf -> Maybe (Either String Conf)
forall a b. (a -> b) -> a -> b
$ String -> Either String Conf
forall a b. a -> Either a b
Left String
e)
      Right (Conf
conf, Maybe String
f) -> do
        YNU -> String -> IO ()
p YNU
Y (String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" Maybe String
f)

        -- pdesc "common general options are configured ?"
        -- --infer-costs"
        -- print --explicit --show-costs"

        Maybe (Either String Conf) -> IO (Maybe (Either String Conf))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Either String Conf) -> IO (Maybe (Either String Conf)))
-> Maybe (Either String Conf) -> IO (Maybe (Either String Conf))
forall a b. (a -> b) -> a -> b
$ Either String Conf -> Maybe (Either String Conf)
forall a. a -> Maybe a
Just (Either String Conf -> Maybe (Either String Conf))
-> Either String Conf -> Maybe (Either String Conf)
forall a b. (a -> b) -> a -> b
$ Conf -> Either String Conf
forall a b. b -> Either a b
Right Conf
conf
  else
    Maybe (Either String Conf) -> IO (Maybe (Either String Conf))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Either String Conf)
forall a. Maybe a
Nothing

------------------------------------------------------------------------------

setupTerminal :: Maybe (Either a Conf) -> IO ()
setupTerminal Maybe (Either a Conf)
meconf = do
  String -> IO ()
pgroup String
"terminal"
  let
    -- Find the last opt/arg matched by a predicate in the general config, if there is one.
    conflookup :: (String -> Bool) -> Maybe String
conflookup String -> Bool
predicate = case Maybe (Either a Conf)
meconf of
      Just (Right Conf
conf) -> (String -> Bool) -> [String] -> Maybe String
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find String -> Bool
predicate ([String] -> Maybe String) -> [String] -> Maybe String
forall a b. (a -> b) -> a -> b
$ [String] -> [String]
forall a. [a] -> [a]
reverse ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ String -> Conf -> [String]
confLookup String
"general" Conf
conf
      Maybe (Either a Conf)
_ -> Maybe String
forall a. Maybe a
Nothing

  String -> IO ()
pdesc String
"the NO_COLOR variable is defined ?"
  Maybe String
mnocolor <- String -> IO (Maybe String)
lookupEnv String
"NO_COLOR"
  case Maybe String
mnocolor of
    Maybe String
Nothing -> YNU -> String -> IO ()
i YNU
N String
""
    Just String
_  -> YNU -> String -> IO ()
i YNU
Y String
""

  Maybe (Either String YNA)
meconfigcolor <- do
    String -> IO ()
pdesc String
"--color is configured by config file ?"
    let mcolorarg :: Maybe String
mcolorarg = (String -> Bool) -> Maybe String
conflookup (\String
a -> (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
a) [String
"--color", String
"--colour"])
    case Maybe String
mcolorarg of
      Maybe String
Nothing -> YNU -> String -> IO ()
i YNU
N String
"" IO ()
-> IO (Maybe (Either String YNA)) -> IO (Maybe (Either String YNA))
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe (Either String YNA) -> IO (Maybe (Either String YNA))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Either String YNA)
forall a. Maybe a
Nothing
      Just String
a  -> do
        YNU -> String -> IO ()
i YNU
Y String
a
        let
          arg :: String
arg = String -> String
forall a. [a] -> [a]
reverse (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Char
'=',Char
' ']) (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. [a] -> [a]
reverse String
a
        Maybe (Either String YNA) -> IO (Maybe (Either String YNA))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Either String YNA) -> IO (Maybe (Either String YNA)))
-> Maybe (Either String YNA) -> IO (Maybe (Either String YNA))
forall a b. (a -> b) -> a -> b
$ Either String YNA -> Maybe (Either String YNA)
forall a. a -> Maybe a
Just (Either String YNA -> Maybe (Either String YNA))
-> Either String YNA -> Maybe (Either String YNA)
forall a b. (a -> b) -> a -> b
$ String -> Either String YNA
parseYNA String
arg

  String -> IO ()
pdesc String
"hledger will use color by default ?"
  case (Maybe (Either String YNA)
meconfigcolor, Maybe String -> Bool
forall a. Maybe a -> Bool
isJust Maybe String
mnocolor) of
    (Just (Right YNA
Yes), Bool
_)     -> YNU -> String -> IO ()
p YNU
Y String
""
    (Just (Right YNA
No),  Bool
_)     -> YNU -> String -> IO ()
i YNU
N String
""
    (Maybe (Either String YNA)
_,                Bool
True)  -> YNU -> String -> IO ()
i YNU
N String
""
    (Maybe (Either String YNA)
_,                Bool
False) -> YNU -> String -> IO ()
p YNU
Y String
""

  String -> IO ()
pdesc String
"the PAGER variable is defined ?"
  Maybe String
mv <- String -> IO (Maybe String)
lookupEnv String
"PAGER"
  case Maybe String
mv of
    Maybe String
Nothing -> YNU -> String -> IO ()
i YNU
N String
""
    Just String
v  -> YNU -> String -> IO ()
i YNU
Y String
v

  String -> IO ()
pdesc String
"--pager is configured by config file ?"
  let mpagerarg :: Maybe String
mpagerarg = (String -> Bool) -> Maybe String
conflookup (String
"--pager" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`)
  Maybe (Either String YNA)
meconfpager <- case Maybe String
mpagerarg of
    Maybe String
Nothing -> YNU -> String -> IO ()
i YNU
N String
"" IO ()
-> IO (Maybe (Either String YNA)) -> IO (Maybe (Either String YNA))
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe (Either String YNA) -> IO (Maybe (Either String YNA))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Either String YNA)
forall a. Maybe a
Nothing
    Just String
a  -> do
      YNU -> String -> IO ()
i YNU
Y String
a
      let arg :: String
arg = String -> String
forall a. [a] -> [a]
reverse (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Char
'=',Char
' ']) (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> String
forall a. [a] -> [a]
reverse String
a
      Maybe (Either String YNA) -> IO (Maybe (Either String YNA))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Either String YNA) -> IO (Maybe (Either String YNA)))
-> Maybe (Either String YNA) -> IO (Maybe (Either String YNA))
forall a b. (a -> b) -> a -> b
$ Either String YNA -> Maybe (Either String YNA)
forall a. a -> Maybe a
Just (Either String YNA -> Maybe (Either String YNA))
-> Either String YNA -> Maybe (Either String YNA)
forall a b. (a -> b) -> a -> b
$ String -> Either String YNA
parseYNA String
arg

  String -> IO ()
pdesc String
"hledger will use a pager when needed ?"
  Maybe String
mpager <- IO (Maybe String)
findPager
  case Maybe String
mpager of
    Maybe String
Nothing    -> YNU -> String -> IO ()
p YNU
N String
"no pager was found"
    Just String
pager ->
      case Maybe (Either String YNA)
meconfpager of
        Just (Right YNA
No) -> YNU -> String -> IO ()
p YNU
N String
"disabled in config file"
        Maybe (Either String YNA)
_ -> do
          YNU -> String -> IO ()
p YNU
Y String
pager

          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (String -> String
takeBaseName String
pager) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"more") (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            String -> IO ()
pdesc String
"the MORE variable is defined ?"
            Maybe String
mv <- String -> IO (Maybe String)
lookupEnv String
"MORE"
            case Maybe String
mv of
              Maybe String
Nothing -> YNU -> String -> IO ()
i YNU
N String
""
              Just String
v  -> YNU -> String -> IO ()
i YNU
Y String
v

          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower (String -> String
takeBaseName String
pager) String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"less") (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            String -> IO ()
pdesc String
"the LESS variable is defined ?"
            Maybe String
mLESS <- String -> IO (Maybe String)
lookupEnv String
"LESS"
            case Maybe String
mLESS of
              Maybe String
Nothing -> YNU -> String -> IO ()
i YNU
N String
""
              Just String
_  -> YNU -> String -> IO ()
i YNU
Y String
""

            String -> IO ()
pdesc String
"the HLEDGER_LESS variable is defined ?"
            Maybe String
mHLEDGER_LESS <- String -> IO (Maybe String)
lookupEnv String
"HLEDGER_LESS"
            case Maybe String
mHLEDGER_LESS of
              Maybe String
Nothing -> YNU -> String -> IO ()
i YNU
N String
""
              Just String
v  -> YNU -> String -> IO ()
i YNU
Y String
v

            Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe String -> Bool
forall a. Maybe a -> Bool
isNothing Maybe String
mHLEDGER_LESS) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
              String -> IO ()
pdesc String
"adjusting LESS variable for color etc. ?"
              Bool
usecolor <- IO Bool
useColorOnStdout
              YNU -> String -> IO ()
i (if Bool
usecolor then YNU
Y else YNU
N) String
""

  String -> IO ()
pdesc String
"--pretty is enabled by config file ?"
  if Maybe String -> Bool
forall a. Maybe a -> Bool
isJust (Maybe String -> Bool) -> Maybe String -> Bool
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> Maybe String
conflookup (String
"--pretty"String -> String -> Bool
forall a. Eq a => a -> a -> Bool
==)
  then YNU -> String -> IO ()
p YNU
Y String
"tables will use box-drawing characters"
  else YNU -> String -> IO ()
i YNU
N String
"tables will use ASCII characters"

  String -> IO ()
pdesc String
"bash shell completions are installed ?" IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> YNU -> String -> IO ()
p YNU
U String
""
  String -> IO ()
pdesc String
"zsh shell completions are installed ?" IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> YNU -> String -> IO ()
p YNU
U String
""

------------------------------------------------------------------------------

setupJournal :: Maybe (Either a Conf) -> IO ()
setupJournal Maybe (Either a Conf)
meconf = do
  String -> IO ()
pgroup String
"journal"
  let
    -- Find the last opt/arg matched by a predicate in the general config, if there is one.
    conflookup :: (String -> Bool) -> Maybe String
conflookup String -> Bool
predicate = case Maybe (Either a Conf)
meconf of
      Just (Right Conf
conf) -> (String -> Bool) -> [String] -> Maybe String
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find String -> Bool
predicate ([String] -> Maybe String) -> [String] -> Maybe String
forall a b. (a -> b) -> a -> b
$ [String] -> [String]
forall a. [a] -> [a]
reverse ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ String -> Conf -> [String]
confLookup String
"general" Conf
conf
      Maybe (Either a Conf)
_ -> Maybe String
forall a. Maybe a
Nothing

  -- pdesc "a home directory journal file exists ?"
  -- mh <- getHomeSafe
  -- (ok,msg) <- case mh of
  --   Just h -> do
  --     let f = h </> journalDefaultFilename
  --     e <- doesFileExist f
  --     return (if e then Y else N, if e then f else "")
  --   Nothing -> return (N, "")
  -- i ok msg

  String -> IO ()
pdesc String
"the LEDGER_FILE variable is defined ?"
  Maybe String
mf <- String -> IO (Maybe String)
lookupEnv String
journalEnvVar
  let
    (YNU
ok, String
msg) = case Maybe String
mf of
      Just String
f  -> (YNU
Y, String
f)
      Maybe String
Nothing -> (YNU
N, String
"")
  YNU -> String -> IO ()
i YNU
ok String
msg

  -- case mf of
  --   Nothing -> return ()
  --   Just f -> do
  --     pdesc "$LEDGER_FILE journal exists ?"
  --     e <- doesFileExist f
  --     i e "" ""

  -- when (isJust mh && isJust mf) $ do
  --   pdesc "$LEDGER_FILE is masking home journal ?"
  --   i Y ""

  String -> IO ()
pdesc String
"a default journal file is readable ?"
  String
jfile <- IO String
defaultJournalPath
  -- let
  --   args = concat [
  --     ["print"],
  --     ["--ignore-assertions" | supportsIgnoreAssertions version],
  --     ["--no-conf" | supportsConfigFiles version]
  --     ]
  -- (exit, _, err) <- readProcessWithExitCode progname args ""
  -- XXX can this ignore assertions and config files, like the above ?
  Either String Journal
ej <- IO (Either String Journal)
defaultJournalSafely
  case Either String Journal
ej of
    Left String
estr -> YNU -> String -> IO ()
p YNU
N (String
jfile String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
":\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
estr)
    Right j :: Journal
j@Journal{[String]
[(String, Text)]
[(Text, AccountDeclarationInfo)]
[(Text, TagDeclarationInfo)]
[(Text, PayeeDeclarationInfo)]
[Text]
[MarketPrice]
[PriceDirective]
[TimeclockEntry]
[PeriodicTransaction]
[TransactionModifier]
[Transaction]
[AccountAlias]
Maybe Char
Maybe Year
Maybe (Text, AmountStyle)
Text
Map Text [Tag]
Map Text Commodity
Map Text AmountStyle
Map Text AccountType
Map AccountType [Text]
POSIXTime
jparsedefaultyear :: Maybe Year
jparsedefaultcommodity :: Maybe (Text, AmountStyle)
jparsedecimalmark :: Maybe Char
jparseparentaccounts :: [Text]
jparsealiases :: [AccountAlias]
jparsetimeclockentries :: [TimeclockEntry]
jincludefilestack :: [String]
jdeclaredpayees :: [(Text, PayeeDeclarationInfo)]
jdeclaredtags :: [(Text, TagDeclarationInfo)]
jdeclaredaccounts :: [(Text, AccountDeclarationInfo)]
jdeclaredaccounttags :: Map Text [Tag]
jdeclaredaccounttypes :: Map AccountType [Text]
jaccounttypes :: Map Text AccountType
jdeclaredcommodities :: Map Text Commodity
jinferredcommoditystyles :: Map Text AmountStyle
jglobalcommoditystyles :: Map Text AmountStyle
jpricedirectives :: [PriceDirective]
jinferredmarketprices :: [MarketPrice]
jtxnmodifiers :: [TransactionModifier]
jperiodictxns :: [PeriodicTransaction]
jtxns :: [Transaction]
jfinalcommentlines :: Text
jfiles :: [(String, Text)]
jlastreadtime :: POSIXTime
jlastreadtime :: Journal -> POSIXTime
jfiles :: Journal -> [(String, Text)]
jfinalcommentlines :: Journal -> Text
jtxns :: Journal -> [Transaction]
jperiodictxns :: Journal -> [PeriodicTransaction]
jtxnmodifiers :: Journal -> [TransactionModifier]
jinferredmarketprices :: Journal -> [MarketPrice]
jpricedirectives :: Journal -> [PriceDirective]
jglobalcommoditystyles :: Journal -> Map Text AmountStyle
jinferredcommoditystyles :: Journal -> Map Text AmountStyle
jdeclaredcommodities :: Journal -> Map Text Commodity
jaccounttypes :: Journal -> Map Text AccountType
jdeclaredaccounttypes :: Journal -> Map AccountType [Text]
jdeclaredaccounttags :: Journal -> Map Text [Tag]
jdeclaredaccounts :: Journal -> [(Text, AccountDeclarationInfo)]
jdeclaredtags :: Journal -> [(Text, TagDeclarationInfo)]
jdeclaredpayees :: Journal -> [(Text, PayeeDeclarationInfo)]
jincludefilestack :: Journal -> [String]
jparsetimeclockentries :: Journal -> [TimeclockEntry]
jparsealiases :: Journal -> [AccountAlias]
jparseparentaccounts :: Journal -> [Text]
jparsedecimalmark :: Journal -> Maybe Char
jparsedefaultcommodity :: Journal -> Maybe (Text, AmountStyle)
jparsedefaultyear :: Journal -> Maybe Year
..} -> do
      YNU -> String -> IO ()
p YNU
Y String
jfile

      String -> IO ()
pdesc String
"it includes additional files ?"
      let numfiles :: Int
numfiles = [(String, Text)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(String, Text)]
jfiles
      if Int
numfiles Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1
      then YNU -> String -> IO ()
i YNU
Y (Int -> String
forall a. Show a => a -> String
show (Int -> String) -> Int -> String
forall a b. (a -> b) -> a -> b
$ Int
numfiles Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
      else YNU -> String -> IO ()
i YNU
N String
""

      String -> IO ()
pdesc String
"all commodities are declared ?"
      let
        numcommodities :: Int
numcommodities = Set Text -> Int
forall a. Set a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Set Text -> Int) -> Set Text -> Int
forall a b. (a -> b) -> a -> b
$ Journal -> Set Text
journalCommodities Journal
j
        undeclaredcommodities :: [Text]
undeclaredcommodities = Journal -> [Text]
journalCommoditiesUsed Journal
j [Text] -> [Text] -> [Text]
forall a. Eq a => [a] -> [a] -> [a]
\\ Journal -> [Text]
journalCommoditiesDeclared Journal
j
      if [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
undeclaredcommodities
      then YNU -> String -> IO ()
p YNU
Y (Int -> String
forall a. Show a => a -> String
show Int
numcommodities)
      else YNU -> String -> IO ()
p YNU
N (Int -> String
forall a. Show a => a -> String
show ([Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
undeclaredcommodities) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"; declaring helps set their precision")

      let
        accttypes :: [AccountType]
accttypes = [AccountType
Asset, AccountType
Liability, AccountType
Equity, AccountType
Revenue, AccountType
Expense, AccountType
Cash, AccountType
Conversion]
        typesdeclaredorinferred :: [AccountType]
typesdeclaredorinferred = [AccountType] -> [AccountType]
forall a. Eq a => [a] -> [a]
nub ([AccountType] -> [AccountType]) -> [AccountType] -> [AccountType]
forall a b. (a -> b) -> a -> b
$ Map Text AccountType -> [AccountType]
forall k a. Map k a -> [a]
M.elems Map Text AccountType
jaccounttypes
        typesnotfound :: [AccountType]
typesnotfound = (AccountType -> Bool) -> [AccountType] -> [AccountType]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not(Bool -> Bool) -> (AccountType -> Bool) -> AccountType -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.(AccountType -> [AccountType] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [AccountType]
typesdeclaredorinferred)) [AccountType]
accttypes
        acctswithdeclaredorinferredtype :: [Text]
acctswithdeclaredorinferredtype = [Text] -> [Text]
forall a. Eq a => [a] -> [a]
nub (Map Text AccountType -> [Text]
forall k a. Map k a -> [k]
M.keys Map Text AccountType
jaccounttypes)
        numaccts :: Int
numaccts = [Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([Text] -> Int) -> [Text] -> Int
forall a b. (a -> b) -> a -> b
$ Journal -> [Text]
journalAccountNames Journal
j
        untypedaccts :: [Text]
untypedaccts = Journal -> [Text]
journalAccountNames Journal
j [Text] -> [Text] -> [Text]
forall a. Eq a => [a] -> [a] -> [a]
\\ [Text]
acctswithdeclaredorinferredtype
        undeclaredaccts :: [Text]
undeclaredaccts = Journal -> [Text]
journalAccountNamesUsed Journal
j [Text] -> [Text] -> [Text]
forall a. Eq a => [a] -> [a] -> [a]
\\ Journal -> [Text]
journalAccountNamesDeclared Journal
j
        -- hasdeclaredaccts t = case M.lookup t jdeclaredaccounttypes of
        --   Just (_ : _) -> True
        --   _ -> False

      -- pdesc "Asset accounts declared ?"    
      -- if hasdeclaredaccts Asset then i Y "" else i N ""

      -- pdesc "Liability accounts declared ?"
      -- if hasdeclaredaccts Liability then i Y "" else i N ""

      -- pdesc "Equity accounts declared ?"
      -- if hasdeclaredaccts Equity then i Y "" else i N ""

      -- pdesc "Revenue accounts declared ?"
      -- if hasdeclaredaccts Revenue then i Y "" else i N ""

      -- pdesc "Expense accounts declared ?"
      -- if hasdeclaredaccts Expense then i Y "" else i N ""

      -- pdesc "Cash accounts declared ?"
      -- if hasdeclaredaccts Cash then i Y "" else i N ""

      -- pdesc "Conversion accounts declared ?"
      -- if hasdeclaredaccts Conversion then i Y "" else i N ""  -- ("--infer-equity will use a default conversion account name")

      -- XXX hard to detect accounts where type was inferred from name
      -- unless arealltypesdeclared $ do
      -- let
      --   acctswithdeclaredtype           = concat (M.elems jdeclaredaccounttypes)
      --   acctswithinferredtype           = acctswithdeclaredorinferredtype \\ acctswithdeclaredtype
      --   arealltypesdeclared = all hasdeclaredaccts accttypes
      --   typesinferredfromnames =
      --     if arealltypesdeclared then []
      --     else sort $ nub $ catMaybes $ map (flip M.lookup jaccounttypes) acctswithinferredtype
      -- pdesc "types detected from account names ?"
      -- if null typesinferredfromnames then i N "" else i Y (concatMap show typesinferredfromnames)

      String -> IO ()
pdesc String
"all accounts are declared ?"
      if [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
undeclaredaccts then YNU -> String -> IO ()
p YNU
Y (Int -> String
forall a. Show a => a -> String
show Int
numaccts) else YNU -> String -> IO ()
i YNU
N (Int -> String
forall a. Show a => a -> String
show ([Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
undeclaredaccts) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" undeclared")

      String -> IO ()
pdesc String
"all accounts have types ?"
      if [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
untypedaccts then YNU -> String -> IO ()
p YNU
Y String
"" else YNU -> String -> IO ()
i YNU
N (Int -> String
forall a. Show a => a -> String
show ([Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
untypedaccts) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" untyped")

      String -> IO ()
pdesc String
"accounts of each type were detected ?"
      if [AccountType] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [AccountType]
typesnotfound
      then YNU -> String -> IO ()
p YNU
Y ((AccountType -> String) -> [AccountType] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap AccountType -> String
forall a. Show a => a -> String
show [AccountType]
accttypes)
      else YNU -> String -> IO ()
p YNU
N ((AccountType -> String) -> [AccountType] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap AccountType -> String
forall a. Show a => a -> String
show [AccountType]
typesnotfound String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"not found; type: queries, bs/cf/is reports may not work")

      String -> IO ()
pdesc String
"commodities/accounts are checked ?"
      let strict :: Bool
strict = Maybe String -> Bool
forall a. Maybe a -> Bool
isJust (Maybe String -> Bool) -> Maybe String -> Bool
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> Maybe String
conflookup (\String
a -> (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
==String
a) [String
"-s", String
"--strict"])
      if Bool
strict
      then YNU -> String -> IO ()
i YNU
Y String
"commodities and accounts must be declared"
      else YNU -> String -> IO ()
i YNU
N String
"use -s to check commodities/accounts"

      String -> IO ()
pdesc String
"balance assertions are checked ?"
      let ignoreassertions :: Bool
ignoreassertions = Maybe String -> Bool
forall a. Maybe a -> Bool
isJust (Maybe String -> Bool) -> Maybe String -> Bool
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> Maybe String
conflookup (\String
a -> (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
==String
a) [String
"-I", String
"--ignore-assertions"])
      if 
        | Bool
ignoreassertions Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
strict -> YNU -> String -> IO ()
i YNU
N String
"use -s to check assertions"
        | Bool -> Bool
not Bool
strict -> YNU -> String -> IO ()
i YNU
Y String
"use -I to ignore assertions"
        | Bool
otherwise -> YNU -> String -> IO ()
i YNU
Y String
"can't ignore assertions (-s in config file)"

------------------------------------------------------------------------------

-- Test a hledger version for support of various features.
Version
ver >=! :: Version -> String -> Bool
>=! String
str = Version
ver Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
>= (Maybe Version -> Version
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Version -> Version) -> Maybe Version -> Version
forall a b. (a -> b) -> a -> b
$ String -> Maybe Version
toVersion String
str)
supportsIgnoreAssertions :: Version -> Bool
supportsIgnoreAssertions = (Version -> String -> Bool
>=! String
"0.24") -- --ignore-assertions (2014)
supportsCommodityDirective :: Version -> Bool
supportsCommodityDirective = (Version -> String -> Bool
>=! String
"1.0") -- commodity directive (2016)
supportsPretty :: Version -> Bool
supportsPretty = (Version -> String -> Bool
>=! String
"1.2") -- --pretty, to use box-drawing characters (2017)
supportsAccountDirective :: Version -> Bool
supportsAccountDirective = (Version -> String -> Bool
>=! String
"1.9") -- account directive (2018)
supportsAccountTypes :: Version -> Bool
supportsAccountTypes = (Version -> String -> Bool
>=! String
"1.13") -- ALERX account types, type: tag (2019)
supportsCashAccountType :: Version -> Bool
supportsCashAccountType = (Version -> String -> Bool
>=! String
"1.19") -- C/Cash account type (2020)
supportsBasicColor :: Version -> Bool
supportsBasicColor = (Version -> String -> Bool
>=! String
"1.19") -- basic color detection/control (2020)
supportsConversionAccountType :: Version -> Bool
supportsConversionAccountType = (Version -> String -> Bool
>=! String
"1.25") -- V/Conversion account type, accounts --types (2022)
supportsConfigFiles :: Version -> Bool
supportsConfigFiles = (Version -> String -> Bool
>=! String
"1.40") -- config files (2024)
supportsColor :: Version -> Bool
supportsColor = (Version -> String -> Bool
>=! String
"1.41") -- robust color detection/control (2024)
supportsPager :: Version -> Bool
supportsPager = (Version -> String -> Bool
>=! String
"1.41") -- use a pager for all output (2024)
supportsBashCompletions :: Version -> Bool
supportsBashCompletions = (Version -> String -> Bool
>=! String
"1.41") -- up to date bash shell completions (2024)

-- yes, no, unknown
data YNU = Y | N | U deriving (YNU -> YNU -> Bool
(YNU -> YNU -> Bool) -> (YNU -> YNU -> Bool) -> Eq YNU
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: YNU -> YNU -> Bool
== :: YNU -> YNU -> Bool
$c/= :: YNU -> YNU -> Bool
/= :: YNU -> YNU -> Bool
Eq)

-- ANSI styles
good :: String -> String
good    = String -> String
bold' (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
brightGreen'
neutral :: String -> String
neutral = String -> String
bold' (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
brightBlue'
warning :: String -> String
warning = String -> String
bold' (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
brightYellow'
bad :: String -> String
bad     = String -> String
bold' (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
brightRed'

-- Show status, in red/green/yellow if supported.
instance Show YNU where
  show :: YNU -> String
show YNU
Y = String -> String
good    String
"yes"    -- ✅ apple emojis - won't work everywhere
  show YNU
N = String -> String
bad     String
" no"    -- ❌
  show YNU
U = String -> String
warning String
"  ?"

-- Show status, in blue/yellow if supported.
showInfo :: YNU -> String
showInfo YNU
Y = String -> String
neutral String
"yes"  -- ℹ️
showInfo YNU
N = String -> String
neutral String
" no"  -- ℹ️
showInfo YNU
U = String -> String
warning String
"  ?"

-- | Print a test's pass or fail status, as "yes" or "no" or "",
-- in green/red if supported, and the (possibly empty) provided message.
p :: YNU -> String -> IO ()
p :: YNU -> String -> IO ()
p YNU
ok String
msg = String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [String
"", YNU -> String
forall a. Show a => a -> String
show YNU
ok, String
"", String
msg]

-- | Like p, but display the status as info, in neutral blue.
i :: YNU -> String -> IO ()
i :: YNU -> String -> IO ()
i YNU
ok String
msg = String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [String
"", YNU -> String
showInfo YNU
ok, String
"", String
msg]

-- | Print a setup test groups heading.
pgroup :: String -> IO ()
pgroup :: String -> IO ()
pgroup String
s = String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
bold' String
s

-- | Print a setup test's description, formatting and padding it to a fixed width.
pdesc :: String -> IO ()
pdesc :: String -> IO ()
pdesc String
s = String -> String -> IO ()
forall r. PrintfType r => String -> r
printf String
"* %-40s" String
s

(IO (Either String String)
getLatestHledgerVersion, String
latestHledgerVersionUrlStr) =
  -- (getLatestHledgerVersionFromHackage, "https://hackage.haskell.org/package/hledger/docs")
  (IO (Either String String)
getLatestHledgerVersionFromHledgerOrg, String
"https://hledger.org/install.html")

httptimeout :: Int
httptimeout = Int
10000000  -- 10s

-- | Get the current hledger release version from the internet.
-- Currently requests the latest doc page from Hackage and inspects the redirect path.
-- Should catch all normal errors, and time out after 10 seconds.
getLatestHledgerVersionFromHackage :: IO (Either String String)
getLatestHledgerVersionFromHackage :: IO (Either String String)
getLatestHledgerVersionFromHackage = do
  let url :: Url 'Https
url = Text -> Url 'Https
https Text
"hackage.haskell.org" Url 'Https -> Text -> Url 'Https
forall (scheme :: Scheme). Url scheme -> Text -> Url scheme
/: Text
"package" Url 'Https -> Text -> Url 'Https
forall (scheme :: Scheme). Url scheme -> Text -> Url scheme
/: Text
"hledger" Url 'Https -> Text -> Url 'Https
forall (scheme :: Scheme). Url scheme -> Text -> Url scheme
/: Text
"docs" Url 'Https -> Text -> Url 'Https
forall (scheme :: Scheme). Url scheme -> Text -> Url scheme
/: Text
""
  Either HttpException BsResponse
result <- IO BsResponse -> IO (Either HttpException BsResponse)
forall e a. Exception e => IO a -> IO (Either e a)
try (IO BsResponse -> IO (Either HttpException BsResponse))
-> IO BsResponse -> IO (Either HttpException BsResponse)
forall a b. (a -> b) -> a -> b
$ HttpConfig -> Req BsResponse -> IO BsResponse
forall (m :: * -> *) a. MonadIO m => HttpConfig -> Req a -> m a
runReq HttpConfig
defaultHttpConfig{httpConfigRedirectCount=0} (Req BsResponse -> IO BsResponse)
-> Req BsResponse -> IO BsResponse
forall a b. (a -> b) -> a -> b
$
    HEAD
-> Url 'Https
-> NoReqBody
-> Proxy BsResponse
-> Option 'Https
-> Req BsResponse
forall (m :: * -> *) method body response (scheme :: Scheme).
(MonadHttp m, HttpMethod method, HttpBody body,
 HttpResponse response,
 HttpBodyAllowed (AllowsBody method) (ProvidesBody body)) =>
method
-> Url scheme
-> body
-> Proxy response
-> Option scheme
-> m response
req HEAD
HEAD Url 'Https
url NoReqBody
NoReqBody Proxy BsResponse
bsResponse (Int -> Option 'Https
forall (scheme :: Scheme). Int -> Option scheme
R.responseTimeout Int
httptimeout)
  case Either HttpException BsResponse
result of
    Right BsResponse
_ -> Either String String -> IO (Either String String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String String -> IO (Either String String))
-> Either String String -> IO (Either String String)
forall a b. (a -> b) -> a -> b
$ String -> Either String String
forall a b. a -> Either a b
Left String
"expected a redirect"
    Left (VanillaHttpException (HttpExceptionRequest Request
_ (StatusCodeException Response ()
rsp ByteString
_))) -> do
      let status :: Int
status = Status -> Int
statusCode (Status -> Int) -> Status -> Int
forall a b. (a -> b) -> a -> b
$ Response () -> Status
forall body. Response body -> Status
responseStatus Response ()
rsp
      if Int
status Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
300 Bool -> Bool -> Bool
&& Int
status Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
400
        then do
          let locationHeader :: Maybe ByteString
locationHeader = HeaderName -> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
hLocation (Response () -> [(HeaderName, ByteString)]
forall body. Response body -> [(HeaderName, ByteString)]
responseHeaders Response ()
rsp)
          case (ByteString -> Text) -> Maybe ByteString -> Maybe Text
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Text
T.decodeUtf8 Maybe ByteString
locationHeader of
            Maybe Text
Nothing       -> Either String String -> IO (Either String String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String String -> IO (Either String String))
-> Either String String -> IO (Either String String)
forall a b. (a -> b) -> a -> b
$ String -> Either String String
forall a b. a -> Either a b
Left String
"no Location header"
            Just Text
location -> do
              let packagename :: [Text]
packagename = Int -> [Text] -> [Text]
forall a. Int -> [a] -> [a]
take Int
1 ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ Int -> [Text] -> [Text]
forall a. Int -> [a] -> [a]
drop Int
1 ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ [Text] -> [Text]
forall a. [a] -> [a]
reverse ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"/" Text
location
              case [Text]
packagename of
                [Text
n] -> Either String String -> IO (Either String String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String String -> IO (Either String String))
-> Either String String -> IO (Either String String)
forall a b. (a -> b) -> a -> b
$ String -> Either String String
forall a b. b -> Either a b
Right (String -> Either String String) -> String -> Either String String
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Char
'0'..Char
'9']) (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
n
                [Text]
_   -> Either String String -> IO (Either String String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String String -> IO (Either String String))
-> Either String String -> IO (Either String String)
forall a b. (a -> b) -> a -> b
$ String -> Either String String
forall a b. a -> Either a b
Left String
"couldn't parse Location"
        else Either String String -> IO (Either String String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String String -> IO (Either String String))
-> Either String String -> IO (Either String String)
forall a b. (a -> b) -> a -> b
$ String -> Either String String
forall a b. a -> Either a b
Left (String -> Either String String) -> String -> Either String String
forall a b. (a -> b) -> a -> b
$ String
"HTTP status " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
status
    Left HttpException
err -> Either String String -> IO (Either String String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String String -> IO (Either String String))
-> Either String String -> IO (Either String String)
forall a b. (a -> b) -> a -> b
$ String -> Either String String
forall a b. a -> Either a b
Left (String -> Either String String) -> String -> Either String String
forall a b. (a -> b) -> a -> b
$ String
"other exception: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ HttpException -> String
forall a. Show a => a -> String
show HttpException
err

-- | Like the above, but get the version from the first number on the hledger.org Install page.
getLatestHledgerVersionFromHledgerOrg :: IO (Either String String)
getLatestHledgerVersionFromHledgerOrg :: IO (Either String String)
getLatestHledgerVersionFromHledgerOrg = do
  let url :: Url 'Https
url = Text -> Url 'Https
https Text
"hledger.org" Url 'Https -> Text -> Url 'Https
forall (scheme :: Scheme). Url scheme -> Text -> Url scheme
/: Text
"install.html"
  do
    Either HttpException BsResponse
result <- IO BsResponse -> IO (Either HttpException BsResponse)
forall e a. Exception e => IO a -> IO (Either e a)
try (IO BsResponse -> IO (Either HttpException BsResponse))
-> IO BsResponse -> IO (Either HttpException BsResponse)
forall a b. (a -> b) -> a -> b
$ HttpConfig -> Req BsResponse -> IO BsResponse
forall (m :: * -> *) a. MonadIO m => HttpConfig -> Req a -> m a
runReq HttpConfig
defaultHttpConfig (Req BsResponse -> IO BsResponse)
-> Req BsResponse -> IO BsResponse
forall a b. (a -> b) -> a -> b
$ GET
-> Url 'Https
-> NoReqBody
-> Proxy BsResponse
-> Option 'Https
-> Req BsResponse
forall (m :: * -> *) method body response (scheme :: Scheme).
(MonadHttp m, HttpMethod method, HttpBody body,
 HttpResponse response,
 HttpBodyAllowed (AllowsBody method) (ProvidesBody body)) =>
method
-> Url scheme
-> body
-> Proxy response
-> Option scheme
-> m response
req GET
GET Url 'Https
url NoReqBody
NoReqBody Proxy BsResponse
bsResponse (Int -> Option 'Https
forall (scheme :: Scheme). Int -> Option scheme
R.responseTimeout Int
httptimeout)
    case Either HttpException BsResponse
result of
      Left (HttpException
e :: R.HttpException) -> Either String String -> IO (Either String String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String String -> IO (Either String String))
-> Either String String -> IO (Either String String)
forall a b. (a -> b) -> a -> b
$ String -> Either String String
forall a b. a -> Either a b
Left (String -> Either String String) -> String -> Either String String
forall a b. (a -> b) -> a -> b
$ HttpException -> String
forall a. Show a => a -> String
show HttpException
e
      Right BsResponse
rsp -> case ByteString -> Either UnicodeException Text
T.decodeUtf8' (ByteString -> Either UnicodeException Text)
-> ByteString -> Either UnicodeException Text
forall a b. (a -> b) -> a -> b
$ BsResponse -> HttpResponseBody BsResponse
forall response.
HttpResponse response =>
response -> HttpResponseBody response
R.responseBody BsResponse
rsp of
        Left UnicodeException
e  -> Either String String -> IO (Either String String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String String -> IO (Either String String))
-> Either String String -> IO (Either String String)
forall a b. (a -> b) -> a -> b
$ String -> Either String String
forall a b. a -> Either a b
Left (String -> Either String String) -> String -> Either String String
forall a b. (a -> b) -> a -> b
$ UnicodeException -> String
forall a. Show a => a -> String
show UnicodeException
e
        Right Text
t -> Either String String -> IO (Either String String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String String -> IO (Either String String))
-> Either String String -> IO (Either String String)
forall a b. (a -> b) -> a -> b
$
          if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
version then String -> Either String String
forall a b. a -> Either a b
Left String
"couldn't parse version" else String -> Either String String
forall a b. b -> Either a b
Right String
version
          where
            -- keep synced
            versionline :: [String]
versionline = Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
take Int
1 ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Bool -> Bool
not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"current hledger release" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf`)) ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ String -> [String]
lines (String -> [String]) -> String -> [String]
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
t
            version :: String
version = (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (String
"0123456789."::[Char])) (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isDigit) (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String -> [String] -> String
forall a. a -> [a] -> a
headDef String
"" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [String]
versionline
  -- work around potential failure on mac (& possible security issue, reported upstream)
  IO (Either String String)
-> (IOError -> IO (Either String String))
-> IO (Either String String)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (\(IOError
_ :: IOError) -> Either String String -> IO (Either String String)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String String -> IO (Either String String))
-> Either String String -> IO (Either String String)
forall a b. (a -> b) -> a -> b
$ String -> Either String String
forall a b. a -> Either a b
Left String
"req failed (mac PATH issue ?)")

-- | Try to run the hledger in PATH with one or more sets of command line arguments.
-- Returns the output from the first set of arguments that runs successfully,
-- or the error output from the last set.
tryHledgerArgs :: [[String]] -> IO (Either String String)
tryHledgerArgs :: [[String]] -> IO (Either String String)
tryHledgerArgs [] = Either String String -> IO (Either String String)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String String -> IO (Either String String))
-> Either String String -> IO (Either String String)
forall a b. (a -> b) -> a -> b
$ String -> Either String String
forall a b. a -> Either a b
Left String
"tryHledgerArgs: no arguments provided"
tryHledgerArgs ([String]
args:[[String]]
rest) = do
  Either String String
eresult <- [String] -> IO (Either String String)
runHledger [String]
args
  case Either String String
eresult of
    Right String
out -> Either String String -> IO (Either String String)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String String -> IO (Either String String))
-> Either String String -> IO (Either String String)
forall a b. (a -> b) -> a -> b
$ String -> Either String String
forall a b. b -> Either a b
Right String
out
    Left String
err -> if [[String]] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[String]]
rest then Either String String -> IO (Either String String)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String String -> IO (Either String String))
-> Either String String -> IO (Either String String)
forall a b. (a -> b) -> a -> b
$ String -> Either String String
forall a b. a -> Either a b
Left String
err else [[String]] -> IO (Either String String)
tryHledgerArgs [[String]]
rest

-- | Run the hledger in PATH with the given command line arguments,
-- returning the output on success or the error output on failure.
runHledger :: [String] -> IO (Either String String)
runHledger :: [String] -> IO (Either String String)
runHledger [String]
args = do
  (ExitCode
exit, String
out, String
err) <- String -> [String] -> String -> IO (ExitCode, String, String)
readProcessWithExitCode String
"hledger" [String]
args String
""
  Either String String -> IO (Either String String)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either String String -> IO (Either String String))
-> Either String String -> IO (Either String String)
forall a b. (a -> b) -> a -> b
$ case ExitCode
exit of
    ExitCode
ExitSuccess -> String -> Either String String
forall a b. b -> Either a b
Right String
out
    ExitFailure Int
_ -> String -> Either String String
forall a b. a -> Either a b
Left String
err