LoginSignup
18

More than 5 years have passed since last update.

Contravariant なんて要らんかったんや!

Last updated at Posted at 2013-04-08
ContraFunctor.hs
-- 標準の Data.Functor.Functor では反変関手を包括できないので Contravariant とい
-- う別の種類の関手が定義されてる。でも本当はそんな余分な定義は要らないんだ。
-- 全部 Functor に一元化できる。そう、Control.Category ならね。

{-# LANGUAGE MultiParamTypeClasses, TypeOperators, TypeSynonymInstances,
             InstanceSigs, FlexibleInstances, ScopedTypeVariables,
             TypeFamilies, FlexibleContexts #-}
import Control.Category
import Prelude hiding ((.), id, Functor(..))

import Control.Arrow (Arrow(..))

-- [圏論セットアップ]

-- 圏は、hom を決めると他のもの (対象の集合とか、射の型とか) が芋づる式に決まる
-- ので hom を圏そのものと見なして良い。これが Control.Category の定義。
{-
class Category hom where
    id :: hom a a
    (.) :: hom b c -> hom a b -> hom a c
-}

-- 例えば Hask では hom a b は単に (a -> b) の事。インスタンスは
-- Control.Category で宣言されてる。
type Hask = (->)

-- Hom が圏そのものとみなすと、Hask^op は単に <- という型構築子になる。newtype
-- 挟まないとインスタンスとか書けないのがちょっと残念。Ticket #785 参照。
-- http://hackage.haskell.org/trac/ghc/ticket/785
newtype (:<-) a b = HaskOp (b -> a)
type HaskOp = (:<-)
instance Category HaskOp where
    id = HaskOp id
    HaskOp f . HaskOp g = HaskOp (g . f)


-- [関手の定義]

-- 圏 hom1 から hom2 への関手。
class (Category hom1, Category hom2) => Functor f hom1 hom2 where
    fmap :: hom1 a b -> hom2 (f a) (f b)


-- [関手の例]

-- 共変関手の例: みんな大好きリスト関手
instance Functor [] Hask Hask where
    fmap :: (a -> b) -> ([a] -> [b])
    fmap = map

-- 反変関手の例: 反変 hom 関手
instance Functor ((:<-) ans) HaskOp Hask where
    fmap :: (a :<- b) -> ((ans :<- a) -> (ans :<- b))
    fmap = (.)
    -- 注: ↑は↓に同じ
    -- fmap (HaskOp f) (HaskOp g) = HaskOp $ g.f


-- [双関手]

-- 双関手は普通に定義すると Functor とは別物になって、例えばこんなんなる。
class (Category hom1, Category hom2, Category hom3) =>
    Bifunctor f hom1 hom2 hom3 where
    bimap :: hom1 a b -> hom2 c d -> hom3 (f a c) (f b d)

-- 共変双関手の例:
instance Bifunctor (,) Hask Hask Hask where
    bimap :: (a -> b) -> (c -> d) -> ((a,c) -> (b,d))
    bimap f g (x,y) = (f x, g y)
instance Bifunctor Either Hask Hask Hask where
    bimap :: (a -> b) -> (c -> d) -> (Either a c -> Either b d)
    bimap f g = either (Left . f) (Right . g)

-- 左引数だけ反変な関手 (profunctor) の例:
instance Bifunctor (->) HaskOp Hask Hask where
    bimap :: (a :<- b) -> (c -> d) -> ((a -> c) -> (b -> d))
    bimap (HaskOp f) g = (g.) . (.f)

-- Arrow は profunctor の特殊な場合。
instance Arrow arr => Bifunctor arr HaskOp Hask Hask where
    bimap :: (a :<- b) -> (c -> d) -> (arr a c -> arr b d)
    bimap (HaskOp f) g = (arr g <<<) . (<<< arr f)

-- で、この双関手というのはアンカリーすると普通の関手の一種と見なすことができる
-- ので厳密には Bifunctor という別の定義は必要ない。…けど、以下に見られるように
-- newtype やら型族の嵐で色々めんどくさくなるから、実際的には別定義にした方が便
-- 利ぽ。



-- [直積圏]

-- C × D の直積圏では hom は hom (a,b) (c,d) のように引数が対の時にしか定義され
-- てない上、(a -> c) と (b -> d) にバラさないといけないので型族が必要になる。

type family Fst a
type instance Fst (a,b) = a
type family Snd a
type instance Snd (a,b) = b

newtype (:×) hom1 hom2 a b =
    Product (hom1 (Fst a) (Fst b), hom2 (Snd a) (Snd b))

instance (Category hom1, Category hom2) => Category (hom1 :× hom2) where
    id :: (hom1 :× hom2) a a
    id = Product (id, id)
    Product (f1, f2) . Product (g1, g2) = Product (f1.g1, f2.g2)

-- 対角関手
newtype Δ a = Δ (a,a)
type instance Fst (Δ a) = a
type instance Snd (Δ a) = a

instance Category hom => Functor Δ hom (hom :× hom) where
    fmap :: hom a b -> (hom :× hom) (Δ a) (Δ b)
    fmap f = Product (f,f)

-- …とまあ、型宣言はすんなり通るんだけど、型族のせいで Product (f,g) という項か
-- ら :× の最後の二つの型引数を一意に推論できない (例えば Δ 型なのか (,) 型な
-- のか分からない) のでそこら中で型注釈してやる必要がある。(.) とか fmap で項を
-- 簡潔に書くはずが、項よりデカい型を書くハメになるという本末転倒っぷり。
productEg :: (String,Int)
productEg = f $> ()                       -- ("1",1) を返す
    where Product (f,g) $> x = (f x, g x) -- 結果を見せるためだけの補助関数
          f :: (Hask :× Hask) ((), ()) (String, Int)
          f = showFst . plus1 . c0 . toΔ
          toΔ :: (Hask :× Hask) (a, a) (Δ a)
          toΔ = Product (id,id)
          c0 :: Num a => (Hask :× Hask) (Δ ()) (Δ a)
          c0 = fmap $ const 0   -- Product (const 0, const 0) と一緒
          plus1 :: Num a => (Hask :× Hask) (Δ a) (Δ a)
          plus1 = fmap (+1)     -- Product ((+1), (+1)) と一緒
          showFst :: Show a => (Hask :× Hask) (Δ a) (String, a)
          showFst = Product (show, id)

newtype Uncurry f a = Uncurry { getUncurry :: f (Fst a) (Snd a) }

-- で、双関手は全て普通の関手として表現し直せるんだけど、
-- Bifunctor f hom1 hom2 hom3 => Functor (Uncurry f) (hom1 :× hom2) hom3
-- とはならず hom3 = Hask で固定される。理由は Uncurry を剥がしたり貼り直したり
-- する射の実装が hom3 に依存するから。hom3 と一緒に Uncurry / getUncurry に対
-- 応する hom3 の射を取るようにすれば多分一般化出来る (だるいからやってない)。
instance Bifunctor f hom1 hom2 Hask =>
    Functor (Uncurry f) (hom1 :× hom2) Hask where
      fmap :: forall a b. (hom1 :× hom2) a b -> Hask (Uncurry f a) (Uncurry f b)
      fmap (Product (f,g)) = liftUC $ bimap f g

liftUC :: (f (Fst p) (Snd p) -> g (Fst a) (Snd a)) -> Uncurry f p -> Uncurry g a
liftUC f (Uncurry x) = Uncurry $ f x


-- [まとめ]

-- Control.Category と HaskOp 使えば Contravariant は Functor に一元化できる。
-- Bifunctor も直積圏を定義すれば Functor に収容できるけど、newtype とか型注釈と
-- か乱れ飛んでウザい。Contravariant はともかく、Bifunctor の Functor 化は実用的
-- では無さそう。

Register as a new user and use Qiita more conveniently

  1. You get articles that match your needs
  2. You can efficiently read back useful information
  3. You can use dark theme
What you can do with signing up
18