Real World Haskell Walk

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
CashOnDelivery

-- 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
>>>

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
>>>

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]
>>>

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
>>>

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

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 = fixLines

>>> :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"]
>>>

$ 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

safeHead :: [a] -> Maybe a
safeTail :: [a] -> Maybe [a]
safeLast :: [a] -> Maybe a
safeInit :: [a] -> Maybe [a]

-- file: ch04/ch04.exercises.hs
splitWith :: (a -> Bool) -> [a] -> [[a]]

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 []
>>>

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
>>>

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

module Main (main) where

import SimpleJSON2

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

$ 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)]

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)

-- file: ch07/basicio.hs
main = do
  putStrLn "Greetings! What is your name?"
  inpStr <- getLine
  putStrLn $ "Welcome to Haskell, " ++ inpStr ++ "!"

-- 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

-- 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)

-- 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!"

-- 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!"

-- file: ch07/basicio-nodo.hs
main =
  putStrLn "Greetings! What is your name?" >>
  getLine >>=
  (\inpStr -> putStrLn $ "Welcome to Haskell, " ++ inpStr ++ "!")

-- 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
>>>

-- 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
>>>

-- file: ch07/return3.hs
returnTest :: IO ()
returnTest =
  do one <- return 1
     let two = 2
     putStrLn $ show (one + two)

main :: IO ()  
main = returnTest

$ > 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 ()
>>>

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
...

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)

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"]
>>> 


>>>

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,"")
>>>

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"
>>>

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))
>>>

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)]
>>>

-- 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)
>>>

{-
  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)
>>>

>>> :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.

>>> :load "syslogtcpserver.hs"
[1 of 1] Compiling Main             ( syslogtcpserver.hs, interpreted )
Ok, modules loaded: Main.
>>> 
>>> serveLog "10514" plainHandler

>>> 
>>> :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)
>>>