Distribution/Compat/Lens.hs

    {-# LANGUAGE RankNTypes #-}
    -- | This module provides very basic lens functionality, without extra dependencies.
    --
    -- For the documentation of the combinators see <http://hackage.haskell.org/package/lens lens> package.
    -- This module uses the same vocabulary.
    module Distribution.Compat.Lens (
        -- * Types
        Lens,
        Lens',
        Traversal,
        Traversal',
        -- ** LensLike
        LensLike,
        LensLike',
        -- ** rank-1 types
        Getting,
        AGetter,
        ASetter,
        ALens,
        ALens',
        -- * Getter
        view,
        use,
        to,
        -- * Setter
        set,
        over,
        -- * Fold
        toDListOf,
        toListOf,
        toSetOf,
        -- * Traversal
        traversed,
        filtered,
        -- * Lens
        cloneLens,
        aview,
        non,
        -- * Common lenses
        _1, _2,
        -- * Operators
        (&),
        (^.),
        (.~), (?~), (%~),
        (.=), (?=), (%=),
        (^#),
        (#~), (#%~),
        -- * Internal Comonads
        Pretext (..),
        -- * Cabal developer info
        -- $development
        ) where

    import Prelude()
    import Distribution.Compat.Prelude

    import Control.Applicative (Const (..))
    import Data.Functor.Identity (Identity (..))
    import Control.Monad.State.Class (MonadState (..), gets, modify)
    import Unsafe.Coerce

    import qualified Distribution.Compat.DList as DList
    import qualified Data.Set as Set

    -------------------------------------------------------------------------------
    -- Types
    -------------------------------------------------------------------------------

    type LensLike  f s t a b = (a -> f b) -> s -> f t
    type LensLike' f s   a   = (a -> f a) -> s -> f s

    type Lens      s t a b = forall f. Functor f     => LensLike f s t a b
    type Traversal s t a b = forall f. Applicative f => LensLike f s t a b

    type Lens'      s a = Lens s s a a
    type Traversal' s a = Traversal s s a a

    type Getting r s a = LensLike (Const r) s s a a

    type AGetter s   a   = LensLike (Const a)     s s a a  -- this doens't exist in 'lens'
    type ASetter s t a b = LensLike Identity      s t a b
    type ALens   s t a b = LensLike (Pretext a b) s t a b

    type ALens' s a = ALens s s a a

    -------------------------------------------------------------------------------
    -- Getter
    -------------------------------------------------------------------------------

    view :: Getting a s a -> s ->  a
    view l s = getConst (l Const s)
    {-# INLINE view #-}

    use :: MonadState s m => Getting a s a -> m a
    use l = gets (view l)
    {-# INLINE use #-}

    to :: (s -> a) -> AGetter s a
    to k f = (unsafeCoerce :: Const t a -> Const t b) . f . k
    {-# INLINE to #-}

    -------------------------------------------------------------------------------
    -- Setter
    -------------------------------------------------------------------------------

    set :: ASetter s t a  b -> b -> s -> t
    set l x = over l (const x)

    over :: ASetter s t a b -> (a -> b) -> s -> t
    over l f s = runIdentity (l (\x -> Identity (f x)) s)

    -------------------------------------------------------------------------------
    -- Fold
    -------------------------------------------------------------------------------

    toDListOf :: Getting (DList.DList a) s a -> s -> DList.DList a
    toDListOf l s = getConst (l (\x -> Const (DList.singleton x)) s)

    toListOf :: Getting (DList.DList a) s a -> s -> [a]
    toListOf l = DList.runDList . toDListOf l

    toSetOf  :: Getting (Set.Set a) s a -> s -> Set.Set a
    toSetOf l s = getConst (l (\x -> Const (Set.singleton x)) s)

    -------------------------------------------------------------------------------
    -- Traversal
    -------------------------------------------------------------------------------

    filtered :: (a -> Bool) -> Traversal' a a
    filtered p f s = if p s then f s else pure s
    {-# INLINE filtered #-}

    traversed :: Traversable f => Traversal (f a) (f b) a b
    traversed = traverse
    {-# INLINE [0] traversed #-}

    -------------------------------------------------------------------------------
    -- Lens
    -------------------------------------------------------------------------------

    aview :: ALens s t a b -> s -> a
    aview l = pretextPos  . l pretextSell
    {-# INLINE aview #-}

    {-
    lens :: (s -> a) -> (s -> a -> s) -> Lens' s a
    lens sa sbt afb s = sbt s <$> afb (sa s)
    -}

    non :: Eq a => a -> Lens' (Maybe a) a
    non x afb s = f <$> afb (fromMaybe x s)
      where f y = if x == y then Nothing else Just y
    {-# INLINE non #-}

    -------------------------------------------------------------------------------
    -- Common
    -------------------------------------------------------------------------------

    _1 ::  Lens (a, c) (b, c) a b
    _1 f (a, c) = flip (,) c <$> f a

    _2 ::  Lens (c, a) (c, b) a b
    _2 f (c, a) = (,) c <$> f a

    -------------------------------------------------------------------------------
    -- Operators
    -------------------------------------------------------------------------------

    -- | '&' is a reverse application operator
    (&) :: a -> (a -> b) -> b
    (&) = flip ($)
    {-# INLINE (&) #-}
    infixl 1 &

    infixl 8 ^., ^#
    infixr 4 .~, %~, ?~
    infixr 4 #~, #%~
    infixr 4 .=, %=, ?=

    (^.) :: s -> Getting a s a -> a
    s ^. l = getConst (l Const s)
    {-# INLINE (^.) #-}

    (.~) :: ASetter s t a b -> b -> s -> t
    (.~) = set
    {-# INLINE (.~) #-}

    (?~) :: ASetter s t a (Maybe b) -> b -> s -> t
    l ?~ b = set l (Just b)
    {-# INLINE (?~) #-}

    (%~) :: ASetter s t a b -> (a -> b) -> s -> t
    (%~) = over
    {-# INLINE (%~) #-}

    (.=) :: MonadState s m => ASetter s s a b -> b -> m ()
    l .= b = modify (l .~ b)
    {-# INLINE (.=) #-}

    (?=) :: MonadState s m => ASetter s s a (Maybe b) -> b -> m ()
    l ?= b = modify (l ?~ b)
    {-# INLINE (?=) #-}

    (%=) :: MonadState s m => ASetter s s a b -> (a -> b) -> m ()
    l %= f = modify (l %~ f)
    {-# INLINE (%=) #-}

    (^#) :: s -> ALens s t a b -> a
    s ^# l = aview l s

    (#~) :: ALens s t a b -> b -> s -> t
    (#~) l b s = pretextPeek b (l pretextSell s)
    {-# INLINE (#~) #-}

    (#%~) :: ALens s t a b -> (a -> b) -> s -> t
    (#%~) l f s = pretextPeeks f (l pretextSell s)
    {-# INLINE (#%~) #-}

    pretextSell :: a -> Pretext a b b
    pretextSell a = Pretext (\afb -> afb a)
    {-# INLINE pretextSell #-}

    pretextPeeks :: (a -> b) -> Pretext a b t -> t
    pretextPeeks f (Pretext m) = runIdentity $ m (\x -> Identity (f x))
    {-# INLINE pretextPeeks #-}

    pretextPeek :: b -> Pretext a b t -> t
    pretextPeek b (Pretext m) = runIdentity $ m (\_ -> Identity b)
    {-# INLINE pretextPeek #-}

    pretextPos :: Pretext a b t -> a
    pretextPos (Pretext m) = getConst (m Const)
    {-# INLINE pretextPos #-}

    cloneLens :: Functor f => ALens s t a b -> LensLike f s t a b
    cloneLens l f s = runPretext (l pretextSell s) f
    {-# INLINE cloneLens #-}

    -------------------------------------------------------------------------------
    -- Comonads
    -------------------------------------------------------------------------------

    -- | @lens@ variant is also parametrised by profunctor.
    data Pretext a b t = Pretext { runPretext :: forall f. Functor f => (a -> f b) -> f t }

    instance Functor (Pretext a b) where
        fmap f (Pretext pretext) = Pretext (\afb -> fmap f (pretext afb))

    -------------------------------------------------------------------------------
    -- Documentation
    -------------------------------------------------------------------------------

    -- $development
    --
    -- We cannot depend on @template-haskell@, because Cabal is a boot library.
    -- This fact makes defining optics a manual task. Here is a small recipe to
    -- make the process less tedious.
    --
    -- First start a repl
    --
    -- > cabal new-repl Cabal:hackage-tests
    --
    -- Because @--extra-package@ isn't yet implemented, we use a test-suite
    -- with @generics-sop@ dependency.
    --
    -- In the repl, we load a helper script:
    --
    -- > :l ../generics-sop-lens.hs
    --
    -- Now we are set up to derive lenses!
    --
    -- > :m +Distribution.Types.SourceRepo
    -- > putStr $ genericLenses (Proxy :: Proxy SourceRepo)
    --
    -- @
    -- repoKind :: Lens' SourceRepo RepoKind
    -- repoKind f s = fmap (\\x -> s { T.repoKind = x }) (f (T.repoKind s))
    -- \{-# INLINE repoKind #-\}
    -- ...
    -- @
    --
    -- /Note:/ You may need to adjust type-aliases, e.g. `String` to `FilePath`.