ghci

GHCi, version 6.8.3: http://www.haskell.org/ghc/  :? for help

Loading package base ... linking ... done.

          

          :set prompt "ghci> "

          

[1, 2, 3]

[1,2,3]

[]

[]

["foo", "bar", "baz", "quux", "fnord", "xyzzy"]

["foo","bar","baz","quux","fnord","xyzzy"]

[True, False, "testing"]



<interactive>:1:14:

    Couldn't match expected type `Bool' against inferred type `[Char]'

    In the expression: "testing"

    In the expression: [True, False, "testing"]

    In the definition of `it': it = [True, False, "testing"]

[1..10]

[1,2,3,4,5,6,7,8,9,10]

[1.0,1.25..2.0]

[1.0,1.25,1.5,1.75,2.0]

[1,4..15]

[1,4,7,10,13]

[10,9..1]

[10,9,8,7,6,5,4,3,2,1]

"This is a string."

"This is a string."

putStrLn "Here's a newline -->\n<-- See?"

Here's a newline -->

<-- See?

'a'

'a'

let a = ['l', 'o', 't', 's', ' ', 'o', 'f', ' ', 'w', 'o', 'r', 'k']a

"lots of work"

a == "lots of work"

True

"" == []

True

'a':"bc"

"abc"

"foo" ++ "bar"

"foobar"

:set +t'c'

'c'

it :: Char

"foo"

"foo"

it :: [Char]

"foo"

"foo"

it :: [Char]

it ++ "bar"

"foobar"

it :: [Char]

it

"foobar"

it :: [Char]

it ++ 3



<interactive>:1:6:

    No instance for (Num [Char])

      arising from the literal `3' at <interactive>:1:6

    Possible fix: add an instance declaration for (Num [Char])

    In the second argument of `(++)', namely `3'

    In the expression: it ++ 3

    In the definition of `it': it = it ++ 3

-- file: ch01/WC.hs

-- lines beginning with "--" are comments.



main = interact wordCount

    where wordCount input = show (length (lines input)) ++ "\n"

cat quux.txt

Teignmouth, England

Paris, France

Ulm, Germany

Auxerre, France

Brunswick, Germany

Beaumont-en-Auge, France

Ryazan, Russia

runghc WC < quux.txt

7

:type 'a'

'a' :: Char

'a' :: Char

'a'

[1,2,3] :: Int



<interactive>:1:0:

    Couldn't match expected type `Int' against inferred type `[a]'

    In the expression: [1, 2, 3] :: Int

    In the definition of `it': it = [1, 2, 3] :: Int

odd 3

True

odd 6

False

compare 2 3

LT

compare 3 3

EQ

compare 3 2

GT

(compare 2 3) == LT

True

compare 2 3 == LT

True

compare (sqrt 3) (sqrt 6)

LT

head [1,2,3,4]

1

head ['a','b','c']

'a'

tail [1,2,3,4]

[2,3,4]

tail [2,3,4]

[3,4]

tail [True,False]

[False]

tail "list"

"ist"

tail []

*** Exception: Prelude.tail: empty list

:type [[True],[False,False]]

[[True],[False,False]] :: [[Bool]]

take 2 [1,2,3,4,5]

[1,2]

drop 3 [1,2,3,4,5]

[4,5]

fst (1,'a')

1

snd (1,'a')

'a'

head (drop 4 "azerty")

't'

:type lines

lines :: String -> [String]

lines "the quick\nbrown fox\njumps"

["the quick","brown fox","jumps"]

:type readFile

readFile :: FilePath -> IO String

-- file: ch03/add.hs

add a b = a + b

:load add.hs

[1 of 1] Compiling Main             ( add.hs, interpreted )

Ok, modules loaded: Main.

add 1 2

3

          

          :cd /tmp

last [1,2,3,4,5]

5

last "baz"

'z'

:type last

last :: [a] -> a

:type take

take :: Int -> [a] -> [a]

-- file: ch02/Take.hs

take :: Int -> ([a] -> [a])

-- file: ch02/myDrop.hs

myDrop :: Int -> [a] -> [a]

:type not

not :: Bool -> Bool

-- file: ch03/BookStore.hs

data BookInfo = Book Int String [String]

                deriving (Show)

-- file: ch03/BookStore.hs

type CustomerID = Int

type ReviewBody = String



data BetterReview = BetterReview BookInfo CustomerID ReviewBody

-- file: ch03/BookStore.hs

type BookRecord = (BookInfo, BookReview)

-- file: ch03/Bool.hs

data Bool = False | True

-- file: ch03/BookStore.hs

type CardHolder = String

type CardNumber = String

type Address = [String]



data BillingInfo = CreditCard CardNumber CardHolder Address

                 | CashOnDelivery

                 | Invoice CustomerID

                   deriving (Show)

:type CreditCard

CreditCard :: CardNumber -> CardHolder -> Address -> BillingInfo

CreditCard "2901650221064486" "Thomas Gradgrind" ["Dickens", "England"]

CreditCard "2901650221064486" "Thomas Gradgrind" ["Dickens","England"]

:type it

it :: BillingInfo

Invoice



<interactive>:1:0:

    No instance for (Show (CustomerID -> BillingInfo))

      arising from a use of `print' at <interactive>:1:0-6

    Possible fix:

      add an instance declaration for (Show (CustomerID -> BillingInfo))

    In the expression: print it

    In a stmt of a 'do' expression: print it

:type it

it :: BillingInfo

-- file: ch03/add.hs

myNot True  = False

myNot False = True

-- file: ch03/add.hs

sumList (x:xs) = x + sumList xs

sumList []     = 0

-- file: ch03/BookStore.hs

nicerID      (Book id _     _      ) = id

nicerTitle   (Book _  title _      ) = title

nicerAuthors (Book _  _     authors) = authors

-- file: ch03/BookStore.hs

data Customer = Customer {

      customerID      :: CustomerID

    , customerName    :: String

    , customerAddress :: Address

    } deriving (Show)

-- file: ch03/AltCustomer.hs

data Customer = Customer Int String [String]

                deriving (Show)



customerID :: Customer -> Int

customerID (Customer id _ _) = id



customerName :: Customer -> String

customerName (Customer _ name _) = name



customerAddress :: Customer -> [String]

customerAddress (Customer _ _ address) = address

:type customerID

customerID :: Customer -> CustomerID

-- file: ch03/BookStore.hs

customer1 = Customer 271828 "J.R. Hacker"

            ["255 Syntax Ct",

             "Milpitas, CA 95134",

             "USA"]

-- file: ch03/BookStore.hs

customer2 = Customer {

              customerID = 271828

            , customerAddress = ["1048576 Disk Drive",

                                 "Milpitas, CA 95134",

                                 "USA"]

            , customerName = "Jane Q. Citizen"

            }

-- file: ch03/Nullable.hs

data Maybe a = Just a

             | Nothing

-- file: ch03/Nullable.hs

someBool = Just True



someString = Just "something"

Just 1.5

Just 1.5

Nothing

Nothing

:type Just "invisible bike"

Just "invisible bike" :: Maybe [Char]

-- file: ch03/Nullable.hs

wrapped = Just (Just "wrapped")

-- file: ch03/ListADT.hs

data List a = Cons a (List a)

            | Nil

              deriving (Show)

Nil

Nil

Cons 0 Nil

Cons 0 Nil

Cons 1 it

Cons 1 (Cons 0 Nil)

Cons 2 it

Cons 2 (Cons 1 (Cons 0 Nil))

Cons 3 it

Cons 3 (Cons 2 (Cons 1 (Cons 0 Nil)))

-- file: ch03/Tree.hs

data Tree a = Node a (Tree a) (Tree a)

            | Empty

              deriving (Show)

-- file: ch03/ListADT.hs

fromList (x:xs) = Cons x (fromList xs)

fromList []     = Nil

fromList "durian"

Cons 'd' (Cons 'u' (Cons 'r' (Cons 'i' (Cons 'a' (Cons 'n' Nil)))))

fromList [Just True, Nothing, Just False]

Cons (Just True) (Cons Nothing (Cons (Just False) Nil))

-- file: ch03/MySecond.hs

mySecond :: [a] -> a



mySecond xs = if null (tail xs)

              then error "list too short"

              else head (tail xs)

mySecond "xi"

'i'

mySecond [2]

*** Exception: list too short

head (mySecond [[9]])

*** Exception: list too short

mySecond []

*** Exception: Prelude.tail: empty list

-- file: ch03/MySecond.hs

safeSecond :: [a] -> Maybe a



safeSecond [] = Nothing

safeSecond xs = if null (tail xs)

                then Nothing

                else Just (head (tail xs))

-- file: ch03/Lending.hs

lend amount balance = let reserve    = 100

                          newBalance = balance - amount

                      in if balance < reserve

                         then Nothing

                         else Just newBalance

-- file: ch03/NestedLets.hs

foo = let a = 1

      in let b = 2

         in a + b

-- file: ch03/GoodIndent.hs

-- This is the leftmost column.



  -- It's fine for top-level declarations to start in any column...

  firstGoodIndentation = 1



  -- ...provided all subsequent declarations do, too!

  secondGoodIndentation = 2

-- file: ch03/BadIndent.hs

-- This is the leftmost column.



    -- Our first declaration is in column 4.

    firstBadIndentation = 1



  -- Our second is left of the first, which is illegal!

  secondBadIndentation = 2

:load GoodIndent.hs

[1 of 1] Compiling Main             ( GoodIndent.hs, interpreted )

Ok, modules loaded: Main.

:load BadIndent.hs

[1 of 1] Compiling Main             ( BadIndent.hs, interpreted )



BadIndent.hs:8:2: parse error on input `secondBadIndentation'

Failed, modules loaded: none.

-- file: ch03/Guard.hs

fromMaybe defval wrapped =

    case wrapped of

      Nothing     -> defval

      Just value  -> value

-- file: ch03/BadTree.hs

nodesAreSame (Node a _ _) (Node b _ _)

    | a == b     = Just a

nodesAreSame _ _ = Nothing

-- file: ch03/Lending.hs

lend3 amount balance

     | amount <= 0            = Nothing

     | amount > reserve * 0.5 = Nothing

     | otherwise              = Just newBalance

    where reserve    = 100

          newBalance = balance - amount

-- file: ch02/myDrop.hs

myDrop n xs = if n <= 0 || null xs

              then xs

              else myDrop (n - 1) (tail xs)

-- file: ch04/InteractWith.hs

-- Save this in a source file, e.g., Interact.hs



import System.Environment (getArgs)



interactWith function inputFile outputFile = do

  input <- readFile inputFile

  writeFile outputFile (function input)



main = mainWith myFunction

  where mainWith function = do

          args <- getArgs

          case args of

            [input,output] -> interactWith function input output

            _ -> putStrLn "error: exactly two arguments needed"



        -- replace "id" with the name of our function below

        myFunction = id

ghc --make InteractWith

[1 of 1] Compiling Main             ( InteractWith.hs, InteractWith.o )

Linking InteractWith ...

./Interact

error: exactly two arguments needed

 ./Interact hello-in.txt hello-out.txt

 cat hello-in.txt

hello world

 cat hello-out.txt

hello world

:type lines

lines :: String -> [String]

lines "line 1\nline 2"

["line 1","line 2"]

lines "foo\n\nbar\n"

["foo","","bar"]

lines "a\r\nb"

["a\r","b"]

-- file: ch04/SplitLines.hs

splitLines :: String -> [String]

-- file: ch04/SplitLines.hs

splitLines [] = []

splitLines cs =

    let (pre, suf) = break isLineTerminator cs

    in  pre : case suf of 

                ('\r':'\n':rest) -> splitLines rest

                ('\r':rest)      -> splitLines rest

                ('\n':rest)      -> splitLines rest

                _                -> []



isLineTerminator c = c == '\r' || c == '\n'

-- file: ch04/Plus.hs

a `plus` b = a + b



data a `Pair` b = a `Pair` b

                  deriving (Show)



-- we can use the constructor either prefix or infix

foo = Pair 1 2

bar = True `Pair` "quux"

1 `plus` 2

3

plus 1 2

3

True `Pair` "something"

True `Pair` "something"

Pair True "something"

True `Pair` "something"

elem 'a' "camogie"

True

3 `elem` [1,2,4,8]

False

:module +Data.List"foo" `isPrefixOf` "foobar"

True

"needle" `isInfixOf` "haystack full of needle thingies"

True

"end" `isSuffixOf` "the end"

True

        

        :module +Data.List

:type length

length :: [a] -> Int

length []

0

length [1,2,3]

3

length "strings are lists, too"

22

:type null

null :: [a] -> Bool

null []

True

null "plugh"

False

:type head

head :: [a] -> a

head [1,2,3]

1

:type tail

tail :: [a] -> [a]

tail "foo"

"oo"

:type last

last :: [a] -> a

last "bar"

'r'

-- file: ch04/Partial.hs

isInAny needle haystack = any inSequence haystack

    where inSequence s = needle `isInfixOf` s

-- file: ch04/Partial.hs

isInAny2 needle haystack = any (\s -> needle `isInfixOf` s) haystack

-- file: ch04/Lambda.hs

safeHead (x:_) = Just x

safeHead _ = Nothing

-- file: ch04/Lambda.hs

unsafeHead = \(x:_) -> x

:type unsafeHead

unsafeHead :: [t] -> t

unsafeHead [1]

1

unsafeHead []

*** Exception: Lambda.hs:7:13-23: Non-exhaustive patterns in lambda

:type dropWhile

dropWhile :: (a -> Bool) -> [a] -> [a]

:module +Data.Char:type dropWhile isSpace

dropWhile isSpace :: [Char] -> [Char]

map (dropWhile isSpace) [" a","f","   e"]

["a","f","e"]

:type zip3

zip3 :: [a] -> [b] -> [c] -> [(a, b, c)]

zip3 "foo" "bar" "quux"

[('f','b','q'),('o','a','u'),('o','r','u')]

:type zip3 "foo"

zip3 "foo" :: [b] -> [c] -> [(Char, b, c)]

let zip3foo = zip3 "foo"

:type zip3foo

zip3foo :: [b] -> [c] -> [(Char, b, c)]

(zip3 "foo") "aaa" "bbb"

[('f','a','b'),('o','a','b'),('o','a','b')]

zip3foo "aaa" "bbb"

[('f','a','b'),('o','a','b'),('o','a','b')]

zip3foo [1,2,3] [True,False,True]

[('f',1,True),('o',2,False),('o',3,True)]

:m +Data.Listtail "foobar"

"oobar"

tail (tail "foobar")

"obar"

tails "foobar"

["foobar","oobar","obar","bar","ar","r",""]

tails []

[[]]

-- file: ch04/SuffixTree.hs

suffixes :: [a] -> [[a]]

suffixes xs@(_:xs') = xs : suffixes xs'

suffixes _ = []

tails "foo"

["foo","oo","o",""]

suffixes "foo"

["foo","oo","o"]

-- file: ch04/SuffixTree.hs

noAsPattern :: [a] -> [[a]]

noAsPattern (x:xs) = (x:xs) : noAsPattern xs

noAsPattern _ = []

-- file: ch04/SuffixTree.hs

suffixes2 xs = init (tails xs)

suffixes2 "foo"

["foo","oo","o"]

-- file: ch04/SuffixTree.hs

compose :: (b -> c) -> (a -> b) -> a -> c

compose f g x = f (g x)

-- file: ch04/SuffixTree.hs

suffixes3 xs = compose init tails xs

-- file: ch04/SuffixTree.hs

suffixes4 = compose init tails

-- file: ch04/SuffixTree.hs

suffixes5 = init . tails

:type (.)

(.) :: (b -> c) -> (a -> b) -> a -> c

:type suffixes

suffixes :: [a] -> [[a]]

:type suffixes5

suffixes5 :: [a] -> [[a]]

suffixes5 "foo"

["foo","oo","o"]

:module +Data.Charlet capCount = length . filter (isUpper . head) . wordscapCount "Hello there, Mom!"

2

"a string" 12345 true

      null

[-3.14, true, null, "a string"]

      {"numbers": [1,2,3,4,5], "useful": false}

-- file: ch05/SimpleJSON.hs

data JValue = JString String

            | JNumber Double

            | JBool Bool

            | JNull

            | JObject [(String, JValue)]

            | JArray [JValue]

              deriving (Eq, Ord, Show)

:load SimpleJSON

[1 of 1] Compiling SimpleJSON       ( SimpleJSON.hs, interpreted )

Ok, modules loaded: SimpleJSON.

JString "foo"

JString "foo"

JNumber 2.7

JNumber 2.7

:type JBool True

JBool True :: JValue

-- file: ch05/SimpleJSON.hs

getString :: JValue -> Maybe String

getString (JString s) = Just s

getString _           = Nothing

:reload

Ok, modules loaded: SimpleJSON.

getString (JString "hello")

Just "hello"

getString (JNumber 3)

Nothing

-- file: ch05/SimpleJSON.hs

getInt (JNumber n) = Just (truncate n)

getInt _           = Nothing



getDouble (JNumber n) = Just n

getDouble _           = Nothing



getBool (JBool b) = Just b

getBool _         = Nothing



getObject (JObject o) = Just o

getObject _           = Nothing



getArray (JArray a) = Just a

getArray _          = Nothing



isNull v            = v == JNull

-- file: ch05/SimpleJSON.hs

module SimpleJSON

    (

      JValue(..)

    , getString

    , getInt

    , getDouble

    , getBool

    , getObject

    , getArray

    , isNull

    ) where

-- file: ch05/Exporting.hs

module ExportEverything where

-- file: ch05/Exporting.hs

module ExportNothing () where

        ghc -c SimpleJSON.hs

-- file: ch05/Main.hs

module Main () where



import SimpleJSON



main = print (JObject [("foo", JNumber 1), ("bar", JBool False)])

        ghc -o simple Main.hs SimpleJSON.o

-- file: ch05/PutJSON.hs

module PutJSON where



import Data.List (intercalate)

import SimpleJSON



renderJValue :: JValue -> String



renderJValue (JString s)   = show s

renderJValue (JNumber n)   = show n

renderJValue (JBool True)  = "true"

renderJValue (JBool False) = "false"

renderJValue JNull         = "null"



renderJValue (JObject o) = "{" ++ pairs o ++ "}"

  where pairs [] = ""

        pairs ps = intercalate ", " (map renderPair ps)

        renderPair (k,v)   = show k ++ ": " ++ renderJValue v



renderJValue (JArray a) = "[" ++ values a ++ "]"

  where values [] = ""

        values vs = intercalate ", " (map renderJValue vs)

-- file: ch05/PutJSON.hs

putJValue :: JValue -> IO ()

putJValue v = putStrLn (renderJValue v)

-- file: ch05/Trouble.hs

upcaseFirst (c:cs) = toUpper c -- forgot ":cs" here

-- file: ch05/Trouble.hs

camelCase :: String -> String

camelCase xs = concat (map upcaseFirst (words xs))

:load Trouble

[1 of 1] Compiling Main             ( Trouble.hs, interpreted )



Trouble.hs:9:27:

    Couldn't match expected type `[Char]' against inferred type `Char'

      Expected type: [Char] -> [Char]

      Inferred type: [Char] -> Char

    In the first argument of `map', namely `upcaseFirst'

    In the first argument of `concat', namely

        `(map upcaseFirst (words xs))'

Failed, modules loaded: none.

-- file: ch05/PrettyJSON.hs

renderJValue :: JValue -> Doc

renderJValue (JBool True)  = text "true"

renderJValue (JBool False) = text "false"

renderJValue JNull         = text "null"

renderJValue (JNumber num) = double num

renderJValue (JString str) = string str

-- file: ch05/PrettyStub.hs

import SimpleJSON



data Doc = ToBeDefined

         deriving (Show)



string :: String -> Doc

string str = undefined



text :: String -> Doc

text str = undefined



double :: Double -> Doc

double num = undefined

:type undefined

undefined :: a

undefined

*** Exception: Prelude.undefined

:type double

double :: Double -> Doc

double 3.14

*** Exception: Prelude.undefined

-- file: ch05/PrettyJSON.hs

string :: String -> Doc

string = enclose '"' '"' . hcat . map oneChar

-- file: ch05/PrettyJSON.hs

pointyString :: String -> Doc

pointyString s = enclose '"' '"' (hcat (map oneChar s))

-- file: ch05/PrettyJSON.hs

enclose :: Char -> Char -> Doc -> Doc

enclose left right x = char left <> x <> char right

-- file: ch05/PrettyStub.hs

(<>) :: Doc -> Doc -> Doc

a <> b = undefined



char :: Char -> Doc

char c = undefined

-- file: ch05/PrettyStub.hs

hcat :: [Doc] -> Doc

hcat xs = undefined

-- file: ch05/PrettyJSON.hs

oneChar :: Char -> Doc

oneChar c = case lookup c simpleEscapes of

              Just r -> text r

              Nothing | mustEscape c -> hexEscape c

                      | otherwise    -> char c

    where mustEscape c = c < ' ' || c == '\x7f' || c > '\xff'



simpleEscapes :: [(Char, String)]

simpleEscapes = zipWith ch "\b\n\f\r\t\\\"/" "bnfrt\\\"/"

    where ch a b = (a, ['\\',b])

-- file: ch05/PrettyJSON.hs

series :: Char -> Char -> (a -> Doc) -> [a] -> Doc

series open close item = enclose open close

                       . fsep . punctuate (char ',') . map item

-- file: ch05/PrettyStub.hs

fsep :: [Doc] -> Doc

fsep xs = undefined

-- file: ch05/Prettify.hs

punctuate :: Doc -> [Doc] -> [Doc]

punctuate p []     = []

punctuate p [d]    = [d]

punctuate p (d:ds) = (d <> p) : punctuate p ds

-- file: ch05/PrettyJSON.hs

renderJValue (JArray ary) = series '[' ']' renderJValue ary

-- file: ch05/PrettyJSON.hs

module PrettyJSON

    (

      renderJValue

    ) where



import Numeric (showHex)

import Data.Char (ord)

import Data.Bits (shiftR, (.&.))



import SimpleJSON (JValue(..))

import Prettify (Doc, (<>), char, double, fsep, hcat, punctuate, text,

                 compact, pretty)

-- file: ch05/Prettify.hs

data Doc = Empty

         | Char Char

         | Text String

         | Line

         | Concat Doc Doc

         | Union Doc Doc

           deriving (Show,Eq)

-- file: ch05/Prettify.hs

empty :: Doc

empty = Empty



char :: Char -> Doc

char c = Char c



text :: String -> Doc

text "" = Empty

text s  = Text s



double :: Double -> Doc

double d = text (show d)

-- file: ch05/Prettify.hs

line :: Doc

line = Line

-- file: ch05/Prettify.hs

(<>) :: Doc -> Doc -> Doc

Empty <> y = y

x <> Empty = x

x <> y = x `Concat` y

text "foo" <> text "bar"

Concat (Text "foo") (Text "bar")

text "foo" <> empty

Text "foo"

empty <> text "bar"

Text "bar"

-- file: ch06/naiveeq.hs

data Color = Red | Green | Blue



colorEq :: Color -> Color -> Bool

colorEq Red   Red   = True

colorEq Green Green = True

colorEq Blue  Blue  = True

colorEq _     _     = False

:load naiveeq.hs

[1 of 1] Compiling Main             ( naiveeq.hs, interpreted )

Ok, modules loaded: Main.

colorEq Red Red

True

colorEq Red Green

False

-- file: ch06/naiveeq.hs

stringEq :: [Char] -> [Char] -> Bool



-- Match if both are empty

stringEq [] [] = True



-- If both start with the same char, check the rest

stringEq (x:xs) (y:ys) = x == y && stringEq xs ys



-- Everything else doesn't match

stringEq _ _ = False

-- file: ch06/eqclasses.hs

class BasicEq a where

    isEqual :: a -> a -> Bool

*Main> :type isEqual

isEqual :: (BasicEq a) => a -> a -> Bool

-- file: ch06/eqclasses.hs

instance BasicEq Bool where

    isEqual True  True  = True

    isEqual False False = True

    isEqual _     _     = False

-- file: ch06/eqclasses.hs

instance BasicEq3 Color where

    isEqual3 Red Red = True

    isEqual3 Green Green = True

    isEqual3 Blue Blue = True

    isEqual3 _ _ = False

-- file: ch06/colorderived.hs

data Color = Red | Green | Blue

     deriving (Read, Show, Eq, Ord)

show Red

"Red"

(read "Red")::Color

Red

(read "[Red,Red,Blue]")::[Color]

[Red,Red,Blue]

(read "[Red, Red, Blue]")::[Color]

[Red,Red,Blue]

Red == Red

True

Red == Blue

False

Data.List.sort [Blue,Green,Blue,Red]

[Red,Green,Blue,Blue]

Red < Blue

True

-- file: ch06/AutomaticDerivation.hs

data CannotShow = CannotShow

                deriving (Show)



-- will not compile, since CannotShow is not an instance of Show

data CannotDeriveShow = CannotDeriveShow CannotShow

                        deriving (Show)



data OK = OK



instance Show OK where

    show _ = "OK"



data ThisWorks = ThisWorks OK

                 deriving (Show)

{

  "query": "awkward squad haskell",

  "estimatedCount": 3920,

  "moreResults": true,

  "results":

  [{

    "title": "Simon Peyton Jones: papers",

    "snippet": "Tackling the awkward squad: monadic input/output ...",

    "url": "http://research.microsoft.com/~simonpj/papers/marktoberdorf/",

   },

   {

    "title": "Haskell for C Programmers | Lambda the Ultimate",

    "snippet": "... the best job of all the tutorials I've read ...",

    "url": "http://lambda-the-ultimate.org/node/724",

   }]

}

-- file: ch05/SimpleResult.hs

import SimpleJSON



result :: JValue

result = JObject [

  ("query", JString "awkward squad haskell"),

  ("estimatedCount", JNumber 3920),

  ("moreResults", JBool True),

  ("results", JArray [

     JObject [

      ("title", JString "Simon Peyton Jones: papers"),

      ("snippet", JString "Tackling the awkward ..."),

      ("url", JString "http://.../marktoberdorf/")

     ]])

  ]

-- file: ch06/JSONClass.hs

type JSONError = String



class JSON a where

    toJValue :: a -> JValue

    fromJValue :: JValue -> Either JSONError a



instance JSON JValue where

    toJValue = id

    fromJValue = Right

-- file: ch06/JSONClass.hs

doubleToJValue :: (Double -> a) -> JValue -> Either JSONError a

doubleToJValue f (JNumber v) = Right (f v)

doubleToJValue _ _ = Left "not a JSON number"



instance JSON Int where

    toJValue = JNumber . realToFrac

    fromJValue = doubleToJValue round



instance JSON Integer where

    toJValue = JNumber . realToFrac

    fromJValue = doubleToJValue round



instance JSON Double where

    toJValue = JNumber

    fromJValue = doubleToJValue id

-- file: ch06/BrokenClass.hs

instance (JSON a) => JSON [a] where

    toJValue = undefined

    fromJValue = undefined

-- file: ch06/BrokenClass.hs

instance (JSON a) => JSON [(String, a)] where

    toJValue = undefined

    fromJValue = undefined

:load BrokenClass

[1 of 2] Compiling SimpleJSON       ( ../ch05/SimpleJSON.hs, interpreted )

[2 of 2] Compiling BrokenClass      ( BrokenClass.hs, interpreted )

Ok, modules loaded: BrokenClass, SimpleJSON.

toJValue [("foo","bar")]



<interactive>:1:0:

    Overlapping instances for JSON [([Char], [Char])]

      arising from a use of `toJValue' at <interactive>:1:0-23

    Matching instances:

      instance (JSON a) => JSON [a]

        -- Defined at BrokenClass.hs:(44,0)-(46,25)

      instance (JSON a) => JSON [(String, a)]

        -- Defined at BrokenClass.hs:(50,0)-(52,25)

    In the expression: toJValue [("foo", "bar")]

    In the definition of `it': it = toJValue [("foo", "bar")]

-- file: ch06/Newtype.hs

data DataInt = D Int

    deriving (Eq, Ord, Show)



newtype NewtypeInt = N Int

    deriving (Eq, Ord, Show)

-- file: ch06/Newtype.hs

newtype UniqueID = UniqueID Int

    deriving (Eq)

N 1 < N 2

True

N 313 + N 37



<interactive>:1:0:

    No instance for (Num NewtypeInt)

      arising from a use of `+' at <interactive>:1:0-11

    Possible fix: add an instance declaration for (Num NewtypeInt)

    In the expression: N 313 + N 37

    In the definition of `it': it = N 313 + N 37

-- file: ch06/JSONClass.hs

newtype JAry a = JAry {

      fromJAry :: [a]

    } deriving (Eq, Ord, Show)

-- file: ch06/JSONClassExport.hs

module JSONClass

    (

      JAry(..)

    ) where

-- file: ch06/JSONClass.hs

jary :: [a] -> JAry a

jary = JAry

-- file: ch06/JSONClassExport.hs

module JSONClass

    (

      JAry(fromJAry)

    , jary

    ) where

-- file: ch06/Monomorphism.hs

myShow = show

:load Monomorphism

[1 of 1] Compiling Main             ( Monomorphism.hs, interpreted )



Monomorphism.hs:2:9:

    Ambiguous type variable `a' in the constraint:

      `Show a' arising from a use of `show' at Monomorphism.hs:2:9-12

    Possible cause: the monomorphism restriction applied to the following:

      myShow :: a -> String (bound at Monomorphism.hs:2:0)

    Probable fix: give these definition(s) an explicit type signature

                  or use -fno-monomorphism-restriction

Failed, modules loaded: none.

-- file: ch07/basicio.hs

main = do

       putStrLn "Greetings!  What is your name?"

       inpStr <- getLine

       putStrLn $ "Welcome to Haskell, " ++ inpStr ++ "!"

$ runghc basicio.hs

Greetings!  What is your name?

John

Welcome to Haskell, John!

:type putStrLn

putStrLn :: String -> IO ()

:type getLine

getLine :: IO String

-- file: ch07/toupper-imp.hs

import System.IO

import Data.Char(toUpper)



main :: IO ()

main = do 

       inh <- openFile "input.txt" ReadMode

       outh <- openFile "output.txt" WriteMode

       mainloop inh outh

       hClose inh

       hClose outh



mainloop :: Handle -> Handle -> IO ()

mainloop inh outh = 

    do ineof <- hIsEOF inh

       if ineof

           then return ()

           else do inpStr <- hGetLine inh

                   hPutStrLn outh (map toUpper inpStr)

                   mainloop inh outh

-- file: ch07/tempfile.hs

import System.IO

import System.Directory(getTemporaryDirectory, removeFile)

import System.IO.Error(catch)

import Control.Exception(finally)



-- The main entry point.  Work with a temp file in myAction.

main :: IO ()

main = withTempFile "mytemp.txt" myAction



{- The guts of the program.  Called with the path and handle of a temporary

   file.  When this function exits, that file will be closed and deleted

   because myAction was called from withTempFile. -}

myAction :: FilePath -> Handle -> IO ()

myAction tempname temph = 

    do -- Start by displaying a greeting on the terminal

       putStrLn "Welcome to tempfile.hs"

       putStrLn $ "I have a temporary file at " ++ tempname



       -- Let's see what the initial position is

       pos <- hTell temph

       putStrLn $ "My initial position is " ++ show pos



       -- Now, write some data to the temporary file

       let tempdata = show [1..10]

       putStrLn $ "Writing one line containing " ++ 

                  show (length tempdata) ++ " bytes: " ++

                  tempdata

       hPutStrLn temph tempdata



       -- Get our new position.  This doesn't actually modify pos

       -- in memory, but makes the name "pos" correspond to a different 

       -- value for the remainder of the "do" block.

       pos <- hTell temph

       putStrLn $ "After writing, my new position is " ++ show pos



       -- Seek to the beginning of the file and display it

       putStrLn $ "The file content is: "

       hSeek temph AbsoluteSeek 0



       -- hGetContents performs a lazy read of the entire file

       c <- hGetContents temph



       -- Copy the file byte-for-byte to stdout, followed by \n

       putStrLn c



       -- Let's also display it as a Haskell literal

       putStrLn $ "Which could be expressed as this Haskell literal:"

       print c



{- This function takes two parameters: a filename pattern and another

   function.  It will create a temporary file, and pass the name and Handle

   of that file to the given function.



   The temporary file is created with openTempFile.  The directory is the one

   indicated by getTemporaryDirectory, or, if the system has no notion of

   a temporary directory, "." is used.  The given pattern is passed to

   openTempFile.



   After the given function terminates, even if it terminates due to an

   exception, the Handle is closed and the file is deleted. -}

withTempFile :: String -> (FilePath -> Handle -> IO a) -> IO a

withTempFile pattern func =

    do -- The library ref says that getTemporaryDirectory may raise on

       -- exception on systems that have no notion of a temporary directory.

       -- So, we run getTemporaryDirectory under catch.  catch takes

       -- two functions: one to run, and a different one to run if the

       -- first raised an exception.  If getTemporaryDirectory raised an

       -- exception, just use "." (the current working directory).

       tempdir <- catch (getTemporaryDirectory) (\_ -> return ".")

       (tempfile, temph) <- openTempFile tempdir pattern 



       -- Call (func tempfile temph) to perform the action on the temporary

       -- file.  finally takes two actions.  The first is the action to run.

       -- The second is an action to run after the first, regardless of

       -- whether the first action raised an exception.  This way, we ensure

       -- the temporary file is always deleted.  The return value from finally

       -- is the first action's return value.

       finally (func tempfile temph) 

               (do hClose temph

                   removeFile tempfile)

-- file: ch08/SumFile.hs

main = do

    contents <- getContents

    print (sumFile contents)

  where sumFile = sum . map read . words

        

        :module +Text.Regex.Posix

-- file: ch08/GlobRegex.hs

module GlobRegex

    (

      globToRegex

    , matchesGlob

    ) where



import Text.Regex.Posix ((=~))



globToRegex :: String -> String

-- file: ch08/GlobRegex.hs

globToRegex cs = '^' : globToRegex' cs ++ "$"

-- file: ch08/GlobRegex.hs

globToRegex' :: String -> String

globToRegex' "" = ""



globToRegex' ('*':cs) = ".*" ++ globToRegex' cs



globToRegex' ('?':cs) = '.' : globToRegex' cs



globToRegex' ('[':'!':c:cs) = "[^" ++ c : charClass cs

globToRegex' ('[':c:cs)     = '['  :  c : charClass cs

globToRegex' ('[':_)        = error "unterminated character class"



globToRegex' (c:cs) = escape c ++ globToRegex' cs

-- file: ch08/GlobRegex.hs

globToRegex' (c:cs) = escape c ++ globToRegex' cs

-- file: ch08/append.hs

(++) :: [a] -> [a] -> [a]



(x:xs) ++ ys = x : (xs ++ ys)

[]     ++ ys = ys

-- file: ch08/Glob.hs

module Glob (namesMatching) where

-- file: ch08/Glob.hs

import System.Directory (doesDirectoryExist, doesFileExist,

                         getCurrentDirectory, getDirectoryContents)

:m +System.FilePath"foo" </> "bar"

Loading package filepath-1.1.0.0 ... linking ... done.

"foo/bar"

dropTrailingPathSeparator "foo/"

"foo"

splitFileName "foo/bar/Quux.hs"

("foo/bar/","Quux.hs")

splitFileName "zippity"

("","zippity")

-- file: ch08/Glob.hs

import System.FilePath (dropTrailingPathSeparator, splitFileName, (</>))

-- file: ch08/Glob.hs

import Control.Exception (handle)

import Control.Monad (forM)

import GlobRegex (matchesGlob)

-- file: ch08/GlobRegexEither.hs

type GlobError = String



globToRegex :: String -> Either GlobError String

-- file: ch08/Useful.hs

import System.FilePath (replaceExtension)

import System.Directory (doesFileExist, renameDirectory, renameFile)

import Glob (namesMatching)



renameWith :: (FilePath -> FilePath)

           -> FilePath

           -> IO FilePath



renameWith f path = do

    let path' = f path

    rename path path'

    return path'

-- file: ch08/Useful.hs

rename :: FilePath -> FilePath -> IO ()



rename old new = do

    isFile <- doesFileExist old

    let f = if isFile then renameFile else renameDirectory

    f old new

-- file: ch08/Useful.hs

cc2cpp =

  mapM (renameWith (flip replaceExtension ".cpp")) =<< namesMatching "*.cc"

-- file: ch09/RecursiveContents.hs

module RecursiveContents (getRecursiveContents) where



import Control.Monad (forM)

import System.Directory (doesDirectoryExist, getDirectoryContents)

import System.FilePath ((</>))



getRecursiveContents :: FilePath -> IO [FilePath]



getRecursiveContents topdir = do

  names <- getDirectoryContents topdir

  let properNames = filter (`notElem` [".", ".."]) names

  paths <- forM properNames $ \name -> do

    let path = topdir </> name

    isDirectory <- doesDirectoryExist path

    if isDirectory

      then getRecursiveContents path

      else return [path]

  return (concat paths)

:m +Control.Monad:type mapM

mapM :: (Monad m) => (a -> m b) -> [a] -> m [b]

:type forM

forM :: (Monad m) => [a] -> (a -> m b) -> m [b]

-- file: ch09/SimpleFinder.hs

import RecursiveContents (getRecursiveContents)



simpleFind :: (FilePath -> Bool) -> FilePath -> IO [FilePath]



simpleFind p path = do

  names <- getRecursiveContents path

  return (filter p names)

:m +System.FilePath:type takeExtension

takeExtension :: FilePath -> String

takeExtension "foo/bar.c"

Loading package filepath-1.1.0.0 ... linking ... done.

".c"

takeExtension "quux"

""

:load SimpleFinder

[1 of 2] Compiling RecursiveContents ( RecursiveContents.hs, interpreted )

[2 of 2] Compiling Main             ( SimpleFinder.hs, interpreted )

Ok, modules loaded: RecursiveContents, Main.

:type simpleFind (\p -> takeExtension p == ".c")

simpleFind (\p -> takeExtension p == ".c") :: FilePath -> IO [FilePath]

        

        :m +System.Directory

:type doesFileExist

doesFileExist :: FilePath -> IO Bool

doesFileExist "."

Loading package old-locale-1.0.0.0 ... linking ... done.

Loading package old-time-1.0.0.0 ... linking ... done.

Loading package directory-1.0.0.1 ... linking ... done.

False

:type doesDirectoryExist

doesDirectoryExist :: FilePath -> IO Bool

doesDirectoryExist "."

True

:type getPermissions

getPermissions :: FilePath -> IO Permissions

:info Permissions

data Permissions

  = Permissions {readable :: Bool,

                 writable :: Bool,

                 executable :: Bool,

                 searchable :: Bool}

  	-- Defined in System.Directory

instance Eq Permissions -- Defined in System.Directory

instance Ord Permissions -- Defined in System.Directory

instance Read Permissions -- Defined in System.Directory

instance Show Permissions -- Defined in System.Directory

-- file: ch09/BetterPredicate.hs

simpleFileSize :: FilePath -> IO Integer



simpleFileSize path = do

  h <- openFile path ReadMode

  size <- hFileSize h

  hClose h

  return size

-- file: ch09/BetterPredicate.hs

saferFileSize :: FilePath -> IO (Maybe Integer)



saferFileSize path = handle (\_ -> return Nothing) $ do

  h <- openFile path ReadMode

  size <- hFileSize h

  hClose h

  return (Just size)

-- file: ch09/BetterPredicate.hs

myTest path _ (Just size) _ =

    takeExtension path == ".cpp" && size > 131072

myTest _ _ _ _ = False

-- file: ch09/BetterPredicate.hs

pathP path _ _ _ = path

-- file: ch09/BetterPredicate.hs

type InfoP a =  FilePath        -- path to directory entry

             -> Permissions     -- permissions

             -> Maybe Integer   -- file size (Nothing if not file)

             -> ClockTime       -- last modified

             -> a



pathP :: InfoP FilePath

-- file: ch09/BetterPredicate.hs

sizeP :: InfoP Integer

sizeP _ _ (Just size) _ = size

sizeP _ _ Nothing     _ = -1

-- file: ch09/ControlledVisit.hs

data Info = Info {

      infoPath :: FilePath

    , infoPerms :: Maybe Permissions

    , infoSize :: Maybe Integer

    , infoModTime :: Maybe ClockTime

    } deriving (Eq, Ord, Show)



getInfo :: FilePath -> IO Info

-- file: ch09/ControlledVisit.hs

traverse :: ([Info] -> [Info]) -> FilePath -> IO [Info]

-- file: ch09/ControlledVisit.hs

traverse order path = do

    names <- getUsefulContents path

    contents <- mapM getInfo (path : map (path </>) names)

    liftM concat $ forM (order contents) $ \info -> do

      if isDirectory info && infoPath info /= path

        then traverse order (infoPath info)

        else return [info]



getUsefulContents :: FilePath -> IO [String]

getUsefulContents path = do

    names <- getDirectoryContents path

    return (filter (`notElem` [".", ".."]) names)



isDirectory :: Info -> Bool

isDirectory = maybe False searchable . infoPerms

-- file: ch09/ControlledVisit.hs

traverseVerbose order path = do

    names <- getDirectoryContents path

    let usefulNames = filter (`notElem` [".", ".."]) names

    contents <- mapM getEntryName ("" : usefulNames)

    recursiveContents <- mapM recurse (order contents)

    return (concat recursiveContents)

  where getEntryName name = getInfo (path </> name)

        isDirectory info = case infoPerms info of

                             Nothing -> False

                             Just perms -> searchable perms

        recurse info = do

            if isDirectory info && infoPath info /= path

                then traverseVerbose order (infoPath info)

                else return [info]

-- file: ch09/FoldDir.hs

data Iterate seed = Done     { unwrap :: seed }

                  | Skip     { unwrap :: seed }

                  | Continue { unwrap :: seed }

                    deriving (Show)



type Iterator seed = seed -> Info -> Iterate seed

-- file: ch10/PNM.hs

import qualified Data.ByteString.Lazy.Char8 as L8

import qualified Data.ByteString.Lazy as L

import Data.Char (isSpace)

-- file: ch10/PNM.hs

data Greymap = Greymap {

      greyWidth :: Int

    , greyHeight :: Int

    , greyMax :: Int

    , greyData :: L.ByteString

    } deriving (Eq)

-- file: ch10/PNM.hs

instance Show Greymap where

    show (Greymap w h m _) = "Greymap " ++ show w ++ "x" ++ show h ++

                             " " ++ show m

-- file: ch10/PNM.hs

parseP5 :: L.ByteString -> Maybe (Greymap, L.ByteString)

-- file: ch10/PNM.hs

(>>?) :: Maybe a -> (a -> Maybe b) -> Maybe b

Nothing >>? _ = Nothing

Just v  >>? f = f v

-- file: ch10/PNM.hs

parseP5_take2 :: L.ByteString -> Maybe (Greymap, L.ByteString)

parseP5_take2 s =

    matchHeader (L8.pack "P5") s      >>?

    \s -> skipSpace ((), s)           >>?

    (getNat . snd)                    >>?

    skipSpace                         >>?

    \(width, s) ->   getNat s         >>?

    skipSpace                         >>?

    \(height, s) ->  getNat s         >>?

    \(maxGrey, s) -> getBytes 1 s     >>?

    (getBytes (width * height) . snd) >>?

    \(bitmap, s) -> Just (Greymap width height maxGrey bitmap, s)



skipSpace :: (a, L.ByteString) -> Maybe (a, L.ByteString)

skipSpace (a, s) = Just (a, L8.dropWhile isSpace s)

-- file: ch10/Parse.hs

data ParseState = ParseState {

      string :: L.ByteString

    , offset :: Int64           -- imported from Data.Int

    } deriving (Show)

-- file: ch10/Parse.hs

simpleParse :: ParseState -> (a, ParseState)

simpleParse = undefined

map (+1) [1,2,3]

[2,3,4]

map show [1,2,3]

["1","2","3"]

:type map show

map show :: (Show a) => [a] -> [String]

-- file: ch10/TreeMap.hs

data Tree a = Node (Tree a) (Tree a)

            | Leaf a

              deriving (Show)

-- file: ch10/TreeMap.hs

treeLengths (Leaf s) = Leaf (length s)

treeLengths (Node l r) = Node (treeLengths l) (treeLengths r)

-- file: ch10/TreeMap.hs

treeMap :: (a -> b) -> Tree a -> Tree b

treeMap f (Leaf a)   = Leaf (f a)

treeMap f (Node l r) = Node (treeMap f l) (treeMap f r)

let tree = Node (Leaf "foo") (Node (Leaf "x") (Leaf "quux"))treeLengths tree

Node (Leaf 3) (Node (Leaf 1) (Leaf 4))

treeMap length tree

Node (Leaf 3) (Node (Leaf 1) (Leaf 4))

treeMap (odd . length) tree

Node (Leaf True) (Node (Leaf True) (Leaf False))

-- file: ch10/TreeMap.hs

class Functor f where

    fmap :: (a -> b) -> f a -> f b

-- file: ch10/TreeMap.hs

instance Functor Tree where

    fmap = treeMap

-- file: ch10/Parse.hs

instance Functor Parse where

    fmap f parser = parser ==> \result ->

                    identity (f result)

parse parseByte L.empty

Left "byte offset 0: no more input"

parse (id <$> parseByte) L.empty

Left "byte offset 0: no more input"

let input = L8.pack "foo"L.head input

102

parse parseByte input

Right 102

parse (id <$> parseByte) input

Right 102

parse ((chr . fromIntegral) <$> parseByte) input

Right 'f'

parse (chr <$> fromIntegral <$> parseByte) input

Right 'f'

-- file: ch10/Parse.hs

w2c :: Word8 -> Char

w2c = chr . fromIntegral



-- import Control.Applicative

parseChar :: Parse Char

parseChar = w2c <$> parseByte

-- file: ch10/Parse.hs

peekByte :: Parse (Maybe Word8)

peekByte = (fmap fst . L.uncons . string) <$> getState

-- file: ch10/Parse.hs

peekChar :: Parse (Maybe Char)

peekChar = fmap w2c <$> peekByte

-- file: ch10/Parse.hs

parseWhile :: (Word8 -> Bool) -> Parse [Word8]

parseWhile p = (fmap p <$> peekByte) ==> \mp ->

               if mp == Just True

               then parseByte ==> \b ->

                    (b:) <$> parseWhile p

               else identity []

-- file: ch10/Parse.hs

parseRawPGM =

    parseWhileWith w2c notWhite ==> \header -> skipSpaces ==>&

    assert (header == "P5") "invalid raw header" ==>&

    parseNat ==> \width -> skipSpaces ==>&

    parseNat ==> \height -> skipSpaces ==>&

    parseNat ==> \maxGrey ->

    parseByte ==>&

    parseBytes (width * height) ==> \bitmap ->

    identity (Greymap width height maxGrey bitmap)

  where notWhite = (`notElem` " \r\n\t")

-- file: ch10/Parse.hs

parseWhileWith :: (Word8 -> a) -> (a -> Bool) -> Parse [a]

parseWhileWith f p = fmap f <$> parseWhile (p . f)



parseNat :: Parse Int

parseNat = parseWhileWith w2c isDigit ==> \digits ->

           if null digits

           then bail "no more input"

           else let n = read digits

                in if n < 0

                   then bail "integer overflow"

                   else identity n



(==>&) :: Parse a -> Parse b -> Parse b

p ==>& f = p ==> \_ -> f



skipSpaces :: Parse ()

skipSpaces = parseWhileWith w2c isSpace ==>& identity ()



assert :: Bool -> String -> Parse ()

assert True  _   = identity ()

assert False err = bail err

-- file: ch10/Parse.hs

parseBytes :: Int -> Parse L.ByteString

parseBytes n =

    getState ==> \st ->

    let n' = fromIntegral n

        (h, t) = L.splitAt n' (string st)

        st' = st { offset = offset st + L.length h, string = t }

    in putState st' ==>&

       assert (L.length h == n') "end of input" ==>&

       identity h

-- file: ch11/QC-basics.hs

import Test.QuickCheck

import Data.List

-- file: ch11/QC-basics.hs

qsort :: Ord a => [a] -> [a]

qsort []     = []

qsort (x:xs) = qsort lhs ++ [x] ++ qsort rhs

    where lhs = filter  (< x) xs

          rhs = filter (>= x) xs

-- file: ch11/QC-basics.hs

prop_idempotent xs = qsort (qsort xs) == qsort xs

prop_idempotent []       

True

prop_idempotent [1,1,1,1]  

True

prop_idempotent [1..100]

True

prop_idempotent [1,5,2,1,2,0,9]

True

$ ghc -fhpc Run.hs --make

$ ./Run

                 simple : .....                            (1000)

                complex : ..                               (400)

$ hpc report Run --exclude=Main --exclude=QC

  18% expressions used (30/158)

   0% boolean coverage (0/3)

        0% guards (0/3), 3 unevaluated

        100% 'if' conditions (0/0)

        100% qualifiers (0/0)

   23% alternatives used (8/34)

    0% local declarations used (0/4)

   42% top-level declarations used (9/21)

$ hpc markup Run --exclude=Main --exclude=QC

-- file: ch12/Barcode.hs

import Data.Array (Array(..), (!), bounds, elems, indices,

                   ixmap, listArray)



import Control.Applicative ((<$>))

import Control.Monad (forM_)

import Data.Char (digitToInt)

import Data.Ix (Ix(..))

import Data.List (foldl', group, sort, sortBy, tails)

import Data.Maybe (catMaybes, listToMaybe)

import Data.Ratio (Ratio)

import Data.Word (Word8)

import System.Environment (getArgs)

import qualified Data.ByteString.Lazy.Char8 as L

import qualified Data.Map as M



import Parse                    -- from chapter 11

-- file: ch12/Barcode.hs

leftOddList = ["0001101", "0011001", "0010011", "0111101", "0100011",

               "0110001", "0101111", "0111011", "0110111", "0001011"]



rightList = map complement <$> leftOddList

    where complement '0' = '1'

          complement '1' = '0'



leftEvenList = map reverse rightList



parityList = ["111111", "110100", "110010", "110001", "101100",

              "100110", "100011", "101010", "101001", "100101"]



listToArray :: [a] -> Array Int a

listToArray xs = listArray (0,l-1) xs

    where l = length xs



leftOddCodes, leftEvenCodes, rightCodes, parityCodes :: Array Int String



leftOddCodes = listToArray leftOddList

leftEvenCodes = listToArray leftEvenList

rightCodes = listToArray rightList

parityCodes = listToArray parityList

-- file: ch12/Barcode.hs

encodeEAN13 :: String -> String

encodeEAN13 = concat . encodeDigits . map digitToInt



-- | This function computes the check digit; don't pass one in.

encodeDigits :: [Int] -> [String]

encodeDigits s@(first:rest) =

    outerGuard : lefties ++ centerGuard : righties ++ [outerGuard]

  where (left, right) = splitAt 5 rest

        lefties = zipWith leftEncode (parityCodes ! first) left

        righties = map rightEncode (right ++ [checkDigit s])



leftEncode :: Char -> Int -> String

leftEncode '1' = (leftOddCodes !)

leftEncode '0' = (leftEvenCodes !)



rightEncode :: Int -> String

rightEncode = (rightCodes !)



outerGuard = "101"

centerGuard = "01010"

product . map length . candidateDigits $ input

34012224

-- file: ch12/Barcode.hs

type Map a = M.Map Digit [a]

-- file: ch12/Barcode.hs

type DigitMap = Map Digit

type ParityMap = Map (Parity Digit)

-- file: ch12/Barcode.hs

updateMap :: Parity Digit       -- ^ new digit

          -> Digit              -- ^ existing key

          -> [Parity Digit]     -- ^ existing digit sequence

          -> ParityMap          -- ^ map to update

          -> ParityMap

updateMap digit key seq = insertMap key (fromParity digit) (digit:seq)



insertMap :: Digit -> Digit -> [a] -> Map a -> Map a

insertMap key digit val m = val `seq` M.insert key' val m

    where key' = (key + digit) `mod` 10

-- file: ch12/Barcode.hs

withRow :: Int -> Pixmap -> (RunLength Bit -> a) -> a

withRow n greymap f = f . runLength . elems $ posterized

    where posterized = threshold 0.4 . fmap luminance . row n $ greymap

-- file: ch12/Barcode.hs

row :: (Ix a, Ix b) => b -> Array (a,b) c -> Array a c

row j a = ixmap (l,u) project a

    where project i = (i,j)

          ((l,_), (u,_)) = bounds a

-- file: ch12/Barcode.hs

findMatch :: [(Run, Bit)] -> Maybe [[Digit]]

findMatch = listToMaybe

          . filter (not . null)

          . map (solve . candidateDigits)

          . tails

-- file: ch12/Barcode.hs

findEAN13 :: Pixmap -> Maybe [Digit]

findEAN13 pixmap = withRow center pixmap (fmap head . findMatch)

  where (_, (maxX, _)) = bounds pixmap

        center = (maxX + 1) `div` 2

-- file: ch12/Barcode.hs

main :: IO ()

main = do

  args <- getArgs

  forM_ args $ \arg -> do

    e <- parse parseRawPPM <$> L.readFile arg

    case e of

      Left err ->     print $ "error: " ++ err

      Right pixmap -> print $ findEAN13 pixmap

let al = [(1, "one"), (2, "two"), (3, "three"), (4, "four")]lookup 1 al

Just "one"

lookup 5 al

Nothing

-- file: ch13/lookup.hs

myLookup :: Eq a => a -> [(a, b)] -> Maybe b

myLookup _ [] = Nothing

myLookup key ((thiskey,thisval):rest) =

    if key == thiskey

       then Just thisval

       else myLookup key rest

-- file: ch13/buildmap.hs

import qualified Data.Map as Map



-- Functions to generate a Map that represents an association list

-- as a map



al = [(1, "one"), (2, "two"), (3, "three"), (4, "four")]



{- | Create a map representation of 'al' by converting the association

-  list using Map.fromList -}

mapFromAL =

    Map.fromList al



{- | Create a map representation of 'al' by doing a fold -}

mapFold =

    foldl (\map (k, v) -> Map.insert k v map) Map.empty al



{- | Manually create a map with the elements of 'al' in it -}

mapManual =

    Map.insert 2 "two" . 

    Map.insert 4 "four" .

    Map.insert 1 "one" .

    Map.insert 3 "three" $ Map.empty

:l buildmap.hs

[1 of 1] Compiling Main             ( buildmap.hs, interpreted )

Ok, modules loaded: Main.

al

Loading package array-0.1.0.0 ... linking ... done.

Loading package containers-0.1.0.2 ... linking ... done.

[(1,"one"),(2,"two"),(3,"three"),(4,"four")]

mapFromAL

fromList [(1,"one"),(2,"two"),(3,"three"),(4,"four")]

mapFold

fromList [(1,"one"),(2,"two"),(3,"three"),(4,"four")]

mapManual

fromList [(1,"one"),(2,"two"),(3,"three"),(4,"four")]

-- file: ch13/funcrecs.hs

{- | Our usual CustomColor type to play with -}

data CustomColor =

  CustomColor {red :: Int,

               green :: Int,

               blue :: Int}

  deriving (Eq, Show, Read)



{- | A new type that stores a name and a function.



The function takes an Int, applies some computation to it, and returns

an Int along with a CustomColor -}

data FuncRec =

    FuncRec {name :: String,

             colorCalc :: Int -> (CustomColor, Int)}



plus5func color x = (color, x + 5)



purple = CustomColor 255 0 255



plus5 = FuncRec {name = "plus5", colorCalc = plus5func purple}

always0 = FuncRec {name = "always0", colorCalc = \_ -> (purple, 0)}

:l funcrecs.hs

[1 of 1] Compiling Main             ( funcrecs.hs, interpreted )

Ok, modules loaded: Main.

:t plus5

plus5 :: FuncRec

name plus5

"plus5"

:t colorCalc plus5

colorCalc plus5 :: Int -> (CustomColor, Int)

(colorCalc plus5) 7

(CustomColor {red = 255, green = 0, blue = 255},12)

:t colorCalc always0

colorCalc always0 :: Int -> (CustomColor, Int)

(colorCalc always0) 7

(CustomColor {red = 255, green = 0, blue = 255},0)

-- file: ch13/funcrecs2.hs

data FuncRec =

    FuncRec {name :: String,

             calc :: Int -> Int,

             namedCalc :: Int -> (String, Int)}



mkFuncRec :: String -> (Int -> Int) -> FuncRec

mkFuncRec name calcfunc =

    FuncRec {name = name,

             calc = calcfunc,

             namedCalc = \x -> (name, calcfunc x)}



plus5 = mkFuncRec "plus5" (+ 5)

always0 = mkFuncRec "always0" (\_ -> 0)

-- file: ch13/passwdmap.hs

import Data.List

import qualified Data.Map as Map

import System.IO

import Text.Printf(printf)

import System.Environment(getArgs)

import System.Exit

import Control.Monad(when)



{- | The primary piece of data this program will store.

   It represents the fields in a POSIX /etc/passwd file -}

data PasswdEntry = PasswdEntry {

    userName :: String,

    password :: String,

    uid :: Integer,

    gid :: Integer,

    gecos :: String,

    homeDir :: String,

    shell :: String}

    deriving (Eq, Ord)



{- | Define how we get data to a 'PasswdEntry'. -}

instance Show PasswdEntry where

    show pe = printf "%s:%s:%d:%d:%s:%s:%s" 

                (userName pe) (password pe) (uid pe) (gid pe)

                (gecos pe) (homeDir pe) (shell pe)



{- | Converting data back out of a 'PasswdEntry'. -}

instance Read PasswdEntry where

    readsPrec _ value =

        case split ':' value of

             [f1, f2, f3, f4, f5, f6, f7] ->

                 -- Generate a 'PasswdEntry' the shorthand way:

                 -- using the positional fields.  We use 'read' to convert

                 -- the numeric fields to Integers.

                 [(PasswdEntry f1 f2 (read f3) (read f4) f5 f6 f7, [])]

             x -> error $ "Invalid number of fields in input: " ++ show x

        where 

        {- | Takes a delimiter and a list.  Break up the list based on the

        -  delimiter. -}

        split :: Eq a => a -> [a] -> [[a]]



        -- If the input is empty, the result is a list of empty lists.

        split _ [] = [[]]

        split delim str =

            let -- Find the part of the list before delim and put it in

                -- "before".  The rest of the list, including the leading 

                -- delim, goes in "remainder".

                (before, remainder) = span (/= delim) str

                in

                before : case remainder of

                              [] -> []

                              x -> -- If there is more data to process,

                                   -- call split recursively to process it

                                   split delim (tail x)



-- Convenience aliases; we'll have two maps: one from UID to entries

-- and the other from username to entries

type UIDMap = Map.Map Integer PasswdEntry

type UserMap = Map.Map String PasswdEntry



{- | Converts input data to maps.  Returns UID and User maps. -}

inputToMaps :: String -> (UIDMap, UserMap)

inputToMaps inp =

    (uidmap, usermap)

    where

    -- fromList converts a [(key, value)] list into a Map

    uidmap = Map.fromList . map (\pe -> (uid pe, pe)) $ entries

    usermap = Map.fromList . 

              map (\pe -> (userName pe, pe)) $ entries

    -- Convert the input String to [PasswdEntry]

    entries = map read (lines inp)



main = do

    -- Load the command-line arguments

    args <- getArgs



    -- If we don't have the right number of args,

    -- give an error and abort



    when (length args /= 1) $ do

        putStrLn "Syntax: passwdmap filename"

        exitFailure



    -- Read the file lazily

    content <- readFile (head args)

    let maps = inputToMaps content

    mainMenu maps



mainMenu maps@(uidmap, usermap) = do

    putStr optionText

    hFlush stdout

    sel <- getLine

    -- See what they want to do.  For every option except 4,

    -- return them to the main menu afterwards by calling

    -- mainMenu recursively

    case sel of

         "1" -> lookupUserName >> mainMenu maps

         "2" -> lookupUID >> mainMenu maps

         "3" -> displayFile >> mainMenu maps

         "4" -> return ()

         _ -> putStrLn "Invalid selection" >> mainMenu maps



    where 

    lookupUserName = do

        putStrLn "Username: "

        username <- getLine

        case Map.lookup username usermap of

             Nothing -> putStrLn "Not found."

             Just x -> print x

    lookupUID = do

        putStrLn "UID: "

        uidstring <- getLine

        case Map.lookup (read uidstring) uidmap of

             Nothing -> putStrLn "Not found."

             Just x -> print x

    displayFile = 

        putStr . unlines . map (show . snd) . Map.toList $ uidmap

    optionText = 

          "\npasswdmap options:\n\

           \\n\

           \1   Look up a user name\n\

           \2   Look up a UID\n\

           \3   Display entire file\n\

           \4   Quit\n\n\

           \Your selection: "

:l num.hs

[1 of 1] Compiling Main             ( num.hs, interpreted )

Ok, modules loaded: Main.

5 + 1 * 3

8

prettyShow $ 5 + 1 * 3

"5+(1*3)"

prettyShow $ 5 * 1 + 3

"(5*1)+3"

prettyShow $ simplify $ 5 + 1 * 3

"5+3"

rpnShow $ 5 + 1 * 3

"5 1 3 * +"

rpnShow $ simplify $ 5 + 1 * 3

"5 3 +"

prettyShow $ 5 + (Symbol "x") * 3

"5+(x*3)"

struct list {

    struct node *head, *tail;

};

-- file: ch13/Append.hs

(++) :: [a] -> [a] -> [a]

(x:xs) ++ ys = x : xs ++ ys

_      ++ ys = ys

:info (++)

(++) :: [a] -> [a] -> [a] 	-- Defined in GHC.Base

infixr 5 ++

-- file: ch13/DataSequence.hs

import qualified Data.Sequence as Seq

Seq.empty

Loading package array-0.1.0.0 ... linking ... done.

Loading package containers-0.1.0.2 ... linking ... done.

fromList []

Seq.singleton 1

fromList [1]

        

        let a = Seq.fromList [1,2,3]

1 Seq.<| Seq.singleton 2

fromList [1,2]

-- file: ch13/DataSequence.hs

import Data.Sequence ((><), (<|), (|>))

Seq.singleton 1 |> 2

fromList [1,2]

let left = Seq.fromList [1,3,3]let right = Seq.fromList [7,1]left >< right

fromList [1,3,3,7,1]

-- file: ch13/DataSequence.hs

import qualified Data.Foldable as Foldable

Foldable.toList (Seq.fromList [1,2,3])

[1,2,3]

-- file: ch14/Maybe.hs

data Maybe a = Nothing

             | Just a

-- file: ch10/Parse.hs

newtype Parse a = Parse {

      runParse :: ParseState -> Either String (a, ParseState)

    }

:type (>>?)

(>>?) :: Maybe a -> (a -> Maybe b) -> Maybe b

:type (==>)

(==>) :: Parse a -> (a -> Parse b) -> Parse b

-- file: ch14/Maybe.hs

chain :: m a -> (a -> m b) -> m b

-- file: ch10/Parse.hs

identity :: a -> Parse a

identity a = Parse (\s -> Right (a, s))

-- file: ch14/Maybe.hs

inject :: a -> m a

-- file: ch14/Maybe.hs

class Monad m where

    -- chain

    (>>=)  :: m a -> (a -> m b) -> m b

    -- inject

    return :: a -> m a

-- file: ch14/Maybe.hs

    (>>) :: m a -> m b -> m b

    a >> f = a >>= \_ -> f

:type print "foo"

print "foo" :: IO ()

print "foo" >>= \_ -> print "bar"

"foo"

"bar"

print "baz" >> print "quux"

"baz"

"quux"

-- file: ch14/Logger.hs

globToRegex :: String -> Logger String

-- file: ch14/Logger.hs

module Logger

    (

      Logger

    , Log

    , runLogger

    , record

    ) where

-- file: ch14/Logger.hs

type Log = [String]

-- file: ch14/Logger.hs

runLogger :: Logger a -> (a, Log)

        

        let m = return "foo" :: Logger String

length m



<interactive>:1:7:

    Couldn't match expected type `[a]'

           against inferred type `Logger String'

    In the first argument of `length', namely `m'

    In the expression: length m

    In the definition of `it': it = length m

:type   m >>= \s -> return (length s)

m >>= \s -> return (length s) :: Logger Int

-- file: ch14/Logger.hs

liftM :: (Monad m) => (a -> b) -> m a -> m b

liftM f m = m >>= \i ->

            return (f i)

-- file: ch14/Logger.hs

newtype Logger a = Logger { execLogger :: (a, Log) }

-- file: ch14/Logger.hs

runLogger = execLogger

-- file: ch14/Logger.hs

record s = Logger ((), [s])

-- file: ch14/Logger.hs

instance Monad Logger where

    return a = Logger (a, [])

-- file: ch14/Logger.hs

    -- (>>=) :: Logger a -> (a -> Logger b) -> Logger b

    m >>= k = let (a, w) = execLogger m

                  n      = k a

                  (b, x) = execLogger n

              in Logger (b, w ++ x)

-- file: ch14/Maybe.hs

instance Monad Maybe where

    Just x >>= k  =  k x

    Nothing >>= _ =  Nothing



    Just _ >> k   =  k

    Nothing >> _  =  Nothing



    return x      =  Just x



    fail _        =  Nothing

-- file: ch14/Maybe.hs

maybe :: b -> (a -> b) -> Maybe a -> b

maybe n _ Nothing  = n

maybe _ f (Just x) = f x

-- file: ch14/Carrier.hs

import qualified Data.Map as M



type PersonName = String

type PhoneNumber = String

type BillingAddress = String

data MobileCarrier = Honest_Bobs_Phone_Network

                   | Morrisas_Marvelous_Mobiles

                   | Petes_Plutocratic_Phones

                     deriving (Eq, Ord)



findCarrierBillingAddress :: PersonName

                          -> M.Map PersonName PhoneNumber

                          -> M.Map PhoneNumber MobileCarrier

                          -> M.Map MobileCarrier BillingAddress

                          -> Maybe BillingAddress

-- file: ch14/ListMonad.hs

returnSingleton :: a -> [a]

returnSingleton x = [x]

:type (>>=)

(>>=) :: (Monad m) => m a -> (a -> m b) -> m b

:type map

map :: (a -> b) -> [a] -> [b]

:type (>>=)

(>>=) :: (Monad m) => m a -> (a -> m b) -> m b

:type flip map

flip map :: [a] -> (a -> b) -> [b]

-- file: ch14/Do.hs            -- file: ch14/Do.hs 

doNotation1 =                  translated1 =

    do act                         act

-- file: ch14/Do.hs            -- file: ch14/Do.hs

doNotation2 =                  translated2 =

    do act1                        act1 >>

       act2                        do act2

       {- ... etc. -}                 {- ... etc. -}

       actN                           actN



                              finalTranslation2 =

                                  act1 >>

                                  act2 >>

                                  {- ... etc. -}

                                  actN

-- file: ch14/Do.hs            -- file: ch14/Do.hs

doNotation3 =                  translated3 =

    do pattern <- act1             let f pattern = do act2

       act2                                           let f pattern = do act2

       {- ... etc. -}                                 actN

       actN                            f _     = fail "..."

                                   in act1 >>= f

:type fmap

fmap :: (Functor f) => (a -> b) -> f a -> f b

:module +Control.Monad

:type liftM

liftM :: (Monad m) => (a1 -> r) -> m a1 -> m r

-- file: ch14/ListMonad.hs

instance Monad [] where

    return x = [x]

    xs >>= f = concat (map f xs)

-- file: ch14/MonadLaws.hs

fmap id        ==   id 

fmap (f . g)   ==   fmap f . fmap g

-- file: ch14/MonadLaws.hs

return x >>= f            ===   f x

-- file: ch14/MonadLaws.hs

do y <- return x

   f y                    ===   f x

-- file: ch14/MonadLaws.hs

m >>= return              ===   m

-- file: ch14/MonadLaws.hs

do y <- m

   return y               ===   m

name=Attila+%42The+Hun%42&occupation=Khan

-- file: ch15/MovieReview.hs

    [("name",       Just "Attila \"The Hun\""),

     ("occupation", Just "Khan")]

-- file: ch15/MovieReview.hs

data MovieReview = MovieReview {

      revTitle :: String

    , revUser :: String

    , revReview :: String

    }

-- file: ch15/MovieReview.hs

simpleReview :: [(String, Maybe String)] -> Maybe MovieReview

simpleReview alist =

  case lookup "title" alist of

    Just (Just title@(_:_)) ->

      case lookup "user" alist of

        Just (Just user@(_:_)) ->

          case lookup "review" alist of

            Just (Just review@(_:_)) ->

                Just (MovieReview title user review)

            _ -> Nothing -- no review

        _ -> Nothing -- no user

    _ -> Nothing -- no title

:m +Control.Monad:type ap

ap :: (Monad m) => m (a -> b) -> m a -> m b

:type MovieReview

MovieReview :: String -> String -> String -> MovieReview

String -> (String -> (String -> MovieReview))

Maybe (String -> (String -> (String -> MovieReview)))

        Maybe (String -> (String -> MovieReview))

-- file: ch15/MovieReview.hs

apReview alist =

    MovieReview `liftM` lookup1 "title" alist

                   `ap` lookup1 "user" alist

                   `ap` lookup1 "review" alist

:type ($)

($) :: (a -> b) -> a -> b

:type ap

ap :: (Monad m) => m (a -> b) -> m a -> m b

-- file: ch15/VCard.hs

data Context = Home | Mobile | Business

               deriving (Eq, Show)



type Phone = String



albulena = [(Home, "+355-652-55512")]



nils = [(Mobile, "+47-922-55-512"), (Business, "+47-922-12-121"),

        (Home, "+47-925-55-121"), (Business, "+47-922-25-551")]



twalumba = [(Business, "+260-02-55-5121")]

-- file: ch15/VCard.hs

onePersonalPhone :: [(Context, Phone)] -> Maybe Phone

onePersonalPhone ps = case lookup Home ps of

                        Nothing -> lookup Mobile ps

                        Just n -> Just n

-- file: ch15/VCard.hs

allBusinessPhones :: [(Context, Phone)] -> [Phone]

allBusinessPhones ps = map snd numbers

    where numbers = case filter (contextIs Business) ps of

                      [] -> filter (contextIs Mobile) ps

                      ns -> ns



contextIs a (b, _) = a == b

onePersonalPhone twalumba

Nothing

onePersonalPhone albulena

Just "+355-652-55512"

allBusinessPhones nils

["+47-922-12-121","+47-922-25-551"]

-- file: ch15/VCard.hs

class Monad m => MonadPlus m where

   mzero :: m a	

   mplus :: m a -> m a -> m a

-- file: ch15/VCard.hs

instance MonadPlus [] where

   mzero = []

   mplus = (++)



instance MonadPlus Maybe where

   mzero = Nothing



   Nothing `mplus` ys  = ys

   xs      `mplus` _ = xs

-- file: ch15/Supply.hs

runSupply :: Supply s a -> [s] -> (a, [s])

-- file: ch15/SupplyClass.hs

class (Monad m) => MonadSupply s m | m -> s where

    next :: m (Maybe s)

-- file: ch15/SupplyInstance.hs

newtype Reader e a = R { runReader :: e -> a }

-- file: ch15/SupplyInstance.hs

instance Monad (Reader e) where

    return a = R $ \_ -> a

    m >>= k = R $ \r -> runReader (k (runReader m r)) r

-- file: ch15/SupplyInstance.hs

ask :: Reader e e

ask = R id

runReader (ask >>= \x -> return (x * 3)) 2

Loading package old-locale-1.0.0.0 ... linking ... done.

Loading package old-time-1.0.0.0 ... linking ... done.

Loading package random-1.0.0.0 ... linking ... done.

6

-- file: ch15/SupplyInstance.hs

newtype MySupply e a = MySupply { runMySupply :: Reader e a }

    deriving (Monad)



instance MonadSupply e (MySupply e) where

    next = MySupply $ do

             v <- ask

             return (Just v)



    -- more concise:

    -- next = MySupply (Just `liftM` ask)

-- file: ch15/SupplyInstance.hs

xy :: (Num s, MonadSupply s m) => m s

xy = do

  Just x <- next

  Just y <- next

  return (x * y)

(fst . runSupply xy) `fmap` randomsIO

3155268008533561605104245047686121354

(fst . runSupply xy) `fmap` randomsIO

1764220767702892260034822063450517650

-- file: ch15/SupplyInstance.hs

runMS :: MySupply i a -> i -> a

runMS = runReader . runMySupply

-- file: ch16/csv1.hs

import Text.ParserCombinators.Parsec



{- A CSV file contains 0 or more lines, each of which is terminated

   by the end-of-line character (eol). -}

csvFile :: GenParser Char st [[String]]

csvFile = 

    do result <- many line

       eof

       return result



-- Each line contains 1 or more cells, separated by a comma

line :: GenParser Char st [String]

line = 

    do result <- cells

       eol                       -- end of line

       return result

       

-- Build up a list of cells.  Try to parse the first cell, then figure out 

-- what ends the cell.

cells :: GenParser Char st [String]

cells = 

    do first <- cellContent

       next <- remainingCells

       return (first : next)



-- The cell either ends with a comma, indicating that 1 or more cells follow,

-- or it doesn't, indicating that we're at the end of the cells for this line

remainingCells :: GenParser Char st [String]

remainingCells =

    (char ',' >> cells)            -- Found comma?  More cells coming

    <|> (return [])                -- No comma?  Return [], no more cells



-- Each cell contains 0 or more characters, which must not be a comma or

-- EOL

cellContent :: GenParser Char st String

cellContent = 

    many (noneOf ",\n")

       



-- The end of line character is \n

eol :: GenParser Char st Char

eol = char '\n'



parseCSV :: String -> Either ParseError [[String]]

parseCSV input = parse csvFile "(unknown)" input

-- file: ch16/csv2.hs

import Text.ParserCombinators.Parsec



csvFile = endBy line eol

line = sepBy cell (char ',')

cell = many (noneOf ",\n")

eol = char '\n'



parseCSV :: String -> Either ParseError [[String]]

parseCSV input = parse csvFile "(unknown)" input

-- file: ch16/csv3.hs

-- This function is not correct!

eol = string "\n" <|> string "\n\r"

:m Text.ParserCombinators.Parseclet eol = string "\n" <|> string "\n\r"

Loading package parsec-2.1.0.1 ... linking ... done.

parse eol "" "\n"

Right "\n"

parse eol "" "\n\r"

Right "\n"

parse (eol >> eof) "" "\n\r"

Left (line 2, column 1):

unexpected "\r"

expecting end of input

parse (eol >> eof) "" "\n"

Right ()

-- file: ch16/csv4.hs

-- This function is not correct!

eol = string "\n\r" <|> string "\n"

-- file: ch16/csv9.hs

import Text.ParserCombinators.Parsec



csvFile = endBy line eol

line = sepBy cell (char ',')

cell = quotedCell <|> many (noneOf ",\n\r")



quotedCell = 

    do char '"'

       content <- many quotedChar

       char '"' <?> "quote at end of cell"

       return content



quotedChar =

        noneOf "\""

    <|> try (string "\"\"" >> return '"')



eol =   try (string "\n\r")

    <|> try (string "\r\n")

    <|> string "\n"

    <|> string "\r"

    <?> "end of line"



parseCSV :: String -> Either ParseError [[String]]

parseCSV input = parse csvFile "(unknown)" input



main =

    do c <- getContents

       case parse csvFile "(stdin)" c of

            Left e -> do putStrLn "Error parsing input:"

                         print e

            Right r -> mapM_ print r

-- file: ch16/ParsecPlus.hs

instance MonadPlus (GenParser tok st) where

    mzero = fail "mzero"

    mplus = (<|>)

-- file: ch16/FormParse.hs

p_query :: CharParser () [(String, Maybe String)]

p_query = p_pair `sepBy` char '&'

-- file: ch16/FormParse.hs

p_pair :: CharParser () (String, Maybe String)

p_pair = do

  name <- many1 p_char

  value <- optionMaybe (char '=' >> many p_char)

  return (name, value)

-- file: ch16/FormParse.hs

p_char :: CharParser () Char

p_char = oneOf urlBaseChars

     <|> (char '+' >> return ' ')

     <|> p_hex



urlBaseChars = ['a'..'z']++['A'..'Z']++['0'..'9']++"$-_.!*'(),"



p_hex :: CharParser () Char

p_hex = do

  char '%'

  a <- hexDigit

  b <- hexDigit

  let ((d, _):_) = readHex [a,b]

  return . toEnum $ d

parseTest p_query "foo=bar&a%21=b+c"

Loading package parsec-2.1.0.1 ... linking ... done.

[("foo",Just "bar"),("a!",Just "b c")]

-- file: ch16/FormParse.hs

p_pair :: CharParser () (String, Maybe String)

p_pair = do

  name <- many1 p_char

  value <- optionMaybe (char '=' >> many p_char)

  return (name, value)

-- file: ch16/FormParse.hs

p_pair_app1 =

    liftM2 (,) (many1 p_char) (optionMaybe (char '=' >> many p_char))

-- file: ch16/ApplicativeParsec.hs

module ApplicativeParsec

    (

      module Control.Applicative

    , module Text.ParserCombinators.Parsec

    ) where



import Control.Applicative

import Control.Monad (MonadPlus(..), ap)

-- Hide a few names that are provided by Applicative.

import Text.ParserCombinators.Parsec hiding (many, optional, (<|>))



-- The Applicative instance for every Monad looks like this.

instance Applicative (GenParser s a) where

    pure  = return

    (<*>) = ap



-- The Alternative instance for every MonadPlus looks like this.

instance Alternative (GenParser s a) where

    empty = mzero

    (<|>) = mplus

-- file: ch16/FormApp.hs

p_hex :: CharParser () Char

p_hex = do

  char '%'

  a <- hexDigit

  b <- hexDigit

  let ((d, _):_) = readHex [a,b]

  return . toEnum $ d

-- file: ch16/FormApp.hs

a_hex = hexify <$> (char '%' *> hexDigit) <*> hexDigit

    where hexify a b = toEnum . fst . head . readHex $ [a,b]

-- file: ch16/FormApp.hs

hexify :: Char -> Char -> Char

hexify a b = toEnum . fst . head . readHex $ [a,b]

:type hexDigit

hexDigit :: CharParser st Char

:type char '%' *> hexDigit

char '%' *> hexDigit :: GenParser Char st Char

-- file: ch16/JSONParsec.hs

p_text :: CharParser () JValue

p_text = spaces *> text

     <?> "JSON text"

    where text = JObject <$> p_object

             <|> JArray <$> p_array

-- file: ch16/JSONParsec.hs

p_series :: Char -> CharParser () a -> Char -> CharParser () [a]

p_series left parser right =

    between (char left <* spaces) (char right) $

            (parser <* spaces) `sepBy` (char ',' <* spaces)

-- file: ch16/JSONParsec.hs

p_array :: CharParser () (JAry JValue)

p_array = JAry <$> p_series '[' p_value ']'

-- file: ch16/JSONParsec.hs

p_object :: CharParser () (JObj JValue)

p_object = JObj <$> p_series '{' p_field '}'

    where p_field = (,) <$> (p_string <* char ':' <* spaces) <*> p_value

-- file: ch16/JSONParsec.hs

p_value :: CharParser () JValue

p_value = value <* spaces

  where value = JString <$> p_string

            <|> JNumber <$> p_number

            <|> JObject <$> p_object

            <|> JArray <$> p_array

            <|> JBool <$> p_bool

            <|> JNull <$ string "null"

            <?> "JSON value"



p_bool :: CharParser () Bool

p_bool = True <$ string "true"

     <|> False <$ string "false"

-- file: ch16/HttpRequestParser.hs

module HttpRequestParser

    (

      HttpRequest(..)

    , Method(..)

    , p_request

    , p_query

    ) where



import ApplicativeParsec

import Numeric (readHex)

import Control.Monad (liftM4)

import System.IO (Handle)

-- file: ch16/HttpRequestParser.hs

data Method = Get | Post

          deriving (Eq, Ord, Show)



data HttpRequest = HttpRequest {

      reqMethod :: Method

    , reqURL :: String

    , reqHeaders :: [(String, String)]

    , reqBody :: Maybe String

    } deriving (Eq, Show)

-- file: ch16/HttpRequestParser.hs

p_request :: CharParser () HttpRequest

p_request = q "GET" Get (pure Nothing)

        <|> q "POST" Post (Just <$> many anyChar)

  where q name ctor body = liftM4 HttpRequest req url p_headers body

            where req = ctor <$ string name <* char ' '

        url = optional (char '/') *>

              manyTill notEOL (try $ string " HTTP/1." <* oneOf "01")

              <* crlf

-- file: ch17/SimpleFFI.hs

{-# LANGUAGE ForeignFunctionInterface #-}

-- file: ch17/SimpleFFI.hs

import Foreign

import Foreign.C.Types

-- file: ch17/SimpleFFI.hs

foreign import ccall "math.h sin"

     c_sin :: CDouble -> CDouble

pcre *pcre_compile(const char *pattern,

                   int options,

                   const char **errptr,

                   int *erroffset,

                   const unsigned char *tableptr);

int pcre_exec(const pcre *code,

              const pcre_extra *extra,

              const char *subject,

              int length,

              int startoffset,

              int options,

              int *ovector,

              int ovecsize);

-- file: ch17/RegexExec.hs

foreign import ccall "pcre.h pcre_exec"

    c_pcre_exec     :: Ptr PCRE

                    -> Ptr PCREExtra

                    -> Ptr Word8

                    -> CInt

                    -> CInt

                    -> PCREExecOption

                    -> Ptr CInt

                    -> CInt

                    -> IO CInt

-- file: ch17/RegexExec.hs

foreign import ccall "pcre.h pcre_fullinfo"

    c_pcre_fullinfo :: Ptr PCRE

                    -> Ptr PCREExtra

                    -> PCREInfo

                    -> Ptr a

                    -> IO CInt

-- file: ch18/CountEntries.hs

module CountEntries (listDirectory, countEntriesTrad) where



import System.Directory (doesDirectoryExist, getDirectoryContents)

import System.FilePath ((</>))

import Control.Monad (forM, liftM)



listDirectory :: FilePath -> IO [String]

listDirectory = liftM (filter notDots) . getDirectoryContents

    where notDots p = p /= "." && p /= ".."



countEntriesTrad :: FilePath -> IO [(FilePath, Int)]

countEntriesTrad path = do

  contents <- listDirectory path

  rest <- forM contents $ \name -> do

            let newName = path </> name

            isDir <- doesDirectoryExist newName

            if isDir

              then countEntriesTrad newName

              else return []

  return $ (path, length contents) : concat rest

-- file: ch18/Reader.hs

class (Monad m) => MonadReader r m | m -> r where

    ask   :: m r

    local :: (r -> r) -> m a -> m a

-- file: ch18/LocalReader.hs

import Control.Monad.Reader



myName step = do

  name <- ask

  return (step ++ ", I am " ++ name)



localExample :: Reader String (String, String, String)

localExample = do

  a <- myName "First"

  b <- local (++"dy") (myName "Second")

  c <- myName "Third"

  return (a, b, c)

runReader localExample "Fred"

Loading package mtl-1.1.0.1 ... linking ... done.

("First, I am Fred","Second, I am Freddy","Third, I am Fred")

-- file: ch18/Reader.hs

instance (Monad m) => Functor (ReaderT r m) where

    ...



instance (MonadIO m) => MonadIO (ReaderT r m) where

    ...



instance (MonadPlus m) => MonadPlus (ReaderT r m) where

    ...

-- file: ch18/UglyStack.hs

import System.Directory

import System.FilePath

import Control.Monad.Reader

import Control.Monad.State



data AppConfig = AppConfig {

      cfgMaxDepth :: Int

    } deriving (Show)



data AppState = AppState {

      stDeepestReached :: Int

    } deriving (Show)

-- file: ch18/UglyStack.hs

type App = ReaderT AppConfig (StateT AppState IO)

-- file: ch18/CustomT.hs

newtype CustomT m a = ...

-- file: ch18/CustomT.hs

instance MonadReader r m => MonadReader r (CustomT m) where

    ...



instance MonadIO m => MonadIO (CustomT m) where

    ...

:m +Control.Monad.Trans:info MonadTrans

class MonadTrans t where lift :: (Monad m) => m a -> t m a

  	-- Defined in Control.Monad.Trans

-- file: ch18/MaybeT.hs

newtype MaybeT m a = MaybeT {

      runMaybeT :: m (Maybe a)

    }

-- file: ch18/MaybeT.hs

bindMT :: (Monad m) => MaybeT m a -> (a -> MaybeT m b) -> MaybeT m b

-- file: ch18/MaybeT.hs

x `bindMT` f = MaybeT $ do

                 unwrapped <- runMaybeT x

                 case unwrapped of

                   Nothing -> return Nothing

                   Just y -> runMaybeT (f y)

-- file: ch18/MTComposition.hs

{-# LANGUAGE FlexibleContexts #-}

import Control.Monad.Writer

import MaybeT



problem :: MonadWriter [String] m => m ()

problem = do

  tell ["this is where i fail"]

  fail "oops"

-- file: ch18/MTComposition.hs

type A = WriterT [String] Maybe



type B = MaybeT (Writer [String])



a :: A ()

a = problem



b :: B ()

b = problem

runWriterT a

Loading package mtl-1.1.0.1 ... linking ... done.

Nothing

runWriter $ runMaybeT b

(Nothing,["this is where i fail"])

:t runWriterT

runWriterT :: WriterT w m a -> m (a, w)

:t runWriter . runMaybeT

runWriter . runMaybeT :: MaybeT (Writer w) a -> (Maybe a, w)

-- file: ch19/divby1.hs

divBy :: Integral a => a -> [a] -> [a]

divBy numerator = map (numerator `div`)

divBy 50 [1,2,5,8,10]

[50,25,10,6,5]

take 5 (divBy 100 [1..])

[100,50,33,25,20]

divBy 50 [1,2,0,8,10]

[50,25,*** Exception: divide by zero

-- file: ch19/divby2.hs

divBy :: Integral a => a -> [a] -> Maybe [a]

divBy _ [] = Just []

divBy _ (0:_) = Nothing

divBy numerator (denom:xs) =

    case divBy numerator xs of

      Nothing -> Nothing

      Just results -> Just ((numerator `div` denom) : results)

divBy 50 [1,2,5,8,10]

Just [50,25,10,6,5]

divBy 50 [1,2,0,8,10]

Nothing

-- file: ch19/MonadError.hs

class (Monad m) => MonadError e m | m -> e where

    throwError :: e             -- error to throw

               -> m a



    catchError :: m a           -- action to execute

               -> (e -> m a)    -- error handler

               -> m a

-- file: ch19/MonadError.hs

class Error a where

    -- create an exception with no message

    noMsg  :: a



    -- create an exception with a message

    strMsg :: String -> a

:module System.CmdrawSystem "ls" ["-l", "/usr"]

Loading package old-locale-1.0.0.0 ... linking ... done.

Loading package old-time-1.0.0.0 ... linking ... done.

Loading package filepath-1.1.0.0 ... linking ... done.

Loading package directory-1.0.0.1 ... linking ... done.

Loading package unix-2.3.0.1 ... linking ... done.

Loading package process-1.0.0.1 ... linking ... done.

total 408

drwxr-xr-x   2 root root  94208 2008-08-22 04:51 bin

drwxr-xr-x   2 root root   4096 2008-04-07 14:44 etc

drwxr-xr-x   2 root root   4096 2008-04-07 14:44 games

drwxr-xr-x 155 root root  16384 2008-08-20 20:54 include

drwxr-xr-x   4 root root   4096 2007-11-01 21:31 java

drwxr-xr-x   6 root root   4096 2008-03-18 11:38 kerberos

drwxr-xr-x  70 root root  36864 2008-08-21 04:52 lib

drwxr-xr-x 212 root root 126976 2008-08-21 04:53 lib64

drwxr-xr-x  23 root root  12288 2008-08-21 04:53 libexec

drwxr-xr-x  15 root root   4096 2008-04-07 14:44 local

drwxr-xr-x   2 root root  20480 2008-08-21 04:53 sbin

drwxr-xr-x 347 root root  12288 2008-08-21 11:01 share

drwxr-xr-x   5 root root   4096 2008-04-07 14:44 src

lrwxrwxrwx   1 root root     10 2008-05-16 15:01 tmp -> ../var/tmp

drwxr-xr-x   2 root root   4096 2007-04-10 11:01 X11R6

ExitSuccess

rawSystem "ls" []

calendartime.ghci  modtime.ghci    rp.ghci	  RunProcessSimple.hs

cmd.ghci	   posixtime.hs    rps.ghci	  timediff.ghci

dir.ghci	   rawSystem.ghci  RunProcess.hs  time.ghci

ExitSuccess

:module System.DirectorysetCurrentDirectory "/etc"

Loading package old-locale-1.0.0.0 ... linking ... done.

Loading package old-time-1.0.0.0 ... linking ... done.

Loading package filepath-1.1.0.0 ... linking ... done.

Loading package directory-1.0.0.1 ... linking ... done.

getCurrentDirectory

"/etc"

setCurrentDirectory ".."

getCurrentDirectory

"/"

getDirectoryContents "/"

["dev",".vmware","mnt","var","etc","net","..","lib","srv","media","lib64","opt",

".ccache","bin","selinux",".","lost+found","proc",".autorelabel",".autofsck",

"sys","misc","home","tmp","boot",".bash_history","root","sbin","usr"]

getDirectoryContents "/" >>= return . filter (`notElem` [".", ".."])

["dev",".vmware","mnt","var","etc","net","lib","srv","media","lib64","opt",

".ccache","bin","selinux","lost+found","proc",".autorelabel",".autofsck",

"sys","misc","home","tmp","boot",".bash_history","root","sbin","usr"]

$ ls /etc | grep 'm.*ap' | tr a-z A-Z

IDMAPD.CONF

MAILCAP

MAILCAP.ORDER

MEDIAPRM

TERMCAP

:module Database.HDBC Database.HDBC.Sqlite3conn <- connectSqlite3 "test1.db"

Loading package array-0.1.0.0 ... linking ... done.

Loading package containers-0.1.0.2 ... linking ... done.

Loading package bytestring-0.9.0.1.1 ... linking ... done.

Loading package old-locale-1.0.0.0 ... linking ... done.

Loading package old-time-1.0.0.0 ... linking ... done.

Loading package mtl-1.1.0.1 ... linking ... done.

Loading package HDBC-1.1.4 ... linking ... done.

Loading package HDBC-sqlite3-1.1.4.0 ... linking ... done.

:type conn

conn :: Connectiondisconnect conn

:module Database.HDBC Database.HDBC.Sqlite3conn <- connectSqlite3 "test1.db"

Loading package array-0.1.0.0 ... linking ... done.

Loading package containers-0.1.0.2 ... linking ... done.

Loading package bytestring-0.9.0.1.1 ... linking ... done.

Loading package old-locale-1.0.0.0 ... linking ... done.

Loading package old-time-1.0.0.0 ... linking ... done.

Loading package mtl-1.1.0.1 ... linking ... done.

Loading package HDBC-1.1.4 ... linking ... done.

Loading package HDBC-sqlite3-1.1.4.0 ... linking ... done.

run conn "CREATE TABLE test (id INTEGER NOT NULL, desc VARCHAR(80))" []

0

run conn "INSERT INTO test (id) VALUES (0)" []

1

commit conndisconnect conn

conn <- connectSqlite3 "test1.db"run conn "INSERT INTO test VALUES (?, ?)" [toSql 0, toSql "zero"]

1

commit conndisconnect conn

conn <- connectSqlite3 "test1.db"stmt <- prepare conn "INSERT INTO test VALUES (?, ?)"execute stmt [toSql 1, toSql "one"]

1

execute stmt [toSql 2, toSql "two"]

1

execute stmt [toSql 3, toSql "three"]

1

execute stmt [toSql 4, SqlNull]

1

commit conndisconnect conn

        

        conn <- connectSqlite3 "test1.db"

        

        stmt <- prepare conn "INSERT INTO test VALUES (?, ?)"

        

        executeMany stmt [[toSql 5, toSql "five's nice"], [toSql 6, SqlNull]]

        

        commit conn

        

        disconnect conn

conn <- connectSqlite3 "test1.db"quickQuery' conn "SELECT * from test where id < 2" []

[[SqlString "0",SqlNull],[SqlString "0",SqlString "zero"],

[SqlString "1",SqlString "one"],[SqlString "0",SqlNull],

[SqlString "0",SqlString "zero"],[SqlString "1",SqlString "one"]]

disconnect conn

-- file: ch21/query.hs

import Database.HDBC.Sqlite3 (connectSqlite3)

import Database.HDBC



{- | Define a function that takes an integer representing the maximum

id value to look up.  Will fetch all matching rows from the test database

and print them to the screen in a friendly format. -}

query :: Int -> IO ()

query maxId = 

    do -- Connect to the database

       conn <- connectSqlite3 "test1.db"



       -- Run the query and store the results in r

       r <- quickQuery' conn

            "SELECT id, desc from test where id <= ? ORDER BY id, desc"

            [toSql maxId]



       -- Convert each row into a String

       let stringRows = map convRow r

                        

       -- Print the rows out

       mapM_ putStrLn stringRows



       -- And disconnect from the database

       disconnect conn



    where convRow :: [SqlValue] -> String

          convRow [sqlId, sqlDesc] = 

              show intid ++ ": " ++ desc

              where intid = (fromSql sqlId)::Integer

                    desc = case fromSql sqlDesc of

                             Just x -> x

                             Nothing -> "NULL"

          convRow x = fail $ "Unexpected result: " ++ show x

conn <- connectSqlite3 "test1.db"getTables conn

["test"]

proxiedClientName conn

"sqlite3"

dbServerVer conn

"3.5.6"

dbTransactionSupport conn

Truedisconnect conn

conn <- connectSqlite3 "test1.db"quickQuery' conn "SELECT * from test2" []

*** Exception: (unknown)

disconnect conn

conn <- connectSqlite3 "test1.db"handleSqlError $ quickQuery' conn "SELECT * from test2" []

*** Exception: user error (SQL error: SqlError {seState = "", seNativeError = 1, 

seErrorMsg = "prepare 20: SELECT * from test2: no such table: test2"})

disconnect conn

-- file: ch22/PodTypes.hs

module PodTypes where



data Podcast =

    Podcast {castId :: Integer, -- ^ Numeric ID for this podcast

             castURL :: String  -- ^ Its feed URL

            }

    deriving (Eq, Show, Read)



data Episode = 

    Episode {epId :: Integer,     -- ^ Numeric ID for this episode

             epCast :: Podcast,   -- ^ The ID of the podcast it came from

             epURL :: String,     -- ^ The download URL for this episode

             epDone :: Bool       -- ^ Whether or not we are done with this ep

            }

    deriving (Eq, Show, Read)

-- file: ch22/PodDB.hs

module PodDB where



import Database.HDBC

import Database.HDBC.Sqlite3

import PodTypes

import Control.Monad(when)

import Data.List(sort)



-- | Initialize DB and return database Connection

connect :: FilePath -> IO Connection

connect fp =

    do dbh <- connectSqlite3 fp

       prepDB dbh

       return dbh



{- | Prepare the database for our data.



We create two tables and ask the database engine to verify some pieces

of data consistency for us:



* castid and epid both are unique primary keys and must never be duplicated

* castURL also is unique

* In the episodes table, for a given podcast (epcast), there must be only

  one instance of each given URL or episode ID

-}

prepDB :: IConnection conn => conn -> IO ()

prepDB dbh =

    do tables <- getTables dbh

       when (not ("podcasts" `elem` tables)) $

           do run dbh "CREATE TABLE podcasts (\

                       \castid INTEGER NOT NULL PRIMARY KEY AUTOINCREMENT,\

                       \castURL TEXT NOT NULL UNIQUE)" []

              return ()

       when (not ("episodes" `elem` tables)) $

           do run dbh "CREATE TABLE episodes (\

                       \epid INTEGER NOT NULL PRIMARY KEY AUTOINCREMENT,\

                       \epcastid INTEGER NOT NULL,\

                       \epurl TEXT NOT NULL,\

                       \epdone INTEGER NOT NULL,\

                       \UNIQUE(epcastid, epurl),\

                       \UNIQUE(epcastid, epid))" []

              return ()

       commit dbh



{- | Adds a new podcast to the database.  Ignores the castid on the

incoming podcast, and returns a new object with the castid populated.



An attempt to add a podcast that already exists is an error. -}

addPodcast :: IConnection conn => conn -> Podcast -> IO Podcast

addPodcast dbh podcast = 

    handleSql errorHandler $

      do -- Insert the castURL into the table.  The database

         -- will automatically assign a cast ID.

         run dbh "INSERT INTO podcasts (castURL) VALUES (?)"

             [toSql (castURL podcast)]

         -- Find out the castID for the URL we just added.

         r <- quickQuery' dbh "SELECT castid FROM podcasts WHERE castURL = ?"

              [toSql (castURL podcast)]

         case r of

           [[x]] -> return $ podcast {castId = fromSql x}

           y -> fail $ "addPodcast: unexpected result: " ++ show y

    where errorHandler e = 

              do fail $ "Error adding podcast; does this URL already exist?\n"

                     ++ show e



{- | Adds a new episode to the database. 



Since this is done by automation instead of by user request, we will

simply ignore requests to add duplicate episodes.  This way, when we are

processing a feed, each URL encountered can be fed to this function,

without having to first look it up in the DB.



Also, we generally won't care about the new ID here, so don't bother

fetching it. -}

addEpisode :: IConnection conn => conn -> Episode -> IO ()

addEpisode dbh ep =

    run dbh "INSERT OR IGNORE INTO episodes (epCastId, epURL, epDone) \

                \VALUES (?, ?, ?)"

                [toSql (castId . epCast $ ep), toSql (epURL ep),

                 toSql (epDone ep)]

    >> return ()

       

{- | Modifies an existing podcast.  Looks up the given podcast by

ID and modifies the database record to match the passed Podcast. -}

updatePodcast :: IConnection conn => conn -> Podcast -> IO ()

updatePodcast dbh podcast =

    run dbh "UPDATE podcasts SET castURL = ? WHERE castId = ?" 

            [toSql (castURL podcast), toSql (castId podcast)]

    >> return ()



{- | Modifies an existing episode.  Looks it up by ID and modifies the

database record to match the given episode. -}

updateEpisode :: IConnection conn => conn -> Episode -> IO ()

updateEpisode dbh episode =

    run dbh "UPDATE episodes SET epCastId = ?, epURL = ?, epDone = ? \

             \WHERE epId = ?"

             [toSql (castId . epCast $ episode),

              toSql (epURL episode),

              toSql (epDone episode),

              toSql (epId episode)]

    >> return ()



{- | Remove a podcast.  First removes any episodes that may exist

for this podcast. -}

removePodcast :: IConnection conn => conn -> Podcast -> IO ()

removePodcast dbh podcast =

    do run dbh "DELETE FROM episodes WHERE epcastid = ?" 

         [toSql (castId podcast)]

       run dbh "DELETE FROM podcasts WHERE castid = ?"

         [toSql (castId podcast)]

       return ()



{- | Gets a list of all podcasts. -}

getPodcasts :: IConnection conn => conn -> IO [Podcast]

getPodcasts dbh =

    do res <- quickQuery' dbh 

              "SELECT castid, casturl FROM podcasts ORDER BY castid" []

       return (map convPodcastRow res)



{- | Get a particular podcast.  Nothing if the ID doesn't match, or

Just Podcast if it does. -}

getPodcast :: IConnection conn => conn -> Integer -> IO (Maybe Podcast)

getPodcast dbh wantedId =

    do res <- quickQuery' dbh 

              "SELECT castid, casturl FROM podcasts WHERE castid = ?"

              [toSql wantedId]

       case res of

         [x] -> return (Just (convPodcastRow x))

         [] -> return Nothing

         x -> fail $ "Really bad error; more than one podcast with ID"



{- | Convert the result of a SELECT into a Podcast record -}

convPodcastRow :: [SqlValue] -> Podcast

convPodcastRow [svId, svURL] =

    Podcast {castId = fromSql svId,

             castURL = fromSql svURL}

convPodcastRow x = error $ "Can't convert podcast row " ++ show x



{- | Get all episodes for a particular podcast. -}

getPodcastEpisodes :: IConnection conn => conn -> Podcast -> IO [Episode]

getPodcastEpisodes dbh pc =

    do r <- quickQuery' dbh

            "SELECT epId, epURL, epDone FROM episodes WHERE epCastId = ?"

            [toSql (castId pc)]

       return (map convEpisodeRow r)

    where convEpisodeRow [svId, svURL, svDone] =

              Episode {epId = fromSql svId, epURL = fromSql svURL,

                       epDone = fromSql svDone, epCast = pc}

<?xml version="1.0" encoding="UTF-8"?>

<rss xmlns:itunes="http://www.itunes.com/DTDs/Podcast-1.0.dtd" version="2.0">

  <channel>

    <title>Haskell Radio</title>

    <link>http://www.example.com/radio/</link>

    <description>Description of this podcast</description>

    <item>

      <title>Episode 2: Lambdas</title>

      <link>http://www.example.com/radio/lambdas</link>

      <enclosure url="http://www.example.com/radio/lambdas.mp3"

       type="audio/mpeg" length="10485760"/>

    </item>

    <item>

      <title>Episode 1: Parsec</title>

      <link>http://www.example.com/radio/parsec</link>

      <enclosure url="http://www.example.com/radio/parsec.mp3"

       type="audio/mpeg" length="10485150"/>

    </item>

  </channel>

</rss>

-- file: ch22/PodParser.hs

module PodParser where



import PodTypes

import Text.XML.HaXml

import Text.XML.HaXml.Parse

import Text.XML.HaXml.Html.Generate(showattr)

import Data.Char

import Data.List



data PodItem = PodItem {itemtitle :: String,

                  enclosureurl :: String

                  }

          deriving (Eq, Show, Read)



data Feed = Feed {channeltitle :: String,

                  items :: [PodItem]}

            deriving (Eq, Show, Read)



{- | Given a podcast and an PodItem, produce an Episode -}

item2ep :: Podcast -> PodItem -> Episode

item2ep pc item =

    Episode {epId = 0,

             epCast = pc,

             epURL = enclosureurl item,

             epDone = False}



{- | Parse the data from a given string, with the given name to use

in error messages. -}

parse :: String -> String -> Feed

parse content name = 

    Feed {channeltitle = getTitle doc,

          items = getEnclosures doc}



    where parseResult = xmlParse name (stripUnicodeBOM content)

          doc = getContent parseResult



          getContent :: Document -> Content

          getContent (Document _ _ e _) = CElem e

          

          {- | Some Unicode documents begin with a binary sequence;

             strip it off before processing. -}

          stripUnicodeBOM :: String -> String

          stripUnicodeBOM ('\xef':'\xbb':'\xbf':x) = x

          stripUnicodeBOM x = x



{- | Pull out the channel part of the document.



Note that HaXml defines CFilter as:



> type CFilter = Content -> [Content]

-}

channel :: CFilter

channel = tag "rss" /> tag "channel"



getTitle :: Content -> String

getTitle doc =

    contentToStringDefault "Untitled Podcast" 

        (channel /> tag "title" /> txt $ doc)



getEnclosures :: Content -> [PodItem]

getEnclosures doc =

    concatMap procPodItem $ getPodItems doc

    where procPodItem :: Content -> [PodItem]

          procPodItem item = concatMap (procEnclosure title) enclosure

              where title = contentToStringDefault "Untitled Episode"

                               (keep /> tag "title" /> txt $ item)

                    enclosure = (keep /> tag "enclosure") item



          getPodItems :: CFilter

          getPodItems = channel /> tag "item"



          procEnclosure :: String -> Content -> [PodItem]

          procEnclosure title enclosure =

              map makePodItem (showattr "url" enclosure)

              where makePodItem :: Content -> PodItem

                    makePodItem x = PodItem {itemtitle = title,

                                       enclosureurl = contentToString [x]}



{- | Convert [Content] to a printable String, with a default if the 

passed-in [Content] is [], signifying a lack of a match. -}

contentToStringDefault :: String -> [Content] -> String

contentToStringDefault msg [] = msg

contentToStringDefault _ x = contentToString x



{- | Convert [Content] to a printable string, taking care to unescape it.



An implementation without unescaping would simply be:



> contentToString = concatMap (show . content)



Because HaXml's unescaping works only on Elements, we must make sure that

whatever Content we have is wrapped in an Element, then use txt to

pull the insides back out. -}

contentToString :: [Content] -> String

contentToString = 

    concatMap procContent

    where procContent x = 

              verbatim $ keep /> txt $ CElem (unesc (fakeElem x))



          fakeElem :: Content -> Element

          fakeElem x = Elem "fake" [] [x]



          unesc :: Element -> Element

          unesc = xmlUnEscape stdXmlEscaper

-- file: ch22/PodDownload.hs

module PodDownload where

import PodTypes

import PodDB

import PodParser

import Network.HTTP

import System.IO

import Database.HDBC

import Data.Maybe

import Network.URI



{- | Download a URL.  (Left errorMessage) if an error,

(Right doc) if success. -}

downloadURL :: String -> IO (Either String String)

downloadURL url =

    do resp <- simpleHTTP request

       case resp of

         Left x -> return $ Left ("Error connecting: " ++ show x)

         Right r -> 

             case rspCode r of

               (2,_,_) -> return $ Right (rspBody r)

               (3,_,_) -> -- A HTTP redirect

                 case findHeader HdrLocation r of

                   Nothing -> return $ Left (show r)

                   Just url -> downloadURL url

               _ -> return $ Left (show r)

    where request = Request {rqURI = uri,

                             rqMethod = GET,

                             rqHeaders = [],

                             rqBody = ""}

          uri = fromJust $ parseURI url



{- | Update the podcast in the database. -}

updatePodcastFromFeed :: IConnection conn => conn -> Podcast -> IO ()

updatePodcastFromFeed dbh pc =

    do resp <- downloadURL (castURL pc)

       case resp of

         Left x -> putStrLn x

         Right doc -> updateDB doc



    where updateDB doc = 

              do mapM_ (addEpisode dbh) episodes

                 commit dbh

              where feed = parse doc (castURL pc)

                    episodes = map (item2ep pc) (items feed)



{- | Downloads an episode, returning a String representing

the filename it was placed into, or Nothing on error. -}

getEpisode :: IConnection conn => conn -> Episode -> IO (Maybe String)

getEpisode dbh ep =

    do resp <- downloadURL (epURL ep)

       case resp of

         Left x -> do putStrLn x

                      return Nothing

         Right doc -> 

             do file <- openBinaryFile filename WriteMode

                hPutStr file doc

                hClose file

                updateEpisode dbh (ep {epDone = True})

                commit dbh

                return (Just filename)

          -- This function ought to apply an extension based on the file type

    where filename = "pod." ++ (show . castId . epCast $ ep) ++ "." ++ 

                     (show (epId ep)) ++ ".mp3"

-- file: ch22/PodMain.hs

module Main where



import PodDownload

import PodDB

import PodTypes

import System.Environment

import Database.HDBC

import Network.Socket(withSocketsDo)



main = withSocketsDo $ handleSqlError $

    do args <- getArgs

       dbh <- connect "pod.db"

       case args of

         ["add", url] -> add dbh url

         ["update"] -> update dbh

         ["download"] -> download dbh

         ["fetch"] -> do update dbh

                         download dbh

         _ -> syntaxError

       disconnect dbh



add dbh url = 

    do addPodcast dbh pc

       commit dbh

    where pc = Podcast {castId = 0, castURL = url}



update dbh = 

    do pclist <- getPodcasts dbh

       mapM_ procPodcast pclist

    where procPodcast pc =

              do putStrLn $ "Updating from " ++ (castURL pc)

                 updatePodcastFromFeed dbh pc



download dbh =

    do pclist <- getPodcasts dbh

       mapM_ procPodcast pclist

    where procPodcast pc =

              do putStrLn $ "Considering " ++ (castURL pc)

                 episodelist <- getPodcastEpisodes dbh pc

                 let dleps = filter (\ep -> epDone ep == False)

                             episodelist

                 mapM_ procEpisode dleps

          procEpisode ep =

              do putStrLn $ "Downloading " ++ (epURL ep)

                 getEpisode dbh ep



syntaxError = putStrLn 

  "Usage: pod command [args]\n\

  \\n\

  \pod add url      Adds a new podcast with the given URL\n\

  \pod download     Downloads all pending episodes\n\

  \pod fetch        Updates, then downloads\n\

  \pod update       Downloads podcast feeds, looks for new episodes\n"

ghc --make -O2 -o pod -package HTTP -package HaXml -package network \

    -package HDBC -package HDBC-sqlite3 PodMain.hs

-- file: ch23/PodLocalMain.hs

module Main where



import qualified PodMainGUI



main = PodMainGUI.main "podresources.glade"

-- file: ch23/PodMainGUI.hs

module PodMainGUI where



import PodDownload

import PodDB

import PodTypes

import System.Environment

import Database.HDBC

import Network.Socket(withSocketsDo)



-- GUI libraries



import Graphics.UI.Gtk hiding (disconnect)

import Graphics.UI.Gtk.Glade



-- Threading



import Control.Concurrent

-- file: ch23/PodMainGUI.hs

-- | Our main GUI type

data GUI = GUI {

      mainWin :: Window,

      mwAddBt :: Button,

      mwUpdateBt :: Button,

      mwDownloadBt :: Button,

      mwFetchBt :: Button,

      mwExitBt :: Button,

      statusWin :: Dialog,

      swOKBt :: Button,

      swCancelBt :: Button,

      swLabel :: Label,

      addWin :: Dialog,

      awOKBt :: Button,

      awCancelBt :: Button,

      awEntry :: Entry}

-- file: ch23/PodMainGUI.hs

guiAdd gui dbh = 

    do -- Initialize the add URL window

       entrySetText (awEntry gui) ""

       onClicked (awCancelBt gui) (widgetHide (addWin gui))

       onClicked (awOKBt gui) procOK

       

       -- Show the add URL window

       windowPresent (addWin gui)

    where procOK =

              do url <- entryGetText (awEntry gui)

                 widgetHide (addWin gui) -- Remove the dialog

                 add dbh url             -- Add to the DB

Figure : Screenshot of the add-a-podcast window

-- file: ch23/PodMainGUI.hs

statusWindow :: IConnection conn =>

                GUI 

             -> conn 

             -> String 

             -> ((String -> IO ()) -> IO ())

             -> IO ()

statusWindow gui dbh title func =

    do -- Clear the status text

       labelSetText (swLabel gui) ""

       

       -- Disable the OK button, enable Cancel button

       widgetSetSensitivity (swOKBt gui) False

       widgetSetSensitivity (swCancelBt gui) True



       -- Set the title

       windowSetTitle (statusWin gui) title



       -- Start the operation

       childThread <- forkIO childTasks



       -- Define what happens when clicking on Cancel

       onClicked (swCancelBt gui) (cancelChild childThread)

       

       -- Show the window

       windowPresent (statusWin gui)

    where childTasks =

              do updateLabel "Starting thread..."

                 func updateLabel

                 -- After the child task finishes, enable OK

                 -- and disable Cancel

                 enableOK

                 

          enableOK = 

              do widgetSetSensitivity (swCancelBt gui) False

                 widgetSetSensitivity (swOKBt gui) True

                 onClicked (swOKBt gui) (widgetHide (statusWin gui))

                 return ()



          updateLabel text =

              labelSetText (swLabel gui) text

          cancelChild childThread =

              do killThread childThread

                 yield

                 updateLabel "Action has been cancelled."

                 enableOK

-- ch24/pod.cabal

Name: pod

Version: 1.0.0

Build-type: Simple

Build-Depends: HTTP, HaXml, network, HDBC, HDBC-sqlite3, base, 

               gtk, glade

Data-files: podresources.glade



Executable: pod

Main-Is: PodCabalMain.hs

GHC-Options: -O2

-- file: ch23/PodCabalMain.hs

module Main where



import qualified PodMainGUI

import Paths_pod(getDataFileName)



main = 

    do gladefn <- getDataFileName "podresources.glade"

       PodMainGUI.main gladefn

:m +Control.Concurrent:t forkIO

forkIO :: IO () -> IO ThreadId

:m +System.Directory

forkIO (writeFile "xyzzy" "seo craic nua!") >> doesFileExist "xyzzy"

False

-- file: ch24/Compressor.hs

import Control.Concurrent (forkIO)

import Control.Exception (handle)

import Control.Monad (forever)

import qualified Data.ByteString.Lazy as L

import System.Console.Readline (readline)



-- Provided by the 'zlib' package on http://hackage.haskell.org/

import Codec.Compression.GZip (compress)



main = do

    maybeLine <- readline "Enter a file to compress> "

    case maybeLine of

      Nothing -> return ()      -- user entered EOF

      Just "" -> return ()      -- treat no name as "want to quit"

      Just name -> do

           handle print $ do

             content <- L.readFile name

             forkIO (compressFile name content)

             return ()

           main

  where compressFile path = L.writeFile (path ++ ".gz") . compress

:t putMVar

putMVar :: MVar a -> a -> IO ()

:t takeMVar

takeMVar :: MVar a -> IO a

-- file: ch24/MVarExample.hs

import Control.Concurrent



communicate = do

  m <- newEmptyMVar

  forkIO $ do

    v <- takeMVar m

    putStrLn ("received " ++ show v)

  putStrLn "sending"

  putMVar m "wake up!"

:t newEmptyMVar

newEmptyMVar :: IO (MVar a)

:t newMVar

newMVar :: a -> IO (MVar a)

:load MVarExample

[1 of 1] Compiling Main             ( MVarExample.hs, interpreted )

Ok, modules loaded: Main.

communicate

sending

received "wake up!"

-- file: ch24/NiceFork.hs

import Control.Concurrent

import Control.Exception (Exception, try)

import qualified Data.Map as M



data ThreadStatus = Running

                  | Finished         -- terminated normally

                  | Threw Exception  -- killed by uncaught exception

                    deriving (Eq, Show)



-- | Create a new thread manager.

newManager :: IO ThreadManager



-- | Create a new managed thread.

forkManaged :: ThreadManager -> IO () -> IO ThreadId



-- | Immediately return the status of a managed thread.

getStatus :: ThreadManager -> ThreadId -> IO (Maybe ThreadStatus)



-- | Block until a specific managed thread terminates.

waitFor :: ThreadManager -> ThreadId -> IO (Maybe ThreadStatus)



-- | Block until all managed threads terminate.

waitAll :: ThreadManager -> IO ()

-- file: ch24/NiceFork.hs

module NiceFork

    (

      ThreadManager

    , newManager

    , forkManaged

    , getStatus

    , waitFor

    , waitAll

    ) where

-- file: ch24/NiceFork.hs

newtype ThreadManager =

    Mgr (MVar (M.Map ThreadId (MVar ThreadStatus)))

    deriving (Eq)



newManager = Mgr `fmap` newMVar M.empty

-- file: ch24/Chan.hs

import Control.Concurrent

import Control.Concurrent.Chan



chanExample = do

  ch <- newChan

  forkIO $ do

    writeChan ch "hello world"

    writeChan ch "now i quit"

  readChan ch >>= print

  readChan ch >>= print

201.49.94.87 - - [08/Jun/2008:07:04:20 -0500] "GET / HTTP/1.1"

200 2097 "http://en.wikipedia.org/wiki/Mercurial_(software)"

"Mozilla/5.0 (Windows; U; Windows XP 5.1; en-GB; rv:1.8.1.12)

Gecko/20080201 Firefox/2.0.0.12" 0 hgbook.red-bean.com

-- file: ch25/A.hs

import System.Environment

import Text.Printf



main = do

    [d] <- map read `fmap` getArgs

    printf "%f\n" (mean [1..d])



mean :: [Double] -> Double

mean xs = sum xs / fromIntegral (length xs)

ghc --make -O2 A.hs

[1 of 1] Compiling Main             ( A.hs, A.o )

Linking A ...

time ./A 1e5

50000.5

./A 1e5  0.05s user 0.01s system 102% cpu 0.059 total

time ./A 1e6

500000.5

./A 1e6  0.26s user 0.04s system 99% cpu 0.298 total

time ./A 1e7

5000000.5

./A 1e7  63.80s user 0.62s system 99% cpu 1:04.53 total

-- file: ch25/B.hs

mean :: [Double] -> Double

mean xs = s / fromIntegral n

  where

    (n, s)     = foldl k (0, 0) xs

    k (n, s) x = (n+1, s+x)

ghc -O2 --make B.hs -fforce-recomptime ./B 1e6

Stack space overflow: current size 8388608 bytes.

Use `+RTS -Ksize' to increase it.

./B 1e6  0.44s user 0.10s system 96% cpu 0.565 total

ghc -O2 --make B.hs -prof -auto-all -caf-all -fforce-recomp

[1 of 1] Compiling Main             ( B.hs, B.o )

Linking B ...

time ./B 1e6 +RTS -i0.001 -hc -p -K100M

500000.5

./B 1e6 +RTS -i0.001 -hc -p -K100M  38.70s user 0.27s system 99% cpu 39.241 total

Figure : Graph of stack usage. The curve is shaped like a hump, with mean representing 80%, and GHC.Real.CAF the other 20%.

        

        ghc -O2 -ddump-simpl G.hs

lgo :: Integer -> [Double] -> Double# -> (# Integer, Double #)



lgo = \ n xs s ->

    case xs of

      []       -> (# n, D# s #);

      (:) x ys ->

        case plusInteger n 1 of

            n' -> case x of

                D# y -> lgo n' ys (+## s y)

-- file: ch25/I.hs

import System.Environment

import Text.Printf

import Data.Array.Vector



main = do

    [d] <- map read `fmap` getArgs

    printf "%f\n" (mean (enumFromToFracU 1 d))



data Pair = Pair !Int !Double



mean :: UArr Double -> Double

mean xs = s / fromIntegral n

  where

    Pair n s       = foldlU k (Pair 0 0) xs

    k (Pair n s) x = Pair (n+1) (s+x)

-- file: BloomFilter/Internal.hs

module BloomFilter.Internal

    (

      Bloom(..)

    , MutBloom(..)

    ) where



import Data.Array.ST (STUArray)

import Data.Array.Unboxed (UArray)

import Data.Word (Word32)



data Bloom a = B {

      blmHash  :: (a -> [Word32])

    , blmArray :: UArray Word32 Bool

    }

-- file: BloomFilter/Mutable.hs

module BloomFilter.Mutable

    (

      MutBloom

    , elem

    , notElem

    , insert

    , length

    , new

    ) where



import Control.Monad (liftM)

import Control.Monad.ST (ST)

import Data.Array.MArray (getBounds, newArray, readArray, writeArray)

import Data.Word (Word32)

import Prelude hiding (elem, length, notElem)



import BloomFilter.Internal (MutBloom(..))

-- file: BloomFilter/Internal.hs

data MutBloom s a = MB {

      mutHash :: (a -> [Word32])

    , mutArray :: STUArray s Word32 Bool

    }

-- file: BloomFilter/Mutable.hs

new :: (a -> [Word32]) -> Word32 -> ST s (MutBloom s a)

new hash numBits = MB hash `liftM` newArray (0,numBits-1) False

-- file: BloomFilter/Mutable.hs

length :: MutBloom s a -> ST s Word32

length filt = (succ . snd) `liftM` getBounds (mutArray filt)

-- file: BloomFilter/Mutable.hs

insert :: MutBloom s a -> a -> ST s ()

insert filt elt = indices filt elt >>=

                  mapM_ (\bit -> writeArray (mutArray filt) bit True)



indices :: MutBloom s a -> a -> ST s [Word32]

indices filt elt = do

  modulus <- length filt

  return $ map (`mod` modulus) (mutHash filt elt)

-- file: BloomFilter/Mutable.hs

elem, notElem :: a -> MutBloom s a -> ST s Bool



elem elt filt = indices filt elt >>=

                allM (readArray (mutArray filt))



notElem elt filt = not `liftM` elem elt filt

-- file: ch26/BloomFilter.hs

module BloomFilter

    (

      Bloom

    , length

    , elem

    , notElem

    , fromList

    ) where



import BloomFilter.Internal

import BloomFilter.Mutable (insert, new)

import Data.Array.ST (runSTUArray)

import Data.Array.IArray ((!), bounds)

import Data.Word (Word32)

import Prelude hiding (elem, length, notElem)



length :: Bloom a -> Int

length = fromIntegral . len



len :: Bloom a -> Word32

len = succ . snd . bounds . blmArray



elem :: a -> Bloom a -> Bool

elt `elem` filt   = all test (blmHash filt elt)

  where test hash = blmArray filt ! (hash `mod` len filt)



notElem :: a -> Bloom a -> Bool

elt `notElem` filt = not (elt `elem` filt)

-- file: ch26/BloomFilter.hs

fromList :: (a -> [Word32])    -- family of hash functions to use

         -> Word32             -- number of bits in filter

         -> [a]                -- values to populate with

         -> Bloom a

fromList hash numBits values =

    B hash . runSTUArray $

      do mb <- new hash numBits

         mapM_ (insert mb) values

         return (mutArray mb)

-- file: BloomFilter/Easy.hs

easyList :: (Hashable a)

         => Double        -- false positive rate (between 0 and 1)

         -> [a]           -- values to populate the filter with

         -> Either String (B.Bloom a)

Name:               rwh-bloomfilter

Version:            0.1

License:            BSD3

License-File:       License.txt

Category:           Data

Stability:          experimental

Build-Type:         Simple

Extra-Source-Files: cbits/lookup3.c cbits/lookup3.h

-- file: examples/BloomCheck.hs

{-# LANGUAGE GeneralizedNewtypeDeriving #-}

module Main where



import BloomFilter.Hash (Hashable)

import Data.Word (Word8, Word32)

import System.Random (Random(..), RandomGen)

import Test.QuickCheck

import qualified BloomFilter.Easy as B

import qualified Data.ByteString as Strict

import qualified Data.ByteString.Lazy as Lazy

-- file: examples/BloomCheck.hs

handyCheck :: Testable a => Int -> a -> IO ()

handyCheck limit = check defaultConfig {

                     configMaxTest = limit

                   , configEvery   = \_ _ -> ""

                   }

-- file: examples/WordTest.hs

module Main where



import Control.Parallel.Strategies (NFData(..))

import Control.Monad (forM_, mapM_)

import qualified BloomFilter.Easy as B

import qualified Data.ByteString.Char8 as BS

import Data.Time.Clock (diffUTCTime, getCurrentTime)

import System.Environment (getArgs)

import System.Exit (exitFailure)



timed :: (NFData a) => String -> IO a -> IO a

timed desc act = do

    start <- getCurrentTime

    ret <- act

    end <- rnf ret `seq` getCurrentTime

    putStrLn $ show (diffUTCTime end start) ++ " to " ++ desc

    return ret



instance NFData BS.ByteString where

    rnf _ = ()



instance NFData (B.Bloom a) where

    rnf filt = B.length filt `seq` ()

-- file: examples/WordTest.hs

main = do

  args <- getArgs

  let files | null args = ["/usr/share/dict/words"]

            | otherwise = args

  forM_ files $ \file -> do



    words <- timed "read words" $

      BS.lines `fmap` BS.readFile file



    let len = length words

        errRate = 0.01



    putStrLn $ show len ++ " words"

    putStrLn $ "suggested sizings: " ++

               show (B.suggestSizing (fromIntegral len) errRate)



    filt <- timed "construct filter" $

      case B.easyList errRate words of

        Left errmsg -> do

          putStrLn $ "Error: " ++ errmsg

          exitFailure

        Right filt -> return filt



    timed "query every element" $

      mapM_ print $ filter (not . (`B.elem` filt)) words

-- file: ch28/GameInventory.hs

{-# LANGUAGE GeneralizedNewtypeDeriving #-}



import Control.Concurrent.STM

import Control.Monad



data Item = Scroll

          | Wand

          | Banjo

            deriving (Eq, Ord, Show)



newtype Gold = Gold Int

    deriving (Eq, Ord, Show, Num)



newtype HitPoint = HitPoint Int

    deriving (Eq, Ord, Show, Num)



type Inventory = TVar [Item]

type Health = TVar HitPoint

type Balance = TVar Gold



data Player = Player {

      balance :: Balance,

      health :: Health,

      inventory :: Inventory

    }

-- file: ch28/GameInventory.hs

basicTransfer qty fromBal toBal = do

  fromQty <- readTVar fromBal

  toQty   <- readTVar toBal

  writeTVar fromBal (fromQty - qty)

  writeTVar toBal   (toQty + qty)

-- file: ch28/GameInventory.hs

transferTest = do

  alice <- newTVar (12 :: Gold)

  bob   <- newTVar 4

  basicTransfer 3 alice bob

  liftM2 (,) (readTVar alice) (readTVar bob)

:load GameInventory

[1 of 1] Compiling Main             ( GameInventory.hs, interpreted )

Ok, modules loaded: Main.

atomically transferTest

Loading package array-0.1.0.0 ... linking ... done.

Loading package stm-2.1.1.1 ... linking ... done.

(Gold 9,Gold 7)

:type atomically

atomically :: STM a -> IO a

:type newTVar

newTVar :: a -> STM (TVar a)

:type readTVar

readTVar :: TVar a -> STM a

:type writeTVar

writeTVar :: TVar a -> a -> STM ()

-- file: ch28/GameInventory.hs

basicTransfer :: Gold -> Balance -> Balance -> STM ()

maybeGiveItem :: Item -> Inventory -> Inventory -> STM Bool

-- file: ch28/GameInventory.hs

maybeSellItem :: Item -> Gold -> Player -> Player -> STM Bool

maybeSellItem item price buyer seller = do

  given <- maybeGiveItem item (inventory seller) (inventory buyer)

  if given

    then do

      basicTransfer price (balance buyer) (balance seller)

      return True

    else return False

-- file: ch28/GameInventory.hs

giveItem :: Item -> Inventory -> Inventory -> STM ()



giveItem item fromInv toInv = do

  fromList <- readTVar fromInv

  case removeInv item fromList of

    Nothing -> retry

    Just newList -> do

      writeTVar fromInv newList

      readTVar toInv >>= writeTVar toInv . (item :)

-- file: ch28/GameInventory.hs

transfer :: Gold -> Balance -> Balance -> STM ()



transfer qty fromBal toBal = do

  fromQty <- readTVar fromBal

  when (qty > fromQty) $

    retry

  writeTVar fromBal (fromQty - qty)

  readTVar toBal >>= writeTVar toBal . (qty +)

:type orElse

orElse :: STM a -> STM a -> STM a

-- file: ch28/GameInventory.hs

crummyList :: [(Item, Gold)] -> Player -> Player

             -> STM (Maybe (Item, Gold))

crummyList list buyer seller = go list

    where go []                         = return Nothing

          go (this@(item,price) : rest) = do

              sellItem item price buyer seller

              return (Just this)

           `orElse`

              go rest

-- file: ch28/GameInventory.hs

maybeSTM :: STM a -> STM (Maybe a)

maybeSTM m = (Just `liftM` m) `orElse` return Nothing

-- file: ch28/STMPlus.hs

instance MonadPlus STM where

  mzero = retry

  mplus = orElse

-- file: ch28/STMPlus.hs

msum :: MonadPlus m => [m a] -> m a

msum =  foldr mplus mzero

-- file: ch28/STMIO.hs

someAction :: IO a



stmTransaction :: STM (IO a)

stmTransaction = return someAction



doSomething :: IO a

doSomething = join (atomically stmTransaction)

:m +GHC.Conc:type unsafeIOToSTM

unsafeIOToSTM :: IO a -> STM a

-- file: ch28/STMIO.hs

launchTorpedoes :: IO ()



notActuallyAtomic = do

  doStuff

  unsafeIOToSTM launchTorpedoes

  mightRetry

-- file: ch28/Check.hs

{-# LANGUAGE FlexibleContexts, GeneralizedNewtypeDeriving,

             PatternGuards #-}



import Control.Concurrent (forkIO)

import Control.Concurrent.STM

import Control.Exception (catch, finally)

import Control.Monad.Error

import Control.Monad.State

import Data.Char (isControl)

import Data.List (nub)

import Network.URI

import Prelude hiding (catch)

import System.Console.GetOpt

import System.Environment (getArgs)

import System.Exit (ExitCode(..), exitWith)

import System.IO (hFlush, hPutStrLn, stderr, stdout)

import Text.Printf (printf)

import qualified Data.ByteString.Lazy.Char8 as B

import qualified Data.Set as S



-- This requires the HTTP package, which is not bundled with GHC

import Network.HTTP



type URL = B.ByteString



data Task = Check URL | Done

-- file: ch28/Check.hs

main :: IO ()

main = do

    (files,k) <- parseArgs

    let n = length files



    -- count of broken links

    badCount <- newTVarIO (0 :: Int)



    -- for reporting broken links

    badLinks <- newTChanIO



    -- for sending jobs to workers

    jobs <- newTChanIO



    -- the number of workers currently running

    workers <- newTVarIO k



    -- one thread reports bad links to stdout

    forkIO $ writeBadLinks badLinks



    -- start worker threads

    forkTimes k workers (worker badLinks jobs badCount)



    -- read links from files, and enqueue them as jobs

    stats <- execJob (mapM_ checkURLs files)

                     (JobState S.empty 0 jobs)



    -- enqueue "please finish" messages

    atomically $ replicateM_ k (writeTChan jobs Done)



    waitFor workers



    broken <- atomically $ readTVar badCount



    printf fmt broken

               (linksFound stats)

               (S.size (linksSeen stats))

               n

  where

    fmt   = "Found %d broken links. " ++

            "Checked %d links (%d unique) in %d files.\n"