module Main where

import System.Environment
import System.Exit
import Control.Exception
import Data.Char
import Data.Either

type Stackelem = Integer


c_ripmode :: Bool
c_ripmode = True


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

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 "rip -- unmatched closing bracket"
	      go   i      st    (_:cs)  = go (i+1) st cs
	      go   _    (_:_)     []    = Left "rip -- 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 "rip -- 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 = 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 = head st
				newst = tail st
				(begin, rest) = (take (fromIntegral n) newst, drop (fromIntegral n) newst)
				res = tail begin ++ head begin : rest

	'R' ->
		rip' xs res
			where
				n = head st
				newst = tail st
				(begin, rest) = (take (fromIntegral n) newst, drop (fromIntegral 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

	'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
		putStr [chr (fromIntegral $ head st)]
		rip' xs (tail st)

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

	'g' -> do
		c <- getChar
		rip' xs (fromIntegral (ord c) : 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 ()