Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Adding Zip comprehension samples from The Monad.Reader article.

  • Loading branch information...
commit 3bc6e1c4c9d46100ea502de500691a9eb0ea93d0 1 parent 7f66b81
unknown authored
View
4 Comprehensions/Makefile
@@ -0,0 +1,4 @@
+ghc-bin = ../../../../Binary/Haskell/ghc/inplace/bin/ghc-stage2
+
+parallel: Parallel.hs
+ $(ghc-bin) Parallel.hs -rtsopts -threaded
View
32 Comprehensions/Maybe.hs
@@ -0,0 +1,32 @@
+{-# LANGUAGE ParallelListComp #-}
+{-# LANGUAGE MonadComprehensions #-}
+
+import Control.Monad.Zip
+
+-------------------------------------------------------------------------------
+-- MonadZip instance for Maybe: Maybe is commutative so we can implement
+-- 'mzip' using bind and we still get symmetric implementation.
+-------------------------------------------------------------------------------
+
+instance MonadZip Maybe where
+ mzip ma mb = ma >>= \a -> mb >>= \b -> (a, b)
+
+-------------------------------------------------------------------------------
+-- Now we can use zip comprehensions with Maybe
+-------------------------------------------------------------------------------
+
+addDo :: Maybe Integer -> Maybe Integer -> Maybe Integer
+addDo a b =
+ do aa <- a
+ bb <- b
+ return (aa + bb)
+
+addCompr :: Maybe Integer -> Maybe Integer -> Maybe Integer
+addCompr a b =
+ [ aa + bb | aa <- a | bb <- b ]
+
+
+main = do
+ print (addDo (Just 1) (Just 2))
+ print (addCompr (Just 1) (Just 2))
+
View
106 Comprehensions/Parallel.hs
@@ -0,0 +1,106 @@
+{-# LANGUAGE ParallelListComp #-}
+{-# LANGUAGE MonadComprehensions #-}
+
+import Control.Monad
+import Control.Monad.Zip
+import Control.Parallel
+import Control.Parallel.Strategies
+import Data.Time.Clock (diffUTCTime, getCurrentTime)
+
+-------------------------------------------------------------------------------
+-- Utilities: Simple functions (omitted from article)
+-------------------------------------------------------------------------------
+
+nfib :: Integer -> Integer
+nfib 0 = 0
+nfib 1 = 1
+nfib n = nfib (n-1) + nfib (n-2)
+
+evalWithTimer f = do
+ putStrLn "starting..."
+ start <- getCurrentTime
+ putStrLn $ "Result: " ++ (show f)
+ end <- getCurrentTime
+ putStrLn $ show (end `diffUTCTime` start) ++ " elapsed."
+
+-------------------------------------------------------------------------------
+-- Example: Writing parallel Fibonacci using Strategies
+-------------------------------------------------------------------------------
+
+fib38 = runEval $ do
+ a <- rpar $ nfib 36
+ b <- rseq $ nfib 37
+ return $ a + b
+
+-------------------------------------------------------------------------------
+-- xDefinition of Eval monad and MonadZip instance
+-------------------------------------------------------------------------------
+
+{-
+-- This is defined in the 'parallel' library (no need to redefine)
+data Eval a = Done a
+
+runEval :: Eval a -> a
+runEval (Done x) = x
+
+instance Monad Eval where
+ return x = Done x
+ Done x >>= k = k x
+-}
+
+instance MonadZip Eval where
+ -- To evaluate two computations in parallel, spawn the first one in
+ -- background using 'rpar' and evaluate the other sequentially using 'rseq'
+ mzip ea eb =
+ [ (a, b) | a <- rpar $ runEval ea,
+ b <- rseq $ runEval eb ]
+
+-------------------------------------------------------------------------------
+-- Example: calculating Fibonacci numbers
+-------------------------------------------------------------------------------
+
+fibTask :: Integer -> Eval Integer
+fibTask n = return $ nfib n
+
+
+-- Run the two tasks in sequence using ',' notation
+fib38seq =
+ [ a + b | a <- fibTask 36
+ , b <- fibTask 37 ]
+
+-- Run the two tasks in parallel using '|' notation
+fib38par =
+ [ a + b | a <- fibTask 36
+ | b <- fibTask 37 ]
+
+
+-- Recursive Fibonacci function with threshold 35
+pfib n | n <= 35 = return $ nfib n
+pfib n = [ a + b | a <- pfib $ n - 1 | b <- pfib $ n - 2 ]
+
+
+main = do
+ putStrLn "Note: Run in parallel using 'parallel +RTS -N2 -RTS'"
+ putStrLn "\nFib 38 - sequential version:"
+ evalWithTimer $ runEval fib38seq
+
+ putStrLn "\nFib 38 - parallel version:"
+ evalWithTimer $ runEval fib38par
+
+ putStrLn "\nRecursive fib 38 - parallel version:"
+ evalWithTimer $ runEval (pfib 38)
+
+-------------------------------------------------------------------------------
+-- Zip comprehensions provide useful sanity check that we can actually
+-- parallelize code. Changing the following to zip comprehension gives a
+-- compile-time error, because there is a data dependency
+-- (but this is not easy to see when using 'do' notation)
+-------------------------------------------------------------------------------
+
+
+ack :: Integer -> Integer -> Eval Integer
+ack 0 n = return $ n + 1
+ack m 0 = ack (m - 1) 1
+ack m n = [ a | n' <- ack m (n - 1)
+ , a <- ack (m - 1) n' ]
+
View
130 Comprehensions/Parsers.hs
@@ -0,0 +1,130 @@
+{-# LANGUAGE ParallelListComp #-}
+{-# LANGUAGE MonadComprehensions #-}
+
+import Data.Char
+import Control.Monad
+import Control.Monad.Zip
+import Control.Applicative (Applicative, pure, (<*>))
+
+-------------------------------------------------------------------------------
+-- Simple parser combinators
+-- (Non-standard feature: result also records the number of consumed
+-- characters, which is used by the implementation of `mzip`)
+-------------------------------------------------------------------------------
+
+newtype Parser a
+ = Parser (String -> [(a, Int, String)])
+
+instance Monad Parser where
+ return a = Parser (\input -> [(a, 0, input)])
+ (Parser p1) >>= f = Parser (\input ->
+ [ (result, n1 + n2, tail)
+ | (a, n1, input') <- p1 input
+ , let (Parser p2) = f a
+ , (result, n2, tail) <- p2 input' ])
+
+instance MonadPlus Parser where
+ mzero = Parser (\_ -> [])
+ mplus (Parser p1) (Parser p2) = Parser (\input ->
+ p1 input ++ p2 input)
+
+run (Parser p) input =
+ [ result | (result, _, tail) <- p input, tail == "" ]
+
+-------------------------------------------------------------------------------
+-- Simple parser combinators
+-------------------------------------------------------------------------------
+
+item :: Parser Char
+item = Parser (\input -> case input of
+ "" -> []
+ c:cs -> [(c, 1, cs)])
+
+sat p = [ c | c <- item, p c ]
+char c = sat (c ==)
+notChar c = sat (c /=)
+
+many p = many1 p `mplus` return []
+many1 p = [ a:as | a <- p, as <- many p ]
+
+-- Equivalents using the do-notation:
+-- sat p = do c <- item; if p c then return c else mzero
+-- many1 p = do a <- p; as <- many p; return $ a:as
+
+-------------------------------------------------------------------------------
+
+brackets :: Char -> Char -> Parser a -> Parser a
+brackets open close body =
+ [ inner | _ <- char open
+ , inner <- (brackets open close body) `mplus` body --(many $ notChar close)
+ , _ <- char close ]
+
+-- Equivalent using the do-notation:
+-- brackets open close = do
+-- _ <- char open;
+-- n <- brackets open close `mplus` (many (notChar close))
+-- _ <- char close;
+-- return n
+
+skipBrackets = brackets '(' ')' (many item)
+
+skipAllBrackets = brackets '(' ')' body
+ where body = many [c | c <- notChar '(' | _ <- notChar ')' ]
+
+-------------------------------------------------------------------------------
+-- Adding `mzip`
+-------------------------------------------------------------------------------
+
+instance MonadZip Parser where
+ mzip (Parser p1) (Parser p2) = Parser (\input ->
+ [ ((a, b), n1, tail1)
+ | (a, n1, tail1) <- p1 input
+ , (b, n2, tail2) <- p2 input
+ , n1 == n2 ])
+
+notContextFree =
+ [ length s
+ | s <- many $ char 'x', _ <- brackets 'y' 'z' unit
+ | _ <- brackets 'x' 'y' unit, _ <- many $ char 'z' ]
+ where unit = return ()
+
+-------------------------------------------------------------------------------
+-- Adding Applicative
+-------------------------------------------------------------------------------
+
+instance Functor Parser where
+ fmap f v = [ f a | a <- v ]
+
+instance Applicative Parser where
+ pure a = return a
+ fs <*> as = [ f a | f <- fs, a <- as ]
+
+-- Applicative version of 'brackets'
+
+bracketsA :: Char -> Char -> Parser a -> Parser a
+bracketsA op cl body =
+ pure (\_ inner _ -> inner)
+ <*> char op
+ <*> bracketsA op cl body `mplus` body
+ <*> char cl
+
+skipBracketsA = bracketsA '(' ')' (many item)
+
+-------------------------------------------------------------------------------
+-- Using `mzip` for input validation
+-------------------------------------------------------------------------------
+
+string "" = return ""
+string (s:ss) = do s <- char s; ss <- string ss; return $ s:ss
+numeric = many (sat isDigit)
+length9 = times item 9
+validPhone1 = (numeric `mzip` length9) >> (return True)
+startsWith p = p >> many item
+
+times p 0 = return []
+times p n = do a <- p; as <- times p (n - 1); return $ a:as
+
+validPhone =
+ [ num | num <- many (sat isDigit)
+ | _ <- times item 10
+ | _ <- startsWith (string "1223") ]
View
71 Comprehensions/Resumptions.hs
@@ -0,0 +1,71 @@
+{-# LANGUAGE ParallelListComp #-}
+{-# LANGUAGE MonadComprehensions #-}
+
+import Control.Monad
+import Control.Monad.Zip
+import Control.Monad.Trans
+
+-------------------------------------------------------------------------------
+-- Poor man's concurrency using Resumptions (not continuations)
+-- 'zip' implements parallel composition
+-- 'bind' implements sequential composition
+-------------------------------------------------------------------------------
+
+data Monad m => Resumption m r
+ = Step (m (Resumption m r))
+ | Done r
+
+action a = Step [ Done r | r <- a ]
+
+run :: Monad m => Resumption m r -> m r
+run (Done r) = return r
+run (Step m) = m >>= run
+
+action' a = Step $ do
+ r <- a
+ return (Done r)
+
+-------------------------------------------------------------------------------
+
+instance Monad m => Monad (Resumption m) where
+ return a = Done a
+ (Done r) >>= f = Step $ return (f r)
+ (Step s) >>= f = Step [ next >>= f | next <- s ]
+
+instance MonadTrans Resumption where
+ lift = action
+
+
+printLoop :: [Char] -> Integer -> a -> Resumption IO a
+printLoop str count result = do
+ lift $ putStrLn str
+ ( if count == 1 then return result -- parens needed by preprocessor, but not GHC
+ else printLoop str (count - 1) result )
+
+main' = run $ printLoop "meow" 3 "cat"
+
+-------------------------------------------------------------------------------
+
+instance Monad m => MonadZip (Resumption m) where
+ mzip (Done a) (Done b) = Done (a, b)
+ mzip sa sb = Step [ mzip a b | a <- step sa, b <- step sb ]
+ where step (Done r) = return $ Done r
+ step (Step sa) = sa
+
+animalsS =
+ [ c ++ " and " ++ d
+ | c <- printLoop "meow" 2 "cat"
+ , d <- printLoop "woof" 3 "dog" ]
+
+animalsP =
+ [ c ++ " and " ++ d
+ | c <- printLoop "meow" 2 "cat"
+ | d <- printLoop "woof" 3 "dog" ]
+
+main :: IO ()
+main = do
+ s <- run animalsP
+ putStrLn $ s
+
+ s <- run animalsS
+ putStrLn $ s
View
2  Preprocessor/Makefile
@@ -1,5 +1,3 @@
-default: preprocessor
-
preprocessor:
happy Parser.ly
ghc Main.lhs -o joinadsp
Please sign in to comment.
Something went wrong with that request. Please try again.