{-# LANGUAGE OverloadedStrings #-}
-- Copyright 2024 United States Government as represented by the Administrator
-- of the National Aeronautics and Space Administration. All Rights Reserved.
--
-- Disclaimers
--
-- Licensed under the Apache License, Version 2.0 (the "License"); you may
-- not use this file except in compliance with the License. You may obtain a
-- copy of the License at
--
--      https://www.apache.org/licenses/LICENSE-2.0
--
-- Unless required by applicable law or agreed to in writing, software
-- distributed under the License is distributed on an "AS IS" BASIS, WITHOUT
-- WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the
-- License for the specific language governing permissions and limitations
-- under the License.
--
-- | Parsing of diagrams from Mermaid files.
module Data.Diagram.Parser.Mermaid
    ( parseDiagramMermaid
    )
  where

-- External imports
import           Control.Monad              (void, when)
import           Data.ByteString.Lazy       (toStrict)
import qualified Data.ByteString.Lazy       as B
import           Data.Either                (isLeft)
import           Data.Functor.Identity      (Identity)
import qualified Data.Set                   as Set
import           Data.Text                  (Text)
import qualified Data.Text                  as T
import qualified Data.Text.Encoding         as T
import           Data.Void                  (Void)
import           Text.Megaparsec            (ErrorFancy (ErrorFail), ParsecT,
                                             choice, empty, errorBundlePretty,
                                             fancyFailure, many, manyTill,
                                             noneOf, parse, (<|>))
import           Text.Megaparsec.Char       (alphaNumChar, char, digitChar,
                                             newline, space1, string)
import qualified Text.Megaparsec.Char.Lexer as L

-- Internal imports: auxiliary
import Data.Diagram  (Diagram (..))
import Data.ExprPair (ExprPair (..), ExprPairT (..), exprPairShow)

-- | Parse a mermaid diagram.
parseDiagramMermaid :: B.ByteString -> ExprPair -> Either String Diagram
parseDiagramMermaid :: ByteString -> ExprPair -> Either String Diagram
parseDiagramMermaid ByteString
txtDia ExprPair
exprP =
    case Either (ParseErrorBundle Text Void) Diagram
parsingResult of
      Left ParseErrorBundle Text Void
e  -> String -> Either String Diagram
forall a b. a -> Either a b
Left (ParseErrorBundle Text Void -> String
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
errorBundlePretty ParseErrorBundle Text Void
e)
      Right Diagram
x -> Diagram -> Either String Diagram
forall a b. b -> Either a b
Right Diagram
x
  where
    txt :: Text
txt           = ByteString -> Text
T.decodeUtf8 (ByteString -> ByteString
toStrict ByteString
txtDia)
    parsingResult :: Either (ParseErrorBundle Text Void) Diagram
parsingResult = Parsec Void Text Diagram
-> String -> Text -> Either (ParseErrorBundle Text Void) Diagram
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
parse (MermaidParser ()
spaces MermaidParser ()
-> Parsec Void Text Diagram -> Parsec Void Text Diagram
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> ExprPair -> Parsec Void Text Diagram
pDiagram ExprPair
exprP) String
"<input>" Text
txt

-- | Type for parser for memaid diagrams.
type MermaidParser = ParsecT Void Text Identity

-- | Parser for mermaid diagrams.
pDiagram :: ExprPair -> MermaidParser Diagram
pDiagram :: ExprPair -> Parsec Void Text Diagram
pDiagram  ExprPair
exprP =
      ExprPair -> Parsec Void Text Diagram
pGraphDiagram ExprPair
exprP
  Parsec Void Text Diagram
-> Parsec Void Text Diagram -> Parsec Void Text Diagram
forall a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ExprPair -> Parsec Void Text Diagram
pStateDiagram ExprPair
exprP
  Parsec Void Text Diagram
-> Parsec Void Text Diagram -> Parsec Void Text Diagram
forall a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ExprPair -> Parsec Void Text Diagram
pSequenceDiagram ExprPair
exprP

-- | Parser for a mermaid diagram.
--
-- This parser depends on an auxiliary parser for the expressions associated to
-- the edges or connections between states.
pGraphDiagram :: ExprPair -> MermaidParser Diagram
pGraphDiagram :: ExprPair -> Parsec Void Text Diagram
pGraphDiagram ExprPair
exprP = do
  _ <- Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"graph" ParsecT Void Text Identity (Tokens Text)
-> MermaidParser () -> ParsecT Void Text Identity (Tokens Text)
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* MermaidParser ()
spaces
  _name <- T.pack <$> manyTill alphaNumChar (char ';')
  _ <- newline

  transitions <- many (pGraphTransition exprP)

  pure $ Diagram transitions

-- | Parser for an edge in a state diagram.
--
-- This parser depends on an auxiliary parser for the expressions associated to
-- the edges or connections between states.
pGraphTransition :: ExprPair -> MermaidParser (Int, String, Int)
pGraphTransition :: ExprPair -> ParsecT Void Text Identity (Int, String, Int)
pGraphTransition ep :: ExprPair
ep@(ExprPair (ExprPairT { exprTParse :: forall a. ExprPairT a -> String -> Either String a
exprTParse = String -> Either String a
parseProp })) = do
  _ <- MermaidParser ()
spaces
  stateFrom <- many digitChar
  _ <- string "-->|"
  edge <- many (noneOf ("|" :: [Char]))

  let x = String -> Either String a
parseProp String
edge
  when (isLeft x) $ fancyFailure $ Set.singleton $
    ErrorFail $ "Edge property has incorrect format: " ++ show edge

  _ <- char '|'
  stateTo <- many digitChar
  _ <- char ';'
  _ <- newline
  return (read stateFrom, exprPairShow ep edge, read stateTo)

-- | Parser for Mermaid diagrams of type stateDiagram-v2.
pStateDiagram :: ExprPair -> MermaidParser Diagram
pStateDiagram :: ExprPair -> Parsec Void Text Diagram
pStateDiagram ExprPair
exprPair = do
  _ <- Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"stateDiagram-v2" ParsecT Void Text Identity (Tokens Text)
-> MermaidParser () -> ParsecT Void Text Identity (Tokens Text)
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* MermaidParser ()
spaces

  transitions <- many (pStateTransition exprPair)

  pure $ Diagram transitions

-- | Parser for transition label in stateDiagram-v2 mermaid diagram.
pStateTransition :: ExprPair -> MermaidParser (Int, String, Int)
pStateTransition :: ExprPair -> ParsecT Void Text Identity (Int, String, Int)
pStateTransition ep :: ExprPair
ep@(ExprPair (ExprPairT { exprTParse :: forall a. ExprPairT a -> String -> Either String a
exprTParse = String -> Either String a
parseProp })) = do
  _ <- MermaidParser ()
spaces
  from <- read <$> many digitChar
  _ <- spaces
  string "-->"
  _ <- spaces
  to <- read <$> many digitChar
  _ <- spaces
  _ <- char ':'
  _ <- spaces
  edge <- many (noneOf ("\n" :: [Char]))

  let x = String -> Either String a
parseProp String
edge
  when (isLeft x) $ fancyFailure $ Set.singleton $
    ErrorFail $ "Edge property has incorrect format: " ++ show edge

  _ <- newline

  pure $ (from, exprPairShow ep edge, to)

-- | Parser for Mermaid diagrams of type sequenceDiagram.
pSequenceDiagram :: ExprPair -> MermaidParser Diagram
pSequenceDiagram :: ExprPair -> Parsec Void Text Diagram
pSequenceDiagram ExprPair
exprPair = do
  MermaidParser ()
spaces
  _ <- Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"sequenceDiagram"
  spaces

  conditions <- many (pSequenceTransition exprPair)
  let transitions = (String -> Int -> (Int, String, Int))
-> [String] -> [Int] -> [(Int, String, Int)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\String
t Int
idx -> (Int
idx, String
t, Int
idx Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)) [String]
conditions [Int
0..]

  pure $ Diagram transitions

-- | Parser for a connection, message or transition in a sequence diagram.
--
-- This parser depends on an auxiliary parser for the expressions associated to
-- the connections or messages between elements.
pSequenceTransition :: ExprPair -> MermaidParser String
pSequenceTransition :: ExprPair -> ParsecT Void Text Identity String
pSequenceTransition ep :: ExprPair
ep@(ExprPair (ExprPairT { exprTParse :: forall a. ExprPairT a -> String -> Either String a
exprTParse = String -> Either String a
parseProp })) = do
  MermaidParser ()
spaces
  stateFrom <- ParsecT Void Text Identity Char
-> ParsecT Void Text Identity String
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many ParsecT Void Text Identity Char
ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
digitChar
  spaces
  pSequenceArrow
  spaces
  stateTo <- many digitChar
  spaces
  _ <- char ':'
  spaces
  edge <- many (noneOf ("\n" :: [Char]))

  let x = String -> Either String a
parseProp String
edge
  when (isLeft x) $ fancyFailure $ Set.singleton $
    ErrorFail $ "Edge property has incorrect format: " ++ show edge

  _ <- newline

  pure (exprPairShow ep edge)

-- | Parser for arrow in sequence diagram.
pSequenceArrow :: MermaidParser ()
pSequenceArrow :: MermaidParser ()
pSequenceArrow = ParsecT Void Text Identity (Tokens Text) -> MermaidParser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void Text Identity (Tokens Text) -> MermaidParser ())
-> ParsecT Void Text Identity (Tokens Text) -> MermaidParser ()
forall a b. (a -> b) -> a -> b
$ [ParsecT Void Text Identity (Tokens Text)]
-> ParsecT Void Text Identity (Tokens Text)
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Alternative m) =>
f (m a) -> m a
choice
  [ Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"->>"
  , Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"-->>"
  , Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
"-)"
  ]

-- | Consume spaces
spaces :: MermaidParser ()
spaces :: MermaidParser ()
spaces = MermaidParser ()
-> MermaidParser () -> MermaidParser () -> MermaidParser ()
forall e s (m :: * -> *).
MonadParsec e s m =>
m () -> m () -> m () -> m ()
L.space MermaidParser ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
space1 MermaidParser ()
forall a. ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a
empty MermaidParser ()
forall a. ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a
empty