---
--- The Tag programming language
--- A pathological language based on a variable Post Tag machine.
--- Copyright 2007, Mark C. Chu-Carroll <markcc@gmail.com>
--- http://www.scienceblogs.com/goodmath
--- 
--- You are free to do whatever you want with this code so long as you include
--- the above copyright notice.
--- 
---
---

module Main where

import Text.ParserCombinators.Parsec
import qualified Text.ParserCombinators.Parsec.Token as P
import Text.ParserCombinators.Parsec.Language 
import System.Environment	
	
data Rule = Rule String Char [Sym] Integer Bool deriving Show
         -- Rule name char stringToAppend numberToDrop printDropped


data TagSystem = TagSystem [Rule] deriving Show
--                         rule

data Sym = SymChar Char | SymHalt | SymInput deriving (Eq,Show)


data TagSystemQueue = TSQ [Sym] deriving (Show)

peekFirst :: TagSystemQueue -> Maybe Sym
peekFirst (TSQ (v:vs)) = Just v
peekFirst (TSQ []) = Nothing

removeN :: Integer -> TagSystemQueue -> ([Sym],TagSystemQueue)
removeN _ t@(TSQ []) = ([], t)
removeN 1 (TSQ (v:vs)) = ([v], TSQ vs)
removeN n (TSQ (v:vs)) = 
	let (front, back) = removeN (n-1) (TSQ vs)
	in ((v:front), back)

appendCharsToQueue :: TagSystemQueue -> [Sym] -> TagSystemQueue
appendCharsToQueue (TSQ queue) syms = TSQ (queue ++ syms)

isEmpty :: TagSystemQueue -> Bool
isEmpty (TSQ (x:xs)) = False
isEmpty (TSQ []) = True


findRule ::  Sym -> [Rule] -> Maybe Rule
findRule sym@(SymChar c) (r@(Rule _ d _ _ _):rules) | c == d = Just r
                                    | otherwise = findRule sym rules
findRule c [] = Nothing
findRule SymHalt _ = Nothing

stepTagSystem :: TagSystem -> TagSystemQueue -> IO (Sym,TagSystemQueue)
stepTagSystem t@(TagSystem rules) input =
    if stringNotEmpty 
        then case rule of
            Just r -> runRule rule input
            Nothing -> if (firstSym == SymHalt)
	                      then return (SymHalt, input)
		                  else error "No matching rule"
        else return (firstSym,input)        where 
                        (stringNotEmpty,firstSym) = case input of
                                     (TSQ []) -> (False,SymHalt)
                                     (TSQ (s:rest)) -> (True,s)
                        rule = findRule firstSym rules

runRule :: (Maybe Rule) -> TagSystemQueue -> IO (Sym,TagSystemQueue)
runRule (Just (Rule name c syms num out)) queue =
    let firstSym = peekFirst queue
        (leader,queueFront) = removeN num queue
    in case firstSym of 
         Nothing -> return (SymHalt, queueFront)
         Just s ->  do { if out then putStr (queueToString (tail leader))
	                            else return ()
                       ; return (s, appendCharsToQueue queueFront syms)
                       }
runRule Nothing queue =
	return (SymHalt, queue)

runTagSystem :: TagSystem -> TagSystemQueue -> IO TagSystemQueue
runTagSystem tagSys queue =
    if (isEmpty queue) 
	    then return queue
        else do { (c,updatedQueue) <- stepTagSystem tagSys queue
                ; case c of
                    SymHalt -> return updatedQueue
                    SymChar _ -> runTagSystem tagSys updatedQueue
                }


queueToString :: [Sym] -> String
queueToString (sym:syms) =
        case sym of
           SymChar c -> (c:(queueToString syms))
           SymHalt -> ('#':(queueToString syms))
           SymInput -> ('?':(queueToString syms))
queueToString [] = []
            

lexer :: P.TokenParser ()

lexer = P.makeTokenParser (haskellDef
                           { P.reservedNames = ["Halt"] })

number = P.integer lexer
ident = P.identifier lexer
whitespace = P.whiteSpace lexer
symbol = P.symbol lexer
colon = symbol ":"
bang = symbol "!"
question = do { s <- symbol "?"
              ; return [SymInput]
              }

parens = P.parens lexer
halt = do { h <- symbol "#"
          ; return SymHalt
          }


stringChar = do { a <- noneOf ")#\n"
                ; return $ SymChar a
                }

stringElement = (stringChar <|> halt)

appendString =  (many stringElement) <|> question

ruleDecl = do { sym <- ident
              ; colon
              ; c <- alphaNum
              ; n <- number
              ; t <- option False (do{ b <- bang
                                     ; return True
                                     })
              ;  str <- parens appendString
              ; return $ Rule sym c str n t
              } 
           
tagProgram = do { rules <- many1 ruleDecl
                ; return $ TagSystem rules
                }


prun :: (Show a) => Parser a -> String -> IO a
prun p input 
	= case (parse p "" input) of 
		Left err -> do{ putStr "parse error at " 
		; print err 
		; error "Parse error"
		} 
		Right x -> return x

parseTagSystemString :: String -> IO  TagSystem
parseTagSystemString input =
    prun (do { whitespace
             ; x <- tagProgram
             ; eof
             ; return x}) input


parseAndRun :: String -> String -> IO String
parseAndRun program input =
    do 
        tagsys <- parseTagSystemString program
        str <- prun appendString input
        (TSQ end) <- runTagSystem tagsys (TSQ str)
        s <- return $ queueToString end
        putStrLn ""
        putStrLn "-------------------------"
        putStrLn s
        return s


main =
	do 
       (file:(input:[])) <- getArgs
       parsedTagsys <- parseFromFile (do { whitespace
                              ; x <- tagProgram
                              ; eof
                              ; return x }) file       
       case parsedTagsys of
          Right tagsys -> do 
             iQ <- prun appendString input
             (TSQ result) <- runTagSystem tagsys (TSQ iQ)
             putStrLn "------------------------"
             putStrLn (queueToString result)
          Left err -> do
            putStrLn ("Parse Error"++(show err))