From: Ramakrishnan Muthukrishnan Date: Sun, 21 Dec 2014 10:50:48 +0000 (+0530) Subject: hw5: downloaded stuff X-Git-Url: https://git.rkrishnan.org/?a=commitdiff_plain;h=7eb3d5ac4f56ff59957bbabcf75f7203b9c9f00d;p=yorgey.git hw5: downloaded stuff --- diff --git a/hw5/05-type-classes.pdf b/hw5/05-type-classes.pdf new file mode 100644 index 0000000..d68610a Binary files /dev/null and b/hw5/05-type-classes.pdf differ diff --git a/hw5/ExprT.hs b/hw5/ExprT.hs new file mode 100644 index 0000000..3408634 --- /dev/null +++ b/hw5/ExprT.hs @@ -0,0 +1,6 @@ +module ExprT where + +data ExprT = Lit Integer + | Add ExprT ExprT + | Mul ExprT ExprT + deriving (Show, Eq) diff --git a/hw5/Parser.hs b/hw5/Parser.hs new file mode 100644 index 0000000..d6e043d --- /dev/null +++ b/hw5/Parser.hs @@ -0,0 +1,105 @@ +-- Applicative parser for infix arithmetic expressions without any +-- dependency on hackage. Builds an explicit representation of the +-- syntax tree to fold over using client-supplied semantics. +module Parser (parseExp) where +import Control.Applicative hiding (Const) +import Control.Arrow +import Data.Char +import Data.Monoid +import Data.List (foldl') + +-- Building block of a computation with some state of type @s@ +-- threaded through it, possibly resulting in a value of type @r@ +-- along with some updated state. +newtype State s r = State (s -> Maybe (r, s)) + +-- Expressions +data Expr = Const Integer + | Add Expr Expr + | Mul Expr Expr + deriving Show + +instance Functor (State s) where + fmap f (State g) = State $ fmap (first f) . g + +instance Applicative (State s) where + pure x = State $ \s -> Just (x, s) + State f <*> State g = State $ \s -> + case f s of + Nothing -> Nothing + Just (r, s') -> fmap (first r) . g $ s' + +instance Alternative (State s) where + empty = State $ const Nothing + State f <|> State g = State $ \s -> maybe (g s) Just (f s) + +-- A parser threads some 'String' state through a computation that +-- produces some value of type @a@. +type Parser a = State String a + +-- Parse one numerical digit. +digit :: Parser Integer +digit = State $ parseDigit + where parseDigit [] = Nothing + parseDigit s@(c:cs) + | isDigit c = Just (fromIntegral $ digitToInt c, cs) + | otherwise = Nothing + +-- Parse an integer. The integer may be prefixed with a negative sign. +num :: Parser Integer +num = maybe id (const negate) <$> optional (char '-') <*> (toInteger <$> some digit) + where toInteger = foldl' ((+) . (* 10)) 0 + +-- Parse a single white space character. +space :: Parser () +space = State $ parseSpace + where parseSpace [] = Nothing + parseSpace s@(c:cs) + | isSpace c = Just ((), cs) + | otherwise = Nothing + +-- Consume zero or more white space characters. +eatSpace :: Parser () +eatSpace = const () <$> many space + +-- Parse a specific character. +char :: Char -> Parser Char +char c = State parseChar + where parseChar [] = Nothing + parseChar (x:xs) | x == c = Just (c, xs) + | otherwise = Nothing + +-- Parse one of our two supported operator symbols. +op :: Parser (Expr -> Expr -> Expr) +op = const Add <$> (char '+') <|> const Mul <$> (char '*') + +-- Succeed only if the end of the input has been reached. +eof :: Parser () +eof = State parseEof + where parseEof [] = Just ((),[]) + parseEof _ = Nothing + +-- Parse an infix arithmetic expression consisting of integers, plus +-- signs, multiplication signs, and parentheses. +parseExpr :: Parser Expr +parseExpr = eatSpace *> + ((buildOp <$> nonOp <*> (eatSpace *> op) <*> parseExpr) <|> nonOp) + where buildOp x op y = x `op` y + nonOp = char '(' *> parseExpr <* char ')' <|> Const <$> num + +-- Run a parser over a 'String' returning the parsed value and the +-- remaining 'String' data. +execParser :: Parser a -> String -> Maybe (a, String) +execParser (State f) = f + +-- Run a parser over a 'String' returning the parsed value. +evalParser :: Parser a -> String -> Maybe a +evalParser = (fmap fst .) . execParser + +-- Parse an arithmetic expression using the supplied semantics for +-- integral constants, addition, and multiplication. +parseExp :: (Integer -> a) -> (a -> a -> a) -> (a -> a -> a) -> String -> Maybe a +parseExp con add mul = (convert <$>) . evalParser (parseExpr <* eof) + where convert (Const x) = con x + convert (Add x y) = add (convert x) (convert y) + convert (Mul x y) = mul (convert x) (convert y) diff --git a/hw5/StackVM.hs b/hw5/StackVM.hs new file mode 100644 index 0000000..5b2591a --- /dev/null +++ b/hw5/StackVM.hs @@ -0,0 +1,58 @@ +module StackVM (StackVal(..), StackExp(..), Stack, Program, stackVM) where + +-- Values that may appear in the stack. Such a value will also be +-- returned by the stackVM program execution function. +data StackVal = IVal Integer | BVal Bool | Void deriving Show + +-- The various expressions our VM understands. +data StackExp = PushI Integer + | PushB Bool + | Add + | Mul + | And + | Or + deriving Show + +type Stack = [StackVal] +type Program = [StackExp] + +-- Execute the given program. Returns either an error message or the +-- value on top of the stack after execution. +stackVM :: Program -> Either String StackVal +stackVM = execute [] + +errType :: String -> Either String a +errType op = Left $ "Encountered '" ++ op ++ "' opcode with ill-typed stack." + +errUnderflow :: String -> Either String a +errUnderflow op = Left $ "Stack underflow with '" ++ op ++ "' opcode." + +-- Execute a program against a given stack. +execute :: Stack -> Program -> Either String StackVal +execute [] [] = Right Void +execute (s:_) [] = Right s + +execute s (PushI x : xs) = execute (IVal x : s) xs +execute s (PushB x : xs) = execute (BVal x : s) xs + +execute (IVal s1 : IVal s2 : ss) (Add : xs) = execute (s':ss) xs + where s' = IVal (s1 + s2) +execute (_:_:_) (Add:_) = errType "Add" +execute _ (Add:_) = errUnderflow "Add" + +execute (IVal s1:IVal s2:ss) (Mul : xs) = execute (s':ss) xs + where s' = IVal (s1 * s2) +execute (_:_:_) (Mul:_) = errType "Mul" +execute _ (Mul:_) = errUnderflow "Mul" + +execute (BVal s1:BVal s2:ss) (And : xs) = execute (s':ss) xs + where s' = BVal (s1 && s2) +execute (_:_:_) (And:_) = errType "And" +execute _ (And:_) = errUnderflow "And" + +execute (BVal s1 : BVal s2 : ss) (Or : xs) = execute (s':ss) xs + where s' = BVal (s1 || s2) +execute (_:_:_) (Or:_) = errType "Or" +execute _ (Or:_) = errUnderflow "Or" + +test = stackVM [PushI 3, PushI 5, Add]