{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} #ifdef TRUSTWORTHY {-# LANGUAGE Trustworthy #-} #endif ----------------------------------------------------------------------------- -- | -- Module : Control.Lens.Internal.Level -- Copyright : (C) 2012-2014 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett <ekmett@gmail.com> -- Stability : experimental -- Portability : non-portable -- -- This module provides implementation details of the combinators in -- "Control.Lens.Level", which provides for the breadth-first 'Control.Lens.Traversal.Traversal' of -- an arbitrary 'Control.Lens.Traversal.Traversal'. ---------------------------------------------------------------------------- module Control.Lens.Internal.Level ( -- * Levels Level(..) , Deepening(..), deepening , Flows(..) ) where import Control.Applicative import Control.Category import Control.Comonad import Data.Foldable import Data.Functor.Apply import Data.Int import Data.Semigroup import Data.Traversable import Data.Word import Prelude hiding ((.),id) ------------------------------------------------------------------------------ -- Levels ------------------------------------------------------------------------------ -- | This data type represents a path-compressed copy of one level of a source -- data structure. We can safely use path-compression because we know the depth -- of the tree. -- -- Path compression is performed by viewing a 'Level' as a PATRICIA trie of the -- paths into the structure to leaves at a given depth, similar in many ways -- to a 'Data.IntMap.IntMap', but unlike a regular PATRICIA trie we do not need -- to store the mask bits merely the depth of the fork. -- -- One invariant of this structure is that underneath a 'Two' node you will not -- find any 'Zero' nodes, so 'Zero' can only occur at the root. data Level i a = Two {-# UNPACK #-} !Word !(Level i a) !(Level i a) | One i a | Zero deriving (Eq,Ord,Show,Read) -- | Append a pair of 'Level' values to get a new 'Level' with path compression. -- -- As the 'Level' type is user-visible, we do not expose this as an illegal -- 'Semigroup' instance, and just use it directly in 'Deepening' as needed. lappend :: Level i a -> Level i a -> Level i a lappend Zero Zero = Zero lappend Zero r@One{} = r lappend l@One{} Zero = l lappend Zero (Two n l r) = Two (n + 1) l r lappend (Two n l r) Zero = Two (n + 1) l r lappend l r = Two 0 l r {-# INLINE lappend #-} instance Functor (Level i) where fmap f = go where go (Two n l r) = Two n (go l) (go r) go (One i a) = One i (f a) go Zero = Zero {-# INLINE fmap #-} instance Foldable (Level i) where foldMap f = go where go (Two _ l r) = go l `mappend` go r go (One _ a) = f a go Zero = mempty {-# INLINE foldMap #-} instance Traversable (Level i) where traverse f = go where go (Two n l r) = Two n <$> go l <*> go r go (One i a) = One i <$> f a go Zero = pure Zero {-# INLINE traverse #-} ------------------------------------------------------------------------------ -- Generating Levels ------------------------------------------------------------------------------ -- | This is an illegal 'Monoid' used to construct a single 'Level'. newtype Deepening i a = Deepening { runDeepening :: forall r. Int -> (Level i a -> Bool -> r) -> r } instance Semigroup (Deepening i a) where Deepening l <> Deepening r = Deepening $ \ n k -> case n of 0 -> k Zero True _ -> let n' = n - 1 in l n' $ \x a -> r n' $ \y b -> k (lappend x y) (a || b) {-# INLINE (<>) #-} -- | This is an illegal 'Monoid'. instance Monoid (Deepening i a) where mempty = Deepening $ \ _ k -> k Zero False {-# INLINE mempty #-} mappend (Deepening l) (Deepening r) = Deepening $ \ n k -> case n of 0 -> k Zero True _ -> let n' = n - 1 in l n' $ \x a -> r n' $ \y b -> k (lappend x y) (a || b) {-# INLINE mappend #-} -- | Generate the leaf of a given 'Deepening' based on whether or not we're at the correct depth. deepening :: i -> a -> Deepening i a deepening i a = Deepening $ \n k -> k (if n == 0 then One i a else Zero) False {-# INLINE deepening #-} ------------------------------------------------------------------------------ -- Reassembling Levels ------------------------------------------------------------------------------ -- | This is an illegal 'Applicative' used to replace the contents of a list of consecutive 'Level' values -- representing each layer of a structure into the original shape that they were derived from. -- -- Attempting to 'Flow' something back into a shape other than the one it was taken from will fail. newtype Flows i b a = Flows { runFlows :: [Level i b] -> a } instance Functor (Flows i b) where fmap f (Flows g) = Flows (f . g) {-# INLINE fmap #-} -- | Walk down one constructor in a 'Level', veering left. triml :: Level i b -> Level i b triml (Two 0 l _) = l triml (Two n l r) = Two (n - 1) l r triml x = x {-# INLINE triml #-} -- | Walk down one constructor in a 'Level', veering right. trimr :: Level i b -> Level i b trimr (Two 0 _ r) = r trimr (Two n l r) = Two (n - 1) l r trimr x = x {-# INLINE trimr #-} instance Apply (Flows i b) where Flows mf <.> Flows ma = Flows $ \ xss -> case xss of [] -> mf [] (ma []) (_:xs) -> mf (triml <$> xs) $ ma (trimr <$> xs) {-# INLINE (<.>) #-} -- | This is an illegal 'Applicative'. instance Applicative (Flows i b) where pure a = Flows (const a) {-# INLINE pure #-} Flows mf <*> Flows ma = Flows $ \ xss -> case xss of [] -> mf [] (ma []) (_:xs) -> mf (triml <$> xs) $ ma (trimr <$> xs) {-# INLINE (<*>) #-}