Playing with lenses

Label.hs

{-# LANGUAGE TypeOperators, RankNTypes, TupleSections #-}

import Prelude hiding ((^))
import Control.Monad

import Lens

-- Like fclabels, but with failure in get to allow for labels on sum types.
type Label f a = forall r. Lens Maybe Id f f r (a :- r)

label :: (f -> Maybe a) -> (a -> f -> f) -> Label f a
label get set = Lens 
  (\f -> fmap (\a -> (\r -> (a :- r), f)) $ get f)
  (\(a :- r) -> Id (set a, r))

getL :: Label f a -> f -> Maybe a
getL l f = fmap (hhead . ($ ()) . fst) $ fwd l f

setL :: Label f a -> a -> f -> f
setL l a f = ($ f) . fst . unId $ bwd l (a :- ())

modL :: Label f a -> (a -> a) -> f -> f
modL l h f = maybe f (\a -> setL l (h a) f) $ getL l f

(^) :: Label b c -> Label a b -> Label a c
a ^ b = label (getL a <=< getL b) (modL b . setL a)


data Person = Person
  { _name   :: String
  , _age    :: Int
  , _isMale :: Bool
  , _place  :: Place
  } deriving Show

data Place = UnknownPlace | Place
  { _city
  , _country
  , _continent :: String
  } deriving Show

name :: Label Person String
name = label (Just . _name) (\a f -> f { _name = a })

age :: Label Person Int
age = label (Just . _age) (\a f -> f { _age = a })

place :: Label Person Place
place = label (Just . _place) (\a f -> f { _place = a })

city :: Label Place String
city = label get set
  where
    get UnknownPlace = Nothing
    get p = Just (_city p)
    set _ UnknownPlace = UnknownPlace
    set s p = p { _city = s }

jan :: Person
jan = Person "Jan" 71 True (Place "Utrecht" "The Netherlands" "Europe")

moveToAmsterdam :: Person -> Person
moveToAmsterdam = setL (city ^ place) "Amsterdam"

ageAndCity :: Label Person (Int, String)
ageAndCity = tuple .-. age .-. (city ^ place)

Lens.hs

{-# LANGUAGE TypeOperators, RankNTypes, TupleSections #-}
module Lens where

import Control.Monad
import Data.Monoid
import Data.Maybe (fromJust)
import Control.Arrow (first, second)

infixr 8 :-
infixr 8 .-.

data Lens mf mb a a' b b' = Lens 
  { fwd :: a' -> mf (b -> b', a)
  , bwd :: b' -> mb (a -> a', b)
  }

data a :- b = a :- b deriving (Eq, Show)

hhead :: (a :- b) -> a
hhead (a :- b) = a

inv :: Lens mf mb a a' b b' -> Lens mb mf b b' a a'
inv l = Lens (bwd l) (fwd l)

-- id
i :: (Monad mf, Monad mb) => Lens mf mb a a b b
i = Lens
  (\a -> return (id, a))
  (\b -> return (id, b))

-- horizontal composition
(.-.) :: (Monad mf, Monad mb) => Lens mf mb a' a'' b' b'' -> Lens mf mb a a' b b' -> Lens mf mb a a'' b b''
~(Lens f1 b1) .-. ~(Lens f2 b2) = Lens 
  (compose (.) f1 f2)
  (compose (.) b1 b2)

compose :: Monad m => (a -> b -> c) -> (i -> m (a, j)) -> (j -> m (b, k)) -> (i -> m (c, k))
compose op mf mg s = do
  (f, s') <- mf s
  (g, s'') <- mg s'
  return (f `op` g, s'')

instance (MonadPlus mf, MonadPlus mb) => Monoid (Lens mf mb a a' b b') where
  mempty = Lens (const mzero) (const mzero)
  ~(Lens f1 b1) `mappend` ~(Lens f2 b2) = Lens
    (\s -> f1 s `mplus` f2 s)
    (\s -> b1 s `mplus` b2 s)

duckb :: (Monad mf, Monad mb) => Lens mf mb a a' b b' -> Lens mf mb a a' (h :- b) (h :- b')
duckb l = Lens
  (\a' -> liftM (first $ \f (h :- b) -> h :- f b) $ fwd l a')
  (\(h :- b') -> liftM (second (h :-)) $ bwd l b')

ducka :: (Monad mf, Monad mb) => Lens mf mb a a' b b' -> Lens mf mb (h :- a) (h :- a') b b'
ducka = inv . duckb . inv

newtype Id a = Id { unId :: a }

instance Monad Id where
  return a = Id a
  Id a >>= f = f a

data IsoM m a b = IsoM (a -> b) (b -> m a)

fromIsoM :: (Monad mf, Monad mb) => IsoM mb b b' -> Lens mf mb a a b b'
fromIsoM (IsoM fd bd) = Lens
  (return . (fd,))
  (liftM (id,) . bd)

tuple :: (Monad mf, Monad mb) => Lens mf mb c c (a :- b :- r) ((a, b) :- r)
tuple = fromIsoM $ IsoM
  (\(a :- b :- r) -> (a, b) :- r)
  (\((a, b) :- r) -> return $ a :- b :- r)

Zipper.hs

{-# LANGUAGE TypeOperators, RankNTypes, TupleSections #-}

import Control.Monad

import Lens

type Zipper a a' b b' = Lens Maybe Id a' a b b'

focus :: Zipper (f :- r) r s (f :- s)
focus = Lens
  (\(f :- r) -> Just (\s -> f :- s, r))
  (\(f :- s) -> Id   (\r -> f :- r, s))

modify :: (x -> x) -> Zipper (t :- ()) r () (x :- ()) -> t -> t
modify f z t = maybe t id $ do
  (b2tb, ctx) <- fwd z (t :- ())
  return . hhead . ($ ctx) . fst . unId $ bwd z (f (hhead (b2tb ())) :- ())

-- vertical composition (Zipper specific or not?)
(.|.) :: (Monad mf, Monad mb)
      => Lens mf mb b b' a a'
      -> Lens mf Id c c' c b'
      -> Lens mf mb b c' a a'
ba .|. cb = Lens
  (\c -> fwd cb c >>= \(c'2b', c') -> fwd ba (c'2b' c'))
  (\a' -> bwd ba a' >>= \(b'2b, a) -> return ((\b' -> let Id (c'2c, c') = bwd cb (b'2b b') in c'2c c'), a))


data Tree a = Leaf | Node a (Tree a) (Tree a) deriving (Show)

node :: Zipper (Tree a :- t) (a :- Tree a :- Tree a :- t) s s
node = inv . fromIsoM $ IsoM to from where
  to   (a :- l :- r :- t) = Node a l r :- t
  from (Node a l r :- t) = return (a :- l :- r :- t)
  from (Leaf :- _) = mzero

leaf :: Zipper (Tree a :- t) t s s
leaf = inv . fromIsoM $ IsoM to from where
  to   t = Leaf :- t
  from (Leaf :- t) = return t
  from (Node _ _ _ :- t) = mzero
  

goValue :: Zipper (Tree a :- r) (Tree a :- Tree a :- r) s (a :- s)
goValue = node .-. focus

goLeft :: Zipper (Tree a :- r) (a :- Tree a :- r) s (Tree a :- s)
goLeft = node .-. ducka focus

goRight :: Zipper (Tree a :- r) (a :- Tree a :- r) s (Tree a :- s)
goRight = node .-. ducka (ducka focus)


freeTree :: Tree Char  
freeTree =   
    Node 'P'  
        (Node 'O'  
            (Node 'L'  
                (Node 'N' Leaf Leaf)  
                (Node 'T' Leaf Leaf)  
            )  
            (Node 'Y'  
                (Node 'S' Leaf Leaf)  
                (Node 'A' Leaf Leaf)  
            )  
        )  
        (Node 'L'  
            (Node 'W'  
                (Node 'C' Leaf Leaf)  
                (Node 'R' Leaf Leaf)  
            )  
            (Node 'A'  
                (Node 'A' Leaf Leaf)  
                (Node 'C' Leaf Leaf)  
            )  
        )

rl :: Zipper (Tree a :- r) (Tree a :- Tree a :- a :- Tree a :- a :- Tree a :- r) s (a :- s)
rl = goValue .|. goLeft .|. goRight

test = modify (const 'P') rl freeTree