{-# LANGUAGE ViewPatterns #-}

{- HLINT ignore "Redundant lambda" -}

-- | Provides utilities.
module Shrun.Utils
  ( -- * Text Utils
    breakStripPoint,
    truncateIfNeeded,
    stripControlAll,
    stripControlSmart,
    escapeDoubleQuotes,

    -- * MonadTime Utils
    diffTime,
    timeSpecToRelTime,

    -- * Terminal input
    hWithHidden,
    withHiddenInput,
    hHide,
    drainStdin,

    -- * Text parsing
    inverseMap,
    inverseMapFail,
    inversePretty,
    inversePrettyFail,

    -- * Misc Utils
    atomicReadWrite,
    fmtUnrecognizedError,
    mkMetaStr,
    parseByteText,
    readIncCounter,
    surroundJust,
    whileM_,
    whenLeft,
    untilJust,
    (∸),
    readStripUnderscores,
    indexPos,
  )
where

import Data.Bytes (Conversion (convert_), SomeSize, parse)
import Data.Char (isControl, isLetter)
import Data.Either (either)
import Data.List qualified as L
import Data.Map qualified as Map
import Data.Sequence qualified as Seq
import Data.Text qualified as T
import Data.Text.Lazy qualified as TL
import Data.Text.Lazy.Builder (Builder)
import Data.Text.Lazy.Builder qualified as TLB
import Data.Time.Relative (RelativeTime, fromSeconds)
import Effects.FileSystem.Handle qualified as H
import Effects.FileSystem.HandleReader qualified as HR
import Effects.FileSystem.HandleWriter qualified as HW
import Effects.Time (TimeSpec, diffTimeSpec)
import Optics.Core qualified as O
import Shrun.Prelude
import Text.Read (Read)
import Text.Read qualified as TR

-- $setup
-- >>> :set -XOverloadedLists
-- >>> import Data.List.NonEmpty (NonEmpty (..))
-- >>> import Data.Semigroup (Sum (..))
-- >>> import Data.Text qualified as T
-- >>> import Effects.Time (TimeSpec (..))
-- >>> import Shrun.Prelude

-- | For given \(x, y\), returns the absolute difference \(|x - y|\)
-- in seconds.
--
-- ==== __Examples__
-- >>> :{
--   let t1 = MkTimeSpec 5 0
--       -- 20 s + 1 billion ns = 21 s
--       t2 = MkTimeSpec 20 1_000_000_000
--   in diffTime t1 t2
-- :}
-- 16
diffTime :: TimeSpec -> TimeSpec -> Natural
diffTime :: TimeSpec -> TimeSpec -> Natural
diffTime TimeSpec
t1 TimeSpec
t2 = Optic' A_Lens NoIx TimeSpec Natural -> TimeSpec -> Natural
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens NoIx TimeSpec Natural
#sec (TimeSpec -> Natural) -> TimeSpec -> Natural
forall a b. (a -> b) -> a -> b
$ TimeSpec -> TimeSpec -> TimeSpec
diffTimeSpec TimeSpec
t1 TimeSpec
t2

-- | Transforms a 'TimeSpec' into a 'RelativeTime'.
timeSpecToRelTime :: TimeSpec -> RelativeTime
timeSpecToRelTime :: TimeSpec -> RelativeTime
timeSpecToRelTime = Natural -> RelativeTime
fromSeconds (Natural -> RelativeTime)
-> (TimeSpec -> Natural) -> TimeSpec -> RelativeTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Optic' A_Lens NoIx TimeSpec Natural -> TimeSpec -> Natural
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens NoIx TimeSpec Natural
#sec

-- | Wrapper for 'Text'\'s 'T.breakOn' that differs in that:
--
-- 1. If the @needle@ is found within the @haystack@, we do not include it
-- in the second part of the pair.
--
-- ==== __Examples__
-- >>> -- Data.Text
-- >>> T.breakOn "=" "HEY=LISTEN"
-- ("HEY","=LISTEN")
--
-- >>> -- Shrun.Utils.Text
-- >>> breakStripPoint "=" "HEY=LISTEN"
-- ("HEY","LISTEN")
--
-- Other examples:
--
-- >>> breakStripPoint "=" "HEYLISTEN"
-- ("HEYLISTEN","")
--
-- >>> breakStripPoint "=" "=HEYLISTEN"
-- ("","HEYLISTEN")
--
-- >>> breakStripPoint "=" "HEYLISTEN="
-- ("HEYLISTEN","")
--
-- >>> breakStripPoint "=" "HEY==LISTEN"
-- ("HEY","=LISTEN")
breakStripPoint :: Text -> Text -> Tuple2 Text Text
breakStripPoint :: Text -> Text -> (Text, Text)
breakStripPoint Text
point Text
txt = case HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
T.breakOn Text
point Text
txt of
  (Text
x, Text -> Text -> Maybe Text
T.stripPrefix Text
point -> Just Text
y) -> (Text
x, Text
y)
  (Text, Text)
pair -> (Text, Text)
pair

-- | For 'Natural' \(n\) and 'Text' \(t = t_0 t_1 \ldots t_m\), truncates
-- \(t\) if \(m > n\). In this case, \(t\) is truncated to \(n - 3\), and an
-- ellipsis ( \(\ldots\) ) is appended. We are left with a string with
-- length exactly \(n\):
--
-- \[
-- t_0 t_1 \ldots t_{n-3} \text{...} \quad \text{-- 3 literal } `\text{.' chars appended}
-- \]
--
-- ==== __Examples__
-- >>> truncateIfNeeded 7 "hi"
-- "hi"
--
-- >>> truncateIfNeeded 10 "This is 21 chars long"
-- "This is..."
truncateIfNeeded :: Int -> Text -> Text
truncateIfNeeded :: Int -> Text -> Text
truncateIfNeeded Int
n Text
txt
  | Text -> Int
T.length Text
txt Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
n = Text
txt
  | Bool
otherwise = Text
txt'
  where
    txt' :: Text
txt' = Int -> Text -> Text
T.take (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
3) Text
txt Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"..."

-- NOTE: [StripControl Newlines]
--
-- Applying stripControl to text that has newlines in it can produce poorly
-- formatted text. This is due to newlines being stripped, so e.g. t1\nt2
-- becomes t1t2. Hence we require 'UnlinedText'.

-- | Strips all control chars, including ansi escape sequences.
--
-- ==== __Examples__
--
-- >>> stripControlAll "foo\ESC[0;3Abar \n baz"
-- "foobar  baz"
stripControlAll :: Text -> Text
stripControlAll :: Text -> Text
stripControlAll =
  -- The ansi stripping must come first. For example, if we strip control
  -- chars from "\ESC[0;3mfoo" we get "0;3mfoo", and then stripAnsiAll will
  -- no longer recognize this as an ansi sequences - i.e. this will leave
  -- remnants from the ansi sequences.
  --
  -- By performing stripAnsiAll first, we remove entire ansi sequences,
  -- then remove other control chars (e.g. newlines, tabs).
  (Char -> Bool) -> Text -> Text
T.filter (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Char -> Bool
isControl) (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> Text
stripAnsiAll

-- | Strips control chars, including most ansi escape sequences. We leave
-- behind SGR ansi escape sequences e.g. text coloring. See
-- https://en.wikipedia.org/wiki/ANSI_escape_code#SGR_(Select_Graphic_Rendition)_parameters.
--
-- ==== __Examples__
--
-- >>> stripControlSmart "foo\ESC[0;3Abar \n baz"
-- "foobar  baz"
--
-- >>> stripControlSmart "foo\ESC[0;3mbar \n baz"
-- "foo\ESC[0;3mbar  baz"
stripControlSmart :: Text -> Text
stripControlSmart :: Text -> Text
stripControlSmart =
  -- Like 'stripControlAll', we need to handle the ansi sequences first.
  -- Because we actually leave some sequences behind, we need to be more
  -- surgical removing the rest of the control chars (e.g. newline, tabs).
  (Char -> Bool) -> Text -> Text
T.filter Char -> Bool
ctrlToFilter (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> Text
stripAnsiControl
  where
    -- stripAnsiControl should be handling all \ESC sequences, so we should
    -- be safe to ignore these, accomplishing our goal of preserving the SGR
    -- sequences. If this is too aggressive, we can instead attempt to strip
    -- out the known 'bad' control chars e.g.
    --
    --   ctrlToFilter = not . (`elem` ['\n', '\t', '\v'])
    --
    ctrlToFilter :: Char -> Bool
ctrlToFilter Char
c
      | Char -> Bool
isControl Char
c = Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\ESC'
      | Bool
otherwise = Bool
True

-- | Strips all ansi sequences from the given text.
--
-- ==== __Examples__
--
-- @
-- stripAnsiAll "foo\ESC[0;3Abar"
-- @
stripAnsiAll :: Text -> Text
stripAnsiAll :: Text -> Text
stripAnsiAll = [Text] -> Text
T.concat ([Text] -> Text) -> (Text -> [Text]) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. ((Text, Text, Text) -> Text) -> [(Text, Text, Text)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (Optic' A_Lens NoIx (Text, Text, Text) Text
-> (Text, Text, Text) -> Text
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens NoIx (Text, Text, Text) Text
forall s t a b. Field1 s t a b => Lens s t a b
_1) ([(Text, Text, Text)] -> [Text])
-> (Text -> [(Text, Text, Text)]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> [(Text, Text, Text)]
splitAnsi

-- | Strips ansi control sequences only.
--
-- ==== __Examples__
--
-- @
-- stripAnsiControl "foo\ESC[0;3Abar"
-- "foobar"
--
-- stripAnsiControl "foo\ESC[0;3mbar"
-- "foo\ESC[0;3mbar"
-- @
stripAnsiControl :: Text -> Text
stripAnsiControl :: Text -> Text
stripAnsiControl Text
txt =
  (Text -> (Text, Text, Text) -> Text)
-> Text -> [(Text, Text, Text)] -> Text
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Text -> (Text, Text, Text) -> Text
forall {a}. Semigroup a => a -> (a, Text, a) -> a
f Text
"" [(Text, Text, Text)]
splitTxt
  where
    splitTxt :: [(Text, Text, Text)]
splitTxt = Text -> [(Text, Text, Text)]
splitAnsi Text
txt
    f :: a -> (a, Text, a) -> a
f a
acc (a
preAnsi, Text
code, a
withAnsi)
      | Text -> Bool
nonControlAnsi Text
code = a
acc a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
withAnsi
      | Bool
otherwise = a
acc a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
preAnsi

nonControlAnsi :: Text -> Bool
nonControlAnsi :: Text -> Bool
nonControlAnsi Text
ansi = case Text -> Maybe (Text, Char)
T.unsnoc Text
ansi of
  -- 'm' equals color: only code we consider 'good' for now
  Just (Text
_, Char
'm') -> Bool
True
  Maybe (Text, Char)
_ -> Bool
False

-- tuple is: (text, ansi_code, ansi_code <> text)
-- example: splitAnsi "foo\ESC[0;3mbar"
splitAnsi :: Text -> [(Text, Text, Text)]
splitAnsi :: Text -> [(Text, Text, Text)]
splitAnsi Text
"" = []
splitAnsi Text
t =
  -- (foo, \ESC[0;3m, bar) : ...
  (Text
preAnsi, Text
ansiCode, Text
preAnsi Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ansiCode) (Text, Text, Text) -> [(Text, Text, Text)] -> [(Text, Text, Text)]
forall a. a -> [a] -> [a]
: [(Text, Text, Text)]
rest
  where
    -- (foo, \ESC[0;3mbar)
    (!Text
preAnsi, !Text
withAnsiFull) = HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
T.breakOn Text
"\ESC[" Text
t
    -- (\ESC[0;3, mbar)
    (!Text
ansiCodeNoChar, !Text
withAnsiChar) = (Char -> Bool) -> Text -> (Text, Text)
T.break Char -> Bool
isLetter Text
withAnsiFull
    -- (\ESC[0;3m, bar)
    (!Text
ansiCode, ![(Text, Text, Text)]
rest) = case Text -> Maybe (Char, Text)
T.uncons Text
withAnsiChar of
      -- (m, bar)
      Just (!Char
ansiChar, !Text
rest') -> (Text -> Char -> Text
T.snoc Text
ansiCodeNoChar Char
ansiChar, Text -> [(Text, Text, Text)]
splitAnsi Text
rest')
      Maybe (Char, Text)
Nothing -> (Text
ansiCodeNoChar, [])

-- | Parses bytes with arbitrary units and converts to bytes. First attempts
-- to parse as a 'Natural' so we do not lose precision. If that fails, falls
-- back to 'Double'.
--
-- ==== __Examples__
--
-- >>> parseByteText "120 mb"
-- Right (MkBytes 120000000)
--
-- >>> parseByteText "4.5 terabytes"
-- Right (MkBytes 4500000000000)
parseByteText :: Text -> Either Text (Bytes B Natural)
parseByteText :: Text -> Either Text (Bytes 'B Natural)
parseByteText Text
txt =
  case forall a. Parser a => Text -> Either Text a
parse @(SomeSize Natural) Text
txt of
    Right SomeSize Natural
b -> Bytes 'B Natural -> Either Text (Bytes 'B Natural)
forall a b. b -> Either a b
Right (Bytes 'B Natural -> Either Text (Bytes 'B Natural))
-> Bytes 'B Natural -> Either Text (Bytes 'B Natural)
forall a b. (a -> b) -> a -> b
$ forall a (t :: Size). (Conversion a, SingI t) => a -> Converted t a
convert_ @_ @B SomeSize Natural
b
    Left Text
_ -> case forall a. Parser a => Text -> Either Text a
parse @(SomeSize Double) Text
txt of
      Right SomeSize Double
b -> Bytes 'B Natural -> Either Text (Bytes 'B Natural)
forall a b. b -> Either a b
Right (Double -> Natural
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
truncate (Double -> Natural) -> Bytes 'B Double -> Bytes 'B Natural
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (t :: Size). (Conversion a, SingI t) => a -> Converted t a
convert_ @_ @B SomeSize Double
b)
      Left Text
err -> Text -> Either Text (Bytes 'B Natural)
forall a b. a -> Either a b
Left Text
err

-- | Runs the action when it is 'Left'.
whenLeft :: (Applicative f) => Either a b -> (a -> f ()) -> f ()
whenLeft :: forall (f :: Type -> Type) a b.
Applicative f =>
Either a b -> (a -> f ()) -> f ()
whenLeft Either a b
e a -> f ()
action = (a -> f ()) -> (b -> f ()) -> Either a b -> f ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either a -> f ()
action (f () -> b -> f ()
forall a b. a -> b -> a
const (() -> f ()
forall a. a -> f a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ())) Either a b
e
{-# INLINEABLE whenLeft #-}

-- | @whileM_ mb ma@ executes @ma@ as long as @mb@ returns 'True'.
whileM_ :: (Monad m) => m Bool -> m a -> m ()
whileM_ :: forall (m :: Type -> Type) a. Monad m => m Bool -> m a -> m ()
whileM_ m Bool
mb m a
ma = m ()
go
  where
    go :: m ()
go =
      m Bool
mb m Bool -> (Bool -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Bool
True -> m a
ma m a -> m () -> m ()
forall a b. m a -> m b -> m b
forall (f :: Type -> Type) a b. Applicative f => f a -> f b -> f b
*> m ()
go
        Bool
False -> () -> m ()
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ()
{-# INLINEABLE whileM_ #-}

-- | Executes the monadic action until we receive a 'Just', returning the
-- value.
untilJust :: (Monad m) => m (Maybe b) -> m b
untilJust :: forall (m :: Type -> Type) b. Monad m => m (Maybe b) -> m b
untilJust m (Maybe b)
m = m b
go
  where
    go :: m b
go =
      m (Maybe b)
m m (Maybe b) -> (Maybe b -> m b) -> m b
forall a b. m a -> (a -> m b) -> m b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe b
Nothing -> m b
go
        Just b
x -> b -> m b
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure b
x
{-# INLINEABLE untilJust #-}

-- | Escape double quotes in strings.
escapeDoubleQuotes :: Text -> Text
escapeDoubleQuotes :: Text -> Text
escapeDoubleQuotes = LazyText -> Text
TL.toStrict (LazyText -> Text) -> (Text -> LazyText) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Builder -> LazyText
TLB.toLazyText (Builder -> LazyText) -> (Text -> Builder) -> Text -> LazyText
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (Builder -> Char -> Builder) -> Builder -> Text -> Builder
forall a. (a -> Char -> a) -> a -> Text -> a
T.foldl' Builder -> Char -> Builder
go Builder
""
  where
    go :: Builder -> Char -> Builder
    go :: Builder -> Char -> Builder
go Builder
acc Char
'"' = Builder
acc Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
"\\\""
    go Builder
acc Char
c = Builder
acc Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
TLB.singleton Char
c

-- | "monus" i.e. subtraction clamped to zero
(∸) :: (Ord a, Num a) => a -> a -> a
a
x ∸ :: forall a. (Ord a, Num a) => a -> a -> a
∸ a
y =
  if a
y a -> a -> Bool
forall a. Ord a => a -> a -> Bool
> a
x
    then a
0
    else a
x a -> a -> a
forall a. Num a => a -> a -> a
- a
y

infixl 6 ∸

readStripUnderscores :: (MonadFail m, Read a) => Text -> m a
readStripUnderscores :: forall (m :: Type -> Type) a. (MonadFail m, Read a) => Text -> m a
readStripUnderscores Text
t = case String -> Either String a
forall a. Read a => String -> Either String a
TR.readEither String
s of
  Left String
err -> String -> m a
forall a. String -> m a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail (String -> m a) -> String -> m a
forall a b. (a -> b) -> a -> b
$ String
"Could not read '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"': " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
err
  Right a
x -> a -> m a
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure a
x
  where
    noUnderscores :: Text
noUnderscores = HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace Text
"_" Text
"" Text
t
    s :: String
s = Text -> String
T.unpack Text
noUnderscores
{-# INLINEABLE readStripUnderscores #-}

-- | Provides a standard format for "unrecognized param" failures.
fmtUnrecognizedError ::
  ( IsString a,
    Monoid a
  ) =>
  -- | Field name.
  a ->
  -- | (Include off?, Valid values).
  (Bool, List a) ->
  -- | Bad unrecognized value or error message.
  a ->
  -- | Error message.
  a
fmtUnrecognizedError :: forall a. (IsString a, Monoid a) => a -> (Bool, [a]) -> a -> a
fmtUnrecognizedError a
fieldName (Bool, [a])
meta a
badValue =
  [a] -> a
forall a. Monoid a => [a] -> a
mconcat
    [ a
"Error parsing ",
      a
fieldName,
      a
": '",
      a
badValue,
      a
"'. Expected one of ",
      (Bool, [a]) -> a
forall a. (IsString a, Monoid a) => (Bool, [a]) -> a
mkMetaStr (Bool, [a])
meta,
      a
"."
    ]

mkMetaStr :: (IsString a, Monoid a) => Tuple2 Bool (List a) -> a
mkMetaStr :: forall a. (IsString a, Monoid a) => (Bool, [a]) -> a
mkMetaStr (Bool
includeOff, [a]
xs) =
  (\a
s -> a
"(" a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
s a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
")")
    (a -> a) -> ([a] -> a) -> [a] -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. [a] -> a
forall a. Monoid a => [a] -> a
mconcat
    ([a] -> a) -> ([a] -> [a]) -> [a] -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. a -> [a] -> [a]
forall a. a -> [a] -> [a]
L.intersperse a
" | "
    ([a] -> [a]) -> ([a] -> [a]) -> [a] -> [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. [a] -> [a]
appendOff
    ([a] -> a) -> [a] -> a
forall a b. (a -> b) -> a -> b
$ [a]
xs
  where
    appendOff :: [a] -> [a]
appendOff =
      if Bool
includeOff
        then ([a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a
"off"])
        else [a] -> [a]
forall a. a -> a
id

-- | Reads from a queue and applies the function, if we receive a value.
-- Atomic in the sense that if a read is successful, then we will apply the
-- given function, even if an async exception is raised.
atomicReadWrite ::
  ( HasCallStack,
    MonadAtomic m,
    MonadMask m
  ) =>
  -- | Queue from which to read.
  TBQueue a ->
  -- | Function to apply.
  (a -> m b) ->
  m ()
atomicReadWrite :: forall (m :: Type -> Type) a b.
(HasCallStack, MonadAtomic m, MonadMask m) =>
TBQueue a -> (a -> m b) -> m ()
atomicReadWrite TBQueue a
queue a -> m b
logAction =
  ((forall a. m a -> m a) -> m ()) -> m ()
forall b. HasCallStack => ((forall a. m a -> m a) -> m b) -> m b
forall (m :: Type -> Type) b.
(MonadMask m, HasCallStack) =>
((forall a. m a -> m a) -> m b) -> m b
mask (((forall a. m a -> m a) -> m ()) -> m ())
-> ((forall a. m a -> m a) -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> m a
restore -> m a -> m a
forall a. m a -> m a
restore (TBQueue a -> m a
forall (m :: Type -> Type) a.
(HasCallStack, MonadAtomic m) =>
TBQueue a -> m a
readTBQueueA' TBQueue a
queue) m a -> (a -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= m b -> m ()
forall (f :: Type -> Type) a. Functor f => f a -> f ()
void (m b -> m ()) -> (a -> m b) -> a -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. a -> m b
logAction
{-# INLINEABLE atomicReadWrite #-}

indexPos :: NESeq a -> NESeq (Positive Int, a)
indexPos :: forall a. NESeq a -> NESeq (Positive Int, a)
indexPos (a
x :<|| Seq a
xs) = (Positive Int
forall m. MMonoid m => m
one, a
x) (Positive Int, a)
-> Seq (Positive Int, a) -> NESeq (Positive Int, a)
forall a. a -> Seq a -> NESeq a
:<|| Seq (Positive Int, a)
ys
  where
    ys :: Seq (Positive Int, a)
ys = Seq (Positive Int) -> Seq a -> Seq (Positive Int, a)
forall a b. Seq a -> Seq b -> Seq (a, b)
Seq.zip (Int -> Positive Int
forall a.
(AMonoid a, HasCallStack, Ord a, Show a) =>
a -> Positive a
unsafePositive (Int -> Positive Int) -> Seq Int -> Seq (Positive Int)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int] -> Seq Int
forall a. [a] -> Seq a
Seq.fromList [Int
2 .. Int
len]) Seq a
xs

    len :: Int
len = Seq a -> Int
forall a. Seq a -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length Seq a
xs Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1

surroundJust ::
  ( O.JoinKinds k A_Prism m,
    O.JoinKinds A_Prism l k
  ) =>
  Optic l ks u v (Maybe a) (Maybe b) ->
  Optic m ks (Maybe u) (Maybe v) a b
surroundJust :: forall k m l (ks :: IxList) u v a b.
(JoinKinds k A_Prism m, JoinKinds A_Prism l k) =>
Optic l ks u v (Maybe a) (Maybe b)
-> Optic m ks (Maybe u) (Maybe v) a b
surroundJust Optic l ks u v (Maybe a) (Maybe b)
l = Prism (Maybe u) (Maybe v) u v
forall a b. Prism (Maybe a) (Maybe b) a b
_Just Prism (Maybe u) (Maybe v) u v
-> Optic l ks u v (Maybe a) (Maybe b)
-> Optic k ks (Maybe u) (Maybe v) (Maybe a) (Maybe b)
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic l ks u v (Maybe a) (Maybe b)
l Optic k ks (Maybe u) (Maybe v) (Maybe a) (Maybe b)
-> Optic A_Prism NoIx (Maybe a) (Maybe b) a b
-> Optic m ks (Maybe u) (Maybe v) a b
forall k l m (is :: IxList) (js :: IxList) (ks :: IxList) s t u v a
       b.
(JoinKinds k l m, AppendIndices is js ks) =>
Optic k is s t u v -> Optic l js u v a b -> Optic m ks s t a b
% Optic A_Prism NoIx (Maybe a) (Maybe b) a b
forall a b. Prism (Maybe a) (Maybe b) a b
_Just

-- | Hides stdin input. Some caveats:
--
-- - Tragically, this does not prevent sudo from hijacking stdin e.g.
--
--     shrun "sudo ls && sleep 10"
--
--   will launch the prompt which will overwrite the terminal. Oh well.
--
-- - It does not /swallow/ stdin e.g. read stdin and throw it away. For
--   example, if the user types in a bunch of stuff, it will be buffered
--   in memory then printed / executed (e.g. enter key) after shrun finishes.
--
--   For the main console, this is handled by 'drainStdin'.
withHiddenInput ::
  ( MonadMask m,
    MonadHandleReader m,
    MonadHandleWriter m
  ) =>
  m a ->
  m a
withHiddenInput :: forall (m :: Type -> Type) a.
(MonadMask m, MonadHandleReader m, MonadHandleWriter m) =>
m a -> m a
withHiddenInput = Handle 'HandleModeReadWrite -> m a -> m a
forall (p :: HandleMode) (m :: Type -> Type) a.
(CanRead p, CanWrite p, MonadMask m, MonadHandleReader m,
 MonadHandleWriter m) =>
Handle p -> m a -> m a
hWithHidden Handle 'HandleModeReadWrite
H.stdin
{-# INLINEABLE withHiddenInput #-}

hWithHidden ::
  ( CanRead p,
    CanWrite p,
    MonadMask m,
    MonadHandleReader m,
    MonadHandleWriter m
  ) =>
  Handle p ->
  m a ->
  m a
hWithHidden :: forall (p :: HandleMode) (m :: Type -> Type) a.
(CanRead p, CanWrite p, MonadMask m, MonadHandleReader m,
 MonadHandleWriter m) =>
Handle p -> m a -> m a
hWithHidden Handle p
h m a
m = m (BufferMode, Bool)
-> ((BufferMode, Bool) -> m ())
-> ((BufferMode, Bool) -> m a)
-> m a
forall (m :: Type -> Type) a c b.
(HasCallStack, MonadMask m) =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracket m (BufferMode, Bool)
hideInput (BufferMode, Bool) -> m ()
unhideInput (m a -> (BufferMode, Bool) -> m a
forall a b. a -> b -> a
const m a
m)
  where
    -- Note that this may not work on windows, if we ever want that.
    --
    -- - https://stackoverflow.com/questions/15848975/preventing-input-characters-appearing-in-terminal
    -- - https://hackage.haskell.org/package/echo
    hideInput :: m (BufferMode, Bool)
hideInput = do
      BufferMode
buffMode <- Handle p -> m BufferMode
forall (p :: HandleMode).
(CanRead p, HasCallStack) =>
Handle p -> m BufferMode
forall (m :: Type -> Type) (p :: HandleMode).
(MonadHandleReader m, CanRead p, HasCallStack) =>
Handle p -> m BufferMode
HR.hGetBuffering Handle p
h
      Bool
echoMode <- Handle p -> m Bool
forall (p :: HandleMode).
(CanRead p, HasCallStack) =>
Handle p -> m Bool
forall (m :: Type -> Type) (p :: HandleMode).
(MonadHandleReader m, CanRead p, HasCallStack) =>
Handle p -> m Bool
HR.hGetEcho Handle p
h
      Handle p -> m ()
forall (p :: HandleMode) (m :: Type -> Type).
(CanWrite p, MonadHandleWriter m) =>
Handle p -> m ()
hHide Handle p
h
      pure (BufferMode
buffMode, Bool
echoMode)

    unhideInput :: (BufferMode, Bool) -> m ()
unhideInput (BufferMode
buffMode, Bool
echoMode) = do
      Handle p -> BufferMode -> m ()
forall (p :: HandleMode).
(CanWrite p, HasCallStack) =>
Handle p -> BufferMode -> m ()
forall (m :: Type -> Type) (p :: HandleMode).
(MonadHandleWriter m, CanWrite p, HasCallStack) =>
Handle p -> BufferMode -> m ()
HW.hSetBuffering Handle p
h BufferMode
buffMode
      Handle p -> Bool -> m ()
forall (p :: HandleMode).
(CanWrite p, HasCallStack) =>
Handle p -> Bool -> m ()
forall (m :: Type -> Type) (p :: HandleMode).
(MonadHandleWriter m, CanWrite p, HasCallStack) =>
Handle p -> Bool -> m ()
HW.hSetEcho Handle p
h Bool
echoMode
{-# INLINEABLE hWithHidden #-}

hHide ::
  (CanWrite p, MonadHandleWriter m) =>
  Handle p ->
  m ()
hHide :: forall (p :: HandleMode) (m :: Type -> Type).
(CanWrite p, MonadHandleWriter m) =>
Handle p -> m ()
hHide Handle p
h = do
  Handle p -> BufferMode -> m ()
forall (p :: HandleMode).
(CanWrite p, HasCallStack) =>
Handle p -> BufferMode -> m ()
forall (m :: Type -> Type) (p :: HandleMode).
(MonadHandleWriter m, CanWrite p, HasCallStack) =>
Handle p -> BufferMode -> m ()
HW.hSetBuffering Handle p
h BufferMode
HW.NoBuffering
  Handle p -> Bool -> m ()
forall (p :: HandleMode).
(CanWrite p, HasCallStack) =>
Handle p -> Bool -> m ()
forall (m :: Type -> Type) (p :: HandleMode).
(MonadHandleWriter m, CanWrite p, HasCallStack) =>
Handle p -> Bool -> m ()
HW.hSetEcho Handle p
h Bool
False
{-# INLINEABLE hHide #-}

-- | Drains stdin.
drainStdin ::
  ( MonadCatch m,
    MonadHandleReader m
  ) =>
  m ()
drainStdin :: forall (m :: Type -> Type).
(MonadCatch m, MonadHandleReader m) =>
m ()
drainStdin =
  m () -> m ()
forall (m :: Type -> Type) a.
(HasCallStack, MonadCatch m) =>
m a -> m ()
tryMySync_
    (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ Handle 'HandleModeReadWrite -> m Bool
forall (p :: HandleMode).
(CanRead p, HasCallStack) =>
Handle p -> m Bool
forall (m :: Type -> Type) (p :: HandleMode).
(MonadHandleReader m, CanRead p, HasCallStack) =>
Handle p -> m Bool
HR.hIsClosed Handle 'HandleModeReadWrite
H.stdin
    m Bool -> (Bool -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Bool
True -> () -> m ()
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ()
      Bool
False ->
        Handle 'HandleModeReadWrite -> m Bool
forall (p :: HandleMode).
(CanRead p, HasCallStack) =>
Handle p -> m Bool
forall (m :: Type -> Type) (p :: HandleMode).
(MonadHandleReader m, CanRead p, HasCallStack) =>
Handle p -> m Bool
HR.hIsReadable Handle 'HandleModeReadWrite
H.stdin m Bool -> (Bool -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Bool
False -> () -> m ()
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ()
          Bool
True -> m ByteString -> m ()
forall (f :: Type -> Type) a. Functor f => f a -> f ()
void (m ByteString -> m ()) -> m ByteString -> m ()
forall a b. (a -> b) -> a -> b
$ Handle 'HandleModeReadWrite -> Int -> m ByteString
forall (p :: HandleMode).
(CanRead p, HasCallStack) =>
Handle p -> Int -> m ByteString
forall (m :: Type -> Type) (p :: HandleMode).
(MonadHandleReader m, CanRead p, HasCallStack) =>
Handle p -> Int -> m ByteString
HR.hGetNonBlocking Handle 'HandleModeReadWrite
H.stdin Int
1_000
{-# INLINEABLE drainStdin #-}

readIncCounter :: TVar Word16 -> STM Word16
readIncCounter :: TVar Word16 -> STM Word16
readIncCounter TVar Word16
counter = do
  Word16
c <- TVar Word16 -> STM Word16
forall a. TVar a -> STM a
readTVar' TVar Word16
counter
  TVar Word16 -> Word16 -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar' TVar Word16
counter (Word16
c Word16 -> Word16 -> Word16
forall a. Num a => a -> a -> a
+ Word16
1)
  pure Word16
c

-- | Parses a finite type from an injective function.
inverseMap ::
  forall a k.
  (Bounded a, Enum a, Ord k) =>
  -- | Injection.
  (a -> k) ->
  -- | Key.
  k ->
  Maybe a
inverseMap :: forall a k. (Bounded a, Enum a, Ord k) => (a -> k) -> k -> Maybe a
inverseMap a -> k
inj = \k
k -> k -> Map k a -> Maybe a
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup k
k Map k a
m
  where
    m :: Map k a
m = [(k, a)] -> Map k a
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(k, a)] -> Map k a) -> [(k, a)] -> Map k a
forall a b. (a -> b) -> a -> b
$ (\a
x -> (a -> k
inj a
x, a
x)) (a -> (k, a)) -> [a] -> [(k, a)]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [a
forall a. Bounded a => a
minBound .. a
forall a. Bounded a => a
maxBound]

-- | 'inverseMap' with text keys given by a Pretty instance.
inversePretty ::
  forall a.
  (Bounded a, Enum a, Pretty a) =>
  -- | Key.
  Text ->
  Maybe a
inversePretty :: forall a. (Bounded a, Enum a, Pretty a) => Text -> Maybe a
inversePretty = (a -> Text) -> Text -> Maybe a
forall a k. (Bounded a, Enum a, Ord k) => (a -> k) -> k -> Maybe a
inverseMap a -> Text
forall a. Pretty a => a -> Text
prettyToText

-- | 'inverseMap' with a Text injection that fails via MonadFail and
-- 'fmtUnrecognizedError'. Intended for parsing config values.
inverseMapFail ::
  forall a m.
  (Bounded a, Enum a, MonadFail m) =>
  -- | Text injection.
  (a -> Text) ->
  -- | Field name.
  Text ->
  -- | Field metavar.
  Tuple2 Bool (List Text) ->
  -- | Key.
  Text ->
  m a
inverseMapFail :: forall a (m :: Type -> Type).
(Bounded a, Enum a, MonadFail m) =>
(a -> Text) -> Text -> (Bool, [Text]) -> Text -> m a
inverseMapFail a -> Text
inj Text
name (Bool, [Text])
meta = \Text
t -> case (a -> Text) -> Text -> Maybe a
forall a k. (Bounded a, Enum a, Ord k) => (a -> k) -> k -> Maybe a
inverseMap a -> Text
inj Text
t of
  Just a
v -> a -> m a
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure a
v
  Maybe a
Nothing ->
    String -> m a
forall a. String -> m a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail
      (String -> m a) -> (Text -> String) -> Text -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
forall {k} (cat :: k -> k -> Type) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Text -> String
unpack
      (Text -> m a) -> Text -> m a
forall a b. (a -> b) -> a -> b
$ Text -> (Bool, [Text]) -> Text -> Text
forall a. (IsString a, Monoid a) => a -> (Bool, [a]) -> a -> a
fmtUnrecognizedError
        Text
name
        (Bool, [Text])
meta
        Text
t

-- | inverseMapFail with 'Pretty' instance.
inversePrettyFail ::
  forall a m.
  (Bounded a, Enum a, MonadFail m, Pretty a) =>
  -- | Field name.
  Text ->
  -- | Field metavar.
  Tuple2 Bool (List Text) ->
  -- | Key.
  Text ->
  m a
inversePrettyFail :: forall a (m :: Type -> Type).
(Bounded a, Enum a, MonadFail m, Pretty a) =>
Text -> (Bool, [Text]) -> Text -> m a
inversePrettyFail = (a -> Text) -> Text -> (Bool, [Text]) -> Text -> m a
forall a (m :: Type -> Type).
(Bounded a, Enum a, MonadFail m) =>
(a -> Text) -> Text -> (Bool, [Text]) -> Text -> m a
inverseMapFail a -> Text
forall a. Pretty a => a -> Text
prettyToText