{-# LANGUAGE OverloadedStrings #-}
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 :: 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
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
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 :: 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
','
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
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
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
'_'
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)
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
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)
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
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