At the time the book Real World Haskell was written (2008) the current
Haskell version was 6.8 and many libraries, modules and
implementations have changed what makes some codes incompatible with
new Haskell versions. In order to solve this problem this section
provides modified codes from the book and the ghci repl sessions in
Haskell v7.10.2.
Reference:
- O’Sullivan, Bryan, John Goerzen, and Donald Bruce Stewart. Real world haskell: Code you can believe in. ” O’Reilly Media, Inc.”, 2008. Available at: http://book.realworldhaskell.org/read/.
Install the necessary libraries with stack
The necessary libraries to run the codes in this page can be installed with the following command outside a project directory (Directory without stack.yaml file):
$ stack install mtl turtle aeson regex-posix network randomOnce the package manager is installed you can run:
$ cd rwh
$ ls
ch03/ ch05/ ch07/ ch10/ ch14/ ch16/ ch18/ shell.nix
ch04/ ch06/ ch08/ ch13/ ch15/ ch17/ ch27/
#
# Where is ghci ??
$ stack exec -- which ghci
/home/arch/.stack/programs/x86_64-linux/ghc-8.0.1/bin/ghci
# Where is ghc ??
$ stack exec -- which ghc
/home/arch/.stack/programs/x86_64-linux/ghc-8.0.1/bin/ghc
# Run ghci
$ stack ghci - file:rwh/ch03/BookStore.hs
data BookInfo = Book Int String [String]
deriving (Show)
data MagazineInfo = Magazine Int String [String]
deriving (Show)
type CustomerID = Int --- Type synonym
type ReviewBody = String
data BookReview = BookReview BookInfo CustomerID String
data BetterReviw = BetterReviw BookInfo CustomerID ReviewBody
type BookRecord = (BookInfo, BookReview)
myInfo = Book 9780135072455 "Algebra of Programming"
["Richard Bird", "Oege de Moor"]
>>> :load "rwh/ch03/BookStore.hs"
[1 of 1] Compiling Main ( rwh/ch03/BookStore.hs, interpreted )
Ok, modules loaded: Main.
>>>
>>> myInfo
Book 9780135072455 "Algebra of Programming" ["Richard Bird","Oege de Moor"]
>>>
>>> :type myInfo
myInfo :: BookInfo
>>>
>>> Book 0 "The Book of Imaginary Beings" ["Jorge Luis Borges"]
Book 0 "The Book of Imaginary Beings" ["Jorge Luis Borges"]
>>>
>>> :type Book 1 "Cosmicomics" ["Italo Calvino"]
Book 1 "Cosmicomics" ["Italo Calvino"] :: BookInfo
>>>
>>> let cities = Book 173 "Use of Weapons" ["Iain M. Banks"]
>>> cities
Book 173 "Use of Weapons" ["Iain M. Banks"]
>>> type CardHolder = String
type CardNumber = String
type Address = [String]
type CustomerID = Int
data BillingInfo = CreditCard CardNumber CardHolder Address
| CashOnDelivery
| Invoice CustomerID
deriving (Show)>>> CreditCard "2901650221064486" "Thomas Gradgrind" ["Dickens", "England"]
CreditCard "2901650221064486" "Thomas Gradgrind" ["Dickens","England"]
>>>
>>> it
CreditCard "2901650221064486" "Thomas Gradgrind" ["Dickens","England"]
>>>
>>> :type it
it :: BillingInfo
>>>
>>>
Invoice 10
>>>
>>> CashOnDelivery
CashOnDeliveryfile:rwh/ch03/AlgebraicVector.hs
-- x and y coordinates or lengths.
data Cartesian2D = Cartesian2D Double Double
deriving (Eq, Show)
--- Angle and distance (magnitude)
data Polar2D = Polar2D Double Double
deriving (Eq, Show)
>>> Cartesian2D (sqrt 2) (sqrt 2)
Cartesian2D 1.4142135623730951 1.4142135623730951
>>>
>>> Polar2D (pi / 4) 2
Polar2D 0.7853981633974483 2.0
>>>
--- The (==) operator requires its arguments
--- to have the same type
---
>>> Cartesian2D (sqrt 2) (sqrt 2) == Polar2D (pi / 4) 2
<interactive>:58:34:
Couldn't match expected type ‘Cartesian2D’
with actual type ‘Polar2D’
In the second argument of ‘(==)’, namely ‘Polar2D (pi / 4) 2’
In the expression:
Cartesian2D (sqrt 2) (sqrt 2) == Polar2D (pi / 4) 2
>>> - file:rwh/ShapeUnion.hs
type Vector = (Double, Double)
data Shape = Circle Vector Double
| Poly [Vector]
sumList (x:xs) = x + sumList xs
sumList [] = 0 >>> :load "rwh/ch03/add.hs"
[1 of 1] Compiling Main ( rwh/ch03/add.hs, interpreted )
Ok, modules loaded: Main.
>>>
>>> sumList []
0
>>> sumList [1, 2, 3, 4, 5, 6]
21
>>> - file:rwh/ch03/BookStore3.hs
data BookInfo = Book Int String [String]
deriving (Show)
data MagazineInfo = Magazine Int String [String]
deriving (Show)
type CustomerID = Int --- Type synonym
type ReviewBody = String
data BookReview = BookReview BookInfo CustomerID String
data BetterReviw = BetterReviw BookInfo CustomerID ReviewBody
type BookRecord = (BookInfo, BookReview)
bookID (Book id title authors) = id
bookTitle (Book id title authors) = title
bookAuthors (Book id title authors) = authors
myInfo = Book 9780135072455 "Algebra of Programming"
["Richard Bird", "Oege de Moor"]
>>> :load "rwh/ch03/BookStore3.hs"
[1 of 1] Compiling Main ( rwh/ch03/BookStore3.hs, interpreted )
Ok, modules loaded: Main.
>>>
>>> bookID (Book 3 "Probability Theory" ["E.T.H. Jaynes"])
3
>>> bookTitle (Book 3 "Probability Theory" ["E.T.H. Jaynes"])
"Probability Theory"
>>> bookAuthors (Book 3 "Probability Theory" ["E.T.H. Jaynes"])
["E.T.H. Jaynes"]
>>> :type bookID
bookID :: BookInfo -> Int
>>> :type bookTitle
bookTitle :: BookInfo -> String
>>> :type bookAuthors
bookAuthors :: BookInfo -> [String]
>>> - file:rwh/ch03/BookStore4.hs
data BookInfo = Book Int String [String]
deriving (Show)
data MagazineInfo = Magazine Int String [String]
deriving (Show)
type CustomerID = Int --- Type synonym
type ReviewBody = String
type Address = [String]
data BookReview = BookReview BookInfo CustomerID String
data BetterReviw = BetterReviw BookInfo CustomerID ReviewBody
type BookRecord = (BookInfo, BookReview)
bookID (Book id title authors) = id
bookTitle (Book id title authors) = title
bookAuthors (Book id title authors) = authors
data Customer = Customer {
customerID :: CustomerID
, customerName :: String
, customerAddress :: Address
} deriving (Show)
myInfo = Book 9780135072455 "Algebra of Programming"
["Richard Bird", "Oege de Moor"]
customer1 = Customer 271828 "J.R. Hacker"
["255 Syntax Ct",
"Milpitas, CA 95134",
"USA"]
customer2 = Customer {
customerID = 271828
, customerAddress = ["1048576 Disk Drive",
"Milpitas, CA 95134",
"USA"]
, customerName = "Jane Q. Citizen"
}>>> :load "rwh/ch03/BookStore4.hs"
[1 of 1] Compiling Main ( rwh/ch03/BookStore4.hs, interpreted )
Ok, modules loaded: Main.
>>>
>>> customer1
Customer {customerID = 271828, customerName = "J.R. Hacker", customerAddress = ["255 Syntax Ct","Milpitas, CA 95134","USA"]}
>>>
>>> customer2
Customer {customerID = 271828, customerName = "Jane Q. Citizen", customerAddress = ["1048576 Disk Drive","Milpitas, CA 95134","USA"]}
>>>
>>> customerID customer1
271828
>>> customerID customer2
271828
>>> customerName customer1
"J.R. Hacker"
>>> customerAddress customer1
["255 Syntax Ct","Milpitas, CA 95134","USA"]
>>>
>>> :t customerName
customerName :: Customer -> String
>>> :t customerAddress
customerAddress :: Customer -> Address
>>> :t customerID
customerID :: Customer -> CustomerID
>>> Page 71: file:rwh/ch04/InteractWith.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 ... $ ./InteractWith /etc/issue error: exactly two arguments needed $ ./InteractWith /etc/issue /tmp/issue.out $ cat /tmp/issue.out Arch Linux \r (\l)Page 73: file:rwh/ch04/FixLines.hs
import System.Environment (getArgs)
interactWith function inputFile outputFile = do
input <- readFile inputFile
writeFile outputFile (function input)
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'
fixLines :: String -> String
fixLines input = unlines (splitLines 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 = fixLinesRunning Interactive:
>>> :load "rwh/ch04/FixLines.hs"
[1 of 1] Compiling Main ( rwh/ch04/FixLines.hs, interpreted )
Ok, modules loaded: Main.
>>>
>>> break odd [2, 4, 5, 6, 8]
([2,4],[5,6,8])
>>> splitLines "line1\nline2\r\nline3\r\n"
["line1","line2","line3"]
>>>
Running in batch mode:
$ curl -O http://www.gnu.org/licenses/gpl-3.0.txt
$ file gpl-3.0.txt
gpl-3.0.txt: ASCII text
# dos2unix replacement
#
$ awk 'sub("$", "\r")' gpl-3.0.txt > gpl-3.0.dos.txt
$ file gpl-3.0.dos.txt
gpl-3.0.dos.txt: ASCII text, with CRLF line terminators
$ ghc --make FixLines
[1 of 1] Compiling Main ( FixLines.hs, FixLines.o )
Linking FixLines ...
$ file FixLines
FixLines: ELF 64-bit LSB executable, x86-64, version 1 (SYSV), dynamically
linked, interpreter
/nix/store/n2wxp513rr00f6hr2dy0waqahns49dch-glibc-2.21/lib/ld-linux-x86-64.so.2,
for GNU/Linux 2.6.32, not stripped
$ ./FixLines
error: exactly two arguments needed
$ ./FixLines gpl-3.0.dos.txt gpl-3.0.unix.txt
$ file gpl-3.0.unix.txt
gpl-3.0.unix.txt: ASCII text- Write your own “safe” definitions of the standard partial list
functions, but make sure they never fail. As a hint, you might want to consider using the following types:
safeHead :: [a] -> Maybe a
safeTail :: [a] -> Maybe [a]
safeLast :: [a] -> Maybe a
safeInit :: [a] -> Maybe [a]- Write a function splitWith that acts similarly to words but takes a predicate and a
list of any type, and then splits its input list on every element for which the predicate returns False:
-- file: ch04/ch04.exercises.hs
splitWith :: (a -> Bool) -> [a] -> [[a]]Page 84: file:rwh/ch04/ch04.exercises.hs
safeHead :: [a] -> Maybe a
safeHead (head:rest) = Just head
safeHead [] = Nothing
safeTail :: [a] -> Maybe [a]
safeTail (head:rest) = Just rest
safeTail [] = Nothing
safeLast :: [a] -> Maybe a
safeLast [x] = Just x
safeLast (hd:tl) = safeLast tl
safeLast [] = Nothing
safeInit :: [a] -> Maybe [a]
safeInit (x:xs) = Just $ init (x:xs)
safeInit [] = Nothing
{-
splitWith_aux :: (a -> Bool) -> [a] -> [[a]] -> [[a]]
splitWith_aux fnp [] acc = []
splitWith_aux fnp (x:xs) acc = if fnp x
then splitWith_aux fnp xs
-}>>> :load "rwh/ch04/ch04.exercises.hs"
[1 of 1] Compiling Main ( rwh/ch04/ch04.exercises.hs, interpreted )
Ok, modules loaded: Main.
>>>
>>> safeHead [1, 2, 3, 4]
Just 1
>>> safeHead [1 ..]
Just 1
>>> safeHead []
Nothing
>>>
>>> safeTail [1, 2, 3, 4]
Just [2,3,4]
>>> safeTail []
Nothing
>>>
>>> safeLast [1, 2, 3, 4]
Just 4
>>> safeLast [4]
Just 4
>>> safeLast []
Nothing
>>>
>>> safeInit []
Nothing
>>> safeInit [1, 2, 3, 4, 5]
Just [1,2,3,4]
>>> safeInit [1]
Just []
>>> Page 86: file:rwh/ch04/IntParse.hs
import Data.Char (digitToInt)
asInt :: String -> Int
asInt xs = loop 0 xs
loop :: Int -> String -> Int
loop acc [] = acc
loop acc (x:xs) = let acc' = acc * 10 + digitToInt x
in loop acc' xs>>>:load rwh/ch04/IntParse.hs
[1 of 1] Compiling Main ( rwh/ch04/IntParse.hs, interpreted )
Ok, modules loaded: Main.
>>>
>>> digitToInt '9'
9
>>> digitToInt 'a'
10
>>> digitToInt 'x'
*** Exception: Char.digitToInt: not a digit 'x'
>>>
>>> asInt "33"
33
>>> asInt "100"
100
>>>
>>> :t asInt
asInt :: String -> Int
>>>
>>> asInt "not a number"
*** Exception: Char.digitToInt: not a digit 'n'
>>> data JValue = JString String
| JNumber Double
| JBool Bool
| JNull
| JObject [(String, JValue)]
| JArray [JValue]
deriving (Eq, Ord, Show)
getString :: JValue -> Maybe String
getString (JString s) = Just s
getString _ = Nothing
getBool :: JValue -> Maybe Bool
getBool (JBool b) = Just b
getBool _ = Nothing
getNumber :: JValue -> Maybe Double
getNumber (JNumber n) = Just n
getNumber _ = Nothing
getObject :: JValue -> Maybe [(String, JValue)]
getObject js = case js of
JObject xs -> Just xs
_ -> Nothing
getArray :: JValue -> Maybe [JValue]
getArray js = case js of
JArray xs -> Just xs
_ -> Nothing
isNull :: JValue -> Bool
isNull JNull = True
isNull _ = False >>> :load "rwh/ch05/SimpleJSON1.hs"
[1 of 1] Compiling Main ( rwh/ch05/SimpleJSON1.hs, interpreted )
Ok, modules loaded: Main.
>>>
>>> JString "New Jersey"
JString "New Jersey"
>>> JNumber 3.1415
JNumber 3.1415
>>> JBool False
JBool False
>>> JBool True
JBool True
>>>
>>> getString (JNumber 3)
Nothing
>>> getString (JString "Utah" )
Just "Utah"
>>>
>>> getNumber (JNumber 10.2323)
Just 10.2323
>>> getNumber (JString "Texas")
Nothing
>>>
>>> getBool (JString "Alabama")
Nothing
>>> getBool (JBool False)
Just False
>>>
>>> getArray (JArray [JString "Alabama", JNumber 102.23, JBool True])
Just [JString "Alabama",JNumber 102.23,JBool True]
>>>
>>> getObject (JObject [("Alabama", JNumber 0), ("Texas", JNumber 2), ("Nevada", JNumber 20), ("New York", JNumber 40)])
Just [("Alabama",JNumber 0.0),("Texas",JNumber 2.0),("Nevada",JNumber 20.0),("New York",JNumber 40.0)]
>>>
>>> isNull JNull
True
>>> isNull (JString "California")
False
>>>
Page: 112 - File: file:rwh/ch05/SimpleJSON2.hs
module SimpleJSON2
(
JValue (..)
, getString
, getInt
, getDouble
, getObject
, getArray
, isNull
) where
data JValue = JString String
| JNumber Double
| JBool Bool
| JNull
| JObject [(String, JValue)]
| JArray [JValue]
deriving (Eq, Ord, Show)
getString :: JValue -> Maybe String
getString (JString s) = Just s
getString _ = Nothing
getBool :: JValue -> Maybe Bool
getBool (JBool b) = Just b
getBool _ = Nothing
getNumber :: JValue -> Maybe Double
getNumber (JNumber n) = Just n
getNumber _ = Nothing
getDouble = getNumber
getObject :: JValue -> Maybe [(String, JValue)]
getObject js = case js of
JObject xs -> Just xs
_ -> Nothing
getArray :: JValue -> Maybe [JValue]
getArray js = case js of
JArray xs -> Just xs
_ -> Nothing
getInt (JNumber n) = Just (truncate n)
getInt _ = Nothing
isNull :: JValue -> Bool
isNull JNull = True
File: file:rwh/ch05/Main.hs
module Main (main) where
import SimpleJSON2
main = print (JObject [("foo", JNumber 1), ("bar", JBool False)])Compile the module:
$ alias ghc=/nix/store/fcwp5nswfq4wm4hc3c9ij8rap9dr9p3q-ghc-7.10.2/bin/ghc
# Generate only object code
#
$ ghc -c SimpleJSON2.hs
$ file SimpleJSON2.o
SimpleJSON2.o: ELF 64-bit LSB relocatable, x86-64, version 1 (SYSV), not stripped
$ file SimpleJSON2.hi
SimpleJSON2.hi: data
# Error:
#
$ ghc -o simple Main.hs SimpleJSON2.o
Linking simple ...
SimpleJSON2.o:(.data+0x0): multiple definition of `__stginit_SimpleJSON2'
./SimpleJSON2.o:(.data+0x0): first defined here
SimpleJSON2.o:(.data+0x0): multiple definition of `SimpleJSON2_isNull_closure'
./SimpleJSON2.o:(.data+0x0): first defined here
...
SimpleJSON2.o: In function `SimpleJSON2_JArray_info':
(.text+0x24f0): multiple definition of `SimpleJSON2_JArray_static_info'
./SimpleJSON2.o:(.text+0x24f0): first defined here
collect2: error: ld returned 1 exit status
# Now it works
#
$ ghc --make -o simple Main.hs
Linking simple ...
$ file simple
simple: ELF 64-bit LSB executable, x86-64, version 1 (SYSV), dynamically linked,
interpreter /nix/store/n2wxp513rr00f6hr2dy0waqahns49dch-glibc-2.21/lib/ld-linux-x86-64.so.2,
for GNU/Linux 2.6.32, not stripped
$ ./simple
JObject [("foo",JNumber 1.0),("bar",JBool False)]Page: 116 file:rwh/ch05/PutJson.hs
module PutJSON where
import Data.List (intercalate)
import SimpleJSON2
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)
-- Good Haskell style involves separating pure code from code that
-- performs I/O. (Real World Haskell)
--
putJValue :: JValue -> IO ()
putJValue v = putStrLn (renderJValue v)Page: 119 file:rwh/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 strPage: 112 file:rwh/ch07/basicio.hs
-- file: ch07/basicio.hs
main = do
putStrLn "Greetings! What is your name?"
inpStr <- getLine
putStrLn $ "Welcome to Haskell, " ++ inpStr ++ "!"
[nix-shell:~/org/wiki/rwh/ch07]$ runhaskell basicio.hs Greetings! What is your name? Julius Caesar Welcome to Haskell, Julius Caesar!
-- file: ch07/callingpure.hs
name2reply :: String -> String
name2reply name =
"Pleased to meet you, " ++ name ++ ".\n" ++
"Your name contains " ++ charcount ++ " characters."
where charcount = show (length name)
main :: IO ()
main = do
putStrLn "Greetings once again. What is your name?"
inpStr <- getLine
let outStr = name2reply inpStr
putStrLn outStr[nix-shell:~/org/wiki/rwh/ch07]$ ghci
GHCi, version 7.10.2: http://www.haskell.org/ghc/ :? for help
>>>
>>> :load
basicio.hs callingpure.hs
>>> :load callingpure.hs
[1 of 1] Compiling Main ( callingpure.hs, interpreted )
Ok, modules loaded: Main.
>>>
>>> name2reply "john"
"Pleased to meet you, john.\nYour name contains 4 characters."
>>> name2reply "julius caesar"
"Pleased to meet you, julius caesar.\nYour name contains 13 characters."
>>>
>>> putStrLn (name2reply "Julis Caesar")
Pleased to meet you, Julis Caesar.
Your name contains 12 characters.
>>>
>>> :t putStrLn (name2reply "Julis Caesar")
putStrLn (name2reply "Julis Caesar") :: IO (-- file: ch07/toupper-imp.hs
import System.IO
import Data.Char(toUpper)
main :: IO ()
main = do
inh <- openFile "/etc/issue" ReadMode
outh <- openFile "/tmp/issue.out" 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
[nix-shell:~/org/wiki/rwh/ch07]$ runhaskell toupper-imp.hs [nix-shell:~/org/wiki/rwh/ch07]$ cat /etc/issue Arch Linux \r (\l) [nix-shell:~/org/wiki/rwh/ch07]$ cat /tmp/issue.out ARCH LINUX \R (\L)
Page 175 file:rwh/ch07/tempfile.hs
The code tempfile.hs failed to run and had to be changed to run in Haskell 7.10.2.
-- file: ch07/tempfile.hs
import System.IO
import System.Directory (getTemporaryDirectory, removeFile)
--import System.IO.Error (catch)
import Control.Exception (catch, finally, IOException)
-- 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
getTempdir :: IO String
getTempdir = catch getTemporaryDirectory handler
where
handler :: IOException -> IO String
handler = \ _ -> return "."
{- 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).
{- Note: It doesn't work anymore in Haskell 7.10.2 -}
{- tempdir <- catch (getTemporaryDirectory) (\_ -> return ".") -}
tempdir <- getTempdir
(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)$ > runhaskell tempfile.hs Welcome to tempfile.hs I have a temporary file at /run/user/1000/mytemp1804289383846930886.txt My initial position is 0 Writing one line containing 22 bytes: [1,2,3,4,5,6,7,8,9,10] After writing, my new position is 23 The file content is: [1,2,3,4,5,6,7,8,9,10] Which could be expressed as this Haskell literal: "[1,2,3,4,5,6,7,8,9,10]\n"
IO actions can be passed as values, stored in data structures and passed to another IO actions. They won’t do anything until invoked (called from the action main).
-- file: ch07/actions.hs
str2action :: String -> IO ()
str2action input = putStrLn ("Data: " ++ input)
list2actions :: [String] -> [IO ()]
list2actions = map str2action
numbers :: [Int]
numbers = [1..10]
strings :: [String]
strings = map show numbers
actions :: [IO ()]
actions = list2actions strings
printitall :: IO ()
printitall = runall actions
-- Take a list of actions, and execute each of them in turn.
runall :: [IO ()] -> IO ()
runall [] = return ()
runall (firstelem:remainingelems) =
do firstelem
runall remainingelems
main = do str2action "Start of the program"
printitall
str2action "Done!"$ > runhaskell actions.hs Data: Start of the program Data: 1 Data: 2 Data: 3 Data: 4 Data: 5 Data: 6 Data: 7 Data: 8 Data: 9 Data: 10 Data: Done! $ >
-- file: ch07/actions2.hs
str2message :: String -> String
str2message input = "Data: " ++ input
str2action :: String -> IO ()
str2action = putStrLn . str2message
numbers :: [Int]
numbers = [1..10]
main = do str2action "Start of the program"
mapM_ (str2action . show) numbers
str2action "Done!"
$ > runhaskell actions2.hs Data: Start of the program Data: 1 Data: 2 Data: 3 Data: 4 Data: 5 Data: 6 Data: 7 Data: 8 Data: 9 Data: 10 Data: Done!
Page 187 file:rwh/ch07/basicio-nodo.hs
-- file: ch07/basicio-nodo.hs
main =
putStrLn "Greetings! What is your name?" >>
getLine >>=
(\inpStr -> putStrLn $ "Welcome to Haskell, " ++ inpStr ++ "!") $ > runhaskell basicio-nodo.hs Greetings! What is your name? Julius Caesar Welcome to Haskell, Julius Caesar!
Page: 187 file:rwh/ch07/return1.hs
-- file: ch07/return1.hs
import Data.Char(toUpper)
isGreen :: IO Bool
isGreen =
do putStrLn "Is green your favorite color?"
inpStr <- getLine
return ((toUpper . head $ inpStr) == 'Y')$ > ghci
GHCi, version 7.10.2: http://www.haskell.org/ghc/ :? for help
>>>
>>> :load return1.hs
[1 of 1] Compiling Main ( return1.hs, interpreted )
Ok, modules loaded: Main.
>>>
>>> :t isGreen
isGreen :: IO Bool
>>>
>>> isGreen
Is green your favorite color?
Y
True
>>> isGreen
Is green your favorite color?
N
False
>>>
Page: 187 file:rwh/ch07/return2.hs
-- file: ch07/return2.hs
import Data.Char(toUpper)
isYes :: String -> Bool
isYes inpStr = (toUpper . head $ inpStr) == 'Y'
isGreen :: IO Bool
isGreen =
do putStrLn "Is green your favorite color?"
inpStr <- getLine
return (isYes inpStr)>>> :load return2.hs
[1 of 1] Compiling Main ( return2.hs, interpreted )
Ok, modules loaded: Main.
>>>
>>> isGreen
Is green your favorite color?
Y
True
>>> isGreen
Is green your favorite color?
N
False
>>>
Page: 187 file:rwh/ch07/return3.hs
-- file: ch07/return3.hs
returnTest :: IO ()
returnTest =
do one <- return 1
let two = 2
putStrLn $ show (one + two)
main :: IO ()
main = returnTest Running in batch mode:
> runhaskell return3.hs 3 >
Running in ghci:
$ > ghci
GHCi, version 7.10.2: http://www.haskell.org/ghc/ :? for help
>>>
>>> :load return3.hs
[1 of 1] Compiling Main ( return3.hs, interpreted )
Ok, modules loaded: Main.
>>>
>>> :t returnTest
returnTest :: IO ()
>>>
>>> return
return returnTest
>>> returnTest
3
>>> :t returnTest
returnTest :: IO ()
>>>
Page 194. file:rwh/ch08/ElfMagic.hs
This function tests if the file is a Unix ELF executable that are recognized by its magic number which is a initial unique set of bytes that identify the file. Unlike Windows, Unix like OS recognizes the file formats by its magic number.
See also:
- Magic number (programming) - Wikipedia, the free encyclopedia
- Executable and Linkable Format - Wikipedia, the free encyclopedia
import qualified Data.ByteString.Lazy as L
hasElfMagic :: L.ByteString -> Bool
hasElfMagic content = L.take 4 content == elfMagic
where elfMagic = L.pack [0x7f, 0x45, 0x4c, 0x46]
isElfFile :: FilePath -> IO Bool
isElfFile path = do
content <- L.readFile path
return (hasElfMagic content)GHCi, version 7.10.2: http://www.haskell.org/ghc/ :? for help
>>>
>>> :load "ch08/ElfMagic.hs"
[1 of 1] Compiling Main ( ch08/ElfMagic.hs, interpreted )
Ok, modules loaded: Main.
>>>
>>> :t hasElfMagic
hasElfMagic :: L.ByteString -> Bool
>>>
>>>
>>> file <- L.readFile "/bin/sh"
>>> :t file
file :: L.ByteString
>>>
>>> hasElfMagic file
True
>>> L.take 10 file
"\DELELF\STX\SOH\SOH\NUL\NUL\NUL"
>>>
>>> file <- L.readFile "/etc/issue"
>>> file
"Arch Linux \\r (\\l)\n\n"
>>> hasElfMagic file
False
>>>
>>> import qualified System.Directory as SD
>>> :t isElfFile
isElfFile :: FilePath -> IO Bool
>>>
>>> isElfFile "/bin/sh"
True
>>> isElfFile "/etc/fstab"
False
>>>
>>> SD.setCurrentDirectory "/bin"
>>> SD.getCurrentDirectory
"/usr/bin"
>>>
>>> files <- SD.getDirectoryContents "/bin"
>>> :t files
files :: [FilePath]
>>>
>>> take 4 files
[".","..","install-info","update-desktop-database"]
>>>
>>> let flist = drop 2 files
>>> take 4 flist
["install-info","update-desktop-database","libinput-list-devices","visudo"]
>>>
>>> :t isElfFile
isElfFile :: FilePath -> IO Bool
>>>
>>> :t filter
filter :: (a -> Bool) -> [a] -> [a]
>>>
>>> filter isElfFile flist
<interactive>:83:8:
Couldn't match type ‘IO Bool’ with ‘Bool’
Expected type: FilePath -> Bool
Actual type: FilePath -> IO Bool
In the first argument of ‘filter’, namely ‘isElfFile’
In the expression: filter isElfFile flist
>>>
>>> import Control.Monad (filterM)
>>> :t filterM
filterM :: Monad m => (a -> m Bool) -> [a] -> m [a]
>>>
>>> filesOnly <- filterM SD.doesFileExist flist
>>>
>>> take 4 filesOnly
["install-info","update-desktop-database","libinput-list-devices","visudo"]
>>>
>>> filterM isElfFile (take 30 filesOnly ) >>= mapM_ putStrLn
install-info
update-desktop-database
libinput-list-devices
visudo
suexec
jack_wait
dirname
j2k_dump
json-glib-format
runlevel
chacl
eu-addr2line
c++
git
gcov
ionice
lircd
...Page 196. file:rwh/ch08/HighestClose.hs
import qualified Data.ByteString.Lazy.Char8 as L
closing = readPrice . (!!4) . L.split ','
readPrice :: L.ByteString -> Maybe Int
readPrice str =
case L.readInt str of
Nothing -> Nothing
Just (dollars,rest) ->
case L.readInt (L.tail rest) of
Nothing -> Nothing
Just (cents,more) ->
Just (dollars * 100 + cents)
highestClose = maximum . (Nothing:) . map closing . L.lines
highestCloseFrom path = do
contents <- L.readFile path
print (highestClose contents)
File: file:rwh/ch08/prices.csv
Date,Open,High,Low,Close,Volume,Adj Close
2008-08-01,20.09,20.12,19.53,19.80,19777000,19.80
2008-06-30,21.12,21.20,20.60,20.66,17173500,20.66
2008-05-30,27.07,27.10,26.63,26.76,17754100,26.76
2008-04-30,27.17,27.78,26.76,27.41,30597400,27.41
>>> :load "rwh/ch08/HighestClose.hs"
[1 of 1] Compiling Main ( rwh/ch08/HighestClose.hs, interpreted )
Ok, modules loaded: Main.
>>>
>>> highestCloseFrom "rwh/ch08/prices.csv"
Just 2741
>>>
>>> contents <- L.readFile "rwh/ch08/prices.csv"
>>> :t contents
contents :: L.ByteString
>>>
-- The output was formatted manually to fit in the
-- screen.
--
>>> tail $ L.lines contents
["2008-08-01,20.09,20.12,19.53,19.80,19777000,19.80",
"2008-06-30,21.12,21.20,20.60,20.66,17173500,20.66",
"2008-05-30,27.07,27.10,26.63,26.76,17754100,26.76",
"2008-04-30,27.17,27.78,26.76,27.41,30597400,27.41"]
>>>
>>> mapM_ (\ x -> putStrLn (show x)) $ tail $ L.lines contents
"2008-08-01,20.09,20.12,19.53,19.80,19777000,19.80"
"2008-06-30,21.12,21.20,20.60,20.66,17173500,20.66"
"2008-05-30,27.07,27.10,26.63,26.76,17754100,26.76"
"2008-04-30,27.17,27.78,26.76,27.41,30597400,27.41"
>>>
>>> mapM_ (\ x -> putStrLn (show x)) $ map (L.split ',') $ tail $ L.lines contents
["2008-08-01","20.09","20.12","19.53","19.80","19777000","19.80"]
["2008-06-30","21.12","21.20","20.60","20.66","17173500","20.66"]
["2008-05-30","27.07","27.10","26.63","26.76","17754100","26.76"]
["2008-04-30","27.17","27.78","26.76","27.41","30597400","27.41"]
>>>
-- Adj close
--
>>> map (!!4) $ map (L.split ',') $ tail $ L.lines contents
["19.80","20.66","26.76","27.41"]
>>>
-- Optmization with function composition
--
>>> map ( (!!4) . L.split ',') $ tail $ L.lines contents
["19.80","20.66","26.76","27.41"]
>>>
>>> map ( (!!4) . L.split ',') . tail . L.lines $ contents
["19.80","20.66","26.76","27.41"]
>>>
>>> let readLByteStringMaybe = readMaybe . L.unpack
>>> :t readLByteStringMaybe
readLByteStringMaybe :: Read a => L.ByteString -> Maybe a
>>>
>>> map (\x -> readLByteStringMaybe x :: Maybe Double) $ map ( (!!4) . L.split ',') . tail . L.lines $ contents
[Just 19.8,Just 20.66,Just 26.76,Just 27.41]
>>>
>>> map ((\x -> readLByteStringMaybe x :: Maybe Double) . (!!4) . L.split ',') . tail . L.lines $ contents
[Just 19.8,Just 20.66,Just 26.76,Just 27.41]
>>>
-- If any number fail to be parsed the whole column will fail,
-- it will return Nothing
--
>>> sequence $ map ((\x -> readLByteStringMaybe x :: Maybe Double) . (!!4) . L.split ',') . tail . L.lines $ contents
Just [19.8,20.66,26.76,27.41]
>>>
>>> fmap sum $ sequence $ map ((\x -> readLByteStringMaybe x :: Maybe Double) . (!!4) . L.split ',') . tail . L.lines $ contents
Just 94.63
>>>
>>> let parseColumnDouble n = sequence . map ((\x -> readLByteStringMaybe x :: Maybe Double) . (!!n) . L.split ',') . tail . L.lines
>>>
>>> :t parseColumnDouble
parseColumnDouble :: Int -> L.ByteString -> Maybe [Double]
>>>
--- Multiline function composition
---
---
---
:set +m -- Allow multi line paste in the repl.
:{
let parseColumnDouble n =
sequence
. map ((\x -> readLByteStringMaybe x :: Maybe Double)
. (!!n)
. L.split ','
)
. tail
. L.lines
:}
>>> parseColumnDouble 0 contents
Nothing
>>> parseColumnDouble 1 contents
Just [20.09,21.12,27.07,27.17]
>>> parseColumnDouble 2 contents
Just [20.12,21.2,27.1,27.78]
>>> parseColumnDouble 3 contents
Just [19.53,20.6,26.63,26.76]
>>> parseColumnDouble 4 contents
Just [19.8,20.66,26.76,27.41]
-- Year
--
>>> map (!!0) $ map (L.split ',') $ tail $ L.lines contents
["2008-08-01","2008-06-30","2008-05-30","2008-04-30"]
>>>
>>> Page 246 - File: file:rwh/ch10/PNM.hs
import qualified Data.ByteString.Lazy.Char8 as L8
import qualified Data.ByteString.Lazy as L
import Data.Char (isSpace)
data Greymap = Greymap {
greyWidth :: Int
, greyHeight :: Int
, greyMax :: Int
, greyData :: L.ByteString
} deriving (Eq)
instance Show Greymap where
show (Greymap w h m _) = "Greymap " ++ show w ++ "x" ++ show h ++
" " ++ show m
parseP5 :: L.ByteString -> Maybe (Greymap, L.ByteString)
parseP5 s =
case matchHeader (L8.pack "P5") s of
Nothing -> Nothing
Just s1 ->
case getNat s1 of
Nothing -> Nothing
Just (width, s2) ->
case getNat (L8.dropWhile isSpace s2) of
Nothing -> Nothing
Just (height, s3) ->
case getNat (L8.dropWhile isSpace s3) of
Nothing -> Nothing
Just (maxGrey, s4)
| maxGrey > 255 -> Nothing
| otherwise ->
case getBytes 1 s4 of
Nothing -> Nothing
Just (_, s5) ->
case getBytes (width * height) s5 of
Nothing -> Nothing
Just (bitmap, s6) ->
Just (Greymap width height maxGrey bitmap, s6)
matchHeader :: L.ByteString -> L.ByteString -> Maybe L.ByteString
matchHeader prefix str
| prefix `L8.isPrefixOf` str
= Just (L8.dropWhile isSpace (L.drop (L.length prefix) str))
| otherwise
= Nothing
getNat :: L.ByteString -> Maybe (Int, L.ByteString)
getNat s = case L8.readInt s of
Nothing -> Nothing
Just (num,rest)
| num <= 0 -> Nothing
| otherwise -> Just (fromIntegral num, rest)
getBytes :: Int -> L.ByteString -> Maybe (L.ByteString, L.ByteString)
getBytes n str = let count = fromIntegral n
both@(prefix,_) = L.splitAt count str
in if L.length prefix < count
then Nothing
else Just both
>>> :load "rwh/ch10/PNM.hs"
[1 of 1] Compiling Main ( rwh/ch10/PNM.hs, interpreted )
Ok, modules loaded: Main.
>>>
>>> content <- L.readFile "rwh/ch10/bird.pgm"
>>>
>>> L.take 30 content
"P5\n321 481\n255\n4`oxyrxvuuuuuuu"
>>>
>>> parseP5 content
Just (Greymap 321x481 255,"")
>>> Test files:
- file:rwh/ch10/bird.pgm
- rwh/ch10/bird.png
file:rwh/ch10/bird.png
Page 240; 250 - File: file:rwh/ch10/Parse.hs
import qualified Data.ByteString.Lazy.Char8 as L8
import qualified Data.ByteString.Lazy as L
import Data.Word (Word8)
import Data.Int (Int64)
import Data.Char (chr, isDigit, isSpace)
import Control.Applicative ((<$>))
data ParseState = ParseState {
string :: L.ByteString
, offset :: Int64 -- imported from Data.Int
} deriving (Show)
simpleParse :: ParseState -> (a, ParseState)
simpleParse = undefined
betterParse :: ParseState -> Either String (a, ParseState)
betterParse = undefined
newtype Parse a = Parse {
runParse :: ParseState -> Either String (a, ParseState)
}
identity :: a -> Parse a
identity a = Parse (\s -> Right (a, s))
parse :: Parse a -> L.ByteString -> Either String a
parse parser initState
= case runParse parser (ParseState initState 0) of
Left err -> Left err
Right (result, _) -> Right result
modifyOffset :: ParseState -> Int64 -> ParseState
modifyOffset initState newOffset =
initState { offset = newOffset }
getState :: Parse ParseState
getState = Parse (\s -> Right (s, s))
putState :: ParseState -> Parse ()
putState s = Parse (\_ -> Right ((), s))
bail :: String -> Parse a
bail err = Parse $ \s -> Left $
"byte offset " ++ show (offset s) ++ ": " ++ err
(==>) :: Parse a -> (a -> Parse b) -> Parse b
firstParser ==> secondParser = Parse chainedParser
where chainedParser initState =
case runParse firstParser initState of
Left errMessage ->
Left errMessage
Right (firstResult, newState) ->
runParse (secondParser firstResult) newState
parseByte :: Parse Word8
parseByte =
getState ==> \initState ->
case L.uncons (string initState) of
Nothing ->
bail "no more input"
Just (byte,remainder) ->
putState newState ==> \_ ->
identity byte
where newState = initState { string = remainder,
offset = newOffset }
newOffset = offset initState + 1
instance Functor Parse where
fmap f parser = parser ==> \result ->
identity (f result)
w2c :: Word8 -> Char
w2c = chr . fromIntegral
parseChar :: Parse Char
parseChar = w2c <$> parseByte
peekByte :: Parse (Maybe Word8)
peekByte = (fmap fst . L.uncons . string) <$> getState
peekChar :: Parse (Maybe Char)
peekChar = fmap w2c <$> peekByte
parseWhile :: (Word8 -> Bool) -> Parse [Word8]
parseWhile p = (fmap p <$> peekByte) ==> \mp ->
if mp == Just True
then parseByte ==> \b ->
(b:) <$> parseWhile p
else identity []
parseWhileVerbose p =
peekByte ==> \mc ->
case mc of
Nothing -> identity []
Just c | p c ->
parseByte ==> \b ->
parseWhileVerbose p ==> \bs ->
identity (b:bs)
| otherwise ->
identity []
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
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>>> :load "rwh/ch10/Parse.hs"
[1 of 1] Compiling Main ( rwh/ch10/Parse.hs, interpreted )
Ok, modules loaded: Main.
>>>
>>> :t identity
identity :: a -> Parse a
>>>
>>> :info Parse
newtype Parse a
= Parse {runParse :: ParseState -> Either String (a, ParseState)}
-- Defined at rwh/ch10/Parse.hs:18:1
>>>
>>>
>>> :type parse (identity 1) undefined
parse (identity 1) undefined :: Num a => Either String a
>>> parse (identity 1) undefined
Right 1
>>>
>>>
>>> parse (identity "foo") undefined
Right "foo"
>>>
>>> let before = ParseState (L8.pack "foo") 0
>>> before
ParseState {string = "foo", offset = 0}
>>>
>>> let after = modifyOffset before 3
>>> after
ParseState {string = "foo", offset = 3}
>>>
>>> :t L8.uncons
L8.uncons :: L.ByteString -> Maybe (Char, L.ByteString)
>>>
>>> :t L8.pack
L8.pack :: [Char] -> L.ByteString
>>>
>>> L8.pack "foo"
"foo"
>>> :t L8.pack "foo"
L8.pack "foo" :: L.ByteString
>>>
>>> L8.uncons $ L8.pack "foo"
Just ('f',"oo")
>>> L8.uncons $ L8.empty
Nothing
>>>
>>> :t runParse
runParse :: Parse a -> ParseState -> Either String (a, ParseState)
>>>
>>> :t parse
parse :: Parse a -> L.ByteString -> Either String a
-- 0xff = 255
--
>>> parse parseByte (L8.pack "\xff")
Right 255
>>>
>>> parse parseByte (L8.pack "\xa")
Right 10
>>> parse parseByte (L8.pack "\xb")
Right 11
>>> parse parseByte (L8.pack "")
Left "byte offset 0: no more input"
>>>
-- 0xfa = 16 * 15 + 10 = 250 decimal
--
--
>>> runParse parseByte $ ParseState (L8.pack "\xfa") 0
Right (250,ParseState {string = "", offset = 1})
>>>
>>> runParse parseByte $ ParseState (L8.pack "x9023") 1
Right (120,ParseState {string = "9023", offset = 2})
>>>
>>> runParse parseByte $ ParseState (L8.pack "") 1
Left "byte offset 1: no more input"
>>>
>>> let input = L8.pack "foo"
>>> :t input
input :: L.ByteString
>>>
>>> L.head input
102
>>> parse parseByte input
Right 102
>>>
>>> parse (id <$> parseByte) input
Right 102
>>> parse ((*2) <$> parseByte) input
Right 204
>>>
>>> parse parseNat (L8.pack "10023 asdb")
Right 10023
>>> parse parseNat (L8.pack "sad10023 asdb")
Left "byte offset 0: no more input"
>>>
>>> parse parseChar (L8.pack "23")
Right '2'
>>> parse parseChar (L8.pack "")
Left "byte offset 0: no more input"
>>>
Page: 244 - File: file:rwh/ch10/TreeMap.hs
data Tree a = Node (Tree a) (Tree a)
| Leaf a
deriving (Show)
treeLengths (Leaf s) = Leaf (length s)
treeLengths (Node l r) = Node (treeLengths l) (treeLengths r)
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)
{-
class Functor f where
fmap :: (a -> b) -> f a -> f b
-}
instance Functor Tree where
fmap = treeMap
>>> fmap length (Node (Leaf "North Carolina") (Leaf "Puerto Rico"))
Node (Leaf 14) (Leaf 11)
>>>
>>> fmap id (Node (Leaf "a") (Leaf "b"))
Node (Leaf "a") (Leaf "b")
>>> >>> :load "rwh/ch10/TreeMap.hs"
[1 of 1] Compiling Main ( rwh/ch10/TreeMap.hs, interpreted )
Ok, modules loaded: Main.
>>>
>>> :info Tree
data Tree a = Node (Tree a) (Tree a) | Leaf a
-- Defined at rwh/ch10/TreeMap.hs:2:1
instance Show a => Show (Tree a)
-- Defined at rwh/ch10/TreeMap.hs:4:25
>>>
>>> let tree = Node (Leaf "foo") (Node (Leaf "x") (Leaf "quux"))
>>> :t tree
tree :: Tree [Char]
>>>
>>> treeLengths tree
Node (Leaf 3) (Node (Leaf 1) (Leaf 4))
>>>
>>> treeMap (odd . length) tree
Node (Leaf True) (Node (Leaf True) (Leaf False))
>>>
Page 367 - File: file:rwh/ch14/Maybe.hs
-- file: ch14/Maybe.hs
data Maybe a = Nothing | Just a
instance Monad Maybe where
-- chain
(>>=) :: Maybe a -> (a -> Maybe b) -> Maybe b
Just x >>= fn = fn x
Nothing >>= fn = Nothing
-- inject
return :: a -> Maybe a
return a = Just a
---
(>>) :: Maybe a -> Maybe b -> Maybe b
Just _ >> mb = mb
Nothing >> mb = Nothing
fail _ = Nothing
{- Function that executes the Maybe monad. If the computation
fails the third parameter is Nothing it returns the value n,
on the other hand if the computation succeeds the third
parameter is (Just x) it applies the function (a -> b) to the
value x wrapped in the monad.
-}
maybe :: b -> (a -> b ) -> Maybe a -> b
maybe n _ Nothing = n
maybe _ f (Just x) = f x
Page: 343. File: file:rwh/ch14/MultiplyTo.hs
guarded :: Bool -> [a] -> [a]
guarded True xs = xs
guarded False _ = []
multiplyTo :: Int -> [(Int, Int)]
multiplyTo n = do
x <- [1..n]
y <- [x..n]
guarded (x * y == n) $
return (x, y)
>>> :load ch14/MultiplyTo.hs
[1 of 1] Compiling Main ( ch14/MultiplyTo.hs, interpreted )
Ok, modules loaded: Main.
>>>
>>> :t multiplyTo
multiplyTo :: Int -> [(Int, Int)]
>>>
>>> multiplyTo 8
[(1,8),(2,4)]
>>>
>>> multiplyTo 100
[(1,100),(2,50),(4,25),(5,20),(10,10)]
>>>
>>> multiplyTo 891
[(1,891),(3,297),(9,99),(11,81),(27,33)]
>>>
>>> multiplyTo 1000
[(1,1000),(2,500),(4,250),(5,200),(8,125),(10,100),(20,50),(25,40)]
>>> Page: 347 - File: file:rwh/ch14/SimpleState.hs
-- file: ch14/SimpleState.hs
{-
This function transforms one state into another yielding
a result (output). The state monad is also called
State Transformer Monad.
s : Type of state
a : Type of state output
s -> (a, s) : State transformer function
:: SimpleState s a :: SimpleState s a
|-------------| |-------------|
State 0 | | State 1 | | State 2
---> | a -> (a, s) | ------> | a -> (a, s) | ------->
|-------------| |-------------|
| |
| |
\ / Output 1: a \ / Output 2: a
-}
type SimpleState s a = s -> (a, s)
-- A type can be partially applied. The type constructor is:
-- SimpleState s
--
type StringState a = SimpleState String a
returnSt :: a -> SimpleState s a
returnSt a = \s -> (a, s)
returnAlt :: a -> SimpleState s a
returnAlt a s = (a, s)
bindSt :: (SimpleState s a) -> (a -> SimpleState s b) -> SimpleState s b
bindSt m fn = \s -> let (a, s') = m s
in (fn a) s'
{-
A more readable version of bindSt
-- m == step
-- k == makeStep
-- s == oldState
-}
bindAlt :: (SimpleState s a) -> (a -> SimpleState s b) -> SimpleState s b
bindAlt step makeStep oldState =
let (result, newState) = step oldState
in (makeStep result) newState
{- Get current state and returens it as result -}
getSt :: SimpleState s s
getSt = \s -> (s, s)
{- Set current state and ignore the current one. -}
putSt :: s -> SimpleState s ()
putSt s = \_ -> ((), s)
>>> :load ch14/SimpleState.hs
[1 of 1] Compiling Main ( ch14/SimpleState.hs, interpreted )
Ok, modules loaded: Main.
>>>
>>> :set +m
>>>
-- It can be pasted in Ghci
--
-- The current state is n, the next state is
-- n + 1, the state output is 2 * n
--
{-
|---------| |----------| |----------| |---------|
--->| stateFn |----> | stateFn |-----> | stateFn |---->| stateFn |-->
1 |---------| 2 |----------| 3 |----------| 4 |---------| 5 ...
| | | |
| | | |
\ / \ / \ / \ /
output = 2 output = 4 output = 6 output = 8
-}
:{
let stateFn :: SimpleState Int Int
stateFn n = (2 * n, n + 1)
:}
>>> :t stateFn
stateFn :: SimpleState Int Int
>>>
>>> stateFn 1
(2,2)
>>> stateFn 2
(4,3)
>>> stateFn 3
(6,4)
>>> stateFn 4
(8,5)
>>> stateFn 5
(10,6)
>>> stateFn 6
(12,7)
>>>
>>> :t returnSt 10
returnSt 10 :: Num a => SimpleState s a
>>>
>>> (returnSt 10) 3
(10,3)
>>> (returnSt 20) 4
(20,4)
>>> (returnSt 12) 5
(12,5)
>>>
>>> getSt 3
(3,3)
>>>
>>> getSt 10
(10,10)
>>>
>>> (putSt 3) 4
((),3)
>>> (putSt 3) 4
((),3)
>>> (putSt 3) 5
((),3)
>>> (putSt 3) 10
((),3)
>>>
Page: 349 - File: file:rwh/ch14/State.hs
{-
Applies a state transformer to a state and returns a new state
yielding a result.
runState :: State s a -> s -> (a, s)
-}
newtype State s a = State { runState :: s -> (a, s) }
returnState :: a -> State s a
returnState a = State ( \s -> (a, s) )
bindState :: State s a -> (a -> State s b) -> State s b
bindState m fn = State $ \s -> let (a, s') = runState m s
in runState (fn a) s'
-- evalState : Returns only the result, throwing away the final state
--
evalState :: State s a -> s -> a
evalState fn s = fst (runState fn s)
-- execState : Throws the result away, returning only the final state
execState :: State s a -> s -> s
execState fn s = snd (runState fn s)
get :: State s s
get = State (\s -> (s, s))
put :: s -> State s ()
put s = State (\ _ -> ((), s))
{- State Monad Evaluation Functions -}
-- runState : Returns both the result and the final state
{- State Monad Evaluation Functions -}
-- runState : Returns both the result and the final state
{-
Applies a function to the result of the
state transformer (state monad) application
keeping the current state.
-}
instance Functor (State s) where
{- fmap :: (a -> b) -> F a -> F b -}
--
-- fmap :: (a -> b) -> State s a -> State s b
fmap f fns =
State $ \oldState -> let (output, newState) = runState fns oldState
in (f output, newState)
instance Applicative (State s) where
pure = returnState
--
-- (<*>) :: State s (a -> b) -> State s a -> State s b
--
-- fsa :: State s a
--
-- fn :: State s (a -> b)
--
-- output :: a
-- newState :: s
--
-- f_a_to_b :: a -> b
-- newState' :: s
--
fn <*> fsa = State $ \ oldState ->
let (output, newState) = runState fsa oldState in
let (f_a_to_b, newState') = runState fn newState in
(f_a_to_b output, newState')
instance Monad (State s) where
-- return :: a -> State s a
--
return a = State $ \s -> (a, s)
-- (>>=) :: State s a -> (a -> State s b) -> State s b
--
-- StateFn :: State s a
--
-- stateMaker :: a -> State s b
--
-- result :: a
--
-- newState :: s
--
--
--
stateFn >>= stateMaker =
State $ \oldState -> let (result, newState) = runState stateFn oldState
in runState (stateMaker result) newState
>>> :load ch14/State.hs
[1 of 1] Compiling Main ( ch14/State.hs, interpreted )
Ok, modules loaded: Main.
>>>
>>> :set +m
>>>
>>> let stateFn1 = State (\x -> (2 * x, x + 1)) :: State Int Int
>>> :t stateFn1
stateFn1 :: State Int Int
>>>
>>> runState stateFn1 0
(0,1)
>>> runState stateFn1 1
(2,2)
>>> runState stateFn1 2
(4,3)
>>> runState stateFn1 3
(6,4)
>>> runState stateFn1 4
(8,5)
>>> runState stateFn1 5
(10,6)
>>>
>>> runState (fmap (*2) stateFn1) 0
(0,1)
>>> runState (fmap (*2) stateFn1) 1
(4,2)
>>> runState (fmap (*2) stateFn1) 2
(8,3)
>>> runState (fmap (*2) stateFn1) 3
(12,4)
>>> runState (fmap (*2) stateFn1) 4
(16,5)
>>> runState (fmap (*2) stateFn1) 5
(20,6)
>>>
{- stateFn in monadic notation
This block can be copied in the repl.
-}
:{
let stateFn2 :: State Int Int
stateFn2 = do
sc <- get
put (sc + 1)
return $ 2 * sc
:}
>>> :t stateFn2
stateFn2 :: State Int Int
>>>
>>> runState stateFn2 0
(0,1)
>>> runState stateFn2 1
(2,2)
>>> runState stateFn2 2
(4,3)
>>> runState stateFn2 3
(6,4)
>>> runState stateFn2 4
(8,5)
>>> runState stateFn2 5
(10,6)
>>>
{- stateFn3 -}
:{
let stateFn3 :: State Int Int
stateFn3 =
get >>= \ sc ->
put (sc + 1) >>= \_ ->
return (2 * sc)
:}
>>> runState stateFn3 0
(0,1)
>>> runState stateFn3 1
(2,2)
>>> runState stateFn3 2
(4,3)
>>> runState stateFn3 3
(6,4)
>>> runState stateFn3 4
(8,5)
>>> runState stateFn3 5
(10,6)
>>>
>>> runState (replicateM 10 stateFn3) 0
([18,16,14,12,10,8,6,4,2,0],10)
>>>
>>> runState (replicateM 0 stateFn3) 0
([],0)
>>> runState (replicateM 1 stateFn3) 0
([0],1)
>>> runState (replicateM 2 stateFn3) 0
([2,0],2)
>>> runState (replicateM 3 stateFn3) 0
([4,2,0],3)
>>> runState (replicateM 4 stateFn3) 0
([6,4,2,0],4)
>>> runState (replicateM 10 stateFn3) 0
([18,16,14,12,10,8,6,4,2,0],10)
>>>
>>> runState ((\x -> x + 3) <$> stateFn3) 0
(3,1)
>>> runState ((\x -> x + 3) <$> stateFn3) 1
(5,2)
>>> runState ((\x -> x + 3) <$> stateFn3) 2
(7,3)
>>> runState ((\x -> x + 3) <$> stateFn3) 3
(9,4)
>>> runState ((\x -> x + 3) <$> stateFn3) 4
(11,5)
>>>
Page 611 - File: file:rwh/ch27/syslogclient.hs
-- file: ch27/syslogclient.hs
import Data.Bits
import Network.Socket
import Network.BSD
import Data.List
import SyslogTypes
data SyslogHandle =
SyslogHandle {slSocket :: Socket,
slProgram :: String,
slAddress :: SockAddr}
openlog :: HostName -- ^ Remote hostname, or localhost
-> String -- ^ Port number or name; 514 is default
-> String -- ^ Name to log under
-> IO SyslogHandle -- ^ Handle to use for logging
openlog hostname port progname =
do -- Look up the hostname and port. Either raises an exception
-- or returns a nonempty list. First element in that list
-- is supposed to be the best option.
addrinfos <- getAddrInfo Nothing (Just hostname) (Just port)
let serveraddr = head addrinfos
-- Establish a socket for communication
sock <- socket (addrFamily serveraddr) Datagram defaultProtocol
-- Save off the socket, program name, and server address in a handle
return $ SyslogHandle sock progname (addrAddress serveraddr)
syslog :: SyslogHandle -> Facility -> Priority -> String -> IO ()
syslog syslogh fac pri msg =
sendstr sendmsg
where code = makeCode fac pri
sendmsg = "<" ++ show code ++ ">" ++ (slProgram syslogh) ++
": " ++ msg
-- Send until everything is done
sendstr :: String -> IO ()
sendstr [] = return ()
sendstr omsg = do sent <- sendTo (slSocket syslogh) omsg
(slAddress syslogh)
sendstr (genericDrop sent omsg)
closelog :: SyslogHandle -> IO ()
closelog syslogh = sClose (slSocket syslogh)
{- | Convert a facility and a priority into a syslog code -}
makeCode :: Facility -> Priority -> Int
makeCode fac pri =
let faccode = codeOfFac fac
pricode = fromEnum pri
in
(faccode `shiftL` 3) .|. pricode
File: file:rwh/ch27/SyslogTypes.hs
module SyslogTypes where
{- | Priorities define how important a log message is. -}
data Priority =
DEBUG -- ^ Debug messages
| INFO -- ^ Information
| NOTICE -- ^ Normal runtime conditions
| WARNING -- ^ General Warnings
| ERROR -- ^ General Errors
| CRITICAL -- ^ Severe situations
| ALERT -- ^ Take immediate action
| EMERGENCY -- ^ System is unusable
deriving (Eq, Ord, Show, Read, Enum)
{- | Facilities are used by the system to determine where messages
are sent. -}
data Facility =
KERN -- ^ Kernel messages
| USER -- ^ General userland messages
| MAIL -- ^ E-Mail system
| DAEMON -- ^ Daemon (server process) messages
| AUTH -- ^ Authentication or security messages
| SYSLOG -- ^ Internal syslog messages
| LPR -- ^ Printer messages
| NEWS -- ^ Usenet news
| UUCP -- ^ UUCP messages
| CRON -- ^ Cron messages
| AUTHPRIV -- ^ Private authentication messages
| FTP -- ^ FTP messages
| LOCAL0
| LOCAL1
| LOCAL2
| LOCAL3
| LOCAL4
| LOCAL5
| LOCAL6
| LOCAL7
deriving (Eq, Show, Read)
facToCode = [
(KERN, 0),
(USER, 1),
(MAIL, 2),
(DAEMON, 3),
(AUTH, 4),
(SYSLOG, 5),
(LPR, 6),
(NEWS, 7),
(UUCP, 8),
(CRON, 9),
(AUTHPRIV, 10),
(FTP, 11),
(LOCAL0, 16),
(LOCAL1, 17),
(LOCAL2, 18),
(LOCAL3, 19),
(LOCAL4, 20),
(LOCAL5, 21),
(LOCAL6, 22),
(LOCAL7, 23)
]
codeToFac = map (\(x, y) -> (y, x)) facToCode
{- | We can't use enum here because the numbering is discontiguous -}
codeOfFac :: Facility -> Int
codeOfFac f = case lookup f facToCode of
Just x -> x
_ -> error $ "Internal error in codeOfFac"
facOfCode :: Int -> Facility
facOfCode f = case lookup f codeToFac of
Just x -> x
_ -> error $ "Invalid code in facOfCode"
File: file:rwh/ch27/syslogserver.hs
import Data.Bits
import Network.Socket
import Network.BSD
import Data.List
type HandlerFunc = SockAddr -> String -> IO ()
serveLog :: String -- ^ Port number or name; 514 is default
-> HandlerFunc -- ^ Function to handle incoming messages
-> IO ()
serveLog port handlerfunc = withSocketsDo $
do -- Look up the port. Either raises an exception or returns
-- a nonempty list.
addrinfos <- getAddrInfo
(Just (defaultHints {addrFlags = [AI_PASSIVE]}))
Nothing (Just port)
let serveraddr = head addrinfos
-- Create a socket
sock <- socket (addrFamily serveraddr) Datagram defaultProtocol
-- Bind it to the address we're listening to
bindSocket sock (addrAddress serveraddr)
-- Loop forever processing incoming data. Ctrl-C to abort.
procMessages sock
where procMessages sock =
do -- Receive one UDP packet, maximum length 1024 bytes,
-- and save its content into msg and its source
-- IP and port into addr
(msg, _, addr) <- recvFrom sock 1024
-- Handle it
handlerfunc addr msg
-- And process more messages
procMessages sock
-- A simple handler that prints incoming packets
plainHandler :: HandlerFunc
plainHandler addr msg =
putStrLn $ "From " ++ show addr ++ ": " ++ msgThis app loaded in GHCI without any errors, however it didn’t work the server printed nothing. It was tested in GHC/GHCI Version 7.10.2, Arch Linux 64 bits, Linux version 4.4.3-1-ARCH.
Page 617 - File: file:rwh/ch27/syslogtcpserver.hs
import Data.Bits
import Network.Socket
import Network.BSD
import Data.List
import Control.Concurrent
import Control.Concurrent.MVar
import System.IO
type HandlerFunc = SockAddr -> String -> IO ()
serveLog :: String -- ^ Port number or name; 514 is default
-> HandlerFunc -- ^ Function to handle incoming messages
-> IO ()
serveLog port handlerfunc = withSocketsDo $
do -- Look up the port. Either raises an exception or returns
-- a nonempty list.
addrinfos <- getAddrInfo
(Just (defaultHints {addrFlags = [AI_PASSIVE]}))
Nothing (Just port)
let serveraddr = head addrinfos
-- Create a socket
sock <- socket (addrFamily serveraddr) Stream defaultProtocol
-- Bind it to the address we're listening to
bindSocket sock (addrAddress serveraddr)
-- Start listening for connection requests. Maximum queue size
-- of 5 connection requests waiting to be accepted.
listen sock 5
-- Create a lock to use for synchronizing access to the handler
lock <- newMVar ()
-- Loop forever waiting for connections. Ctrl-C to abort.
procRequests lock sock
where
-- | Process incoming connection requests
procRequests :: MVar () -> Socket -> IO ()
procRequests lock mastersock =
do (connsock, clientaddr) <- accept mastersock
handle lock clientaddr
"syslogtcpserver.hs: client connnected"
forkIO $ procMessages lock connsock clientaddr
procRequests lock mastersock
-- | Process incoming messages
procMessages :: MVar () -> Socket -> SockAddr -> IO ()
procMessages lock connsock clientaddr =
do connhdl <- socketToHandle connsock ReadMode
hSetBuffering connhdl LineBuffering
messages <- hGetContents connhdl
mapM_ (handle lock clientaddr) (lines messages)
hClose connhdl
handle lock clientaddr
"syslogtcpserver.hs: client disconnected"
-- Lock the handler before passing data to it.
handle :: MVar () -> HandlerFunc
-- This type is the same as
-- handle :: MVar () -> SockAddr -> String -> IO ()
handle lock clientaddr msg =
withMVar lock
(\a -> handlerfunc clientaddr msg >> return a)
-- A simple handler that prints incoming packets
plainHandler :: HandlerFunc
plainHandler addr msg =
putStrLn $ "From " ++ show addr ++ ": " ++ msgFile: file:rwh/ch27/syslogtcpserver.hs
-- file: ch27/syslogtcpclient.hs
import Data.Bits
import Network.Socket
import Network.BSD
import Data.List
import SyslogTypes
import System.IO
data SyslogHandle =
SyslogHandle {slHandle :: Handle,
slProgram :: String}
openlog :: HostName -- ^ Remote hostname, or localhost
-> String -- ^ Port number or name; 514 is default
-> String -- ^ Name to log under
-> IO SyslogHandle -- ^ Handle to use for logging
openlog hostname port progname =
do -- Look up the hostname and port. Either raises an exception
-- or returns a nonempty list. First element in that list
-- is supposed to be the best option.
addrinfos <- getAddrInfo Nothing (Just hostname) (Just port)
let serveraddr = head addrinfos
-- Establish a socket for communication
sock <- socket (addrFamily serveraddr) Stream defaultProtocol
-- Mark the socket for keep-alive handling since it may be idle
-- for long periods of time
setSocketOption sock KeepAlive 1
-- Connect to server
connect sock (addrAddress serveraddr)
-- Make a Handle out of it for convenience
h <- socketToHandle sock WriteMode
-- We're going to set buffering to BlockBuffering and then
-- explicitly call hFlush after each message, below, so that
-- messages get logged immediately
hSetBuffering h (BlockBuffering Nothing)
-- Save off the socket, program name, and server address in a handle
return $ SyslogHandle h progname
syslog :: SyslogHandle -> Facility -> Priority -> String -> IO ()
syslog syslogh fac pri msg =
do hPutStrLn (slHandle syslogh) sendmsg
-- Make sure that we send data immediately
hFlush (slHandle syslogh)
where code = makeCode fac pri
sendmsg = "<" ++ show code ++ ">" ++ (slProgram syslogh) ++
": " ++ msg
closelog :: SyslogHandle -> IO ()
closelog syslogh = hClose (slHandle syslogh)
{- | Convert a facility and a priority into a syslog code -}
makeCode :: Facility -> Priority -> Int
makeCode fac pri =
let faccode = codeOfFac fac
pricode = fromEnum pri
in
(faccode `shiftL` 3) .|. pricode
Running: syslogtcpserver with telnet as client:
>>> :load "syslogtcpserver.hs"
[1 of 1] Compiling Main ( syslogtcpserver.hs, interpreted )
Ok, modules loaded: Main.
>>>
-- Open another terminal window
-- and enter:
--
-- $ telnet localhost 10514
--
-- and type the log messages.
--
--
>>> serveLog "10514" plainHandler
From 127.0.0.1:49570: syslogtcpserver.hs: client connnected
From 127.0.0.1:49570: Test message - Fatal kernel error
From 127.0.0.1:49570: Application server running OK.
Running: syslogtcpserver with syslogclient:
syslogserver:
>>> :load "syslogtcpserver.hs"
[1 of 1] Compiling Main ( syslogtcpserver.hs, interpreted )
Ok, modules loaded: Main.
>>>
>>> serveLog "10514" plainHandler
syslogclient:
>>>
>>> :load sylogtcpclient.hs
[1 of 2] Compiling SyslogTypes ( SyslogTypes.hs, interpreted )
[2 of 2] Compiling Main ( sylogtcpclient.hs, interpreted )
Ok, modules loaded: SyslogTypes, Main.
>>>
>>> openlog "localhost" "10514" "tcptest"
*** Exception: connect: does not exist (Connection refused)
>>>
>>> sl <- openlog "localhost" "1514" "tcptest"
*** Exception: connect: does not exist (Connection refused)
>>>