diff options
| -rw-r--r-- | rip-lang.txt | 6 | ||||
| -rw-r--r-- | rip.hs | 311 |
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] @@ -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 () |