state: added state handling and variables

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

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 :: State -> [Value] -> (Value, State)
-eval [x@(BNum _)] = x
+eval state [x@(BNum _)] = (x, state)
-eval [x@(BBool _)] = x
+eval state [(BDef (BSym sym) expr)] =
-eval [x@(BErr _)] = x
+    let (val, newstate) = eval state expr
-eval [x@(BIf cond body alt)] =
+    in (val, M.insert sym val newstate)
-  if truthy (eval cond)
+eval state [x@(BBool _)] = (x, state)
-    then eval body
+eval state [x@(BErr _)] = (x, state)
-    else case alt of
+eval state [(BIf cond body alt)] =
-          Just vals -> eval vals
+    let (evald, ifstate) = eval state cond
-          Nothing -> BBool False
+    in
-eval [(BOp x)] = BErr ("operation " ++ x ++ " requires arguments")
+      if truthy evald
-eval [] = BOp ""
+        then eval ifstate body
-eval l = treeEval l [] []
+        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
+treeEval :: State -> [Value] -> [Value] -> [Value] -> Value
-handleOp expr (op:ops) ((BNum op2):((BNum op1):nums)) =
+treeEval _ [] [] (num:_) = num
-    treeEval expr ops (((findOp op) op1 op2):nums)
+treeEval state [] ops nums = handleOp state [] ops nums
-handleOp expr ((BOp op):ops) _ = BErr ("Not enough arguments to operation " ++ op)
+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 (BSym ">") = Just (>)
-logicalOp (BOp "<") = Just (<)
+logicalOp (BSym "<") = Just (<)
-logicalOp (BOp ">=") = Just (>=)
+logicalOp (BSym ">=") = Just (>=)
-logicalOp (BOp "<=") = Just (<=)
+logicalOp (BSym "<=") = Just (<=)
-logicalOp (BOp "==") = Just (==)
+logicalOp (BSym "==") = Just (==)
-logicalOp (BOp "!=") = Just (/=)
+logicalOp (BSym "!=") = Just (/=)
 logicalOp _ = Nothing
 
 
 binOp :: Value -> Maybe (Number -> Number -> Number)
-binOp (BOp "*") = Just (*)
+binOp (BSym "*") = Just (*)
-binOp (BOp "/") = Just (/)
+binOp (BSym "/") = Just (/)
-binOp (BOp "+") = Just (+)
+binOp (BSym "+") = Just (+)
-binOp (BOp "-") = Just ( - )
+binOp (BSym "-") = Just ( - )
-binOp (BOp "^") = Just (**)
+binOp (BSym "^") = Just (**)
 binOp _ = Nothing

src/BC/Parse.hs

@@ -6,8 +6,8 @@ import qualified Text.ParserCombinators.Parsec as P
 
 import BC.Types
 
-symbol :: P.Parser Char
+symchar :: P.Parser Char
-symbol = P.oneOf "!%&|*+-/<=>^~"
+symchar = P.oneOf "!%&|*+-/<=>^~"
 
 
 number :: P.Parser Value
@@ -44,45 +44,58 @@ bool = P.try parseTrue P.<|> parseFalse
             return $ BBool False
 
 
-operator :: P.Parser Value
+symbol :: P.Parser Value
-operator = do
+symbol = do
-    res <- P.many1 $ P.letter P.<|> symbol
+    res <- P.many1 $ P.letter P.<|> symchar
-    return $ BOp res
+    return $ BSym res
 
 
 -- I obviously can't parsec
 parseIf :: P.Parser Value
 parseIf = do
-      _ <- P.string "if"
+    _ <- P.string "if"
-      _ <- P.optionMaybe P.spaces
+    _ <- P.optionMaybe P.spaces
-      _ <- P.string "("
+    _ <- P.string "("
-      _ <- P.optionMaybe P.spaces
+    _ <- P.optionMaybe P.spaces
-      cond <- P.sepBy expr P.spaces
+    cond <- P.sepBy expr P.spaces
-      _ <- P.optionMaybe P.spaces
+    _ <- P.optionMaybe P.spaces
-      _ <- P.string ")"
+    _ <- P.string ")"
-      _ <- P.optionMaybe P.spaces
+    _ <- P.optionMaybe P.spaces
-      _ <- P.string "{"
+    _ <- P.string "{"
-      _ <- P.optionMaybe P.spaces
+    _ <- P.optionMaybe P.spaces
-      body <- P.sepBy expr P.spaces
+    body <- P.sepBy expr P.spaces
-      _ <- P.optionMaybe P.spaces
+    _ <- P.optionMaybe P.spaces
-      _ <- P.string "}"
+    _ <- P.string "}"
-      _ <- P.optionMaybe P.spaces
+    _ <- P.optionMaybe P.spaces
-      alt <- P.optionMaybe (P.string "else")
+    alt <- P.optionMaybe (P.string "else")
-      case alt of
+    case alt of
-        Just _ -> do
+      Just _ -> do
-          _ <- P.optionMaybe P.spaces
+        _ <- P.optionMaybe P.spaces
-          _ <- P.string "{"
+        _ <- P.string "{"
-          _ <- P.optionMaybe P.spaces
+        _ <- P.optionMaybe P.spaces
-          altbody <- P.sepBy expr P.spaces
+        altbody <- P.sepBy expr P.spaces
-          _ <- P.optionMaybe P.spaces
+        _ <- P.optionMaybe P.spaces
-          _ <- P.string "}"
+        _ <- P.string "}"
-          return $ BIf cond body (Just altbody)
+        return $ BIf cond body (Just altbody)
-        Nothing -> return $ BIf cond body Nothing
+      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]

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 :: State -> String -> IO State
-output out =
+output state out =
     let res = parse out
     in if length res == 1 && isErr (res !! 0)
-      then putStrLn $ show (res !! 0)
+      then do
-      else putStrLn $ returnStr ++ show (eval res)
+        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 :: State -> String -> IO ()
-printStatus str =
+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 :: State -> IO (Maybe String)
-readline = read' ""
+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 :: State -> IO ()
-prompt = do
+prompt state = do
-    input <- readline
+    input <- readline state
     case input of
       Nothing -> putStrLn "\nBye!"
       Just "quit" -> putStrLn "\nBye!"
       Just str -> do
         putStrLn ""
-        output str
+        newstate <- output state str
-        prompt
+        prompt newstate
 
 
 installHandlers :: IO ()
@@ -106,4 +112,4 @@ startPrompt :: IO ()
 startPrompt = do
     printHeader
     installHandlers
-    prompt
+    prompt newState

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

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 (BSym "^") = 5
-precedence (BOp "*") = 4
+precedence (BSym "*") = 4
-precedence (BOp "/") = 4
+precedence (BSym "/") = 4
-precedence (BOp "-") = 3
+precedence (BSym "-") = 3
-precedence (BOp "+") = 3
+precedence (BSym "+") = 3
-precedence (BOp "%") = 4
+precedence (BSym "%") = 4
-precedence (BOp "||") = 1
+precedence (BSym "||") = 1
-precedence (BOp "&&") = 1
+precedence (BSym "&&") = 1
-precedence (BOp "<") = 2
+precedence (BSym "<") = 2
-precedence (BOp ">") = 2
+precedence (BSym ">") = 2
-precedence (BOp "<=") = 2
+precedence (BSym "<=") = 2
-precedence (BOp ">=") = 2
+precedence (BSym ">=") = 2
-precedence (BOp "==") = 2
+precedence (BSym "==") = 2
-precedence (BOp "!=") = 2
+precedence (BSym "!=") = 2
 precedence _         = 0