Skip to content

Instantly share code, notes, and snippets.

@deniok

deniok/Fp11.hs Secret

Last active November 16, 2020 13:17
  • Star 0 You must be signed in to star a gist
  • Fork 0 You must be signed in to fork a gist
Star You must be signed in to star a gist
Save deniok/f47319136b07093269ecf7a017086b95 to your computer and use it in GitHub Desktop.
FP_HSE2020Fall_11
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