all: added function definitions and calls

src/BC/Eval.hs

@@ -16,6 +16,7 @@ eval state [x@(BNum _)] = (x, state)
 eval state [(BDef (BSym sym) expr)] =
     let (val, newstate) = eval state expr
     in (val, M.insert sym val newstate)
+eval state [x@(BFun sym _ _)] = (BBool True, M.insert sym x state)
 eval state [x@(BBool _)] = (x, state)
 eval state [x@(BErr _)] = (x, state)
 eval state [x@(BWhile cond body)] =
@@ -39,6 +40,11 @@ eval state [(BSym x)] =
     case M.lookup x state of
       Just val -> (val, state)
       Nothing  -> (BErr (x ++ " is undefined"), state)
+eval state [(BCall (BSym name) args)] =
+    case M.lookup name state of
+      Just val@(BFun _ _ _) -> funCall state val args
+      Nothing -> (BErr ("function " ++ name ++ " is undefined"), state)
+      _ -> (BErr (name ++ " is not a function"), state)
 eval state [] = (BSym "", state)
 eval state l = (treeEval state l [] [], state)
 
@@ -96,3 +102,21 @@ binOp (BSym "+") = Just (+)
 binOp (BSym "-") = Just ( - )
 binOp (BSym "^") = Just (**)
 binOp _ = Nothing
+
+
+funCall :: State -> Value -> [[Value]] -> (Value, State)
+funCall state (BFun name args body) provided =
+    if length args == length provided
+      then let
+        nstate = callWith state args provided
+        (val, _) = eval nstate body
+        in (val, state)
+      else
+        (BErr ("Expected " ++ show (length args) ++
+               " arguments in call to function " ++ name ++ ", got " ++
+               show (length provided)),
+         state)
+  where callWith state [] _ = state
+        callWith state (a:args) (p:provided) =
+          let (evald, nstate) = eval state p
+          in callWith (M.insert a evald nstate) args provided

src/BC/Parse.hs

@@ -6,6 +6,13 @@ import qualified Text.ParserCombinators.Parsec as P
 
 import BC.Types
 
+keywords = ["define", "if", "else", "while"]
+
+
+optspace :: P.Parser (Maybe ())
+optspace = P.optionMaybe P.spaces
+
+
 symchar :: P.Parser Char
 symchar = P.oneOf "!%&|*+-/<=>^~"
 
@@ -14,6 +21,13 @@ number :: P.Parser Value
 number = P.try float P.<|> integer
 
 
+commasep parser = P.sepBy parser sep
+  where sep = do _ <- optspace
+                 str <- P.string ","
+                 _ <- optspace
+                 return $ str
+
+
 float :: P.Parser Value
 float = do
     neg <- P.optionMaybe (P.string "-")
@@ -47,15 +61,19 @@ bool = P.try parseTrue P.<|> parseFalse
 symbol :: P.Parser Value
 symbol = do
     res <- P.many1 $ P.letter P.<|> symchar
-    return $ BSym res
+    if contains keywords res
+      then P.unexpected res
+      else return $ BSym res
+  where contains [] _ = False
+        contains (x:xy) y = if x == y then True else contains xy y
 
 
 block :: P.Parser [Value]
 block = do
     _ <- P.string "{"
-    _ <- P.optionMaybe P.spaces
+    _ <- optspace
     body <- P.sepBy expr P.spaces
-    _ <- P.optionMaybe P.spaces
+    _ <- optspace
     _ <- P.string "}"
     return $ body
 
@@ -64,19 +82,19 @@ block = do
 parseIf :: P.Parser Value
 parseIf = do
     _ <- P.string "if"
-    _ <- P.optionMaybe P.spaces
+    _ <- optspace
     _ <- P.string "("
-    _ <- P.optionMaybe P.spaces
+    _ <- optspace
     cond <- P.sepBy expr P.spaces
-    _ <- P.optionMaybe P.spaces
+    _ <- optspace
     _ <- P.string ")"
-    _ <- P.optionMaybe P.spaces
+    _ <- optspace
     body <- block
-    _ <- P.optionMaybe P.spaces
+    _ <- optspace
     alt <- P.optionMaybe (P.string "else")
     case alt of
       Just _ -> do
-        _ <- P.optionMaybe P.spaces
+        _ <- optspace
         altbody <- block
         return $ BIf cond body (Just altbody)
       Nothing -> return $ BIf cond body Nothing
@@ -85,15 +103,15 @@ parseIf = do
 while :: P.Parser Value
 while = do
     _ <- P.string "while"
-    _ <- P.optionMaybe P.spaces
+    _ <- optspace
     _ <- P.string "("
-    _ <- P.optionMaybe P.spaces
+    _ <- optspace
     cond <- P.sepBy expr P.spaces
-    _ <- P.optionMaybe P.spaces
+    _ <- optspace
     _ <- P.string ")"
-    _ <- P.optionMaybe P.spaces
+    _ <- optspace
     body <- block
-    _ <- P.optionMaybe P.spaces
+    _ <- optspace
     return $ BWhile cond body
 
 
@@ -102,25 +120,56 @@ def = do
     sym <- symbol
     _ <- P.spaces
     _ <- P.string "="
-    _ <- P.optionMaybe P.spaces
+    _ <- optspace
     expr <- P.sepBy expr P.spaces
     return $ BDef sym expr
 
 
+fun :: P.Parser Value
+fun = do
+    _ <- P.string "define"
+    _ <- P.spaces
+    name <- P.many1 $ P.letter P.<|> symchar
+    _ <- optspace
+    _ <- P.string "("
+    _ <- optspace
+    args <- commasep (P.many1 $ P.letter P.<|> symchar)
+    _ <- optspace
+    _ <- P.string ")"
+    _ <- optspace
+    body <- block
+    _ <- optspace
+    return $ BFun name args body
+
+
+call :: P.Parser Value
+call = do
+    name <- symbol
+    _ <- P.string "("
+    _ <- optspace
+    args <- commasep parser
+    _ <- optspace
+    _ <- P.string ")"
+    return $ BCall name args
+
+
+
 expr :: P.Parser Value
 expr = P.try bool
  P.<|> P.try def
  P.<|> P.try while
  P.<|> P.try parseIf
+ P.<|> P.try fun
+ P.<|> P.try call
  P.<|> P.try number
  P.<|> symbol
 
 
 parser :: P.Parser [Value]
-parser = (P.sepBy expr P.spaces) <* P.eof
+parser = (P.sepBy expr P.spaces)
 
 parse :: String -> [Value]
-parse input = case P.parse parser (trim input) (trim input) of
+parse input = case P.parse (parser <* P.eof) (trim input) (trim input) of
     Left err  -> [BErr $ show err]
     Right val -> val
   where trim s = trimR "" $ dropWhile isSpace s

src/BC/Prompt.hs

@@ -44,7 +44,14 @@ printStatus state str =
                in putStr (str ++ repeat '\b' (length str - 9))
   where repeat str 0 = ""
         repeat str n = (str:repeat str (n-1))
-        trunc s = if length s > 20 then take 20 s ++ "..." else s
+        contains c [] = False
+        contains c (s:xs) = if c == s then True else contains c xs
+        trunc s =
+          let tr = truncLen s
+          in if contains '\n' tr
+              then takeWhile (\x -> x /= '\n') tr ++ "..."
+              else tr
+        truncLen s = if length s > 20 then take 20 s ++ "..." else s
 
 
 cleanPrompt :: IO ()

src/BC/Types.hs

@@ -8,20 +8,27 @@ data Value = BNum Number
            | BIf [Value] [Value] (Maybe [Value])
            | BWhile [Value] [Value]
            | BDef Value [Value]
+           | BFun String [String] [Value]
+           | BCall Value [[Value]]
            | BErr String
 instance Show Value where
   show (BBool b) = if b then "true" else "false"
   show (BDef sym expr) = show sym ++ " = " ++ unwords (map show expr)
   show (BIf cond body alt) =
-    "if (" ++ unwords (map show cond) ++ ") {\n\t" ++
-    intercalate "\n\t" (map show body) ++ "\n}" ++
+    "if (" ++ unwords (map show cond) ++ ") {\n  " ++
+    unwords (map show body) ++ "\n}" ++
       (case alt of
         Just vals ->
-          " else {\n\t" ++ intercalate "\n\t" (map show vals) ++ "\n}"
+          " else {\n  " ++ unwords (map show vals) ++ "\n}"
         Nothing -> "")
   show (BWhile cond body) =
-    "while (" ++ unwords (map show cond) ++ ") {\n\t" ++
-    intercalate "\n\t" (map show body) ++ "\n}"
+    "while (" ++ unwords (map show cond) ++ ") {\n  " ++
+    unwords (map show body) ++ "\n}"
+  show (BFun name args body) =
+    "define " ++ name ++ "(" ++ intercalate ", " args ++ ") {\n  " ++
+    unwords (map show body) ++ "\n}"
+  show (BCall name args) =
+    show name ++ "(" ++ intercalate ", " (map show args) ++ ")"
   show (BSym  o) = o
   show (BNum n) = show n
   show (BErr e) = "error: " ++ e