{-# LANGUAGE UndecidableInstances #-}

module Shrun.Configuration.Data.Graph
  ( -- * Args
    EdgeArgs (..),
    Edges (..),
    sortEdges,
    Edge,
    EdgeSequential (..),
    EdgeLabel (..),
    displayEdgeLabel,

    -- * Graph
    CommandGraph (..),
    Vertex,
    LVertex,

    -- ** Creation
    mkGraph,
    mkEdgelessGraph,

    -- ** Functions
    labVertices,
    labVertex,
    labInVertices,
    outVertices,
    vertices,

    -- *** Context
    context,
    ctxLabVertex,
    ctxOutVertices,
  )
where

import Data.Graph.Inductive.Graph (Context, Node)
import Data.Graph.Inductive.Graph qualified as G
import Data.Graph.Inductive.PatriciaTree (Gr)
import Data.Graph.Inductive.Query.Dominators qualified as Dom
import Data.HashMap.Strict qualified as HMap
import Data.HashSet qualified as HSet
import Data.List qualified as L
import Data.Sequence qualified as Seq
import Data.Sequence.NonEmpty qualified as NESeq
import Data.Text qualified as T
import GHC.Exts (IsList (Item))
import GHC.Exts qualified as Exts
import Shrun.Command.Types
  ( CommandIndex,
    CommandOrd (MkCommandOrd),
    CommandP (MkCommandP),
    CommandP1,
    LVertex,
    Vertex,
  )
import Shrun.Command.Types qualified as Command.Types
import Shrun.Configuration.Default (Default (def))
import Shrun.Prelude

-- Note that these 'Edge' types all refer to types that are user-facing i.e.
-- parsed. The internal graph operates an pure Ints intead of our CommandIndex.

-------------------------------------------------------------------------------
--                                User Edges                                 --
-------------------------------------------------------------------------------

-- NOTE: [User Edges]
--
-- These edge types are used at the user-config level i.e. CLI args or
-- toml configuration. Once we parse the edges and commands into a
-- 'CommandGraph', we use more appropriate vertex/edge types.

-- | Types of edges.
data EdgeLabel
  = -- | cmd1 & cmd2 runs cmd2 iff cmd1 succeeds.
    EdgeAnd
  | -- | cmd1 | cmd2 runs cmd2 iff cmd1 fails.
    EdgeOr
  | -- | cmd1 ; cmd2 runs cmd2 iff cmd1 finishes with any status.
    EdgeAny
  deriving stock (EdgeLabel
EdgeLabel -> EdgeLabel -> Bounded EdgeLabel
forall a. a -> a -> Bounded a
$cminBound :: EdgeLabel
minBound :: EdgeLabel
$cmaxBound :: EdgeLabel
maxBound :: EdgeLabel
Bounded, Int -> EdgeLabel
EdgeLabel -> Int
EdgeLabel -> [EdgeLabel]
EdgeLabel -> EdgeLabel
EdgeLabel -> EdgeLabel -> [EdgeLabel]
EdgeLabel -> EdgeLabel -> EdgeLabel -> [EdgeLabel]
(EdgeLabel -> EdgeLabel)
-> (EdgeLabel -> EdgeLabel)
-> (Int -> EdgeLabel)
-> (EdgeLabel -> Int)
-> (EdgeLabel -> [EdgeLabel])
-> (EdgeLabel -> EdgeLabel -> [EdgeLabel])
-> (EdgeLabel -> EdgeLabel -> [EdgeLabel])
-> (EdgeLabel -> EdgeLabel -> EdgeLabel -> [EdgeLabel])
-> Enum EdgeLabel
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: EdgeLabel -> EdgeLabel
succ :: EdgeLabel -> EdgeLabel
$cpred :: EdgeLabel -> EdgeLabel
pred :: EdgeLabel -> EdgeLabel
$ctoEnum :: Int -> EdgeLabel
toEnum :: Int -> EdgeLabel
$cfromEnum :: EdgeLabel -> Int
fromEnum :: EdgeLabel -> Int
$cenumFrom :: EdgeLabel -> [EdgeLabel]
enumFrom :: EdgeLabel -> [EdgeLabel]
$cenumFromThen :: EdgeLabel -> EdgeLabel -> [EdgeLabel]
enumFromThen :: EdgeLabel -> EdgeLabel -> [EdgeLabel]
$cenumFromTo :: EdgeLabel -> EdgeLabel -> [EdgeLabel]
enumFromTo :: EdgeLabel -> EdgeLabel -> [EdgeLabel]
$cenumFromThenTo :: EdgeLabel -> EdgeLabel -> EdgeLabel -> [EdgeLabel]
enumFromThenTo :: EdgeLabel -> EdgeLabel -> EdgeLabel -> [EdgeLabel]
Enum, EdgeLabel -> EdgeLabel -> Bool
(EdgeLabel -> EdgeLabel -> Bool)
-> (EdgeLabel -> EdgeLabel -> Bool) -> Eq EdgeLabel
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: EdgeLabel -> EdgeLabel -> Bool
== :: EdgeLabel -> EdgeLabel -> Bool
$c/= :: EdgeLabel -> EdgeLabel -> Bool
/= :: EdgeLabel -> EdgeLabel -> Bool
Eq, (forall x. EdgeLabel -> Rep EdgeLabel x)
-> (forall x. Rep EdgeLabel x -> EdgeLabel) -> Generic EdgeLabel
forall x. Rep EdgeLabel x -> EdgeLabel
forall x. EdgeLabel -> Rep EdgeLabel x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. EdgeLabel -> Rep EdgeLabel x
from :: forall x. EdgeLabel -> Rep EdgeLabel x
$cto :: forall x. Rep EdgeLabel x -> EdgeLabel
to :: forall x. Rep EdgeLabel x -> EdgeLabel
Generic, Eq EdgeLabel
Eq EdgeLabel =>
(EdgeLabel -> EdgeLabel -> Ordering)
-> (EdgeLabel -> EdgeLabel -> Bool)
-> (EdgeLabel -> EdgeLabel -> Bool)
-> (EdgeLabel -> EdgeLabel -> Bool)
-> (EdgeLabel -> EdgeLabel -> Bool)
-> (EdgeLabel -> EdgeLabel -> EdgeLabel)
-> (EdgeLabel -> EdgeLabel -> EdgeLabel)
-> Ord EdgeLabel
EdgeLabel -> EdgeLabel -> Bool
EdgeLabel -> EdgeLabel -> Ordering
EdgeLabel -> EdgeLabel -> EdgeLabel
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: EdgeLabel -> EdgeLabel -> Ordering
compare :: EdgeLabel -> EdgeLabel -> Ordering
$c< :: EdgeLabel -> EdgeLabel -> Bool
< :: EdgeLabel -> EdgeLabel -> Bool
$c<= :: EdgeLabel -> EdgeLabel -> Bool
<= :: EdgeLabel -> EdgeLabel -> Bool
$c> :: EdgeLabel -> EdgeLabel -> Bool
> :: EdgeLabel -> EdgeLabel -> Bool
$c>= :: EdgeLabel -> EdgeLabel -> Bool
>= :: EdgeLabel -> EdgeLabel -> Bool
$cmax :: EdgeLabel -> EdgeLabel -> EdgeLabel
max :: EdgeLabel -> EdgeLabel -> EdgeLabel
$cmin :: EdgeLabel -> EdgeLabel -> EdgeLabel
min :: EdgeLabel -> EdgeLabel -> EdgeLabel
Ord, Int -> EdgeLabel -> ShowS
[EdgeLabel] -> ShowS
EdgeLabel -> String
(Int -> EdgeLabel -> ShowS)
-> (EdgeLabel -> String)
-> ([EdgeLabel] -> ShowS)
-> Show EdgeLabel
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> EdgeLabel -> ShowS
showsPrec :: Int -> EdgeLabel -> ShowS
$cshow :: EdgeLabel -> String
show :: EdgeLabel -> String
$cshowList :: [EdgeLabel] -> ShowS
showList :: [EdgeLabel] -> ShowS
Show)
  deriving anyclass (Eq EdgeLabel
Eq EdgeLabel =>
(Int -> EdgeLabel -> Int)
-> (EdgeLabel -> Int) -> Hashable EdgeLabel
Int -> EdgeLabel -> Int
EdgeLabel -> Int
forall a. Eq a => (Int -> a -> Int) -> (a -> Int) -> Hashable a
$chashWithSalt :: Int -> EdgeLabel -> Int
hashWithSalt :: Int -> EdgeLabel -> Int
$chash :: EdgeLabel -> Int
hash :: EdgeLabel -> Int
Hashable, EdgeLabel -> ()
(EdgeLabel -> ()) -> NFData EdgeLabel
forall a. (a -> ()) -> NFData a
$crnf :: EdgeLabel -> ()
rnf :: EdgeLabel -> ()
NFData)

instance Pretty EdgeLabel where
  pretty :: forall ann. EdgeLabel -> Doc ann
pretty = EdgeLabel -> Doc ann
forall s. IsString s => EdgeLabel -> s
displayEdgeLabel

displayEdgeLabel :: (IsString s) => EdgeLabel -> s
displayEdgeLabel :: forall s. IsString s => EdgeLabel -> s
displayEdgeLabel = \case
  EdgeLabel
EdgeAnd -> s
"&"
  EdgeLabel
EdgeOr -> s
"|"
  EdgeLabel
EdgeAny -> s
";"

-- | Sequential options.
data EdgeSequential
  = -- | Sequential 'and'-edges.
    EdgeSequentialAnd
  | -- | Sequential 'or'-edges.
    EdgeSequentialOr
  | -- | Sequential 'any'-edges.
    EdgeSequentialAny
  deriving stock (EdgeSequential
EdgeSequential -> EdgeSequential -> Bounded EdgeSequential
forall a. a -> a -> Bounded a
$cminBound :: EdgeSequential
minBound :: EdgeSequential
$cmaxBound :: EdgeSequential
maxBound :: EdgeSequential
Bounded, Int -> EdgeSequential
EdgeSequential -> Int
EdgeSequential -> [EdgeSequential]
EdgeSequential -> EdgeSequential
EdgeSequential -> EdgeSequential -> [EdgeSequential]
EdgeSequential
-> EdgeSequential -> EdgeSequential -> [EdgeSequential]
(EdgeSequential -> EdgeSequential)
-> (EdgeSequential -> EdgeSequential)
-> (Int -> EdgeSequential)
-> (EdgeSequential -> Int)
-> (EdgeSequential -> [EdgeSequential])
-> (EdgeSequential -> EdgeSequential -> [EdgeSequential])
-> (EdgeSequential -> EdgeSequential -> [EdgeSequential])
-> (EdgeSequential
    -> EdgeSequential -> EdgeSequential -> [EdgeSequential])
-> Enum EdgeSequential
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
$csucc :: EdgeSequential -> EdgeSequential
succ :: EdgeSequential -> EdgeSequential
$cpred :: EdgeSequential -> EdgeSequential
pred :: EdgeSequential -> EdgeSequential
$ctoEnum :: Int -> EdgeSequential
toEnum :: Int -> EdgeSequential
$cfromEnum :: EdgeSequential -> Int
fromEnum :: EdgeSequential -> Int
$cenumFrom :: EdgeSequential -> [EdgeSequential]
enumFrom :: EdgeSequential -> [EdgeSequential]
$cenumFromThen :: EdgeSequential -> EdgeSequential -> [EdgeSequential]
enumFromThen :: EdgeSequential -> EdgeSequential -> [EdgeSequential]
$cenumFromTo :: EdgeSequential -> EdgeSequential -> [EdgeSequential]
enumFromTo :: EdgeSequential -> EdgeSequential -> [EdgeSequential]
$cenumFromThenTo :: EdgeSequential
-> EdgeSequential -> EdgeSequential -> [EdgeSequential]
enumFromThenTo :: EdgeSequential
-> EdgeSequential -> EdgeSequential -> [EdgeSequential]
Enum, EdgeSequential -> EdgeSequential -> Bool
(EdgeSequential -> EdgeSequential -> Bool)
-> (EdgeSequential -> EdgeSequential -> Bool) -> Eq EdgeSequential
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: EdgeSequential -> EdgeSequential -> Bool
== :: EdgeSequential -> EdgeSequential -> Bool
$c/= :: EdgeSequential -> EdgeSequential -> Bool
/= :: EdgeSequential -> EdgeSequential -> Bool
Eq, (forall x. EdgeSequential -> Rep EdgeSequential x)
-> (forall x. Rep EdgeSequential x -> EdgeSequential)
-> Generic EdgeSequential
forall x. Rep EdgeSequential x -> EdgeSequential
forall x. EdgeSequential -> Rep EdgeSequential x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. EdgeSequential -> Rep EdgeSequential x
from :: forall x. EdgeSequential -> Rep EdgeSequential x
$cto :: forall x. Rep EdgeSequential x -> EdgeSequential
to :: forall x. Rep EdgeSequential x -> EdgeSequential
Generic, Eq EdgeSequential
Eq EdgeSequential =>
(EdgeSequential -> EdgeSequential -> Ordering)
-> (EdgeSequential -> EdgeSequential -> Bool)
-> (EdgeSequential -> EdgeSequential -> Bool)
-> (EdgeSequential -> EdgeSequential -> Bool)
-> (EdgeSequential -> EdgeSequential -> Bool)
-> (EdgeSequential -> EdgeSequential -> EdgeSequential)
-> (EdgeSequential -> EdgeSequential -> EdgeSequential)
-> Ord EdgeSequential
EdgeSequential -> EdgeSequential -> Bool
EdgeSequential -> EdgeSequential -> Ordering
EdgeSequential -> EdgeSequential -> EdgeSequential
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: EdgeSequential -> EdgeSequential -> Ordering
compare :: EdgeSequential -> EdgeSequential -> Ordering
$c< :: EdgeSequential -> EdgeSequential -> Bool
< :: EdgeSequential -> EdgeSequential -> Bool
$c<= :: EdgeSequential -> EdgeSequential -> Bool
<= :: EdgeSequential -> EdgeSequential -> Bool
$c> :: EdgeSequential -> EdgeSequential -> Bool
> :: EdgeSequential -> EdgeSequential -> Bool
$c>= :: EdgeSequential -> EdgeSequential -> Bool
>= :: EdgeSequential -> EdgeSequential -> Bool
$cmax :: EdgeSequential -> EdgeSequential -> EdgeSequential
max :: EdgeSequential -> EdgeSequential -> EdgeSequential
$cmin :: EdgeSequential -> EdgeSequential -> EdgeSequential
min :: EdgeSequential -> EdgeSequential -> EdgeSequential
Ord, Int -> EdgeSequential -> ShowS
[EdgeSequential] -> ShowS
EdgeSequential -> String
(Int -> EdgeSequential -> ShowS)
-> (EdgeSequential -> String)
-> ([EdgeSequential] -> ShowS)
-> Show EdgeSequential
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> EdgeSequential -> ShowS
showsPrec :: Int -> EdgeSequential -> ShowS
$cshow :: EdgeSequential -> String
show :: EdgeSequential -> String
$cshowList :: [EdgeSequential] -> ShowS
showList :: [EdgeSequential] -> ShowS
Show)
  deriving anyclass (EdgeSequential -> ()
(EdgeSequential -> ()) -> NFData EdgeSequential
forall a. (a -> ()) -> NFData a
$crnf :: EdgeSequential -> ()
rnf :: EdgeSequential -> ()
NFData)

-- | CLI command graph. The default instance is an "edgeless graph", in the
-- sense that all commands are root nodes without any edges, hence normal
-- behavior.
data EdgeArgs
  = -- | Sequential i.e. a linear graph of success edges.
    EdgeArgsSequential EdgeSequential
  | -- | Explicit edges.
    EdgeArgsList Edges
  deriving stock (EdgeArgs -> EdgeArgs -> Bool
(EdgeArgs -> EdgeArgs -> Bool)
-> (EdgeArgs -> EdgeArgs -> Bool) -> Eq EdgeArgs
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: EdgeArgs -> EdgeArgs -> Bool
== :: EdgeArgs -> EdgeArgs -> Bool
$c/= :: EdgeArgs -> EdgeArgs -> Bool
/= :: EdgeArgs -> EdgeArgs -> Bool
Eq, Int -> EdgeArgs -> ShowS
[EdgeArgs] -> ShowS
EdgeArgs -> String
(Int -> EdgeArgs -> ShowS)
-> (EdgeArgs -> String) -> ([EdgeArgs] -> ShowS) -> Show EdgeArgs
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> EdgeArgs -> ShowS
showsPrec :: Int -> EdgeArgs -> ShowS
$cshow :: EdgeArgs -> String
show :: EdgeArgs -> String
$cshowList :: [EdgeArgs] -> ShowS
showList :: [EdgeArgs] -> ShowS
Show)

instance Default EdgeArgs where
  def :: EdgeArgs
def = Edges -> EdgeArgs
EdgeArgsList Edges
forall a. Monoid a => a
mempty

instance IsList EdgeArgs where
  type Item EdgeArgs = Edge

  fromList :: [Item EdgeArgs] -> EdgeArgs
fromList = Edges -> EdgeArgs
EdgeArgsList (Edges -> EdgeArgs) -> ([Edge] -> Edges) -> [Edge] -> EdgeArgs
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
. [Edge] -> Edges
[Item Edges] -> Edges
forall l. IsList l => [Item l] -> l
Exts.fromList

  toList :: EdgeArgs -> [Item EdgeArgs]
toList (EdgeArgsList Edges
xs) = Edges -> [Item Edges]
forall l. IsList l => l -> [Item l]
Exts.toList Edges
xs
  toList (EdgeArgsSequential EdgeSequential
_) = String -> [Edge]
forall a. HasCallStack => String -> a
error String
"Called toList on EdgeArgsSequential"

-- | An edge between two indices.
type Edge = Tuple3 CommandIndex CommandIndex EdgeLabel

edgeToFgl :: Edge -> GEdge
edgeToFgl :: Edge -> GEdge
edgeToFgl (CommandIndex
s, CommandIndex
d, EdgeLabel
l) =
  ( CommandIndex -> Int
toV CommandIndex
s,
    CommandIndex -> Int
toV CommandIndex
d,
    EdgeLabel
l
  )

-- | FGL edge.
type GEdge = Tuple3 Node Node EdgeLabel

-- | Dependency edges are supplied by the user on the CLI.
newtype Edges = MkEdges {Edges -> Seq Edge
unEdges :: Seq Edge}
  deriving newtype (Int -> [Item Edges] -> Edges
[Item Edges] -> Edges
Edges -> [Item Edges]
([Item Edges] -> Edges)
-> (Int -> [Item Edges] -> Edges)
-> (Edges -> [Item Edges])
-> IsList Edges
forall l.
([Item l] -> l)
-> (Int -> [Item l] -> l) -> (l -> [Item l]) -> IsList l
$cfromList :: [Item Edges] -> Edges
fromList :: [Item Edges] -> Edges
$cfromListN :: Int -> [Item Edges] -> Edges
fromListN :: Int -> [Item Edges] -> Edges
$ctoList :: Edges -> [Item Edges]
toList :: Edges -> [Item Edges]
IsList, Semigroup Edges
Edges
Semigroup Edges =>
Edges
-> (Edges -> Edges -> Edges) -> ([Edges] -> Edges) -> Monoid Edges
[Edges] -> Edges
Edges -> Edges -> Edges
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
$cmempty :: Edges
mempty :: Edges
$cmappend :: Edges -> Edges -> Edges
mappend :: Edges -> Edges -> Edges
$cmconcat :: [Edges] -> Edges
mconcat :: [Edges] -> Edges
Monoid, NonEmpty Edges -> Edges
Edges -> Edges -> Edges
(Edges -> Edges -> Edges)
-> (NonEmpty Edges -> Edges)
-> (forall b. Integral b => b -> Edges -> Edges)
-> Semigroup Edges
forall b. Integral b => b -> Edges -> Edges
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
$c<> :: Edges -> Edges -> Edges
<> :: Edges -> Edges -> Edges
$csconcat :: NonEmpty Edges -> Edges
sconcat :: NonEmpty Edges -> Edges
$cstimes :: forall b. Integral b => b -> Edges -> Edges
stimes :: forall b. Integral b => b -> Edges -> Edges
Semigroup)
  deriving stock (Edges -> Edges -> Bool
(Edges -> Edges -> Bool) -> (Edges -> Edges -> Bool) -> Eq Edges
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Edges -> Edges -> Bool
== :: Edges -> Edges -> Bool
$c/= :: Edges -> Edges -> Bool
/= :: Edges -> Edges -> Bool
Eq, Int -> Edges -> ShowS
[Edges] -> ShowS
Edges -> String
(Int -> Edges -> ShowS)
-> (Edges -> String) -> ([Edges] -> ShowS) -> Show Edges
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Edges -> ShowS
showsPrec :: Int -> Edges -> ShowS
$cshow :: Edges -> String
show :: Edges -> String
$cshowList :: [Edges] -> ShowS
showList :: [Edges] -> ShowS
Show)

sortEdges :: Edges -> Edges
sortEdges :: Edges -> Edges
sortEdges =
  Seq Edge -> Edges
MkEdges
    (Seq Edge -> Edges) -> (Edges -> Seq Edge) -> Edges -> 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. Ord a => Seq a -> Seq a
Seq.sort
    (Seq Edge -> Seq Edge) -> (Edges -> Seq Edge) -> Edges -> 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
. Optic' An_Iso NoIx Edges (Seq Edge) -> Edges -> Seq Edge
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' An_Iso NoIx Edges (Seq Edge)
#unEdges

instance
  ( k ~ An_Iso,
    a ~ Seq Edge,
    b ~ Seq Edge
  ) =>
  LabelOptic "unEdges" k Edges Edges a b
  where
  labelOptic :: Optic k NoIx Edges Edges a b
labelOptic = (Edges -> a) -> (b -> Edges) -> Iso Edges Edges a b
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso (\(MkEdges Seq Edge
es) -> a
Seq Edge
es) b -> Edges
Seq Edge -> Edges
MkEdges
  {-# INLINE labelOptic #-}

-------------------------------------------------------------------------------
--                              Command Graph                                --
-------------------------------------------------------------------------------

-- NOTE: [Command Graph]
--
-- 'CommandGraph' is merely fgl's graph type, along with the root vertexes.
-- We want other modules to use the API here rather than depend on fgl's API,
-- hence other modules should use functions/types defined here only.
--
-- Currently, our vertex types are aliases:
--
--   - type Vertex = Int
--   - type LVertex a = Tuple2 Vertex a
--
-- Which happens to match fgl's Node and LNode, respectively. We do this for
-- convenience, though a newtype would be another option.
--
-- We currently do not have any particular type for edges, as our 'edge'
-- functions return source or dest vertices directly.

-- | Command dependency graph. Morally, @Vertex == CommandIndex@.
data CommandGraph = MkCommandGraph
  { -- | Underlying graph.
    CommandGraph -> Gr CommandP1 EdgeLabel
graph :: Gr CommandP1 EdgeLabel,
    -- | Root commands i.e. have no dependencies.
    CommandGraph -> NESeq Int
roots :: NESeq Vertex
  }
  deriving stock (CommandGraph -> CommandGraph -> Bool
(CommandGraph -> CommandGraph -> Bool)
-> (CommandGraph -> CommandGraph -> Bool) -> Eq CommandGraph
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CommandGraph -> CommandGraph -> Bool
== :: CommandGraph -> CommandGraph -> Bool
$c/= :: CommandGraph -> CommandGraph -> Bool
/= :: CommandGraph -> CommandGraph -> Bool
Eq, Int -> CommandGraph -> ShowS
[CommandGraph] -> ShowS
CommandGraph -> String
(Int -> CommandGraph -> ShowS)
-> (CommandGraph -> String)
-> ([CommandGraph] -> ShowS)
-> Show CommandGraph
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CommandGraph -> ShowS
showsPrec :: Int -> CommandGraph -> ShowS
$cshow :: CommandGraph -> String
show :: CommandGraph -> String
$cshowList :: [CommandGraph] -> ShowS
showList :: [CommandGraph] -> ShowS
Show)

instance
  ( k ~ A_Lens,
    a ~ Gr CommandP1 EdgeLabel,
    b ~ Gr CommandP1 EdgeLabel
  ) =>
  LabelOptic "graph" k CommandGraph CommandGraph a b
  where
  labelOptic :: Optic k NoIx CommandGraph CommandGraph a b
labelOptic =
    LensVL CommandGraph CommandGraph a b
-> Lens CommandGraph CommandGraph a b
forall s t a b. LensVL s t a b -> Lens s t a b
lensVL
      (LensVL CommandGraph CommandGraph a b
 -> Lens CommandGraph CommandGraph a b)
-> LensVL CommandGraph CommandGraph a b
-> Lens CommandGraph CommandGraph a b
forall a b. (a -> b) -> a -> b
$ \a -> f b
f (MkCommandGraph Gr CommandP1 EdgeLabel
a1 NESeq Int
a2) ->
        (Gr CommandP1 EdgeLabel -> CommandGraph)
-> f (Gr CommandP1 EdgeLabel) -> f CommandGraph
forall a b. (a -> b) -> f a -> f b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap
          (\Gr CommandP1 EdgeLabel
b -> Gr CommandP1 EdgeLabel -> NESeq Int -> CommandGraph
MkCommandGraph Gr CommandP1 EdgeLabel
b NESeq Int
a2)
          (a -> f b
f a
Gr CommandP1 EdgeLabel
a1)
  {-# INLINE labelOptic #-}

instance
  ( k ~ A_Lens,
    a ~ NESeq Vertex,
    b ~ NESeq Vertex
  ) =>
  LabelOptic "roots" k CommandGraph CommandGraph a b
  where
  labelOptic :: Optic k NoIx CommandGraph CommandGraph a b
labelOptic =
    LensVL CommandGraph CommandGraph a b
-> Lens CommandGraph CommandGraph a b
forall s t a b. LensVL s t a b -> Lens s t a b
lensVL
      (LensVL CommandGraph CommandGraph a b
 -> Lens CommandGraph CommandGraph a b)
-> LensVL CommandGraph CommandGraph a b
-> Lens CommandGraph CommandGraph a b
forall a b. (a -> b) -> a -> b
$ \a -> f b
f (MkCommandGraph Gr CommandP1 EdgeLabel
a1 NESeq Int
a2) ->
        (NESeq Int -> CommandGraph) -> f (NESeq Int) -> f CommandGraph
forall a b. (a -> b) -> f a -> f b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap
          (\NESeq Int
b -> Gr CommandP1 EdgeLabel -> NESeq Int -> CommandGraph
MkCommandGraph Gr CommandP1 EdgeLabel
a1 NESeq Int
b)
          (a -> f b
f a
NESeq Int
a2)
  {-# INLINE labelOptic #-}

instance Pretty CommandGraph where
  pretty :: forall ann. CommandGraph -> Doc ann
pretty CommandGraph
c =
    [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vcat
      [ Doc ann
"graph:",
        Doc ann
prettyGraph,
        Doc ann
"roots: " Doc ann -> Doc ann -> Doc ann
forall a. Semigroup a => a -> a -> a
<> Doc ann
rs
      ]
    where
      rs :: Doc ann
rs = [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
hsep (Doc ann -> [Doc ann] -> [Doc ann]
forall ann. Doc ann -> [Doc ann] -> [Doc ann]
punctuate Doc ann
forall ann. Doc ann
comma ([Doc ann] -> [Doc ann])
-> ([Int] -> [Doc ann]) -> [Int] -> [Doc ann]
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
. (Int -> Doc ann) -> [Int] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> Doc ann
forall ann. Int -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty ([Int] -> [Doc ann]) -> [Int] -> [Doc ann]
forall a b. (a -> b) -> a -> b
$ NESeq Int -> [Int]
forall a. NESeq a -> [a]
forall (t :: Type -> Type) a. Foldable t => t a -> [a]
toList (CommandGraph
c CommandGraph
-> Optic' A_Lens NoIx CommandGraph (NESeq Int) -> NESeq Int
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx CommandGraph (NESeq Int)
#roots))

      prettyGraph :: Doc ann
prettyGraph =
        -- 3. Make the output slightly nicer.
        String -> Doc ann
forall {ann}. String -> Doc ann
massageGraph
          -- 2. Use fgl's prettify to create a String rep.
          (String -> Doc ann)
-> (Gr CommandP1 EdgeLabel -> String)
-> Gr CommandP1 EdgeLabel
-> Doc ann
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
. Gr (Doc (ZonkAny 1)) (Doc (ZonkAny 2)) -> String
forall (gr :: Type -> Type -> Type) a b.
(Graph gr, Show a, Show b) =>
gr a b -> String
G.prettify
          -- 1. Map graph to a less noisy one i.e. remove commands, and
          -- prettyify indices.
          (Gr (Doc (ZonkAny 1)) (Doc (ZonkAny 2)) -> String)
-> (Gr CommandP1 EdgeLabel
    -> Gr (Doc (ZonkAny 1)) (Doc (ZonkAny 2)))
-> Gr CommandP1 EdgeLabel
-> 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 -> Doc (ZonkAny 1))
-> (EdgeLabel -> Doc (ZonkAny 2))
-> Gr CommandP1 EdgeLabel
-> Gr (Doc (ZonkAny 1)) (Doc (ZonkAny 2))
forall a b c d. (a -> b) -> (c -> d) -> Gr a c -> Gr b d
forall (p :: Type -> Type -> Type) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap CommandP1 -> Doc (ZonkAny 1)
forall {b} {ann}. b -> Doc ann
mapCmd EdgeLabel -> Doc (ZonkAny 2)
forall a ann. Pretty a => a -> Doc ann
forall ann. EdgeLabel -> Doc ann
pretty
          (Gr CommandP1 EdgeLabel -> Doc ann)
-> Gr CommandP1 EdgeLabel -> Doc ann
forall a b. (a -> b) -> a -> b
$ CommandGraph
c
          CommandGraph
-> Optic' A_Lens NoIx CommandGraph (Gr CommandP1 EdgeLabel)
-> Gr CommandP1 EdgeLabel
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx CommandGraph (Gr CommandP1 EdgeLabel)
#graph

      -- G.prettify is pretty good, but we want to do some extra processing
      -- e.g. indent and label each line.
      massageGraph :: String -> Doc ann
massageGraph =
        [Doc ann] -> Doc ann
forall ann. [Doc ann] -> Doc ann
vcat
          ([Doc ann] -> Doc ann)
-> (String -> [Doc ann]) -> String -> Doc ann
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 -> Doc ann) -> [Text] -> [Doc ann]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> Doc ann -> Doc ann
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 (Doc ann -> Doc ann) -> (Text -> Doc ann) -> Text -> Doc ann
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 -> Doc ann
forall ann. Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty)
          ([Text] -> [Doc ann]) -> (String -> [Text]) -> String -> [Doc ann]
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]
T.lines
          (Text -> [Text]) -> (String -> Text) -> String -> [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
. String -> Text
pack

      mapCmd :: b -> Doc ann
mapCmd = Doc ann -> b -> Doc ann
forall a b. a -> b -> a
const (forall a ann. Pretty a => a -> Doc ann
pretty @String String
" ")

-- | Creates a command dependency graph from list of dependencies and typed
-- commands.
mkGraph ::
  ( HasCallStack,
    MonadThrow m
  ) =>
  EdgeArgs ->
  NESeq CommandP1 ->
  m CommandGraph
mkGraph :: forall (m :: Type -> Type).
(HasCallStack, MonadThrow m) =>
EdgeArgs -> NESeq CommandP1 -> m CommandGraph
mkGraph EdgeArgs
cdgArgs NESeq CommandP1
cmds = do
  -- Verify edges are unique
  Seq GEdge -> m ()
forall (m :: Type -> Type).
(HasCallStack, MonadThrow m) =>
Seq GEdge -> m ()
verifyUniqueEdges Seq GEdge
edges

  -- Verify all edges exist.
  Seq GEdge -> HashSet Int -> m ()
forall (m :: Type -> Type).
(HasCallStack, MonadThrow m) =>
Seq GEdge -> HashSet Int -> m ()
allEdgesExist Seq GEdge
edges HashSet Int
cmdSet

  -- Find roots.
  let rootMap :: HashMap Int CommandP1
rootMap = HashMap Int CommandP1 -> HashSet Int -> HashMap Int CommandP1
forall k v. Hashable k => HashMap k v -> HashSet k -> HashMap k v
withoutKeys HashMap Int CommandP1
cmdMap HashSet Int
nonRoots

  (NESeq Int
roots, [(Int, CommandP1)]
vs) <- case HashMap Int CommandP1 -> [(Int, CommandP1)]
forall k v. HashMap k v -> [(k, v)]
HMap.toList HashMap Int CommandP1
rootMap of
    [] -> Text -> m (NESeq Int, [(Int, CommandP1)])
forall (m :: Type -> Type) a.
(HasCallStack, MonadThrow m) =>
Text -> m a
throwText Text
"No root command(s) found! There is probably a cycle."
    ((Int, CommandP1)
r : [(Int, CommandP1)]
rs) -> do
      (NESeq Int, [(Int, CommandP1)])
-> m (NESeq Int, [(Int, CommandP1)])
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure
        ( ((Int, CommandP1) -> Int) -> NESeq (Int, CommandP1) -> NESeq Int
forall a b. (a -> b) -> NESeq a -> NESeq b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (Optic' A_Lens NoIx (Int, CommandP1) Int -> (Int, CommandP1) -> Int
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens NoIx (Int, CommandP1) Int
forall s t a b. Field1 s t a b => Lens s t a b
_1) ((Int, CommandP1)
r (Int, CommandP1) -> Seq (Int, CommandP1) -> NESeq (Int, CommandP1)
forall a. a -> Seq a -> NESeq a
:<|| [(Int, CommandP1)] -> Seq (Int, CommandP1)
forall a. [a] -> Seq a
Seq.fromList [(Int, CommandP1)]
rs),
          HashMap Int CommandP1 -> [(Int, CommandP1)]
forall k v. HashMap k v -> [(k, v)]
HMap.toList HashMap Int CommandP1
cmdMap
        )

  let graph :: Gr CommandP1 EdgeLabel
graph = forall (gr :: Type -> Type -> Type) a b.
Graph gr =>
[LNode a] -> [LEdge b] -> gr a b
G.mkGraph @Gr [(Int, CommandP1)]
vs (Seq GEdge -> [GEdge]
forall a. Seq a -> [a]
forall (t :: Type -> Type) a. Foldable t => t a -> [a]
toList Seq GEdge
edges)
      cdg :: CommandGraph
cdg =
        MkCommandGraph
          { Gr CommandP1 EdgeLabel
graph :: Gr CommandP1 EdgeLabel
graph :: Gr CommandP1 EdgeLabel
graph,
            NESeq Int
roots :: NESeq Int
roots :: NESeq Int
roots
          }

  -- Verify all nodes reachable.
  CommandGraph -> HashSet Int -> m ()
forall (m :: Type -> Type).
(HasCallStack, MonadThrow m) =>
CommandGraph -> HashSet Int -> m ()
verifyAllReachable CommandGraph
cdg HashSet Int
cmdSet

  -- Verify no cycles. Note that it is probably impossible to have
  -- no root nodes or unreachable nodes without a cycle, so in some sense
  -- this check subsumes them. The primary caveat is that our cycle detection
  -- involves traversing from the roots, so:
  --
  --   - If we have no roots, then we cannot find any cycles.
  --   - If some nodes are unreachable, then traversing the roots will not
  --     find them, hence not find the cycle.
  --
  -- Therefore all of these checks need to be here. The alternative would be
  -- to check for cycles for every single vertex.
  CommandGraph -> m ()
forall (m :: Type -> Type).
(HasCallStack, MonadThrow m) =>
CommandGraph -> m ()
verifyNoCycles CommandGraph
cdg

  pure CommandGraph
cdg
  where
    edges :: Seq GEdge
edges = case EdgeArgs
cdgArgs of
      EdgeArgsList Edges
es -> Edge -> GEdge
edgeToFgl (Edge -> GEdge) -> Seq Edge -> Seq GEdge
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Edges
es Edges -> Optic' An_Iso NoIx Edges (Seq Edge) -> Seq Edge
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' An_Iso NoIx Edges (Seq Edge)
#unEdges)
      (EdgeArgsSequential EdgeSequential
s) -> EdgeSequential -> NESeq CommandP1 -> Seq GEdge
mkSequentialEdges EdgeSequential
s NESeq CommandP1
cmds

    -- nonRoots is all vertices with an in-edge.
    nonRoots :: HashSet Int

    (HashMap Int [Int]
_, HashSet Int
nonRoots) = ((HashMap Int [Int], HashSet Int)
 -> GEdge -> (HashMap Int [Int], HashSet Int))
-> (HashMap Int [Int], HashSet Int)
-> Seq GEdge
-> (HashMap Int [Int], HashSet Int)
forall b a. (b -> a -> b) -> b -> Seq a -> b
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (HashMap Int [Int], HashSet Int)
-> GEdge -> (HashMap Int [Int], HashSet Int)
mkEdgeMap (HashMap Int [Int]
forall k v. HashMap k v
HMap.empty, HashSet Int
forall a. HashSet a
HSet.empty) Seq GEdge
edges

    mkEdgeMap :: EdgeAcc -> GEdge -> EdgeAcc
    mkEdgeMap :: (HashMap Int [Int], HashSet Int)
-> GEdge -> (HashMap Int [Int], HashSet Int)
mkEdgeMap (HashMap Int [Int]
mp, HashSet Int
nr) (Int
s, Int
d, EdgeLabel
_) = case Int -> HashMap Int [Int] -> Maybe [Int]
forall k v. Hashable k => k -> HashMap k v -> Maybe v
HMap.lookup Int
s HashMap Int [Int]
mp of
      Maybe [Int]
Nothing -> (Int -> [Int] -> HashMap Int [Int] -> HashMap Int [Int]
forall k v. Hashable k => k -> v -> HashMap k v -> HashMap k v
HMap.insert Int
s [Int
d] HashMap Int [Int]
mp, Int -> HashSet Int -> HashSet Int
forall a. Hashable a => a -> HashSet a -> HashSet a
HSet.insert Int
d HashSet Int
nr)
      Just [Int]
es -> (Int -> [Int] -> HashMap Int [Int] -> HashMap Int [Int]
forall k v. Hashable k => k -> v -> HashMap k v -> HashMap k v
HMap.insert Int
s (Int
d Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
es) HashMap Int [Int]
mp, Int -> HashSet Int -> HashSet Int
forall a. Hashable a => a -> HashSet a -> HashSet a
HSet.insert Int
d HashSet Int
nr)

    cmdSet :: HashSet Int
cmdSet = HashMap Int CommandP1 -> HashSet Int
forall k a. HashMap k a -> HashSet k
HMap.keysSet HashMap Int CommandP1
cmdMap
    cmdMap :: HashMap Int CommandP1
cmdMap =
      [(Int, CommandP1)] -> HashMap Int CommandP1
forall k v. Hashable k => [(k, v)] -> HashMap k v
HMap.fromList ((\CommandP1
cmd -> (CommandIndex -> Int
toV (CommandIndex -> Int) -> CommandIndex -> Int
forall a b. (a -> b) -> a -> b
$ CommandP1
cmd CommandP1
-> Optic' A_Lens NoIx CommandP1 CommandIndex -> CommandIndex
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx CommandP1 CommandIndex
#index, CommandP1
cmd)) (CommandP1 -> (Int, CommandP1))
-> [CommandP1] -> [(Int, CommandP1)]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> NESeq CommandP1 -> [CommandP1]
forall a. NESeq a -> [a]
forall (t :: Type -> Type) a. Foldable t => t a -> [a]
toList NESeq CommandP1
cmds)

    withoutKeys :: (Hashable k) => HashMap k v -> HashSet k -> HashMap k v
    withoutKeys :: forall k v. Hashable k => HashMap k v -> HashSet k -> HashMap k v
withoutKeys HashMap k v
m HashSet k
s = HashMap k v
m HashMap k v -> HashMap k (ZonkAny 0 -> ()) -> HashMap k v
forall k v w.
Hashable k =>
HashMap k v -> HashMap k w -> HashMap k v
`HMap.difference` [(k, ZonkAny 0 -> ())] -> HashMap k (ZonkAny 0 -> ())
forall k v. Hashable k => [(k, v)] -> HashMap k v
HMap.fromList ((,() -> ZonkAny 0 -> ()
forall a b. a -> b -> a
const ()) (k -> (k, ZonkAny 0 -> ())) -> [k] -> [(k, ZonkAny 0 -> ())]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> HashSet k -> [k]
forall a. HashSet a -> [a]
HSet.toList HashSet k
s)

-- | Creates a trivial command dep graph where each command is a
-- disconnected vertex, hence root. This exists to avoid the monad in
-- 'mkGraph', as some uses want purity (defaultConfig...).
-- We /should/ have @mkGraph mempty == mkEdgelessGraph@.
mkEdgelessGraph :: NESeq CommandP1 -> CommandGraph
mkEdgelessGraph :: NESeq CommandP1 -> CommandGraph
mkEdgelessGraph NESeq CommandP1
cmds =
  MkCommandGraph
    { Gr CommandP1 EdgeLabel
graph :: Gr CommandP1 EdgeLabel
graph :: Gr CommandP1 EdgeLabel
graph,
      NESeq Int
roots :: NESeq Int
roots :: NESeq Int
roots
    }
  where
    graph :: Gr CommandP1 EdgeLabel
graph = [(Int, CommandP1)] -> [GEdge] -> Gr CommandP1 EdgeLabel
forall a b. [LNode a] -> [LEdge b] -> Gr a b
forall (gr :: Type -> Type -> Type) a b.
Graph gr =>
[LNode a] -> [LEdge b] -> gr a b
G.mkGraph [(Int, CommandP1)]
idxCmds []

    idxCmds :: [(Int, CommandP1)]
idxCmds = [Int] -> [CommandP1] -> [(Int, CommandP1)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
1 ..] (NESeq CommandP1 -> [CommandP1]
forall a. NESeq a -> [a]
forall (t :: Type -> Type) a. Foldable t => t a -> [a]
toList NESeq CommandP1
cmds)

    roots :: NESeq Int
roots = CommandIndex -> Int
toV (CommandIndex -> Int)
-> (CommandP1 -> CommandIndex) -> CommandP1 -> Int
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 CommandP1 CommandIndex
-> CommandP1 -> CommandIndex
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens NoIx CommandP1 CommandIndex
#index (CommandP1 -> Int) -> NESeq CommandP1 -> NESeq Int
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> NESeq CommandP1
cmds

-- | Retrieves all labeled vertices.
labVertices :: CommandGraph -> List (LVertex CommandP1)
labVertices :: CommandGraph -> [(Int, CommandP1)]
labVertices = Gr CommandP1 EdgeLabel -> [(Int, CommandP1)]
forall a b. Gr a b -> [LNode a]
forall (gr :: Type -> Type -> Type) a b.
Graph gr =>
gr a b -> [LNode a]
G.labNodes (Gr CommandP1 EdgeLabel -> [(Int, CommandP1)])
-> (CommandGraph -> Gr CommandP1 EdgeLabel)
-> CommandGraph
-> [(Int, CommandP1)]
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 CommandGraph (Gr CommandP1 EdgeLabel)
-> CommandGraph -> Gr CommandP1 EdgeLabel
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens NoIx CommandGraph (Gr CommandP1 EdgeLabel)
#graph

-- | Finds a labeled vertex. Can fail.
labVertex :: (HasCallStack, MonadEvaluate m) => CommandGraph -> Vertex -> m (LVertex CommandP1)
labVertex :: forall (m :: Type -> Type).
(HasCallStack, MonadEvaluate m) =>
CommandGraph -> Int -> m (Int, CommandP1)
labVertex CommandGraph
cg = (Context CommandP1 EdgeLabel -> (Int, CommandP1))
-> m (Context CommandP1 EdgeLabel) -> m (Int, CommandP1)
forall a b. (a -> b) -> m a -> m b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap Context CommandP1 EdgeLabel -> (Int, CommandP1)
forall a b. Context a b -> LNode a
G.labNode' (m (Context CommandP1 EdgeLabel) -> m (Int, CommandP1))
-> (Int -> m (Context CommandP1 EdgeLabel))
-> Int
-> m (Int, CommandP1)
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
. CommandGraph -> Int -> m (Context CommandP1 EdgeLabel)
forall (m :: Type -> Type).
(HasCallStack, MonadEvaluate m) =>
CommandGraph -> Int -> m (Context CommandP1 EdgeLabel)
context CommandGraph
cg

-- | Retrieves all vertices.
vertices :: CommandGraph -> List Vertex
vertices :: CommandGraph -> [Int]
vertices = Gr CommandP1 EdgeLabel -> [Int]
forall (gr :: Type -> Type -> Type) a b.
Graph gr =>
gr a b -> [Int]
G.nodes (Gr CommandP1 EdgeLabel -> [Int])
-> (CommandGraph -> Gr CommandP1 EdgeLabel)
-> CommandGraph
-> [Int]
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 CommandGraph (Gr CommandP1 EdgeLabel)
-> CommandGraph -> Gr CommandP1 EdgeLabel
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens NoIx CommandGraph (Gr CommandP1 EdgeLabel)
#graph

-- | Given a vertex d, returns all (s, l) s.t. there exists an l-edge
-- s -> d.
labInVertices :: CommandGraph -> Vertex -> List (Tuple2 Vertex EdgeLabel)
labInVertices :: CommandGraph -> Int -> [(Int, EdgeLabel)]
labInVertices = Gr CommandP1 EdgeLabel -> Int -> [(Int, EdgeLabel)]
forall (gr :: Type -> Type -> Type) a b.
Graph gr =>
gr a b -> Int -> [(Int, b)]
G.lpre (Gr CommandP1 EdgeLabel -> Int -> [(Int, EdgeLabel)])
-> (CommandGraph -> Gr CommandP1 EdgeLabel)
-> CommandGraph
-> Int
-> [(Int, EdgeLabel)]
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 CommandGraph (Gr CommandP1 EdgeLabel)
-> CommandGraph -> Gr CommandP1 EdgeLabel
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens NoIx CommandGraph (Gr CommandP1 EdgeLabel)
#graph

-- | Given a vertex s, returns all d s.t. there exists an edge s -> d.
outVertices :: CommandGraph -> Vertex -> List Vertex
outVertices :: CommandGraph -> Int -> [Int]
outVertices CommandGraph
cg = Gr CommandP1 EdgeLabel -> Int -> [Int]
forall (gr :: Type -> Type -> Type) a b.
Graph gr =>
gr a b -> Int -> [Int]
G.suc (CommandGraph
cg CommandGraph
-> Optic' A_Lens NoIx CommandGraph (Gr CommandP1 EdgeLabel)
-> Gr CommandP1 EdgeLabel
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx CommandGraph (Gr CommandP1 EdgeLabel)
#graph)

-- | 'labVertex' that operates on the context.
ctxLabVertex :: Context a b -> LVertex a
ctxLabVertex :: forall a b. Context a b -> LNode a
ctxLabVertex = Context a b -> LNode a
forall a b. Context a b -> LNode a
G.labNode'

-- | 'outVertices' that operates on the context.
ctxOutVertices :: Context a b -> List Vertex
ctxOutVertices :: forall a b. Context a b -> [Int]
ctxOutVertices = Context a b -> [Int]
forall a b. Context a b -> [Int]
G.suc'

-- | Given a vertex, retrieves its context.
context ::
  ( HasCallStack,
    MonadEvaluate m
  ) =>
  CommandGraph ->
  Vertex ->
  m (Context CommandP1 EdgeLabel)
context :: forall (m :: Type -> Type).
(HasCallStack, MonadEvaluate m) =>
CommandGraph -> Int -> m (Context CommandP1 EdgeLabel)
context CommandGraph
cg = Context CommandP1 EdgeLabel -> m (Context CommandP1 EdgeLabel)
forall a. HasCallStack => a -> m a
forall (m :: Type -> Type) a.
(MonadEvaluate m, HasCallStack) =>
a -> m a
evaluate (Context CommandP1 EdgeLabel -> m (Context CommandP1 EdgeLabel))
-> (Int -> Context CommandP1 EdgeLabel)
-> Int
-> m (Context CommandP1 EdgeLabel)
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
. Context CommandP1 EdgeLabel -> Context CommandP1 EdgeLabel
forall a. NFData a => a -> a
force (Context CommandP1 EdgeLabel -> Context CommandP1 EdgeLabel)
-> (Int -> Context CommandP1 EdgeLabel)
-> Int
-> Context CommandP1 EdgeLabel
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
. Gr CommandP1 EdgeLabel -> Int -> Context CommandP1 EdgeLabel
forall (gr :: Type -> Type -> Type) a b.
Graph gr =>
gr a b -> Int -> Context a b
G.context (CommandGraph
cg CommandGraph
-> Optic' A_Lens NoIx CommandGraph (Gr CommandP1 EdgeLabel)
-> Gr CommandP1 EdgeLabel
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx CommandGraph (Gr CommandP1 EdgeLabel)
#graph)

displayCommandIndex :: CommandIndex -> Text
displayCommandIndex :: CommandIndex -> Text
displayCommandIndex = CommandIndex -> Text
forall a. Pretty a => a -> Text
prettyToText

displayVertex :: Node -> Text
displayVertex :: Int -> Text
displayVertex = CommandIndex -> Text
displayCommandIndex (CommandIndex -> Text) -> (Int -> CommandIndex) -> Int -> 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
. HasCallStack => Int -> CommandIndex
Int -> CommandIndex
Command.Types.fromVertex

toV :: CommandIndex -> Node
toV :: CommandIndex -> Int
toV = CommandIndex -> Int
Command.Types.toVertex

-- ((out) Edge Map, Non-roots)
type EdgeAcc =
  Tuple2
    (HashMap Int (List Int))
    (HashSet Int)

verifyUniqueEdges :: (HasCallStack, MonadThrow m) => Seq GEdge -> m ()
verifyUniqueEdges :: forall (m :: Type -> Type).
(HasCallStack, MonadThrow m) =>
Seq GEdge -> m ()
verifyUniqueEdges Seq GEdge
edges = case [(EdgeNoLabel, Seq EdgeLabel)]
duplicates of
  [] -> () -> m ()
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ()
  es :: [(EdgeNoLabel, Seq EdgeLabel)]
es@((EdgeNoLabel, Seq EdgeLabel)
_ : [(EdgeNoLabel, Seq EdgeLabel)]
_) -> do
    let msg :: Text
msg =
          [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
            [ Text
"Found multiple edges between the same commands:",
              [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Text
"\n  - " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text)
-> ((EdgeNoLabel, Seq EdgeLabel) -> Text)
-> (EdgeNoLabel, Seq EdgeLabel)
-> 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
. (EdgeNoLabel, Seq EdgeLabel) -> Text
renderDuplicates ((EdgeNoLabel, Seq EdgeLabel) -> Text)
-> [(EdgeNoLabel, Seq EdgeLabel)] -> [Text]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [(EdgeNoLabel, Seq EdgeLabel)]
es
            ]
    Text -> m ()
forall (m :: Type -> Type) a.
(HasCallStack, MonadThrow m) =>
Text -> m a
throwText Text
msg
  where
    duplicates :: [(EdgeNoLabel, Seq EdgeLabel)]
duplicates =
      -- sort for determinism
      [(EdgeNoLabel, Seq EdgeLabel)] -> [(EdgeNoLabel, Seq EdgeLabel)]
forall a. Ord a => [a] -> [a]
L.sort
        ([(EdgeNoLabel, Seq EdgeLabel)] -> [(EdgeNoLabel, Seq EdgeLabel)])
-> (Seq GEdge -> [(EdgeNoLabel, Seq EdgeLabel)])
-> Seq GEdge
-> [(EdgeNoLabel, Seq EdgeLabel)]
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
. ((EdgeNoLabel, Seq EdgeLabel) -> (EdgeNoLabel, Seq EdgeLabel))
-> [(EdgeNoLabel, Seq EdgeLabel)] -> [(EdgeNoLabel, Seq EdgeLabel)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (\((Int
s, Int
d), Seq EdgeLabel
ls) -> ((Int
s, Int
d), Seq EdgeLabel -> Seq EdgeLabel
forall a. Ord a => Seq a -> Seq a
Seq.sort Seq EdgeLabel
ls))
        ([(EdgeNoLabel, Seq EdgeLabel)] -> [(EdgeNoLabel, Seq EdgeLabel)])
-> (Seq GEdge -> [(EdgeNoLabel, Seq EdgeLabel)])
-> Seq GEdge
-> [(EdgeNoLabel, Seq EdgeLabel)]
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
. HashMap EdgeNoLabel (Seq EdgeLabel)
-> [(EdgeNoLabel, Seq EdgeLabel)]
forall k v. HashMap k v -> [(k, v)]
HMap.toList
        (HashMap EdgeNoLabel (Seq EdgeLabel)
 -> [(EdgeNoLabel, Seq EdgeLabel)])
-> (Seq GEdge -> HashMap EdgeNoLabel (Seq EdgeLabel))
-> Seq GEdge
-> [(EdgeNoLabel, Seq EdgeLabel)]
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 EdgeLabel -> Bool)
-> HashMap EdgeNoLabel (Seq EdgeLabel)
-> HashMap EdgeNoLabel (Seq EdgeLabel)
forall v k. (v -> Bool) -> HashMap k v -> HashMap k v
HMap.filter ((Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1) (Int -> Bool) -> (Seq EdgeLabel -> Int) -> Seq EdgeLabel -> 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
. Seq EdgeLabel -> Int
forall a. Seq a -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length)
        (HashMap EdgeNoLabel (Seq EdgeLabel)
 -> HashMap EdgeNoLabel (Seq EdgeLabel))
-> (Seq GEdge -> HashMap EdgeNoLabel (Seq EdgeLabel))
-> Seq GEdge
-> HashMap EdgeNoLabel (Seq EdgeLabel)
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
. (HashMap EdgeNoLabel (Seq EdgeLabel)
 -> GEdge -> HashMap EdgeNoLabel (Seq EdgeLabel))
-> HashMap EdgeNoLabel (Seq EdgeLabel)
-> Seq GEdge
-> HashMap EdgeNoLabel (Seq EdgeLabel)
forall b a. (b -> a -> b) -> b -> Seq a -> b
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' HashMap EdgeNoLabel (Seq EdgeLabel)
-> GEdge -> HashMap EdgeNoLabel (Seq EdgeLabel)
go HashMap EdgeNoLabel (Seq EdgeLabel)
forall k v. HashMap k v
HMap.empty
        (Seq GEdge -> [(EdgeNoLabel, Seq EdgeLabel)])
-> Seq GEdge -> [(EdgeNoLabel, Seq EdgeLabel)]
forall a b. (a -> b) -> a -> b
$ Seq GEdge
edges

    go :: EdgeDupeAcc -> GEdge -> EdgeDupeAcc
    go :: HashMap EdgeNoLabel (Seq EdgeLabel)
-> GEdge -> HashMap EdgeNoLabel (Seq EdgeLabel)
go HashMap EdgeNoLabel (Seq EdgeLabel)
found (Int
s, Int
d, EdgeLabel
l) = (Maybe (Seq EdgeLabel) -> Maybe (Seq EdgeLabel))
-> EdgeNoLabel
-> HashMap EdgeNoLabel (Seq EdgeLabel)
-> HashMap EdgeNoLabel (Seq EdgeLabel)
forall k v.
Hashable k =>
(Maybe v -> Maybe v) -> k -> HashMap k v -> HashMap k v
HMap.alter Maybe (Seq EdgeLabel) -> Maybe (Seq EdgeLabel)
combineLabels (Int
s, Int
d) HashMap EdgeNoLabel (Seq EdgeLabel)
found
      where
        combineLabels :: Maybe (Seq EdgeLabel) -> Maybe (Seq EdgeLabel)
combineLabels Maybe (Seq EdgeLabel)
Nothing = Seq EdgeLabel -> Maybe (Seq EdgeLabel)
forall a. a -> Maybe a
Just (Seq EdgeLabel -> Maybe (Seq EdgeLabel))
-> Seq EdgeLabel -> Maybe (Seq EdgeLabel)
forall a b. (a -> b) -> a -> b
$ EdgeLabel -> Seq EdgeLabel
forall a. a -> Seq a
Seq.singleton EdgeLabel
l
        combineLabels (Just Seq EdgeLabel
ls) = Seq EdgeLabel -> Maybe (Seq EdgeLabel)
forall a. a -> Maybe a
Just (Seq EdgeLabel -> Maybe (Seq EdgeLabel))
-> Seq EdgeLabel -> Maybe (Seq EdgeLabel)
forall a b. (a -> b) -> a -> b
$ Seq EdgeLabel
ls Seq EdgeLabel -> EdgeLabel -> Seq EdgeLabel
forall a. Seq a -> a -> Seq a
:|> EdgeLabel
l

    renderDuplicates :: Tuple2 (Tuple2 Node Node) (Seq EdgeLabel) -> Text
    renderDuplicates :: (EdgeNoLabel, Seq EdgeLabel) -> Text
renderDuplicates ((Int
s, Int
d), Seq EdgeLabel
ls) =
      Text -> [Text] -> Text
T.intercalate Text
", " ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (\EdgeLabel
l -> GEdge -> Text
renderEdge (Int
s, Int
d, EdgeLabel
l)) (EdgeLabel -> Text) -> [EdgeLabel] -> [Text]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Seq EdgeLabel -> [EdgeLabel]
forall a. Seq a -> [a]
forall (t :: Type -> Type) a. Foldable t => t a -> [a]
toList Seq EdgeLabel
ls

    renderEdge :: (Node, Node, EdgeLabel) -> Text
    renderEdge :: GEdge -> Text
renderEdge (Int
s, Int
d, EdgeLabel
l) =
      [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
        [ Text
"'",
          Int -> Text
forall a. Show a => a -> Text
showt Int
s,
          Text
" ",
          EdgeLabel -> Text
forall s. IsString s => EdgeLabel -> s
displayEdgeLabel EdgeLabel
l,
          Text
" ",
          Int -> Text
forall a. Show a => a -> Text
showt Int
d,
          Text
"'"
        ]

type EdgeNoLabel = Tuple2 Node Node

type EdgeDupeAcc = HashMap EdgeNoLabel (Seq EdgeLabel)

-- | Verifies all commands references in the edges exist.
allEdgesExist :: (HasCallStack, MonadThrow m) => Seq GEdge -> HashSet Int -> m ()
allEdgesExist :: forall (m :: Type -> Type).
(HasCallStack, MonadThrow m) =>
Seq GEdge -> HashSet Int -> m ()
allEdgesExist Seq GEdge
edges HashSet Int
cmds = Seq GEdge -> (GEdge -> m ()) -> m ()
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Seq GEdge
edges ((GEdge -> m ()) -> m ()) -> (GEdge -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \(Int
s, Int
d, EdgeLabel
_) -> do
  if
    | Int
s Int -> HashSet Int -> Bool
forall {a}. Hashable a => a -> HashSet a -> Bool
`notMember` HashSet Int
cmds ->
        Text -> m ()
forall (m :: Type -> Type) a.
(HasCallStack, MonadThrow m) =>
Text -> m a
throwText (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Int -> EdgeNoLabel -> Text
forall {a} {a} {a}. (Show a, Show a, Show a) => a -> (a, a) -> Text
mkErr Int
s (Int
s, Int
d)
    | Int
d Int -> HashSet Int -> Bool
forall {a}. Hashable a => a -> HashSet a -> Bool
`notMember` HashSet Int
cmds ->
        Text -> m ()
forall (m :: Type -> Type) a.
(HasCallStack, MonadThrow m) =>
Text -> m a
throwText (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Int -> EdgeNoLabel -> Text
forall {a} {a} {a}. (Show a, Show a, Show a) => a -> (a, a) -> Text
mkErr Int
d (Int
s, Int
d)
    | Bool
otherwise -> () -> m ()
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ()
  where
    notMember :: a -> HashSet a -> Bool
notMember a
x = Bool -> Bool
not (Bool -> Bool) -> (HashSet a -> Bool) -> HashSet a -> 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
. a -> HashSet a -> Bool
forall {a}. Hashable a => a -> HashSet a -> Bool
HSet.member a
x

    mkErr :: a -> (a, a) -> Text
mkErr a
x (a
s, a
d) =
      [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
        [ Text
"Command index ",
          a -> Text
forall a. Show a => a -> Text
showt a
x,
          Text
" in dependency ",
          a -> Text
forall a. Show a => a -> Text
showt a
s,
          Text
" -> ",
          a -> Text
forall a. Show a => a -> Text
showt a
d,
          Text
" does not exist."
        ]

verifyAllReachable :: (HasCallStack, MonadThrow m) => CommandGraph -> HashSet Int -> m ()
verifyAllReachable :: forall (m :: Type -> Type).
(HasCallStack, MonadThrow m) =>
CommandGraph -> HashSet Int -> m ()
verifyAllReachable CommandGraph
cdg HashSet Int
cmdSet = do
  case HashSet Int -> [Int]
forall a. HashSet a -> [a]
forall (t :: Type -> Type) a. Foldable t => t a -> [a]
toList HashSet Int
nonReachable of
    [] -> () -> m ()
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ()
    xs :: [Int]
xs@(Int
_ : [Int]
_) -> do
      let msg :: Text
msg =
            [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
              [ Text
"The following commands are not reachable: ",
                Text -> [Text] -> Text
T.intercalate Text
", " (Int -> Text
forall a. Show a => a -> Text
showt (Int -> Text) -> [Int] -> [Text]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [Int]
xs),
                Text
". There is probably a cycle."
              ]
      Text -> m ()
forall (m :: Type -> Type) a.
(HasCallStack, MonadThrow m) =>
Text -> m a
throwText Text
msg
  where
    nonReachable :: HashSet Int
nonReachable = HashSet Int -> HashSet Int -> HashSet Int
forall a. Hashable a => HashSet a -> HashSet a -> HashSet a
HSet.difference HashSet Int
cmdSet HashSet Int
reachable
    reachable :: HashSet Int
reachable = CommandGraph -> HashSet Int
reachableFromRoots CommandGraph
cdg

-- Dominators seems to do what we want, but if not we can write this manually.
reachableFromRoots :: CommandGraph -> HashSet Node
reachableFromRoots :: CommandGraph -> HashSet Int
reachableFromRoots CommandGraph
cdg =
  [Int] -> HashSet Int
forall a. Hashable a => [a] -> HashSet a
HSet.fromList
    ([Int] -> HashSet Int)
-> (NESeq Int -> [Int]) -> NESeq Int -> HashSet Int
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
. ((Int, [Int]) -> Int) -> [(Int, [Int])] -> [Int]
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 (Int, [Int]) Int -> (Int, [Int]) -> Int
forall k (is :: IxList) s a.
Is k A_Getter =>
Optic' k is s a -> s -> a
view Optic' A_Lens NoIx (Int, [Int]) Int
forall s t a b. Field1 s t a b => Lens s t a b
_1)
    ([(Int, [Int])] -> [Int])
-> (NESeq Int -> [(Int, [Int])]) -> NESeq Int -> [Int]
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
. (Gr CommandP1 EdgeLabel -> Int -> [(Int, [Int])]
forall (gr :: Type -> Type -> Type) a b.
Graph gr =>
gr a b -> Int -> [(Int, [Int])]
Dom.dom Gr CommandP1 EdgeLabel
graph (Int -> [(Int, [Int])])
-> (NESeq Int -> [Int]) -> NESeq Int -> [(Int, [Int])]
forall (m :: Type -> Type) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< NESeq Int -> [Int]
forall a. NESeq a -> [a]
forall (t :: Type -> Type) a. Foldable t => t a -> [a]
toList)
    (NESeq Int -> HashSet Int) -> NESeq Int -> HashSet Int
forall a b. (a -> b) -> a -> b
$ CommandGraph
cdg
    CommandGraph
-> Optic' A_Lens NoIx CommandGraph (NESeq Int) -> NESeq Int
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx CommandGraph (NESeq Int)
#roots
  where
    graph :: Gr CommandP1 EdgeLabel
graph = CommandGraph
cdg CommandGraph
-> Optic' A_Lens NoIx CommandGraph (Gr CommandP1 EdgeLabel)
-> Gr CommandP1 EdgeLabel
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx CommandGraph (Gr CommandP1 EdgeLabel)
#graph

-- | Verifies that no cycles exist.
verifyNoCycles :: (HasCallStack, MonadThrow m) => CommandGraph -> m ()
verifyNoCycles :: forall (m :: Type -> Type).
(HasCallStack, MonadThrow m) =>
CommandGraph -> m ()
verifyNoCycles CommandGraph
cdg = (Int -> m ()) -> NESeq Int -> m ()
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (CommandGraph -> Int -> m ()
forall (m :: Type -> Type).
(HasCallStack, MonadThrow m) =>
CommandGraph -> Int -> m ()
traverseVertex CommandGraph
cdg) (CommandGraph
cdg CommandGraph
-> Optic' A_Lens NoIx CommandGraph (NESeq Int) -> NESeq Int
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx CommandGraph (NESeq Int)
#roots)

traverseVertex :: forall m. (HasCallStack, MonadThrow m) => CommandGraph -> Node -> m ()
traverseVertex :: forall (m :: Type -> Type).
(HasCallStack, MonadThrow m) =>
CommandGraph -> Int -> m ()
traverseVertex CommandGraph
cdg = CycleAcc -> Int -> m ()
go (HashSet Int
forall a. HashSet a
HSet.empty, [])
  where
    fromV :: Node -> List Node
    fromV :: Int -> [Int]
fromV = Gr CommandP1 EdgeLabel -> Int -> [Int]
forall (gr :: Type -> Type -> Type) a b.
Graph gr =>
gr a b -> Int -> [Int]
G.suc (CommandGraph
cdg CommandGraph
-> Optic' A_Lens NoIx CommandGraph (Gr CommandP1 EdgeLabel)
-> Gr CommandP1 EdgeLabel
forall k s (is :: IxList) a.
Is k A_Getter =>
s -> Optic' k is s a -> a
^. Optic' A_Lens NoIx CommandGraph (Gr CommandP1 EdgeLabel)
#graph)

    go :: CycleAcc -> Node -> m ()
    go :: CycleAcc -> Int -> m ()
go (HashSet Int
foundVs, [Int]
path) Int
v = do
      if Int -> HashSet Int -> Bool
forall {a}. Hashable a => a -> HashSet a -> Bool
HSet.member Int
v HashSet Int
foundVs
        then do
          let msg :: Text
msg =
                [Text] -> Text
forall a. Monoid a => [a] -> a
mconcat
                  [ Text
"Found command cycle: ",
                    [Int] -> Text
renderPath ([Int] -> [Int]
forall a. [a] -> [a]
L.reverse ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ Int
v Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
path)
                  ]
          Text -> m ()
forall (m :: Type -> Type) a.
(HasCallStack, MonadThrow m) =>
Text -> m a
throwText Text
msg
        else do
          let es :: [Int]
es = Int -> [Int]
fromV Int
v
          (Int -> m ()) -> [Int] -> m ()
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (CycleAcc -> Int -> m ()
go (Int -> HashSet Int -> HashSet Int
forall a. Hashable a => a -> HashSet a -> HashSet a
HSet.insert Int
v HashSet Int
foundVs, Int
v Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [Int]
path)) [Int]
es

    renderPath :: [Int] -> Text
renderPath = Text -> [Text] -> Text
T.intercalate Text
" -> " ([Text] -> Text) -> ([Int] -> [Text]) -> [Int] -> 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
. (Int -> Text) -> [Int] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap Int -> Text
displayVertex

type CycleAcc = (HashSet Node, [Node])

mkSequentialEdges :: EdgeSequential -> NESeq CommandP1 -> Seq GEdge
mkSequentialEdges :: EdgeSequential -> NESeq CommandP1 -> Seq GEdge
mkSequentialEdges EdgeSequential
eseq =
  Seq GEdge -> Seq GEdge
forall {a}. Seq a -> Seq a
dropLast
    (Seq GEdge -> Seq GEdge)
-> (NESeq CommandP1 -> Seq GEdge) -> NESeq CommandP1 -> Seq GEdge
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 -> GEdge) -> Seq CommandP1 -> Seq GEdge
forall a b. (a -> b) -> Seq a -> Seq b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap CommandP1 -> GEdge
toEdge
    (Seq CommandP1 -> Seq GEdge)
-> (NESeq CommandP1 -> Seq CommandP1)
-> NESeq CommandP1
-> Seq GEdge
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 -> CommandOrd 'CommandPhase1)
-> Seq CommandP1 -> Seq CommandP1
forall b a. Ord b => (a -> b) -> Seq a -> Seq a
Seq.sortOn CommandP1 -> CommandOrd 'CommandPhase1
forall (p :: CommandPhase). CommandP p -> CommandOrd p
MkCommandOrd
    (Seq CommandP1 -> Seq CommandP1)
-> (NESeq CommandP1 -> Seq CommandP1)
-> NESeq CommandP1
-> Seq CommandP1
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 CommandP1 -> Seq CommandP1
forall a. NESeq a -> Seq a
NESeq.toSeq
  where
    toEdge :: CommandP1 -> GEdge
toEdge (MkCommandP CommandIndex
idx Maybe Text
_ Text
_) =
      ( CommandIndex -> Int
toV CommandIndex
idx,
        CommandIndex -> Int
toV (CommandIndex -> Int) -> CommandIndex -> Int
forall a b. (a -> b) -> a -> b
$ CommandIndex -> CommandIndex
Command.Types.succ CommandIndex
idx,
        EdgeLabel
label
      )

    label :: EdgeLabel
label = 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