pl/bc
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

state: added state handling and variables

Browse Source
This commit is contained in:
Veit Heller
2017-05-17 14:24:32 +02:00
parent 30ecca462d
commit a3ba8c9c9b
6 changed files with 157 additions and 105 deletions
Download Patch File Download Diff File Expand all files Collapse all files

2
bc.cabal
View File

@@ -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

101
src/BC/Eval.hs
View File

@@ -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

77
src/BC/Parse.hs
View File

@@ -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]

38
src/BC/Prompt.hs
View File

@@ -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

10
src/BC/State.hs Normal file
View File

@@ -0,0 +1,10 @@
module BC.State where
import Data.HashMap
import BC.Types
type State = Map String Value
newState :: State
newState = empty

34
src/BC/Types.hs
View File

@@ -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