{- File: monads.hs Author: Max Levatich -} import System.IO import Data.Char (isAlpha, toLower, isPunctuation, isNumber) import Prelude hiding (log) import Control.Monad import Control.Applicative import Control.Monad.Trans.Maybe import Control.Monad.State -- An exercise to implement a little imperative programming language! -- Starting with a definition for arithmetic expressions data Op = Plus | Mult | Sub deriving (Eq, Show) data AExpr = BinOp AExpr Op AExpr | Neg AExpr | Literal Int | Var String deriving (Eq, Show) -- Boolean expressions data BExpr = BTrue | BFalse | BNot BExpr | BAnd BExpr BExpr | BOr BExpr BExpr | BEq AExpr AExpr | BNeq AExpr AExpr | BLt AExpr AExpr | BGt AExpr AExpr deriving (Eq, Show) -- A Program is a statement type Program = Statement -- A statement is assignment, if-then-else, a while loop, or a sequence of two Statements. -- (allows arbitrary chains of statements, like "s1; s2") data Statement = SAssign String AExpr | SIf BExpr Statement Statement | SWhile BExpr Statement | SSeq Statement Statement | SReturn AExpr deriving (Eq, Show) -- Type alias for an association list storing variable names and their values type Store = [(String, Int)] -- Helpers for retrieving and inserting things into a Store getVar :: Store -> String -> Maybe Int getVar [] _ = Nothing getVar ((k',v):xs) k | k == k' = Just v | otherwise = getVar xs k -- Modified version to work in StateT (for evalS) putVarM :: String -> Int -> StateT Store Maybe () putVarM n i = do vs <- get case vs of [] -> put [(n, i)] ((n', i'):ls) | n' == n -> put $ (n', i):ls | otherwise -> put $ (n', i'):(putVar ls n i) putVar :: Store -> String -> Int -> Store putVar [] name i = [(name, i)] putVar ((name', i'):ls) name i | name' == name = (name', i ):ls | otherwise = (name', i'):(putVar ls name i) -- How to evaluate an arithmetic expression and produce an Int? -- This version doesn't have the Store as an argument, so it can't handle the (Var _) case. evalA :: AExpr -> Int evalA (BinOp e1 op e2) = case op of Plus -> i1 + i2 Mult -> i1 * i2 Sub -> i1 - i2 where i1 = evalA e1 i2 = evalA e2 evalA (Neg e) = negate $ evalA e evalA (Literal i) = i evalA (Var _) = undefined -- Bad! -- One modification we can make to arithmetic expression evaluation -- is to add a debug log with the Logged datatype. newtype Logged a = Logged (a, [String]) deriving Show -- Re-implementing evalA to evaluate subexpressions and merge their logs. -- (still no Store, so cant handle the (Var _) case) evalA_l :: AExpr -> Logged Int evalA_l (BinOp e1 op e2) = case op of Plus -> Logged (i1 + i2, opLog "Added ") Mult -> Logged (i1 * i2, opLog "Multiplied ") Sub -> Logged (i1 - i2, opLog "Subtracted ") where opLog s = l1 ++ l2 ++ [s ++ show i1 ++ " by " ++ show i2] Logged (i1, l1) = evalA_l e1 Logged (i2, l2) = evalA_l e2 evalA_l (Neg e) = Logged (negate i, l ++ ["Negated: " ++ show i]) where Logged (i, l) = evalA_l e evalA_l (Literal i) = Logged (i, ["Found literal: " ++ show i]) evalA_l (Var _) = undefined -- Bad! -- Making Logged into a Monad -- with helper function `log` log :: String -> Logged () log s = Logged ((), [s]) -- To be a monad, you have to be a functor! instance Functor Logged where fmap f (Logged (x, l)) = Logged (f x, l) -- ...and an Applicative. The default implementation of the Monad function `return` -- is the same as `pure` here. instance Applicative Logged where pure i = Logged (i, []) (<*>) = undefined -- Finally we define bind (>>=) in our Monad instance to capture the idea of getting a new -- log from evaluating a subexpression and merging it with the existing log. instance Monad Logged where (>>=) (Logged (x, l)) f = Logged (x', l'') where Logged (x', l') = f x l'' = l ++ l' -- And re-implementing logging using "Monadic" code! -- The `do` blocks are syntactic sugar to hide the -- binds (>>=) chaining each line together. -- Still don't handle (Var _) case evalA_l' :: AExpr -> Store -> Logged Int evalA_l' (BinOp e1 op e2) st = do i1 <- evalA_l' e1 st i2 <- evalA_l' e2 st let logstr s = s ++ " " ++ show i1 ++ " by " ++ show i2 log $ case op of Plus -> logstr "Added" Mult -> logstr "Multiplied" Sub -> logstr "Subtracted" return $ case op of Plus -> i1 + i2 Mult -> i1 * i2 Sub -> i1 - i2 evalA_l' (Neg e) st = do i <- evalA_l' e st log ("Negated " ++ show i) return $ negate i evalA_l' (Literal i) _ = do log $ "Found literal " ++ show i return i evalA_l' (Var _) _ = undefined -- Now the implementation of evalA is mostly separate from the Monad used. -- Another monadic version with minimal changes that DOES use the Store and handles -- missing variables gracefully with the Maybe monad. evalA_m :: AExpr -> Store -> Maybe Int evalA_m (BinOp e1 op e2) st = do i1 <- evalA_m e1 st i2 <- evalA_m e2 st return $ case op of Plus -> i1 + i2 Mult -> i1 * i2 Sub -> i1 - i2 evalA_m (Neg e) st = fmap negate $ evalA_m e st evalA_m (Literal i) _ = return i evalA_m (Var s) st = getVar st s -- Generic helper for evalB (see below) binopT :: (a -> Store -> Maybe b) -> a -> a -> (b -> b -> Bool) -> Store -> Maybe Bool binopT eval_f e1 e2 op vs = do [e1', e2'] <- mapM (`eval_f` vs) [e1, e2] return $ op e1' e2' -- do e1' <- eval_f e1 vs -- Alternative -- e2' <- eval_f e2 vs -- return $ op e1' e2' -- Now let's finish up our programming language: -- evaluating boolean expressions. -- We can easily thread failure from evalA up through evalB with the Maybe monad, -- And keep our concision using the helper function binopT above. evalB :: BExpr -> Store -> Maybe Bool evalB BTrue = \_ -> return True evalB BFalse = \_ -> return False evalB (BNot b1) = fmap not . evalB b1 evalB (BAnd b1 b2) = binopT evalB b1 b2 (&&) evalB (BOr b1 b2) = binopT evalB b1 b2 (||) evalB (BEq a1 a2) = binopT evalA_m a1 a2 (==) evalB (BNeq a1 a2) = binopT evalA_m a1 a2 (/=) evalB (BLt a1 a2) = binopT evalA_m a1 a2 (<) evalB (BGt a1 a2) = binopT evalA_m a1 a2 (>) -- Before writing a monadic version of evalS (the interpreter), we did some more work with -- monads and monad transformers. evalS is at the bottom of this file. -- Now that Logged is a Monad, we can also use it for other computations! -- Logging how a list doubling proceeds: doubleList :: [Int] -> Logged [Int] doubleList [] = do log "Reached end of list" return [] doubleList (x:xs) = do log $ "Doubling: " ++ show x rest <- doubleList xs return $ 2 * x : rest -- By using mapM, we can implement the monadic doubleList more concisely, just like we -- implemented the original doubleList concisely as `doubleList = map (*2)` -- Unfortunately, this doesn't work with Logged, since mapM relies on the fact that -- a Monad is an Applicative, and we left <*> undefined (line 114). But mapM will -- work "out-of-the-box" with all of your usual monads. -- doubleList = mapM (\x -> Logged (x * 2, ["Doubling: " ++ show x])) -- Similarly to mapM, we can use foldM fold monadic computations. Here's an -- example where we log the summing of a list. sumList :: [Int] -> Logged Int sumList xs = foldM (\b x -> Logged (x + b, ["Adding: " ++ show x])) 0 xs -- As you might expect, filterM also exists. -- Look in Control.Monad (https://hackage.haskell.org/package/base-4.21.0.0/docs/Control-Monad.html) -- for more monad helpers! -- List itself, [], is also a Monad! So we can write `do` blocks for functions -- that return lists. The list monad captures `non-determinism` in computations. -- The result of cartProduct is a list of all possible results from pairing an -- element from x and an element from y. -- If we include the `guard (even x)` line, then we will filter to only entries -- where x is even. cartProduct :: [Int] -> [Int] -> [(Int, Int)] cartProduct xs ys = do x <- xs y <- ys -- guard (even x) return (x, y) -- I/O is also a monad! We can read and write files, read input, -- and get command line arguments while in the I/O monad. -- Once we've defined a `main :: IO ()` function we can compile Haskell programs -- to executables with `stack ghc monads.hs`, and then run them with `main` as the -- entry point with `./monads`. -- Note that I did not make `palindromes.txt` available for download. -- To test, create `palindromes.txt` in the current directory. -- The file, for reference, was: {- Able was I saw elba Taco cat Race car Palindrome A man, a plan, a canal, Panama! -} palindromes :: IO () palindromes = do contents <- readFile "palindromes.txt" let ls = lines contents isPalindrome s = s' == reverse s' where s' = [ toLower x | x <- s, isAlpha x ] print $ map isPalindrome ls -- A verbose way to print the reverse of each input line echoRev :: IO () echoRev = forever $ do -- forever executes a do-block over and over again l <- getLine putStrLn $ reverse l -- A concise way, noting that (=<<) is just (>>=) with the arguments flipped. -- We can use fmap to apply a non-monadic function (reverse) to a monadic result (getLine) -- and get back a monadic result -- echoRev = forever $ putStrLn =<< fmap reverse getLine -- Another concise way -- echoRev = forever $ getLine >>= putStrLn . reverse -- Introducing the State monad with a little game! -- The first argument to State is the type of the State. -- Here, it's a Boolean (is the game on?) and an Int (what's the score?). -- The final result is an Int. -- State gives us the `get` and `put` functions for modifying the state. -- stringGame "caaabbbcaabbca" = 0 stringGame :: String -> State (Bool, Int) Int stringGame [] = do (_, score) <- get return score stringGame (x:xs) = do (on, score) <- get case x of 'a' | on -> put (on, score + 1) 'b' | on -> put (on, score - 1) 'c' -> put (not on, score) _ -> put (on, score) stringGame xs -- We also get the evalState function for running a Stateful function with an initial state -- Here the initial state is (False, 0) -- evalState (stringGame "cabca") (False, 0) -- Introducing monad transformers via password validation. -- We want to use the IO monad (for reading password) -- and Maybe monad (for validating) at the same time. -- So we use MaybeT IO, and whenever we want to do an IO action, we prefix it with the `lift` function isValid :: String -> Bool isValid s = foldr (&&) True [length s >= 8, any isAlpha s, any isNumber s, any isPunctuation s] getPassphrase :: MaybeT IO String getPassphrase = do s <- lift getLine guard (isValid s) return s askPassphrase :: MaybeT IO () askPassphrase = do lift $ putStrLn "Insert your new passphrase:" value <- getPassphrase lift $ putStrLn "Storing in database..." -- For reference, this is how bind (>>=) is defined for the Maybe monad -- maybe_value >>= f = case maybe_value of -- Nothing -> Nothing -- Just value -> f value -- MaybeT is a monad; here's the instance that defines bind and return -- instance Monad m => Monad (MaybeT m) where -- return = MaybeT . return . Just -- x >>= f = MaybeT $ do maybe_value <- runMaybeT x -- case maybe_value of -- Nothing -> return Nothing -- Just value -> runMaybeT $ f value -- And here's the MonadTrans instance for MaybeT that lets us use it as a monad transformer -- (defines lift) -- instance MonadTrans MaybeT where -- lift = MaybeT . (liftM Just) -- Finally we can finish our monadic interpreter! (the eval function for Statements) -- We use the StateT monad transformer to leverage the State and Maybe monads together evalS :: Statement -> StateT Store Maybe Int evalS (SReturn e) = do vs <- get i <- lift $ evalA_m e vs return i -- ALT: get >>= (lift . evalA_m e) evalS (SAssign name e) = do vs <- get i <- lift $ evalA_m e vs putVarM name i return 0 -- ALT: get >>= lift . evalA_m e >>= putVarM name -- return 0 evalS (SIf b s1 s2) = do vs <- get b' <- lift $ evalB b vs if b' then evalS s1 else evalS s2 -- ALT: b' <- get >>= lift . evalB b evalS (SWhile b s) = do vs <- get b' <- lift $ evalB b vs if b' then evalS (SSeq s (SWhile b s)) else return 0 -- ALT: b' <- get >>= lift . evalB b evalS (SSeq s1 s2) = evalS s1 >> evalS s2 -- Wrapper that runs a program and pulls out the result with evalStateT runProgram :: Program -> IO () runProgram p = case evalStateT (evalS p) [] of Just i -> print i Nothing -> putStrLn "Variable used before definition" -- A test program {- x = 4; y = 10; while (x > 1) { y = y * x; x = x - 2; } return y; -} sampleprog :: Statement sampleprog = SSeq ( SAssign "x" (Literal 4) ) ( SSeq -- Changing this to "z" results error w/ message "Variable used before definition" ( SAssign "y" (Literal 10) ) ( SSeq ( SWhile ( BGt (Var "x") (Literal (1)) ) ( SSeq ( SAssign "y" (BinOp (Var "y") Mult (Var "x")) ) ( SAssign "x" (BinOp (Var "x") Sub (Literal 2)) ) ) ) ( SReturn (Var "y") ) ) ) -- One last note: If you want to define your own Monad instance, -- you can use `ap` and `liftM` from Control.Monad to implement the -- Functor and Applicative instances without having to define -- `fmap` and `<*>` yourself. The definition of `pure` is the same as -- `return`. data BinTree a = Leaf a | Branch (BinTree a) (BinTree a) deriving (Show) -- The only thing I actually write myself is a definition for bind (>>=) -- and the definition for return (which I place in `pure` so the compiler doesn't complain) instance Monad BinTree where Leaf x >>= f = f x Branch l r >>= f = Branch (l >>= f) (r >>= f) instance Functor BinTree where fmap = liftM instance Applicative BinTree where pure = Leaf (<*>) = ap