Add functions

Sorry for the de-patterning of parenpairs. I hate the resulting
function, but ghc didn't like my generalisation of the open and
closing paren. It claimed that there were overlapping patterns,
which there were, but it should've just evaluated them in order
... Just like it does with guards. So I went with those guards.

3 files changed, 107 insertions, 45 deletions

diff --git a/functions.rip b/functions.rip
new file mode 100644
index 0000000..add2900
--- /dev/null
+++ b/functions.rip
@@ -0,0 +1,3 @@
+F<hoi>[98mDo 58madDo 6so]
+<hoi>
+<hoi>
diff --git a/rip-lang.txt b/rip-lang.txt
index 52de72c..75ed5bf 100644
--- a/rip-lang.txt
+++ b/rip-lang.txt
@@ -20,6 +20,8 @@ W: I, but then "while" instead of "if"
 o: outputs the top value as an ascii char
 O: outputs the top value as a number
 g: gets a character and pushes the ascii value
+F<bla>[code]: define a function named "bla" with the body "code"
+<bla>: call the function named "bla"
 $: outputs a stackdump
 whitespace: nop
 
diff --git a/rip.hs b/rip.hs
index 9e390cd..c1571bb 100644
--- a/rip.hs
+++ b/rip.hs
@@ -7,6 +7,9 @@ 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
 
@@ -42,62 +45,97 @@ safeGetChar =
         ((\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 "Unmatched closing bracket"
-          go   i      st    (_:cs)  = go (i+1) st cs
-          go   _    (_:_)     []    = Left "Unmatched open bracket"
+
+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 head (dropWhile isSpace s) == '[' then getcodeblock' s else Left "No codeblock when expected"
+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
-        afterwhite = dropWhile isSpace s
-        parenserr = parenpairs afterwhite
+        parenserr = bracketpairs s
         parens = fromRight parenserr
         mainpair = minimum parens
         blockend = snd mainpair
-        inblock = drop 1 $ take blockend afterwhite
-        afterblock = drop (blockend + 1) afterwhite
+        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 []
+rip s = rip' s Map.empty []
 
-rip' :: String -> [Stackelem] -> IO [Stackelem]
-rip' [] st = return st
-rip' (x:xs) st = do
+--       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 (fromIntegral (ord n - ord '0') : st)
+            rip' xs fns (fromIntegral (ord n - ord '0') : st)
 
         'P' ->
-            rip' xs (tail st)
+            rip' xs fns (tail st)
 
         'S' ->
-            rip' xs (b:a:cs)
+            rip' xs fns (b:a:cs)
                 where (a:b:cs) = st
 
         'D' ->
-            rip' xs (head st : st)
+            rip' xs fns (head st : st)
 
         'i' ->
-            rip' xs (head st + 1 : tail st)
+            rip' xs fns (head st + 1 : tail st)
 
         'd' ->
-            rip' xs (head st - 1 : tail st)
+            rip' xs fns (head st - 1 : tail st)
 
         'r' ->
-            rip' xs res
+            rip' xs fns res
                 where
                     n = fromIntegral $ head st
                     newst = tail st
@@ -105,7 +143,7 @@ rip' (x:xs) st = do
                     res = tail begin ++ head begin : rest
 
         'R' ->
-            rip' xs res
+            rip' xs fns res
                 where
                     n = fromIntegral $ head st
                     newst = tail st
@@ -113,35 +151,35 @@ rip' (x:xs) st = do
                     res = last begin : init begin ++ rest  --SLOW!
 
         'a' ->
-            rip' xs (a + b : cs)
+            rip' xs fns (a + b : cs)
                 where (b:a:cs) = st
 
         's' ->
-            rip' xs (a - b : cs)
+            rip' xs fns (a - b : cs)
                 where (b:a:cs) = st
 
         'm' ->
-            rip' xs (a * b : cs)
+            rip' xs fns (a * b : cs)
                 where (b:a:cs) = st
 
         'q' ->
-            rip' xs (a `div` b : cs)
+            rip' xs fns (a `div` b : cs)
                 where (b:a:cs) = st
 
         'G' ->
-            rip' xs (booltoint (a > b) : cs)
+            rip' xs fns (booltoint (a > b) : cs)
                 where (b:a:cs) = st
 
         'L' ->
-            rip' xs (booltoint (a < b) : cs)
+            rip' xs fns (booltoint (a < b) : cs)
                 where (b:a:cs) = st
 
         'E' ->
-            rip' xs (booltoint (a == b) : cs)
+            rip' xs fns (booltoint (a == b) : cs)
                 where (b:a:cs) = st
 
         'n' ->
-            rip' xs (booltoint (head st == 0) : tail st)
+            rip' xs fns (booltoint (head st == 0) : tail st)
 
         'I' ->
             let maybecb = getcodeblock xs
@@ -151,9 +189,9 @@ rip' (x:xs) st = do
                 Right (inblock,afterblock) ->
                     if head st /= 0
                         then do
-                            newstack <- rip' inblock (tail st)
-                            rip' afterblock newstack
-                        else rip' afterblock (tail st)
+                            newstack <- rip' inblock fns (tail st)
+                            rip' afterblock fns newstack
+                        else rip' afterblock fns (tail st)
 
         'W' ->
             let maybecb = getcodeblock xs
@@ -163,15 +201,15 @@ rip' (x:xs) st = do
                 Right (inblock,afterblock) ->
                     let
                         doloop st = do
-                            newstack <- rip' inblock st
+                            newstack <- rip' inblock fns 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)
+                            rip' afterblock fns newstack
+                        else rip' afterblock fns (tail st)
 
         'o' -> do
             let n = fromIntegral (head st)
@@ -180,23 +218,42 @@ rip' (x:xs) st = do
                 (\ex -> riperror $ "Invalid character value " ++ (show n))
                 (\c -> do
                     putChar c
-                    rip' xs (tail st))
+                    rip' xs fns (tail st))
                 res
 
         'O' -> do
             putStr $ show (head st)
-            rip' xs (tail st)
+            rip' xs fns (tail st)
 
         'g' -> do
             n <- liftM (maybe (-1) ord) safeGetChar
-            rip' xs (fromIntegral n : st)
+            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
 
         '$' -> do
             print st
-            rip' xs st
+            rip' xs fns st
 
         c | isSpace c ->
-            rip' xs st
+            rip' xs fns st
 
         _ -> riperror $ "Unknown command '" ++ [x,'\'']