{-# LANGUAGE UndecidableInstances #-}

-- | Provides the 'Command' wrapper for commands.
module Shrun.Command.Types
  ( -- * Command
    CommandP (..),
    CommandP1,
    CommandP2,
    commandToProcess,

    -- ** Index
    CommandIndex,
    Internal.fromPositive,
    Internal.unsafeFromInt,
    Internal.toVertex,
    Internal.fromVertex,
    Internal.succ,
    Internal.addNN,
    Internal.range,
    Internal.joinRange,

    -- * Order
    CommandOrd (..),

    -- * Status
    CommandStatus (..),

    -- ** Map
    CommandStatusMapP (..),
    TCommandStatusMap,
    CommandStatusMap,
    readCommandStatus,

    -- * Misc
    CommandPhase (..),
    Internal.Vertex,
    Internal.LVertex,
  )
where

import Data.Text qualified as T
import Effects.System.Process (Pid)
import Effects.System.Process qualified as P
import Shrun.Command.Types.Internal (CommandIndex)
import Shrun.Command.Types.Internal qualified as Internal
import Shrun.Prelude

-- $setup
-- >>> :set -XOverloadedLists

data CommandPhase
  = CommandPhase1
  | CommandPhase2

-- | Wrapper for shell commands. Whenever the CommandIndex order is important,
-- see 'CommandOrd'.
type CommandP :: CommandPhase -> Type
data CommandP p = MkCommandP
  { -- | NonNegative index for the command.
    forall (p :: CommandPhase). CommandP p -> CommandIndex
index :: CommandIndex,
    -- | The key name for the command, for display purposes.
    forall (p :: CommandPhase). CommandP p -> Maybe Text
key :: Maybe Text,
    -- | The shell command to run.
    forall (p :: CommandPhase). CommandP p -> Text
command :: Text
  }
  deriving stock (CommandP p -> CommandP p -> Bool
(CommandP p -> CommandP p -> Bool)
-> (CommandP p -> CommandP p -> Bool) -> Eq (CommandP p)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (p :: CommandPhase). CommandP p -> CommandP p -> Bool
$c== :: forall (p :: CommandPhase). CommandP p -> CommandP p -> Bool
== :: CommandP p -> CommandP p -> Bool
$c/= :: forall (p :: CommandPhase). CommandP p -> CommandP p -> Bool
/= :: CommandP p -> CommandP p -> Bool
Eq, (forall x. CommandP p -> Rep (CommandP p) x)
-> (forall x. Rep (CommandP p) x -> CommandP p)
-> Generic (CommandP p)
forall x. Rep (CommandP p) x -> CommandP p
forall x. CommandP p -> Rep (CommandP p) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (p :: CommandPhase) x. Rep (CommandP p) x -> CommandP p
forall (p :: CommandPhase) x. CommandP p -> Rep (CommandP p) x
$cfrom :: forall (p :: CommandPhase) x. CommandP p -> Rep (CommandP p) x
from :: forall x. CommandP p -> Rep (CommandP p) x
$cto :: forall (p :: CommandPhase) x. Rep (CommandP p) x -> CommandP p
to :: forall x. Rep (CommandP p) x -> CommandP p
Generic, Int -> CommandP p -> ShowS
[CommandP p] -> ShowS
CommandP p -> String
(Int -> CommandP p -> ShowS)
-> (CommandP p -> String)
-> ([CommandP p] -> ShowS)
-> Show (CommandP p)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (p :: CommandPhase). Int -> CommandP p -> ShowS
forall (p :: CommandPhase). [CommandP p] -> ShowS
forall (p :: CommandPhase). CommandP p -> String
$cshowsPrec :: forall (p :: CommandPhase). Int -> CommandP p -> ShowS
showsPrec :: Int -> CommandP p -> ShowS
$cshow :: forall (p :: CommandPhase). CommandP p -> String
show :: CommandP p -> String
$cshowList :: forall (p :: CommandPhase). [CommandP p] -> ShowS
showList :: [CommandP p] -> ShowS
Show)
  deriving anyclass (Eq (CommandP p)
Eq (CommandP p) =>
(Int -> CommandP p -> Int)
-> (CommandP p -> Int) -> Hashable (CommandP p)
Int -> CommandP p -> Int
CommandP p -> Int
forall a. Eq a => (Int -> a -> Int) -> (a -> Int) -> Hashable a
forall (p :: CommandPhase). Eq (CommandP p)
forall (p :: CommandPhase). Int -> CommandP p -> Int
forall (p :: CommandPhase). CommandP p -> Int
$chashWithSalt :: forall (p :: CommandPhase). Int -> CommandP p -> Int
hashWithSalt :: Int -> CommandP p -> Int
$chash :: forall (p :: CommandPhase). CommandP p -> Int
hash :: CommandP p -> Int
Hashable, CommandP p -> ()
(CommandP p -> ()) -> NFData (CommandP p)
forall a. (a -> ()) -> NFData a
forall (p :: CommandPhase). CommandP p -> ()
$crnf :: forall (p :: CommandPhase). CommandP p -> ()
rnf :: CommandP p -> ()
NFData)

-- NOTE: We use standard Eq here and put the equivalence class Ord on a
-- newtype (CommandOrd) because some of tests verify all CommandP fields
-- match our expectations. Implementing Eq/Ord in terms of index would
-- weaken tests and hide bugs (e.g. potential legend refactors had a bug
-- with the key, but the tests missed this when Eq was determined by index).
--
-- We also intentionally do not implement Ord, as such uses should
-- probably use CommandOrd, and we do not want to accidentally use the
-- derived Ord.

instance
  ( k ~ A_Lens,
    a ~ CommandIndex,
    b ~ CommandIndex
  ) =>
  LabelOptic "index" k (CommandP p) (CommandP p) a b
  where
  labelOptic :: Optic k NoIx (CommandP p) (CommandP p) a b
labelOptic =
    LensVL (CommandP p) (CommandP p) a b
-> Lens (CommandP p) (CommandP p) a b
forall s t a b. LensVL s t a b -> Lens s t a b
lensVL
      (LensVL (CommandP p) (CommandP p) a b
 -> Lens (CommandP p) (CommandP p) a b)
-> LensVL (CommandP p) (CommandP p) a b
-> Lens (CommandP p) (CommandP p) a b
forall a b. (a -> b) -> a -> b
$ \a -> f b
f (MkCommandP CommandIndex
a1 Maybe Text
a2 Text
a3) ->
        (CommandIndex -> CommandP p) -> f CommandIndex -> f (CommandP p)
forall a b. (a -> b) -> f a -> f b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap
          (\CommandIndex
b -> CommandIndex -> Maybe Text -> Text -> CommandP p
forall (p :: CommandPhase).
CommandIndex -> Maybe Text -> Text -> CommandP p
MkCommandP CommandIndex
b Maybe Text
a2 Text
a3)
          (a -> f b
f a
CommandIndex
a1)
  {-# INLINE labelOptic #-}

instance
  ( k ~ A_Lens,
    a ~ Maybe Text,
    b ~ Maybe Text
  ) =>
  LabelOptic "key" k (CommandP p) (CommandP p) a b
  where
  labelOptic :: Optic k NoIx (CommandP p) (CommandP p) a b
labelOptic =
    LensVL (CommandP p) (CommandP p) a b
-> Lens (CommandP p) (CommandP p) a b
forall s t a b. LensVL s t a b -> Lens s t a b
lensVL
      (LensVL (CommandP p) (CommandP p) a b
 -> Lens (CommandP p) (CommandP p) a b)
-> LensVL (CommandP p) (CommandP p) a b
-> Lens (CommandP p) (CommandP p) a b
forall a b. (a -> b) -> a -> b
$ \a -> f b
f (MkCommandP CommandIndex
a1 Maybe Text
a2 Text
a3) ->
        (Maybe Text -> CommandP p) -> f (Maybe Text) -> f (CommandP p)
forall a b. (a -> b) -> f a -> f b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap
          (\Maybe Text
b -> CommandIndex -> Maybe Text -> Text -> CommandP p
forall (p :: CommandPhase).
CommandIndex -> Maybe Text -> Text -> CommandP p
MkCommandP CommandIndex
a1 Maybe Text
b Text
a3)
          (a -> f b
f a
Maybe Text
a2)
  {-# INLINE labelOptic #-}

instance
  ( k ~ A_Lens,
    a ~ Text,
    b ~ Text
  ) =>
  LabelOptic "command" k (CommandP p) (CommandP p) a b
  where
  labelOptic :: Optic k NoIx (CommandP p) (CommandP p) a b
labelOptic =
    LensVL (CommandP p) (CommandP p) a b
-> Lens (CommandP p) (CommandP p) a b
forall s t a b. LensVL s t a b -> Lens s t a b
lensVL
      (LensVL (CommandP p) (CommandP p) a b
 -> Lens (CommandP p) (CommandP p) a b)
-> LensVL (CommandP p) (CommandP p) a b
-> Lens (CommandP p) (CommandP p) a b
forall a b. (a -> b) -> a -> b
$ \a -> f b
f (MkCommandP CommandIndex
a1 Maybe Text
a2 Text
a3) ->
        (Text -> CommandP p) -> f Text -> f (CommandP p)
forall a b. (a -> b) -> f a -> f b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap
          (\Text
b -> CommandIndex -> Maybe Text -> Text -> CommandP p
forall (p :: CommandPhase).
CommandIndex -> Maybe Text -> Text -> CommandP p
MkCommandP CommandIndex
a1 Maybe Text
a2 Text
b)
          (a -> f b
f a
Text
a3)
  {-# INLINE labelOptic #-}

-- | Phase1 commands.
type CommandP1 = CommandP CommandPhase1

-- | Phase2 commands.
type CommandP2 = CommandP CommandPhase2

advancePhase :: CommandP1 -> Maybe Text -> CommandP2
advancePhase :: CommandP1 -> Maybe Text -> CommandP2
advancePhase CommandP1
cmd Maybe Text
minit = Optic A_Lens NoIx CommandP1 CommandP2 Text Text
-> (Text -> Text) -> CommandP1 -> CommandP2
forall k (is :: IxList) s t a b.
Is k A_Setter =>
Optic k is s t a b -> (a -> b) -> s -> t
over' Optic A_Lens NoIx CommandP1 CommandP2 Text Text
#command Text -> Text
f CommandP1
cmd
  where
    f :: Text -> Text
f = case Maybe Text
minit of
      Maybe Text
Nothing -> Text -> Text
forall a. a -> a
id
      Just Text
init -> \Text
c -> Text
init Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" && " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
c

-- | Transforms a command into its text to be executed by the shell.
commandToShell :: CommandP2 -> String
commandToShell :: CommandP2 -> String
commandToShell = Text -> String
T.unpack (Text -> String) -> (CommandP2 -> Text) -> CommandP2 -> String
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 CommandP2 Text -> CommandP2 -> Text
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens NoIx CommandP2 Text
#command

-- Transforms a command into a 'ProcessConfig'.
--
commandToProcess :: CommandP1 -> Maybe Text -> CreateProcess
commandToProcess :: CommandP1 -> Maybe Text -> CreateProcess
commandToProcess CommandP1
command =
  String -> CreateProcess
P.shell
    (String -> CreateProcess)
-> (Maybe Text -> String) -> Maybe Text -> CreateProcess
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
. CommandP2 -> String
commandToShell
    (CommandP2 -> String)
-> (Maybe Text -> CommandP2) -> Maybe Text -> String
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
. CommandP1 -> Maybe Text -> CommandP2
advancePhase CommandP1
command

-- | Represents a Command's status.
type CommandStatus :: Type
data CommandStatus
  = -- | The command ran successfully.
    CommandSuccess
  | -- | The command failed.
    CommandFailure
  | -- | The command is running. It is associated to its own PID and child
    -- PIDs, for later cleanup.
    CommandRunning (Tuple2 (Maybe Pid) (List Pid))
  | -- | The command is waiting to run.
    CommandWaiting

-- | Wraps 'CommandP' for the purposes of ordering by index.
newtype CommandOrd p = MkCommandOrd (CommandP p)
  deriving newtype ((forall x. CommandOrd p -> Rep (CommandOrd p) x)
-> (forall x. Rep (CommandOrd p) x -> CommandOrd p)
-> Generic (CommandOrd p)
forall x. Rep (CommandOrd p) x -> CommandOrd p
forall x. CommandOrd p -> Rep (CommandOrd p) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (p :: CommandPhase) x. Rep (CommandOrd p) x -> CommandOrd p
forall (p :: CommandPhase) x. CommandOrd p -> Rep (CommandOrd p) x
$cfrom :: forall (p :: CommandPhase) x. CommandOrd p -> Rep (CommandOrd p) x
from :: forall x. CommandOrd p -> Rep (CommandOrd p) x
$cto :: forall (p :: CommandPhase) x. Rep (CommandOrd p) x -> CommandOrd p
to :: forall x. Rep (CommandOrd p) x -> CommandOrd p
Generic, Eq (CommandOrd p)
Eq (CommandOrd p) =>
(Int -> CommandOrd p -> Int)
-> (CommandOrd p -> Int) -> Hashable (CommandOrd p)
Int -> CommandOrd p -> Int
CommandOrd p -> Int
forall a. Eq a => (Int -> a -> Int) -> (a -> Int) -> Hashable a
forall (p :: CommandPhase). Eq (CommandOrd p)
forall (p :: CommandPhase). Int -> CommandOrd p -> Int
forall (p :: CommandPhase). CommandOrd p -> Int
$chashWithSalt :: forall (p :: CommandPhase). Int -> CommandOrd p -> Int
hashWithSalt :: Int -> CommandOrd p -> Int
$chash :: forall (p :: CommandPhase). CommandOrd p -> Int
hash :: CommandOrd p -> Int
Hashable)

instance Eq (CommandOrd p) where
  MkCommandOrd CommandP p
x == :: CommandOrd p -> CommandOrd p -> Bool
== MkCommandOrd CommandP p
y = CommandP p
x CommandP p
-> Optic' A_Lens NoIx (CommandP p) CommandIndex -> CommandIndex
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx (CommandP p) CommandIndex
#index CommandIndex -> CommandIndex -> Bool
forall a. Eq a => a -> a -> Bool
== CommandP p
y CommandP p
-> Optic' A_Lens NoIx (CommandP p) CommandIndex -> CommandIndex
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx (CommandP p) CommandIndex
#index

instance Ord (CommandOrd p) where
  MkCommandOrd CommandP p
x <= :: CommandOrd p -> CommandOrd p -> Bool
<= MkCommandOrd CommandP p
y = CommandP p
x CommandP p
-> Optic' A_Lens NoIx (CommandP p) CommandIndex -> CommandIndex
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx (CommandP p) CommandIndex
#index CommandIndex -> CommandIndex -> Bool
forall a. Ord a => a -> a -> Bool
<= CommandP p
y CommandP p
-> Optic' A_Lens NoIx (CommandP p) CommandIndex -> CommandIndex
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx (CommandP p) CommandIndex
#index

instance
  (k ~ An_Iso, a ~ CommandP p, b ~ CommandP p) =>
  LabelOptic "unCommandOrd" k (CommandOrd p) (CommandOrd p) a b
  where
  labelOptic :: Optic k NoIx (CommandOrd p) (CommandOrd p) a b
labelOptic = (CommandOrd p -> a)
-> (b -> CommandOrd p) -> Iso (CommandOrd p) (CommandOrd p) a b
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso (\(MkCommandOrd CommandP p
x) -> a
CommandP p
x) b -> CommandOrd p
CommandP p -> CommandOrd p
forall (p :: CommandPhase). CommandP p -> CommandOrd p
MkCommandOrd
  {-# INLINE labelOptic #-}

-- | Command status map index.
data CommandStatusMapIndex
  = CommandStatusMapStm
  | CommandStatusMapPure

-- | Relates index to command status type.
type CommandStatusMapIndexF :: CommandStatusMapIndex -> Type
type family CommandStatusMapIndexF i where
  CommandStatusMapIndexF CommandStatusMapStm = HashMap CommandIndex (Tuple2 CommandP1 (TVar CommandStatus))
  CommandStatusMapIndexF CommandStatusMapPure = HashMap CommandIndex (Tuple2 CommandP1 CommandStatus)

-- | Command status map.
type CommandStatusMapP :: CommandStatusMapIndex -> Type
newtype CommandStatusMapP p = MkCommandStatusMapP
  { forall (p :: CommandStatusMapIndex).
CommandStatusMapP p -> CommandStatusMapIndexF p
unCommandStatusMap :: CommandStatusMapIndexF p
  }

-- | Normal status map, mutable in stm.
type TCommandStatusMap = CommandStatusMapP CommandStatusMapStm

-- | Pure status map i.e. after the stm map has been read.
type CommandStatusMap = CommandStatusMapP CommandStatusMapPure

instance
  (k ~ An_Iso, a ~ CommandStatusMapIndexF p, b ~ CommandStatusMapIndexF p) =>
  LabelOptic "unCommandStatusMap" k (CommandStatusMapP p) (CommandStatusMapP p) a b
  where
  labelOptic :: Optic k NoIx (CommandStatusMapP p) (CommandStatusMapP p) a b
labelOptic = (CommandStatusMapP p -> a)
-> (b -> CommandStatusMapP p)
-> Iso (CommandStatusMapP p) (CommandStatusMapP p) a b
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso (\(MkCommandStatusMapP CommandStatusMapIndexF p
x) -> a
CommandStatusMapIndexF p
x) b -> CommandStatusMapP p
CommandStatusMapIndexF p -> CommandStatusMapP p
forall (p :: CommandStatusMapIndex).
CommandStatusMapIndexF p -> CommandStatusMapP p
MkCommandStatusMapP
  {-# INLINE labelOptic #-}

-- | Reads a map of TVars into a pure map via a single STM transaction.
readCommandStatus ::
  ( HasCallStack,
    MonadAtomic m
  ) =>
  TCommandStatusMap ->
  m CommandStatusMap
readCommandStatus :: forall (m :: Type -> Type).
(HasCallStack, MonadAtomic m) =>
TCommandStatusMap -> m CommandStatusMap
readCommandStatus (MkCommandStatusMapP CommandStatusMapIndexF 'CommandStatusMapStm
mp) =
  HashMap CommandIndex (CommandP1, CommandStatus) -> CommandStatusMap
CommandStatusMapIndexF 'CommandStatusMapPure -> CommandStatusMap
forall (p :: CommandStatusMapIndex).
CommandStatusMapIndexF p -> CommandStatusMapP p
MkCommandStatusMapP (HashMap CommandIndex (CommandP1, CommandStatus)
 -> CommandStatusMap)
-> m (HashMap CommandIndex (CommandP1, CommandStatus))
-> m CommandStatusMap
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> STM (HashMap CommandIndex (CommandP1, CommandStatus))
-> m (HashMap CommandIndex (CommandP1, CommandStatus))
forall a. HasCallStack => STM a -> m a
forall (m :: Type -> Type) a.
(MonadAtomic m, HasCallStack) =>
STM a -> m a
atomically (HashMap CommandIndex (CommandP1, TVar CommandStatus)
-> ((CommandP1, TVar CommandStatus)
    -> STM (CommandP1, CommandStatus))
-> STM (HashMap CommandIndex (CommandP1, CommandStatus))
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for HashMap CommandIndex (CommandP1, TVar CommandStatus)
CommandStatusMapIndexF 'CommandStatusMapStm
mp ((TVar CommandStatus -> STM CommandStatus)
-> (CommandP1, TVar CommandStatus)
-> STM (CommandP1, CommandStatus)
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> (CommandP1, a) -> f (CommandP1, b)
traverse TVar CommandStatus -> STM CommandStatus
forall a. TVar a -> STM a
readTVar'))