FP_HSE2020Fall_11

Fp11.hs

module Fp11 where
import Data.Maybe (fromMaybe)
import Data.Monoid (Sum(..),Product(..))
import Control.Monad(replicateM)
import Control.Monad.Trans.Writer
import Control.Monad.Trans.Reader
import Control.Monad.Trans.State


-----------------------------------------------------
-- Монада Reader

-- простейший Reader (instance Monad ((->) e) where ...)
doIt :: Int -> Int
doIt = do
  a <- (^2)
  b <- (*5)
  return $ a + b
{-
GHCi> doIt 2      
14
GHCi> doIt 3
24  
-}

-- тип окружения - r
simpleReader :: Show r => Reader r String
simpleReader = reader 
    (\e -> "Environment is " ++ show e)

{-
GHCi> runReader simpleReader 42
"Environment is 42"

GHCi> runReader simpleReader True
"Environment is True"
-}

type User = String
type Password = String
type UsersTable = [(User,Password)]

pwds :: UsersTable
pwds = [("Bill","123"),("Ann","qwerty"),("John","2sRq8P")]

-- возвращает имя первого пользователя в списке
firstUser :: Reader UsersTable User
firstUser = do
  e <- ask
  let name = fst (head e)
  return name

{-
GHCi> runReader firstUser pwds 
"Bill"
GHCi> runReader firstUser []
"*** Exception: Prelude.head: empty list
-}

-- возвращает длину пароля пользователя  или -1, если такого пользователя нет
getPwdLen :: User -> Reader UsersTable Int
getPwdLen person = do
  mbPwd <- asks $ lookup person 
  let mbLen = fmap length mbPwd
  let len = fromMaybe (-1) mbLen
  return len

{-
GHCi>  runReader (getPwdLen "Ann") pwds
6
GHCi>  runReader (getPwdLen "Ann") []  
-1
-}


usersCount :: Reader UsersTable Int
usersCount = asks length

localTest :: Reader UsersTable (Int,Int)
localTest = do
  count1 <- usersCount 
  count2 <- local (("Mike","1"):) usersCount 
  return (count1, count2)

{-
GHCi> runReader localTest pwds
(3,4)
GHCi> runReader localTest []  
(0,1)
-}



-----------------------------------------------------
-- Монада Writer

{-
GHCi> runWriter (return 3 :: Writer String Int)        
(3,"")
GHCi> runWriter (return 3 :: Writer (Sum Int) Int)     
(3,Sum {getSum = 0})
GHCi> execWriter (return 3 :: Writer (Product Int) Int)
Product {getProduct = 1}
-}

type Vegetable = String
type Price = Double
type Qty = Double
type Cost = Double
type PriceList = [(Vegetable,Price)]

prices :: PriceList
prices = [("Potato",13),("Tomato",55),("Apple",48)]

-- tell позволяет задать вывод
addVegetable :: Vegetable -> Qty -> Writer (Sum Cost) (Vegetable, Price)
addVegetable veg qty = do
  let pr = fromMaybe 0 $ lookup veg prices
  let cost = qty * pr
  tell $ Sum cost
  return (veg, pr)
{-
GHCi> runWriter $ addVegetable "Apple" 100
(("Apple",48.0),Sum {getSum = 4800.0})
GHCi> runWriter $ addVegetable "Pear" 100
(("Pear",0.0),Sum {getSum = 0.0})
-}
  
-- суммарная стоимость копится <<за кадром>>
myCart0 :: Writer (Sum Cost) [(Vegetable, Price)]
myCart0 = do
  x1 <- addVegetable "Potato" 3.5
  x2 <- addVegetable "Tomato" 1.0
  x3 <- addVegetable "AGRH!!" 1.6
  return [x1,x2,x3]
{-
GHCi> runWriter myCart0
([("Potato",13.0),("Tomato",55.0),("AGRH!!",0.0)],Sum {getSum = 100.5})
GHCi> execWriter myCart0
Sum {getSum = 100.5}
-}


-- если хотим знать промежуточные стоимости, используем listen ...
myCart1 :: Writer (Sum Cost) [((Vegetable, Price), Sum Cost)]
myCart1 = do
  x1 <- listen $ addVegetable "Potato" 3.5
  x2 <- listen $ addVegetable "Tomato" 1.0
  x3 <- listen $ addVegetable "AGRH!!" 1.6
  return [x1,x2,x3]
{-
GHCi> runWriter myCart1 
([(("Potato",13.0),Sum {getSum = 45.5}),(("Tomato",55.0),Sum {getSum = 55.0}),(("AGRH!!",0.0),Sum {getSum = 0.0})],Sum {getSum = 100.5})
-}

-- ... или listens
myCart1' :: Writer (Sum Cost) [((Vegetable, Price), Cost)]
myCart1' = do
  x1 <- listens getSum $ addVegetable "Potato" 3.5
  x2 <- listens getSum $ addVegetable "Tomato" 1.0
  x3 <- listens getSum $ addVegetable "AGRH!!" 1.6
  return [x1,x2,x3]
{-
GHCi> runWriter myCart1'
([(("Potato",13.0),45.5),(("Tomato",55.0),55.0),(("AGRH!!",0.0),0.0)],Sum {getSum = 100.5})
-}


--  (pass технический хелпер для censor)
--  для модификации лога используют censor :: (w -> w) -> Writer a -> Writer a
myCart0' :: Writer (Sum Cost) [(Vegetable, Price)]
myCart0' = censor (discount 10) myCart0

-- бизнес-логика:)
discount :: Double -> Sum Cost -> Sum Cost
discount proc s@(Sum x) 
  | x < 100  = s
  | x >= 100 = Sum $ x * (100 - proc) / 100

{-
GHCi> execWriter myCart0
Sum {getSum = 100.5}
GHCi> execWriter myCart0'
Sum {getSum = 90.45}
-}




-----------------------------------------------------
-- Монада State

{-
GHCi> runState (return 3 :: State String Int) "Hi, State!"
(3,"Hi, State!")
GHCi> execState (return 3 :: State String Int) "Hi, State!"
"Hi, State!"
GHCi> evalState (return 3 :: State String Int) "Hi, State!"
3
-}

tick :: State Int Int
tick = do 
  n <- get
  put (n + 1)
  return n

succ' :: Int -> Int
succ' n = execState tick n

plus :: Int -> Int -> Int
plus n x = execState (sequence $ replicate n tick) x

plus' :: Int -> Int -> Int
plus' n x = execState (replicateM n tick) x
 



-----------------------------------------------------
-- Монада IO

main' = do
  putStrLn "What is your name?"
  name <- getLine'
  putStrLn ("Nice to meet you, " ++ name ++ "!")

main'' =
  putStrLn "What is your name?" >>
  getLine' >>= \name ->
  putStrLn $ "Nice to meet you, " ++ name ++ "!"


getLine' :: IO String
getLine' = do 
  c <- getChar
  if c == '\n' then
    return []
  else do 
    cs <- getLine'
    return (c:cs)
    
putStr'         :: String -> IO ()
putStr' []      =  return ()
putStr' (x:xs)  =  putChar x >> putStr' xs
    
putStr'' :: String -> IO ()
putStr'' = sequence_ . map putChar

putStr''' :: String -> IO ()
putStr''' = mapM_ putChar


{-
Как устроен IO внутри? 
GHC.Prim (0.6.1)

-- | @State\#@ is the primitive, unlifted type of states.  It has
--         one type parameter, thus @State\# RealWorld@, or @State\# s@,
--         where s is a type variable. The only purpose of the type parameter
--         is to keep different state threads separate.  It is represented by
--         nothing at all. 
data State# s

-- | @RealWorld@ is deeply magical.  It is /primitive/, but it is not
--         /unlifted/ (hence @ptrArg@).  We never manipulate values of type
--         @RealWorld@; it\'s only used in the type system, to parameterise @State\#@. 
data RealWorld


--base-4.14.0.0/docs/src/GHC.ST

newtype ST s a = ST (STRep s a)
type STRep s a = State# s -> (# State# s, a #)

-- | Return the value computed by a state thread.
-- The @forall@ ensures that the internal state used by the 'ST'
-- computation is inaccessible to the rest of the program.
runST :: (forall s. ST s a) -> a
runST (ST st_rep) = case runRW# st_rep of (# _, a #) -> a
-- See Note [Definition of runRW#] in GHC.Magic


newtype IO a = IO (State# RealWorld -> (# State# RealWorld, a #))

-}