--
-- Interpreter for the ~ language in Haskell, by Ørjan Johansen 2007.
-- Sep 30 2013:
--  Minimal changes to make it compile with modern Haskell Platform.
--  (This probably breaks it on Hugs, as catch was renamed to catchIOError.)
--
-- Tested (but not much) with Hugs (requires -98 option.)  See haskell.org.
-- License: <http://creativecommons.org/licenses/publicdomain/>
--
-- For the ~ program, either give its filename as command line argument,
-- or give the source on stdin terminated by a line containing only a period.
--

module Main where

import Text.ParserCombinators.Parsec
import Control.Monad
import Control.Monad.State
import Data.Sequence
import System.Environment
import System.IO
import System.IO.Error (catchIOError)

type TM = StateT (Seq Int) IO

main = do
    args <- getArgs
    let path = case args of [] -> ""; [p] -> p; _ -> error "Too many arguments"
    source <- case path of
        "" -> let
            loop = do
                l <- getLine
                if (l==".") then return [] else liftM (l:) loop
          in liftM unlines loop
        p -> readFile p
    run path source

run path source = case parse program path source of
    Left err    -> print err
    Right prog  -> evalStateT prog empty

program = do spaces; p <- statements; eof; return p
statements = liftM sequence_ $ many statement

statement :: Parser (TM ())
statement = between (return ()) (optional $ op '|') (simple <|> compound)

simple = do
    op '!'; args <- count 3 argument
    return $ do
        [x,y,z] <- sequence args
        if x==y then push_front z else pop_back >> return ()
  <|> do
    op '#'; args <- count 3 argument
    return $ do
        [x,y,z] <- sequence args
        if x==y then pop_front >> return () else push_back z
  <|> do
    cmd <- many1 (oneOf "+-" <?> "") <?> "unary operator"
    Just f <- return $ lookup cmd
       [("+" , \x -> do pop_front; push_back x),
        ("-" , \x -> do pop_back; push_front x),
        ("++", \x -> do pop_back >>= push_back . (+ 1) ; push_front x),
        ("--", \x -> do pop_front >>= push_front . (+ 1) ; push_back x),
        ("+-", \x -> do pop_front >>= push_front . (+ x)
                        pop_back >>= push_back . (subtract x)),
        ("-+", \x -> do pop_front >>= push_front . (subtract x)
                        pop_back >>= push_back . (+ x))]
    spaces; a <- argument
    return $ a >>= f
  <|> do
    op '$'; return $ do
        pop_front >>= liftIO . putChar . toEnum
        (push_back =<<) $ liftIO $ do
            e <- isEOF
            if e then return 0 else liftM fromEnum getChar
  <|> do
    op '%'; return $ do
        pop_back >>= liftIO . print
        (push_front =<<) $ liftIO $ do
            e <- isEOF
            if e then return 0 else catchIOError readLn (const (return 0))
  <|> do
    op '~'; return $ do
        f <- pop_front; b <- pop_back; push_front b; push_back f

compound = do
    s <- between (op '{') (op '}') statements
    return $ let loop = do p <- peek_front; when (p/=0) (do s; loop) in loop
  <|> do
    s <- between (op '[') (op ']') statements
    return $ let loop = do s; p <- peek_back; when (p/=0) loop in loop


argument :: Parser (TM Int)
argument =
      do op '^'; return peek_front
  <|> do op '&'; return peek_back
  <|> do n <- liftM read $ many1 digit; spaces; return (return n)

op c = do char c; spaces

peek_front  :: TM Int
peek_back   :: TM Int
pop_front   :: TM Int
pop_back    :: TM Int
push_front  :: Int -> TM ()
push_back   :: Int -> TM ()

peek_front      = gets (`index` 0)
peek_back       = do (_ :> b) <- gets viewr; return b
pop_front       = do (f :< r) <- gets viewl; put r; return f
pop_back        = do (r :> b) <- gets viewr; put r; return b
push_front f    = modify (f <|)
push_back b     = modify (|> b)