Zipp.hs

{-# language GADTs #-}
{-# language RankNTypes #-}
{-# language NamedFieldPuns #-}

{-
    This is an universal zipper (functional-update iterator) over any recursive
    data structure.
    
    You can enter /any/ data structure 'a' and navigate between recursion points
    "inside" it using 'Lens' a a'-accessors. This also means 'a' can be 'Int'
    and, for instance, some accessor can just add '5' to it.
    
    "Normal" usage is as follows: given binary tree 't', you 'open' it; then yoy can go to
    any of its children using 'poke' (or 'go', if the tree is infinite). You can
    `modify` the node using and then come `back` to 't'. After all these manipulations you
    'close' the iterator and it returns 't' with changes you made at selected child node.
    
    <category-theory>
    Since its lens-bases (accessor-based), it cannot be made a 'Comonad' - since
    lenses form a continuum and therefore cannot be enumerated.
    </category-theory>
    
    I had to depend on @lens@ instead of @microlens@, because only @lens@ provides 'Prism''.
    And without the latter, this zipper has almost no use (unless you navigate infinite
    trees on daily basis).
    
    I may instead put a @Lens.Cut@ module nearby with excerpts from @lens@ package.
-}

module Zipp
    ( -- * The iterator type
      Zipper
      
      -- * Navigation
    , go
    , poke
    , back
    , unsafeBack
    , isAtTop
    
      -- * get access
    , get
    , modify
    
      -- * Constructor/eliminator
    , open
    , close
    )
    where

import Control.Arrow

import Data.List
import qualified Data.List.NonEmpty as NL
import Data.List.NonEmpty (NonEmpty(..))

import Control.Lens hiding (locus)

data Layer a = Layer
    { update :: Setter' a a
    , locus  :: a
    , dirty  :: Bool
    }

-- | Type for iterator.
type Zipper a = NL.NonEmpty (Layer a)

-- | Use a lens to go to child node.
go :: Lens' a a -> Zipper a -> Zipper a
go lens zipper@(Layer {update, locus} :| _) =
    NL.cons
        Layer
            { update = lens
            , locus  = locus^.lens
            , dirty  = False
            }
        zipper

-- | Try going on some non-guarateed path.
poke :: Prism' a a -> Zipper a -> Maybe (Zipper a)
poke prism zipper = do
    dest <- get zipper ^? prism
    return $ 
        NL.cons
            Layer
                { update = prism
                , locus  = dest
                , dirty  = False
                }
            zipper

-- | Undo last 'go' operation. Update child node inside current one.
--
--   Caveat emptor: will not check if we are at the top.
unsafeBack :: Zipper a -> Zipper a
unsafeBack (Layer{dirty, update, locus} :| (layer@Layer {locus = whole, dirty = dirty'} : rest))
    | dirty = (:|)
        layer
            { locus = whole & update.~ locus
            , dirty = dirty || dirty'
            }
        rest

    | otherwise = layer :| rest

-- | Undo last 'go' operation. Update child node inside current one.
back :: Zipper a -> Maybe (Zipper a)
back zipper
    | isAtTop zipper = Nothing
    | otherwise      = Just (unsafeBack zipper)

-- | Check if the iterator gets to top node.
isAtTop :: Zipper a -> Bool
isAtTop (_ :| (_ : _)) = False
isAtTop  _             = True

-- | Return current thing iterator gets to.
get :: Zipper a -> a
get (layer :| _) = locus layer

-- | Perform mutation over a node, mark it as dirty.
--
--   In current implementation cannot be undone.
modify :: (a -> a) -> Zipper a -> Zipper a
modify f (layer :| rest) = (:|)
    layer
        { locus = f (locus layer)
        , dirty = True
        }
    rest

-- | Transform a value into iterator over it.
open :: a -> Zipper a
open whole = (:|)
    Layer
        { update = id
        , locus = whole
        , dirty = False
        }
    []

-- | Apply any delayed writes and return final form of the iterated object.
close :: Zipper a -> a
close zipper = case back zipper of
    Just zipper -> close zipper
    Nothing     -> locus (NL.head zipper)

times n f = go n
  where
    go 0 = id
    go n = go (n - 1) . f

here  :: Lens' [a]  a
there :: Lens' [a] [a]

here  = lens head (\(_ : t) h -> h : t)
there = lens tail (\(h : _) t -> h : t)

main
    = open [1..]
    & times 10000000 (go there)
    & modify (here .~ 42000)
    & close
    & (!! 10000000)
    & print