path: root/rip.hs

module Main where

import System.Environment
import System.Exit
import System.IO
import System.IO.Error
import Control.Exception
import Control.Monad
import Data.Char
import Data.Either
import Data.Maybe
import Data.List
import qualified Data.Map.Strict as Map
import Data.Map.Strict ((!))
import Network.Socket
import Numeric

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

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

pad :: a -> Int -> [a] -> [a]
pad c n s
    | length s >= n = s
    | otherwise = c : pad c (n-1) s

getBytes :: Stackelem -> [Int]
getBytes = reverse . getBytes'

getBytes' :: Stackelem -> [Int]
getBytes' 0 = []
getBytes' n = fromIntegral m : getBytes' q
    where (q,m) = divMod n 256

hex :: (Integral a, Show a) => a -> String
hex n = showHex n ""

pairs :: [a] -> [(a,a)]
pairs [] = []
pairs (a:b:cs) = (a,b) : pairs cs

safeHGetChar :: Handle -> IO (Maybe Char)
safeHGetChar h =
    catch
        (liftM Just $ hGetChar h)
        ((\ex -> if isEOFError ex then return Nothing else ioError ex)
            :: IOError -> IO (Maybe Char))

safeGetChar :: IO (Maybe Char)
safeGetChar = safeHGetChar stdin


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 = findIndex (== '>') xs
        name = take (fromJust maybeidx) xs

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

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

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

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

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

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

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

        'r' ->
            rip' xs fns conns 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 conns 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 conns (fromIntegral (length st) : st)

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

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

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

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

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

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

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

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

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

        'n' ->
            rip' xs fns conns (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,newconns) <- rip' inblock fns conns (tail st)
                            rip' afterblock fns newconns newstack
                        else rip' afterblock fns conns (tail st)

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

                Right (inblock,afterblock) ->
                    let
                        doloop st cn = do
                            (newstack,newconns) <- rip' inblock fns cn st
                            if head newstack /= 0
                                then doloop (tail newstack) newconns
                                else return (tail newstack,newconns)
                    in if head st /= 0
                        then do
                            (newstack,newconns) <- doloop (tail st) conns
                            rip' afterblock fns newconns newstack
                        else rip' afterblock fns conns (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 conns (tail st))
                res

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

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

        'C' -> do
            let (portint:hostnameint:newst) = st
                hostname =
                    if hostnameint < 2^32
                        then intercalate "." $ map show $ getBytes hostnameint
                        else intercalate ":" $ map (\(a,b) -> pad '0' 2 (hex a) ++ pad '0' 2 (hex b)) $ pairs $ pad 0 16 $ getBytes hostnameint
            addrinfo <- liftM head $ getAddrInfo (Just $ defaultHints {addrSocketType = Stream}) (Just hostname) (Just $ show portint)
            sock <- socket (addrFamily addrinfo) Stream defaultProtocol
            connect sock (addrAddress addrinfo)
            h <- socketToHandle sock ReadWriteMode
            let ident = fromIntegral $ succ $ Map.size conns
            rip' xs fns (Map.insert ident h conns) $ ident : newst

        'c' -> do
            let (ident:newst) = st
            hClose $ conns ! ident
            let newconns = Map.delete ident conns
            rip' xs fns newconns newst

        'w' -> do
            let (c:newst@(ident:_)) = st
            hPutChar (conns ! ident) $ chr $ fromIntegral c
            rip' xs fns conns newst

        't' -> do
            let (ident:_) = st
            c <- liftM (maybe (-1) ordI) $ safeHGetChar $ conns ! ident
            --c <- liftM ordI $ hGetChar $ conns ! ident
            rip' xs fns conns $ c : 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,newconns) <- rip' s fns conns st
                            rip' newcode fns newconns 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) conns st

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

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

        '"' ->
            let str = takeWhile (/='"') xs
                rest = drop (length str + 1) xs
            in if length str == length xs
                then riperror "No closing quote in \"string\""
                else rip' rest fns conns $ reverse (map (fromIntegral . fromEnum) str) ++ st

        '$' -> do
            putStrLn $ '[' : ((intercalate " " . map show . reverse) st) ++ "]"
            rip' xs fns conns st

        c | isSpace c ->
            rip' xs fns conns 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 ()