path: root/rip.hs

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
import Data.Maybe
import Data.List as List
import Data.Map.Strict as Map

type Stackelem = Integer


c_ripmode :: Bool
c_ripmode = True

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

ordI :: (Integral a) => Char -> a
ordI = fromIntegral . ord

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


parenpairs :: Char -> Char -> String -> Either String [(Int,Int)]
parenpairs open close s = go 0 [] s -- index, stack, string
    where
        go   _      []       []     = Right []
        go   i      st       s
            |                   length s /= 0 && head s == open  =
                go (i+1) (i:st) (tail s)
            | length st == 0 && length s /= 0 && head s == close =
                Left $ "Unmatched closing '" ++ [close,'\'']
            | length st /= 0 && length s == 0                    =
                Left $ "Unmatched open '" ++ [open,'\'']
            | length st /= 0 && length s /= 0 && head s == close =
                either Left (\x -> Right $ (head st,i):x) $ go (i+1) (tail st) (tail s)
            | otherwise =
                go (i+1) st (tail s)

bracketpairs :: String -> Either String [(Int,Int)]
bracketpairs = parenpairs '[' ']'


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

-- assumes that s starts immediately with '['
getcodeblock' :: String -> Either String (String,String)
getcodeblock' s = either Left (\_ -> Right (inblock,afterblock)) parenserr
    where
        parenserr = bracketpairs s
        parens = fromRight parenserr
        mainpair = minimum parens
        blockend = snd mainpair
        inblock = drop 1 $ take blockend s
        afterblock = drop (blockend + 1) s

--          code substr         error / name
getfuncname :: String -> Either String String
getfuncname s =
    if length afterwhite /= 0 && head afterwhite == '<'
        then getfuncname' afterwhite
        else Left "No function name when expected"
    where
        afterwhite = dropWhile isSpace s

-- assumes that the argument starts immediately with '<'
getfuncname' :: String -> Either String String
getfuncname' (_:xs) =
    if isNothing maybeidx
        then Left "No closing '>' in function name"
        else Right name
    where 
        maybeidx = List.findIndex (== '>') xs
        name = take (fromJust maybeidx) xs

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

--       code         function map            stack      resulting stack
rip' :: String -> Map.Map String String -> [Stackelem] -> IO [Stackelem]
rip' [] _ st = return st
rip' code@(x:xs) fns st = do
    if c_debugmode then print st else return ()
    case x of
        n | '0' <= n && n <= '9' ->
            rip' xs fns (fromIntegral (ord n - ord '0') : st)

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

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

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

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

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

        'r' ->
            rip' xs fns 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 fns res
                where
                    n = fromIntegral $ head st
                    newst = tail st
                    (begin, rest) = (take n newst, drop n newst)
                    res = last begin : init begin ++ rest  --SLOW!

        'l' ->
            rip' xs fns (fromIntegral (length st) : st)

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

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

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

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

        'M' ->
            rip' xs fns (a `mod` b : cs)
                where (b:a:cs) = st

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

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

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

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

        'n' ->
            rip' xs fns (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 fns (tail st)
                            rip' afterblock fns newstack
                        else rip' afterblock fns (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 fns st
                            if head newstack /= 0
                                then doloop $ tail newstack
                                else return $ tail newstack
                    in if head st /= 0
                        then do
                            newstack <- doloop (tail st)
                            rip' afterblock fns newstack
                        else rip' afterblock fns (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 fns (tail st))
                res

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

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

        '<' ->
            case (getfuncname code) of
                Left s -> riperror s
                Right name -> case (Map.lookup name fns) of
                    Nothing -> riperror $ "Function '" ++ name ++ "' not found"
                    Just s -> let newcode = drop (length name + 1) xs
                        in do
                            newstack <- rip' s fns st
                            rip' newcode fns newstack

        'F' -> case (getfuncname xs) of
            Left s -> riperror s
            Right name -> case (Map.lookup name fns) of
                Just _ -> riperror $ "Function '" ++ name ++ "' already exists"
                Nothing -> case (getcodeblock $ drop (length name + 2) xs) of
                    Left s -> riperror s
                    Right (inblock,afterblock) ->
                        rip' afterblock (Map.insert name inblock fns) st

        '#' -> case (getfuncname xs) of
            Left s -> riperror s
            Right name -> do
                contents <- readFile name
                rip' (contents ++ drop (length name + 2) xs) fns st

        '\'' -> rip' (tail xs) fns $ ordI (head xs) : st

        '$' -> do
            (putStrLn . List.intercalate " " . List.map show . reverse) st
            rip' xs fns st

        c | isSpace c ->
            rip' xs fns 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
            readFile (argv !! 0) >>= rip
            return ()