StoreによるLensの定義(Scalaと一緒？)

gistfile1.hs

module Main where
import Prelude hiding ((.), id)
import Control.Category
import Control.Applicative

---------
-- Test

main :: IO ()
main = do
  let sample = (1, (True, "Hoge"))
  print $ getL _1 sample
  print $ getL (_1._2) sample
  print $ getL (_2._2) sample
  print $ setL _1 999 sample 
  print $ setL (_1._2) False sample
  print $ setL (_2._2) "Piyo" sample

---------
-- Comonad

class Functor w => Comonad w where
  extract :: w a -> a
  duplicate :: w a -> w (w a)
  extend :: (w a -> b) -> w a -> w b

  extend f = fmap f . duplicate
  duplicate = extend id

(=>>) :: Comonad w => w a -> (w a -> b) -> w b
(=>>) = flip extend

---------
-- Store

data Store s a = Store { peek :: s -> a, pos :: s }

-- 無くても使える(´・ω・`)
instance Functor (Store s) where
  fmap f s = Store 
    { peek = f . peek s 
    , pos = pos s 
    }
instance Comonad (Store s) where
  extract s = peek s $ pos s
  duplicate s = Store
    { peek = Store $ peek s
    , pos = pos s
    }

---------
-- Lens

newtype Lens a b = Lens { runLens :: a -> Store b a }

instance Category Lens where
  id = Lens $ \x -> Store id x
  l . r = Lens $ \x -> let
    rStore = runLens r x
    lStore = runLens l $ pos rStore
    in Store (peek rStore . peek lStore) $ pos lStore

lens :: (a -> b) -> (b -> a -> a) -> Lens a b
lens get set = Lens $ \x -> Store 
  { peek = (`set` x)
  , pos = get x
  }

getL :: Lens a b -> a -> b
getL l x = pos $ runLens l x

setL :: Lens a b -> b -> a -> a
setL l n o = peek (runLens l o) n

_1 :: Lens (a, b) a
_1 = lens fst $ \x t -> (x, snd t)

_2 :: Lens (a, b) b
_2 = lens snd $ \x t -> (fst t, x)