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 -> [Value] -> (Value, State)
eval state [x@(BNum _)] = (x, 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 let (val, newstate) = eval state expr
in (val, M.insert sym val newstate) in (val, M.insert sym val newstate)
eval state [x@(BFun sym _ _)] = (BBool True, M.insert sym x state) 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] (val, retstate) = eval newstate [x]
in if truthy val then (val, retstate) else (bodyval, retstate) in if truthy val then (val, retstate) else (bodyval, retstate)
else (BBool False, whilestate) else (BBool False, whilestate)
eval state [(BIf cond body alt)] = eval state [BIf cond body alt] =
let (evald, ifstate) = eval state cond let (evald, ifstate) = eval state cond
in in
if truthy evald if truthy evald
@@ -43,13 +43,13 @@ eval state [(BIf cond body alt)] =
else case alt of else case alt of
Just vals -> evalAll ifstate vals Just vals -> evalAll ifstate vals
Nothing -> (BBool False, ifstate) Nothing -> (BBool False, ifstate)
eval state [(BSym x)] = eval state [BSym x] =
case M.lookup x state of case M.lookup x state of
Just val -> (val, state) Just val -> (val, state)
Nothing -> (BErr (x ++ " is undefined"), 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 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) Nothing -> (BErr ("function " ++ name ++ " is undefined"), state)
_ -> (BErr (name ++ " is not a function"), state) _ -> (BErr (name ++ " is not a function"), state)
eval state [] = (BSym "", state) eval state [] = (BSym "", state)
@@ -59,13 +59,10 @@ eval state l = (treeEval state l [] [], state)
treeEval :: State -> [Value] -> [Value] -> [Value] -> Value treeEval :: State -> [Value] -> [Value] -> [Value] -> Value
treeEval _ [] [] (num:_) = num treeEval _ [] [] (num:_) = num
treeEval state [] ops nums = handleOp state [] ops nums 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 (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 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 case M.lookup sym state of
Just val -> treeEval state xy ops (val:nums) Just val -> treeEval state xy ops (val:nums)
Nothing -> Nothing ->
@@ -81,21 +78,21 @@ treeEval state (x@(BSym sym):xy) [] nums =
else BErr (sym ++ " is undefined") else BErr (sym ++ " is undefined")
treeEval state (x:xy) ops vals = treeEval state (x:xy) ops vals =
let (val, nstate) = eval state [x] 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 -> [Value] -> [Value] -> [Value] -> Value
handleOp state expr ((BSym op):ops) ((BNum op2):((BNum op1):nums)) = handleOp state expr (BSym op:ops) (BNum op2:(BNum op1:nums)) =
treeEval state expr ops (((findOp op) op1 op2):nums) treeEval state expr ops (findOp op op1 op2:nums)
handleOp _ expr ((BSym op):ops) x = BErr ("Not enough arguments to operation " ++ op) handleOp _ expr (BSym op:ops) x = BErr ("Not enough arguments to operation " ++ op)
findOp x = case binOp x of findOp x = case binOp x of
Just op -> \a -> \b -> (BNum $ op a b) Just op -> \a b -> (BNum $ op a b)
Nothing -> Nothing ->
case logicalOp x of case logicalOp x of
Just lop -> \a -> \b -> (BBool $ lop a b) Just lop -> \a b -> BBool $ lop a b
Nothing -> \a -> \b -> (BNum $ BInt 0) Nothing -> \a b -> BNum $ BInt 0
logicalOp :: String -> Maybe (Number -> Number -> Bool) 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 where sep = do _ <- optspace
str <- P.string "," str <- P.string ","
_ <- optspace _ <- optspace
return $ str return str
float :: P.Parser Value float :: P.Parser Value
@@ -70,26 +70,30 @@ block = do
body <- P.sepBy parser newline body <- P.sepBy parser newline
_ <- optspace _ <- optspace
_ <- P.string "}" _ <- P.string "}"
return $ body return body
where newline = do where newline = do
_ <- P.many (P.string " " P.<|> P.string "\t") _ <- P.many (P.string " " P.<|> P.string "\t")
_ <- P.string "\n" _ <- P.string "\n"
P.many (P.string " " P.<|> P.string "\t") P.many (P.string " " P.<|> P.string "\t")
-- I obviously can't parsec headAndBlock parser = do
parseIf :: P.Parser Value
parseIf = do
_ <- P.string "if"
_ <- optspace _ <- optspace
_ <- P.string "(" _ <- P.string "("
_ <- optspace _ <- optspace
cond <- parser args <- parser
_ <- optspace _ <- optspace
_ <- P.string ")" _ <- P.string ")"
_ <- optspace _ <- optspace
body <- block body <- block
_ <- optspace _ <- optspace
return (args, body)
parseIf :: P.Parser Value
parseIf = do
_ <- P.string "if"
(cond, body) <- headAndBlock parser
alt <- P.optionMaybe (P.string "else") alt <- P.optionMaybe (P.string "else")
case alt of case alt of
Just _ -> do Just _ -> do
@@ -102,15 +106,7 @@ parseIf = do
while :: P.Parser Value while :: P.Parser Value
while = do while = do
_ <- P.string "while" _ <- P.string "while"
_ <- optspace (cond, body) <- headAndBlock parser
_ <- P.string "("
_ <- optspace
cond <- parser
_ <- optspace
_ <- P.string ")"
_ <- optspace
body <- block
_ <- optspace
return $ BWhile cond body return $ BWhile cond body
@@ -129,15 +125,7 @@ fun = do
_ <- P.string "define" _ <- P.string "define"
_ <- P.spaces _ <- P.spaces
name <- P.many1 $ P.letter P.<|> symchar name <- P.many1 $ P.letter P.<|> symchar
_ <- optspace (args, body) <- headAndBlock (commasep (P.many1 $ P.letter P.<|> symchar))
_ <- P.string "("
_ <- optspace
args <- commasep (P.many1 $ P.letter P.<|> symchar)
_ <- optspace
_ <- P.string ")"
_ <- optspace
body <- block
_ <- optspace
return $ BFun name args body return $ BFun name args body
@@ -165,11 +153,11 @@ expr = P.try bool
parser :: P.Parser [Value] 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.Parser [Value]
outerparser = (P.sepBy expr P.spaces) outerparser = P.sepBy expr P.spaces
parse :: String -> [Value] parse :: String -> [Value]

104
src/BC/Prompt.hs
View File

@@ -1,5 +1,6 @@
module BC.Prompt (startPrompt) where module BC.Prompt (startPrompt) where
import Control.Monad (unless)
import Data.Char import Data.Char
import System.IO import System.IO
import System.Posix.Signals import System.Posix.Signals
@@ -10,6 +11,10 @@ import BC.Parse
import BC.State import BC.State
import BC.Types import BC.Types
data Prompt = PState Int [String]
printHeader :: IO () printHeader :: IO ()
printHeader = do printHeader = do
putStrLn $ "bc (better calculator) version " ++ versionStr putStrLn $ "bc (better calculator) version " ++ versionStr
@@ -20,10 +25,10 @@ printHeader = do
output :: State -> String -> IO State output :: State -> String -> IO State
output state out = output state out =
let res = parse out let res = parse out
in if length res == 1 && isErr (res !! 0) in if length res == 1 && isErr (head res)
then do then do
putStrLn $ show (res !! 0) print (head res)
return $ state return state
else else
let (ret, newstate) = eval state res let (ret, newstate) = eval state res
in do putStrLn $ returnStr ++ show ret in do putStrLn $ returnStr ++ show ret
@@ -33,21 +38,17 @@ output state out =
printStatus :: State -> String -> IO () printStatus :: State -> String -> IO ()
printStatus state str = printStatus state str =
let res = parse str let res = parse str
in if length res == 1 && isErr (res !! 0) in unless (length res == 1 && isErr (head res)) $
then return ()
else
let (evald, _) = eval state res let (evald, _) = eval state res
out = show evald out = show evald
in if isErr evald || length out == 0 in unless (isErr evald || null out) $
then return () let str = " \x1b[33m=> " ++ trunc out ++ "\x1b[0m"
else let str = " \x1b[33m=> " ++ trunc out ++ "\x1b[0m" in do putStr str
in putStr (str ++ repeat '\b' (length str - 9)) moveCursor (length str - 9)
where repeat str 0 = "" where trunc s =
repeat str n = (str:repeat str (n-1))
trunc s =
let tr = truncLen s let tr = truncLen s
in if contains tr '\n' in if contains tr '\n'
then takeWhile (\x -> x /= '\n') tr ++ "..." then takeWhile (/= '\n') tr ++ "..."
else tr else tr
truncLen s = if length s > 20 then take 20 s ++ "..." else s truncLen s = if length s > 20 then take 20 s ++ "..." else s
@@ -56,53 +57,84 @@ cleanPrompt :: IO ()
cleanPrompt = putStr "\x1b[2K\r" cleanPrompt = putStr "\x1b[2K\r"
moveCursor :: Int -> IO ()
moveCursor n = putStr (repeatB n)
where repeatB 0 = ""
repeatB n = '\b':repeatB (n-1)
-- TODO: Stub -- TODO: Stub
readSpecialKey :: IO () readSpecialKey :: Int -> String -> Prompt -> IO (Int, String, Prompt)
readSpecialKey = do readSpecialKey pos acc pstate@(PState hpos history) = do
c <- getChar c <- getChar
c2 <- 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 -> Prompt -> IO (Maybe String)
readline state = read' "" readline state = read' "" 0
where read' acc = do where read' acc pos pstate = do
cleanPrompt cleanPrompt
putStr promptStr putStr promptStr
putStr acc putStr acc
printStatus state acc printStatus state acc
moveCursor (length acc - pos)
c <- getChar c <- getChar
case c of case c of
'\EOT' -> return Nothing '\EOT' -> return Nothing
'\n' -> return (Just acc) '\n' -> return (Just acc)
'\DEL' -> '\DEL' ->
if length acc > 0 if null acc || pos == 0
then do then read' acc pos pstate
putStr "\b \b"
read' (init acc)
else do else do
read' acc putStr "\b \b"
read' (take (pos-1) acc ++ drop pos acc) (pos-1) pstate
'\x1b' -> do '\x1b' -> do
readSpecialKey (pos, nacc, newpstate) <- readSpecialKey pos acc pstate
read' acc read' nacc (clamp pos 0 (length acc)) newpstate
c -> c ->
if isPrint c if isPrint c
then do then do
putStr [c] putStr [c]
read' (acc ++ [c]) read' (acc ++ [c]) (pos+1) pstate
else read' acc else read' acc pos pstate
clamp n min max
| n < min = min
| n > max = max
| otherwise = n
prompt :: State -> IO () prompt :: State -> Prompt -> IO ()
prompt state = do prompt state pstate@(PState _ history) = do
input <- readline state input <- readline state pstate
case input of case input of
Nothing -> putStrLn "\nBye!" Nothing -> putStrLn "\nBye!"
Just "quit" -> putStrLn "\nBye!" Just "quit" -> putStrLn "\nBye!"
Just str -> do Just str -> do
putStrLn "" putStrLn ""
newstate <- output state str newstate <- output state str
prompt newstate let newpstate = PState (-1) (str:history)
prompt newstate newpstate
installHandlers :: IO () installHandlers :: IO ()
@@ -117,4 +149,4 @@ startPrompt :: IO ()
startPrompt = do startPrompt = do
printHeader printHeader
installHandlers 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) ** (BFloat y) = BFloat $ fromIntegral x ** y
(BInt x) ** (BInt y) = BInt $ x ^ y (BInt x) ** (BInt y) = BInt $ x ^ y
logBase x y = log y / log x 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 tan x = sin x / cos x
tanh x = sinh x / cosh x tanh x = sinh x / cosh x
@@ -71,7 +71,7 @@ instance Num Number where
abs (BFloat x) = BFloat $ abs x abs (BFloat x) = BFloat $ abs x
signum (BInt x) = BInt $ signum x signum (BInt x) = BInt $ signum x
signum (BFloat x) = BFloat $ signum x signum (BFloat x) = BFloat $ signum x
fromInteger x = BInt x fromInteger = BInt
negate (BInt x) = BInt $ negate x negate (BInt x) = BInt $ negate x
negate (BFloat x) = BFloat $ negate x negate (BFloat x) = BFloat $ negate x
@@ -100,7 +100,7 @@ precedence "!=" = 2
contains :: Eq a => [a] -> a -> Bool contains :: Eq a => [a] -> a -> Bool
contains [] _ = False 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 = ["<=", ">=", "==", "!=", "<", ">", "||", "&&", "^", "*", "/", "-", "+", "%"] operators = ["<=", ">=", "==", "!=", "<", ">", "||", "&&", "^", "*", "/", "-", "+", "%"]

4
src/Main.hs
View File

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