From: Ramakrishnan Muthukrishnan <ram@rkrishnan.org>
Date: Sun, 21 Dec 2014 10:50:48 +0000 (+0530)
Subject: hw5: downloaded stuff
X-Git-Url: https://git.rkrishnan.org/pf/content/en/seg/biz/frontends/rgr-080307.php?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]