module Main where

import System.Environment
import System.Exit
import Data.Char

type Stackelem = Integer

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

parenpairs :: String -> [(Int,Int)]
parenpairs = go 0 []
	--       index  stack   string
	where go   _      []      []    = []
	      go   i      st   ('[':cs) = go (i+1) (i:st) cs
	      go   i    (s:st) (']':cs) = (s,i) : go (i+1) st cs
	      go   i      []   (']':cs) = error "rip -- unmatched closing bracket"
	      go   i      st    (_:cs)  = go (i+1) st cs
	      go   _    (_:_)     []    = error "rip -- unmatched open bracket"

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

getcodeblock' :: String -> (String,String)
getcodeblock' s = (inblock,afterblock)
	where
		afterwhite = dropWhile isSpace s
		parens = parenpairs afterwhite
		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!

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

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

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

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

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

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

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

	'I' ->
		either
			(\_ -> error "rip -- no block following I")
			(\(inblock,afterblock) ->
				if head st /= 0
					then do
						newstack <- rip' inblock (tail st)
						rip' afterblock newstack
					else rip' afterblock (tail st))
			(getcodeblock xs)

	'W' ->
		either
			(\_ -> error "rip -- no block following W")
			(\(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))
			(getcodeblock xs)

	'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)

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

	c | isSpace c ->
		rip' xs st

	_ -> do
		putStr "(error) Stack: "
		print st
		ioError (userError $ "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 ()