{-# LANGUAGE OverloadedStrings #-}

-- |This module provides types for parsing 'Tms' Turing machines.
module TmsParser (parser, parseTms, pTms) where

import Text.Megaparsec hiding (empty)
import Text.Megaparsec.Char
import Text.Megaparsec.Byte (string)
import Text.Megaparsec.Error (errorBundlePretty)
import Data.Text (Text)
import Control.Monad (guard, void)

import qualified Data.Set as Set

import TmsType
import ParsingHelpers

-- | Empty space.
empty :: Parser ()
empty :: Parser ()
empty = ParsecT Void Text Identity [Char] -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void Text Identity [Char] -> Parser ())
-> ParsecT Void Text Identity [Char] -> Parser ()
forall a b. (a -> b) -> a -> b
$ ParsecT Void Text Identity Char
-> ParsecT Void Text Identity [Char]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many ParsecT Void Text Identity Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
separatorChar

-- | Token.
tok :: Parser a -> Parser a
tok :: Parser a -> Parser a
tok Parser a
p = do
    Parser ()
empty
    a
v <- Parser a
p
    Parser ()
empty
    a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return a
v

-- | Identifier.
pIdentifier :: Parser String
pIdentifier :: ParsecT Void Text Identity [Char]
pIdentifier =
    ParsecT Void Text Identity [Char]
-> ParsecT Void Text Identity [Char]
forall a. Parser a -> Parser a
tok ParsecT Void Text Identity [Char]
pLetters
    where
        pLetters :: ParsecT Void Text Identity [Char]
pLetters = do
            Char
first <- ParsecT Void Text Identity Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
letterChar
            [Char]
rest <- ParsecT Void Text Identity Char
-> ParsecT Void Text Identity [Char]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many ParsecT Void Text Identity Char
pChar
            [Char] -> ParsecT Void Text Identity [Char]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char] -> ParsecT Void Text Identity [Char])
-> [Char] -> ParsecT Void Text Identity [Char]
forall a b. (a -> b) -> a -> b
$ Char
first Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char]
rest

-- | Comma.
comma :: Parser ()
comma :: Parser ()
comma = do
    ParsecT Void Text Identity Char -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void Text Identity Char -> Parser ())
-> ParsecT Void Text Identity Char -> Parser ()
forall a b. (a -> b) -> a -> b
$ ParsecT Void Text Identity Char -> ParsecT Void Text Identity Char
forall a. Parser a -> Parser a
tok (ParsecT Void Text Identity Char
 -> ParsecT Void Text Identity Char)
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
forall a b. (a -> b) -> a -> b
$ Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
','

-- | Pair '<key>: <value>\n'.
pKeyValue :: Tokens Text -> Parser a -> Parser a
pKeyValue :: Tokens Text -> Parser a -> Parser a
pKeyValue Tokens Text
key Parser a
value = do
    ParsecT Void Text Identity Text -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void Text Identity Text -> Parser ())
-> ParsecT Void Text Identity Text -> Parser ()
forall a b. (a -> b) -> a -> b
$ Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
string Tokens Text
key
    ParsecT Void Text Identity Char -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void Text Identity Char -> Parser ())
-> ParsecT Void Text Identity Char -> Parser ()
forall a b. (a -> b) -> a -> b
$ ParsecT Void Text Identity Char -> ParsecT Void Text Identity Char
forall a. Parser a -> Parser a
tok (ParsecT Void Text Identity Char
 -> ParsecT Void Text Identity Char)
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
forall a b. (a -> b) -> a -> b
$ Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
':'
    a
x <- Parser a
value
    ParsecT Void Text Identity [Char] -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void Text Identity [Char] -> Parser ())
-> ParsecT Void Text Identity [Char] -> Parser ()
forall a b. (a -> b) -> a -> b
$ ParsecT Void Text Identity [Char]
-> ParsecT Void Text Identity [Char]
forall a. Parser a -> Parser a
tok (ParsecT Void Text Identity [Char]
 -> ParsecT Void Text Identity [Char])
-> ParsecT Void Text Identity [Char]
-> ParsecT Void Text Identity [Char]
forall a b. (a -> b) -> a -> b
$ ParsecT Void Text Identity Char
-> ParsecT Void Text Identity [Char]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many ParsecT Void Text Identity Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
newline
    a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x

-- | TmsTapeHeadMovement
pMove :: Parser Char
pMove :: ParsecT Void Text Identity Char
pMove = Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'<' ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'-' ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'>'

mvChar2TmsHeadMove :: Char -> Maybe TmsTapeHeadMovement
mvChar2TmsHeadMove :: Char -> Maybe TmsTapeHeadMovement
mvChar2TmsHeadMove Char
c = case Char
c of
    Char
'<' -> TmsTapeHeadMovement -> Maybe TmsTapeHeadMovement
forall (m :: * -> *) a. Monad m => a -> m a
return TmsTapeHeadMovement
MoveLeft
    Char
'>' -> TmsTapeHeadMovement -> Maybe TmsTapeHeadMovement
forall (m :: * -> *) a. Monad m => a -> m a
return TmsTapeHeadMovement
MoveRight
    Char
'-' -> TmsTapeHeadMovement -> Maybe TmsTapeHeadMovement
forall (m :: * -> *) a. Monad m => a -> m a
return TmsTapeHeadMovement
Stay
    Char
_   -> Maybe TmsTapeHeadMovement
forall a. Maybe a
Nothing

-- | Tape symbol.
pChar :: Parser Char
pChar :: ParsecT Void Text Identity Char
pChar = ParsecT Void Text Identity Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
alphaNumChar ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
char Char
Token Text
'_'

-- | Tms Command.
pCommand :: Parser (TmsCommand, Int)
pCommand :: Parser (TmsCommand, Int)
pCommand = do
    [Char]
iniSt <- ParsecT Void Text Identity [Char]
pIdentifier
    Parser ()
comma
    [Char]
iniChars <- ParsecT Void Text Identity Char
pChar ParsecT Void Text Identity Char
-> Parser () -> ParsecT Void Text Identity [Char]
forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
`sepBy1` Parser ()
comma
    let len :: Int
len = [Char] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
iniChars
    ParsecT Void Text Identity [Char] -> Parser ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (ParsecT Void Text Identity [Char] -> Parser ())
-> ParsecT Void Text Identity [Char] -> Parser ()
forall a b. (a -> b) -> a -> b
$ ParsecT Void Text Identity Char
-> ParsecT Void Text Identity [Char]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
many ParsecT Void Text Identity Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
newline
    [Char]
finSt <- ParsecT Void Text Identity [Char]
pIdentifier
    Parser ()
comma
    [Char]
finCharsMoves <- (ParsecT Void Text Identity Char
pChar ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
-> ParsecT Void Text Identity Char
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT Void Text Identity Char
pMove) ParsecT Void Text Identity Char
-> Parser () -> ParsecT Void Text Identity [Char]
forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
`sepBy1` Parser ()
comma
    Bool -> Parser ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Parser ()) -> Bool -> Parser ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
finCharsMoves Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
len Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
2
    let ([Char]
finChars, [Char]
moveChars) = Int -> [Char] -> ([Char], [Char])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
len [Char]
finCharsMoves
    [TmsTapeHeadMovement]
moves <- case (Char -> Maybe TmsTapeHeadMovement)
-> [Char] -> Maybe [TmsTapeHeadMovement]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Char -> Maybe TmsTapeHeadMovement
mvChar2TmsHeadMove [Char]
moveChars of
        Just [TmsTapeHeadMovement]
m  -> [TmsTapeHeadMovement]
-> ParsecT Void Text Identity [TmsTapeHeadMovement]
forall (m :: * -> *) a. Monad m => a -> m a
return [TmsTapeHeadMovement]
m
        Maybe [TmsTapeHeadMovement]
Nothing -> [Char] -> ParsecT Void Text Identity [TmsTapeHeadMovement]
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Non move character found."
    (TmsCommand, Int) -> Parser (TmsCommand, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return ((TmsState, [TmsSingleTapeCommand], TmsState) -> TmsCommand
TmsCommand ([Char] -> TmsState
TmsState [Char]
iniSt, (Char -> Char -> TmsTapeHeadMovement -> TmsSingleTapeCommand)
-> [Char]
-> [Char]
-> [TmsTapeHeadMovement]
-> [TmsSingleTapeCommand]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 Char -> Char -> TmsTapeHeadMovement -> TmsSingleTapeCommand
makeSTC [Char]
iniChars [Char]
finChars [TmsTapeHeadMovement]
moves, [Char] -> TmsState
TmsState [Char]
finSt), Int
len)
    where
        makeSTC :: Char -> Char -> TmsTapeHeadMovement -> TmsSingleTapeCommand
        makeSTC :: Char -> Char -> TmsTapeHeadMovement -> TmsSingleTapeCommand
makeSTC Char
f Char
t TmsTapeHeadMovement
m = (TmsTapeSquare, TmsTapeHeadMovement) -> TmsSingleTapeCommand
TmsSingleTapeCommand (Char -> Char -> TmsTapeSquare
ChangeFromTo Char
f Char
t, TmsTapeHeadMovement
m)

-- | Extract command tape alphabets.
commandAlphabet :: TmsCommand -> [String]
commandAlphabet :: TmsCommand -> [[Char]]
commandAlphabet (TmsCommand (TmsState
_, [TmsSingleTapeCommand]
cmds, TmsState
_)) = TmsSingleTapeCommand -> [Char]
tapeCmdAlphabet (TmsSingleTapeCommand -> [Char])
-> [TmsSingleTapeCommand] -> [[Char]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TmsSingleTapeCommand]
cmds
    where
        tapeCmdAlphabet :: TmsSingleTapeCommand -> String
        tapeCmdAlphabet :: TmsSingleTapeCommand -> [Char]
tapeCmdAlphabet (TmsSingleTapeCommand (ChangeFromTo Char
f Char
t, TmsTapeHeadMovement
_)) = [Char
f, Char
t]
        tapeCmdAlphabet TmsSingleTapeCommand
_                                            = [Char]
forall a. Monoid a => a
mempty

-- | Get alphabets of all commands.
alphabet :: [TmsCommand] -> [String]
alphabet :: [TmsCommand] -> [[Char]]
alphabet [TmsCommand]
tmsCommands = ((Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'_') ([Char] -> [Char]) -> (Set Char -> [Char]) -> Set Char -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Char -> [Char]
forall a. Set a -> [a]
Set.toList) (Set Char -> [Char]) -> ([Char] -> Set Char) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Set Char
forall a. Ord a => [a] -> Set a
Set.fromList ([Char] -> [Char]) -> [[Char]] -> [[Char]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
    ([[Char]] -> [[Char]] -> [[Char]]) -> [[[Char]]] -> [[Char]]
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 (\[[Char]]
x [[Char]]
y -> ([Char] -> [Char] -> [Char]) -> ([Char], [Char]) -> [Char]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
(++) (([Char], [Char]) -> [Char]) -> [([Char], [Char])] -> [[Char]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[Char]] -> [[Char]] -> [([Char], [Char])]
forall a b. [a] -> [b] -> [(a, b)]
zip [[Char]]
x [[Char]]
y) (TmsCommand -> [[Char]]
commandAlphabet (TmsCommand -> [[Char]]) -> [TmsCommand] -> [[[Char]]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TmsCommand]
tmsCommands)

-- | Tms.
-- Example:
--
-- name: TuringMachine_1
-- init: q1
-- accept: q2, q3
-- 
-- q1, _, x
-- q2, a, y, -, >
-- 
-- q0, _, _
-- q3, a, _, <, -
-- Note: lines should not end with ' ', also there could not be any newlines after Tms.
pTms :: Parser Tms
pTms :: Parser Tms
pTms = do
    [Char]
name             <- Tokens Text
-> ParsecT Void Text Identity [Char]
-> ParsecT Void Text Identity [Char]
forall a. Tokens Text -> Parser a -> Parser a
pKeyValue Tokens Text
"name"   ParsecT Void Text Identity [Char]
pIdentifier
    [Char]
initStateName    <- Tokens Text
-> ParsecT Void Text Identity [Char]
-> ParsecT Void Text Identity [Char]
forall a. Tokens Text -> Parser a -> Parser a
pKeyValue Tokens Text
"init"   ParsecT Void Text Identity [Char]
pIdentifier
    [[Char]]
acceptStateNames <- Tokens Text -> Parser [[Char]] -> Parser [[Char]]
forall a. Tokens Text -> Parser a -> Parser a
pKeyValue Tokens Text
"accept" (ParsecT Void Text Identity [Char]
pIdentifier ParsecT Void Text Identity [Char] -> Parser () -> Parser [[Char]]
forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
`sepBy1` Parser ()
comma)
    [(TmsCommand, Int)]
cmdsLens <- Parser (TmsCommand, Int) -> Parser (TmsCommand, Int)
forall a. Parser a -> Parser a
tok Parser (TmsCommand, Int)
pCommand Parser (TmsCommand, Int)
-> ParsecT Void Text Identity [Char]
-> ParsecT Void Text Identity [(TmsCommand, Int)]
forall (m :: * -> *) a sep. MonadPlus m => m a -> m sep -> m [a]
`sepBy1` ParsecT Void Text Identity Char
-> ParsecT Void Text Identity [Char]
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
some ParsecT Void Text Identity Char
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m (Token s)
newline
    let ([TmsCommand]
cmds, [Int]
lens) = [(TmsCommand, Int)] -> ([TmsCommand], [Int])
forall a b. [(a, b)] -> ([a], [b])
unzip [(TmsCommand, Int)]
cmdsLens
    Bool
True <- case [Int]
lens of
        (Int
len : [Int]
others) | Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
1 -> Bool -> ParsecT Void Text Identity Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> ParsecT Void Text Identity Bool)
-> Bool -> ParsecT Void Text Identity Bool
forall a b. (a -> b) -> a -> b
$ (Int -> Bool) -> [Int] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
len) [Int]
others
        [Int]
_                         -> [Char] -> ParsecT Void Text Identity Bool
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Not all commands has same length."
    Tms -> Parser Tms
forall (m :: * -> *) a. Monad m => a -> m a
return (Tms -> Parser Tms) -> Tms -> Parser Tms
forall a b. (a -> b) -> a -> b
$ ([Char], TmsState, [TmsState], [TmsCommand], [[Char]]) -> Tms
Tms (
            [Char]
name,
            [Char] -> TmsState
TmsState [Char]
initStateName,
            [Char] -> TmsState
TmsState ([Char] -> TmsState) -> [[Char]] -> [TmsState]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[Char]]
acceptStateNames,
            [TmsCommand]
cmds,
            [TmsCommand] -> [[Char]]
alphabet [TmsCommand]
cmds
        )


parser :: Parser Tms
parser :: Parser Tms
parser = Parser Tms -> Parser Tms
forall a. Parser a -> Parser a
makeEofParser Parser Tms
pTms

-- | Parse Tms from file.
parseTms :: FilePath -> FilePath -> IO Tms
parseTms :: [Char] -> [Char] -> IO Tms
parseTms [Char]
inputFile [Char]
errorFile =
    Parser Tms -> [Char] -> [Char] -> IO Tms
forall a. Parser a -> [Char] -> [Char] -> IO a
parseFromFile Parser Tms
TmsParser.parser [Char]
errorFile [Char]
inputFile