{-# LANGUAGE OverloadedLists #-}

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

import Data.Text qualified as T
import Options.Applicative (Parser, ReadM)
import Options.Applicative qualified as OA
import Options.Applicative.Help.Chunk qualified as Chunk
import Options.Applicative.Help.Pretty qualified as Pretty
import Shrun.Configuration.Args.Parsing.Graph.Edges qualified as Edges
import Shrun.Configuration.Args.Parsing.Graph.Sequential qualified as Sequential
import Shrun.Configuration.Args.Parsing.Graph.Utils (MParser)
import Shrun.Configuration.Args.Parsing.Graph.Utils qualified as Utils
import Shrun.Configuration.Args.Parsing.Utils qualified as Utils
import Shrun.Configuration.Data.Graph
  ( EdgeArgs
      ( EdgeArgsList,
        EdgeArgsSequential
      ),
    Edges (MkEdges),
  )
import Shrun.Configuration.Data.WithDisabled (WithDisabled)
import Shrun.Prelude
import Text.Megaparsec qualified as MP

edgesParser :: Parser (Maybe (WithDisabled EdgeArgs))
edgesParser :: Parser (Maybe (WithDisabled EdgeArgs))
edgesParser =
  ReadM EdgeArgs
-> [Mod OptionFields (WithDisabled EdgeArgs)]
-> (Bool, [String])
-> Parser (Maybe (WithDisabled EdgeArgs))
forall a.
ReadM a
-> [Mod OptionFields (WithDisabled a)]
-> (Bool, [String])
-> Parser (Maybe (WithDisabled a))
Utils.mWithDisabledParser
    ReadM EdgeArgs
readEdges
    [Mod OptionFields (WithDisabled EdgeArgs)]
opts
    (Bool
True, [String
Item [String]
"EDGES_STR", String
Item [String]
"&&", String
Item [String]
"||", String
Item [String]
";;"])
  where
    opts :: [Mod OptionFields (WithDisabled EdgeArgs)]
opts =
      [ String -> Mod OptionFields (WithDisabled EdgeArgs)
forall (f :: Type -> Type) a. HasName f => String -> Mod f a
OA.long String
"edges",
        Item [Mod OptionFields (WithDisabled EdgeArgs)]
Mod OptionFields (WithDisabled EdgeArgs)
helpTxt
      ]

    helpTxt :: Mod OptionFields (WithDisabled EdgeArgs)
helpTxt =
      Maybe Doc -> Mod OptionFields (WithDisabled EdgeArgs)
forall (f :: Type -> Type) a. Maybe Doc -> Mod f a
OA.helpDoc
        (Maybe Doc -> Mod OptionFields (WithDisabled EdgeArgs))
-> ([Chunk Doc] -> Maybe Doc)
-> [Chunk Doc]
-> Mod OptionFields (WithDisabled 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
. Chunk Doc -> Maybe Doc
forall a. Chunk a -> Maybe a
Chunk.unChunk
        (Chunk Doc -> Maybe Doc)
-> ([Chunk Doc] -> Chunk Doc) -> [Chunk Doc] -> Maybe Doc
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
. (Doc -> Doc) -> Chunk Doc -> Chunk Doc
forall a b. (a -> b) -> Chunk a -> Chunk b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
forall ann. Doc ann
Pretty.line)
        (Chunk Doc -> Chunk Doc)
-> ([Chunk Doc] -> Chunk Doc) -> [Chunk Doc] -> Chunk Doc
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
. [Chunk Doc] -> Chunk Doc
Chunk.vsepChunks
        ([Chunk Doc] -> Mod OptionFields (WithDisabled EdgeArgs))
-> [Chunk Doc] -> Mod OptionFields (WithDisabled EdgeArgs)
forall a b. (a -> b) -> a -> b
$ [ Item [Chunk Doc]
Chunk Doc
items,
            Item [Chunk Doc]
Chunk Doc
outro
          ]

    items :: Chunk Doc
items =
      NESeq String -> Chunk Doc
Utils.itemizeHelper
        (NESeq String -> Chunk Doc) -> NESeq String -> Chunk Doc
forall a b. (a -> b) -> a -> b
$ String
intro
        String -> Seq String -> NESeq String
forall a. a -> Seq a -> NESeq a
:<|| [ String
Item (Seq String)
andEdges,
               String
Item (Seq String)
orEdges,
               String
Item (Seq String)
anyEdges
             ]

    intro :: String
intro =
      [String] -> String
forall a. Monoid a => [a] -> a
mconcat
        [ String
Item [String]
"Comma-separated list, specifying command dependencies, based on ",
          String
Item [String]
"their left-to-right order. There are three edge types:"
        ]

    andEdges :: String
andEdges = String
"and: '1 & 2', runs cmd2 iff cmd1 succeeds."
    orEdges :: String
orEdges = String
"or: '1 | 2', runs cmd2 iff cmd1 fails."
    anyEdges :: String
anyEdges = String
"any: '1 ; 2', runs cmd2 iff cmd1 finishes."

    outro :: Chunk Doc
outro =
      String -> Chunk Doc
Chunk.paragraph
        (String -> Chunk Doc) -> String -> Chunk Doc
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall a. Monoid a => [a] -> a
mconcat
          [ String
Item [String]
"The literals are equivalent to placing edges between all ",
            String
Item [String]
"commands e.g. '&&' puts an 'and'-edge between all commands."
          ]

readEdges :: ReadM EdgeArgs
readEdges :: ReadM EdgeArgs
readEdges = do
  Text
txt <- ReadM Text
forall s. IsString s => ReadM s
OA.str
  case Text -> Either String EdgeArgs
parseEdges Text
txt of
    Left String
err -> String -> ReadM EdgeArgs
forall a. String -> ReadM a
forall (m :: Type -> Type) a. MonadFail m => String -> m a
fail String
err
    Right EdgeArgs
cga -> EdgeArgs -> ReadM EdgeArgs
forall a. a -> ReadM a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure EdgeArgs
cga

parseEdges :: Text -> Either String EdgeArgs
parseEdges :: Text -> Either String EdgeArgs
parseEdges Text
txt = do
  let stripped :: Text
stripped = Text -> Text
T.stripStart Text
txt
  Bool -> Either String () -> Either String ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (Text -> Bool
T.null Text
stripped) (Either String () -> Either String ())
-> Either String () -> Either String ()
forall a b. (a -> b) -> a -> b
$ do
    String -> Either String ()
forall a b. a -> Either a b
Left (String -> Either String ()) -> String -> Either String ()
forall a b. (a -> b) -> a -> b
$ String
"Received empty input: '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
unpack Text
txt String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'"

  (ParseErrorBundle Text FatalError -> String)
-> Either (ParseErrorBundle Text FatalError) EdgeArgs
-> Either String EdgeArgs
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: Type -> Type -> Type) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ParseErrorBundle Text FatalError -> String
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
MP.errorBundlePretty
    (Either (ParseErrorBundle Text FatalError) EdgeArgs
 -> Either String EdgeArgs)
-> Either (ParseErrorBundle Text FatalError) EdgeArgs
-> Either String EdgeArgs
forall a b. (a -> b) -> a -> b
$ ParsecT FatalError Text Identity EdgeArgs
-> String
-> Text
-> Either (ParseErrorBundle Text FatalError) EdgeArgs
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
MP.parse (ParsecT FatalError Text Identity EdgeArgs
parser ParsecT FatalError Text Identity EdgeArgs
-> ParsecT FatalError Text Identity ()
-> ParsecT FatalError Text Identity EdgeArgs
forall a b.
ParsecT FatalError Text Identity a
-> ParsecT FatalError Text Identity b
-> ParsecT FatalError Text Identity a
forall (f :: Type -> Type) a b. Applicative f => f a -> f b -> f a
<* ParsecT FatalError Text Identity ()
forall e s (m :: Type -> Type). MonadParsec e s m => m ()
MP.eof) String
"" Text
stripped

parser :: MParser EdgeArgs
parser :: ParsecT FatalError Text Identity EdgeArgs
parser = do
  forall (t :: Type -> Type) (f :: Type -> Type) a.
(Foldable t, Alternative f) =>
t (f a) -> f a
asum @List
    [ EdgeSequential -> EdgeArgs
EdgeArgsSequential (EdgeSequential -> EdgeArgs)
-> ParsecT FatalError Text Identity EdgeSequential
-> ParsecT FatalError Text Identity EdgeArgs
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT FatalError Text Identity EdgeSequential
Sequential.parseSequential,
      Edges -> EdgeArgs
EdgeArgsList (Edges -> EdgeArgs)
-> ParsecT FatalError Text Identity Edges
-> ParsecT FatalError Text Identity EdgeArgs
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT FatalError Text Identity Edges
parseMultiEdges
    ]

parseMultiEdges :: MParser Edges
parseMultiEdges :: ParsecT FatalError Text Identity Edges
parseMultiEdges = do
  NESeq Edge
e <- ParsecT FatalError Text Identity (NESeq Edge)
p
  [NESeq Edge]
es <- ParsecT FatalError Text Identity (NESeq Edge)
-> ParsecT FatalError Text Identity [NESeq Edge]
forall (m :: Type -> Type) a. MonadPlus m => m a -> m [a]
MP.many (ParsecT FatalError Text Identity ()
Utils.parseComma ParsecT FatalError Text Identity ()
-> ParsecT FatalError Text Identity (NESeq Edge)
-> ParsecT FatalError Text Identity (NESeq Edge)
forall a b.
ParsecT FatalError Text Identity a
-> ParsecT FatalError Text Identity b
-> ParsecT FatalError Text Identity b
forall (f :: Type -> Type) a b. Applicative f => f a -> f b -> f b
*> ParsecT FatalError Text Identity (NESeq Edge)
p)
  pure $ Seq Edge -> Edges
MkEdges (Seq Edge -> Edges)
-> (NESeq Edge -> Seq Edge) -> NESeq Edge -> 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
. NESeq Edge -> Seq Edge
forall a. NESeq a -> Seq a
neseqToSeq (NESeq Edge -> Edges) -> NESeq Edge -> Edges
forall a b. (a -> b) -> a -> b
$ NonEmpty (NESeq Edge) -> NESeq Edge
forall m. Semigroup m => NonEmpty m -> m
forall (t :: Type -> Type) m.
(Foldable1 t, Semigroup m) =>
t m -> m
fold1 (NESeq Edge
e NESeq Edge -> [NESeq Edge] -> NonEmpty (NESeq Edge)
forall a. a -> [a] -> NonEmpty a
:| [NESeq Edge]
es)
  where
    p :: ParsecT FatalError Text Identity (NESeq Edge)
p = ParsecT FatalError Text Identity (NESeq Edge)
Edges.parseEdges