module Modelling.ActivityDiagram.Auxiliary.Parser (
  ParseValue(..),
  parseMappingSequence
) where

import qualified Data.Map as M (fromList)

import Control.Applicative (Alternative((<|>)))
import Data.Char (isControl, isSpace)
import Data.Maybe (catMaybes)
import Data.Map (Map)
import Modelling.Auxiliary.Common (parseInt)
import Text.Parsec.String (Parser)
import Text.Parsec(
  endOfLine,
  satisfy,
  skipMany,
  sepEndBy,
  sepBy,
  choice,
  many1,
  char,
  letter,
  digit,
  between
  )

data ParseValue =
  ParseInt Int |
  ParseString String |
  ParseTuple (ParseValue, ParseValue) |
  ParseList [ParseValue]
  deriving (ParseValue -> ParseValue -> Bool
(ParseValue -> ParseValue -> Bool)
-> (ParseValue -> ParseValue -> Bool) -> Eq ParseValue
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ParseValue -> ParseValue -> Bool
== :: ParseValue -> ParseValue -> Bool
$c/= :: ParseValue -> ParseValue -> Bool
/= :: ParseValue -> ParseValue -> Bool
Eq, Int -> ParseValue -> ShowS
[ParseValue] -> ShowS
ParseValue -> String
(Int -> ParseValue -> ShowS)
-> (ParseValue -> String)
-> ([ParseValue] -> ShowS)
-> Show ParseValue
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ParseValue -> ShowS
showsPrec :: Int -> ParseValue -> ShowS
$cshow :: ParseValue -> String
show :: ParseValue -> String
$cshowList :: [ParseValue] -> ShowS
showList :: [ParseValue] -> ShowS
Show)

parseMappingSequence :: Parser (Map String ParseValue)
parseMappingSequence :: Parser (Map String ParseValue)
parseMappingSequence = [(String, ParseValue)] -> Map String ParseValue
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList ([(String, ParseValue)] -> Map String ParseValue)
-> ([Maybe (String, ParseValue)] -> [(String, ParseValue)])
-> [Maybe (String, ParseValue)]
-> Map String ParseValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe (String, ParseValue)] -> [(String, ParseValue)]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (String, ParseValue)] -> Map String ParseValue)
-> ParsecT String () Identity [Maybe (String, ParseValue)]
-> Parser (Map String ParseValue)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Parser (Maybe (String, ParseValue))
parseMapping Parser (Maybe (String, ParseValue))
-> ParsecT String () Identity Char
-> ParsecT String () Identity [Maybe (String, ParseValue)]
forall s (m :: * -> *) t u a sep.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]
`sepEndBy` ParsecT String () Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
endOfLine)

parseMapping :: Parser (Maybe (String, ParseValue))
parseMapping :: Parser (Maybe (String, ParseValue))
parseMapping = Parser ()
skipSpaceChars Parser ()
-> Parser (Maybe (String, ParseValue))
-> Parser (Maybe (String, ParseValue))
forall a b.
ParsecT String () Identity a
-> ParsecT String () Identity b -> ParsecT String () Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser (Maybe (String, ParseValue))
text
  where
    parseLine :: ParsecT String () Identity (String, ParseValue)
parseLine = (,) (String -> ParseValue -> (String, ParseValue))
-> ParsecT String () Identity String
-> ParsecT String () Identity (ParseValue -> (String, ParseValue))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ParsecT String () Identity String
parseString ParsecT String () Identity String
-> Parser () -> ParsecT String () Identity String
forall a b.
ParsecT String () Identity a
-> ParsecT String () Identity b -> ParsecT String () Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
skipSpaceChars ParsecT String () Identity String
-> ParsecT String () Identity Char
-> ParsecT String () Identity String
forall a b.
ParsecT String () Identity a
-> ParsecT String () Identity b -> ParsecT String () Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
':' ParsecT String () Identity String
-> Parser () -> ParsecT String () Identity String
forall a b.
ParsecT String () Identity a
-> ParsecT String () Identity b -> ParsecT String () Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
skipSpaceChars) ParsecT String () Identity (ParseValue -> (String, ParseValue))
-> ParsecT String () Identity ParseValue
-> ParsecT String () Identity (String, ParseValue)
forall a b.
ParsecT String () Identity (a -> b)
-> ParsecT String () Identity a -> ParsecT String () Identity b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ParsecT String () Identity ParseValue
parseValue
    emptyLine :: Parser ()
emptyLine = Parser ()
skipSpaceChars
    text :: Parser (Maybe (String, ParseValue))
text = ((String, ParseValue) -> Maybe (String, ParseValue)
forall a. a -> Maybe a
Just ((String, ParseValue) -> Maybe (String, ParseValue))
-> ParsecT String () Identity (String, ParseValue)
-> Parser (Maybe (String, ParseValue))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT String () Identity (String, ParseValue)
parseLine) Parser (Maybe (String, ParseValue))
-> Parser (Maybe (String, ParseValue))
-> Parser (Maybe (String, ParseValue))
forall a.
ParsecT String () Identity a
-> ParsecT String () Identity a -> ParsecT String () Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Maybe (String, ParseValue)
forall a. Maybe a
Nothing Maybe (String, ParseValue)
-> Parser () -> Parser (Maybe (String, ParseValue))
forall a b.
a -> ParsecT String () Identity b -> ParsecT String () Identity a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Parser ()
emptyLine)

parseValue :: Parser ParseValue
parseValue :: ParsecT String () Identity ParseValue
parseValue = ParsecT String () Identity ParseValue
value ParsecT String () Identity ParseValue
-> Parser () -> ParsecT String () Identity ParseValue
forall a b.
ParsecT String () Identity a
-> ParsecT String () Identity b -> ParsecT String () Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
skipSpaceChars
  where value :: ParsecT String () Identity ParseValue
value = [ParsecT String () Identity ParseValue]
-> ParsecT String () Identity ParseValue
forall s (m :: * -> *) t u a.
Stream s m t =>
[ParsecT s u m a] -> ParsecT s u m a
choice [ [ParseValue] -> ParseValue
ParseList ([ParseValue] -> ParseValue)
-> ParsecT String () Identity [ParseValue]
-> ParsecT String () Identity ParseValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT String () Identity [ParseValue]
parseList
                        ,(ParseValue, ParseValue) -> ParseValue
ParseTuple ((ParseValue, ParseValue) -> ParseValue)
-> ParsecT String () Identity (ParseValue, ParseValue)
-> ParsecT String () Identity ParseValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT String () Identity (ParseValue, ParseValue)
parseTuple
                        ,Int -> ParseValue
ParseInt (Int -> ParseValue)
-> ParsecT String () Identity Int
-> ParsecT String () Identity ParseValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT String () Identity Int
parseInt
                        ,String -> ParseValue
ParseString (String -> ParseValue)
-> ParsecT String () Identity String
-> ParsecT String () Identity ParseValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParsecT String () Identity String
parseString
                        ]

parseString :: Parser String
parseString :: ParsecT String () Identity String
parseString =
  ParsecT String () Identity Char
-> ParsecT String () Identity Char
-> ParsecT String () Identity String
-> ParsecT String () Identity String
forall s (m :: * -> *) t u open close a.
Stream s m t =>
ParsecT s u m open
-> ParsecT s u m close -> ParsecT s u m a -> ParsecT s u m a
between (Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'"') (Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'"') ParsecT String () Identity String
forall {u}. ParsecT String u Identity String
parseAlphaNum ParsecT String () Identity String
-> ParsecT String () Identity String
-> ParsecT String () Identity String
forall a.
ParsecT String () Identity a
-> ParsecT String () Identity a -> ParsecT String () Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
  ParsecT String () Identity String
forall {u}. ParsecT String u Identity String
parseAlphaNum
  where
    parseAlphaNum :: ParsecT String u Identity String
parseAlphaNum = ParsecT String u Identity Char -> ParsecT String u Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (ParsecT String u Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
letter ParsecT String u Identity Char
-> ParsecT String u Identity Char -> ParsecT String u Identity Char
forall a.
ParsecT String u Identity a
-> ParsecT String u Identity a -> ParsecT String u Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT String u Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit)

parseTuple :: Parser (ParseValue, ParseValue)
parseTuple :: ParsecT String () Identity (ParseValue, ParseValue)
parseTuple = ParsecT String () Identity Char
-> ParsecT String () Identity Char
-> ParsecT String () Identity (ParseValue, ParseValue)
-> ParsecT String () Identity (ParseValue, ParseValue)
forall s (m :: * -> *) t u open close a.
Stream s m t =>
ParsecT s u m open
-> ParsecT s u m close -> ParsecT s u m a -> ParsecT s u m a
between (Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'(' ParsecT String () Identity Char
-> Parser () -> ParsecT String () Identity Char
forall a b.
ParsecT String () Identity a
-> ParsecT String () Identity b -> ParsecT String () Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
skipSpaceChars) (Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
')')
  (ParsecT String () Identity (ParseValue, ParseValue)
 -> ParsecT String () Identity (ParseValue, ParseValue))
-> ParsecT String () Identity (ParseValue, ParseValue)
-> ParsecT String () Identity (ParseValue, ParseValue)
forall a b. (a -> b) -> a -> b
$ do ParseValue
x <- ParsecT String () Identity ParseValue
parseValue ParsecT String () Identity ParseValue
-> ParsecT String () Identity Char
-> ParsecT String () Identity ParseValue
forall a b.
ParsecT String () Identity a
-> ParsecT String () Identity b -> ParsecT String () Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
',' ParsecT String () Identity ParseValue
-> Parser () -> ParsecT String () Identity ParseValue
forall a b.
ParsecT String () Identity a
-> ParsecT String () Identity b -> ParsecT String () Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
skipSpaceChars
       ParseValue
y <- ParsecT String () Identity ParseValue
parseValue
       (ParseValue, ParseValue)
-> ParsecT String () Identity (ParseValue, ParseValue)
forall a. a -> ParsecT String () Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (ParseValue
x,ParseValue
y)

parseList :: Parser [ParseValue]
parseList :: ParsecT String () Identity [ParseValue]
parseList = ParsecT String () Identity Char
-> ParsecT String () Identity Char
-> ParsecT String () Identity [ParseValue]
-> ParsecT String () Identity [ParseValue]
forall s (m :: * -> *) t u open close a.
Stream s m t =>
ParsecT s u m open
-> ParsecT s u m close -> ParsecT s u m a -> ParsecT s u m a
between (Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'[' ParsecT String () Identity Char
-> Parser () -> ParsecT String () Identity Char
forall a b.
ParsecT String () Identity a
-> ParsecT String () Identity b -> ParsecT String () Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
skipSpaceChars) (Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
']')
  (ParsecT String () Identity [ParseValue]
 -> ParsecT String () Identity [ParseValue])
-> ParsecT String () Identity [ParseValue]
-> ParsecT String () Identity [ParseValue]
forall a b. (a -> b) -> a -> b
$ (ParsecT String () Identity ParseValue
parseValue ParsecT String () Identity ParseValue
-> Parser () -> ParsecT String () Identity ParseValue
forall a b.
ParsecT String () Identity a
-> ParsecT String () Identity b -> ParsecT String () Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
skipSpaceChars) ParsecT String () Identity ParseValue
-> ParsecT String () Identity Char
-> ParsecT String () Identity [ParseValue]
forall s (m :: * -> *) t u a sep.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]
`sepBy` (Char -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
',' ParsecT String () Identity Char
-> Parser () -> ParsecT String () Identity Char
forall a b.
ParsecT String () Identity a
-> ParsecT String () Identity b -> ParsecT String () Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
skipSpaceChars)

skipSpaceChars :: Parser ()
skipSpaceChars :: Parser ()
skipSpaceChars = ParsecT String () Identity Char -> Parser ()
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m ()
skipMany (ParsecT String () Identity Char -> Parser ())
-> ParsecT String () Identity Char -> Parser ()
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ParsecT String () Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
(Char -> Bool) -> ParsecT s u m Char
satisfy (\Char
c -> Char -> Bool
isSpace Char
c Bool -> Bool -> Bool
&& Bool -> Bool
not (Char -> Bool
isControl Char
c))