From a3ba8c9c9bdcdb769132fcf8c501b114ddfe9b73 Mon Sep 17 00:00:00 2001 From: hellerve Date: Wed, 17 May 2017 14:24:32 +0200 Subject: [PATCH] state: added state handling and variables --- bc.cabal | 2 +- src/BC/Eval.hs | 101 ++++++++++++++++++++++++++++------------------- src/BC/Parse.hs | 77 +++++++++++++++++++++--------------- src/BC/Prompt.hs | 38 ++++++++++-------- src/BC/State.hs | 10 +++++ src/BC/Types.hs | 34 ++++++++-------- 6 files changed, 157 insertions(+), 105 deletions(-) create mode 100644 src/BC/State.hs diff --git a/bc.cabal b/bc.cabal index 6dcaa76..2b045c6 100644 --- a/bc.cabal +++ b/bc.cabal @@ -14,6 +14,6 @@ cabal-version: >=1.10 executable bc main-is: Main.hs hs-source-dirs: src/ - build-depends: base >=4.9 && <4.10, parsec, unix + build-depends: base >=4.9 && <4.10, hashmap, parsec, unix hs-source-dirs: src default-language: Haskell2010 diff --git a/src/BC/Eval.hs b/src/BC/Eval.hs index 8e86da7..9a3008a 100644 --- a/src/BC/Eval.hs +++ b/src/BC/Eval.hs @@ -1,5 +1,8 @@ module BC.Eval (eval) where +import qualified Data.HashMap as M + +import BC.State import BC.Types truthy :: Value -> Bool @@ -8,37 +11,55 @@ truthy (BBool x) = x truthy _ = False -eval :: [Value] -> Value -eval [x@(BNum _)] = x -eval [x@(BBool _)] = x -eval [x@(BErr _)] = x -eval [x@(BIf cond body alt)] = - if truthy (eval cond) - then eval body - else case alt of - Just vals -> eval vals - Nothing -> BBool False -eval [(BOp x)] = BErr ("operation " ++ x ++ " requires arguments") -eval [] = BOp "" -eval l = treeEval l [] [] +eval :: State -> [Value] -> (Value, State) +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@(BBool _)] = (x, state) +eval state [x@(BErr _)] = (x, state) +eval state [(BIf cond body alt)] = + let (evald, ifstate) = eval state cond + in + if truthy evald + then eval ifstate body + else case alt of + Just vals -> eval ifstate vals + Nothing -> (BBool False, ifstate) +eval state [(BSym x)] = + case M.lookup x state of + Just val -> (val, state) + Nothing -> (BErr (x ++ " is undefined"), state) +eval state [] = (BSym "", state) +eval state l = (treeEval state l [] [], state) -treeEval :: [Value] -> [Value] -> [Value] -> Value -treeEval [] [] (num:_) = num -treeEval [] ops nums = handleOp [] ops nums -treeEval (x@(BIf _ _ _):xy) ops nums = treeEval (eval [x]:xy) ops nums -treeEval (x@(BNum _):xy) ops nums = treeEval xy ops (x:nums) -treeEval ((BBool x):xy) ops nums = - treeEval xy ops ((BNum $ BInt $ if x then 1 else 0):nums) -treeEval expr@(x@(BOp _):xy) ops@(op:_) nums = - if precedence x > precedence op - then treeEval xy (x:ops) nums - else handleOp expr ops nums -treeEval (x@(BOp _):xy) [] nums = treeEval xy [x] nums -handleOp :: [Value] -> [Value] -> [Value] -> Value -handleOp expr (op:ops) ((BNum op2):((BNum op1):nums)) = - treeEval expr ops (((findOp op) op1 op2):nums) -handleOp expr ((BOp op):ops) _ = BErr ("Not enough arguments to operation " ++ op) +treeEval :: State -> [Value] -> [Value] -> [Value] -> Value +treeEval _ [] [] (num:_) = num +treeEval state [] ops nums = handleOp state [] ops nums +treeEval state (x@(BIf _ _ _):xy) ops nums = + let (val, newstate) = eval state [x] + in treeEval newstate (val:xy) ops nums +treeEval state (x@(BNum _):xy) ops nums = treeEval state xy ops (x:nums) +treeEval state ((BBool x):xy) ops nums = + treeEval state xy ops ((BNum $ BInt $ if x then 1 else 0):nums) +treeEval state expr@(x@(BSym sym):xy) ops@(op:_) nums = + case M.lookup sym state of + Just val -> treeEval state xy ops (val:nums) + Nothing -> + if precedence x > precedence op + then treeEval state xy (x:ops) nums + else handleOp state expr ops nums +treeEval state (x@(BSym sym):xy) [] nums = + case M.lookup sym state of + Just val -> treeEval state xy [] (val:nums) + Nothing -> treeEval state xy [x] nums + + +handleOp :: State -> [Value] -> [Value] -> [Value] -> Value +handleOp state expr (op:ops) ((BNum op2):((BNum op1):nums)) = + treeEval state expr ops (((findOp op) op1 op2):nums) +handleOp _ expr ((BSym op):ops) _ = BErr ("Not enough arguments to operation " ++ op) findOp x = case binOp x of @@ -50,19 +71,19 @@ findOp x = case binOp x of logicalOp :: Value -> Maybe (Number -> Number -> Bool) -logicalOp (BOp ">") = Just (>) -logicalOp (BOp "<") = Just (<) -logicalOp (BOp ">=") = Just (>=) -logicalOp (BOp "<=") = Just (<=) -logicalOp (BOp "==") = Just (==) -logicalOp (BOp "!=") = Just (/=) +logicalOp (BSym ">") = Just (>) +logicalOp (BSym "<") = Just (<) +logicalOp (BSym ">=") = Just (>=) +logicalOp (BSym "<=") = Just (<=) +logicalOp (BSym "==") = Just (==) +logicalOp (BSym "!=") = Just (/=) logicalOp _ = Nothing binOp :: Value -> Maybe (Number -> Number -> Number) -binOp (BOp "*") = Just (*) -binOp (BOp "/") = Just (/) -binOp (BOp "+") = Just (+) -binOp (BOp "-") = Just ( - ) -binOp (BOp "^") = Just (**) +binOp (BSym "*") = Just (*) +binOp (BSym "/") = Just (/) +binOp (BSym "+") = Just (+) +binOp (BSym "-") = Just ( - ) +binOp (BSym "^") = Just (**) binOp _ = Nothing diff --git a/src/BC/Parse.hs b/src/BC/Parse.hs index e2971bd..3841171 100644 --- a/src/BC/Parse.hs +++ b/src/BC/Parse.hs @@ -6,8 +6,8 @@ import qualified Text.ParserCombinators.Parsec as P import BC.Types -symbol :: P.Parser Char -symbol = P.oneOf "!%&|*+-/<=>^~" +symchar :: P.Parser Char +symchar = P.oneOf "!%&|*+-/<=>^~" number :: P.Parser Value @@ -44,45 +44,58 @@ bool = P.try parseTrue P.<|> parseFalse return $ BBool False -operator :: P.Parser Value -operator = do - res <- P.many1 $ P.letter P.<|> symbol - return $ BOp res +symbol :: P.Parser Value +symbol = do + res <- P.many1 $ P.letter P.<|> symchar + return $ BSym res -- I obviously can't parsec parseIf :: P.Parser Value parseIf = do - _ <- P.string "if" - _ <- P.optionMaybe P.spaces - _ <- P.string "(" - _ <- P.optionMaybe P.spaces - cond <- P.sepBy expr P.spaces - _ <- P.optionMaybe P.spaces - _ <- P.string ")" - _ <- P.optionMaybe P.spaces - _ <- P.string "{" - _ <- P.optionMaybe P.spaces - body <- P.sepBy expr P.spaces - _ <- P.optionMaybe P.spaces - _ <- P.string "}" - _ <- P.optionMaybe P.spaces - alt <- P.optionMaybe (P.string "else") - case alt of - Just _ -> do - _ <- P.optionMaybe P.spaces - _ <- P.string "{" - _ <- P.optionMaybe P.spaces - altbody <- P.sepBy expr P.spaces - _ <- P.optionMaybe P.spaces - _ <- P.string "}" - return $ BIf cond body (Just altbody) - Nothing -> return $ BIf cond body Nothing + _ <- P.string "if" + _ <- P.optionMaybe P.spaces + _ <- P.string "(" + _ <- P.optionMaybe P.spaces + cond <- P.sepBy expr P.spaces + _ <- P.optionMaybe P.spaces + _ <- P.string ")" + _ <- P.optionMaybe P.spaces + _ <- P.string "{" + _ <- P.optionMaybe P.spaces + body <- P.sepBy expr P.spaces + _ <- P.optionMaybe P.spaces + _ <- P.string "}" + _ <- P.optionMaybe P.spaces + alt <- P.optionMaybe (P.string "else") + case alt of + Just _ -> do + _ <- P.optionMaybe P.spaces + _ <- P.string "{" + _ <- P.optionMaybe P.spaces + altbody <- P.sepBy expr P.spaces + _ <- P.optionMaybe P.spaces + _ <- P.string "}" + return $ BIf cond body (Just altbody) + Nothing -> return $ BIf cond body Nothing +def :: P.Parser Value +def = do + sym <- symbol + _ <- P.spaces + _ <- P.string "=" + _ <- P.optionMaybe P.spaces + expr <- P.sepBy expr P.spaces + return $ BDef sym expr + expr :: P.Parser Value -expr = P.try bool P.<|> P.try parseIf P.<|> P.try number P.<|> operator +expr = P.try bool + P.<|> P.try def + P.<|> P.try parseIf + P.<|> P.try number + P.<|> symbol parser :: P.Parser [Value] diff --git a/src/BC/Prompt.hs b/src/BC/Prompt.hs index 7b23e47..3ed5b7a 100644 --- a/src/BC/Prompt.hs +++ b/src/BC/Prompt.hs @@ -7,6 +7,7 @@ import System.Posix.Signals import BC.Config import BC.Eval import BC.Parse +import BC.State import BC.Types printHeader :: IO () @@ -16,21 +17,26 @@ printHeader = do putStrLn "This is free software with ABSOLUTELY NO WARRANTY.\n" -output :: String -> IO () -output out = +output :: State -> String -> IO State +output state out = let res = parse out in if length res == 1 && isErr (res !! 0) - then putStrLn $ show (res !! 0) - else putStrLn $ returnStr ++ show (eval res) + then do + putStrLn $ show (res !! 0) + return $ state + else + let (ret, newstate) = eval state res + in do putStrLn $ returnStr ++ show ret + return newstate -printStatus :: String -> IO () -printStatus str = +printStatus :: State -> String -> IO () +printStatus state str = let res = parse str in if length res == 1 && isErr (res !! 0) then return () else - let evald = eval res + let (evald, _) = eval state res out = show evald in if isErr evald || length out == 0 then return () @@ -53,13 +59,13 @@ readSpecialKey = do return () -readline :: IO (Maybe String) -readline = read' "" +readline :: State -> IO (Maybe String) +readline state = read' "" where read' acc = do cleanPrompt putStr promptStr putStr acc - printStatus acc + printStatus state acc c <- getChar case c of '\EOT' -> return Nothing @@ -82,16 +88,16 @@ readline = read' "" else read' acc -prompt :: IO () -prompt = do - input <- readline +prompt :: State -> IO () +prompt state = do + input <- readline state case input of Nothing -> putStrLn "\nBye!" Just "quit" -> putStrLn "\nBye!" Just str -> do putStrLn "" - output str - prompt + newstate <- output state str + prompt newstate installHandlers :: IO () @@ -106,4 +112,4 @@ startPrompt :: IO () startPrompt = do printHeader installHandlers - prompt + prompt newState diff --git a/src/BC/State.hs b/src/BC/State.hs new file mode 100644 index 0000000..fadb0dd --- /dev/null +++ b/src/BC/State.hs @@ -0,0 +1,10 @@ +module BC.State where + +import Data.HashMap + +import BC.Types + +type State = Map String Value + +newState :: State +newState = empty diff --git a/src/BC/Types.hs b/src/BC/Types.hs index 945203e..ff29369 100644 --- a/src/BC/Types.hs +++ b/src/BC/Types.hs @@ -4,11 +4,13 @@ import Data.List (intercalate) data Value = BNum Number | BBool Bool - | BOp String + | BSym String | BIf [Value] [Value] (Maybe [Value]) + | BDef 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 x y z) = "if (" ++ unwords (map show x) ++ ") {\n\t" ++ intercalate "\n\t" (map show y) ++ "\n}" ++ @@ -16,7 +18,7 @@ instance Show Value where Just vals -> " else {\n\t" ++ intercalate "\n\t" (map show vals) ++ "\n}" Nothing -> "") - show (BOp o) = o + show (BSym o) = o show (BNum n) = show n show (BErr e) = "error: " ++ e @@ -69,18 +71,18 @@ isErr _ = False precedence :: Value -> Int -precedence (BOp "^") = 5 -precedence (BOp "*") = 4 -precedence (BOp "/") = 4 -precedence (BOp "-") = 3 -precedence (BOp "+") = 3 -precedence (BOp "%") = 4 -precedence (BOp "||") = 1 -precedence (BOp "&&") = 1 -precedence (BOp "<") = 2 -precedence (BOp ">") = 2 -precedence (BOp "<=") = 2 -precedence (BOp ">=") = 2 -precedence (BOp "==") = 2 -precedence (BOp "!=") = 2 +precedence (BSym "^") = 5 +precedence (BSym "*") = 4 +precedence (BSym "/") = 4 +precedence (BSym "-") = 3 +precedence (BSym "+") = 3 +precedence (BSym "%") = 4 +precedence (BSym "||") = 1 +precedence (BSym "&&") = 1 +precedence (BSym "<") = 2 +precedence (BSym ">") = 2 +precedence (BSym "<=") = 2 +precedence (BSym ">=") = 2 +precedence (BSym "==") = 2 +precedence (BSym "!=") = 2 precedence _ = 0