-----------------------------------------------------------------------
--
--  Haskell: The Craft of Functional Programming
--  Simon Thompson
--  (c) Addison-Wesley, 1996-2011.
--
--  Chapter 18
--
-----------------------------------------------------------------------


module Chapter18 where

import Prelude hiding (lookup)
import System.IO 
import Control.Monad (liftM, ap)
import Control.Monad.Identity
import Chapter8 (getInt)
import Data.Time
import System.Locale hiding (defaultTimeLocale)
import System.IO.Unsafe (unsafePerformIO)

-- Programming with monads
-- ^^^^^^^^^^^^^^^^^^^^^^^


-- The basics of input/output
-- ^^^^^^^^^^^^^^^^^^^^^^^^^^

-- Reading input is done by getLine and getChar: see Prelude for details.

--  getLine :: IO String
--  getChar :: IO Char

-- Text strings are written using 
--  
--  putStr :: String -> IO ()
--  putStrLn :: String -> IO ()

-- A hello, world program

helloWorld :: IO ()
helloWorld :: IO ()
helloWorld = String -> IO ()
putStr String
"Hello, World!"

-- Simple examples

readWrite :: IO ()

readWrite :: IO ()
readWrite =
    do
      IO String
getLine
      String -> IO ()
putStrLn String
"one line read"

readEcho :: IO ()

readEcho :: IO ()
readEcho =
    do
      String
line <-IO String
getLine
      String -> IO ()
putStrLn (String
"line read: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
line)


-- Adding a sequence of integers from the input

sumInts :: Integer -> IO Integer

sumInts :: Integer -> IO Integer
sumInts Integer
s
  = do Integer
n <- IO Integer
getInt
       if Integer
nInteger -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
==Integer
0 
          then Integer -> IO Integer
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Integer
s
          else Integer -> IO Integer
sumInts (Integer
sInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
n)

-- Adding a list of integers, using an accumulator

sumAcc :: Integer -> [Integer] -> Integer

sumAcc :: Integer -> [Integer] -> Integer
sumAcc Integer
s [] = Integer
s
sumAcc Integer
s (Integer
n:[Integer]
ns) 
  = if Integer
nInteger -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
==Integer
0
       then Integer
s
       else Integer -> [Integer] -> Integer
sumAcc (Integer
sInteger -> Integer -> Integer
forall a. Num a => a -> a -> a
+Integer
n) [Integer]
ns


-- Addiing a sequence of integers, courteously.

sumInteract :: IO ()
sumInteract :: IO ()
sumInteract
  = do String -> IO ()
putStrLn String
"Enter integers one per line"
       String -> IO ()
putStrLn String
"These will be summed until zero is entered"
       Integer
sum <- Integer -> IO Integer
sumInts Integer
0
       String -> IO ()
putStr String
"The sum is "
       Integer -> IO ()
forall a. Show a => a -> IO ()
print Integer
sum


-- Further I/O
-- ^^^^^^^^^^^

-- Interaction at the terminal

copyInteract :: IO ()

copyInteract :: IO ()
copyInteract = 
    do
      Handle -> BufferMode -> IO ()
hSetBuffering Handle
stdin BufferMode
LineBuffering
      IO ()
copyEOF
      Handle -> BufferMode -> IO ()
hSetBuffering Handle
stdin BufferMode
NoBuffering

copyEOF :: IO ()

copyEOF :: IO ()
copyEOF = 
    do 
      Bool
eof <- IO Bool
isEOF
      if Bool
eof  
        then () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return () 
        else do String
line <- IO String
getLine 
                String -> IO ()
putStrLn String
line
                IO ()
copyEOF

-- Input and output as lazy lists

-- Reverse all the lines in the input.

listIOprog :: String -> String

listIOprog :: String -> String
listIOprog = [String] -> String
unlines ([String] -> String) -> (String -> [String]) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map String -> String
forall a. [a] -> [a]
reverse ([String] -> [String])
-> (String -> [String]) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines


-- Generating random numbers

randomInt :: Integer -> IO Integer
randomInt :: Integer -> IO Integer
randomInt Integer
n = 
    do
      UTCTime
time <- IO UTCTime
getCurrentTime
      Integer -> IO Integer
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ( (Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`rem` Integer
n) (Integer -> Integer) -> Integer -> Integer
forall a b. (a -> b) -> a -> b
$ String -> Integer
forall a. Read a => String -> a
read (String -> Integer) -> String -> Integer
forall a b. (a -> b) -> a -> b
$ Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
6 (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale String
"%q" UTCTime
time)
      
randInt :: Integer -> Integer
randInt :: Integer -> Integer
randInt = IO Integer -> Integer
forall a. IO a -> a
unsafePerformIO (IO Integer -> Integer)
-> (Integer -> IO Integer) -> Integer -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> IO Integer
randomInt 
      


-- The calculator
-- ^^^^^^^^^^^^^^

-- This is available separately in the Calculator directory.


-- The do notation revisited
-- ^^^^^^^^^^^^^^^^^^^^^^^^^

addOneInt :: IO ()

addOneInt :: IO ()
addOneInt 
  = do String
line <- IO String
getLine
       String -> IO ()
putStrLn (Int -> String
forall a. Show a => a -> String
show (Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ String -> Int
forall a. Read a => String -> a
read String
line :: Int))       

addOneInt' :: IO ()
addOneInt' 
  = IO String
getLine IO String -> (String -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \String
line ->
    String -> IO ()
putStrLn (Int -> String
forall a. Show a => a -> String
show (Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ String -> Int
forall a. Read a => String -> a
read String
line :: Int))     

-- Monads for Functional Programming
-- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^

-- The definition of the Monad class
--  class Monad m where
--    (>>=)  :: m a -> (a -> m b) -> m b
--    return :: a -> m a
--    fail   :: String -> m a

-- Kelisli composition for monadic functions.

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

-- f >@> g = \ x -> (f x) >>= g


-- Some examples of monads
-- ^^^^^^^^^^^^^^^^^^^^^^^

-- Some examples from the standard prelude.

-- The list monad

--  instance Monad [] where
--    xs >>= f  = concat (map f xs)
--    return x  = [x]
--    zero      = []

-- The Maybe monad

--  instance Monad Maybe where
--    (Just x) >>= k  =  k x
--    Nothing  >>= k  =  Nothing
--    return          =  Just


-- The parsing monad

--  data SParse a b = SParse (Parse a b)

--  instance Monad (SParse a) where
--    return x = SParse (succeed x)
--    zero     = SParse fail
--    (SParse pr) >>= f 
--      = SParse (\s -> concat [ sparse (f x) rest | (x,rest) <- pr st ])

--  sparse :: SParse a b -> Parse a b
--  sparse (SParse pr) = pr

-- A state monad (the state need not be a table; this example is designed
-- to support the example discussed below.)

type Table a = [a]

data State a b = State (Table a -> (Table a , b))

instance Monad (State a) where

  return :: forall a. a -> State a a
return a
x = (Table a -> (Table a, a)) -> State a a
forall a b. (Table a -> (Table a, b)) -> State a b
State (\Table a
tab -> (Table a
tab,a
x))

  (State Table a -> (Table a, a)
st) >>= :: forall a b. State a a -> (a -> State a b) -> State a b
>>= a -> State a b
f 
    = (Table a -> (Table a, b)) -> State a b
forall a b. (Table a -> (Table a, b)) -> State a b
State (\Table a
tab -> let 
                     (Table a
newTab,a
y)    = Table a -> (Table a, a)
st Table a
tab
                     (State Table a -> (Table a, b)
trans) = a -> State a b
f a
y 
                     in
                     Table a -> (Table a, b)
trans Table a
newTab)

instance Applicative (State a) where
  pure :: forall a. a -> State a a
pure = a -> State a a
forall a. a -> State a a
forall (m :: * -> *) a. Monad m => a -> m a
return
  <*> :: forall a b. State a (a -> b) -> State a a -> State a b
(<*>) = State a (a -> b) -> State a a -> State a b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Functor (State a) where
  fmap :: forall a b. (a -> b) -> State a a -> State a b
fmap = (a -> b) -> State a a -> State a b
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM


-- Example: Monadic computation over trees
-- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^

-- A type of binary trees.

data Tree a = Nil | Node a (Tree a) (Tree a)
              deriving (Tree a -> Tree a -> Bool
(Tree a -> Tree a -> Bool)
-> (Tree a -> Tree a -> Bool) -> Eq (Tree a)
forall a. Eq a => Tree a -> Tree a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => Tree a -> Tree a -> Bool
== :: Tree a -> Tree a -> Bool
$c/= :: forall a. Eq a => Tree a -> Tree a -> Bool
/= :: Tree a -> Tree a -> Bool
Eq,Eq (Tree a)
Eq (Tree a) =>
(Tree a -> Tree a -> Ordering)
-> (Tree a -> Tree a -> Bool)
-> (Tree a -> Tree a -> Bool)
-> (Tree a -> Tree a -> Bool)
-> (Tree a -> Tree a -> Bool)
-> (Tree a -> Tree a -> Tree a)
-> (Tree a -> Tree a -> Tree a)
-> Ord (Tree a)
Tree a -> Tree a -> Bool
Tree a -> Tree a -> Ordering
Tree a -> Tree a -> Tree a
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. Ord a => Eq (Tree a)
forall a. Ord a => Tree a -> Tree a -> Bool
forall a. Ord a => Tree a -> Tree a -> Ordering
forall a. Ord a => Tree a -> Tree a -> Tree a
$ccompare :: forall a. Ord a => Tree a -> Tree a -> Ordering
compare :: Tree a -> Tree a -> Ordering
$c< :: forall a. Ord a => Tree a -> Tree a -> Bool
< :: Tree a -> Tree a -> Bool
$c<= :: forall a. Ord a => Tree a -> Tree a -> Bool
<= :: Tree a -> Tree a -> Bool
$c> :: forall a. Ord a => Tree a -> Tree a -> Bool
> :: Tree a -> Tree a -> Bool
$c>= :: forall a. Ord a => Tree a -> Tree a -> Bool
>= :: Tree a -> Tree a -> Bool
$cmax :: forall a. Ord a => Tree a -> Tree a -> Tree a
max :: Tree a -> Tree a -> Tree a
$cmin :: forall a. Ord a => Tree a -> Tree a -> Tree a
min :: Tree a -> Tree a -> Tree a
Ord,Int -> Tree a -> String -> String
[Tree a] -> String -> String
Tree a -> String
(Int -> Tree a -> String -> String)
-> (Tree a -> String)
-> ([Tree a] -> String -> String)
-> Show (Tree a)
forall a. Show a => Int -> Tree a -> String -> String
forall a. Show a => [Tree a] -> String -> String
forall a. Show a => Tree a -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: forall a. Show a => Int -> Tree a -> String -> String
showsPrec :: Int -> Tree a -> String -> String
$cshow :: forall a. Show a => Tree a -> String
show :: Tree a -> String
$cshowList :: forall a. Show a => [Tree a] -> String -> String
showList :: [Tree a] -> String -> String
Show)

-- Summing a tree of integers

-- A direct solution:

sTree :: Tree Integer -> Integer

sTree :: Tree Integer -> Integer
sTree Tree Integer
Nil            = Integer
0
sTree (Node Integer
n Tree Integer
t1 Tree Integer
t2) = Integer
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Tree Integer -> Integer
sTree Tree Integer
t1 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Tree Integer -> Integer
sTree Tree Integer
t2

-- A monadic solution: first giving a value of type Identity Int ...

sumTree :: Tree Integer -> Identity Integer

sumTree :: Tree Integer -> Identity Integer
sumTree Tree Integer
Nil = Integer -> Identity Integer
forall a. a -> Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Integer
0

sumTree (Node Integer
n Tree Integer
t1 Tree Integer
t2)
  = do Integer
num <- Integer -> Identity Integer
forall a. a -> Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return Integer
n
       Integer
s1  <- Tree Integer -> Identity Integer
sumTree Tree Integer
t1
       Integer
s2  <- Tree Integer -> Identity Integer
sumTree Tree Integer
t2
       Integer -> Identity Integer
forall a. a -> Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer
num Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
s1 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
s2)

-- ... then adapted to give an Int solution

sTree' :: Tree Integer -> Integer

sTree' :: Tree Integer -> Integer
sTree' = Identity Integer -> Integer
forall a. Identity a -> a
identity (Identity Integer -> Integer)
-> (Tree Integer -> Identity Integer) -> Tree Integer -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree Integer -> Identity Integer
sumTree

identity :: Identity a -> a

identity :: forall a. Identity a -> a
identity (Identity a
x) = a
x

-- Using a state monad in a tree calculation
-- ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^

-- The top level function ...

numTree :: Eq a => Tree a -> Tree Integer

-- ... and the function which does all the work:

numberTree :: Eq a => Tree a -> State a (Tree Integer)

-- Its structure mirrors exactly the structure of the earlier program to
-- sum the tree.

numberTree :: forall a. Eq a => Tree a -> State a (Tree Integer)
numberTree Tree a
Nil = Tree Integer -> State a (Tree Integer)
forall a. a -> State a a
forall (m :: * -> *) a. Monad m => a -> m a
return Tree Integer
forall a. Tree a
Nil

numberTree (Node a
x Tree a
t1 Tree a
t2)
  = do Integer
num <- a -> State a Integer
forall a. Eq a => a -> State a Integer
numberNode a
x
       Tree Integer
nt1 <- Tree a -> State a (Tree Integer)
forall a. Eq a => Tree a -> State a (Tree Integer)
numberTree Tree a
t1
       Tree Integer
nt2 <- Tree a -> State a (Tree Integer)
forall a. Eq a => Tree a -> State a (Tree Integer)
numberTree Tree a
t2
       Tree Integer -> State a (Tree Integer)
forall a. a -> State a a
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> Tree Integer -> Tree Integer -> Tree Integer
forall a. a -> Tree a -> Tree a -> Tree a
Node Integer
num Tree Integer
nt1 Tree Integer
nt2)

-- The work of the algorithm is done node by node, hence the function

numberNode :: Eq a => a -> State a Integer

numberNode :: forall a. Eq a => a -> State a Integer
numberNode a
x = (Table a -> (Table a, Integer)) -> State a Integer
forall a b. (Table a -> (Table a, b)) -> State a b
State (a -> Table a -> (Table a, Integer)
forall a. Eq a => a -> Table a -> (Table a, Integer)
nNode a
x)

--  
-- Looking up a value in the table; will side-effect the table if the value
-- is not present.

nNode :: Eq a => a -> (Table a -> (Table a , Integer))
nNode :: forall a. Eq a => a -> Table a -> (Table a, Integer)
nNode a
x Table a
table
  | a -> Table a -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem a
x Table a
table        = (Table a
table      , a -> Table a -> Integer
forall a. Eq a => a -> Table a -> Integer
lookup a
x Table a
table)
  | Bool
otherwise           = (Table a
tableTable a -> Table a -> Table a
forall a. [a] -> [a] -> [a]
++[a
x] , Table a -> Integer
forall {a}. [a] -> Integer
integerLength Table a
table)
    where
      integerLength :: [a] -> Integer
integerLength = Int -> Integer
forall a. Integral a => a -> Integer
toInteger(Int -> Integer) -> ([a] -> Int) -> [a] -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
.[a] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length
  
-- Looking up a value in the table when known to be present

lookup :: Eq a => a -> Table a -> Integer

lookup :: forall a. Eq a => a -> Table a -> Integer
lookup a
x Table a
tab = 
    Integer -> Table a -> Integer
forall {t}. Num t => t -> Table a -> t
locate Integer
0 Table a
tab
           where
             locate :: t -> Table a -> t
locate t
n (a
y:Table a
ys) = 
                 if a
xa -> a -> Bool
forall a. Eq a => a -> a -> Bool
==a
y then t
n else t -> Table a -> t
locate (t
nt -> t -> t
forall a. Num a => a -> a -> a
+t
1) Table a
ys

-- Extracting a value froma state monad.

runST :: State a b -> b
runST :: forall a b. State a b -> b
runST (State Table a -> (Table a, b)
st) = (Table a, b) -> b
forall a b. (a, b) -> b
snd (Table a -> (Table a, b)
st [])

-- The top-level function defined eventually.

numTree :: forall a. Eq a => Tree a -> Tree Integer
numTree = State a (Tree Integer) -> Tree Integer
forall a b. State a b -> b
runST (State a (Tree Integer) -> Tree Integer)
-> (Tree a -> State a (Tree Integer)) -> Tree a -> Tree Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree a -> State a (Tree Integer)
forall a. Eq a => Tree a -> State a (Tree Integer)
numberTree

-- Example tree

egTree :: Tree String
 
egTree :: Tree String
egTree = String -> Tree String -> Tree String -> Tree String
forall a. a -> Tree a -> Tree a -> Tree a
Node String
"Moon"
               (String -> Tree String -> Tree String -> Tree String
forall a. a -> Tree a -> Tree a -> Tree a
Node String
"Ahmet" Tree String
forall a. Tree a
Nil Tree String
forall a. Tree a
Nil)
               (String -> Tree String -> Tree String -> Tree String
forall a. a -> Tree a -> Tree a -> Tree a
Node String
"Dweezil"  
                        (String -> Tree String -> Tree String -> Tree String
forall a. a -> Tree a -> Tree a -> Tree a
Node String
"Ahmet" Tree String
forall a. Tree a
Nil Tree String
forall a. Tree a
Nil) 
                        (String -> Tree String -> Tree String -> Tree String
forall a. a -> Tree a -> Tree a -> Tree a
Node String
"Moon" Tree String
forall a. Tree a
Nil Tree String
forall a. Tree a
Nil))