Lens.hs

{-# LANGUAGE RankNTypes                 #-}
{-# LANGUAGE DeriveTraversable          #-}
{-# LANGUAGE DeriveFoldable             #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

module Lens where

type Lens s t a b = forall f. (Functor f)  => (a -> f b) -> s -> f t

type Lens' s a = Lens s s a a -- Simple Lens

data Person = Person { _name      :: String
                     , _address   :: Address
                     , _pets      :: [String]
                     , _relatives :: [Person] }
  deriving (Show)

-- Lenses for Person
name      f (Person n a p r) = fmap (\n' -> Person n' a p r) (f n)
address   f (Person n a p r) = fmap (\a' -> Person n a' p r) (f a)
pets      f (Person n a p r) = fmap (\p' -> Person n a p' r) (f p)
relatives f (Person n a p r) = fmap (\r' -> Person n a p r') (f r)

data Address = Address { _street  :: String
                       , _city    :: String
                       , _zipcode :: Integer }
  deriving (Show)

-- Lenses for Address
street  f (Address s c z) = fmap (\ns -> Address ns c z) (f s)
city    f (Address s c z) = fmap (\nc -> Address s nc z) (f c)
zipcode f (Address s c z) = fmap (\nz -> Address s c nz) (f z)


newtype Identity a = Identity { runIdentity :: a }
  deriving (Show, Foldable, Traversable)

newtype Const a b = Const { getConst :: a } 
  deriving (Show, Foldable, Traversable)

instance Functor Identity where
  fmap f (Identity a) = Identity (f a)

instance Applicative Identity where
  pure a = Identity a
  (<*>) (Identity f) (Identity a) = Identity (f a)

instance Functor (Const a) where
  fmap _ (Const a) = Const a

instance Monoid m => Applicative (Const m) where
  pure _ = Const mempty
  (<*>) (Const a) (Const b) = Const (a `mappend` b)

over :: Lens s t a b -> (a -> b) -> s -> t
over ln f s = runIdentity $ ln (Identity . f) s

view :: Monoid a => Lens s t a b -> s -> a
view ln s = getConst $ ln Const s

set :: Lens s t a b -> b -> s -> t
set ln a = over ln (const a)

_1 :: Lens (a, b) (c, b) a c
_1 f (x, y) = fmap (\a -> (a, y)) (f x)

_2 :: Lens (b, a) (b, c) a c
_2 f (x, y) = fmap (\a -> (x, a)) (f y)

trev = Person "Trevor" (Address "12257 SW 11th" "Yukon" 73099) critters [dad, mom]
  where
    critters        = ["Ace", "Moe", "Devon"]
    parentsCritters = ["Bailey", "Sadie", "ScardyCat"]
    dad             = Person "Doug" (Address "8525 NW 23rd" "OKC" 73127) parentsCritters []
    mom             = Person "Lou"  (Address "8525 NW 23rd" "OKC" 73127) parentsCritters []

You can use this like the following view zipcode trev