module Main where

import System.Environment
import System.Exit
import System.IO.Error
import Control.Exception
import Control.Monad
import Data.Char
import Data.Either

type Stackelem = Integer


c_ripmode :: Bool
c_ripmode = False

c_debugmode :: Bool
c_debugmode = False


booltoint :: (Integral a) => Bool -> a
booltoint False = 0
booltoint True = 1

riperror :: String -> IO a
riperror s = do
    if c_ripmode
        then putStrLn "rip"
        else putStrLn $ "ERROR: " ++ s
    exitFailure

fromRight :: Either a b -> b
fromRight (Right r) = r

fromLeft :: Either a b -> a
fromLeft (Left l) = l

safeGetChar :: IO (Maybe Char)
safeGetChar =
    catch
        (liftM Just getChar)
        ((\ex -> if isEOFError ex then return Nothing else ioError ex)
            :: IOError -> IO (Maybe Char))

parenpairs :: String -> Either String [(Int,Int)]
parenpairs = go 0 []
    --       index  stack   string
    where go   _      []      []    = Right []
          go   i      st   ('[':cs) = go (i+1) (i:st) cs
          go   i    (s:st) (']':cs) = either Left (\x -> Right $ (s,i):x) $ go (i+1) st cs
          go   i      []   (']':cs) = Left "Unmatched closing bracket"
          go   i      st    (_:cs)  = go (i+1) st cs
          go   _    (_:_)     []    = Left "Unmatched open bracket"

-- returns string in and after codeblock
getcodeblock :: String -> Either String (String,String)
getcodeblock s = if head (dropWhile isSpace s) == '[' then getcodeblock' s else Left "No codeblock when expected"

getcodeblock' :: String -> Either String (String,String)
getcodeblock' s = either Left (\_ -> Right (inblock,afterblock)) parenserr
    where
        afterwhite = dropWhile isSpace s
        parenserr = parenpairs afterwhite
        parens = fromRight parenserr
        mainpair = minimum parens
        blockend = snd mainpair
        inblock = drop 1 $ take blockend afterwhite
        afterblock = drop (blockend + 1) afterwhite

-- returns the resulting stack
-- rip: Rip InterPreter (recursive acronym)
rip :: String -> IO [Stackelem]
rip s = rip' s []

rip' :: String -> [Stackelem] -> IO [Stackelem]
rip' [] st = return st
rip' (x:xs) st = do
    if c_debugmode then print st else return ()
    case x of
        n | '0' <= n && n <= '9' ->
            rip' xs (fromIntegral (ord n - ord '0') : st)

        'P' ->
            rip' xs (tail st)

        'S' ->
            rip' xs (b:a:cs)
                where (a:b:cs) = st

        'D' ->
            rip' xs (head st : st)

        'i' ->
            rip' xs (head st + 1 : tail st)

        'd' ->
            rip' xs (head st - 1 : tail st)

        'r' ->
            rip' xs res
                where
                    n = fromIntegral $ head st
                    newst = tail st
                    (begin, rest) = (take n newst, drop n newst)
                    res = tail begin ++ head begin : rest

        'R' ->
            rip' xs res
                where
                    n = fromIntegral $ head st
                    newst = tail st
                    (begin, rest) = (take n newst, drop n newst)
                    res = last begin : init begin ++ rest  --SLOW!

        'a' ->
            rip' xs (a + b : cs)
                where (b:a:cs) = st

        's' ->
            rip' xs (a - b : cs)
                where (b:a:cs) = st

        'm' ->
            rip' xs (a * b : cs)
                where (b:a:cs) = st

        'q' ->
            rip' xs (a `div` b : cs)
                where (b:a:cs) = st

        'G' ->
            rip' xs (booltoint (a > b) : cs)
                where (b:a:cs) = st

        'L' ->
            rip' xs (booltoint (a < b) : cs)
                where (b:a:cs) = st

        'E' ->
            rip' xs (booltoint (a == b) : cs)
                where (b:a:cs) = st

        'n' ->
            rip' xs (booltoint (head st == 0) : tail st)

        'I' ->
            let maybecb = getcodeblock xs
            in case maybecb of
                Left s -> riperror s

                Right (inblock,afterblock) ->
                    if head st /= 0
                        then do
                            newstack <- rip' inblock (tail st)
                            rip' afterblock newstack
                        else rip' afterblock (tail st)

        'W' ->
            let maybecb = getcodeblock xs
            in case maybecb of
                Left s -> riperror s

                Right (inblock,afterblock) ->
                    let
                        doloop st = do
                            newstack <- rip' inblock st
                            if head newstack /= 0
                                then doloop $ tail newstack
                                else return newstack
                    in if head st /= 0
                        then do
                            newstack <- doloop (tail st)
                            rip' afterblock newstack
                        else rip' afterblock (tail st)

        'o' -> do
            let n = fromIntegral (head st)
            res <- try $ evaluate $ chr n :: IO (Either SomeException Char)
            either
                (\ex -> riperror $ "Invalid character value " ++ (show n))
                (\c -> do
                    putChar c
                    rip' xs (tail st))
                res

        'O' -> do
            putStr $ show (head st)
            rip' xs (tail st)

        'g' -> do
            n <- liftM (maybe (-1) ord) safeGetChar
            rip' xs (fromIntegral n : st)

        '$' -> do
            print st
            rip' xs st

        c | isSpace c ->
            rip' xs st

        _ -> riperror $ "Unknown command '" ++ [x,'\'']


main :: IO ()
main = do
    argv <- getArgs
    if length argv /= 1
        then do
            putStrLn "Pass a rip file as the command-line argument"
            exitFailure
        else do
            source <- readFile (argv !! 0)
            rip source
            return ()