aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--rip-lang.txt6
-rw-r--r--rip.hs311
2 files changed, 173 insertions, 144 deletions
diff --git a/rip-lang.txt b/rip-lang.txt
index 72ae8cb..52de72c 100644
--- a/rip-lang.txt
+++ b/rip-lang.txt
@@ -13,6 +13,7 @@ r: pops the number of items to rotate clockwise
R: pops the number of items to rotate anti-clockwise
a s m q: + - * / (add, subtract, multiply, quotient (integer))
G L E: greater, less, equal; booleans are 1 and 0, as you expect
+n: not; equivalent to 0E
[ ... ]: syntactical; a codeblock
I: pops boolean, conditionally executing the codeblock that should follow the I, depending on the boolean (aka "if")
W: I, but then "while" instead of "if"
@@ -37,3 +38,8 @@ Fibonacci:
9io
D3r+
1]
+
+
+Cat:
+
+gD01sEnW[ogD01sEn]
diff --git a/rip.hs b/rip.hs
index 6dddb20..9e390cd 100644
--- a/rip.hs
+++ b/rip.hs
@@ -2,7 +2,9 @@ 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
@@ -10,7 +12,10 @@ type Stackelem = Integer
c_ripmode :: Bool
-c_ripmode = True
+c_ripmode = False
+
+c_debugmode :: Bool
+c_debugmode = False
booltoint :: (Integral a) => Bool -> a
@@ -19,10 +24,10 @@ booltoint True = 1
riperror :: String -> IO a
riperror s = do
- if c_ripmode
- then putStrLn "rip"
- else putStrLn $ "ERROR: " ++ s
- exitFailure
+ if c_ripmode
+ then putStrLn "rip"
+ else putStrLn $ "ERROR: " ++ s
+ exitFailure
fromRight :: Either a b -> b
fromRight (Right r) = r
@@ -30,30 +35,37 @@ 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 "rip -- unmatched closing bracket"
- go i st (_:cs) = go (i+1) st cs
- go _ (_:_) [] = Left "rip -- unmatched open bracket"
+ -- 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 "rip -- no codeblock when expected"
+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
+ 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)
@@ -62,130 +74,141 @@ 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,'\'']
+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 ()
+ 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 ()