From a011b5647fb4af63639432616ee35383f0021290 Mon Sep 17 00:00:00 2001 From: hellerve Date: Fri, 19 May 2017 15:45:46 +0200 Subject: [PATCH] all: added function definitions and calls --- src/BC/Eval.hs | 24 ++++++++++++++ src/BC/Parse.hs | 83 ++++++++++++++++++++++++++++++++++++++---------- src/BC/Prompt.hs | 9 +++++- src/BC/Types.hs | 17 +++++++--- 4 files changed, 110 insertions(+), 23 deletions(-) diff --git a/src/BC/Eval.hs b/src/BC/Eval.hs index 9c2cb37..5933c36 100644 --- a/src/BC/Eval.hs +++ b/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 diff --git a/src/BC/Parse.hs b/src/BC/Parse.hs index eeeb914..d978261 100644 --- a/src/BC/Parse.hs +++ b/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 diff --git a/src/BC/Prompt.hs b/src/BC/Prompt.hs index 3ed5b7a..a7c3377 100644 --- a/src/BC/Prompt.hs +++ b/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 () diff --git a/src/BC/Types.hs b/src/BC/Types.hs index c91feb5..95630ba 100644 --- a/src/BC/Types.hs +++ b/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