{-# LANGUAGE CPP #-}{-# LANGUAGE GADTs #-}{-# LANGUAGE TypeFamilies #-}{-# LANGUAGE TypeOperators #-}{-# LANGUAGE EmptyDataDecls #-}{-# LANGUAGE FlexibleContexts #-}{-# LANGUAGE FlexibleInstances #-}{-# LANGUAGE MultiParamTypeClasses #-}#ifdef TRUSTWORTHY{-# LANGUAGE Trustworthy #-}#endif------------------------------------------------------------------------------- |-- Module : Control.Lens.Internal.Zipper-- Copyright : (C) 2012 Edward Kmett-- License : BSD-style (see the file LICENSE)-- Maintainer : Edward Kmett <ekmett@gmail.com>-- Stability : experimental-- Portability : non-portable---- This module provides internal types and functions used in the implementation-- of @Control.Lens.Zipper@. You shouldn't need to import it directly, and the-- exported types can be used to break 'Zipper' invariants.------------------------------------------------------------------------------moduleControl.Lens.Internal.ZipperwhereimportControl.ApplicativeimportControl.CategoryimportControl.MonadimportControl.Lens.ClassesimportControl.Lens.GetterimportControl.Lens.IndexedLensimportControl.Lens.InternalimportControl.Lens.SetterimportControl.Lens.TraversalimportControl.Lens.TypeimportData.MaybeimportPreludehiding((.),id)-- $setup-- >>> import Control.Lens-- >>> import Data.Char------------------------------------------------------------------------------- * Zippers------------------------------------------------------------------------------- | This is used to represent the 'Top' of the 'Zipper'.---- Every 'Zipper' starts with 'Top'.---- /e.g./ @'Top' ':>' a@ is the type of the trivial 'Zipper'.dataTopinfixl9:>-- | This is the type of a 'Zipper'. It visually resembles a \"breadcrumb trail\" as-- used in website navigation. Each breadcrumb in the trail represents a level you-- can move up to.---- This type operator associates to the left, so you can use a type like---- @'Top' ':>' ('String','Double') ':>' 'String' ':>' 'Char'@---- to represent a zipper from @('String','Double')@ down to 'Char' that has an intermediate-- crumb for the 'String' containing the 'Char'.---- You can construct a zipper into *any* data structure with 'zipper'.---- You can repackage up the contents of a zipper with 'rezip'.---- >>> rezip $ zipper 42-- 42---- The combinators in this module provide lot of things you can do to the zipper while you-- have it open.---- Note that a value of type @h ':>' s ':>' a@ doesn't actually contain a value-- of type @h ':>' s@ -- as we descend into a level, the previous level is-- unpacked and stored in 'Coil' form. Only one value of type @_ ':>' _@ exists-- at any particular time for any particular 'Zipper'.datah:>a=Zipper(Coilha)-- The 'Coil' storing the previous levels of the 'Zipper'.{-# UNPACK #-}!Int-- Number of items to the left.[a]-- Items to the left (stored reversed).a-- Focused item.[a]-- Items to the right.-- | This is an alias for '(:>)'. Provided mostly for conveniencetypeZipper=(:>)-- | This represents the type a 'Zipper' will have when it is fully 'Zipped' back up.typefamilyZippedhatypeinstanceZippedTopa=atypeinstanceZipped(h:>s)a=Zippedhs-- | A 'Coil' is a linked list of the levels above the current one. The length-- of a 'Coil' is known at compile time.---- This is part of the internal structure of a zipper. You shouldn't need to manipulate this directly.dataCoil::*->*->*whereCoil::CoilTopaSnoc::Coilhs-- Previous 'Coil'.->SimpleLensLike(Bazaaraa)sa-- The 'Traversal' used to descend into this level (used to build a 'Tape').-- The Zipper above us, unpacked:->{-# UNPACK #-}!Int-- Number of items to the left.->[s]-- Previous level's items to the left (stored reverse).->([a]->s)-- Function to rebuild the previous level's focused item from the entire current level.-- (Since the current level always has a focus, the list must be nonempty.)->[s]-- Previous level's items to the right.->Coil(h:>s)a-- | This 'Lens' views the current target of the 'Zipper'.---- A 'Tape' that can be used to get to the current location is available as the index of this 'Lens'.focus::SimpleIndexedLens(Tape(h:>a))(h:>a)afocus=indexed$\f(Zipperhnlar)->(\a'->Zipperhnla'r)<$>f(Tape(peelh)n)a{-# INLINE focus #-}-- | Construct a 'Zipper' that can explore anything, and start it at the top.zipper::a->Top:>azippera=ZipperCoil0[]a[]{-# INLINE zipper #-}-- | Return the index into the current 'Traversal' within the current level of the 'Zipper'.---- @'jerkTo' ('tooth' l) l = Just'@---- Mnemonically, zippers have a number of 'teeth' within each level. This is which 'tooth' you are currently at.tooth::(h:>a)->Inttooth(Zipper_n___)=n{-# INLINE tooth #-}-- | Move the 'Zipper' 'upward', closing the current level and focusing on the parent element.---- NB: Attempts to move upward from the 'Top' of the 'Zipper' will fail to typecheck.--upward::(h:>s:>a)->h:>supward(Zipper(Snoch_unulskurs)_lsxrs)=Zipperhunulsuxurswhereux=k(reverseListls++x:rs){-# INLINE upward #-}-- | Jerk the 'Zipper' one 'tooth' to the 'rightward' within the current 'Lens' or 'Traversal'.---- Attempts to move past the start of the current 'Traversal' (or trivially, the current 'Lens')-- will return 'Nothing'.---- >>> isNothing $ zipper "hello" & rightward-- True---- >>> zipper "hello" & fromWithin traverse & rightward <&> view focus-- 'e'---- >>> zipper "hello" & fromWithin traverse & rightward <&> focus .~ 'u' <&> rezip-- "hullo"---- >>> rezip $ zipper (1,2) & fromWithin both & tug rightward & focus .~ 3-- (1,3)rightward::MonadPlusm=>(h:>a)->m(h:>a)rightward(Zipper____[])=mzerorightward(Zipperhnlsa(r:rs))=return(Zipperh(n+1)(a:ls)rrs){-# INLINE rightward #-}-- | Jerk the 'zipper' 'leftward' one 'tooth' within the current 'Lens' or 'Traversal'.---- Attempts to move past the end of the current 'Traversal' (or trivially, the current 'Lens')-- will return 'Nothing'.---- >>> isNothing $ zipper "hello" & leftward-- True-- >>> isNothing $ zipper "hello" & within traverse >>= leftward-- True---- >>> zipper "hello" & within traverse <&> tug leftward-- Just 'h'---- >>> zipper "hello" & fromWithin traverse & tug rightward & tug leftward & view focus-- 'h'leftward::MonadPlusm=>(h:>a)->m(h:>a)leftward(Zipper__[]__)=mzeroleftward(Zipperhn(l:ls)ars)=return(Zipperh(n-1)lsl(a:rs)){-# INLINE leftward #-}-- | Move to the leftmost position of the current 'Traversal'.---- This is just a convenient alias for @'farthest' 'leftward'@.---- >>> zipper "hello" & fromWithin traverse & rightmost & focus .~ 'a' & rezip-- "hella"leftmost::(a:>b)->a:>bleftmost=farthestleftward-- | Move to the rightmost position of the current 'Traversal'.---- This is just a convenient alias for @'farthest' 'rightward'@.---- >>> zipper "hello" & fromWithin traverse & rightmost & focus .~ 'y' & leftmost & focus .~ 'j' & rezip-- "jelly"rightmost::(a:>b)->a:>brightmost=farthestrightward-- | This allows you to safely 'tug leftward' or 'tug rightward' on a 'zipper'. This-- will attempt the move, and stay where it was if it fails.---- The more general signature allows its use in other circumstances, however.---- @'tug' f x ≡ 'fromMaybe' a (f a)@---- >>> fmap rezip $ zipper "hello" & within traverse <&> tug leftward <&> focus .~ 'j'-- "jello"---- >>> fmap rezip $ zipper "hello" & within traverse <&> tug rightward <&> focus .~ 'u'-- "hullo"tug::(a->Maybea)->a->atugfa=fromMaybea(fa){-# INLINE tug #-}-- | This allows you to safely @'tug' 'leftward'@ or @'tug' 'rightward'@ multiple times on a 'zipper',-- moving multiple steps in a given direction and stopping at the last place you-- couldn't move from. This lets you safely move a zipper, because it will stop at either end.---- >>> fmap rezip $ zipper "stale" & within traverse <&> tugs rightward 2 <&> focus .~ 'y'-- "style"---- >>> rezip $ zipper "want" & fromWithin traverse & tugs rightward 2 & focus .~ 'r' & tugs leftward 100 & focus .~ 'c'-- "cart"tugs::(a->Maybea)->Int->a->atugsfn0|n0<0=error"tugs: negative tug count"|otherwise=gon0wherego0a=agona=maybea(go(n-1))(fa){-# INLINE tugs #-}-- | Move in a direction as far as you can go, then stop there.---- This repeatedly applies a function until it returns Nothing, and then returns the last answer.---- >>> fmap rezip $ zipper ("hello","world") & downward _1 & within traverse <&> rightmost <&> focus .~ 'a'-- ("hella","world")---- >>> rezip $ zipper ("hello","there") & fromWithin (both.traverse) & rightmost & focus .~ 'm'-- ("hello","therm")farthest::(a->Maybea)->a->afarthestf=gowheregoa=maybeago(fa){-# INLINE farthest #-}-- | This allows for you to repeatedly pull a 'zipper' in a given direction, failing if it falls off the end.---- >>> isNothing $ zipper "hello" & within traverse >>= jerks rightward 10-- True---- >>> fmap rezip $ zipper "silly" & within traverse >>= jerks rightward 3 <&> focus .~ 'k'-- "silky"jerks::Monadm=>(a->ma)->Int->a->majerksfn0|n0<0=fail"jerks: negative jerk count"|otherwise=gon0wherego0a=returnagona=fa>>=go(n-1){-# INLINE jerks #-}-- | Returns the number of siblings at the current level in the 'zipper'.---- @'teeth' z '>=' 1@---- /NB:/ If the current 'Traversal' targets an infinite number of elements then this may not terminate.---- >>> zipper ("hello","world") & teeth-- 1---- >>> zipper ("hello","world") & fromWithin both & teeth-- 2---- >>> zipper ("hello","world") & downward _1 & teeth-- 1---- >>> zipper ("hello","world") & downward _1 & fromWithin traverse & teeth-- 5---- >>> zipper ("hello","world") & fromWithin (_1.traverse) & teeth-- 5---- >>> zipper ("hello","world") & fromWithin (both.traverse) & teeth-- 10teeth::(h:>a)->Intteeth(Zipper_n__rs)=n+1+lengthrs{-# INLINE teeth #-}-- | Move the 'Zipper' horizontally to the element in the @n@th position in the-- current level, absolutely indexed, starting with the 'farthest' 'leftward' as @0@.---- This returns 'Nothing' if the target element doesn't exist.---- @'jerkTo' n ≡ 'jerks' 'rightward' n . 'farthest' 'leftward'@---- >>> isNothing $ zipper "not working." & jerkTo 20-- True-- >>> isNothing $ zipper "not working." & fromWithin traverse & jerkTo 20-- True---- >>> fmap rezip $ zipper "not working" & within traverse >>= jerkTo 2 <&> focus .~ 'w'-- Just "now working"jerkTo::MonadPlusm=>Int->(h:>a)->m(h:>a)jerkTonz=casecompareknofLT->jerksrightward(n-k)zEQ->returnzGT->jerksleftward(k-n)zwherek=toothz{-# INLINE jerkTo #-}-- | Move the 'Zipper' horizontally to the element in the @n@th position of the-- current level, absolutely indexed, starting with the 'farthest' 'leftward' as @0@.---- If the element at that position doesn't exist, then this will clamp to the range @0 <= n < 'teeth'@.---- @'tugTo' n ≡ 'tugs' 'rightward' n . 'farthest' 'leftward'@---- >>> rezip $ zipper "not working." & fromWithin traverse & tugTo 100 & focus .~ '!' & tugTo 1 & focus .~ 'u'-- "nut working!"tugTo::Int->(h:>a)->h:>atugTonz=casecompareknofLT->tugsrightward(n-k)zEQ->zGT->tugsleftward(k-n)zwherek=toothz{-# INLINE tugTo #-}-- | Step down into a 'Lens'. This is a constrained form of 'fromWithin' for when you know-- there is precisely one target that can never fail.---- @-- 'downward' :: 'Simple' 'Lens' s a -> (h :> s) -> h :> s :> a-- 'downward' :: 'Simple' 'Iso' s a -> (h :> s) -> h :> s :> a-- @downward::SimpleLensLike(Contextaa)sa->(h:>s)->h:>s:>adownwardl(Zipperhnlssrs)=casel(Contextid)sofContextka->Zipper(Snoch(cloneLensl)nls(k.head)rs)0[]a[]{-# INLINE downward #-}-- | Step down into the 'leftmost' entry of a 'Traversal'.---- @-- 'within' :: 'Simple' 'Traversal' s a -> (h :> s) -> Maybe (h :> s :> a)-- 'within' :: 'Simple' 'Lens' s a -> (h :> s) -> Maybe (h :> s :> a)-- 'within' :: 'Simple' 'Iso' s a -> (h :> s) -> Maybe (h :> s :> a)-- @within::MonadPlusm=>SimpleLensLike(Bazaaraa)sa->(h:>s)->m(h:>s:>a)withinl(Zipperhnlssrs)=casepartsOf'l(Contextid)sofContext_[]->mzeroContextk(a:as)->return(Zipper(Snochlnlskrs)0[]aas){-# INLINE within #-}-- | Step down into every entry of a 'Traversal' simultaneously.---- >>> zipper ("hello","world") & withins both >>= leftward >>= withins traverse >>= rightward <&> focus %~ toUpper <&> rezip-- [("hEllo","world"),("heLlo","world"),("helLo","world"),("hellO","world")]---- @-- 'withins' :: 'Simple' 'Traversal' s a -> (h :> s) -> [h :> s :> a]-- 'withins' :: 'Simple' 'Lens' s a -> (h :> s) -> [h :> s :> a]-- 'withins' :: 'Simple' 'Iso' s a -> (h :> s) -> [h :> s :> a]-- @withins::SimpleLensLike(Bazaaraa)sa->(h:>s)->[h:>s:>a]withinsl(Zipperhnlssrs)=casepartsOf'l(Contextid)sofContextkys->gok[]yswheregokxs(y:ys)=Zipper(Snochlnlskrs)0xsyys:gok(y:xs)ysgo__[]=[]-- | Unsafely step down into a 'Traversal' that is /assumed/ to be non-empty.---- If this invariant is not met then this will usually result in an error!---- @-- 'fromWithin' :: 'Simple' 'Traversal' s a -> (h :> s) -> h :> s :> a-- 'fromWithin' :: 'Simple' 'Lens' s a -> (h :> s) -> h :> s :> a-- 'fromWithin' :: 'Simple' 'Iso' s a -> (h :> s) -> h :> s :> a-- @---- You can reason about this function as if the definition was:---- @'fromWithin' l ≡ 'fromJust' '.' 'within' l@---- but it is lazier in such a way that if this invariant is violated, some code-- can still succeed if it is lazy enough in the use of the focused value.fromWithin::SimpleLensLike(Bazaaraa)sa->(h:>s)->h:>s:>afromWithinl(Zipperhnlssrs)=casepartsOf'l(Contextid)sofContextk~(a:as)->Zipper(Snochlnlskrs)0[]aas{-# INLINE fromWithin #-}-- | This enables us to pull the 'Zipper' back up to the 'Top'.classZippinghawhererecoil::Coilha->[a]->ZippedhainstanceZippingTopawhererecoilCoil=head{-# INLINE recoil #-}instanceZippinghs=>Zipping(h:>s)awhererecoil(Snoch__lskrs)as=recoilh(reverseListls++kas:rs){-# INLINE recoil #-}-- | Close something back up that you opened as a 'Zipper'.rezip::Zippingha=>(h:>a)->Zippedharezip(Zipperh_lsars)=recoilh(reverseListls++a:rs){-# INLINE rezip #-}-- | Extract the current 'focus' from a 'Zipper' as a 'Context'focusedContext::Zippingha=>(h:>a)->Contextaa(Zippedha)focusedContextz=Context(\a->z&focus.~a&rezip)(z^.focus)------------------------------------------------------------------------------- * Tapes------------------------------------------------------------------------------- | A 'Tape' is a recorded path through the 'Traversal' chain of a 'Zipper'.dataTapekwhereTape::Trackha->{-# UNPACK #-}!Int->Tape(h:>a)-- | Save the current path as as a 'Tape' we can play back later.saveTape::(h:>a)->Tape(h:>a)saveTape(Zipperhn___)=Tape(peelh)n{-# INLINE saveTape #-}-- | Restore ourselves to a previously recorded position precisely.---- If the position does not exist, then fail.restoreTape::MonadPlusm=>Tape(h:>a)->Zippedha->m(h:>a)restoreTape(Tapehn)=restoreTrackh>=>jerksrightwardn{-# INLINE restoreTape #-}-- | Restore ourselves to a location near our previously recorded position.---- When moving left to right through a 'Traversal', if this will clamp at each level to the range @0 <= k < teeth@,-- so the only failures will occur when one of the sequence of downward traversals find no targets.restoreNearTape::MonadPlusm=>Tape(h:>a)->Zippedha->m(h:>a)restoreNearTape(Tapehn)a=liftM(tugsrightwardn)(restoreNearTrackha){-# INLINE restoreNearTape #-}-- | Restore ourselves to a previously recorded position.---- This *assumes* that nothing has been done in the meantime to affect the existence of anything on the entire path.---- Motions leftward or rightward are clamped, but all traversals included on the 'Tape' are assumed to be non-empty.---- Violate these assumptions at your own risk!unsafelyRestoreTape::Tape(h:>a)->Zippedha->h:>aunsafelyRestoreTape(Tapehn)=unsafelyRestoreTrackh>>>tugsrightwardn{-# INLINE unsafelyRestoreTape #-}------------------------------------------------------------------------------- * Tracks------------------------------------------------------------------------------- | This is used to peel off the path information from a 'Coil' for use when saving the current path for later replay.peel::Coilha->TrackhapeelCoil=Trackpeel(Snochln___)=Fork(peelh)nl-- | The 'Track' forms the bulk of a 'Tape'.dataTrack::*->*->*whereTrack::TrackTopaFork::Trackhs->{-# UNPACK #-}!Int->SimpleLensLike(Bazaaraa)sa->Track(h:>s)a-- | Restore ourselves to a previously recorded position precisely.---- If the position does not exist, then fail.restoreTrack::MonadPlusm=>Trackha->Zippedha->m(h:>a)restoreTrackTrack=return.zipperrestoreTrack(Forkhnl)=restoreTrackh>=>jerksrightwardn>=>withinl-- | Restore ourselves to a location near our previously recorded position.---- When moving leftward to rightward through a 'Traversal', if this will clamp at each level to the range @0 <= k < teeth@,-- so the only failures will occur when one of the sequence of downward traversals find no targets.restoreNearTrack::MonadPlusm=>Trackha->Zippedha->m(h:>a)restoreNearTrackTrack=return.zipperrestoreNearTrack(Forkhnl)=restoreNearTrackh>=>tugsrightwardn>>>withinl-- | Restore ourselves to a previously recorded position.---- This *assumes* that nothing has been done in the meantime to affect the existence of anything on the entire path.---- Motions leftward or rightward are clamped, but all traversals included on the 'Tape' are assumed to be non-empty.---- Violate these assumptions at your own risk!unsafelyRestoreTrack::Trackha->Zippedha->h:>aunsafelyRestoreTrackTrack=zipperunsafelyRestoreTrack(Forkhnl)=unsafelyRestoreTrackh>>>tugsrightwardn>>>fromWithinl------------------------------------------------------------------------------- * Helper functions------------------------------------------------------------------------------- | Reverse a list.---- GHC doesn't optimize @reverse []@ into @[]@, so we'll nudge it with our own-- reverse function.---- This is relevant when descending into a lens, for example -- we know the-- unzipped part of the level will be empty.reverseList::[a]->[a]reverseList[]=[]reverseList(x:xs)=go[x]xswheregoa[]=agoa(y:ys)=go(y:a)ys{-# INLINE reverseList #-}