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

all: refactoring according to hlint; parser: added history

Browse Source
This commit is contained in:
Veit Heller
2017-05-19 12:50:11 -04:00
parent abd68c8525
commit 7b85c63b43
5 changed files with 101 additions and 86 deletions
Download Patch File Download Diff File Expand all files Collapse all files

31
src/BC/Eval.hs
View File

@@ -20,7 +20,7 @@ evalAll state (x:xs) =
eval :: State -> [Value] -> (Value, State)
eval state [x@(BNum _)] = (x, state)
eval state [(BDef (BSym sym) expr)] =
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)
@@ -35,7 +35,7 @@ eval state [x@(BWhile cond body)] =
(val, retstate) = eval newstate [x]
in if truthy val then (val, retstate) else (bodyval, retstate)
else (BBool False, whilestate)
eval state [(BIf cond body alt)] =
eval state [BIf cond body alt] =
let (evald, ifstate) = eval state cond
in
if truthy evald
@@ -43,13 +43,13 @@ eval state [(BIf cond body alt)] =
else case alt of
Just vals -> evalAll ifstate vals
Nothing -> (BBool False, ifstate)
eval state [(BSym x)] =
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)] =
eval state [BCall (BSym name) args] =
case M.lookup name state of
Just val@(BFun _ _ _) -> funCall state val args
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)
@@ -59,13 +59,10 @@ eval state l = (treeEval state l [] [], state)
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 (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@((BSym op):_) nums =
treeEval state expr@(x@(BSym sym):xy) ops@(BSym op:_) nums =
case M.lookup sym state of
Just val -> treeEval state xy ops (val:nums)
Nothing ->
@@ -81,21 +78,21 @@ treeEval state (x@(BSym sym):xy) [] nums =
else BErr (sym ++ " is undefined")
treeEval state (x:xy) ops vals =
let (val, nstate) = eval state [x]
in treeEval nstate xy ops (val:vals)
in treeEval nstate (val:xy) ops vals
handleOp :: State -> [Value] -> [Value] -> [Value] -> Value
handleOp state expr ((BSym op):ops) ((BNum op2):((BNum op1):nums)) =
treeEval state expr ops (((findOp op) op1 op2):nums)
handleOp _ expr ((BSym op):ops) x = BErr ("Not enough arguments to operation " ++ op)
handleOp state expr (BSym op:ops) (BNum op2:(BNum op1:nums)) =
treeEval state expr ops (findOp op op1 op2:nums)
handleOp _ expr (BSym op:ops) x = BErr ("Not enough arguments to operation " ++ op)
findOp x = case binOp x of
Just op -> \a -> \b -> (BNum $ op a b)
Just op -> \a b -> (BNum $ op a b)
Nothing ->
case logicalOp x of
Just lop -> \a -> \b -> (BBool $ lop a b)
Nothing -> \a -> \b -> (BNum $ BInt 0)
Just lop -> \a b -> BBool $ lop a b
Nothing -> \a b -> BNum $ BInt 0
logicalOp :: String -> Maybe (Number -> Number -> Bool)

42
src/BC/Parse.hs
View File

@@ -22,7 +22,7 @@ commasep parser = P.sepBy parser sep
where sep = do _ <- optspace
str <- P.string ","
_ <- optspace
return $ str
return str
float :: P.Parser Value
@@ -70,26 +70,30 @@ block = do
body <- P.sepBy parser newline
_ <- optspace
_ <- P.string "}"
return $ body
return body
where newline = do
_ <- P.many (P.string " " P.<|> P.string "\t")
_ <- P.string "\n"
P.many (P.string " " P.<|> P.string "\t")
-- I obviously can't parsec
parseIf :: P.Parser Value
parseIf = do
_ <- P.string "if"
headAndBlock parser = do
_ <- optspace
_ <- P.string "("
_ <- optspace
cond <- parser
args <- parser
_ <- optspace
_ <- P.string ")"
_ <- optspace
body <- block
_ <- optspace
return (args, body)
parseIf :: P.Parser Value
parseIf = do
_ <- P.string "if"
(cond, body) <- headAndBlock parser
alt <- P.optionMaybe (P.string "else")
case alt of
Just _ -> do
@@ -102,15 +106,7 @@ parseIf = do
while :: P.Parser Value
while = do
_ <- P.string "while"
_ <- optspace
_ <- P.string "("
_ <- optspace
cond <- parser
_ <- optspace
_ <- P.string ")"
_ <- optspace
body <- block
_ <- optspace
(cond, body) <- headAndBlock parser
return $ BWhile cond body
@@ -129,15 +125,7 @@ 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
(args, body) <- headAndBlock (commasep (P.many1 $ P.letter P.<|> symchar))
return $ BFun name args body
@@ -165,11 +153,11 @@ expr = P.try bool
parser :: P.Parser [Value]
parser = (P.sepBy expr (P.string " " P.<|> P.string "\t"))
parser = P.sepBy expr (P.string " " P.<|> P.string "\t")
outerparser :: P.Parser [Value]
outerparser = (P.sepBy expr P.spaces)
outerparser = P.sepBy expr P.spaces
parse :: String -> [Value]

104
src/BC/Prompt.hs
View File

@@ -1,5 +1,6 @@
module BC.Prompt (startPrompt) where
import Control.Monad (unless)
import Data.Char
import System.IO
import System.Posix.Signals
@@ -10,6 +11,10 @@ import BC.Parse
import BC.State
import BC.Types
data Prompt = PState Int [String]
printHeader :: IO ()
printHeader = do
putStrLn $ "bc (better calculator) version " ++ versionStr
@@ -20,10 +25,10 @@ printHeader = do
output :: State -> String -> IO State
output state out =
let res = parse out
in if length res == 1 && isErr (res !! 0)
in if length res == 1 && isErr (head res)
then do
putStrLn $ show (res !! 0)
return $ state
print (head res)
return state
else
let (ret, newstate) = eval state res
in do putStrLn $ returnStr ++ show ret
@@ -33,21 +38,17 @@ output state out =
printStatus :: State -> String -> IO ()
printStatus state str =
let res = parse str
in if length res == 1 && isErr (res !! 0)
then return ()
else
in unless (length res == 1 && isErr (head res)) $
let (evald, _) = eval state res
out = show evald
in if isErr evald || length out == 0
then return ()
else let str = " \x1b[33m=> " ++ trunc out ++ "\x1b[0m"
in putStr (str ++ repeat '\b' (length str - 9))
where repeat str 0 = ""
repeat str n = (str:repeat str (n-1))
trunc s =
in unless (isErr evald || null out) $
let str = " \x1b[33m=> " ++ trunc out ++ "\x1b[0m"
in do putStr str
moveCursor (length str - 9)
where trunc s =
let tr = truncLen s
in if contains tr '\n'
then takeWhile (\x -> x /= '\n') tr ++ "..."
then takeWhile (/= '\n') tr ++ "..."
else tr
truncLen s = if length s > 20 then take 20 s ++ "..." else s
@@ -56,53 +57,84 @@ cleanPrompt :: IO ()
cleanPrompt = putStr "\x1b[2K\r"
moveCursor :: Int -> IO ()
moveCursor n = putStr (repeatB n)
where repeatB 0 = ""
repeatB n = '\b':repeatB (n-1)
-- TODO: Stub
readSpecialKey :: IO ()
readSpecialKey = do
readSpecialKey :: Int -> String -> Prompt -> IO (Int, String, Prompt)
readSpecialKey pos acc pstate@(PState hpos history) = do
c <- getChar
c2 <- getChar
return ()
if c == '['
then
case c2 of
'A' ->
if hpos < (length history - 1)
then
let nacc = history !! (hpos+1)
in return (length nacc, nacc, PState (hpos+1) history)
else return (pos, acc, pstate)
'B' ->
if hpos > -1
then if hpos == 0
then return (0, "", PState (-1) history)
else
let nacc = history !! (hpos-1)
in return (length nacc, nacc, PState (hpos-1) history)
else return (pos, acc, pstate)
'C' -> return (pos+1, acc, pstate)
'D' -> return (pos-1, acc, pstate)
_ -> return (pos, acc, pstate)
else return (pos, acc, pstate)
readline :: State -> IO (Maybe String)
readline state = read' ""
where read' acc = do
readline :: State -> Prompt -> IO (Maybe String)
readline state = read' "" 0
where read' acc pos pstate = do
cleanPrompt
putStr promptStr
putStr acc
printStatus state acc
moveCursor (length acc - pos)
c <- getChar
case c of
'\EOT' -> return Nothing
'\n' -> return (Just acc)
'\n' -> return (Just acc)
'\DEL' ->
if length acc > 0
then do
putStr "\b \b"
read' (init acc)
if null acc || pos == 0
then read' acc pos pstate
else do
read' acc
putStr "\b \b"
read' (take (pos-1) acc ++ drop pos acc) (pos-1) pstate
'\x1b' -> do
readSpecialKey
read' acc
c ->
(pos, nacc, newpstate) <- readSpecialKey pos acc pstate
read' nacc (clamp pos 0 (length acc)) newpstate
c ->
if isPrint c
then do
putStr [c]
read' (acc ++ [c])
else read' acc
read' (acc ++ [c]) (pos+1) pstate
else read' acc pos pstate
clamp n min max
| n < min = min
| n > max = max
| otherwise = n
prompt :: State -> IO ()
prompt state = do
input <- readline state
prompt :: State -> Prompt -> IO ()
prompt state pstate@(PState _ history) = do
input <- readline state pstate
case input of
Nothing -> putStrLn "\nBye!"
Just "quit" -> putStrLn "\nBye!"
Just str -> do
putStrLn ""
newstate <- output state str
prompt newstate
let newpstate = PState (-1) (str:history)
prompt newstate newpstate
installHandlers :: IO ()
@@ -117,4 +149,4 @@ startPrompt :: IO ()
startPrompt = do
printHeader
installHandlers
prompt newState
prompt newState (PState (-1) [])

6
src/BC/Types.hs
View File

@@ -54,7 +54,7 @@ instance Floating Number where
(BInt x) ** (BFloat y) = BFloat $ fromIntegral x ** y
(BInt x) ** (BInt y) = BInt $ x ^ y
logBase x y = log y / log x
sqrt x = x ** (BFloat 0.5)
sqrt x = x ** BFloat 0.5
tan x = sin x / cos x
tanh x = sinh x / cosh x
@@ -71,7 +71,7 @@ instance Num Number where
abs (BFloat x) = BFloat $ abs x
signum (BInt x) = BInt $ signum x
signum (BFloat x) = BFloat $ signum x
fromInteger x = BInt x
fromInteger = BInt
negate (BInt x) = BInt $ negate x
negate (BFloat x) = BFloat $ negate x
@@ -100,7 +100,7 @@ precedence "!=" = 2
contains :: Eq a => [a] -> a -> Bool
contains [] _ = False
contains (x:xy) y = if x == y then True else contains xy y
contains (x:xy) y = (x == y) || contains xy y
operators = ["<=", ">=", "==", "!=", "<", ">", "||", "&&", "^", "*", "/", "-", "+", "%"]

4
src/Main.hs
View File

@@ -12,7 +12,5 @@ import BC.State
main :: IO ()
main = do
tty <- queryTerminal stdInput
if tty
then startPrompt
else getContents >>= putStrLn . show . evalOne . parse
if tty then startPrompt else getContents >>= print . evalOne . parse
where evalOne inp = let (val, _) = eval newState inp in val