Skip to content

Instantly share code, notes, and snippets.

@deniok

deniok/Fp12.hs Secret

Last active Nov 27, 2020
Embed
What would you like to do?
FP_HSE2020Fall_12
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
module Fp12 where
import Control.Applicative (Alternative(empty, (<|>)))
import Control.Monad (guard, MonadPlus(..), ap, liftM)
import Control.Monad.State
(StateT, MonadState(get, put), modify, MonadTrans(..), State)
-- мы используем библиотеку mtl, а не transformers,
-- для transformers следовало бы писать
--import Control.Monad.Trans.State
import Control.Monad.Identity ( Identity(..) )
--import Control.Monad.Error -- depricated начиная c ghc 7.10
import Control.Monad.Except
( Except, runExcept, MonadError(catchError, throwError) )
import Data.Foldable (msum)
import Control.Monad.Fail ( MonadFail(..) )
pythags :: [(Integer, Integer, Integer)]
pythags = do
z <- [1..]
x <- [1..z]
y <- [x..z]
guard $ x^2 + y^2 == z^2
return (x, y, z)
{-
GHCi> take 5 pythags
[(3,4,5),(6,8,10),(5,12,13),(9,12,15),(8,15,17)]
-}
--------------------------------------------------
-- монада Except
data DivByError = ErrZero | Other String
deriving (Eq,Show)
(/?) :: Double -> Double -> Except DivByError Double
_ /? 0 = throwError ErrZero -- в mtl throwError, в transformers throwE
x /? y = return $ x / y
example0 :: Double -> Double -> Except DivByError String
example0 x y = action `catchError` handler where -- в mtl catchError, в transformers catchE
action = do
q <- x /? y
return $ show q
handler = return . show
{-
GHCi> runExcept $ example0 5 2
Right "2.5"
GHCi> runExcept $ example0 5 0
Right "ErrZero"
-}
instance Semigroup DivByError where
Other s1 <> Other s2 = Other $ s1 ++ s2
Other s1 <> ErrZero = Other $ s1 ++ "zero;"
ErrZero <> Other s2 = Other $ "zero;" ++ s2
ErrZero <> ErrZero = Other "zero;zero"
instance Monoid DivByError where
mempty = Other ""
example2 :: Double -> Double -> Except DivByError String
example2 x y = action `catchError` handler where -- в mtl catchError, в transformers catchE
action = do
q <- x /? y
guard $ y>=0
return $ show q
handler = return . show
{-
GHCi> runExcept $ example2 5 2
Right "2.5"
GHCi> runExcept $ example2 5 0
Right "ErrZero"
GHCi> runExcept $ example2 5 (-2)
Right "Other \"\""
GHCi> runExcept $ msum [5/?0, 7/?0, 2/?0]
Left (Other "zero;zero;zero;")
GHCi> runExcept $ msum [5/?0, 7/?0, 2/?4]
Right 0.5
-}
test :: [Except DivByError Double] -> Either DivByError Double
test = runExcept . msum
{-
GHCi> do {x<-(*2); y<-ask; return (x+y)} $ 5
15
GHCi> Left 5 `catchError` (\e -> Right (e^2))
Right 25
GHCi> Right 5 `catchError` (\e -> Right (e^2))
Right 5
>
-}
--------------------------------------------------
-- Многопараметрические классы типов
data Vector = Vector Int Int
deriving (Eq, Show)
data Matrix = Matrix Vector Vector
deriving (Eq, Show)
-- требуются расширения MultiParamTypeClasses, FunctionalDependencies (второе влечет первое:)
class Mult a b c | a b -> c where
(***) :: a -> b -> c
instance Mult Matrix Matrix Matrix where
Matrix (Vector a11 a12) (Vector a21 a22) *** Matrix (Vector b11 b12) (Vector b21 b22) =
Matrix (Vector c11 c12) (Vector c21 c22) where
c11 = a11 * b11 + a12 * b21
c12 = a11 * b12 + a12 * b22
c21 = a21 * b11 + a22 * b21
c22 = a21 * b12 + a22 * b22
{-
GHCi> let a = Matrix (Vector 1 2) (Vector 3 4)
GHCi> let i = Matrix (Vector 1 0) (Vector 0 1)
GHCi> a *** i
Matrix (Vector 1 2) (Vector 3 4)
-}
--------------------------------------------------------
-- Трансформеры монад
--(мы используем библиотеку mtl, а не transformers)
stInteger :: State Integer Integer
stInteger = do modify (+1)
get
stString :: State String String
stString = do modify (++"1")
get
{-
GHCi> evalState stInteger 0
1
GHCi> evalState stString "0"
"01"
-}
stComb :: StateT Integer (StateT String Identity) (Integer, String)
stComb = do modify (+1)
lift $ modify (++"1")
a <- get
b <- lift get
return (a,b)
{-
GHCi> runIdentity $ evalStateT (evalStateT stComb 0) "0"
(1,"01")
-}
-----------------------------------
newtype MaybeT m a = MaybeT { runMaybeT :: m (Maybe a) }
instance Monad m => Monad (MaybeT m) where
return = lift . return
mx >>= k = MaybeT $ do
v <- runMaybeT mx
case v of
Nothing -> return Nothing
Just y -> runMaybeT (k y)
-- fail _ = MaybeT $ return Nothing -- для старых компиляторов;
-- fail = Control.Monad.Fail.fail -- теперь все происходит так
{-
Из-за MonadFail Proposal надо еще написать
-}
instance Monad m => MonadFail (MaybeT m) where
fail _ = MaybeT $ return Nothing
{-
Если же семантика имплементируемого трансформера не подразумевает умения
обрабатывать ошибки, то все равно необходимо протащить fail из внутренней
монады, если он там есть - то есть контекст представителя должен быть (MonadFail m).
-}
{-
Из-за AMP надо еще написать
-}
instance Monad m => Functor (MaybeT m) where
fmap = liftM
instance Monad m => Applicative (MaybeT m) where
pure = return
(<*>) = ap
instance MonadTrans MaybeT where
lift = MaybeT . fmap Just
{-
GHCi> :t liftM Just
liftM Just :: Monad m => m a -> m (Maybe a)
GHCi> :t liftM Just get
liftM Just get :: MonadState a m => m (Maybe a)
-}
mbSt :: MaybeT (StateT Integer Identity) Integer
mbSt = do
lift $ modify (+1)
a <- lift get
True <- return $ a >= 3
--guard (a >= 3)
return a
{-
GHCi> runIdentity $ evalStateT (runMaybeT mbSt) 0
Nothing
GHCi> runIdentity $ evalStateT (runMaybeT mbSt) 2
Just 3
-}
-- Чтобы заработал guard нужно сделать MaybeT m представителем Alternative.
-- (Начиная с GHC 7.10 guard определен через Alternative, а не MonadPlus.)
instance Monad m => Alternative (MaybeT m) where
empty = MaybeT $ return Nothing
x <|> y = MaybeT $ do
v <- runMaybeT x
case v of
Nothing -> runMaybeT y
Just _ -> return v
-- Это необязательно, но может пригодиться для msum, mfilter
instance Monad m => MonadPlus (MaybeT m)
mbSt' :: MaybeT (State Integer) Integer
mbSt' = do lift $ modify (+1)
a <- lift get
guard $ a >= 3 -- !!
return a
{-
GHCi> runIdentity $ evalStateT (runMaybeT mbSt') 0
Nothing
GHCi> runIdentity $ evalStateT (runMaybeT mbSt') 2
Just 3
-}
-- Для любой пары монад можно избавиться от подъёма
-- стандартных операций вложенной монады
{-
class Monad m => MonadState s m | m -> s where
get :: m s
get = state (\s -> (s, s))
put :: s -> m ()
put s = state (\_ -> ((), s))
state :: (s -> (a, s)) -> m a
state f = do
s <- get
let ~(a, s') = f s
put s'
return a
modify :: MonadState s m => (s -> s) -> m ()
modify f = state (\s -> ((), f s))
gets :: MonadState s m => (s -> a) -> m a
gets f = do
s <- get
return (f s)
-}
-- требуются расширения FlexibleInstances, UndecidableInstances
instance MonadState s m => MonadState s (MaybeT m) where
get = lift get
put = lift . put
mbSt'' :: MaybeT (State Integer) Integer
mbSt'' = do
modify (+1) -- без lift
a <- get -- без lift
guard $ a >= 3
return a
{-
GHCi> runIdentity $ evalStateT (runMaybeT mbSt'') 0
Nothing
GHCi> runIdentity $ evalStateT (runMaybeT mbSt'') 2
Just 3
-}
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment