├── Chapter04 ├── some-package │ ├── LICENSE │ ├── tests │ │ └── properties.hs │ ├── app │ │ └── main.hs │ ├── stack.yaml │ └── some-package.cabal ├── specialize.hs ├── datafamilies-closed.hs ├── datafamilies.hs ├── scoped-type-variables.hs ├── gadts.hs ├── patternsynonyms.hs ├── typefamilies.hs ├── mr.hs ├── viewpatterns.hs ├── lazypat.hs ├── fundeps.hs ├── associated.hs ├── primops.hs └── errors.hs ├── Chapter08 ├── B.hs ├── A.hs ├── cpp.hs ├── liberate-case.hs ├── cse.hs ├── weak-threadid.hs └── full-laziness.hs ├── Chapter06 ├── echo.hs ├── echo-t.hs ├── echo-lt.hs ├── readwithfile.hs ├── bracket.hs ├── readwrite.hs ├── interact.hs ├── echo-bs.hs ├── echo-lbs.hs ├── logging-t.hs ├── pipes-exceptions.hs ├── readwrite-bs.hs ├── pipes.hs ├── ptr.hs ├── fastlogger.hs ├── resourcet.hs ├── socket-echo.hs ├── socket-udp.hs ├── conduit.hs ├── io-streams-exceptions.hs ├── monadlogger.hs ├── io-streams.hs └── io-streams-parser.hs ├── Chapter10 ├── c_var.c ├── struct-marshal-c.h ├── ffi-fib.hs ├── callbacks-procedure.c ├── ffi-math-h.hs ├── FunExport.hs ├── FunExport_stub.h ├── callbacks_stub.h ├── ffi-funptr_stub.h ├── wrapper-ex_stub.h ├── fun_export.c ├── fib.c ├── hs-fib.c ├── ffi-c-var.hs ├── ffi-funptr.hs ├── dyn_fun_export.c ├── callbacks.hs ├── struct-marshal.hsc └── struct-marshal.hs ├── Chapter03 ├── crash.hs ├── mean.hs ├── heap-profiling.hs ├── heap-profiling-optimized.hs ├── prof-basics.hs ├── benchmark.hs ├── ekg-fact.hs ├── encryption.hs └── encryption-optimized.hs ├── Chapter09 ├── lifted-names.hs ├── main.hs ├── th-names.hs ├── th-helloworld.hs ├── compact-matrix.hs ├── reify-example.hs ├── MatrixSplice.hs ├── splice-testing.hs ├── ConstSplices.hs ├── th-testing.hs ├── MySplices.hs ├── SetterSplice.hs └── gsum.hs ├── Chapter07 ├── top-level.hs ├── ioref-counter.hs ├── ioref-supply.hs ├── ioref.hs ├── forking.hs ├── mvar-reserve.hs ├── concurrently.hs ├── newtype-monadbasecontrol.hs ├── stm-either.hs ├── transactionm.hs ├── mvar-async.hs ├── mvar-queue.hs ├── chan-actors.hs ├── async-cli.hs └── tvar-account.hs ├── Chapter05 ├── ackermanns.hs ├── fib-list.hs ├── ivar-testing.hs ├── rows.hs ├── fib-eval.hs ├── fib.hs ├── spawn.hs ├── spawnio.hs ├── stencil.hs ├── bigrecord.hs └── letterrec.hs ├── Chapter11 ├── stencil.hs ├── tuples.hs ├── matrix-fixed.hs ├── matrix.hs └── matrix-cuda.hs ├── Chapter02 ├── map-fib.hs ├── bytestring-perf.hs ├── backtracking-list.hs ├── seq-memory-usage-gnuplot.txt ├── seq-memory-usage.csv ├── list-fusion.hs ├── bytestring-lazy-perf.hs ├── sum_array_mutable.hs ├── noise.hs ├── string-builder.hs ├── circular.hs ├── strict_and_unpacked.hs ├── fib-array-mem.hs ├── sum_mutable.hs ├── builder-encoding.hs ├── dlist.hs ├── gadts.hs ├── bubblesort-optimized.hs ├── cont-state-writer.hs ├── vector-testing.hs ├── bubblesort.hs ├── bitstore.hs └── seq-memory-usage.svg ├── Chapter13 ├── reactive-banana-fib.hs ├── reactive-banana-counter.hs ├── elerea-first-ex.hs └── yampa.hs ├── Chapter01 ├── worker_wrapper.hs ├── class_performance.hs ├── fib.hs ├── time_and_space.hs └── time_and_space_2.hs ├── .gitattributes ├── Chapter14 ├── fclabels.hs └── fgl.hs ├── Chapter12 ├── remote-exec.hs ├── bi-directional.hs ├── client-server.hs └── first-example.hs ├── .gitignore ├── License └── README.md /Chapter04/some-package/LICENSE: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /Chapter08/B.hs: -------------------------------------------------------------------------------- 1 | module B where 2 | 3 | import A (a) 4 | 5 | b = a ++ "b" 6 | -------------------------------------------------------------------------------- /Chapter04/some-package/tests/properties.hs: -------------------------------------------------------------------------------- 1 | 2 | import Lib 3 | 4 | main = do 5 | undefined 6 | -------------------------------------------------------------------------------- /Chapter06/echo.hs: -------------------------------------------------------------------------------- 1 | -- file: echo.hs 2 | 3 | main = getContents >>= putStr 4 | -- interact id 5 | -------------------------------------------------------------------------------- /Chapter10/c_var.c: -------------------------------------------------------------------------------- 1 | /* file: c_var.c */ 2 | 3 | int c_var = 0; 4 | 5 | void update() { 6 | c_var = 42; 7 | } 8 | -------------------------------------------------------------------------------- /Chapter04/some-package/app/main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | import Lib 3 | 4 | main = foo "bar" 5 | 6 | -------------------------------------------------------------------------------- /Chapter08/A.hs: -------------------------------------------------------------------------------- 1 | module A where 2 | 3 | import {-# SOURCE #-} B (b) 4 | 5 | a = "a" 6 | 7 | main = print b 8 | -------------------------------------------------------------------------------- /Chapter03/crash.hs: -------------------------------------------------------------------------------- 1 | -- file: crash.hs 2 | 3 | f = head 4 | g = f . tail 5 | h = g . tail 6 | 7 | main = print $ h [1,2] 8 | -------------------------------------------------------------------------------- /Chapter10/struct-marshal-c.h: -------------------------------------------------------------------------------- 1 | // file: struct-marshal-c.h 2 | 3 | typedef struct { 4 | int a; 5 | double b; 6 | } Some; 7 | -------------------------------------------------------------------------------- /Chapter10/ffi-fib.hs: -------------------------------------------------------------------------------- 1 | -- file: ffi-fib.hs 2 | 3 | foreign import ccall 4 | fib_c :: Int -> Int 5 | 6 | main = print $ fib_c 20 7 | -------------------------------------------------------------------------------- /Chapter09/lifted-names.hs: -------------------------------------------------------------------------------- 1 | 2 | import Language.Haskell.TH 3 | 4 | right, left :: Name 5 | right = 'Right 6 | left = 'Left 7 | 8 | pi' = 'pi 9 | -------------------------------------------------------------------------------- /Chapter06/echo-t.hs: -------------------------------------------------------------------------------- 1 | -- file: echo-t.hs 2 | 3 | import System.IO 4 | import qualified Data.Text.IO as T 5 | 6 | main = T.getContents >>= T.putStr 7 | -------------------------------------------------------------------------------- /Chapter06/echo-lt.hs: -------------------------------------------------------------------------------- 1 | -- file: echo-t.hs 2 | 3 | import System.IO 4 | import qualified Data.Text.Lazy.IO as T 5 | 6 | main = T.getContents >>= T.putStr 7 | 8 | -------------------------------------------------------------------------------- /Chapter10/callbacks-procedure.c: -------------------------------------------------------------------------------- 1 | /* file: callbacks-procedure.c */ 2 | 3 | void procedure(void (*callback)(double), double n) { 4 | callback(n * 3); 5 | } 6 | -------------------------------------------------------------------------------- /Chapter10/ffi-math-h.hs: -------------------------------------------------------------------------------- 1 | -- file: ffi-math-h.hs 2 | 3 | foreign import ccall unsafe "math.h sin" 4 | csin :: Double -> Double 5 | 6 | main = print (csin pi) 7 | -------------------------------------------------------------------------------- /Chapter10/FunExport.hs: -------------------------------------------------------------------------------- 1 | module FunExport where 2 | 3 | foreign export ccall 4 | fun :: Int -> Int -> Int 5 | 6 | fun :: Int -> Int -> Int 7 | fun a b = a ^ 2 + b 8 | -------------------------------------------------------------------------------- /Chapter08/cpp.hs: -------------------------------------------------------------------------------- 1 | -- file: cpp.hs 2 | 3 | {-# LANGUAGE CPP #-} 4 | 5 | main = do 6 | #ifdef DEVELOPMENT 7 | print "just debugging" 8 | #endif 9 | return () 10 | -------------------------------------------------------------------------------- /Chapter06/readwithfile.hs: -------------------------------------------------------------------------------- 1 | -- file: readwithfile.hs 2 | 3 | import System.IO 4 | 5 | main = do 6 | old <- withFile "file.txt" ReadWriteMode hGetContents 7 | putStrLn old 8 | -------------------------------------------------------------------------------- /Chapter04/specialize.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | lem x = x || not x 4 | {-# INLINE lem #-} 5 | {-# RULES "lem/tautology" forall a. lem a = True #-} 6 | 7 | main = print $ lem True 8 | -------------------------------------------------------------------------------- /Chapter06/bracket.hs: -------------------------------------------------------------------------------- 1 | -- file: bracket.hs 2 | 3 | import Control.Exception 4 | import System.IO hiding (withFile) 5 | 6 | withFile file mode go = bracket (openFile file mode) hClose go 7 | -------------------------------------------------------------------------------- /Chapter09/main.hs: -------------------------------------------------------------------------------- 1 | -- file: main.hs 2 | 3 | foo :: Int -> Int 4 | foo 1 = 1 5 | foo n = n * foo (n - 1) 6 | 7 | main = do 8 | line <- getLine 9 | print $ foo (read line) 10 | -------------------------------------------------------------------------------- /Chapter09/th-names.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# LANGUAGE TemplateHaskell #-} 3 | 4 | import Language.Haskell.TH 5 | 6 | n = 5 7 | 8 | main = print $(fmap VarE (newName "n")) 9 | where n = 1 10 | -------------------------------------------------------------------------------- /Chapter04/datafamilies-closed.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | 3 | data family TStrict a where 4 | TStrict (a, b) = TStrict2 !a !b 5 | TStrict (a, b, c) = TStrict3 !a !b !c 6 | 7 | -------------------------------------------------------------------------------- /Chapter09/th-helloworld.hs: -------------------------------------------------------------------------------- 1 | -- file: th-helloworld.hs 2 | {-# LANGUAGE TemplateHaskell #-} 3 | 4 | import Language.Haskell.TH 5 | 6 | main = putStrLn $(return (LitE (StringL "Hello World!"))) 7 | -------------------------------------------------------------------------------- /Chapter10/FunExport_stub.h: -------------------------------------------------------------------------------- 1 | #include "HsFFI.h" 2 | #ifdef __cplusplus 3 | extern "C" { 4 | #endif 5 | extern HsInt fun(HsInt a1, HsInt a2); 6 | #ifdef __cplusplus 7 | } 8 | #endif 9 | 10 | -------------------------------------------------------------------------------- /Chapter04/datafamilies.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | 3 | data family TStrict a 4 | 5 | data instance TStrict (a, b) = TStrict2 !a !b 6 | data instance TStrict (a, b, c) = TStrict3 !a !b !c 7 | -------------------------------------------------------------------------------- /Chapter06/readwrite.hs: -------------------------------------------------------------------------------- 1 | -- file: readwrite.hs 2 | 3 | main = do 4 | writeFile "file.txt" "old" 5 | old <- readFile "file.txt" 6 | writeFile "file.txt" "new" 7 | putStrLn old 8 | 9 | -------------------------------------------------------------------------------- /Chapter06/interact.hs: -------------------------------------------------------------------------------- 1 | import Data.Char (toUpper) 2 | import System.IO 3 | 4 | main = do 5 | hSetBuffering stdin LineBuffering 6 | hSetBuffering stdout LineBuffering 7 | interact (map toUpper) 8 | -------------------------------------------------------------------------------- /Chapter07/top-level.hs: -------------------------------------------------------------------------------- 1 | 2 | import Data.IORef 3 | import System.IO.Unsafe (unsafePerformIO) 4 | import Control.Concurrent.STM 5 | 6 | globalVar :: IORef Int 7 | globalVar = unsafePerformIO (newIORef 0) 8 | 9 | -------------------------------------------------------------------------------- /Chapter10/callbacks_stub.h: -------------------------------------------------------------------------------- 1 | #include "HsFFI.h" 2 | #ifdef __cplusplus 3 | extern "C" { 4 | #endif 5 | extern void Main_dVr(StgStablePtr the_stableptr, HsDouble a1); 6 | #ifdef __cplusplus 7 | } 8 | #endif 9 | 10 | -------------------------------------------------------------------------------- /Chapter03/mean.hs: -------------------------------------------------------------------------------- 1 | -- file: mean.hs 2 | 3 | mean xs = sum xs / fromIntegral (length xs) 4 | 5 | sumlg xs = sum (map log xs) 6 | 7 | main = do 8 | print $ mean [1..1000000] 9 | print $ sumlg [1..1000001] 10 | -------------------------------------------------------------------------------- /Chapter10/ffi-funptr_stub.h: -------------------------------------------------------------------------------- 1 | #include "HsFFI.h" 2 | #ifdef __cplusplus 3 | extern "C" { 4 | #endif 5 | extern HsDouble Main_d37c(StgStablePtr the_stableptr, HsDouble a1); 6 | #ifdef __cplusplus 7 | } 8 | #endif 9 | 10 | -------------------------------------------------------------------------------- /Chapter10/wrapper-ex_stub.h: -------------------------------------------------------------------------------- 1 | #include "HsFFI.h" 2 | #ifdef __cplusplus 3 | extern "C" { 4 | #endif 5 | extern HsDouble Main_dyK(StgStablePtr the_stableptr, HsDouble a1); 6 | #ifdef __cplusplus 7 | } 8 | #endif 9 | 10 | -------------------------------------------------------------------------------- /Chapter07/ioref-counter.hs: -------------------------------------------------------------------------------- 1 | 2 | import Control.Monad (replicateM_) 3 | import Data.IORef 4 | 5 | main = do 6 | counter <- newIORef 0 7 | replicateM_ 10000000 (modifyIORef counter (+1)) 8 | print =<< readIORef counter 9 | -------------------------------------------------------------------------------- /Chapter10/fun_export.c: -------------------------------------------------------------------------------- 1 | /* file: fun_export.c */ 2 | 3 | #include 4 | #include "FunExport_stub.h" 5 | 6 | int main(int argc, char *argv[]) { 7 | hs_init(&argc, &argv); 8 | printf("%d\n", fun(1, 2)); 9 | } 10 | -------------------------------------------------------------------------------- /Chapter10/fib.c: -------------------------------------------------------------------------------- 1 | /* file: fib.c */ 2 | 3 | int fib_c(int num) 4 | { 5 | if (num <= 2) 6 | { 7 | return 1; 8 | } 9 | else 10 | { 11 | return(fib_c(num - 1) + fib_c(num - 2)); 12 | } 13 | } 14 | -------------------------------------------------------------------------------- /Chapter05/ackermanns.hs: -------------------------------------------------------------------------------- 1 | import Control.Parallel 2 | import Control.DeepSeq 3 | 4 | ackermann :: Int -> Int -> Int 5 | ackermann 0 n = n + 1 6 | ackermann m 0 = ackermann (m - 1) 1 7 | ackermann m n = ackermann (m - 1) (ackermann m (n - 1)) 8 | -------------------------------------------------------------------------------- /Chapter06/echo-bs.hs: -------------------------------------------------------------------------------- 1 | -- file: echo-bs.hs 2 | 3 | import System.IO 4 | import qualified Data.ByteString as B 5 | 6 | main = do 7 | hSetBinaryMode stdin True 8 | hSetBinaryMode stdout True 9 | B.getContents >>= B.putStr 10 | -------------------------------------------------------------------------------- /Chapter04/scoped-type-variables.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | 3 | fun :: forall a b. (a -> b) -> [a] -> [a] -> ([b], [b]) 4 | fun f xs ys = let go :: [a] -> [b] 5 | go = map f 6 | in (go xs, go ys) 7 | -------------------------------------------------------------------------------- /Chapter06/echo-lbs.hs: -------------------------------------------------------------------------------- 1 | -- file: echo-lbs.hs 2 | 3 | import System.IO 4 | import qualified Data.ByteString.Lazy as L 5 | 6 | main = do 7 | hSetBinaryMode stdin True 8 | hSetBinaryMode stdout True 9 | L.getContents >>= L.putStr 10 | -------------------------------------------------------------------------------- /Chapter11/stencil.hs: -------------------------------------------------------------------------------- 1 | 2 | import Data.Array.Accelerate as A 3 | 4 | stFun ( (x1, x2, x3) 5 | , (y1, y2, y3) 6 | , (z1, z2, z3) ) = y1 >* 0.5 &&* 7 | y2 >* 0.5 &&* 8 | y3 >* 0.5 ? (1, 0) 9 | -------------------------------------------------------------------------------- /Chapter04/gadts.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE GADTs #-} 2 | 3 | data Value a where 4 | Boolean :: Bool -> Value Bool 5 | Not :: Value Bool -> Value Bool 6 | Numeric :: Num a => a -> Value a 7 | Sum :: Num a => Value a -> Value a -> Value a 8 | -------------------------------------------------------------------------------- /Chapter10/hs-fib.c: -------------------------------------------------------------------------------- 1 | /* file: hs-fib.c */ 2 | 3 | #include 4 | 5 | int fib_c(HsInt num) 6 | { 7 | if (num <= 2) 8 | { 9 | return 1; 10 | } 11 | else 12 | { 13 | return(fib_c(num - 1) + fib_c(num - 2)); 14 | } 15 | } 16 | 17 | -------------------------------------------------------------------------------- /Chapter02/map-fib.hs: -------------------------------------------------------------------------------- 1 | -- file: map-fib.hs 2 | 3 | import Data.IntMap as IM 4 | 5 | fib :: Int -> IntMap Int 6 | fib n = m where 7 | m = IM.fromList $ (1,1) : (2,1) : 8 | [ (i, IM.findWithDefault 0 (i-1) m + IM.findWithDefault 0 (i-2) m) 9 | | i <- [3..n] ] 10 | -------------------------------------------------------------------------------- /Chapter08/liberate-case.hs: -------------------------------------------------------------------------------- 1 | -- file: liberate-case.hs 2 | 3 | option = ('a', 'b') 4 | 5 | -- fun x = case option of 6 | -- (a, _) -> a : fun x 7 | 8 | fun x = case option of 9 | (a, _) -> a : (let f x' = a : f x' in f x) 10 | 11 | -------------------------------------------------------------------------------- /Chapter04/patternsynonyms.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE PatternSynonyms #-} 2 | 3 | pattern B1 a <- (a,_,_,_) 4 | pattern B2 a <- (_,a,_,_) 5 | pattern B3 a <- (_,_,a,_) 6 | pattern B4 a <- (_,_,_,a) 7 | 8 | fun (B1 True) = 1 9 | fun (B2 True) = 2 10 | fun (B3 True) = 3 11 | fun (B4 True) = 4 12 | -------------------------------------------------------------------------------- /Chapter07/ioref-supply.hs: -------------------------------------------------------------------------------- 1 | -- file: ioref-supply.hs 2 | 3 | import Data.IORef 4 | 5 | type Supply = IORef Int 6 | 7 | createSupply :: IO Supply 8 | createSupply = newIORef 0 9 | 10 | newUID :: Supply -> IO Int 11 | newUID supply = atomicModifyIORef' supply $ \uid -> (uid + 1, uid) 12 | -------------------------------------------------------------------------------- /Chapter09/compact-matrix.hs: -------------------------------------------------------------------------------- 1 | -- file compact-matrix.hs 2 | 3 | {-# LANGUAGE QuasiQuotes #-} 4 | 5 | import MatrixSplice 6 | 7 | m1, m2 :: [[Double]] 8 | 9 | m1 = [matrix| 10 | 1 2 11 | 2 1 12 | |] 13 | 14 | m2 = [matrix| 15 | 1.5 4.2 5 16 | 5.5 4.1 4 17 | 4.5 4 1 6 18 | |] 19 | -------------------------------------------------------------------------------- /Chapter09/reify-example.hs: -------------------------------------------------------------------------------- 1 | -- file: reify-example.hs 2 | 3 | {-# LANGUAGE TemplateHaskell #-} 4 | 5 | import SetterSplice 6 | 7 | data User = User 8 | { firstName :: String 9 | , lastName :: String 10 | , age :: Int 11 | } deriving Show 12 | 13 | deriveSetters ''User 14 | -------------------------------------------------------------------------------- /Chapter09/MatrixSplice.hs: -------------------------------------------------------------------------------- 1 | module MatrixSplice where 2 | 3 | import Language.Haskell.TH.Quote 4 | 5 | matrix :: QuasiQuoter 6 | matrix = QuasiQuoter { quoteExp = dataToExpQ (\_ -> Nothing) . parse } 7 | 8 | parse :: String -> [[Double]] 9 | parse = map (map read . words) . filter (/= "") . lines 10 | -------------------------------------------------------------------------------- /Chapter06/logging-t.hs: -------------------------------------------------------------------------------- 1 | -- file: logging-t.hs 2 | 3 | {-# LANGUAGE TemplateHaskell #-} 4 | 5 | import Data.Text (pack) 6 | import Control.Monad 7 | import Control.Monad.Logger 8 | 9 | app :: LoggingT IO () 10 | app = replicateM_ 500000 $ $logInfo (pack "msg") 11 | 12 | main = runStdoutLoggingT app2 13 | -------------------------------------------------------------------------------- /Chapter13/reactive-banana-fib.hs: -------------------------------------------------------------------------------- 1 | -- file: reactive-banana-fib.hs 2 | {-# LANGUAGE RecursiveDo #-} 3 | 4 | import Reactive.Banana 5 | 6 | fib :: Event () -> Moment (Behavior Int) 7 | fib step = mdo 8 | fib1 <- stepper 1 (fib2 <@ step) 9 | fib2 <- accumB 1 ((+) <$> fib1 <@ step) 10 | return fib1 11 | -------------------------------------------------------------------------------- /Chapter04/typefamilies.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeFamilies #-} 2 | 3 | import qualified Data.Text as T 4 | 5 | type family Elem container 6 | type instance Elem String = Char 7 | type instance Elem T.Text = Char 8 | 9 | 10 | 11 | type family Elem' container where 12 | Elem' String = Char 13 | Elem' T.Text = Char 14 | -------------------------------------------------------------------------------- /Chapter04/mr.hs: -------------------------------------------------------------------------------- 1 | -- file: mr.hs 2 | 3 | import qualified Data.List 4 | 5 | main = do 6 | -- let f = (1 +) 7 | -- let f = \x -> 1 + x 8 | let f x = (1 + x) 9 | 10 | print $ f (6 :: Int) 11 | print $ f (0.1 :: Double) 12 | 13 | let len = Data.List.genericLength [1..1000] 14 | print (len, len) 15 | -------------------------------------------------------------------------------- /Chapter07/ioref.hs: -------------------------------------------------------------------------------- 1 | -- ioref.hs 2 | 3 | import Data.IORef 4 | import Control.Concurrent 5 | 6 | fun ref c = do 7 | x <- readIORef ref 8 | writeIORef ref c 9 | putStr x 10 | fun ref c 11 | 12 | main = do 13 | ref <- newIORef "a" 14 | forkIO $ fun ref "a" 15 | forkIO $ fun ref "b" 16 | threadDelay 5000 17 | -------------------------------------------------------------------------------- /Chapter05/fib-list.hs: -------------------------------------------------------------------------------- 1 | 2 | import Control.Parallel 3 | 4 | fib :: Int -> Int 5 | fib n 6 | | n <= 1 = 1 7 | | otherwise = let a = fib (n - 1) 8 | b = fib (n - 2) 9 | in a + b 10 | 11 | main = do 12 | let fibs = [ fib x | x <- [1..40] ] :: [Int] 13 | foldr par () fibs `seq` print fibs 14 | -------------------------------------------------------------------------------- /Chapter10/ffi-c-var.hs: -------------------------------------------------------------------------------- 1 | -- file: ffi-c-var.hs 2 | 3 | import Foreign.C (CInt) 4 | import Foreign.Ptr (Ptr) 5 | import Foreign.Storable (peek) 6 | 7 | foreign import ccall unsafe "&" c_var :: Ptr CInt 8 | foreign import ccall unsafe update :: IO () 9 | 10 | main = do peek c_var >>= print 11 | update 12 | peek c_var >>= print 13 | 14 | -------------------------------------------------------------------------------- /Chapter08/cse.hs: -------------------------------------------------------------------------------- 1 | -- file: cse.hs 2 | 3 | import Control.Monad 4 | import Control.Concurrent.MVar 5 | import System.IO.Unsafe 6 | 7 | unsafeVar :: a -> MVar a 8 | unsafeVar i = unsafePerformIO (newMVar i) 9 | {-# NOINLINE unsafeVar #-} 10 | 11 | main = do 12 | let a = unsafeVar 5 13 | b = unsafeVar 5 14 | takeMVar a 15 | takeMVar b 16 | -------------------------------------------------------------------------------- /Chapter04/viewpatterns.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ViewPatterns #-} 2 | 3 | funky :: [Int] -> String 4 | funky (length -> 0) = "Empty list!" 5 | funky (last -> 4) = "Ends in four!" 6 | funky (sum -> n) = "Sum is " ++ show n 7 | 8 | -- funky xs | 0 <- length xs = "Empty list!" 9 | -- | 4 <- last xs = "Ends in four!" 10 | -- | n <- sum xs = "Sum is " ++ show n 11 | -------------------------------------------------------------------------------- /Chapter06/pipes-exceptions.hs: -------------------------------------------------------------------------------- 1 | -- file: pipes-exceptions.hs 2 | 3 | import Control.Exception 4 | import Pipes 5 | import GHC.IO.Exception (IOException(..)) 6 | 7 | tolerantStdinLn :: Producer' String IO () 8 | tolerantStdinLn = do 9 | x <- lift $ try readLn 10 | case x of 11 | Left e@IOError{} -> return () 12 | Right ln -> yield ln >> tolerantStdinLn 13 | -------------------------------------------------------------------------------- /Chapter09/splice-testing.hs: -------------------------------------------------------------------------------- 1 | -- file splice-testing.hs 2 | {-# LANGUAGE TemplateHaskell #-} 3 | 4 | import MySplices 5 | 6 | two :: Int 7 | two = $(pure myExp) + $(pure myExp) 8 | 9 | -- n = 1 10 | $(pure [myDec]) 11 | 12 | f :: (Int, Int) -> String 13 | f $(pure myPat) = "1 and 1" 14 | f _ = "something else" 15 | 16 | mint :: $(pure myType) 17 | mint = Just two 18 | 19 | -------------------------------------------------------------------------------- /Chapter03/heap-profiling.hs: -------------------------------------------------------------------------------- 1 | -- file: heap-profiling.hs 2 | 3 | sin' :: Double -> Double 4 | sin' x = go 0 x where 5 | go n x 6 | | n > precision = x 7 | | otherwise = go (n + 1) $ x + 8 | (-1) ** n * x ** (2 * n + 1) / factorial (2 * n + 1) 9 | 10 | precision = 800 11 | 12 | factorial n = product [1..n] 13 | 14 | main = print $ sum $ map sin' [0,0.1..1] 15 | -------------------------------------------------------------------------------- /Chapter06/readwrite-bs.hs: -------------------------------------------------------------------------------- 1 | -- file: readwrite-bs.hs 2 | {-# LANGUAGE OverloadedStrings #-} 3 | import System.IO 4 | import qualified Data.ByteString as B 5 | 6 | main = do 7 | hSetBinaryMode stdin True 8 | hSetBinaryMode stdout True 9 | B.writeFile "file.txt" "old" 10 | old <- B.readFile "file.txt" 11 | B.writeFile "file.txt" "new" 12 | B.putStr old 13 | 14 | -------------------------------------------------------------------------------- /Chapter10/ffi-funptr.hs: -------------------------------------------------------------------------------- 1 | -- file: ffi-funptr.hs 2 | 3 | import Foreign.Ptr (FunPtr) 4 | 5 | foreign import ccall "math.h & cos" 6 | p_cos :: FunPtr (Double -> Double) 7 | 8 | foreign import ccall "dynamic" 9 | mkF :: FunPtr (Double -> Double) -> (Double -> Double) 10 | 11 | foreign import ccall "wrapper" 12 | toF :: (Double -> Double) -> IO (FunPtr (Double -> Double)) 13 | 14 | -------------------------------------------------------------------------------- /Chapter08/weak-threadid.hs: -------------------------------------------------------------------------------- 1 | -- file: weak-threadid.hs 2 | 3 | import System.Mem.Weak 4 | import Control.Concurrent 5 | import Control.Concurrent.MVar 6 | 7 | main = do 8 | tid <- forkFinally (do { var <- newEmptyMVar 9 | ; takeMVar (var :: MVar ()) 10 | }) print >>= mkWeakThreadId 11 | threadDelay 10000000 12 | print =<< deRefWeak tid 13 | -------------------------------------------------------------------------------- /Chapter10/dyn_fun_export.c: -------------------------------------------------------------------------------- 1 | /* file: dyn_fun_export.c */ 2 | 3 | #include 4 | #include 5 | 6 | int main(int argc, char *argv[]) { 7 | void *dl = dlopen("./libfunexport.so", RTLD_LAZY); 8 | void (*hs_init)(int *argc, char **argv[]) = dlsym(dl, "hs_init"); 9 | hs_init(&argc, &argv); 10 | int (*fun)(int a, int b) = dlsym(dl, "fun"); 11 | printf("%d\n", fun(1, 2)); 12 | } 13 | 14 | -------------------------------------------------------------------------------- /Chapter02/bytestring-perf.hs: -------------------------------------------------------------------------------- 1 | -- file: bytestring-perf.hs 2 | -- ghc -rtsopts -O bytestring-perf.hs && time ./bytestring-perf +RTS -s < /dev/zero 3 | 4 | import qualified Data.ByteString as B 5 | import System.IO (stdin) 6 | 7 | go :: Int -> Int -> IO Int 8 | go 0 s = return $! s 9 | go n s = do bs <- B.hGet stdin (1024 * 1024) 10 | go (n-1) $! B.length bs + s 11 | 12 | main = go 2048 0 >>= print 13 | -------------------------------------------------------------------------------- /Chapter02/backtracking-list.hs: -------------------------------------------------------------------------------- 1 | -- file: backtracking-list.hs 2 | 3 | import Control.Monad (guard) 4 | 5 | special_pythagorean :: Int -> [(Int,Int,Int)] 6 | special_pythagorean n = do 7 | a <- [1 .. n] 8 | b <- [a + 1 .. n] 9 | c <- [b + 1 .. n] 10 | guard (a + b + c == n) 11 | guard (a ^ 2 + b ^ 2 == c ^ 2) 12 | return (a, b, c) 13 | 14 | main = print $ head $ special_pythagorean 1000 15 | -------------------------------------------------------------------------------- /Chapter09/ConstSplices.hs: -------------------------------------------------------------------------------- 1 | module ConstSplices where 2 | 3 | import Language.Haskell.TH 4 | 5 | constN :: Int -> Q Dec 6 | constN nth = do 7 | exp <- constExp nth 8 | let name = mkName $ "const" ++ show nth 9 | return $ FunD name [ Clause [] (NormalB exp) [] ] 10 | 11 | constExp :: Int -> Q Exp 12 | constExp nth = do 13 | a <- newName "a" 14 | return $ LamE (VarP a : replicate nth WildP) (VarE a) 15 | 16 | -------------------------------------------------------------------------------- /Chapter02/seq-memory-usage-gnuplot.txt: -------------------------------------------------------------------------------- 1 | set datafile separator "," 2 | set autoscale fix 3 | set key inside right center 4 | 5 | set xtics 0,10,120 6 | set xtics add ("4" 4) 7 | 8 | set title "Performance with different buffer sizes" 9 | set ytics 0,0.5,4.5 10 | set yrange [0:3.6] 11 | set arrow from 4, graph 0 to 4, graph 1 nohead 12 | plot 'seq-memory-usage.csv' using 1:2 title "Heap usage (gigabytes)" with lines 13 | 14 | -------------------------------------------------------------------------------- /Chapter01/worker_wrapper.hs: -------------------------------------------------------------------------------- 1 | 2 | import System.Environment (getArgs) 3 | 4 | isPrime :: Int -> Bool 5 | isPrime n 6 | | n <= 1 = False 7 | | n <= 3 = True 8 | | otherwise = worker 2 9 | where 10 | worker i | i >= n = True 11 | | mod n i == 0 = False 12 | | otherwise = worker (i+1) 13 | 14 | main = getArgs >>= putStrLn . show . isPrime . read . head 15 | -------------------------------------------------------------------------------- /Chapter02/seq-memory-usage.csv: -------------------------------------------------------------------------------- 1 | 1,0.560 2 | 2,1.680 3 | 3,2.160 4 | 4,1.960 5 | 5,2.080 6 | 6,2.320 7 | 8,2.320 8 | 9,2.770 9 | 11,2.770 10 | 12,2.880 11 | 14,2.880 12 | 15,2.890 13 | 17,2.890 14 | 18,2.930 15 | 20,2.930 16 | 21,3.090 17 | 29,3.090 18 | 30,3.240 19 | 38,3.240 20 | 39,3.280 21 | 47,3.280 22 | 48,3.285 23 | 56,3.285 24 | 57,3.297 25 | 65,3.297 26 | 66,3.350 27 | 92,3.350 28 | 93,3.400 29 | 119,3.400 30 | 120,3.413 31 | -------------------------------------------------------------------------------- /Chapter02/list-fusion.hs: -------------------------------------------------------------------------------- 1 | -- file: list-fusion.hs 2 | 3 | inc :: [Int] -> [Int] 4 | inc (x:xs) = x + 1 : inc xs 5 | inc [] = [] 6 | 7 | summer :: Int -> [Int] -> [Int] 8 | summer a (x:xs) = let r = a + x in r `seq` r : summer r xs 9 | summer _ [] = [] 10 | 11 | main = do 12 | -- print $ sum $ summer 0 $ inc [1..100000] -- 24 MB, 87% productivity 13 | print $ sum $ scanl (+) 0 $ map (+1) [1..100000] -- 6 MB, 96% productivity 14 | -------------------------------------------------------------------------------- /Chapter02/bytestring-lazy-perf.hs: -------------------------------------------------------------------------------- 1 | -- file: bytestring-lazy-perf.hs 2 | 3 | import qualified Data.ByteString.Lazy as B 4 | import qualified Data.ByteString as S 5 | import System.IO (stdin) 6 | 7 | size = 2048 * 1024 * 1024 8 | 9 | go :: Int -> [S.ByteString] -> Int 10 | go s (c:cs) | s >= size = s 11 | | otherwise = go (s + S.length c) cs 12 | 13 | main = do 14 | bs <- B.hGetContents stdin 15 | print $ go 0 (B.toChunks bs) 16 | -------------------------------------------------------------------------------- /Chapter05/ivar-testing.hs: -------------------------------------------------------------------------------- 1 | 2 | import Control.Monad.Par 3 | 4 | f :: (NFData a, NFData b) => a -> b -> (a, b) 5 | f c1 c2 = runPar $ do 6 | i1 <- new 7 | i2 <- new 8 | fork $ put i1 c1 9 | fork $ put i2 c2 10 | r1 <- get i1 11 | r2 <- get i2 12 | return (r1, r2) 13 | 14 | 15 | main = print $ 16 | runPar $ do 17 | iv <- new 18 | put iv (0 :: Int) 19 | put iv 1 20 | get iv 21 | 22 | -------------------------------------------------------------------------------- /Chapter05/rows.hs: -------------------------------------------------------------------------------- 1 | -- plain: 3.7s 2 | 3 | import Control.Parallel.Strategies 4 | 5 | minmax :: [Int] -> (Int, Int) 6 | minmax xs = (minimum xs, maximum xs) 7 | 8 | main = do 9 | let matrix = [ [1..1000001], [2..2000002], [3..2000003] 10 | , [4..2000004], [5..2000005], [6..2000006] 11 | , [7..2000007] ] 12 | minmaxes = map minmax matrix 13 | 14 | in print (minmaxes `using` parTraversable rdeepseq) 15 | -------------------------------------------------------------------------------- /.gitattributes: -------------------------------------------------------------------------------- 1 | # Auto detect text files and perform LF normalization 2 | * text=auto 3 | 4 | # Custom for Visual Studio 5 | *.cs diff=csharp 6 | 7 | # Standard to msysgit 8 | *.doc diff=astextplain 9 | *.DOC diff=astextplain 10 | *.docx diff=astextplain 11 | *.DOCX diff=astextplain 12 | *.dot diff=astextplain 13 | *.DOT diff=astextplain 14 | *.pdf diff=astextplain 15 | *.PDF diff=astextplain 16 | *.rtf diff=astextplain 17 | *.RTF diff=astextplain 18 | -------------------------------------------------------------------------------- /Chapter14/fclabels.hs: -------------------------------------------------------------------------------- 1 | -- file: fclabels.hs 2 | {-# LANGUAGE TemplateHaskell #-} 3 | 4 | import Prelude hiding (id, (.)) 5 | import Control.Category 6 | import Data.Label 7 | 8 | data Member = Member 9 | { _name :: String 10 | , _task :: String 11 | } deriving Show 12 | 13 | data Team = Team 14 | { _leader :: Member 15 | , _memebrs :: [Member] 16 | } deriving Show 17 | 18 | mkLabels [''Member, ''Team] 19 | -------------------------------------------------------------------------------- /Chapter03/heap-profiling-optimized.hs: -------------------------------------------------------------------------------- 1 | -- file: heap-profiling-optimized.hs 2 | {-# LANGUAGE BangPatterns #-} 3 | 4 | import Data.List (foldl') 5 | 6 | sin' :: Double -> Double 7 | sin' x = go 0 x where 8 | go n !x 9 | | n > precision = x 10 | | otherwise = go (n + 1) $ x + 11 | (-1) ** n * x ** (2 * n + 1) / factorial (2 * n + 1) 12 | 13 | precision = 800 14 | 15 | factorial n = foldl' (*) 1 [1..n] 16 | 17 | main = print $ sum $ map sin' [0,0.1..1] 18 | -------------------------------------------------------------------------------- /Chapter03/prof-basics.hs: -------------------------------------------------------------------------------- 1 | -- file: prof-basics.hs 2 | 3 | sma :: [Double] -> [Double] 4 | -- sma (x0:x1:xs) = (x0 + x1) / 2 : sma (x1:xs) 5 | sma (x0:x1:xs) = let r = (x0 + x1) / 2 in r `seq` r : sma (x1:xs) 6 | sma xs = xs 7 | 8 | main = 9 | -- let a = {-# SCC "list-" #-} [1..1000000] 10 | -- b = {-# SCC "sma-" #-} sma a 11 | -- c = {-# SCC "sum-" #-} sum b 12 | let a = [1..1000000] 13 | b = sma a 14 | c = sum b 15 | in print c 16 | -------------------------------------------------------------------------------- /Chapter09/th-testing.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# LANGUAGE TemplateHaskell #-} 3 | 4 | import Language.Haskell.TH 5 | import ConstSplices 6 | import Control.Monad (forM) 7 | 8 | 9 | $(forM [1..15] constN) 10 | 11 | 12 | idExp :: Q Exp 13 | idExp = [| \x -> x |] 14 | 15 | main = do 16 | putStrLn $ show $([| pi + 2 |]) 17 | putStrLn $ $(constExp 2) "hello" () 42 18 | 19 | -- const1 :: a -> b -> a 20 | -- 21 | -- const2 :: a -> b -> c -> a 22 | -- 23 | -- const3 :: a -> b -> c -> d -> a 24 | -------------------------------------------------------------------------------- /Chapter09/MySplices.hs: -------------------------------------------------------------------------------- 1 | module MySplices where 2 | 3 | import Language.Haskell.TH 4 | 5 | -- Expression: literal 1 6 | myExp :: Exp 7 | myExp = LitE (IntegerL 1) 8 | 9 | -- Declaration: n = 1 10 | myDec :: Dec 11 | myDec = ValD (VarP (mkName "n")) (NormalB myExp) [] 12 | 13 | -- Pattern: (1, 2) 14 | myPat :: Pat 15 | myPat = TupP [LitP (IntegerL 1), LitP (IntegerL 2)] 16 | 17 | -- Type: Maybe Int 18 | myType :: Type 19 | myType = AppT (ConT (mkName "Maybe")) (ConT (mkName "Int")) 20 | 21 | -------------------------------------------------------------------------------- /Chapter04/lazypat.hs: -------------------------------------------------------------------------------- 1 | -- file: lazypat.hs 2 | 3 | server :: [Int] -> [Int] 4 | server (y:ys) = process y : server ys 5 | where process n = n ^ 2 6 | 7 | client :: Int -> [Int] -> [Int] 8 | client initial ~(x:xs) = initial : client (next x) xs 9 | where next n = n `mod` 65534 10 | 11 | requests :: [Int] 12 | requests = client initial responses 13 | where initial = 2 14 | 15 | responses :: [Int] 16 | responses = server requests 17 | 18 | main = 19 | print $ take 10 responses 20 | 21 | -------------------------------------------------------------------------------- /Chapter05/fib-eval.hs: -------------------------------------------------------------------------------- 1 | 2 | import Control.Parallel.Strategies 3 | 4 | fib :: Int -> Int 5 | fib n 6 | | n <= 1 = 1 7 | | otherwise = let a = fib (n - 1) 8 | b = fib (n - 2) 9 | in a + b 10 | 11 | main = do 12 | let res = runEval $ do 13 | x <- rpar $ fib 37 14 | y <- rpar $ fib 38 15 | z <- rpar $ fib 39 16 | w <- rpar $ fib 40 17 | return (x, y, z, w) 18 | res `seq` print res 19 | -------------------------------------------------------------------------------- /Chapter07/forking.hs: -------------------------------------------------------------------------------- 1 | -- file: forking.hs 2 | 3 | import Control.Concurrent 4 | 5 | -- outputs nothing 6 | test1 = do 7 | tid <- forkIO $ threadDelay 100000000 8 | killThread tid 9 | 10 | -- outputs exception: Prelude.undefined 11 | test2 = do 12 | tid <- forkIO $ undefined 13 | killThread tid 14 | 15 | -- waits for the thread to exit 16 | test3 = do 17 | mvar <- newEmptyMVar 18 | tid <- threadDelay 5000000 `forkFinally` \_ -> putMVar mvar () 19 | takeMVar mvar 20 | -------------------------------------------------------------------------------- /Chapter07/mvar-reserve.hs: -------------------------------------------------------------------------------- 1 | -- file: mvar-reserve.hs 2 | 3 | import Control.Exception (bracket) 4 | import Control.Concurrent (forkIO) 5 | import Control.Concurrent.MVar 6 | 7 | printing lock str = 8 | bracket (takeMVar lock) (\i -> putMVar lock $! i+1) (\_ -> print str) 9 | 10 | main = do 11 | lock <- newMVar 1 :: IO (MVar Int) 12 | forkIO $ printing lock "output a" 13 | forkIO $ printing lock "output b" 14 | forkIO $ printing lock "output c" 15 | takeMVar lock >>= print 16 | -------------------------------------------------------------------------------- /Chapter02/sum_array_mutable.hs: -------------------------------------------------------------------------------- 1 | -- file: sum_array_mutable.hs 2 | {-# LANGUAGE FlexibleContexts #-} 3 | 4 | import Control.Monad.ST 5 | import Data.Array.ST 6 | 7 | count_stuarray :: Int -> Int 8 | count_stuarray n = runST $ do 9 | ref <- newArray (0,0) 0 :: ST s (STUArray s Int Int) 10 | let go 0 = readArray ref 0 11 | go i = do s <- readArray ref 0 12 | writeArray ref 0 $ s + i 13 | go (i-1) 14 | go n 15 | 16 | main = print $ count_stuarray 10000000 17 | -------------------------------------------------------------------------------- /Chapter06/pipes.hs: -------------------------------------------------------------------------------- 1 | -- file: pipes.hs 2 | 3 | import Control.Monad 4 | import System.Random (randomIO) 5 | import Pipes 6 | 7 | randoms :: Producer' Int IO () 8 | randoms = forever (liftIO randomIO >>= yield) 9 | 10 | taking :: Monad m => Int -> Pipe a a m () 11 | taking 0 = return () 12 | taking n = await >>= yield >> taking (n - 1) 13 | 14 | printing :: Show a => Consumer' a IO () 15 | printing = forever (await >>= liftIO . print) 16 | 17 | effect :: Effect IO () 18 | effect = randoms >-> taking 5 >-> printing 19 | -------------------------------------------------------------------------------- /Chapter07/concurrently.hs: -------------------------------------------------------------------------------- 1 | -- file: concurrently.hs 2 | 3 | import Control.Applicative 4 | import Control.Concurrent 5 | import Control.Concurrent.Async 6 | 7 | lineOrTimeOut :: Concurrently (Either String ()) 8 | lineOrTimeOut = 9 | Concurrently (fmap Left getLine) <|> 10 | Concurrently (fmap Right (threadDelay 5000000)) 11 | 12 | threeLines :: Concurrently (String, String, String) 13 | threeLines = (,,) 14 | <$> Concurrently getLine 15 | <*> Concurrently getLine 16 | <*> Concurrently getLine 17 | -------------------------------------------------------------------------------- /Chapter10/callbacks.hs: -------------------------------------------------------------------------------- 1 | -- file: callbacks.hs 2 | 3 | import Foreign.Ptr (FunPtr) 4 | 5 | foreign import ccall safe -- (1) 6 | procedure :: FunPtr (Double -> IO ()) -> Double -> IO () 7 | 8 | foreign import ccall "wrapper" -- (2) 9 | toCallback :: (Double -> IO ()) -> IO (FunPtr (Double -> IO ())) 10 | 11 | printRes :: Double -> IO () -- (3) 12 | printRes x = putStrLn $ "Result: " ++ show x 13 | 14 | main = do 15 | cont <- toCallback printRes -- (4) 16 | procedure cont 5 -- (5) 17 | procedure cont 8 18 | 19 | -------------------------------------------------------------------------------- /Chapter05/fib.hs: -------------------------------------------------------------------------------- 1 | import Control.Parallel 2 | 3 | fib :: Int -> Int 4 | fib n 5 | | n <= 1 = 1 6 | | n <= 28 = fib (n - 1) + fib (n - 2) 7 | | otherwise = let a = fib (n - 1) 8 | b = fib (n - 2) 9 | in a `par` b `par` a + b 10 | -- in a + b 11 | 12 | main = do 13 | let x = fib 37 14 | y = fib 38 15 | z = fib 39 16 | w = fib 40 17 | 18 | x `par` y `par` z `par` w `pseq` print (x, y, z, w) 19 | -- print (x,y,z,w) 20 | -------------------------------------------------------------------------------- /Chapter11/tuples.hs: -------------------------------------------------------------------------------- 1 | -- file: tuples.hs 2 | 3 | 4 | import Data.Array.Accelerate as A 5 | import Data.Array.Accelerate.CUDA 6 | 7 | f1 :: (Exp Int, Exp Int) -> Acc (Scalar Int) 8 | f1 (x, y) = unit (x + y) 9 | 10 | f2 :: Exp (Int, Int) -> Acc (Scalar Int) 11 | f2 e = let (x, y) = unlift e :: (Exp Int, Exp Int) 12 | in unit (x + y) 13 | 14 | main = let 15 | xs = [run $ f1 (x, y) | x <- [1..10], y <- [1..10]] 16 | ys = [run $ f2 $ lift ((x, y) :: (Int, Int)) | x <- [1..10], y <- [1..10]] 17 | in print xs 18 | -------------------------------------------------------------------------------- /Chapter07/newtype-monadbasecontrol.hs: -------------------------------------------------------------------------------- 1 | -- file: newtype-monadbasecontrol.hs 2 | -- 3 | -- this doesn't compile as such and that's intentional 4 | 5 | newtype Handler a = Handler 6 | { unHandler :: LoggingT (StateT HandlerState (ReaderT Config IO)) a } 7 | deriving ( ... ) 8 | 9 | instance MonadBaseControl IO Handler where 10 | type StM Handler a = StM (LoggingT (StateT HandlerState (ReaderT Config IO))) a 11 | liftBaseWith f = Handler $ liftBaseWith $ \q -> f (q . unHandler) 12 | restoreM = Handler . restoreM 13 | -------------------------------------------------------------------------------- /Chapter07/stm-either.hs: -------------------------------------------------------------------------------- 1 | -- file: stm-either.hs 2 | 3 | import Control.Concurrent 4 | import Control.Concurrent.STM 5 | 6 | eitherOr :: IO a -> IO b -> IO (Either a b) 7 | eitherOr job_a job_b = do 8 | a <- doAsyncSTM job_a 9 | b <- doAsyncSTM job_b 10 | atomically $ fmap Left (takeTMVar a) `orElse` fmap Right (takeTMVar b) 11 | 12 | doAsyncSTM :: IO a -> IO (TMVar a) 13 | doAsyncSTM job = do 14 | tmvar <- newEmptyTMVarIO 15 | forkIO $ do r <- job 16 | atomically $ putTMVar tmvar r 17 | return tmvar 18 | -------------------------------------------------------------------------------- /Chapter05/spawn.hs: -------------------------------------------------------------------------------- 1 | import Control.Monad.Par 2 | 3 | type A = Int 4 | type B = Int 5 | type C = Int 6 | type D = Int 7 | 8 | computation :: A -> (A -> B) -> (A -> C) -> (B -> C -> D) -> Par D 9 | computation fa fb fc fd = do 10 | av <- newFull fa -- (1) 11 | bv <- spawn $ do a <- get av -- (2) 12 | return $ fb a 13 | cv <- spawn $ do a <- get av -- (3) 14 | return $ fc a 15 | b <- get bv -- (4) 16 | c <- get cv 17 | return (fd b c) -- (5) 18 | -------------------------------------------------------------------------------- /Chapter06/ptr.hs: -------------------------------------------------------------------------------- 1 | 2 | import System.IO 3 | import Foreign.Ptr (Ptr) 4 | import Foreign.Storable (Storable(sizeOf, peek)) 5 | import Foreign.Marshal (alloca) 6 | 7 | main = withBinaryFile "/dev/random" ReadMode $ alloca . process 8 | where 9 | process :: Handle -> Ptr Int -> IO () 10 | process h ptr = go where 11 | go = do 12 | count <- hGetBuf h ptr (sizeOf (undefined :: Int)) 13 | if count > 0 14 | then do num <- peek ptr 15 | print num 16 | go 17 | else return () 18 | -------------------------------------------------------------------------------- /Chapter14/fgl.hs: -------------------------------------------------------------------------------- 1 | -- file: fgl.hs 2 | 3 | import Data.Graph.Inductive.Graph 4 | import Data.Graph.Inductive.PatriciaTree 5 | 6 | build :: Int -> Gr Int () 7 | build 0 = empty 8 | build n = (to, n, n, from) & build (n - 1) 9 | where 10 | to = [] 11 | from = [ ((), m) | m <- [n - 1, n - 2 .. 0] ] 12 | 13 | sumNodes :: [Int] -> Gr Int () -> Int 14 | sumNodes [] _ = 0 15 | sumNodes (n:ns) gr = case mctx of 16 | Nothing -> sumNodes ns gr 17 | Just (_,_,x,from) -> x + sumNodes (ns ++ [ m | (_,m) <- from ]) gr' 18 | where 19 | (mctx, gr') = match n gr 20 | -------------------------------------------------------------------------------- /Chapter08/full-laziness.hs: -------------------------------------------------------------------------------- 1 | -- file: full-laziness.hs 2 | 3 | import Control.Monad 4 | import Control.Concurrent.MVar 5 | import System.IO.Unsafe 6 | 7 | unsafeVar :: a -> MVar a 8 | unsafeVar i = unsafePerformIO (newMVar i) 9 | {-# NOINLINE unsafeVar #-} 10 | 11 | unsafeVar' :: b -> a -> MVar a 12 | unsafeVar' _ i = unsafePerformIO (newMVar i) 13 | {-# NOINLINE unsafeVar' #-} 14 | 15 | main = do 16 | -- xs <- replicateM 10 (return (unsafeVar 1)) 17 | -- xs <- forM [1..10] $ \_ -> return (unsafeVar 1) 18 | xs <- forM [1..10] $ \i -> return (unsafeVar' i 1) 19 | mapM_ takeMVar xs 20 | 21 | -------------------------------------------------------------------------------- /Chapter05/spawnio.hs: -------------------------------------------------------------------------------- 1 | 2 | import Control.Monad.IO.Class 3 | import Control.Monad.Par.IO 4 | import Control.Monad.Par.Class 5 | 6 | type A = Int 7 | type B = Int 8 | type C = Int 9 | type D = Int 10 | 11 | computationIO :: IO A -> (A -> IO B) -> (A -> IO C) -> (B -> C -> IO D) -> ParIO D 12 | computationIO fa fb fc fd = do 13 | av <- newFull =<< liftIO fa 14 | bv <- spawn $ do a <- get av 15 | liftIO $ fb a 16 | cv <- spawn $ do a <- get av 17 | liftIO $ fc a 18 | b <- get bv 19 | c <- get cv 20 | liftIO (fd b c) 21 | -------------------------------------------------------------------------------- /Chapter07/transactionm.hs: -------------------------------------------------------------------------------- 1 | -- file: transactionm.hs 2 | 3 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 4 | 5 | import Control.Monad.Base 6 | import Control.Monad.Trans.Reader 7 | import Control.Concurrent.STM 8 | 9 | import Control.Monad.Reader 10 | 11 | type TransactionM a = ReaderT String STM a 12 | 13 | newtype TransactionM' a = TransactionM' (ReaderT String STM a) 14 | deriving ( Functor, Applicative, Monad 15 | , MonadReader String, MonadBase STM ) 16 | 17 | transaction :: TVar a -> TransactionM' (Maybe a) 18 | transaction var = do 19 | liftBase $ readTVar var 20 | return undefined 21 | -------------------------------------------------------------------------------- /Chapter11/matrix-fixed.hs: -------------------------------------------------------------------------------- 1 | -- file: matrix-fixed.hs 2 | 3 | {-# LANGUAGE TypeOperators #-} 4 | 5 | import Data.Array.Accelerate as A 6 | 7 | type Matrix = Array DIM2 Double 8 | 9 | matProduct :: Acc Matrix -> Acc Matrix -> Acc Matrix 10 | matProduct a b = let 11 | 12 | Z :. mx :. _ = unlift (shape a) :: Z :. Exp Int :. Exp Int 13 | Z :. _ :. my = unlift (shape b) :: Z :. Exp Int :. Exp Int 14 | 15 | aRep = A.replicate (lift $ Z :. All :. my :. All) a 16 | bRep = A.replicate (lift $ Z :. mx :. All :. All) (A.transpose b) 17 | 18 | in A.fold (+) 0 19 | $ A.zipWith (*) aRep bRep 20 | -------------------------------------------------------------------------------- /Chapter06/fastlogger.hs: -------------------------------------------------------------------------------- 1 | -- file: fastlogger.hs 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | import Data.Monoid 5 | import System.Log.FastLogger 6 | 7 | type MyLogger = String -> IO () 8 | 9 | app :: MyLogger -> IO () 10 | app log = do 11 | log "Haskell is fun" 12 | log "and logging is fun too!" 13 | 14 | main = do 15 | getTimeStamp <- newTimeCache "%Y-%M-%d %H:%m" 16 | withTimedFastLogger getTimeStamp (LogStdout defaultBufSize) $ 17 | \logger -> app (logger . logFormat) 18 | 19 | logFormat :: String -> FormattedTime -> LogStr 20 | logFormat msg time = toLogStr time <> ": " <> toLogStr msg <> "\n" 21 | -------------------------------------------------------------------------------- /Chapter02/noise.hs: -------------------------------------------------------------------------------- 1 | -- file: noise.hs 2 | 3 | import ListT -- package list-t 4 | import System.Random -- package random 5 | import Control.Monad.Trans (lift) -- package mtl 6 | import Control.Concurrent (threadDelay) 7 | 8 | noise :: [Double] -> ListT IO Double 9 | noise pat = do 10 | pat' <- ListT.repeat pat 11 | x <- ListT.fromFoldable pat' 12 | lift $ do delay <- randomIO 13 | threadDelay (mod delay 300000) 14 | randomRIO (x - 0.5, x + 0.5) 15 | 16 | main = let generator = noise [1,5,10,5] 17 | in ListT.traverse_ print generator >> print (E 0) 18 | -------------------------------------------------------------------------------- /Chapter04/fundeps.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE FunctionalDependencies #-} 4 | 5 | import qualified Data.Text as T 6 | import qualified Data.ByteString as BS 7 | import Data.Word (Word8) 8 | 9 | -- class Index container index elem where 10 | class Index container index elem | container -> elem where 11 | index :: container -> index -> elem 12 | 13 | instance Index String Int Char where 14 | index = (!!) 15 | 16 | instance Index T.Text Int Char where 17 | index = T.index 18 | 19 | instance Index BS.ByteString Int Word8 where 20 | index = BS.index 21 | -------------------------------------------------------------------------------- /Chapter11/matrix.hs: -------------------------------------------------------------------------------- 1 | -- file: matrix.hs 2 | 3 | {-# LANGUAGE TypeOperators #-} 4 | 5 | import Data.Array.Accelerate as A 6 | 7 | type Matrix = Array DIM2 Double 8 | 9 | matProduct :: Acc Matrix -> Acc Matrix -> Acc Matrix 10 | matProduct a b = let 11 | 12 | Z :. mx :. _ = unlift (shape a) :: Z :. Exp Int :. Exp Int 13 | Z :. _ :. my = unlift (shape b) :: Z :. Exp Int :. Exp Int 14 | 15 | in generate (index2 mx my) $ \ix -> 16 | let Z :. x :. y = unlift ix :: Z :. Exp Int :. Exp Int 17 | s1 = lift (Z :. x :. All) 18 | s2 = lift (Z :. All :. y) 19 | in the $ A.sum $ A.zipWith (*) (slice a s1) (slice b s2) 20 | -------------------------------------------------------------------------------- /Chapter07/mvar-async.hs: -------------------------------------------------------------------------------- 1 | -- file: mvar-async.hs 2 | 3 | import Control.Concurrent 4 | import Control.Exception 5 | 6 | doAsync :: MVar a -> IO a -> IO ThreadId 7 | doAsync mvar job = forkIO $ do 8 | r <- job 9 | putMVar mvar r 10 | 11 | main = do 12 | mvars <- sequence [newEmptyMVar, newEmptyMVar] 13 | sequence [ doAsync mvar getLine | mvar <- mvars ] 14 | results <- mapM takeMVar mvars 15 | print results 16 | 17 | doAsyncSafe :: MVar (Either SomeException a) -> IO a -> IO ThreadId 18 | doAsyncSafe mvar job = mask_ $ forkIOWithUnmask $ \unmask -> 19 | do { r <- unmask job; putMVar mvar (Right r) } 20 | `catch` \e -> putMVar mvar (Left e) 21 | -------------------------------------------------------------------------------- /Chapter04/associated.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE MultiParamTypeClasses #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | 5 | import qualified Data.Text as T 6 | import qualified Data.ByteString as BS 7 | import Data.Word (Word8) 8 | 9 | class Index container index where 10 | type Elem container 11 | index :: container -> index -> Elem container 12 | 13 | instance Index String Int where 14 | type Elem String = Char 15 | index = (!!) 16 | 17 | instance Index T.Text Int where 18 | type Elem T.Text = Char 19 | index = T.index 20 | 21 | instance Index BS.ByteString Int where 22 | type Elem BS.ByteString = Word8 23 | index = BS.index 24 | -------------------------------------------------------------------------------- /Chapter02/string-builder.hs: -------------------------------------------------------------------------------- 1 | 2 | type Builder = [Char] -> [Char] 3 | 4 | toString :: Builder -> String 5 | toString b = b [] 6 | 7 | string :: String -> Builder 8 | string str = (str ++) 9 | 10 | data Tree = Tree !(Int, Tree) !(Int, Tree) 11 | | Leaf !String 12 | 13 | encodeTree :: Tree -> Builder 14 | encodeTree (Tree (l1, t1) (l2, t2)) = 15 | string "[" . string (show l1) . string ":" . encodeTree t1 . 16 | string "," . string (show l2) . string ":" . encodeTree t2 . string "]" 17 | encodeTree (Leaf str) = string "\"" . string str . string "\"" 18 | 19 | main = putStrLn $ toString $ encodeTree $ 20 | Tree (1,Leaf "one") (2, Tree (3,Leaf "three") (4,Leaf "four")) 21 | -------------------------------------------------------------------------------- /Chapter10/struct-marshal.hsc: -------------------------------------------------------------------------------- 1 | -- file: struct-marshal.hsc 2 | 3 | #include 4 | 5 | import Foreign.Storable 6 | 7 | data Some = Some { a :: Int, b :: Double } 8 | 9 | -- Define the #alignment macro for GHC 7. It is available by default 10 | -- starting with GHC 8.0.1. 11 | #let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__) 12 | 13 | instance Storable Some where 14 | sizeOf _ = (#size Some) 15 | alignment _ = (#alignment Some) 16 | peek ptr = Some <$> (#peek Some, a) ptr 17 | <*> (#peek Some, b) ptr 18 | poke ptr some = do 19 | (#poke Some, a) ptr (a some) 20 | (#poke Some, b) ptr (b some) 21 | -------------------------------------------------------------------------------- /Chapter01/class_performance.hs: -------------------------------------------------------------------------------- 1 | 2 | class Some a where 3 | next :: a -> a -> a 4 | 5 | instance Some Double where 6 | next a b = (a + b) / 2 7 | 8 | goGeneral :: Some a => Int -> a -> a 9 | goGeneral 0 x = x 10 | goGeneral n x = goGeneral (n-1) (next x x) 11 | 12 | goSpecialized :: Int -> Double -> Double 13 | goSpecialized 0 x = x 14 | goSpecialized n x = goSpecialized (n-1) (next' x x) 15 | 16 | next' :: Double -> Double -> Double 17 | next' a b = (a + b) / 2 18 | 19 | main = 20 | -- 1.09GB allocation, 3.4s 21 | -- print $ (goGeneral (5000000 :: Int) 1.1 :: Double) 22 | 23 | -- 1.01GB allocation, 3.2s 24 | print $ (goSpecialized (5000000 :: Int) 1.1 :: Double) 25 | -------------------------------------------------------------------------------- /Chapter06/resourcet.hs: -------------------------------------------------------------------------------- 1 | -- file: resourcet.hs 2 | 3 | import Control.Exception 4 | 5 | import Control.Monad.IO.Class (liftIO) 6 | import Control.Monad.Trans.Resource 7 | import System.IO 8 | 9 | copy_resourcet :: ResIO () 10 | copy_resourcet = do 11 | (_, f1) <- allocate (openFile "read.txt" ReadMode) hClose 12 | (_, f2) <- allocate (openFile "write.txt" WriteMode) hClose 13 | liftIO $ hGetContents f1 >>= hPutStr f2 14 | 15 | main = runResourceT copy_resourcet 16 | 17 | copy_bracket :: IO () 18 | copy_bracket = 19 | bracket (openFile "read.txt" ReadMode) hClose $ \f1 -> 20 | bracket (openFile "write.txt" WriteMode) hClose $ \f2 -> 21 | hGetContents f1 >>= hPutStr f2 22 | -------------------------------------------------------------------------------- /Chapter07/mvar-queue.hs: -------------------------------------------------------------------------------- 1 | -- file: mvar-queue.hs 2 | 3 | import Control.Concurrent.MVar 4 | 5 | data Queue a = Queue (MVar [a]) (MVar [a]) 6 | 7 | newQueue :: IO (Queue a) 8 | newQueue = Queue <$> newMVar [] <*> newMVar [] 9 | 10 | enqueue :: Queue a -> a -> IO () 11 | enqueue (Queue _ ys_var) x = modifyMVar_ ys_var (return . (x :)) 12 | 13 | dequeue :: Queue a -> IO (Maybe a) 14 | dequeue (Queue xs_var ys_var) = modifyMVar xs_var $ \xs_q -> 15 | case xs_q of 16 | x : xs -> return (xs, Just x) 17 | [] -> modifyMVar ys_var $ \ys_q -> 18 | return $ case reverse ys_q of 19 | [] -> ([], ([], Nothing)) 20 | x : xs -> ([], (xs, Just x)) 21 | -------------------------------------------------------------------------------- /Chapter02/circular.hs: -------------------------------------------------------------------------------- 1 | -- file: circular.hs 2 | -- run with "./circular N", where N is the buffer size 3 | 4 | import Data.Sequence as Seq 5 | import Data.Foldable (toList, foldl') 6 | 7 | import System.Environment 8 | 9 | data Circular a = Circular !Int (Seq.Seq a) 10 | 11 | create :: Int -> Circular a 12 | create n = Circular n Seq.empty 13 | 14 | values :: Circular a -> [a] 15 | values (Circular _ s) = toList s 16 | 17 | observe :: Circular a -> a -> Circular a 18 | observe (Circular n s) x 19 | | Seq.length s < n = Circular n $ s |> x 20 | | _ :< s' <- viewl s = Circular n $ s' |> x 21 | 22 | main = do 23 | [x] <- getArgs 24 | print $ values $ foldl' observe (create (read x)) [1..10000000 :: Int] 25 | -------------------------------------------------------------------------------- /Chapter06/socket-echo.hs: -------------------------------------------------------------------------------- 1 | -- file: socket-echo.hs 2 | 3 | import Control.Exception 4 | import Network.Socket 5 | 6 | server = bracket 7 | (socket AF_UNIX Stream defaultProtocol) 8 | close 9 | (\s -> do 10 | bind s (SockAddrUnix "./echo.socket") 11 | listen s 1 12 | (conn, _) <- accept s 13 | talk conn) 14 | where 15 | talk s = do r <- recv s 1024 16 | putStrLn r 17 | send s r 18 | talk s 19 | 20 | client = do 21 | s <- socket AF_UNIX Stream defaultProtocol 22 | connect s (SockAddrUnix "./echo.socket") 23 | send s "ping" 24 | pong <- recv s 1024 25 | putStrLn pong 26 | 27 | main = 28 | server 29 | -- client 30 | -------------------------------------------------------------------------------- /Chapter01/fib.hs: -------------------------------------------------------------------------------- 1 | -- file: fib.hs 2 | 3 | fib_mem :: Int -> Integer 4 | fib_mem = (map fib [0..] !!) 5 | where fib 0 = 1 6 | fib 1 = 1 7 | fib n = fib_mem (n-2) + fib_mem (n-1) 8 | 9 | fib_mem_arg :: Int -> Integer 10 | fib_mem_arg x = map fib [0..] !! x 11 | where fib 0 = 1 12 | fib 1 = 1 13 | fib n = fib_mem_lambda (n-2) + fib_mem_lambda (n-1) 14 | 15 | fib_mem_lambda :: Int -> Integer 16 | fib_mem_lambda = \x -> map fib [0..] !! x 17 | where fib 0 = 1 18 | fib 1 = 1 19 | fib n = fib_mem_lambda (n-2) + fib_mem_lambda (n-1) 20 | 21 | main = print $ fib_mem_arg 10000 22 | 23 | fib_zip :: Int -> Integer 24 | fib_zip n = fib !! n 25 | where fib = 1 : 1 : zipWith (+) fib (tail fib) 26 | -------------------------------------------------------------------------------- /Chapter02/strict_and_unpacked.hs: -------------------------------------------------------------------------------- 1 | -- file: strict_and_unpacked.hs 2 | -- ghc -O 3 | 4 | {-# LANGUAGE BangPatterns #-} 5 | 6 | data PairP = PairP Int Int deriving (Show) 7 | 8 | data PairS = PairS !Int !Int deriving (Show) 9 | 10 | data PairU = PairU {-# UNPACK #-} !Int {-# UNPACK #-} !Int deriving (Show) 11 | 12 | iter :: Int -> (a -> a) -> a -> a 13 | iter end f x = go 0 x 14 | where go !n x | n < end = go (n + 1) $! f x 15 | | otherwise = x 16 | 17 | main = print $ iter 10000 18 | (\(PairP !i !j) -> PairP (i*j) (i+j)) (PairP 1 1) -- 373 KB 19 | -- (\(PairS !i !j) -> PairS (i*j) (i+j)) (PairS 1 1) -- 53 KB 20 | -- (\(PairU !i !j) -> PairU (i*j) (i+j)) (PairU 1 1) -- 53 KB 21 | -------------------------------------------------------------------------------- /Chapter07/chan-actors.hs: -------------------------------------------------------------------------------- 1 | -- file: chan-actors.hs 2 | 3 | import Data.List (isPrefixOf) 4 | import Control.Monad 5 | import Control.Concurrent 6 | import Control.Concurrent.Chan 7 | 8 | client :: Int -> Chan String -> IO () 9 | client i chan = go where 10 | go = do input <- readChan chan 11 | if input == ("request " ++ show i) 12 | then writeChan chan ("response " ++ show i) 13 | else return () 14 | go 15 | 16 | main = do 17 | chan <- newChan 18 | chans <- replicateM 3 (dupChan chan) 19 | zipWithM_ (\i c -> forkIO $ client i c) [1..] chans 20 | 21 | forM_ [1..3] $ writeChan chan . ("request " ++) . show 22 | getChanContents chan >>= mapM_ print . filter (isPrefixOf "response") 23 | -------------------------------------------------------------------------------- /Chapter02/fib-array-mem.hs: -------------------------------------------------------------------------------- 1 | -- file: fib-array-mem.hs 2 | {-# LANGUAGE FlexibleContexts #-} 3 | 4 | import Data.Array.IArray 5 | import Data.Array.Unboxed (UArray) 6 | 7 | fib :: Int -> Array Int Integer 8 | fib n = arr where 9 | arr = listArray (1,n) $ 1 : 1 : [ arr!(i-2) + arr!(i-1) | i <- [3..n] ] 10 | 11 | pascal :: Int -> Array (Int, Int) Integer 12 | pascal n = arr where 13 | arr = array ((1,1),(n,n)) $ 14 | [ ((i,1),1) | i <- [1..n] ] ++ 15 | [ ((1,j),1) | j <- [1..n] ] ++ 16 | [ ((i,j),arr!(i-1,j) + arr!(i,j-1)) | i <- [2..n], j <- [2..n] ] 17 | 18 | main = do 19 | let arr = fib 100000 20 | print (arr!100000 `mod` 17) 21 | 22 | toUArray :: (Ix i, IArray UArray e) => Array i e -> UArray i e 23 | toUArray a = listArray (bounds a) (elems a) 24 | -------------------------------------------------------------------------------- /Chapter03/benchmark.hs: -------------------------------------------------------------------------------- 1 | module Main where 2 | 3 | import Criterion.Main 4 | import Data.List (foldl') 5 | 6 | main = defaultMain [ 7 | bgroup "list" 8 | [ bench "sum" $ whnf sum [1..1000000] 9 | , bench "foldr" $ whnf (foldr (+) 0) [1..1000000] 10 | , bench "foldl" $ whnf (foldl (+) 0) [1..1000000] 11 | , bench "foldl'" $ whnf (foldl' (+) 0) [1..1000000] 12 | ] 13 | , 14 | bgroup "foldl" 15 | [ bench "_" $ whnf (\_ -> foldl (+) 0 [1..1000000]) undefined 16 | , bench "()" $ whnf (\() -> foldl (+) 0 [1..1000000]) () 17 | , bench "num" $ whnf (\n -> foldl (+) 0 [1..n]) (1000000) 18 | , bench "num (strict)" $ whnf (\n -> foldl' (+) 0 [1..n]) (1000000) 19 | ] 20 | ] 21 | -------------------------------------------------------------------------------- /Chapter12/remote-exec.hs: -------------------------------------------------------------------------------- 1 | -- file: remote-exec.hs 2 | {-# LANGUAGE TemplateHaskell, KindSignatures #-} 3 | 4 | import Data.Typeable 5 | 6 | import Control.Distributed.Process 7 | import Control.Distributed.Process.Closure 8 | import Control.Distributed.Process.Node (initRemoteTable) 9 | import Control.Distributed.Process.Backend.SimpleLocalnet 10 | 11 | rpc :: String -> Process Int 12 | rpc str = return (length str) 13 | 14 | remotable ['rpc] 15 | 16 | foo :: Process () 17 | foo = do 18 | node <- getSelfNode 19 | str <- call $(functionTDict 'rpc) node ($(mkClosure 'rpc) "foo") 20 | say (show str) 21 | 22 | main :: IO () 23 | main = do 24 | backend <- initializeBackend "localhost" "9001" (__remoteTable initRemoteTable) 25 | startMaster backend $ \_ -> foo 26 | -------------------------------------------------------------------------------- /Chapter02/sum_mutable.hs: -------------------------------------------------------------------------------- 1 | -- file: sum_mutable.hs 2 | 3 | import Control.Monad.ST 4 | import Data.IORef 5 | import Data.STRef 6 | 7 | count_st :: Int -> Int 8 | count_st n = runST $ do 9 | ref <- newSTRef 0 10 | let go 0 = readSTRef ref 11 | go i = modifySTRef' ref (+ i) >> go (i - 1) 12 | go n 13 | 14 | count_io :: Int -> IO Int 15 | count_io n = do 16 | ref <- newIORef 0 17 | let go 0 = readIORef ref 18 | go i = modifyIORef' ref (+ i) >> go (i - 1) 19 | go n 20 | 21 | count_pure :: Int -> Int 22 | count_pure n = go n 0 where 23 | go 0 s = s 24 | go i s = go (i - 1) $! (s + i) 25 | 26 | main = 27 | -- print $ count_st 10000000 -- 160 MB 28 | -- count_io 10000000 >>= print -- 160 MB 29 | print $ count_pure 10000000 -- 51.8 KB 30 | -------------------------------------------------------------------------------- /Chapter01/time_and_space.hs: -------------------------------------------------------------------------------- 1 | -- time_and_space.hs 2 | import Data.List (foldl') 3 | 4 | sum' :: Fractional a => [a] -> a 5 | sum' = foldl' (+) 0 6 | 7 | mean :: Fractional a => [a] -> a 8 | mean v = sum' v / fromIntegral (length v) 9 | 10 | covariance :: [Double] -> [Double] -> Double 11 | covariance xs ys = 12 | sum' (zipWith (\x y -> (x - mean xs) * (y - mean ys)) xs ys) 13 | / fromIntegral (length xs) 14 | 15 | main = do 16 | let xs = [1, 1.1 .. 500] 17 | ys = [2, 2.1 .. 501] 18 | print $ covariance xs ys 19 | 20 | covariance' :: [Double] -> [Double] -> Double 21 | covariance' xs ys = 22 | let mean_xs = mean xs 23 | mean_ys = mean ys 24 | in 25 | sum' (zipWith (\x y -> (x - mean_xs) * (y - mean_ys)) xs ys) 26 | / fromIntegral (length xs) 27 | -------------------------------------------------------------------------------- /Chapter11/matrix-cuda.hs: -------------------------------------------------------------------------------- 1 | -- file: matrix-cuda.hs 2 | 3 | {-# LANGUAGE TypeOperators #-} 4 | 5 | import Data.Array.Accelerate as A 6 | import Data.Array.Accelerate.CUDA 7 | 8 | type Matrix = Array DIM2 Double 9 | 10 | matProduct :: Acc Matrix -> Acc Matrix -> Acc Matrix 11 | matProduct a b = let 12 | 13 | Z :. mx :. _ = unlift (shape a) :: Z :. Exp Int :. Exp Int 14 | Z :. _ :. my = unlift (shape b) :: Z :. Exp Int :. Exp Int 15 | 16 | aRep = A.replicate (lift $ Z :. All :. my :. All) a 17 | bRep = A.replicate (lift $ Z :. mx :. All :. All) (A.transpose b) 18 | 19 | in A.fold (+) 0 20 | $ A.zipWith (*) aRep bRep 21 | 22 | main = let 23 | mat :: Matrix 24 | mat = fromList (Z :. 100 :. 100) [1..] 25 | 26 | res = run $ A.sum $ matProduct (lift mat) (lift mat) 27 | 28 | in print res 29 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # Windows image file caches 2 | Thumbs.db 3 | ehthumbs.db 4 | 5 | # Folder config file 6 | Desktop.ini 7 | 8 | # Recycle Bin used on file shares 9 | $RECYCLE.BIN/ 10 | 11 | # Windows Installer files 12 | *.cab 13 | *.msi 14 | *.msm 15 | *.msp 16 | 17 | # Windows shortcuts 18 | *.lnk 19 | 20 | # ========================= 21 | # Operating System Files 22 | # ========================= 23 | 24 | # OSX 25 | # ========================= 26 | 27 | .DS_Store 28 | .AppleDouble 29 | .LSOverride 30 | 31 | # Thumbnails 32 | ._* 33 | 34 | # Files that might appear in the root of a volume 35 | .DocumentRevisions-V100 36 | .fseventsd 37 | .Spotlight-V100 38 | .TemporaryItems 39 | .Trashes 40 | .VolumeIcon.icns 41 | 42 | # Directories potentially created on remote AFP share 43 | .AppleDB 44 | .AppleDesktop 45 | Network Trash Folder 46 | Temporary Items 47 | .apdisk 48 | -------------------------------------------------------------------------------- /Chapter02/builder-encoding.hs: -------------------------------------------------------------------------------- 1 | -- file: builder-encoding.hs 2 | 3 | -- Tree (1, Leaf "one") (2, Leaf "two") 4 | -- into 5 | -- [ 1:"one", 2:"two" ] 6 | 7 | {-# LANGUAGE OverloadedStrings #-} 8 | 9 | import Data.ByteString (ByteString) 10 | import qualified Data.ByteString.Builder as B 11 | import Data.Monoid ((<>)) 12 | import System.IO (stdout) 13 | 14 | data Tree = Tree !(Int, Tree) !(Int, Tree) 15 | | Leaf !ByteString 16 | 17 | encodeTree :: Tree -> B.Builder 18 | encodeTree (Tree (l1, t1) (l2, t2)) = B.charUtf8 '[' 19 | <> B.intDec l1 <> B.charUtf8 ':' <> encodeTree t1 20 | <> B.charUtf8 ',' 21 | <> B.intDec l2 <> B.charUtf8 ':' <> encodeTree t2 <> B.charUtf8 ']' 22 | encodeTree (Leaf bs) = B.charUtf8 '"' <> B.byteString bs <> B.charUtf8 '"' 23 | 24 | main = B.hPutBuilder stdout $ encodeTree $ 25 | Tree (1,Leaf "one") (2, Tree (3,Leaf "three") (4,Leaf "four")) 26 | -------------------------------------------------------------------------------- /Chapter02/dlist.hs: -------------------------------------------------------------------------------- 1 | -- file: dlist.hs 2 | 3 | import Control.Monad.Writer 4 | 5 | newtype DList a = DList ([a] -> [a]) 6 | 7 | fromList :: [a] -> DList a 8 | fromList xs = DList (xs ++) 9 | 10 | toList :: DList a -> [a] 11 | toList (DList list) = list [] 12 | 13 | instance Monoid (DList a) where 14 | mempty = DList id 15 | mappend (DList x) (DList y) = DList (x . y) 16 | 17 | ----------------------------------------------------- 18 | 19 | type DListWriter = Writer (DList Int) 20 | type ListWriter = Writer [Int] 21 | 22 | action :: Int -> ListWriter () 23 | action 15000 = return () 24 | action n = action (n + 1) >> tell [n] 25 | 26 | action' :: Int -> DListWriter () 27 | action' 15000 = return () 28 | action' n = action' (n + 1) >> tell (fromList [n]) 29 | 30 | main = do 31 | forM (snd $ runWriter (action 1)) print 32 | forM (toList $ snd $ runWriter (action' 1)) print 33 | -------------------------------------------------------------------------------- /Chapter01/time_and_space_2.hs: -------------------------------------------------------------------------------- 1 | -- ghc -O -rtsopts -XBangPatterns time_and_space_2.hs 2 | -- time ./time_and_space_2 +RTS -s 3 | 4 | goGen u = sum [1..u] + product [1..u] 5 | goGenShared u = let xs = [1..u] in sum xs + product xs 6 | goGenOnePass u = su + pu 7 | where 8 | (su, pu) = foldl f (0,1) [1..u] 9 | f (s, p) i = let s' = s+i 10 | p' = p*i 11 | in s' `seq` p' `seq` (s', p') 12 | -- f (!s, !p) i = (s+i, p*i) 13 | 14 | main = print $ do 15 | -- uncomment one of these lines, compile and execute 16 | 17 | -- goGen 10000 -- 0.050ms, 87MB heap, 10MB during GC, 0.7MB residency, 6MB total mem, 60% GC 18 | -- goGenShared 10000 -- 0.070ms, 88MB heap, 29MB during GC, 0.9MB residency, 7MB total mem, 70% GC 19 | -- goGenOnePass 10000 -- 0.025ms, 86MB heap, 0.9MB during GC, 0.05MB residency, 2MB total mem, 20% GC 20 | -------------------------------------------------------------------------------- /Chapter02/gadts.hs: -------------------------------------------------------------------------------- 1 | -- file: gadts.hs 2 | {-# LANGUAGE GADTs #-} 3 | 4 | data Object a where 5 | Number :: Integral a => a -> Object a 6 | Number' :: Integral a => a -> Object a 7 | Character :: Char -> Object Char 8 | 9 | data ObjectE where 10 | NumberE :: Integral a => a -> ObjectE 11 | 12 | main = print $ 13 | foldl (\a b -> a + b) 0 [ x | x <- [1..1000000 :: Int] ] 14 | 15 | -- foldl (\a (Number b) -> a + b) 0 [ Number x | x <- [1..1000000 :: Int] ] 16 | 17 | -- foldl (\a (NumberE b) -> a + fromIntegral b) 0 [ NumberE x | x <- [1..1000000 :: Int] ] 18 | 19 | -- foldl f 0 [ if odd x then Number x else Number' x | x <- [1..1000000 :: Int] ] 20 | 21 | -- foldl f 0 [ Number x | x <- [1..1000000 :: Int] ] 22 | 23 | f a x = case x of 24 | Character _ -> a 25 | Number n -> a + n 26 | Number' n -> a - n 27 | -------------------------------------------------------------------------------- /Chapter03/ekg-fact.hs: -------------------------------------------------------------------------------- 1 | -- file: ekg-fact.hs 2 | {-# LANGUAGE OverloadedStrings #-} 3 | module Main where 4 | 5 | import Control.Monad 6 | import System.Remote.Monitoring -- package ekg 7 | import System.Metrics -- package ekg-core 8 | import qualified System.Metrics.Counter as Counter -- package ekg-core 9 | 10 | main = do 11 | server <- forkServer "localhost" 8000 12 | factorials <- createCounter "factorials.count" (serverMetricStore server) 13 | forever $ do 14 | input <- getLine 15 | print $ product [1..read input :: Integer] 16 | Counter.inc factorials 17 | 18 | {- 19 | -- file: ekg-fact.hs 20 | {-# LANGUAGE OverloadedStrings #-} 21 | module Main where 22 | 23 | import Control.Monad 24 | import System.Remote.Monitoring 25 | 26 | main = do 27 | forkServer "localhost" 8000 28 | forever $ do 29 | input <- getLine 30 | print $ product [1..read input :: Integer] 31 | -} 32 | -------------------------------------------------------------------------------- /Chapter07/async-cli.hs: -------------------------------------------------------------------------------- 1 | -- file: async-cli.hs 2 | 3 | import Control.Monad (forever) 4 | import Control.Concurrent 5 | import Control.Concurrent.Async 6 | 7 | main1 = forever $ 8 | withAsync getLine $ \userInput -> 9 | withAsync (threadDelay 5000000) $ \timeOut -> do 10 | res <- waitEither userInput timeOut 11 | case res of 12 | Left input -> print input 13 | Right _ -> putStrLn "Timeout!" 14 | 15 | main2 = forever $ do 16 | res <- withAsync getLine $ \userInput -> 17 | withAsync (threadDelay 5000000) $ \timeOut -> 18 | waitEither userInput timeOut 19 | case res of 20 | Left input -> print input 21 | Right _ -> putStrLn "Timeout!" 22 | 23 | main3 = forever $ do 24 | res <- getLine `race` threadDelay 5000000 25 | case res of 26 | Left input -> print input 27 | Right _ -> putStrLn "Timeout!" 28 | 29 | main = main3 30 | -------------------------------------------------------------------------------- /Chapter06/socket-udp.hs: -------------------------------------------------------------------------------- 1 | -- file: socket-udp.hs 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | import Control.Monad (forever) 5 | import System.Socket 6 | import System.Socket.Protocol.UDP (UDP) 7 | import System.Socket.Type.Datagram (Datagram) 8 | import System.Socket.Family.Inet (Inet, SocketAddress(..), inetLoopback) 9 | 10 | server = do 11 | s <- socket :: IO (Socket Inet Datagram UDP) 12 | bind s (SocketAddressInet inetLoopback 3003) 13 | forever $ do 14 | (msg, addr) <- receiveFrom s 1024 mempty 15 | sendTo s msg mempty addr 16 | 17 | client = do 18 | s <- socket :: IO (Socket Inet Datagram UDP) 19 | connect s (SocketAddressInet inetLoopback 3003) 20 | send s "ping" mempty 21 | receive s 1024 mempty >>= print 22 | 23 | -- sendTo s "ping" mempty (SocketAddressInet inetLoopback 3003) 24 | 25 | -- Run server via runghc and client from GHCi separetely, for example. 26 | main = server 27 | -------------------------------------------------------------------------------- /Chapter02/bubblesort-optimized.hs: -------------------------------------------------------------------------------- 1 | -- file: bubblesort-optimized.hs 2 | 3 | import Data.Vector.Unboxed as V 4 | import Data.Vector.Unboxed.Mutable as MV 5 | 6 | import Control.Monad.ST 7 | import System.Random (randomIO) -- for testing 8 | 9 | bubblesortM v = loop where 10 | indices = V.enumFromTo 1 (MV.length v - 1) 11 | 12 | loop = do swapped <- V.foldM' f False indices 13 | if swapped then loop else return () 14 | 15 | f swapped i = do 16 | a <- MV.unsafeRead v (i-1) 17 | b <- MV.unsafeRead v i 18 | if a > b then MV.unsafeSwap v (i-1) i >> return True 19 | else return swapped 20 | 21 | bubblesort v = runST $ do 22 | mv <- V.thaw v 23 | bubblesortM mv 24 | V.unsafeFreeze mv 25 | 26 | main = do 27 | v <- V.generateM 10000 $ \_ -> randomIO :: IO Double 28 | let v_sorted = bubblesort v 29 | median = v_sorted ! 5000 30 | print median 31 | -------------------------------------------------------------------------------- /Chapter06/conduit.hs: -------------------------------------------------------------------------------- 1 | -- file conduit.hs 2 | 3 | import Control.Monad 4 | import Control.Monad.IO.Class (liftIO) 5 | import Data.Conduit 6 | import System.Random (randomIO) 7 | 8 | randoms :: Source IO Int 9 | randoms = forever (liftIO randomIO >>= yield) 10 | 11 | taking :: Monad m => Int -> Conduit a m a 12 | taking 0 = error "ASdf" -- return () 13 | taking n = do x <- await 14 | case x of 15 | Nothing -> return () 16 | Just y -> yield y >> taking (n - 1) 17 | 18 | printing :: Show a => Sink a IO () 19 | printing = do x <- await 20 | case x of 21 | Nothing -> return () 22 | Just y -> liftIO (print y) >> printing 23 | 24 | main :: IO () 25 | main = randoms =$= taking 5 $$ printing 26 | 27 | ------------------------------------------ 28 | 29 | counter :: Source IO Int 30 | counter = go 0 31 | where go n = yield n >> go (n + 1) 32 | 33 | 34 | -------------------------------------------------------------------------------- /Chapter05/stencil.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE QuasiQuotes #-} 2 | 3 | import Data.Array.Repa as Repa 4 | import Data.Array.Repa.Stencil 5 | import Data.Array.Repa.Stencil.Dim2 6 | import Data.Bits ((.|.)) 7 | 8 | image :: Array D DIM2 Double 9 | image = fromFunction (ix2 5 5) $ 10 | \(Z :. x :. y) -> if x == 0 || x == 2 || y == 2 then 1 else 0 11 | 12 | stencil :: Stencil DIM2 Double 13 | stencil = [stencil2| 0 0 0 14 | 1 1 1 15 | 0 0 0 |] 16 | 17 | stencil' :: Stencil DIM2 Double 18 | stencil' = [stencil2| -1 1 -1 19 | -2 1 -2 20 | -1 1 -1 |] 21 | 22 | st1, st2 :: Array PC5 DIM2 Int 23 | st1 = Repa.smap (\x -> if x >= 3 then 1 else 0) $ 24 | mapStencil2 BoundClamp stencil image 25 | 26 | st2 = Repa.smap (\x -> if x >= 1 then 1 else 0) $ 27 | mapStencil2 BoundClamp stencil' image 28 | 29 | main = print $ head $ computeUnboxedP $ Repa.szipWith (.|.) st1 st2 30 | -------------------------------------------------------------------------------- /Chapter12/bi-directional.hs: -------------------------------------------------------------------------------- 1 | -- file: bi-directional.hs 2 | 3 | import Control.Distributed.Process 4 | import Control.Distributed.Process.Node (initRemoteTable) 5 | import Control.Distributed.Process.Backend.SimpleLocalnet 6 | 7 | server :: Process () 8 | server = do 9 | pid <- getSelfPid 10 | (sendport', recvport) <- newChan 11 | _clientPid <- spawnLocal (client pid sendport') 12 | sendport <- expect 13 | 14 | -- server: send via sendport, receive via recvport 15 | sendChan sendport "ping" 16 | receiveChan recvport >>= say 17 | 18 | client :: ProcessId -> SendPort String -> Process () 19 | client pid sendport = do 20 | (sendport', recvport) <- newChan 21 | send pid sendport' 22 | 23 | -- client: send via sendport, receive via recvport 24 | ping <- receiveChan recvport 25 | sendChan sendport ("pong: " ++ ping) 26 | 27 | main = do 28 | backend <- initializeBackend "localhost" "9001" initRemoteTable 29 | startMaster backend (\_ -> server) 30 | -------------------------------------------------------------------------------- /Chapter02/cont-state-writer.hs: -------------------------------------------------------------------------------- 1 | -- file: cont-state-writer.hs 2 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE FlexibleContexts #-} 6 | 7 | import Control.Monad.State.Strict 8 | import Control.Monad.Cont 9 | 10 | newtype StateCPS s r a = StateCPS (Cont (s -> r) a) 11 | deriving (Functor, Applicative, Monad, MonadCont) 12 | 13 | instance MonadState s (StateCPS s r) where 14 | get = StateCPS $ cont $ \k -> \s -> k s s 15 | put s = StateCPS $ cont $ \k -> \_ -> k () s 16 | 17 | runStateCPS :: StateCPS s s () -> s -> s 18 | runStateCPS (StateCPS m) = runCont m (\_ -> id) 19 | 20 | 21 | -- TESTING 22 | 23 | action :: MonadState Int m => m () 24 | action = replicateM_ 1000000 $ do 25 | i <- get 26 | put $! i + 1 27 | 28 | main = do 29 | print $ (runStateCPS action 0 :: Int) -- 75ms, 224MB heap, 55KB GC 30 | print $ (snd $ runState action 0 :: Int) -- 80ms, 312MB heap, 71KB GC 31 | -------------------------------------------------------------------------------- /Chapter02/vector-testing.hs: -------------------------------------------------------------------------------- 1 | -- file: vector-testing.hs 2 | 3 | import qualified Data.Vector.Unboxed as U 4 | import System.Random (randomIO) 5 | 6 | type Obs = U.Vector (TimeStamp, Double) 7 | 8 | type TimeStamp = Int 9 | type Period = Int 10 | 11 | -- | O(1) 12 | values :: Obs -> U.Vector Double 13 | values obs = snd (U.unzip obs) 14 | 15 | -- | O(n+m), no copying. 16 | window :: TimeStamp -> TimeStamp -> Obs -> Obs 17 | window from until v = 18 | let (_, start) = U.span ((< from) . fst) v 19 | (between, _) = U.span ((<= until) . fst) start 20 | in between 21 | 22 | -- | O(n) 23 | average :: Obs -> Double 24 | average obs = U.sum (values obs) / fromIntegral (U.length (values obs)) 25 | 26 | main = do 27 | obs <- U.generateM (1024 ^ 2) $ \i -> randomIO >>= \v -> return (i, v) 28 | print $ average $ window 1 (1024 ^ 2) obs 29 | print $ average $ window 2 (1023 ^ 2) obs 30 | print $ average $ window 3 (1022 ^ 2) obs 31 | print $ average $ window 4 (1021 ^ 2) obs 32 | -------------------------------------------------------------------------------- /Chapter12/client-server.hs: -------------------------------------------------------------------------------- 1 | -- file: client-server.hs 2 | {-# LANGUAGE BangPatterns #-} 3 | 4 | import Control.Monad 5 | import Control.Distributed.Process 6 | import Control.Distributed.Process.Node (initRemoteTable) 7 | import Control.Distributed.Process.Backend.SimpleLocalnet 8 | 9 | master :: Process () 10 | master = do 11 | ports <- replicateM 100 $ do 12 | (sendport, recvport) <- newChan 13 | _pid <- spawnLocal (client sendport) 14 | return recvport 15 | 16 | port <- mergePortsRR ports 17 | let loop !s = do 18 | mn <- receiveChanTimeout 1000 port 19 | case mn of 20 | Just n -> loop (s + n) 21 | Nothing -> do say $ "final: " ++ show s 22 | terminate 23 | loop 0 24 | 25 | client :: SendPort Double -> Process () 26 | client sendport = forM_ [1..100] (sendChan sendport) 27 | 28 | main = do 29 | backend <- initializeBackend "localhost" "9001" initRemoteTable 30 | startMaster backend (\_ -> master) 31 | -------------------------------------------------------------------------------- /Chapter06/io-streams-exceptions.hs: -------------------------------------------------------------------------------- 1 | -- file: io-streams-exceptions.hs 2 | 3 | import Control.Exception 4 | import System.IO.Streams (Generator, InputStream, OutputStream) 5 | import qualified System.IO.Streams as S 6 | 7 | divideBy :: InputStream Int -> InputStream Int -> IO (InputStream Int) 8 | divideBy as bs = S.makeInputStream go 9 | where 10 | go = do 11 | ma <- S.read as 12 | mb <- S.read bs 13 | case (ma, mb) of 14 | (Just a, Just b) -> 15 | (return $! Just $! div a b) 16 | `catch` 17 | (const go :: ArithException -> IO (Maybe Int)) 18 | _ -> return Nothing 19 | 20 | thisFails :: IO (InputStream Int) 21 | thisFails = S.makeInputStream (return (Just undefined)) 22 | 23 | thisFailsCorrectly :: IO (InputStream Int) 24 | thisFailsCorrectly = S.makeInputStream (return $! Just $! undefined) 25 | 26 | main = do x <- S.fromList [0..4] 27 | y <- S.fromList [1,0,0,2] 28 | divideBy x y >>= S.toList >>= print 29 | -------------------------------------------------------------------------------- /Chapter07/tvar-account.hs: -------------------------------------------------------------------------------- 1 | -- file: tvar-account.hs 2 | 3 | import Control.Applicative 4 | import Control.Concurrent.STM 5 | 6 | type Balance = Int 7 | type Account = TVar Balance 8 | 9 | createAccount :: Balance -> STM Account 10 | createAccount = newTVar 11 | 12 | withdraw account amount = do 13 | balance <- readTVar account 14 | if balance - amount < 0 15 | then retry 16 | else writeTVar account $! balance - amount 17 | 18 | deposit account amount = do 19 | balance <- readTVar account 20 | writeTVar account $! balance + amount 21 | 22 | transfer from to n = do 23 | withdraw from n 24 | deposit to n 25 | 26 | withdraw' :: Account -> Account -> Balance -> STM () 27 | withdraw' primary secondary amount = 28 | withdraw primary amount <|> withdraw secondary amount 29 | 30 | main = do 31 | acc1 <- atomically $ createAccount 5 32 | acc2 <- atomically $ createAccount 3 33 | atomically $ transfer acc1 acc2 2 34 | atomically (readTVar acc1) >>= print 35 | atomically (readTVar acc2) >>= print 36 | -------------------------------------------------------------------------------- /Chapter09/SetterSplice.hs: -------------------------------------------------------------------------------- 1 | module SetterSplice where 2 | 3 | import Language.Haskell.TH 4 | import Data.List (nub) 5 | import Control.Monad (forM) 6 | 7 | deriveSetters :: Name -> Q [Dec] 8 | deriveSetters nm = do 9 | TyConI tyCon <- reify nm -- (1) 10 | case tyCon of 11 | DataD _ nm tyVars cs _ -> do -- (2) 12 | let fieldsTypes = nub (concatMap recFields cs) -- (3) 13 | forM fieldsTypes $ 14 | \(nm, ty) -> setterDec nm -- (5) 15 | where 16 | recFields (RecC _ xs) = -- (4) 17 | map (\(var,_,ty) -> (var, ty)) xs 18 | 19 | setterDec :: Name -> Q Dec 20 | setterDec nm = do 21 | let nmD = mkName $ nameBase nm ++ "'" -- (2) 22 | nmV <- newName "val" 23 | nmP <- newName "p" 24 | let pat = [VarP nmV, VarP nmP] -- (3) 25 | body = NormalB $ RecUpdE (VarE nmP) [ (nm, VarE nmV) ] -- (4) 26 | return $ FunD nmD [ Clause pat body [] ] -- (1) 27 | -------------------------------------------------------------------------------- /Chapter13/reactive-banana-counter.hs: -------------------------------------------------------------------------------- 1 | -- file: reactive-banana-counter.hs 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | 4 | import Graphics.UI.WX 5 | import Reactive.Banana 6 | import Reactive.Banana.WX 7 | 8 | app :: IO () 9 | app = do 10 | f <- frame [ text := "App" ] 11 | up <- button f [ text := "Up" ] 12 | down <- button f [ text := "Down" ] 13 | res <- staticText f [] 14 | 15 | set f [ layout := margin 10 16 | ( column 5 [ widget res 17 | , row 5 [widget up, widget down] ] ) ] 18 | 19 | let 20 | network :: MomentIO () 21 | network = do 22 | eup <- event0 up command 23 | edown <- event0 down command 24 | 25 | (counter :: Behavior Int) 26 | <- accumB 0 $ unions 27 | [ (+1) <$ eup 28 | , subtract 1 <$ edown 29 | ] 30 | 31 | sink res [ text :== show <$> counter ] 32 | 33 | evnet <- compile network 34 | actuate evnet 35 | 36 | main = start app 37 | -------------------------------------------------------------------------------- /Chapter10/struct-marshal.hs: -------------------------------------------------------------------------------- 1 | {-# LINE 1 "struct-marshal.hsc" #-} 2 | -- file: struct-marshal.hsc 3 | {-# LINE 2 "struct-marshal.hsc" #-} 4 | 5 | 6 | {-# LINE 4 "struct-marshal.hsc" #-} 7 | 8 | -- Define the #alignment macro for GHC 7. It is available by default 9 | -- starting with GHC 8.0.1. 10 | 11 | {-# LINE 8 "struct-marshal.hsc" #-} 12 | 13 | import Foreign.Storable 14 | 15 | data Some = Some { a :: Int, b :: Double } 16 | 17 | instance Storable Some where 18 | sizeOf _ = ((16)) 19 | {-# LINE 15 "struct-marshal.hsc" #-} 20 | alignment _ = (8) 21 | {-# LINE 16 "struct-marshal.hsc" #-} 22 | peek ptr = Some <$> ((\hsc_ptr -> peekByteOff hsc_ptr 0)) ptr 23 | {-# LINE 17 "struct-marshal.hsc" #-} 24 | <*> ((\hsc_ptr -> peekByteOff hsc_ptr 8)) ptr 25 | {-# LINE 18 "struct-marshal.hsc" #-} 26 | poke ptr (Some a b) = do 27 | ((\hsc_ptr -> pokeByteOff hsc_ptr 0)) ptr a 28 | {-# LINE 20 "struct-marshal.hsc" #-} 29 | ((\hsc_ptr -> pokeByteOff hsc_ptr 8)) ptr b 30 | {-# LINE 21 "struct-marshal.hsc" #-} 31 | 32 | main = undefined 33 | -------------------------------------------------------------------------------- /Chapter05/bigrecord.hs: -------------------------------------------------------------------------------- 1 | import Control.Parallel.Strategies 2 | 3 | -- data A = A Int Bool [Double] String 4 | -- 5 | -- buildPar :: A 6 | -- buildPar = runEval $ 7 | -- Record <$> rpar toInt 8 | -- <*> rpar toBool 9 | -- <*> evalList rpar toList 10 | -- <*> rpar toString 11 | 12 | data T a b = T a b deriving (Show) 13 | 14 | parT :: Strategy a -> Strategy b -> Strategy (T a b) 15 | parT sa sb (T a b) = do 16 | a' <- rparWith sa a 17 | b' <- rparWith sb b 18 | return (T a' b') 19 | 20 | parL :: Strategy a -> Strategy [a] 21 | parL s xs = do 22 | go xs 23 | return xs 24 | where 25 | go [] = return () 26 | go (x:xs) = do rpar `dot` s $ x 27 | go xs 28 | 29 | -- main = print (T (sum [1..1000000000 :: Int]) (sum [1..1000000001 :: Int]) `using` parT rdeepseq rdeepseq) 30 | main = print ([sum [1..1000000000 :: Int], sum [1..1000000001 :: Int], sum [1..1000000002 :: Int], sum [1..1000000003 :: Int], sum [1..1000000004 :: Int], sum [1..1000000004 :: Int], sum [1..1000000004 :: Int]] `using` parL rdeepseq) 31 | -------------------------------------------------------------------------------- /License: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2016 Packt 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /Chapter04/primops.hs: -------------------------------------------------------------------------------- 1 | -- file: primops.hs 2 | 3 | {-# LANGUAGE MagicHash #-} 4 | {-# LANGUAGE UnboxedTuples #-} 5 | 6 | import GHC.Exts 7 | import GHC.Types (IO(IO)) 8 | import Control.Monad.Primitive 9 | 10 | data CASArrayIO a = CASArrayIO (MutableArray# RealWorld a) 11 | 12 | newCasArray :: Int -> a -> IO (CASArrayIO a) 13 | newCasArray (I# n) a = IO $ \st0 -> 14 | let (# st1, arr #) = newArray# n a st0 15 | in (# st1, CASArrayIO arr #) 16 | 17 | cas :: Ord a => CASArrayIO a -> Int -> a -> IO a 18 | cas (CASArrayIO arr) (I# n) a = IO $ \st0 -> 19 | let (# st1, c #) = readArray# arr n st0 20 | a' = if a > c then a else c 21 | (# st2, r, b #) = casArray# arr n c a' st1 22 | in (# st2, b #) 23 | 24 | cas' :: Ord a => CASArrayIO a -> Int -> a -> IO a 25 | cas' (CASArrayIO arr) (I# n) a = do 26 | c <- primitive $ readArray# arr n 27 | let a' = if a > c then a else c 28 | primitive $ \st -> let (# st', _, b #) = casArray# arr n c a' st 29 | in (# st', b #) 30 | 31 | 32 | readCas :: CASArrayIO a -> Int -> IO a 33 | readCas (CASArrayIO arr) (I# n) = IO $ readArray# arr n 34 | -------------------------------------------------------------------------------- /Chapter06/monadlogger.hs: -------------------------------------------------------------------------------- 1 | -- file: monadlogger.hs 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE DeriveFunctor #-} 4 | 5 | import Control.Monad.Logger 6 | import Data.Monoid 7 | import System.Log.FastLogger 8 | 9 | type MyLogger = LogStr -> IO () 10 | 11 | newtype App a = App { unApp :: MyLogger -> IO a } 12 | deriving (Functor) 13 | 14 | instance Applicative App where 15 | pure x = App $ \_ -> pure x 16 | App f <*> (App g) = App $ \log -> f log <*> g log 17 | 18 | instance Monad App where 19 | App f >>= g = App $ \log -> do r <- f log 20 | unApp (g r) log 21 | 22 | instance MonadLogger App where 23 | monadLoggerLog _ _ _ msg = App $ \log -> log (toLogStr msg) 24 | 25 | app :: App () 26 | app = do 27 | logInfoN "Haskell is fun" 28 | logInfoN "and logging is fun too!" 29 | 30 | logFormat :: LogStr -> FormattedTime -> LogStr 31 | logFormat msg time = toLogStr time <> ": " <> msg <> "\n" 32 | 33 | main = do 34 | getTimeStamp <- newTimeCache "%Y-%M-%d %H:%m" 35 | withTimedFastLogger getTimeStamp (LogStdout defaultBufSize) $ 36 | \logger -> unApp app (logger . logFormat) 37 | -------------------------------------------------------------------------------- /Chapter02/bubblesort.hs: -------------------------------------------------------------------------------- 1 | -- file: bubblesort.hs 2 | 3 | import Data.Vector as V 4 | import Data.Vector.Mutable as MV 5 | 6 | import Control.Monad.ST 7 | import System.Random (randomIO) -- for testing 8 | -- import Control.Monad.Primitive (PrimMonad(PrimState)) 9 | 10 | -- unboxed: bubblesortM :: (Ord a, Unbox a, PrimMonad m) => MVector (PrimState m) a -> m () 11 | -- boxed: bubblesortM :: (Ord a, PrimMonad m) => MVector (PrimState m) a -> m () 12 | bubblesortM v = loop where 13 | indices = V.fromList [1 .. MV.length v - 1] 14 | 15 | loop = do swapped <- V.foldM' f False indices 16 | if swapped then loop else return () 17 | 18 | f swapped i = do 19 | a <- MV.read v (i-1) 20 | b <- MV.read v i 21 | if a > b then MV.swap v (i-1) i >> return True 22 | else return swapped 23 | 24 | -- boxed: bubblesort :: Ord a => Vector a -> Vector a 25 | -- unboxed: bubblesort :: (Ord a, Unbox a) => Vector a -> Vector a 26 | bubblesort v = runST $ do 27 | mv <- V.thaw v 28 | bubblesortM mv 29 | V.freeze mv 30 | 31 | main = do 32 | v <- V.generateM 10000 $ \_ -> randomIO :: IO Double 33 | let v_sorted = bubblesort v 34 | median = v_sorted ! 5000 35 | print median 36 | -------------------------------------------------------------------------------- /Chapter04/some-package/stack.yaml: -------------------------------------------------------------------------------- 1 | # For more information, see: http://docs.haskellstack.org/en/stable/yaml_configuration.html 2 | 3 | # Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2) 4 | resolver: lts-5.11 5 | 6 | # Local packages, usually specified by relative directory name 7 | packages: 8 | - '.' 9 | 10 | # Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3) 11 | extra-deps: [] 12 | 13 | # Override default flag values for local packages and extra-deps 14 | flags: {} 15 | 16 | # Extra package databases containing global packages 17 | extra-package-dbs: [] 18 | 19 | # Control whether we use the GHC we find on the path 20 | # system-ghc: true 21 | 22 | # Require a specific version of stack, using version ranges 23 | # require-stack-version: -any # Default 24 | # require-stack-version: >= 1.0.0 25 | 26 | # Override the architecture used by stack, especially useful on Windows 27 | # arch: i386 28 | # arch: x86_64 29 | 30 | # Extra directories used by stack for building 31 | # extra-include-dirs: [/path/to/dir] 32 | # extra-lib-dirs: [/path/to/dir] 33 | 34 | # Allow a newer minor version of GHC than the snapshot specifies 35 | # compiler-check: newer-minor 36 | -------------------------------------------------------------------------------- /Chapter04/errors.hs: -------------------------------------------------------------------------------- 1 | 2 | {-# LANGUAGE ExistentialQuantification #-} 3 | import Control.Exception 4 | import Data.Typeable 5 | 6 | data MyException = MyException deriving (Show, Typeable) 7 | instance Exception MyException 8 | 9 | --------------------------------------------------------------------------- 10 | 11 | data SomeApplicationException = forall e. Exception e => SomeApplicationException e 12 | deriving Typeable 13 | 14 | instance Show SomeApplicationException where 15 | show (SomeApplicationException e) = "application: " ++ show e 16 | 17 | instance Exception SomeApplicationException 18 | 19 | ------------- 20 | 21 | data WorkerException = WorkerException String deriving (Show, Typeable) 22 | 23 | instance Exception WorkerException where 24 | toException = toException . SomeApplicationException 25 | fromException x = do 26 | SomeApplicationException e <- fromException x 27 | cast e 28 | 29 | --------------------------------------------------------------------------- 30 | 31 | foo = undefined 32 | 33 | worker = throwIO $ WorkerException "flood" 34 | 35 | main = do 36 | catch worker (\e@(WorkerException _) -> print e) 37 | catch worker (\e@(SomeApplicationException _) -> print e) 38 | -------------------------------------------------------------------------------- /Chapter06/io-streams.hs: -------------------------------------------------------------------------------- 1 | -- file: io-streams.hs 2 | 3 | import Data.IORef (newIORef, readIORef, writeIORef) 4 | import Control.Monad.IO.Class (liftIO) 5 | import System.IO.Streams (Generator, InputStream, OutputStream) 6 | import qualified System.IO.Streams as S 7 | import System.Random (randomIO) 8 | 9 | randomInputStreamRef :: Int -> IO (InputStream Double) 10 | randomInputStreamRef count = do 11 | ref <- newIORef count 12 | S.makeInputStream $ do 13 | n <- readIORef ref 14 | if n <= 0 15 | then return Nothing 16 | else do writeIORef ref $! n - 1 17 | r <- randomIO 18 | return (Just r) 19 | 20 | randomInputStreamGen :: Int -> IO (InputStream Double) 21 | randomInputStreamGen count = S.fromGenerator (go count) 22 | where 23 | go :: Int -> Generator Double () 24 | go 0 = return () 25 | go n = liftIO randomIO >>= S.yield >> go (n - 1) 26 | 27 | randomInputStreamAna :: Int -> IO (InputStream Double) 28 | randomInputStreamAna count = S.unfoldM go count 29 | where 30 | go 0 = return Nothing 31 | go n = randomIO >>= \r -> return (Just (r, n - 1)) 32 | 33 | main = randomInputStreamRef 500000 >>= S.fold (+) 0 >>= print 34 | -------------------------------------------------------------------------------- /Chapter02/bitstore.hs: -------------------------------------------------------------------------------- 1 | -- file: bitstore.hs 2 | {-# LANGUAGE BangPatterns #-} 3 | 4 | import Data.Array.Unboxed 5 | import Data.Bits (xor) 6 | 7 | type BitTuple = (Bool, Bool, Bool) 8 | data BitStruct = BitStruct !Bool !Bool !Bool deriving Show 9 | type BitArray = UArray Int Bool 10 | 11 | test :: Int -> Int -> Bool 12 | test n x = x `mod` n == 0 13 | 14 | go :: BitStruct -> [Int] -> BitStruct 15 | go res [] = res 16 | go (BitStruct two three five) (x:xs) = go 17 | (BitStruct (test 2 x `xor` two) (test 3 x `xor` three) (test 5 x `xor` five)) xs 18 | 19 | go' :: (Bool, Bool, Bool) -> [Int] -> (Bool, Bool, Bool) 20 | go' res [] = res 21 | go' (!two, !three, !five) (x:xs) = go' 22 | (test 2 x `xor` two, test 3 x `xor` three, test 5 x `xor` five) xs 23 | 24 | goA :: BitArray -> [Int] -> BitArray 25 | goA arr (x:xs) = 26 | let arr' = (listArray (0,2) [ test 2 x `xor` (arr!0) 27 | , test 2 x `xor` (arr!1) 28 | , test 2 x `xor` (arr!2) ]) 29 | in arr' `seq` goA arr' xs 30 | goA arr [] = arr 31 | 32 | 33 | main = 34 | -- print $ go (BitStruct True True True) [1..1000000] -- 80 MB, 0.075s 35 | -- print $ go' (True, True, True) [1..1000000] -- 176 MB, 0.1s 36 | print $ goA (listArray (0,2) (repeat True)) [1..1000000] -- 370 MB, 0.17s 37 | -------------------------------------------------------------------------------- /Chapter04/some-package/some-package.cabal: -------------------------------------------------------------------------------- 1 | -- Initial some.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | name: some-package 5 | version: 0.1.0.0 6 | -- synopsis: 7 | -- description: 8 | license: BSD3 9 | license-file: LICENSE 10 | author: Samuli Thomasson 11 | maintainer: samuli.thomasson@paivola.fi 12 | -- copyright: 13 | -- category: 14 | build-type: Simple 15 | -- extra-source-files: 16 | cabal-version: >=1.10 17 | 18 | library 19 | exposed-modules: Lib 20 | -- other-modules: 21 | -- other-extensions: 22 | build-depends: base >=4.8 && <4.9, bytestring >=0.10 && <0.11 23 | hs-source-dirs: src 24 | default-language: Haskell2010 25 | other-extensions: OverloadedStrings 26 | 27 | executable foo 28 | main-is: app/main.hs 29 | build-depends: base, some-package 30 | default-language: Haskell2010 31 | 32 | test-suite test-props 33 | type: exitcode-stdio-1.0 34 | main-is: properties.hs 35 | hs-source-dirs: tests 36 | build-depends: base, some-package, tasty 37 | 38 | benchmark bench-foo 39 | type: exitcode-stdio-1.0 40 | main-is: benchmarks.hs 41 | hs-source-dirs: tests 42 | build-depends: base, some-package, criterion 43 | -------------------------------------------------------------------------------- /Chapter03/encryption.hs: -------------------------------------------------------------------------------- 1 | -- file: encryption.hs 2 | -- 3 | -- generate key: 4 | -- dd if=/dev/urandom of=key.bin bs=1M count=1 5 | -- 6 | -- a file to encrypt: 7 | -- dd if=/dev/urandom of=plain.bin bs=1M count=24 8 | 9 | import qualified Data.ByteString as B 10 | import Data.Bits (xor) 11 | import System.Environment (getArgs) 12 | 13 | encrypt :: B.ByteString -> B.ByteString -> B.ByteString 14 | encrypt key plain = go key plain 15 | where 16 | keyLength = B.length key 17 | 18 | go k0 b 19 | | B.null b = B.empty 20 | | otherwise = 21 | let (b0, bn) = B.splitAt keyLength b 22 | r0 = B.pack $ B.zipWith xor k0 b0 23 | in r0 `B.append` go b0 bn 24 | 25 | decrypt :: B.ByteString -> B.ByteString -> B.ByteString 26 | decrypt key plain = go key plain 27 | where 28 | keyLength = B.length key 29 | 30 | go k0 b 31 | | B.null b = B.empty 32 | | otherwise = 33 | let (b0, bn) = B.splitAt keyLength b 34 | r0 = B.pack $ B.zipWith xor k0 b0 35 | in r0 `B.append` go r0 bn 36 | 37 | main = do 38 | [action, keyFile, inputFile] <- getArgs 39 | key <- B.readFile keyFile 40 | input <- B.readFile inputFile 41 | case action of 42 | "encrypt" -> B.writeFile (inputFile ++ ".out") $ encrypt key input 43 | "decrypt" -> B.writeFile (inputFile ++ ".out") $ decrypt key input 44 | -------------------------------------------------------------------------------- /Chapter09/gsum.hs: -------------------------------------------------------------------------------- 1 | -- file: gsum.hs 2 | 3 | {-# LANGUAGE DefaultSignatures #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE TypeOperators #-} 6 | 7 | {-# LANGUAGE DeriveGeneric #-} 8 | {-# LANGUAGE DeriveAnyClass #-} 9 | {-# LANGUAGE StandaloneDeriving #-} 10 | 11 | import GHC.Generics 12 | 13 | class GSum' f where 14 | gsum' :: f p -> Double 15 | 16 | class GSum a where 17 | gsum :: a -> Double 18 | 19 | default gsum :: (Generic a, GSum' (Rep a)) => a -> Double 20 | gsum = gsum' . from 21 | 22 | instance GSum Double where 23 | gsum = id 24 | 25 | instance GSum Int where 26 | gsum = fromIntegral 27 | 28 | instance GSum Integer where 29 | gsum = fromInteger 30 | 31 | --------------------------------- 32 | 33 | instance GSum' V1 where 34 | gsum' _ = undefined 35 | 36 | instance GSum' U1 where 37 | gsum' U1 = 1 38 | 39 | instance (GSum' f, GSum' g) => GSum' (f :+: g) where 40 | gsum' (L1 x) = gsum' x 41 | gsum' (R1 y) = gsum' y 42 | 43 | instance (GSum' f, GSum' g) => GSum' (f :*: g) where 44 | gsum' (x :*: y) = gsum' x + gsum' y 45 | 46 | instance GSum c => GSum' (K1 i c) where 47 | gsum' (K1 x) = gsum x 48 | 49 | instance GSum' f => GSum' (M1 i t f) where 50 | gsum' (M1 x) = gsum' x 51 | 52 | ---------------------------------- 53 | 54 | deriving instance (GSum a, GSum b) => GSum (Either a b) 55 | deriving instance (GSum a, GSum b) => GSum (a, b) 56 | 57 | data T a b = TA a | TB b | TAB a b 58 | deriving (Generic, GSum) 59 | -------------------------------------------------------------------------------- /Chapter12/first-example.hs: -------------------------------------------------------------------------------- 1 | -- file: first-exmaple.hs 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | 5 | import Control.Distributed.Process 6 | import Control.Distributed.Process.Closure 7 | import Control.Distributed.Process.Node (initRemoteTable) 8 | import Control.Distributed.Process.Backend.SimpleLocalnet 9 | 10 | import Data.Binary (Binary) 11 | import Data.Typeable (Typeable) 12 | import GHC.Generics (Generic) 13 | 14 | data SummerMsg = Add Int ProcessId 15 | | Value Int 16 | deriving (Show, Typeable, Generic) 17 | 18 | instance Binary SummerMsg 19 | 20 | summerProc :: Process () 21 | summerProc = go 0 22 | where 23 | go s = do msg@(Add num from) <- expect 24 | say $ "received msg: " ++ show msg 25 | let s' = s + num 26 | send from (Value s') 27 | go s' 28 | 29 | remotable ['summerProc] 30 | 31 | summerTest :: Process () 32 | summerTest = do 33 | node <- getSelfNode 34 | summerPid <- spawn node $(mkStaticClosure 'summerProc) 35 | 36 | mypid <- getSelfPid 37 | 38 | send summerPid (Add 5 mypid) 39 | send summerPid (Add 7 mypid) 40 | 41 | Value n <- expect 42 | say $ "updated value: " ++ show n 43 | Value n' <- expect 44 | say $ "updated value: " ++ show n' 45 | 46 | main :: IO () 47 | main = do 48 | backend <- initializeBackend "localhost" "9001" (__remoteTable initRemoteTable) 49 | startMaster backend $ \_ -> summerTest 50 | -------------------------------------------------------------------------------- /Chapter03/encryption-optimized.hs: -------------------------------------------------------------------------------- 1 | -- file: encryption-optimized.hs 2 | 3 | import qualified Data.ByteString as B 4 | import qualified Data.ByteString.Lazy as L 5 | import qualified Data.ByteString.Builder as Builder 6 | import Data.Bits (xor) 7 | import System.Environment (getArgs) 8 | 9 | encrypt :: B.ByteString -> B.ByteString -> B.ByteString 10 | encrypt key plain = L.toStrict $ Builder.toLazyByteString $ go key plain 11 | where 12 | keyLength = B.length key 13 | 14 | go k0 b 15 | | B.null b = mempty 16 | | otherwise = 17 | let (b0, bn) = B.splitAt keyLength b 18 | r0 = mconcat $ map Builder.word8 $ B.zipWith xor k0 b0 19 | in r0 `mappend` go b0 bn 20 | 21 | decrypt :: B.ByteString -> B.ByteString -> B.ByteString 22 | decrypt key plain = L.toStrict $ Builder.toLazyByteString $ go (Builder.byteString key) plain 23 | where 24 | keyLength = B.length key 25 | 26 | go k0 b 27 | | B.null b = mempty 28 | | otherwise = 29 | let (b0, bn) = B.splitAt keyLength b 30 | r0 = mconcat $ map Builder.word8 $ B.zipWith xor (L.toStrict $ Builder.toLazyByteString k0) b0 31 | in r0 `mappend` go r0 bn 32 | 33 | main = do 34 | [action, keyFile, inputFile] <- getArgs 35 | key <- B.readFile keyFile 36 | input <- B.readFile inputFile 37 | case action of 38 | "encrypt" -> B.writeFile (inputFile ++ ".out") $ encrypt key input 39 | "decrypt" -> B.writeFile (inputFile ++ ".out") $ decrypt key input 40 | -------------------------------------------------------------------------------- /Chapter13/elerea-first-ex.hs: -------------------------------------------------------------------------------- 1 | -- file: elerea-first-ex.hs 2 | 3 | {-# LANGUAGE RecursiveDo #-} 4 | 5 | import Control.Monad 6 | import Control.Applicative 7 | import Control.Monad.IO.Class 8 | import FRP.Elerea.Simple 9 | 10 | sigtest :: Show a => SignalGen (Signal a) -> IO () 11 | sigtest gen = start gen >>= replicateM 10 >>= print 12 | 13 | fibonacci :: SignalGen (Signal Int) 14 | fibonacci = do 15 | rec fib <- delay 1 fib1 16 | fib1 <- delay 1 fib2 17 | let fib2 = (+) <$> fib <*> fib1 18 | return fib 19 | 20 | -- signaling side-effects 21 | 22 | linesum :: SignalGen (Signal ()) 23 | linesum = 24 | fmap (fmap read) (effectful getLine) 25 | >>= transfer (0::Int) (+) 26 | >>= effectful1 (putStrLn . ("sum: " ++) . show) 27 | 28 | memoizing :: SignalGen (Signal Int) 29 | memoizing = do 30 | ln <- effectful getLine 31 | sums <- transfer (0::Int) (+) 32 | 33 | 34 | -- dynamic countdowns 35 | 36 | countdown :: Int -> SignalGen (Signal Int) 37 | countdown n = stateful n (subtract 1) 38 | 39 | -- Implementation taken from Elerea's haddocks 40 | collection :: Signal [Signal a] -> (a -> Bool) -> SignalGen (Signal [a]) 41 | collection source isAlive = mdo 42 | sig <- delay [] (map snd <$> collWithVals') 43 | coll <- memo (liftA2 (++) source sig) 44 | let collWithVals = zip <$> (sequence =<< coll) <*> coll 45 | collWithVals' <- memo (filter (isAlive . fst) <$> collWithVals) 46 | return $ map fst <$> collWithVals' 47 | 48 | readCountdowns :: SignalGen (Signal [Signal Int]) 49 | readCountdowns = do 50 | input <- effectful getLine 51 | generator $ do -- Signal (SignalGen [Signal Int]) 52 | x <- input 53 | return $ case x of 54 | "" -> return [] 55 | _ -> return <$> countdown (read x) 56 | 57 | runCountdowns :: SignalGen (Signal [Int]) 58 | runCountdowns = do 59 | csig <- readCountdowns 60 | collection csig (> 0) 61 | -------------------------------------------------------------------------------- /Chapter13/yampa.hs: -------------------------------------------------------------------------------- 1 | -- file: yampa.hs 2 | 3 | import FRP.Yampa 4 | 5 | import Control.Monad (when) 6 | 7 | square :: SF Double Double 8 | square = arr (^2) 9 | 10 | f :: SF Double Double 11 | f = arr (+1) >>> arr (^2) 12 | 13 | cSum :: SF Int Int 14 | cSum = loop (second (iPre 0) >>^ go) 15 | where go (x,s) = let s' = x + s in (s', s') 16 | 17 | tick :: SF a Time 18 | tick = time >>> loopPre 0 (arr (\(t, t') -> (t - t', t))) 19 | 20 | switchFooBar, switchFooBar' :: SF () String 21 | switchFooBar = switch (constant "foo" &&& after 2 "bar") constant 22 | switchFooBar' = dSwitch (constant "foo" &&& after 2 "bar") constant 23 | 24 | switchRec :: SF () String 25 | switchRec = go (0, "foo", "bar") 26 | where 27 | go (t, x, y) = 28 | switch (constant x &&& after (t + 2) (t + 2, y, x)) go 29 | 30 | swap :: SF Bool String 31 | swap = rSwitch foo <<< identity &&& swapEv 32 | where 33 | swapEv = edge >>> sscanPrim go True (Event foo) 34 | go tag = event Nothing $ \_ -> 35 | Just (not tag, Event $ if tag then bar else foo) 36 | 37 | foo = constant "foo" 38 | bar = constant "bar" 39 | 40 | withCC :: SF Int Int 41 | withCC = kSwitch (arr (+1)) trigger cont 42 | where 43 | trigger :: SF (Int, Int) (Event (Int -> Int)) 44 | trigger = sscan f NoEvent 45 | 46 | f _ (inp,_) | inp > 1 && inp < 10 = Event (*inp) 47 | | otherwise = NoEvent 48 | 49 | cont :: SF Int Int -> (Int -> Int) -> SF Int Int 50 | cont f f' = f >>> arr f' 51 | 52 | 53 | 54 | 55 | main = reactimate init sense actuate sf 56 | where 57 | init = return "0" 58 | 59 | sense _ = do ln <- getLine 60 | return (1, Just ln) 61 | 62 | actuate _ out = do putStrLn out 63 | return (out == "END") 64 | 65 | sf = arr read >>> 66 | sscan (+) 0 >>> 67 | dSwitch (arr show &&& arr (filterE (>= 42) . Event)) (\_ -> constant "END") 68 | -------------------------------------------------------------------------------- /Chapter06/io-streams-parser.hs: -------------------------------------------------------------------------------- 1 | -- file: io-streams-parser.hs 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | import Data.Monoid ((<>)) 5 | import Control.Applicative ((<|>)) 6 | import Data.ByteString (ByteString) 7 | import Data.Attoparsec.ByteString.Char8 as PC8 8 | import System.IO.Streams (Generator, InputStream, OutputStream) 9 | import qualified System.IO.Streams as S 10 | 11 | import System.IO.Streams.File (withFileAsInput) 12 | import System.IO.Streams.Attoparsec (parserToInputStream) 13 | 14 | data Line = Notification ByteString | Message Time User ByteString deriving Show 15 | type Time = ByteString 16 | type User = ByteString 17 | 18 | {- Input format 19 | 20 | [00:50] It is the power of the mind to be unconquerable 21 | [05:03] The monad here is nothing but a simple substance which enters into compounds 22 | [00:01] Warriors should suffer their pain silently 23 | 24 | -} 25 | 26 | timeParser :: Parser Time 27 | timeParser = char '[' *> takeWhile1 (/= ']') <* char ']' <* PC8.takeWhile (== ' ') 28 | 29 | userParser :: Parser User 30 | userParser = char '<' *> takeWhile1 (/= '>') <* char '>' <* PC8.takeWhile (== ' ') 31 | 32 | lineParser, messageParser, notificationParser :: Parser Line 33 | 34 | lineParser = messageParser <|> notificationParser 35 | 36 | notificationParser = string "=== " *> (Notification <$> PC8.takeWhile (/= '\n')) 37 | 38 | messageParser = Message <$> timeParser <*> userParser <*> PC8.takeWhile (/= '\n') 39 | 40 | -------------------------------------------- 41 | 42 | logParser :: Parser (Maybe Line) 43 | logParser = (endOfInput *> pure Nothing) <|> 44 | (fmap Just lineParser <* PC8.takeWhile (== '\n')) 45 | 46 | lineOutputStream :: IO (OutputStream Line) 47 | lineOutputStream = S.contramapMaybe f =<< S.ignoreEof S.stdout 48 | where 49 | f (Message _ _ msg) = Just (msg <> "\n") 50 | f _ = Nothing 51 | 52 | main = withFileAsInput "messages.log" $ \is -> do 53 | lines <- parserToInputStream logParser is 54 | outs <- lineOutputStream 55 | S.connect lines outs 56 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | # Haskell High Performance Programming 5 | This is the code repository for [Haskell High Performance Programming](https://www.packtpub.com/application-development/haskell-high-performance-programming?utm_source=github&utm_medium=repository&utm_campaign=9781786464217) By Packt. It contains all the supporting project files necessary to work through the book from start to finish. 6 | 7 | ## Instructions and Navigation 8 | All of the code is organized into folders. Each folder starts with number followed by the application name. For example, Chapter02. 9 | 10 | You will see code something similar to the following: 11 | 12 | ```haskell 13 | class Some a where 14 | next :: a -> a -> a 15 | 16 | instance Some Double where 17 | next a b = (a + b) / 2 18 | 19 | goGeneral :: Some a => Int -> a -> a 20 | goGeneral 0 x = x 21 | goGeneral n x = goGeneral (n-1) (next x x) 22 | 23 | ``` 24 | 25 | Software and Hardware List 26 | 27 | | Chapter | Software required | OS required | 28 | | -------- | ------------------- | ------------| 29 | | 1 to 14 | GHC >= 7.6 | Windows | 30 | | 4 | Haskell Stack tool | Windows | 31 | | 11 | CUDA-enabled system | Windows | 32 | 33 | 34 | 35 | ## Related Haskell Products: 36 | * [Haskell Data Analysis Cookbook](https://www.packtpub.com/big-data-and-business-intelligence/haskell-data-analysis-cookbook?utm_source=github&utm_medium=repository&utm_campaign=9781783286331) 37 | * [Haskell Design Patterns](https://www.packtpub.com/application-development/haskell-design-patterns?utm_source=github&utm_medium=repository&utm_campaign=9781783988723) 38 | * [Learning Haskell Data Analysis](https://www.packtpub.com/big-data-and-business-intelligence/learning-haskell-data-analysis?utm_source=github&utm_medium=repository&utm_campaign=9781784394707) 39 | 40 | 41 | 42 | 43 | 44 | 45 | ### Suggestions and Feedback 46 | [Click here](https://docs.google.com/forms/d/e/1FAIpQLSe5qwunkGf6PUvzPirPDtuy1Du5Rlzew23UBp2S-P3wB-GcwQ/viewform) if you have any feedback or suggestions. 47 | ### Download a free PDF 48 | 49 | If you have already purchased a print or Kindle version of this book, you can get a DRM-free PDF version at no cost.
Simply click on the link to claim your free PDF. 50 |

https://packt.link/free-ebook/9781786464217

-------------------------------------------------------------------------------- /Chapter05/letterrec.hs: -------------------------------------------------------------------------------- 1 | -- file: letterrec.hs 2 | {-# LANGUAGE QuasiQuotes #-} 3 | {-# LANGUAGE BangPatterns #-} 4 | 5 | import Data.Array.Repa as Repa 6 | import Data.Array.Repa.IO.BMP as BMP 7 | import Data.Array.Repa.Algorithms.Pixel as Pixel 8 | import Data.Array.Repa.Algorithms.Convolve as Conv 9 | import Data.Array.Repa.Unsafe as Unsafe 10 | import Data.List (foldl1') 11 | 12 | type Image r = Array r DIM2 Double 13 | 14 | readImage :: FilePath -> IO (Image U) 15 | readImage !fp = do 16 | result <- BMP.readImageFromBMP fp 17 | computeP $ mirror $ case result of 18 | Left err -> error "readImage: Failed to load image from file" 19 | Right array -> Repa.map Pixel.doubleLuminanceOfRGB8 array 20 | 21 | mirror :: Image D -> Image D 22 | mirror !img = Unsafe.unsafeBackpermute (extent img) (\(Z :. x :. y) -> ix2 (mx - 1 - x) y) img 23 | where Z :. mx :. _ = extent img 24 | 25 | sta, stb, stc :: Image U 26 | 27 | sta = fromListUnboxed (ix2 8 5) 28 | [ -1, -1, -1, -1, -1 29 | , -1, -1, -1, -1, -1 30 | , -1, 1, 1, 1, -1 31 | , -1, -1, -1, -1, 1 32 | , -1, 1, 1, 1, 1 33 | , 1, -1, -1, -1, 1 34 | , 1, -1, -1, -1, 1 35 | , -1, 1, 1, 1, 1 ] 36 | 37 | stb = fromListUnboxed (ix2 8 5) 38 | [ 1, -1, -1, -1, -1 39 | , 1, -1, -1, -1, -1 40 | , 1, 1, 1, 1, -1 41 | , 1, -1, -1, -1, 1 42 | , 1, -1, -1, -1, 1 43 | , 1, -1, -1, -1, 1 44 | , 1, -1, -1, -1, 1 45 | , 1, 1, 1, 1, -1 ] 46 | 47 | stc = fromListUnboxed (ix2 8 5) 48 | [ -1, -1, -1, -1, -1 49 | , -1, -1, -1, -1, -1 50 | , -1, 1, 1, 1, -1 51 | , 1, -1, -1, -1, 1 52 | , 1, -1, -1, -1, -1 53 | , 1, -1, -1, -1, -1 54 | , 1, -1, -1, -1, 1 55 | , -1, 1, 1, 1, -1 ] 56 | 57 | std :: Image U 58 | std = computeUnboxedS . transpose . mirror $ transpose stb 59 | 60 | {-# INLINE sta #-} 61 | {-# INLINE stb #-} 62 | {-# INLINE stc #-} 63 | {-# INLINE std #-} 64 | 65 | {-# INLINE match #-} 66 | 67 | {-# INLINE recognize #-} 68 | 69 | {-# INLINE readImage #-} 70 | 71 | {-# INLINE mirror #-} 72 | 73 | match :: Monad m => Char -> Image U -> Image U -> m (Array D DIM2 Char) 74 | match !char !stencil !image = do 75 | let !threshold = sumAllS (Repa.map (max 0) stencil) - 0.1 76 | res <- convolveP (const 0) stencil image 77 | return $! Repa.map (\(!x) -> if x > threshold then char else '\NUL') res 78 | 79 | recognize :: Monad m => Image U -> m String 80 | recognize !img = do 81 | let !recs = [ match c st img 82 | | (c, st) <- [ ('a', sta), ('b', stb), ('c', stc), ('d', std) ] ] 83 | letters <- sequence recs 84 | combined <- computeUnboxedP $ foldl1' (Repa.zipWith max) letters 85 | let !(Z :. _ :. my) = extent combined 86 | !lineEnds = Unsafe.unsafeTraverse combined id $ \f ix@(Z :. _ :. y) -> 87 | if y == my - 1 then '\n' else f ix 88 | return $! unlines . words $ filter (/= '\NUL') $ toList lineEnds 89 | 90 | main = do 91 | img <- readImage "image.bmp" 92 | str <- recognize img 93 | putStr str 94 | -------------------------------------------------------------------------------- /Chapter02/seq-memory-usage.svg: -------------------------------------------------------------------------------- 1 | 2 | 5 | Qt SVG Document 6 | Generated with Qt 7 | 8 | 9 | 10 | 11 | 14 | 15 | 16 | 19 | 20 | 21 | 24 | 25 | 26 | 27 | 30 | 31 | 32 | 33 | 34 | 37 | 38 | 39 | 42 | 43 | 44 | 47 | 48 | 49 | 52 | 53 | 54 | 57 | 58 | 59 | 62 | 63 | 64 | 67 | 0 69 | 70 | 71 | 74 | 75 | 76 | 79 | 80 | 81 | 84 | 85 | 86 | 87 | 90 | 91 | 92 | 93 | 94 | 97 | 98 | 99 | 102 | 103 | 104 | 107 | 108 | 109 | 112 | 113 | 114 | 117 | 118 | 119 | 122 | 123 | 124 | 127 | 0.5 129 | 130 | 131 | 134 | 135 | 136 | 139 | 140 | 141 | 144 | 145 | 146 | 147 | 150 | 151 | 152 | 153 | 154 | 157 | 158 | 159 | 162 | 163 | 164 | 167 | 168 | 169 | 172 | 173 | 174 | 177 | 178 | 179 | 182 | 183 | 184 | 187 | 1 189 | 190 | 191 | 194 | 195 | 196 | 199 | 200 | 201 | 204 | 205 | 206 | 207 | 210 | 211 | 212 | 213 | 214 | 217 | 218 | 219 | 222 | 223 | 224 | 227 | 228 | 229 | 232 | 233 | 234 | 237 | 238 | 239 | 242 | 243 | 244 | 247 | 1.5 249 | 250 | 251 | 254 | 255 | 256 | 259 | 260 | 261 | 264 | 265 | 266 | 267 | 270 | 271 | 272 | 273 | 274 | 277 | 278 | 279 | 282 | 283 | 284 | 287 | 288 | 289 | 292 | 293 | 294 | 297 | 298 | 299 | 302 | 303 | 304 | 307 | 2 309 | 310 | 311 | 314 | 315 | 316 | 319 | 320 | 321 | 324 | 325 | 326 | 327 | 330 | 331 | 332 | 333 | 334 | 337 | 338 | 339 | 342 | 343 | 344 | 347 | 348 | 349 | 352 | 353 | 354 | 357 | 358 | 359 | 362 | 363 | 364 | 367 | 2.5 369 | 370 | 371 | 374 | 375 | 376 | 379 | 380 | 381 | 384 | 385 | 386 | 387 | 390 | 391 | 392 | 393 | 394 | 397 | 398 | 399 | 402 | 403 | 404 | 407 | 408 | 409 | 412 | 413 | 414 | 417 | 418 | 419 | 422 | 423 | 424 | 427 | 3 429 | 430 | 431 | 434 | 435 | 436 | 439 | 440 | 441 | 444 | 445 | 446 | 447 | 450 | 451 | 452 | 453 | 454 | 457 | 458 | 459 | 462 | 463 | 464 | 467 | 468 | 469 | 472 | 473 | 474 | 477 | 478 | 479 | 482 | 483 | 484 | 487 | 3.5 489 | 490 | 491 | 494 | 495 | 496 | 499 | 500 | 501 | 504 | 505 | 506 | 507 | 510 | 511 | 512 | 513 | 514 | 517 | 518 | 519 | 522 | 523 | 524 | 527 | 528 | 529 | 532 | 533 | 534 | 537 | 538 | 539 | 542 | 543 | 544 | 547 | 4 549 | 550 | 551 | 554 | 555 | 556 | 559 | 560 | 561 | 564 | 565 | 566 | 567 | 570 | 571 | 572 | 573 | 574 | 577 | 578 | 579 | 582 | 583 | 584 | 587 | 588 | 589 | 592 | 593 | 594 | 597 | 598 | 599 | 602 | 603 | 604 | 607 | 10 609 | 610 | 611 | 614 | 615 | 616 | 619 | 620 | 621 | 624 | 625 | 626 | 627 | 630 | 631 | 632 | 633 | 634 | 637 | 638 | 639 | 642 | 643 | 644 | 647 | 648 | 649 | 652 | 653 | 654 | 657 | 658 | 659 | 662 | 663 | 664 | 667 | 20 669 | 670 | 671 | 674 | 675 | 676 | 679 | 680 | 681 | 684 | 685 | 686 | 687 | 690 | 691 | 692 | 693 | 694 | 697 | 698 | 699 | 702 | 703 | 704 | 707 | 708 | 709 | 712 | 713 | 714 | 717 | 718 | 719 | 722 | 723 | 724 | 727 | 30 729 | 730 | 731 | 734 | 735 | 736 | 739 | 740 | 741 | 744 | 745 | 746 | 747 | 750 | 751 | 752 | 753 | 754 | 757 | 758 | 759 | 762 | 763 | 764 | 767 | 768 | 769 | 772 | 773 | 774 | 777 | 778 | 779 | 782 | 783 | 784 | 787 | 40 789 | 790 | 791 | 794 | 795 | 796 | 799 | 800 | 801 | 804 | 805 | 806 | 807 | 810 | 811 | 812 | 813 | 814 | 817 | 818 | 819 | 822 | 823 | 824 | 827 | 828 | 829 | 832 | 833 | 834 | 837 | 838 | 839 | 842 | 843 | 844 | 847 | 50 849 | 850 | 851 | 854 | 855 | 856 | 859 | 860 | 861 | 864 | 865 | 866 | 867 | 868 | 871 | 872 | 873 | 874 | 875 | 878 | 879 | 880 | 883 | 884 | 885 | 888 | 889 | 890 | 893 | 894 | 895 | 898 | 899 | 900 | 903 | 904 | 905 | 908 | 60 910 | 911 | 912 | 915 | 916 | 917 | 920 | 921 | 922 | 925 | 926 | 927 | 928 | 929 | 932 | 933 | 934 | 935 | 936 | 939 | 940 | 941 | 944 | 945 | 946 | 949 | 950 | 951 | 954 | 955 | 956 | 959 | 960 | 961 | 964 | 965 | 966 | 969 | 70 971 | 972 | 973 | 976 | 977 | 978 | 981 | 982 | 983 | 986 | 987 | 988 | 989 | 990 | 993 | 994 | 995 | 996 | 997 | 1000 | 1001 | 1002 | 1005 | 1006 | 1007 | 1010 | 1011 | 1012 | 1015 | 1016 | 1017 | 1020 | 1021 | 1022 | 1025 | 1026 | 1027 | 1030 | 80 1032 | 1033 | 1034 | 1037 | 1038 | 1039 | 1042 | 1043 | 1044 | 1047 | 1048 | 1049 | 1050 | 1051 | 1054 | 1055 | 1056 | 1057 | 1058 | 1061 | 1062 | 1063 | 1066 | 1067 | 1068 | 1071 | 1072 | 1073 | 1076 | 1077 | 1078 | 1081 | 1082 | 1083 | 1086 | 1087 | 1088 | 1091 | 90 1093 | 1094 | 1095 | 1098 | 1099 | 1100 | 1103 | 1104 | 1105 | 1108 | 1109 | 1110 | 1111 | 1112 | 1115 | 1116 | 1117 | 1118 | 1119 | 1122 | 1123 | 1124 | 1127 | 1128 | 1129 | 1132 | 1133 | 1134 | 1137 | 1138 | 1139 | 1142 | 1143 | 1144 | 1147 | 1148 | 1149 | 1152 | 100 1154 | 1155 | 1156 | 1159 | 1160 | 1161 | 1164 | 1165 | 1166 | 1169 | 1170 | 1171 | 1172 | 1173 | 1176 | 1177 | 1178 | 1179 | 1180 | 1183 | 1184 | 1185 | 1188 | 1189 | 1190 | 1193 | 1194 | 1195 | 1198 | 1199 | 1200 | 1203 | 1204 | 1205 | 1208 | 1209 | 1210 | 1213 | 110 1215 | 1216 | 1217 | 1220 | 1221 | 1222 | 1225 | 1226 | 1227 | 1230 | 1231 | 1232 | 1233 | 1236 | 1237 | 1238 | 1239 | 1240 | 1243 | 1244 | 1245 | 1248 | 1249 | 1250 | 1253 | 1254 | 1255 | 1258 | 1259 | 1260 | 1263 | 1264 | 1265 | 1268 | 1269 | 1270 | 1273 | 120 1275 | 1276 | 1277 | 1280 | 1281 | 1282 | 1285 | 1286 | 1287 | 1290 | 1291 | 1292 | 1293 | 1294 | 1297 | 1298 | 1299 | 1302 | 1303 | 1304 | 1307 | 1308 | 1309 | 1312 | 1313 | 1314 | 1317 | 1318 | 1319 | 1322 | 1323 | 1324 | 1327 | Performance with different buffer sizes 1329 | 1330 | 1331 | 1334 | 1335 | 1336 | 1339 | 1340 | 1341 | 1344 | 1345 | 1346 | 1349 | 1350 | 1351 | 1354 | 1355 | 1356 | 1359 | 1360 | 1361 | 1364 | Heap usage (gigabytes) 1366 | 1367 | 1368 | 1371 | 1372 | 1373 | 1376 | 1377 | 1378 | 1381 | 1382 | 1383 | 1384 | 1387 | 1388 | 1389 | 1392 | 1393 | 1394 | 1397 | 1398 | 1399 | 1402 | 1403 | 1404 | 1407 | 1408 | 1409 | 1410 | 1413 | 1414 | 1415 | 1418 | 1419 | 1420 | 1423 | 1424 | 1425 | 1426 | 1429 | 1430 | 1431 | 1434 | 1435 | 1436 | 1437 | --------------------------------------------------------------------------------