{-# LANGUAGE MonadComprehensions #-}
{-# LANGUAGE OverloadedLists #-}

-- | Provides types for the legend functionality.
module Shrun.Configuration.Legend
  ( -- * Parsing
    linesToMap,
    LegendMap,
    DuplicateKeyError (..),

    -- * Translation
    translateCommands,
    CyclicKeyError (..),
  )
where

import Data.HashMap.Strict qualified as Map
import Data.HashSet qualified as Set
import Data.Sequence.NonEmpty qualified as NESeq
import Data.Text.Lazy qualified as LazyT
import Data.Text.Lazy.Builder (Builder)
import Data.Text.Lazy.Builder qualified as LTBuilder
import Shrun.Command.Types
  ( CommandIndex,
    CommandP (MkCommandP),
    CommandP1,
  )
import Shrun.Command.Types qualified as CT
import Shrun.Configuration.Data.Graph
  ( Edge,
    EdgeArgs (EdgeArgsList, EdgeArgsSequential),
    EdgeLabel (EdgeAnd, EdgeAny, EdgeOr),
    EdgeSequential (EdgeSequentialAnd, EdgeSequentialAny, EdgeSequentialOr),
    Edges (MkEdges),
  )
import Shrun.Configuration.Data.Graph qualified as Graph
import Shrun.Configuration.Toml.Legend (KeyVal (MkKeyVal), LegendMap)
import Shrun.Prelude

-- $setup
-- >>> import Shrun.Prelude
-- >>> import Data.HashMap.Strict qualified as Map

-- | Errors when parsing the legend.
newtype DuplicateKeyError = MkDuplicateKeyError Text
  deriving stock (DuplicateKeyError -> DuplicateKeyError -> Bool
(DuplicateKeyError -> DuplicateKeyError -> Bool)
-> (DuplicateKeyError -> DuplicateKeyError -> Bool)
-> Eq DuplicateKeyError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DuplicateKeyError -> DuplicateKeyError -> Bool
== :: DuplicateKeyError -> DuplicateKeyError -> Bool
$c/= :: DuplicateKeyError -> DuplicateKeyError -> Bool
/= :: DuplicateKeyError -> DuplicateKeyError -> Bool
Eq, Int -> DuplicateKeyError -> ShowS
[DuplicateKeyError] -> ShowS
DuplicateKeyError -> String
(Int -> DuplicateKeyError -> ShowS)
-> (DuplicateKeyError -> String)
-> ([DuplicateKeyError] -> ShowS)
-> Show DuplicateKeyError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DuplicateKeyError -> ShowS
showsPrec :: Int -> DuplicateKeyError -> ShowS
$cshow :: DuplicateKeyError -> String
show :: DuplicateKeyError -> String
$cshowList :: [DuplicateKeyError] -> ShowS
showList :: [DuplicateKeyError] -> ShowS
Show)

instance Exception DuplicateKeyError where
  displayException :: DuplicateKeyError -> String
displayException (MkDuplicateKeyError Text
k) = String
"Legend error: found duplicate key: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
unpack Text
k

-- | Attempts to parse the given ['KeyVal'] into 'LegendMap'.
-- Duplicate keys are not allowed.
linesToMap :: (HasCallStack, MonadThrow m) => Seq KeyVal -> m LegendMap
linesToMap :: forall (m :: Type -> Type).
(HasCallStack, MonadThrow m) =>
Seq KeyVal -> m LegendMap
linesToMap = (KeyVal -> m LegendMap -> m LegendMap)
-> m LegendMap -> Seq KeyVal -> m LegendMap
forall a b. (a -> b -> b) -> b -> Seq a -> b
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr KeyVal -> m LegendMap -> m LegendMap
forall {m :: Type -> Type}.
MonadThrow m =>
KeyVal -> m LegendMap -> m LegendMap
f (LegendMap -> m LegendMap
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure LegendMap
forall k v. HashMap k v
Map.empty)
  where
    f :: KeyVal -> m LegendMap -> m LegendMap
f (MkKeyVal Maybe EdgeArgs
es Text
k NESeq Text
v) = (Text, (NESeq Text, Maybe EdgeArgs)) -> m LegendMap -> m LegendMap
forall {m :: Type -> Type} {v}.
MonadThrow m =>
(Text, v) -> m (HashMap Text v) -> m (HashMap Text v)
insertPair (Text
k, (NESeq Text
v, Maybe EdgeArgs
es))
    insertPair :: (Text, v) -> m (HashMap Text v) -> m (HashMap Text v)
insertPair (Text
key, v
cmd) m (HashMap Text v)
mMap = do
      HashMap Text v
mp <- m (HashMap Text v)
mMap
      case Text -> HashMap Text v -> Maybe v
forall k v. Hashable k => k -> HashMap k v -> Maybe v
Map.lookup Text
key HashMap Text v
mp of
        Just v
_ -> DuplicateKeyError -> m (HashMap Text v)
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: Type -> Type) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (DuplicateKeyError -> m (HashMap Text v))
-> DuplicateKeyError -> m (HashMap Text v)
forall a b. (a -> b) -> a -> b
$ Text -> DuplicateKeyError
MkDuplicateKeyError Text
key
        Maybe v
Nothing -> HashMap Text v -> m (HashMap Text v)
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (HashMap Text v -> m (HashMap Text v))
-> HashMap Text v -> m (HashMap Text v)
forall a b. (a -> b) -> a -> b
$ Text -> v -> HashMap Text v -> HashMap Text v
forall k v. Hashable k => k -> v -> HashMap k v -> HashMap k v
Map.insert Text
key v
cmd HashMap Text v
mp

newtype CyclicKeyError = MkCyclicKeyError Text
  deriving stock (CyclicKeyError -> CyclicKeyError -> Bool
(CyclicKeyError -> CyclicKeyError -> Bool)
-> (CyclicKeyError -> CyclicKeyError -> Bool) -> Eq CyclicKeyError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CyclicKeyError -> CyclicKeyError -> Bool
== :: CyclicKeyError -> CyclicKeyError -> Bool
$c/= :: CyclicKeyError -> CyclicKeyError -> Bool
/= :: CyclicKeyError -> CyclicKeyError -> Bool
Eq, Int -> CyclicKeyError -> ShowS
[CyclicKeyError] -> ShowS
CyclicKeyError -> String
(Int -> CyclicKeyError -> ShowS)
-> (CyclicKeyError -> String)
-> ([CyclicKeyError] -> ShowS)
-> Show CyclicKeyError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CyclicKeyError -> ShowS
showsPrec :: Int -> CyclicKeyError -> ShowS
$cshow :: CyclicKeyError -> String
show :: CyclicKeyError -> String
$cshowList :: [CyclicKeyError] -> ShowS
showList :: [CyclicKeyError] -> ShowS
Show)

instance Exception CyclicKeyError where
  displayException :: CyclicKeyError -> String
displayException (MkCyclicKeyError Text
path) =
    String
"Encountered cyclic definitions when translating commands: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
unpack Text
path

-- | Returns a list of 'Text' commands, potentially transforming a
-- given string via the `LegendMap` @legend@.
--
-- Given a command string /s/, we first check if /s/ exists as a key in
-- @legend@. If it does not, we return /s/. If there is a key matching
-- /s/, i.e.,
--
-- @
-- legend = fromList [...,(s, v),...]
-- @
--
-- where \(v = v_1,,\ldots,,v_n\), then we recursively search on each
-- \(v_i\). We stop and return \(v_i\) when it does not exist as a key in the
-- map.
--
-- ==== __Examples__
-- >>> :set -XOverloadedLists
-- >>> :{
--   let m = Map.fromList
--         [ ("cmd1", ("one" :<|| [], Nothing)),
--           ("cmd2", ("two" :<|| [], Nothing)),
--           ("all", ("cmd1" :<|| ["cmd2","other"], Nothing))
--         ]
--       k = (fmap . first) (fmap (view #command))
--   in k $ translateCommands m ("all" :<|| ["blah"]) Nothing
-- :}
-- (fromList ("one" :| ["two","other","blah"]),MkEdges {unEdges = fromList []})
--
-- Note: If -- when looking up a line -- we detect a cycle, then a 'CyclicKeyError'
-- will be returned.
--
-- >>> :{
--   let m = Map.fromList
--         [ ("a", ("b" :<|| [], Nothing)),
--           ("b", ("c" :<|| [], Nothing)),
--           ("c", ("a" :<|| [], Nothing))
--         ]
--   in try @_ @CyclicKeyError $ translateCommands m ("a" :<|| []) Nothing
-- :}
-- Left (MkCyclicKeyError "a -> b -> c -> a")
translateCommands ::
  forall m.
  ( HasCallStack,
    MonadThrow m
  ) =>
  LegendMap ->
  NESeq Text ->
  Maybe EdgeArgs ->
  m (Tuple2 (NESeq CommandP1) Edges)
translateCommands :: forall (m :: Type -> Type).
(HasCallStack, MonadThrow m) =>
LegendMap
-> NESeq Text -> Maybe EdgeArgs -> m (NESeq CommandP1, Edges)
translateCommands LegendMap
legendMap NESeq Text
commands =
  LegendMap -> NESeq Text -> Maybe EdgeArgs -> m (LegendMap, Text)
forall (m :: Type -> Type).
(HasCallStack, MonadThrow m) =>
LegendMap -> NESeq Text -> Maybe EdgeArgs -> m (LegendMap, Text)
addCliLegend LegendMap
legendMap NESeq Text
commands (Maybe EdgeArgs -> m (LegendMap, Text))
-> ((LegendMap, Text) -> m (NESeq CommandP1, Edges))
-> Maybe EdgeArgs
-> m (NESeq CommandP1, Edges)
forall (m :: Type -> Type) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> (LegendMap -> Text -> m (NESeq CommandP1, Edges))
-> (LegendMap, Text) -> m (NESeq CommandP1, Edges)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry LegendMap -> Text -> m (NESeq CommandP1, Edges)
forall (m :: Type -> Type).
(HasCallStack, MonadThrow m) =>
LegendMap -> Text -> m (NESeq CommandP1, Edges)
translateMap
{-# INLINEABLE translateCommands #-}

translateMap ::
  forall m.
  ( HasCallStack,
    MonadThrow m
  ) =>
  LegendMap ->
  Text ->
  m (Tuple2 (NESeq CommandP1) Edges)
translateMap :: forall (m :: Type -> Type).
(HasCallStack, MonadThrow m) =>
LegendMap -> Text -> m (NESeq CommandP1, Edges)
translateMap LegendMap
mp Text
initKey = do
  -- NOTE: [CLI and Legend Edges]
  --
  -- Previously, translateCommands took in the LegendMap and CLI commands
  -- (NESeq Text), and simply traversed 'go' over the CLI commands.
  --
  -- This became a bit awkward once the Legend keys could take edges, because
  -- this separation would mean we'd have to repair the Legend edges then
  -- repair the CLI edges. The repair logic is tricky, so duplicating this
  -- logic was not attractive.
  --
  -- We observed that this separation between CLI commands and LegendMap
  -- was arguably artificial, because we could just add the CLI command to the
  -- LegendMap under some InitKey, and then run translateCommands on InitKey.
  -- This therefore means the CLI and Toml aliases share the same logic
  -- (e.g. edge repairs, indexing), which is exactly what we want.
  --
  -- Still, this is slightly unsatisfactory as we require logic to conjure
  -- up an unused InitKey, which can technically fail (though a failure
  -- would be truly pathological). There are some alternatives that do not
  -- require adding the CLI commands + edges to the LegendMap:
  --
  -- 1. Treat them totally separately here. As mentioned, this means we
  --    have to duplicate the indexing + edge repair logic. Not ideal.
  --
  -- 2. Abstract the lookup function. That is, instead of doing Map.lookup
  --    in 'go', pass it in as a function. The very first lookup will
  --    hardcode returning the CLI commands + edges, the rest will use
  --    Map.lookup. This requires adding some kind of flag to the accumulator
  --    e.g. a boolean that determines which lookup to use.
  let commands :: NESeq (CommandIndex, Text)
commands = NESeq Text -> NESeq (CommandIndex, Text)
forall a. NESeq a -> NESeq (CommandIndex, a)
indexSeq (NESeq Text -> NESeq (CommandIndex, Text))
-> NESeq Text -> NESeq (CommandIndex, Text)
forall a b. (a -> b) -> a -> b
$ Text -> NESeq Text
forall a. a -> NESeq a
NESeq.singleton Text
initKey
  (NESeq CommandP1
cmds, Edges
edges, HashMap CommandIndex (CommandIndex, CommandIndex)
_) <- Maybe Text
-> HashSet Text
-> Builder
-> CommandIndex
-> NESeq (CommandIndex, Text)
-> m Acc
go Maybe Text
forall a. Maybe a
Nothing HashSet Text
forall a. HashSet a
Set.empty (Text -> Builder
LTBuilder.fromText Text
"") CommandIndex
forall m. MMonoid m => m
one NESeq (CommandIndex, Text)
commands
  (NESeq CommandP1, Edges) -> m (NESeq CommandP1, Edges)
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (NESeq CommandP1
cmds, Edges -> Edges
Graph.sortEdges Edges
edges)
  where
    go ::
      -- Previous key, for handling the key on the Command.
      Maybe Text ->
      -- Keys found so far, for detecting cycles.
      HashSet Text ->
      -- The stringbuilder path is a textual representation of the key path
      -- we have traversed so far, e.g., a -> b -> c
      Builder ->
      -- Starting index for the next command.
      CommandIndex ->
      -- List to process: tuple of (command or alias) text, along with
      -- _original_ index, for repairing any edges that reference this text,
      -- after alias expansion changes the indexes.
      NESeq (Tuple2 CommandIndex Text) ->
      -- Accumulator of (NESeq CommandP1, Edges, Map Idx (Idx, Idx)). We
      -- accumulate commands and edges as we encounter them. We also build up
      -- a map that relates original index to new index bounds, for repairing
      -- edges.
      m Acc
    go :: Maybe Text
-> HashSet Text
-> Builder
-> CommandIndex
-> NESeq (CommandIndex, Text)
-> m Acc
go Maybe Text
prevKey HashSet Text
foundKeys Builder
path CommandIndex
startIdx ((CommandIndex
origIdx, Text
line) :<|| Seq (CommandIndex, Text)
lines) = do
      case Text -> LegendMap -> Maybe (NESeq Text, Maybe EdgeArgs)
forall k v. Hashable k => k -> HashMap k v -> Maybe v
Map.lookup Text
line LegendMap
mp of
        Maybe (NESeq Text, Maybe EdgeArgs)
Nothing -> do
          -- The line isn't a key. Make a singleton command and continue with the rest.
          let cmds :: NESeq CommandP1
cmds = CommandP1 -> NESeq CommandP1
forall a. a -> NESeq a
NESeq.singleton (CommandIndex -> Maybe Text -> Text -> CommandP1
forall (p :: CommandPhase).
CommandIndex -> Maybe Text -> Text -> CommandP p
MkCommandP CommandIndex
startIdx Maybe Text
prevKey Text
line)
              -- The new index is just the single startIdx.
              allData :: Acc
allData = (NESeq CommandP1
cmds, Edges
forall a. Monoid a => a
mempty, CommandIndex
-> (CommandIndex, CommandIndex)
-> HashMap CommandIndex (CommandIndex, CommandIndex)
forall k v. Hashable k => k -> v -> HashMap k v
Map.singleton CommandIndex
origIdx (CommandIndex
startIdx, CommandIndex
startIdx))
          case Seq (CommandIndex, Text)
lines of
            Seq (CommandIndex, Text)
Empty -> Acc -> m Acc
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Acc
allData
            (CommandIndex, Text)
l :<| Seq (CommandIndex, Text)
ls -> (Acc
allData Acc -> Acc -> Acc
forall a. Semigroup a => a -> a -> a
<>) (Acc -> Acc) -> m Acc -> m Acc
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
-> HashSet Text
-> Builder
-> CommandIndex
-> NESeq (CommandIndex, Text)
-> m Acc
go Maybe Text
prevKey HashSet Text
foundKeys Builder
path (CommandIndex -> CommandIndex
CT.succ CommandIndex
startIdx) ((CommandIndex, Text)
l (CommandIndex, Text)
-> Seq (CommandIndex, Text) -> NESeq (CommandIndex, Text)
forall a. a -> Seq a -> NESeq a
:<|| Seq (CommandIndex, Text)
ls)
        -- The line is a key, check for cycles and recursively call.
        Just (NESeq Text
vals, Maybe EdgeArgs
mEdges) -> case Maybe Text
maybeCyclicVal of
          Just Text
cyclicVal -> do
            let pathTxt :: Text
pathTxt = Builder -> Text -> Text -> Text
builderToPath Builder
path Text
line Text
cyclicVal
            CyclicKeyError -> m Acc
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: Type -> Type) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (CyclicKeyError -> m Acc) -> CyclicKeyError -> m Acc
forall a b. (a -> b) -> a -> b
$ Text -> CyclicKeyError
MkCyclicKeyError Text
pathTxt
          Maybe Text
Nothing -> do
            -- 1. Run on newly found commands.
            --
            -- NOTE: We have to split these cases up due to handling the prevKey
            -- differently. We want to pass along the key name (i.e. line)
            -- iff we have exactly one value i.e. key = val. We do _not_ want to
            -- pass this in if we have a list i.e. key = [val1, val2, ...].
            --
            -- If we did, the command output would have:
            --   [Success][all] N seconds
            --   [Success][all] N seconds
            --   ...
            --
            -- That is, we would have multiple commands sharing the same key
            -- name, hence the output would be ambiguous. To prevent this, only
            -- pass the name in when it is guaranteed we have a unique
            -- key = val mapping.
            --
            -- We also must guard against the initKey, since we do not want
            -- that to be considered a key.
            let mPrevKey :: Maybe Text
mPrevKey =
                  if NESeq Text -> Int
forall a. NESeq a -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length NESeq Text
vals Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 Bool -> Bool -> Bool
|| Text
line Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
initKey
                    then Maybe Text
forall a. Maybe a
Nothing
                    else Text -> Maybe Text
forall a. a -> Maybe a
Just Text
line
                -- Add indexes to the found values. These are the _original_
                -- indexes i.e. what mEdges references.
                valsIx :: NESeq (CommandIndex, Text)
valsIx = NESeq Text -> NESeq (CommandIndex, Text)
forall a. NESeq a -> NESeq (CommandIndex, a)
indexSeq NESeq Text
vals

            -- Run 'go' on the found vals, collecting the expanded commands
            -- (subCmds), all edges (subEdges), and map from subCommands. We
            -- use this map to repair mEdges.
            (NESeq CommandP1
subCmds, Edges
subEdges, HashMap CommandIndex (CommandIndex, CommandIndex)
subCmdIdxMap) <- Maybe Text
-> HashSet Text
-> Builder
-> CommandIndex
-> NESeq (CommandIndex, Text)
-> m Acc
go Maybe Text
mPrevKey HashSet Text
foundKeys' Builder
path' CommandIndex
startIdx NESeq (CommandIndex, Text)
valsIx
            let -- numCmds, subtracting one as this represents the _final_
                -- index, which is one less than the total number of commands.
                -- E.g. endIdx === startIdx <=> len(vals) === 1, hence
                -- numCmdsIdx === 0.
                numCmdsIdx :: NonNegative Int
numCmdsIdx = Int -> NonNegative Int
forall a.
(AMonoid a, HasCallStack, Ord a, Show a) =>
a -> NonNegative a
unsafeNonNegative (Int -> NonNegative Int) -> Int -> NonNegative Int
forall a b. (a -> b) -> a -> b
$ NESeq CommandP1 -> Int
forall a. NESeq a -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length NESeq CommandP1
subCmds Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
                endIdx :: CommandIndex
endIdx = CommandIndex -> NonNegative Int -> CommandIndex
CT.addNN CommandIndex
startIdx NonNegative Int
numCmdsIdx

                -- idxMap is the index map for _this_ command i.e. the line
                -- with subcommands. Its value is its original index
                -- to its new start (startIdx) and end (endIdx, which is
                -- just the length of the expanded commands). E.g., if we had
                --
                --   line => [cmd1, cmd2, cmd3]
                --
                -- Then the new indexes would be (startIdx, startIdx + 2)
                --
                -- Note that we do not want to return subCmdIdxMap as it is
                -- only relevant for repairing mEdges. The only map we should
                -- return here is idxMap.
                idxMap :: HashMap CommandIndex (CommandIndex, CommandIndex)
idxMap = CommandIndex
-> (CommandIndex, CommandIndex)
-> HashMap CommandIndex (CommandIndex, CommandIndex)
forall k v. Hashable k => k -> v -> HashMap k v
Map.singleton CommandIndex
origIdx (CommandIndex
startIdx, CommandIndex
endIdx)

                -- If this is the init key, let's give it a better name in
                -- error messages.
                errKeyName :: Text
errKeyName =
                  if Text
line Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
initKey
                    then Text
"command_line"
                    else Text
line

            -- Repair the edges.
            Edges
repairedEdges <- case Maybe EdgeArgs
mEdges of
              Maybe EdgeArgs
Nothing -> Edges -> m Edges
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Edges
forall a. Monoid a => a
mempty
              Just (EdgeArgsSequential EdgeSequential
s) ->
                -- If our graph is sequential, make an edge list (sequential
                -- edges for original values), then repair it.
                Text
-> Edges
-> HashMap CommandIndex (CommandIndex, CommandIndex)
-> m Edges
forall (m :: Type -> Type).
(HasCallStack, MonadThrow m) =>
Text
-> Edges
-> HashMap CommandIndex (CommandIndex, CommandIndex)
-> m Edges
repairEdges Text
errKeyName (EdgeSequential -> NESeq Text -> Edges
mkSequentialEdges EdgeSequential
s NESeq Text
vals) HashMap CommandIndex (CommandIndex, CommandIndex)
subCmdIdxMap
              Just (EdgeArgsList Edges
es) -> Text
-> Edges
-> HashMap CommandIndex (CommandIndex, CommandIndex)
-> m Edges
forall (m :: Type -> Type).
(HasCallStack, MonadThrow m) =>
Text
-> Edges
-> HashMap CommandIndex (CommandIndex, CommandIndex)
-> m Edges
repairEdges Text
errKeyName Edges
es HashMap CommandIndex (CommandIndex, CommandIndex)
subCmdIdxMap

            let newEdges :: Edges
newEdges = Edges
repairedEdges Edges -> Edges -> Edges
forall a. Semigroup a => a -> a -> a
<> Edges
subEdges
                allData :: Acc
allData = (NESeq CommandP1
subCmds, Edges
newEdges, HashMap CommandIndex (CommandIndex, CommandIndex)
idxMap)

            -- 2. Run 'go' on the rest.
            case Seq (CommandIndex, Text)
lines of
              Seq (CommandIndex, Text)
Empty -> Acc -> m Acc
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Acc
allData
              (CommandIndex, Text)
l :<| Seq (CommandIndex, Text)
ls -> do
                let newIdx :: CommandIndex
newIdx = CommandIndex
startIdx CommandIndex -> CommandIndex -> CommandIndex
forall s. ASemigroup s => s -> s -> s
.+. HasCallStack => Int -> CommandIndex
Int -> CommandIndex
CT.unsafeFromInt (NESeq CommandP1 -> Int
forall a. NESeq a -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length NESeq CommandP1
subCmds)
                (Acc
allData Acc -> Acc -> Acc
forall a. Semigroup a => a -> a -> a
<>) (Acc -> Acc) -> m Acc -> m Acc
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
-> HashSet Text
-> Builder
-> CommandIndex
-> NESeq (CommandIndex, Text)
-> m Acc
go Maybe Text
prevKey HashSet Text
foundKeys Builder
path CommandIndex
newIdx ((CommandIndex, Text)
l (CommandIndex, Text)
-> Seq (CommandIndex, Text) -> NESeq (CommandIndex, Text)
forall a. a -> Seq a -> NESeq a
:<|| Seq (CommandIndex, Text)
ls)
          where
            foundKeys' :: HashSet Text
foundKeys' = Text -> HashSet Text -> HashSet Text
forall a. Hashable a => a -> HashSet a -> HashSet a
Set.insert Text
line HashSet Text
foundKeys
            -- Detect if we have an intersection between previously found
            -- keys and the values we just found. If so we have found a
            -- cyclic error.
            intersect :: HashSet Text
intersect = HashSet Text -> HashSet Text -> HashSet Text
forall a. Eq a => HashSet a -> HashSet a -> HashSet a
Set.intersection HashSet Text
foundKeys (NESeq Text -> HashSet Text
neToSet NESeq Text
vals)
            -- If there are cycles then this should be `Just cyclicVal`
            -- (this list should have at most one since we are detecting
            -- the first cycle)
            maybeCyclicVal :: Maybe Text
maybeCyclicVal = [Text] -> Maybe Text
forall (f :: Type -> Type) a. Foldable f => f a -> Maybe a
headMaybe ([Text] -> Maybe Text) -> [Text] -> Maybe Text
forall a b. (a -> b) -> a -> b
$ HashSet Text -> [Text]
forall a. HashSet a -> [a]
Set.toList HashSet Text
intersect
            path' :: Builder
path' =
              if Text
line Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
initKey
                then Builder
""
                else Builder
path Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
LTBuilder.fromText Text
line Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
" -> "
            neToSet :: NESeq Text -> HashSet Text
neToSet = [Text] -> HashSet Text
forall a. Hashable a => [a] -> HashSet a
Set.fromList ([Text] -> HashSet Text)
-> (NESeq Text -> [Text]) -> NESeq Text -> HashSet 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
. NESeq Text -> [Text]
forall a. NESeq a -> [a]
forall (t :: Type -> Type) a. Foldable t => t a -> [a]
toList
{-# INLINEABLE translateMap #-}

-- | Adds indexes to the NESeq.
indexSeq :: NESeq a -> NESeq (Tuple2 CommandIndex a)
indexSeq :: forall a. NESeq a -> NESeq (CommandIndex, a)
indexSeq NESeq a
xs = NESeq CommandIndex -> NESeq a -> NESeq (CommandIndex, a)
forall a b. NESeq a -> NESeq b -> NESeq (a, b)
NESeq.zip (HasCallStack => Int -> CommandIndex
Int -> CommandIndex
CT.unsafeFromInt (Int -> CommandIndex) -> NESeq Int -> NESeq CommandIndex
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int] -> NESeq Int
forall a. HasCallStack => [a] -> NESeq a
unsafeListToNESeq [Int
Item [Int]
1 .. NESeq a -> Int
forall a. NESeq a -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length NESeq a
xs]) NESeq a
xs

-- | Repairs the paramter @edges@, based on the param @indexMap@. The
-- fundamental problems is that some edge @src -> dest@ may no longer be
-- correct after alias expansion. That is, suppose we have:
--
-- @
--   commands: cmd1 some_aliases cmd2
--   edges: 1 -> 2, 2 -> 3
-- @
--
-- i.e. our edges means @cmd1 -> some_aliases, some_aliases -> cmd2@
--
-- Say @some_aliases@ expands to @a1 a2 a2@. If we did nothing, our edges
-- would now mean @cmd1 -> a1, a1 -> a2@, which is not what we wanted.
-- What we really want is:
--
-- @
--   # original 'cmd1 -> some_aliases' edge
--   cmd1 -> a1, cmd1 -> a3, cmd1 -> a3
--   # original 'some_aliases -> cmd2' edge
--   a1 -> cmd2, a2 -> cmd2, a3 -> cmd2
-- @
--
-- i.e. we need to update the indexes, and when an alias is part of an edge,
-- we need to add edges for each alias index. To do this, the param
-- @indexMap@ stores a mapping from prevIndex to newIndexRange. In this case,
-- we'd have:
--
-- @
--   1 -> (1,1)
--   2 -> (2,4)
--   3 -> (5,5)
-- @
--
-- Then for each edge @src -> dest@, we look up both in the map to produce:
--
-- @
--   - Sources: (srcStart, srcEnd)
--   - Dests: (destStart, destEnd)
-- @
--
-- And make edges for the cartesian product of @Sources x Dests@ i.e. all
-- @si -> dj@.
repairEdges ::
  ( HasCallStack,
    MonadThrow m
  ) =>
  Text ->
  Edges ->
  HashMap CommandIndex (Tuple2 CommandIndex CommandIndex) ->
  m Edges
repairEdges :: forall (m :: Type -> Type).
(HasCallStack, MonadThrow m) =>
Text
-> Edges
-> HashMap CommandIndex (CommandIndex, CommandIndex)
-> m Edges
repairEdges Text
key (MkEdges Seq Edge
es) HashMap CommandIndex (CommandIndex, CommandIndex)
idxMap = Seq Edge -> Edges
MkEdges (Seq Edge -> Edges) -> m (Seq Edge) -> m Edges
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Edge -> m (Seq Edge) -> m (Seq Edge))
-> m (Seq Edge) -> Seq Edge -> m (Seq Edge)
forall a b. (a -> b -> b) -> b -> Seq a -> b
forall (t :: Type -> Type) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Edge -> m (Seq Edge) -> m (Seq Edge)
mapEdge (Seq Edge -> m (Seq Edge)
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Seq Edge
forall a. Seq a
Empty) Seq Edge
es
  where
    mapEdge :: Edge -> m (Seq Edge) -> m (Seq Edge)
mapEdge (CommandIndex
src, CommandIndex
dest, EdgeLabel
lbl) m (Seq Edge)
mAcc = do
      (CommandIndex
srcStart, CommandIndex
srcEnd) <- CommandIndex -> m (CommandIndex, CommandIndex)
lookupEdge CommandIndex
src
      (CommandIndex
destStart, CommandIndex
destEnd) <- CommandIndex -> m (CommandIndex, CommandIndex)
lookupEdge CommandIndex
dest

      let newEdges :: Seq Edge
          newEdges :: Seq Edge
newEdges =
            [ (CommandIndex
s, CommandIndex
d, EdgeLabel
lbl)
            | CommandIndex
s <- [Item (Seq CommandIndex)
CommandIndex
srcStart .. Item (Seq CommandIndex)
CommandIndex
srcEnd],
              CommandIndex
d <- [Item (Seq CommandIndex)
CommandIndex
destStart .. Item (Seq CommandIndex)
CommandIndex
destEnd]
            ]
      (Seq Edge
newEdges Seq Edge -> Seq Edge -> Seq Edge
forall a. Semigroup a => a -> a -> a
<>) (Seq Edge -> Seq Edge) -> m (Seq Edge) -> m (Seq Edge)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Seq Edge)
mAcc
      where
        lookupEdge :: CommandIndex -> m (CommandIndex, CommandIndex)
lookupEdge CommandIndex
i = case CommandIndex
-> HashMap CommandIndex (CommandIndex, CommandIndex)
-> Maybe (CommandIndex, CommandIndex)
forall k v. Hashable k => k -> HashMap k v -> Maybe v
Map.lookup CommandIndex
i HashMap CommandIndex (CommandIndex, CommandIndex)
idxMap of
          Maybe (CommandIndex, CommandIndex)
Nothing ->
            Text -> m (CommandIndex, CommandIndex)
forall (m :: Type -> Type) a.
(HasCallStack, MonadThrow m) =>
Text -> m a
throwText
              (Text -> m (CommandIndex, CommandIndex))
-> Text -> m (CommandIndex, CommandIndex)
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
                [ Text
Item [Text]
"Key ",
                  Text
Item [Text]
key,
                  Text
Item [Text]
": Index '",
                  CommandIndex -> Text
forall a. Pretty a => a -> Text
prettyToText CommandIndex
i,
                  Text
Item [Text]
"' in edge '",
                  CommandIndex -> Text
forall a. Pretty a => a -> Text
prettyToText CommandIndex
src,
                  Text
Item [Text]
" ",
                  EdgeLabel -> Text
forall s. IsString s => EdgeLabel -> s
Graph.displayEdgeLabel EdgeLabel
lbl,
                  Text
Item [Text]
" ",
                  CommandIndex -> Text
forall a. Pretty a => a -> Text
prettyToText CommandIndex
dest,
                  Text
Item [Text]
"' is out-of-bounds."
                ]
          Just (CommandIndex
s, CommandIndex
e) -> (CommandIndex, CommandIndex) -> m (CommandIndex, CommandIndex)
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (CommandIndex
s, CommandIndex
e)
{-# INLINEABLE repairEdges #-}

mkSequentialEdges :: EdgeSequential -> NESeq Text -> Edges
mkSequentialEdges :: EdgeSequential -> NESeq Text -> Edges
mkSequentialEdges EdgeSequential
eseq =
  Seq Edge -> Edges
MkEdges
    (Seq Edge -> Edges)
-> (NESeq Text -> Seq Edge) -> NESeq Text -> Edges
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
. Seq Edge -> Seq Edge
forall {a}. Seq a -> Seq a
dropLast
    (Seq Edge -> Seq Edge)
-> (NESeq Text -> Seq Edge) -> NESeq Text -> Seq Edge
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
. ((CommandIndex, Text) -> Edge)
-> Seq (CommandIndex, Text) -> Seq Edge
forall a b. (a -> b) -> Seq a -> Seq b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (CommandIndex, Text) -> Edge
toEdge
    (Seq (CommandIndex, Text) -> Seq Edge)
-> (NESeq Text -> Seq (CommandIndex, Text))
-> NESeq Text
-> Seq Edge
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
. NESeq (CommandIndex, Text) -> Seq (CommandIndex, Text)
forall a. NESeq a -> Seq a
NESeq.toSeq
    (NESeq (CommandIndex, Text) -> Seq (CommandIndex, Text))
-> (NESeq Text -> NESeq (CommandIndex, Text))
-> NESeq Text
-> Seq (CommandIndex, 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
. NESeq Text -> NESeq (CommandIndex, Text)
forall a. NESeq a -> NESeq (CommandIndex, a)
indexSeq
  where
    toEdge :: (CommandIndex, Text) -> Edge
toEdge (CommandIndex
idx, Text
_) = (CommandIndex
idx, CommandIndex -> CommandIndex
CT.succ CommandIndex
idx, EdgeLabel
lbl)

    lbl :: EdgeLabel
lbl = case EdgeSequential
eseq of
      EdgeSequential
EdgeSequentialAnd -> EdgeLabel
EdgeAnd
      EdgeSequential
EdgeSequentialOr -> EdgeLabel
EdgeOr
      EdgeSequential
EdgeSequentialAny -> EdgeLabel
EdgeAny

    dropLast :: Seq a -> Seq a
dropLast Seq a
Empty = Seq a
forall a. Seq a
Empty
    dropLast (a
_ :<| Seq a
Empty) = Seq a
forall a. Seq a
Empty
    dropLast (a
x :<| Seq a
ys) = a
x a -> Seq a -> Seq a
forall a. a -> Seq a -> Seq a
:<| Seq a -> Seq a
dropLast Seq a
ys

-- | Acc is our basic accumulator. In addition to the commands and edges that
-- we want to accumulate, we also have a map that relates a names old index
-- to its new index range. This is used to repair edges. For instance:
-- we have commands:
--
--   shrun --edges="1 & 3" cmd1 some_aliases cmd2
--
-- where some_aliases expands to a1 and a2. The intention is that cmd2 needs
-- to wait for cmd1. But after alias expansion, our commands will be indexed:
--
--   cmd1 a1 a2 cmd2
--
-- And the edge will mistakenly be "cmd1 & a2". We use the map to update
-- the edges i.e. transform that edge to "1 & 4".
type Acc =
  Tuple3
    (NESeq CommandP1)
    Edges
    (HashMap CommandIndex (CommandIndex, CommandIndex))

builderToPath :: Builder -> Text -> Text -> Text
builderToPath :: Builder -> Text -> Text -> Text
builderToPath Builder
path Text
l Text
v =
  LazyText -> Text
LazyT.toStrict
    (LazyText -> Text) -> LazyText -> Text
forall a b. (a -> b) -> a -> b
$ Builder -> LazyText
LTBuilder.toLazyText
    (Builder -> LazyText) -> Builder -> LazyText
forall a b. (a -> b) -> a -> b
$ Builder
path
    Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
LTBuilder.fromText Text
l
    Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
" -> "
    Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
LTBuilder.fromText Text
v

-- | Adds the commands and edges to the map under some unmapped key, that
-- is returned.
--
-- See NOTE: [CLI and Legend Edges]
--
-- We add the CLI commands and possible CLI edges to the legendMap e.g.
-- 'shrun_init_key_1 -> (CLI commands, CLI edges)'. We do this so
-- translateCommands can act uniformly over the map, which makes handling
-- edges correctly easier.
addCliLegend ::
  (HasCallStack, MonadThrow m) =>
  LegendMap ->
  NESeq Text ->
  Maybe EdgeArgs ->
  m (Tuple2 LegendMap Text)
addCliLegend :: forall (m :: Type -> Type).
(HasCallStack, MonadThrow m) =>
LegendMap -> NESeq Text -> Maybe EdgeArgs -> m (LegendMap, Text)
addCliLegend LegendMap
legendMap NESeq Text
commands Maybe EdgeArgs
mCliEdgeArgs = do
  Text
unmappedKey <- LegendMap -> NESeq Text -> m Text
forall (m :: Type -> Type).
(HasCallStack, MonadThrow m) =>
LegendMap -> NESeq Text -> m Text
findUnmappedKey LegendMap
legendMap NESeq Text
commands
  pure (Text -> (NESeq Text, Maybe EdgeArgs) -> LegendMap -> LegendMap
forall k v. Hashable k => k -> v -> HashMap k v -> HashMap k v
Map.insert Text
unmappedKey (NESeq Text
commands, Maybe EdgeArgs
mCliEdgeArgs) LegendMap
legendMap, Text
unmappedKey)
{-# INLINEABLE addCliLegend #-}

-- | Finds a key that does not exist in the map or as a command name
-- (The latter is to avoid cycles).
findUnmappedKey ::
  forall m.
  (HasCallStack, MonadThrow m) =>
  LegendMap ->
  NESeq Text ->
  m Text
findUnmappedKey :: forall (m :: Type -> Type).
(HasCallStack, MonadThrow m) =>
LegendMap -> NESeq Text -> m Text
findUnmappedKey LegendMap
legendMap NESeq Text
commands = Word16 -> m Text
go Word16
0
  where
    commandSet :: HashSet Text
commandSet = [Text] -> HashSet Text
forall a. Hashable a => [a] -> HashSet a
Set.fromList (NESeq Text -> [Text]
forall a. NESeq a -> [a]
forall (t :: Type -> Type) a. Foldable t => t a -> [a]
toList NESeq Text
commands)
    mx :: Word16
mx = Word16
forall a. Bounded a => a
maxBound
    pfx :: Text
pfx = Text
"shrun_init_key_"

    unmapped :: Text -> Bool
unmapped Text
t =
      Bool -> Bool
not (Text -> LegendMap -> Bool
forall k a. Hashable k => k -> HashMap k a -> Bool
Map.member Text
t LegendMap
legendMap Bool -> Bool -> Bool
|| Text -> HashSet Text -> Bool
forall a. Hashable a => a -> HashSet a -> Bool
Set.member Text
t HashSet Text
commandSet)

    go :: Word16 -> m Text
    go :: Word16 -> m Text
go Word16
i
      | Word16
i Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
== Word16
mx =
          Text -> m Text
forall (m :: Type -> Type) a.
(HasCallStack, MonadThrow m) =>
Text -> m a
throwText
            (Text -> m Text) -> Text -> m Text
forall a b. (a -> b) -> a -> b
$ [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
              [ Text
Item [Text]
"Found too many ",
                Text
Item [Text]
pfx,
                Text
Item [Text]
"<i> keys in legend. Expected at least one free in range (0, ",
                Word16 -> Text
forall a. Show a => a -> Text
showt Word16
mx,
                Text
Item [Text]
")."
              ]
      | Text -> Bool
unmapped Text
key = Text -> m Text
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Text
key
      | Bool
otherwise = Word16 -> m Text
go (Word16
i Word16 -> Word16 -> Word16
forall a. Num a => a -> a -> a
+ Word16
1)
      where
        key :: Text
key = Text
pfx Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Word16 -> Text
forall a. Show a => a -> Text
showt Word16
i
{-# INLINEABLE findUnmappedKey #-}