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

module Shrun.Configuration.Args.Parsing.Graph.Edges
  ( parseEdges,
  )
where

import Data.Sequence.NonEmpty qualified as NESeq
import Shrun.Command.Types qualified as Cmd.T
import Shrun.Command.Types.Internal (CommandIndex)
import Shrun.Configuration.Args.Parsing.Graph.Utils (MParser)
import Shrun.Configuration.Args.Parsing.Graph.Utils qualified as Utils
import Shrun.Configuration.Data.Graph
  ( Edge,
    EdgeLabel (EdgeAnd, EdgeAny, EdgeOr),
  )
import Shrun.Configuration.Data.Graph qualified as Graph
import Shrun.Prelude
import Text.Megaparsec qualified as MP

-- | Parses at least one edge, stops if any commas are found. We return
-- NESeq rather than Edges as the former allows us to be more precise that
-- at least one edge is required for a successful parse.
--
-- After we are done parsing all edges, we can combine them.
parseEdges :: MParser (NESeq Edge)
parseEdges :: MParser (NESeq Edge)
parseEdges = String -> MParser (NESeq Edge) -> MParser (NESeq Edge)
forall a.
String
-> ParsecT FatalError Text Identity a
-> ParsecT FatalError Text Identity a
forall e s (m :: Type -> Type) a.
MonadParsec e s m =>
String -> m a -> m a
MP.label String
label (MParser (NESeq Edge) -> MParser (NESeq Edge))
-> MParser (NESeq Edge) -> MParser (NESeq Edge)
forall a b. (a -> b) -> a -> b
$ do
  String
-> ParsecT FatalError Text Identity ()
-> ParsecT FatalError Text Identity ()
forall a.
String -> MParser a -> ParsecT FatalError Text Identity ()
Utils.failIfNext String
edgeErr ParsecT FatalError Text Identity ()
parseEdgeDest
  MParser CommandIndex -> MParser (Maybe CommandIndex)
forall a. MParser a -> MParser (Maybe a)
Utils.optionalTry MParser CommandIndex
Utils.parseOneIndex MParser (Maybe CommandIndex)
-> (Maybe CommandIndex -> MParser (NESeq Edge))
-> MParser (NESeq Edge)
forall a b.
ParsecT FatalError Text Identity a
-> (a -> ParsecT FatalError Text Identity b)
-> ParsecT FatalError Text Identity b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just CommandIndex
s -> CommandIndex -> MParser (NESeq Edge)
parseEdgeIndex CommandIndex
s
    Maybe CommandIndex
Nothing -> MParser (NESeq CommandIndex)
Utils.parseIndexSet MParser (NESeq CommandIndex)
-> (NESeq CommandIndex -> MParser (NESeq Edge))
-> MParser (NESeq Edge)
forall a b.
ParsecT FatalError Text Identity a
-> (a -> ParsecT FatalError Text Identity b)
-> ParsecT FatalError Text Identity b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= NESeq CommandIndex -> MParser (NESeq Edge)
parseEdgeIndexSet
  where
    label :: String
label = String
"comma-delimited edge(s) (e.g. \"1 & 2, {3,4} ; 1, 4 &.. 6\")"

    edgeErr :: String
edgeErr = String -> String -> String
Utils.mkMpError String
"label" String
vertexLabel

    -- Improving the error message for e.g. '& 3' specifically, as this is
    -- probably an intended edge (not a literal e.g. '&&'). We only want to
    -- use this error when we have a correct edge and dest, otherwise fall
    -- back to general error message.
    parseEdgeDest :: ParsecT FatalError Text Identity ()
parseEdgeDest = ParsecT FatalError Text Identity ()
-> ParsecT FatalError Text Identity ()
forall a.
ParsecT FatalError Text Identity a
-> ParsecT FatalError Text Identity a
forall e s (m :: Type -> Type) a. MonadParsec e s m => m a -> m a
MP.try (ParsecT FatalError Text Identity ()
 -> ParsecT FatalError Text Identity ())
-> ParsecT FatalError Text Identity ()
-> ParsecT FatalError Text Identity ()
forall a b. (a -> b) -> a -> b
$ do
      ParsecT FatalError Text Identity EdgeLabel
-> ParsecT FatalError Text Identity ()
forall (f :: Type -> Type) a. Functor f => f a -> f ()
void ParsecT FatalError Text Identity EdgeLabel
parseEdgeLabel
      MParser CommandIndex -> ParsecT FatalError Text Identity ()
forall (f :: Type -> Type) a. Functor f => f a -> f ()
void MParser CommandIndex
Utils.parseOneIndex ParsecT FatalError Text Identity ()
-> ParsecT FatalError Text Identity ()
-> ParsecT FatalError Text Identity ()
forall a.
ParsecT FatalError Text Identity a
-> ParsecT FatalError Text Identity a
-> ParsecT FatalError Text Identity a
forall (f :: Type -> Type) a. Alternative f => f a -> f a -> f a
<|> MParser (NESeq CommandIndex) -> ParsecT FatalError Text Identity ()
forall (f :: Type -> Type) a. Functor f => f a -> f ()
void MParser (NESeq CommandIndex)
Utils.parseIndexSet

-- NOTE: [Commas]
--
-- Edges are delimited by commas e.g. '1 & 2, 2 & 3'. Hence if we see a comma
-- we want to stop (without consuming them!). We use the 'parseIfNoComma'
-- function to guard our parsers s.t. they do not run if they parse a comma.
--
-- The lone exception to this is the /first vertex/ i.e. we want to guarantee
-- at least one successful parse, hence a comma should be a failure.
--
-- To that end, we split our parsers X into a normal variant (called first)
-- and an 'XComma' variant that stops if a comma is found. This allows us
-- to guarantee that if the parser succeeds, we have found at least one
-- value (hence non-empty type).

parseEdgeIndexComma :: CommandIndex -> MParser (Seq Edge)
parseEdgeIndexComma :: CommandIndex -> MParser (Seq Edge)
parseEdgeIndexComma = Seq Edge -> MParser (Seq Edge) -> MParser (Seq Edge)
forall a. a -> MParser a -> MParser a
Utils.parseIfNoComma [] (MParser (Seq Edge) -> MParser (Seq Edge))
-> (CommandIndex -> MParser (Seq Edge))
-> CommandIndex
-> MParser (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 Edge -> Seq Edge)
-> MParser (NESeq Edge) -> MParser (Seq Edge)
forall a b.
(a -> b)
-> ParsecT FatalError Text Identity a
-> ParsecT FatalError Text Identity b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap NESeq Edge -> Seq Edge
forall a. NESeq a -> Seq a
neseqToSeq (MParser (NESeq Edge) -> MParser (Seq Edge))
-> (CommandIndex -> MParser (NESeq Edge))
-> CommandIndex
-> MParser (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 -> MParser (NESeq Edge)
parseEdgeIndex

parseEdgeIndex :: CommandIndex -> MParser (NESeq Edge)
parseEdgeIndex :: CommandIndex -> MParser (NESeq Edge)
parseEdgeIndex CommandIndex
s = do
  -- Try dots for a better error message.
  String
-> ParsecT FatalError Text Identity ()
-> ParsecT FatalError Text Identity ()
forall a.
String -> MParser a -> ParsecT FatalError Text Identity ()
Utils.failIfNext String
err ParsecT FatalError Text Identity ()
Utils.parseDots

  EdgeLabel
lbl <- ParsecT FatalError Text Identity EdgeLabel
parseEdgeLabel
  ParsecT FatalError Text Identity ()
-> ParsecT FatalError Text Identity (Maybe ())
forall (f :: Type -> Type) a. Alternative f => f a -> f (Maybe a)
MP.optional ParsecT FatalError Text Identity ()
Utils.parseDots ParsecT FatalError Text Identity (Maybe ())
-> (Maybe () -> MParser (NESeq Edge)) -> MParser (NESeq Edge)
forall a b.
ParsecT FatalError Text Identity a
-> (a -> ParsecT FatalError Text Identity b)
-> ParsecT FatalError Text Identity b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just () -> EdgeLabel -> CommandIndex -> MParser (NESeq Edge)
parseEdgeDots EdgeLabel
lbl CommandIndex
s
    Maybe ()
Nothing -> EdgeLabel -> NESeq CommandIndex -> MParser (NESeq Edge)
parseEdgeNoDots EdgeLabel
lbl (CommandIndex -> NESeq CommandIndex
forall a. a -> NESeq a
NESeq.singleton CommandIndex
s)
  where
    err :: String
err = String
"Expected a label, found '..'. Perhaps you wanted an edge range (e.g. '&..')?"

parseEdgeIndexSetComma :: NESeq CommandIndex -> MParser (Seq Edge)
parseEdgeIndexSetComma :: NESeq CommandIndex -> MParser (Seq Edge)
parseEdgeIndexSetComma = Seq Edge -> MParser (Seq Edge) -> MParser (Seq Edge)
forall a. a -> MParser a -> MParser a
Utils.parseIfNoComma [] (MParser (Seq Edge) -> MParser (Seq Edge))
-> (NESeq CommandIndex -> MParser (Seq Edge))
-> NESeq CommandIndex
-> MParser (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 Edge -> Seq Edge)
-> MParser (NESeq Edge) -> MParser (Seq Edge)
forall a b.
(a -> b)
-> ParsecT FatalError Text Identity a
-> ParsecT FatalError Text Identity b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap NESeq Edge -> Seq Edge
forall a. NESeq a -> Seq a
neseqToSeq (MParser (NESeq Edge) -> MParser (Seq Edge))
-> (NESeq CommandIndex -> MParser (NESeq Edge))
-> NESeq CommandIndex
-> MParser (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 -> MParser (NESeq Edge)
parseEdgeIndexSet

parseEdgeIndexSet :: NESeq CommandIndex -> MParser (NESeq Edge)
parseEdgeIndexSet :: NESeq CommandIndex -> MParser (NESeq Edge)
parseEdgeIndexSet NESeq CommandIndex
idxs = do
  EdgeLabel
lbl <- ParsecT FatalError Text Identity EdgeLabel
parseEdgeLabel

  -- Try dots for a better error message.
  String
-> ParsecT FatalError Text Identity ()
-> ParsecT FatalError Text Identity ()
forall a.
String -> MParser a -> ParsecT FatalError Text Identity ()
Utils.failIfNext (EdgeLabel -> String
dotsSetErr EdgeLabel
lbl) ParsecT FatalError Text Identity ()
Utils.parseDots

  EdgeLabel -> NESeq CommandIndex -> MParser (NESeq Edge)
parseEdgeNoDots EdgeLabel
lbl NESeq CommandIndex
idxs

parseEdgeDots :: EdgeLabel -> CommandIndex -> MParser (NESeq Edge)
parseEdgeDots :: EdgeLabel -> CommandIndex -> MParser (NESeq Edge)
parseEdgeDots EdgeLabel
lbl CommandIndex
s = String -> MParser (NESeq Edge) -> MParser (NESeq Edge)
forall a.
String
-> ParsecT FatalError Text Identity a
-> ParsecT FatalError Text Identity a
forall e s (m :: Type -> Type) a.
MonadParsec e s m =>
String -> m a -> m a
MP.label String
label (MParser (NESeq Edge) -> MParser (NESeq Edge))
-> MParser (NESeq Edge) -> MParser (NESeq Edge)
forall a b. (a -> b) -> a -> b
$ do
  -- Try set for a better error message.
  String
-> MParser (NESeq CommandIndex)
-> ParsecT FatalError Text Identity ()
forall a.
String -> MParser a -> ParsecT FatalError Text Identity ()
Utils.failIfNext (EdgeLabel -> String
dotsSetErr EdgeLabel
lbl) MParser (NESeq CommandIndex)
Utils.parseIndexSet

  CommandIndex
d <- MParser CommandIndex
Utils.parseOneIndex
  (CommandIndex
r1, CommandIndex
r2 :<|| Seq CommandIndex
rs) <- case CommandIndex
-> CommandIndex -> Either String (CommandIndex, NESeq CommandIndex)
Cmd.T.range CommandIndex
s CommandIndex
d of
    Right (CommandIndex, NESeq CommandIndex)
r -> (CommandIndex, NESeq CommandIndex)
-> ParsecT
     FatalError Text Identity (CommandIndex, NESeq CommandIndex)
forall a. a -> ParsecT FatalError Text Identity a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (CommandIndex, NESeq CommandIndex)
r
    Left String
err -> String
-> ParsecT
     FatalError Text Identity (CommandIndex, NESeq CommandIndex)
forall a. String -> ParsecT FatalError Text Identity a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail String
err

  let edges :: NESeq Edge
edges@(Edge
e1 :<|| Seq Edge
es) = Seq CommandIndex -> NESeq Edge -> NESeq Edge
go (CommandIndex
r2 CommandIndex -> Seq CommandIndex -> Seq CommandIndex
forall a. a -> Seq a -> Seq a
:<| Seq CommandIndex
rs) (Edge -> NESeq Edge
forall a. a -> NESeq a
NESeq.singleton (CommandIndex
r1, CommandIndex
r2, EdgeLabel
lbl))
      go :: Seq CommandIndex -> NESeq Edge -> NESeq Edge
go Seq CommandIndex
Empty NESeq Edge
acc = NESeq Edge
acc
      go (CommandIndex
_ :<| Seq CommandIndex
Empty) NESeq Edge
acc = NESeq Edge
acc
      go (CommandIndex
x1 :<| CommandIndex
x2 :<| Seq CommandIndex
xs) NESeq Edge
acc = Seq CommandIndex -> NESeq Edge -> NESeq Edge
go (CommandIndex
x2 CommandIndex -> Seq CommandIndex -> Seq CommandIndex
forall a. a -> Seq a -> Seq a
:<| Seq CommandIndex
xs) (NESeq Edge
acc NESeq Edge -> Edge -> NESeq Edge
forall a. NESeq a -> a -> NESeq a
NESeq.|> (CommandIndex
x1, CommandIndex
x2, EdgeLabel
lbl))

  MParser Bool
Utils.anyLeft MParser Bool
-> (Bool -> MParser (NESeq Edge)) -> MParser (NESeq Edge)
forall a b.
ParsecT FatalError Text Identity a
-> (a -> ParsecT FatalError Text Identity b)
-> ParsecT FatalError Text Identity b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Bool
False -> NESeq Edge -> MParser (NESeq Edge)
forall a. a -> ParsecT FatalError Text Identity a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure NESeq Edge
edges
    Bool
True -> (\Seq Edge
ds -> Edge
e1 Edge -> Seq Edge -> NESeq Edge
forall a. a -> Seq a -> NESeq a
:<|| Seq Edge
es Seq Edge -> Seq Edge -> Seq Edge
forall a. Semigroup a => a -> a -> a
<> Seq Edge
ds) (Seq Edge -> NESeq Edge)
-> MParser (Seq Edge) -> MParser (NESeq Edge)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> CommandIndex -> MParser (Seq Edge)
parseEdgeIndexComma CommandIndex
d
  where
    label :: String
label = String
"a single vertex (e.g. '3')"

dotsSetErr :: EdgeLabel -> String
dotsSetErr :: EdgeLabel -> String
dotsSetErr EdgeLabel
lbl =
  [String] -> String
forall a. Monoid a => [a] -> a
mconcat
    [ String
Item [String]
"Edge ranges (e.g. '",
      EdgeLabel -> String
forall s. IsString s => EdgeLabel -> s
Graph.displayEdgeLabel EdgeLabel
lbl,
      String
Item [String]
"..') are not allowed with set syntax."
    ]

parseEdgeNoDots :: EdgeLabel -> NESeq CommandIndex -> MParser (NESeq Edge)
parseEdgeNoDots :: EdgeLabel -> NESeq CommandIndex -> MParser (NESeq Edge)
parseEdgeNoDots EdgeLabel
lbl NESeq CommandIndex
srcs = String -> MParser (NESeq Edge) -> MParser (NESeq Edge)
forall a.
String
-> ParsecT FatalError Text Identity a
-> ParsecT FatalError Text Identity a
forall e s (m :: Type -> Type) a.
MonadParsec e s m =>
String -> m a -> m a
MP.label String
vertexLabel (MParser (NESeq Edge) -> MParser (NESeq Edge))
-> MParser (NESeq Edge) -> MParser (NESeq Edge)
forall a b. (a -> b) -> a -> b
$ do
  Maybe CommandIndex
mD <- MParser CommandIndex -> MParser (Maybe CommandIndex)
forall a. MParser a -> MParser (Maybe a)
Utils.optionalTry MParser CommandIndex
Utils.parseOneIndex
  (edges :: NESeq Edge
edges@(Edge
e1 :<|| Seq Edge
es), MParser (Seq Edge)
parseMore) <- case Maybe CommandIndex
mD of
    Just CommandIndex
d -> do
      let edges :: NESeq Edge
edges = [(CommandIndex
s, CommandIndex
d, EdgeLabel
lbl) | CommandIndex
s <- NESeq CommandIndex
srcs]
      (NESeq Edge, MParser (Seq Edge))
-> ParsecT
     FatalError Text Identity (NESeq Edge, MParser (Seq Edge))
forall a. a -> ParsecT FatalError Text Identity a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (NESeq Edge
edges, CommandIndex -> MParser (Seq Edge)
parseEdgeIndexComma CommandIndex
d)
    Maybe CommandIndex
Nothing -> do
      NESeq CommandIndex
dests <- MParser (NESeq CommandIndex)
Utils.parseIndexSet
      let edges :: NESeq Edge
edges =
            [ (CommandIndex
s, CommandIndex
d, EdgeLabel
lbl)
            | CommandIndex
s <- NESeq CommandIndex
srcs,
              CommandIndex
d <- NESeq CommandIndex
dests
            ]
      (NESeq Edge, MParser (Seq Edge))
-> ParsecT
     FatalError Text Identity (NESeq Edge, MParser (Seq Edge))
forall a. a -> ParsecT FatalError Text Identity a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (NESeq Edge
edges, NESeq CommandIndex -> MParser (Seq Edge)
parseEdgeIndexSetComma NESeq CommandIndex
dests)

  MParser Bool
Utils.anyLeft MParser Bool
-> (Bool -> MParser (NESeq Edge)) -> MParser (NESeq Edge)
forall a b.
ParsecT FatalError Text Identity a
-> (a -> ParsecT FatalError Text Identity b)
-> ParsecT FatalError Text Identity b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Bool
False -> NESeq Edge -> MParser (NESeq Edge)
forall a. a -> ParsecT FatalError Text Identity a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure NESeq Edge
edges
    Bool
True -> (\Seq Edge
ds -> Edge
e1 Edge -> Seq Edge -> NESeq Edge
forall a. a -> Seq a -> NESeq a
:<|| Seq Edge
es Seq Edge -> Seq Edge -> Seq Edge
forall a. Semigroup a => a -> a -> a
<> Seq Edge
ds) (Seq Edge -> NESeq Edge)
-> MParser (Seq Edge) -> MParser (NESeq Edge)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> MParser (Seq Edge)
parseMore

vertexLabel :: String
vertexLabel :: String
vertexLabel = String
"a vertex (e.g. '3', '{1,5}')"

parseEdgeLabel :: MParser EdgeLabel
parseEdgeLabel :: ParsecT FatalError Text Identity EdgeLabel
parseEdgeLabel = String
-> ParsecT FatalError Text Identity EdgeLabel
-> ParsecT FatalError Text Identity EdgeLabel
forall a.
String
-> ParsecT FatalError Text Identity a
-> ParsecT FatalError Text Identity a
forall e s (m :: Type -> Type) a.
MonadParsec e s m =>
String -> m a -> m a
MP.label String
label (ParsecT FatalError Text Identity EdgeLabel
 -> ParsecT FatalError Text Identity EdgeLabel)
-> ParsecT FatalError Text Identity EdgeLabel
-> ParsecT FatalError Text Identity EdgeLabel
forall a b. (a -> b) -> a -> b
$ do
  forall (t :: Type -> Type) (f :: Type -> Type) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum @List
    [ EdgeLabel
EdgeAnd EdgeLabel
-> ParsecT FatalError Text Identity Text
-> ParsecT FatalError Text Identity EdgeLabel
forall a b.
a
-> ParsecT FatalError Text Identity b
-> ParsecT FatalError Text Identity a
forall (f :: Type -> Type) a b. Functor f => a -> f b -> f a
<$ Text -> ParsecT FatalError Text Identity Text
Utils.string Text
"&",
      EdgeLabel
EdgeOr EdgeLabel
-> ParsecT FatalError Text Identity Text
-> ParsecT FatalError Text Identity EdgeLabel
forall a b.
a
-> ParsecT FatalError Text Identity b
-> ParsecT FatalError Text Identity a
forall (f :: Type -> Type) a b. Functor f => a -> f b -> f a
<$ Text -> ParsecT FatalError Text Identity Text
Utils.string Text
"|",
      EdgeLabel
EdgeAny EdgeLabel
-> ParsecT FatalError Text Identity Text
-> ParsecT FatalError Text Identity EdgeLabel
forall a b.
a
-> ParsecT FatalError Text Identity b
-> ParsecT FatalError Text Identity a
forall (f :: Type -> Type) a b. Functor f => a -> f b -> f a
<$ Text -> ParsecT FatalError Text Identity Text
Utils.string Text
";"
    ]
  where
    label :: String
label = String
"a label ('&', '|', ';')"