1
1
mirror of https://github.com/thma/LtuPatternFactory.git synced 2024-12-02 08:33:20 +03:00

on the way to a poor man's coerce...

This commit is contained in:
thma 2018-11-12 21:41:29 +01:00
parent 2badd11048
commit 1f33d594f9

View File

@ -1,37 +1,43 @@
{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-}
{-# LANGUAGE FlexibleInstances, UndecidableInstances #-}
module Coerce where
import Data.Monoid (Sum (..), getSum)
import Data.Functor.Product -- Product of Functors
import Data.Functor.Compose -- Composition of Functors
import Data.Functor.Const -- Const Functor
import Control.Applicative -- WrappedMonad
import Control.Monad.State.Lazy -- State Monad
import Data.Typeable
-- | This module provides explicit coercion.
-- Just in case you want to know what's behind the "magic" Data.Coerce.coerce
class Coerce a b | a -> b where
down :: a -> b
up :: b -> a
unwrap :: a -> b
wrap :: b -> a
instance Coerce (Const a b) a where
down = getConst
up = Const
unwrap = getConst
wrap = Const
instance Coerce (Sum a) a where
unwrap = getSum
wrap = Sum
instance (Coerce(m a) b, Coerce(n a) c) => Coerce((Product m n) a) (b,c) where
down mnx = (down (pfst mnx), down(psnd mnx)) where
unwrap mnx = (unwrap (pfst mnx), unwrap(psnd mnx)) where
pfst (Pair fst _) = fst
psnd (Pair _ snd) = snd
up (x,y) = Pair (up x) (up y)
wrap (x,y) = Pair (wrap x) (wrap y)
instance (Functor m, Functor n, Coerce(m b)c, Coerce(n a)b) => Coerce((Compose m n) a) c where
down = down . fmap down . getCompose
up = Compose . fmap up . up
unwrap = unwrap . fmap unwrap . getCompose
wrap = Compose . fmap wrap . wrap
instance Coerce (m a) c => Coerce (WrappedMonad m a) c where
down = down . unwrapMonad
up = WrapMonad . up
unwrap = unwrap . unwrapMonad
wrap = WrapMonad . wrap
instance Coerce (State s a) (s -> (a,s)) where
down = runState
up = state
unwrap = runState
wrap = state