FP_HSE2020Fall_11
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
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 #)) | |
-} |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment