-- "Data/Lens/Minimal.hs"  An minimalistic lens library.
-- 
-- Copyright (C) 2008-2015  Ramin Honary.
--
-- "mini-lens" is free software: you can redistribute it and/or modify it under
-- the terms of the GNU General Public License as published by the Free
-- Software Foundation, either version 3 of the License, or (at your option)
-- any later version.

-- | This module defines a very simple 'Lens' data type inspired by Job Varnish's "lenses" package.
--
-- The 'Lens' type aims to provide a very simple improvement on Haskell's record syntax: the idea of
-- composable record accessors called 'Lens'es. With record syntax you can fetch and update a data
-- type like so:
-- 
-- @
-- let previousValue = record1 dat in
--     dat{ record1 = newValue1, record2 = newValue2 }
-- @
--
-- With Minimal 'Lens'es, it is possible to achieve the same thing with the following expression:
--
-- @
-- let previousValue = dat 'Data.Lens.Minimal.Lens.~>' recordName in
--     'with' dat [ record1 'Data.Lens.Minimal.Lens.<~' newValue1, record2 'Data.Lens.Minimal.Lens.<~' newValue2 ]
-- @
--
-- Minimal 'Lens'es can be composed with the 'Control.Category.Category' operators @(.)@,
-- @('Control.Category.<<<')@ and @('Control.Category.>>>')@ so something like this:
--
-- @
-- return $ dat{ record = (\\dat' -> dat'{ subRecord = newValue }) (record dat) }
-- @
--
-- can be simplified to this:
--
-- @
-- return $ 'with' dat [ record 'Control.Category.>>>' subRecord 'Data.Lens.Minimal.Lens.<~' newValue ]
-- @
--
-- or equivalently with the dot operator, which is identical to @('Control.Category.>>>')@ with the
-- arguments flipped:
--
-- @
-- return $ 'with' dat [ subRecord . record 'Data.Lens.Minimal.Lens.<~' newValue ]
-- @
--
-- Fetching values is done with @('Data.Lens.Minimal.Lens.~>')@, which is a left-handed infix operator of
-- precedence 1 so that you can compose 'Lens'es for fetching. The above example with @record@ and
-- @subRecord@ could be fetched like so:
--
-- @
-- return (dat ~> record ~> subRecord)
-- @
--
-- This is reminiscient of popular languages like C/C++ in which you could write the above with a
-- similar expression:
--
-- > return (dat.record.subRecord); // the dot operator in C is of course completely different from Haskell.
--
-- In the hopes of trying to be somewhat consistent with work that has come before mine, I borrowed
-- the terminology for some of these API functions from the "lenses" library, in particular the
-- 'fetch', 'update', and 'alter' functions. However what is called @fromGetSet@ in Job Varnish's
-- Lens library, in this module this function is simply called 'newLens', and has a the monadic
-- version 'newLensM'.
module Data.Lens.Minimal where

import           Prelude hiding ((.), id)

import           Control.Applicative
import           Control.Arrow
import           Control.Category
import           Control.Concurrent.MVar
import           Control.Monad
import           Control.Monad.Except
import           Control.Monad.Identity
import           Control.Monad.State.Lazy

import           Data.Array.IArray
import           Data.Array.IO
import           Data.Array.Unboxed
import qualified Data.IntMap as I
import           Data.IORef
import qualified Data.Map    as M
import           Data.Monoid

----------------------------------------------------------------------------------------------------

-- | A 'Lens' is a 'Control.Monad.State.StateT' monadic function that 'Control.Monad.Trans.lift's a
-- monad @m@, and can perform an update on an element @e@ stored within a container @c@. The
-- container @c@ is the state of the 'Control.Monad.State.StateT' function.
--
-- The monadic function inside of the 'Lens' @newtype@ takes an optional updating function as an
-- argument. If the updating function is not provided then the 'Lens' must perform a 'fetch' from
-- the container @c@; if the updating function is provided then the 'Lens' must perform an 'alter'
-- on the container @c@. The function is but wrapped in a @newtype@ 'Lens' and instantiates
-- 'Control.Category.Category' to make for what I believe is a cleaner function composition
-- semantics, especially in that you can use 'Control.Category.>>>' for 'Lens' composition.
newtype Lens m c e =
  Lens
  { lensStateT :: Maybe (e -> m e) -> StateT c m e 
    -- ^ Lenses perform two possible functions: lookups and updates. If a lens is to be used as an
    -- updating lens, the updating function will be wrapped in the 'Prelude.Just' constructor and
    -- passed to this function. If a lens is to be used as a lookup lens, 'Prelude.Nothing' is
    -- passed to this function.
    --
    -- On receiving 'Prelude.Nothing', this function must return the expected value stored within a
    -- container. For example, a 'Lens' called 'tuple1', which operates on a container type @c@
    -- where @c@ is a tuple, is expected return the first element of the tuple.
    --
    -- On receiving an updater function wrapped in 'Prelude.Just', this function lookup the expected
    -- value in the container, pass the value to the given updater function, and then store the
    -- updated value back into the container.
    --
    -- As a law, passing a non-'Prelude.Nothing' argument should not modify container @c@ at all,
    -- although it is conceivable that, if your container includes something like a "number of times
    -- accessed" counter value, the container @c@ could be updated under these circumstances. But be
    -- warned that this is very bad programming practice.
  }

-- | This is a 'Lens' where the monad must be 'Control.Monad.Identity.Identity'. The advantage of
-- using this over 'Lens' (apart from the fact that it is easier to write it's type in your code) is
-- that it guarantees access to your container must be pure, with no IO.
type PureLens c e = Lens Identity c e

instance Monad m => Category (Lens m) where
  id = newLens id const
  (Lens bc) . (Lens ab) = Lens $ \c -> StateT $ \a -> case c of
    Nothing -> evalStateT (ab Nothing) a >>= evalStateT (bc Nothing) >>= \c -> return (c, a)
    Just  c -> do
      (b, a) <- runStateT (ab  Nothing) a -- fetch b from a
      (c, b) <- runStateT (bc $ Just c) b -- update c into b, updating b
      (_, a) <- runStateT (ab $ Just (return . const b)) a -- update updated b into a
      return (c, a)

-- | This function allows you to construct a new 'Lens' without using a
-- 'Control.Monad.State.Lazy.StateT' transformer. Instead provide two functions, a function that
-- 'fetch's an element @e@ from the container @c@, and a function that 'update's an element @e@ into
-- the container.
newLensM :: Monad m => (c -> m e) -> (e -> c -> m c) -> Lens m c e
newLensM fetch update = Lens $ maybe (get >>= lift . fetch) $ \upd ->
  get >>= \st -> lift (fetch st >>= upd) >>= \o -> lift (update o st) >>= put >> return o

-- | This function is similar to 'newLensM', but the two parameter functions are pure functions.
-- *NOTE:* that the 'Lens' constructed by this function can be used as both a monadic 'Lens' or a
-- 'PureLens', only the 'fetch' and 'update' parameters are pure.
newLens :: Monad m => (c -> e) -> (e -> c -> c) -> Lens m c e
newLens fetch update = newLensM (return . fetch) (\o -> return . update o)

----------------------------------------------------------------------------------------------------

-- | This is defined as @('Prelude.flip' 'pureFetch')@ a left-associative infix operator of
-- precedence 8. On the right of this infix operator is the data from which you want to fetch, on
-- the right is a 'Lens' used to retrieve the data from within it. For example, the expression:
--
-- @
-- someContainer 'Data.Lens.Minilens.~>' getElem
-- @
--
-- will use a lens called @getElem@ to fetch an element from the data structure called
-- @someContainer@.
--
-- It looks and behaves similar to the C/C++ programming language operator @->@. It is left
-- associative so the expression @a~>b~>c~>d@ is the same as @((a ~> b) ~> c) ~> d@, which means you
-- can use this operator to compose 'Lens'es to retrieve elements at arbitrary depth.
--
-- This function requires a 'PureLens', but of course any 'Lens' polymorphic over the monadic type
-- @m@ can be used, automatic type inference will choose to make use of
-- 'Data.Monad.Identity.Identity' if the type is polymorphic.
(~>) :: c -> PureLens c e -> e
(~>) = flip pureFetch
infixl 9 ~>

-- | The 'Data.Lens.Minilens.~>' operator uses a 'Lens' to fetch an element from a container. Often
-- times, it is useful to use the 'Lens' alone using Haskell's infix operator section syntax:
--
-- @
-- getter :: Container -> Element
-- getter container = container'Data.Lens.Minilens.~>'lensToGetElem
-- -- This can be abreviated to:
--
-- getter :: Container -> Element
-- getter = (~> lensToGetElem)
-- @
--
-- It is often useful to use a @getter@ that we see above with 'Data.Functor.Functor's '
-- 'Data.Functor.fmap' infix operator: @('Data.Functor.<$>')@. For example:
--
-- @
-- fmapper :: [Container] -> [Element]
-- fmapper list = (~> lensToGetElem) 'Data.Functor.<$>' list
-- @
--
-- This pattern is used so often that it warrants it's own operator. The 'Data.Lens.Minimal.<$~>'
-- operator uses @('Data.Lens.Minimal.~>)'@ applies a lens to the element of a
-- 'Data.Functor.Functor' using 'Data.Functor.<$>'. So the above @fmapper@ could be written as:
--
-- @
-- fmapper :: [Container] -> [Element]
-- fmapper list = listToGetElem 'Data.Lens.Minimal.<$~>' list
-- @
--
-- which can be further abbreviated to:
--
-- @
-- fmapper :: [Container] -> [Element]
-- fmapper = (listToGetElem 'Data.Lens.Minimal.<$~>')
-- @
(<$~>) :: Functor f => PureLens c e -> f c -> f e
(<$~>) lens f = (~> lens) <$> f

-- | Use a list of updating functions to change elements in a container @c@. The list elements are
-- of type @(c -> c)@, which are usually constructed using 'Lens' operators like
-- @('Data.Lens.Minimal.<~')@ or @('Data.Lens.Minimal.$=')@. For example:
--
-- @
-- moveSoutheast :: Gameboard -> Gameboard
-- moveSoutheast gameboard = 'with' gameboard
--     [ player 'Control.Category.>>>' position 'Control.Category.>>>' northCoord 'Data.Lens.Minimal.$=' 'Prelude.subtract' 1
--     , player 'Control.Category.>>>' position 'Control.Category.>>>' eastCoord 'Data.Lens.Minimal.$=' (+ 1)
--     , player 'Control.Category.>>>' isMyTurn 'Data.Lens.Minimal.<~' False
--     ]
-- @
--
-- However any updating function may be used, not just ones constructed from 'Lens' operators.
--
-- In category theory jargon, 'with' applies a sequence of 'Data.Monoid.Endo'functors (updating
-- functions) to a container @c@. The 'Data.Monoid.Endo'functors are applied in the order they
-- appear in the list from left-to-right. The 'Data.Monoid.mconcat'enation of the 'Data.Monoid.Dual'
-- of each 'Data.Monoid.Endo'functor in the list @[c -> c]@ is applied to the container @c@.
with :: c -> [c -> c] -> c
with c fx = foldl (>>>) id fx $ c

-- | This is the 'with' function with the parameters 'Prelude.flip'ped. It is convenient when used
-- with 'Control.Monad.State.Class.modify' when you want to update the state of a
-- 'Control.Monad.State.Lazy.StateT' monad using a 'Lens'. So take the example given in the 'with'
-- section above, the function could be written as:
--
-- @
-- moveSoutheast :: Gameboard -> Gameboard
-- moveSoutheast = 'by'
--     [ player 'Control.Category.>>>' position 'Control.Category.>>>' northCoord 'Data.Lens.Minimal.$=' 'Prelude.subtract' 1
--     , player 'Control.Category.>>>' position 'Control.Category.>>>' eastCoord 'Data.Lens.Minimal.$=' (+ 1)
--     , player 'Control.Category.>>>' isMyTurn 'Data.Lens.Minimal.<~' False
--     ]
-- @
by :: [c -> c] -> c -> c
by = flip with

-- | Like 'with' but passes 'Data.Monoid.mempty' as the first parameter, so instead of writing
-- something like:
--
-- @
-- 'with' 'Data.Monoid.mempty' [foo 'Data.Lens.Minimal.Lens.<~' 0, bar 'Data.Lens.Minimal.Lens.<~' 1]
-- @
-- 
-- All you have to write is:
--
-- @
-- new [foo 'Data.Lens.Minimal.Lens.<~' 0, bar 'Data.Lens.Minimal.Lens.<~' 1]
-- @
new :: Monoid c => [c -> c] -> c
new = with mempty

-- | This is a function intended to be used with the 'with' function. It is used for constructing a
-- simple updating 'Data.Monoid.Endo'functor (updating function) that simply stores the element @e@
-- into a container @c@ using 'pureUpdate'. You would use this operator when building a list of
-- updates to pass to the 'with' function.
--
-- This function requires a 'PureLens', but of course any 'Lens' polymorphic over the monadic type
-- @m@ can be used, automatic type inference will choose to make use of
-- 'Data.Monad.Identity.Identity' if the type is polymorphic.
--
-- This operator is visually similar to the bind operator used in Haskell's "do" notation @(<-)@.
-- Visually, it looks like you are writing a value into a lens, like in a procedural programming
-- language where the field you want to modify is on the left of the assignment operator, and the
-- value you want to write is on the right.
--
-- @
-- 'with' myData [fieldInData 'Data.Lens.Minimal.Lens.<~' 0]
-- @
(<~) :: PureLens c e -> e -> c -> c
(<~) = pureUpdate
infixr 0 <~

-- | This is a function intended to be used with the 'with', 'by', or 'new' functions. It is used
-- for constructing a simple updating 'Data.Monoid.Endo'functor (updating function) that updates
-- element @e@ inside of a container @c@ using 'pureAlter'. You would use this operator when
-- building a list of updates to pass to the 'with' function.
--
-- This function requires a 'PureLens', but of course any 'Lens' polymorphic over the monadic type
-- @m@ can be used, automatic type inference will choose to make use of
-- 'Data.Monad.Identity.Identity' if the type is polymorphic.
--
-- This operator is superficially similar to updating operators in popular C/C++ family of
-- programming languages. In this languages, to do an in-place update on a variable "x", for example
-- to increment an integer "x" by 5, you would write: @myData->x += 5;@
--
-- Likewise this operator does an "in-place update." However you must provide a function on the
-- right-hand side of this operator that will perform the update:
--
-- @
-- 'with' myData [x 'Data.Lens.Minimal.Lens.$=' (+ 5)]
-- @
($=) :: PureLens c e -> (e -> e) -> c -> c
($=) lens f c = snd (pureAlter lens f c)
infixr 0 $=

----------------------------------------------------------------------------------------------------

-- | This class lets you define a way to focus a 'Lens'. A 'focus' takes a single index parameter
-- @i@ and can 'fetch' or 'update' an element @e@ within container @c@ at that index @i@.
class Monad m => FocusesWith i m c e where
  focus :: i -> Lens m c e

-- | Converts a 'Lens' to a 'Control.Monad.State.Lazy.StateT' monad transformer that returns the
-- element @e@ of the container @c@.
getWithLens :: Monad m => Lens m c e -> StateT c m e
getWithLens (Lens lens) = lens Nothing

-- | Converts a 'Lens' to a 'Control.Monad.State.Lazy.StateT' monad transformer that inserts an
-- element @e@ into the container @c@.
putWithLens :: Monad m => Lens m c e -> (e -> StateT c m e)
putWithLens (Lens lens) = lens . Just . const . return

-- | Converts a 'Lens' to a 'Control.Monad.State.Lazy.StateT' monad transformer that modifies the
-- element @e@ within the container.
modifyWithLens :: Monad m => Lens m c e -> ((e -> m e) -> StateT c m e)
modifyWithLens (Lens lens) = lens . Just

-- | Use a 'Lens' to read an element @e@ within a container @c@. This function is usually used in
-- @do@ notation:
--
-- @
-- func container1 container2 = do
--     elem <- container1 `fetch` a 'Control.Category.>>>' b 'Control.Category.>>>' c 'Control.Category.>>>' d;
--     foo  <- container2 `fetch` bar 'Control.Category.>>>' baz
--     combineAndReturn elem foo
-- @
fetch :: Monad m => Lens m c e -> c -> m e
fetch (Lens lens) = evalStateT (lens Nothing)

-- | Similar to 'fetch', but performs the lookup purely, without Monadic side-effects. It is usually
-- easier to use the infix operator version of this function: @('Data.Lens.Minimal.~>')@.
pureFetch :: PureLens c e -> c -> e
pureFetch lens = runIdentity . fetch lens

-- | Defined as @(\\lens -> 'Control.Monad.State.Class.get' >>= 'fetch' lens)@. Although instead of
-- this function, it is usually easier to simply write:
--
-- @
-- 'Control.Monad.State.Class.get' >>= 'fetch' lens
-- @
--
-- or if your lens can be used as a 'PureLens':
--
-- @
-- 'Control.Monad.State.Class.gets' ('Data.Lens.Minimal.~>' lens)
-- @
lensGet :: (Monad m, MonadState c m) => Lens m c e -> m e
lensGet lens = get >>= fetch lens

-- | Use a 'Lens' that can access the 'Control.Monad.State.state' within a
-- 'Control.Monad.State.Class.MonadState' function to update the 'Control.Monad.State.state'. The
-- 'lensPut' function is defined as:
--
-- @
-- (\\lens elem -> 'Control.Monad.State.Class.get' >>= 'update' lens elem >>= \\e -> 'Control.Monad.State.Class.put' e >> return e)
-- @
lensPut :: (Monad m, MonadState c m) => Lens m c e -> e -> m e
lensPut lens e = get >>= update lens e >>= \c -> put c >> return e

-- | Use a 'Lens' to write an element @e@ within a container @c@. The pure infix version of this
-- function is @('Data.Lens.Minimal.<~')@, which is usually more useful. This function can be used
-- when 'Lens' is not a 'PureLens' and so the monadic type @m@ of the 'Lens' may not be
-- 'Control.Monad.Identity.Identity'.
--
-- Notice that the type signature of this function is defined such that multiple 'update' functions
-- can be composed using the 'Control.Monad.>>=' operator, for example:
--
-- @
--     'update' lastName  "Curry"    newPersonRecord
-- >>= 'update' firstName "Haskell"
-- >>= 'update' born      1900
-- >>= 'update' died      1981
-- @
update :: Monad m => Lens m c e -> e -> c -> m c
update (Lens lens) o = execStateT (lens $ Just $ const $ return o)

-- | Similar to 'update', but performs the update purely, without Monadic side-effects. It is
-- usually easier to use the infix operator version of this function: @('Data.Lens.Minimal.<~')@.
pureUpdate :: PureLens c e -> e -> c -> c
pureUpdate lens o = runIdentity . update lens o

-- | Like 'update', but also returns the value @e@ that was changed along with the updated container
-- @c@. The altering function must be a monadic function. For example:
alter :: Monad m => Lens m c e -> (e -> m e) -> c -> m (e, c)
alter (Lens lens) f = runStateT (lens $ Just f)

-- | Similar to 'alter' but requires a 'PureLens' and performs an update with a pure function. It
-- is usually easier to use the infix operator version of this function: @('Data.Lens.Minimal.$=')@.
pureAlter :: PureLens c e -> (e -> e) -> c -> (e, c)
pureAlter lens f = runIdentity . alter lens (return . f)

-- | Defined as @(\\lens f -> 'Control.Monad.State.Class.get' >>= 'alter' lens f >>= 'Control.Monad.State.Class.state' . 'Prelude.const')@.
lensModify :: (Monad m, MonadState c m) => Lens m c e -> (e -> m e) -> m (e, c)
lensModify lens f = get >>= alter lens f >>= \ (e, c) -> put c >> return (e, c)

----------------------------------------------------------------------------------------------------

-- | Use 'Control.Monad.Trans.Class.lift' to lift the operating monad of the 'Lens'. This is useful
-- when you want to modify the behavior of an existing 'Lens' by changing the monad in which 'update'
-- and 'fetch' operate. One example of how this could be used is if you want 'update' or 'fetch' to
-- be able to throw an error message, you could lift the monad into an
-- 'Control.Monad.Except.ExceptT' monad.
--
-- @
-- data Container = Container ('Prelude.Maybe' 'Prelude.Int') ('Prelude.Maybe' 'Prelude.String')
-- 
-- maybeInt :: 'Prelude.Monad' m => 'Lens' m Container ('Prelude.Maybe' 'Prelude.Int')
  -- maybeInt = 'newLens' (\\ (Container i _) -> i) (\\i (Container _ s) -> Container i s)
-- 
-- maybeString :: 'Prelude.Monad' m => 'Lens' m Container ('Prelude.Maybe' 'Prelude.String')
-- maybeString = 'newLens' (\\ (Container _ s) -> s) (\\s (Container i _) -> Container i s)
-- 
-- required :: 'Prelude.Monad' m => 'Prelude.String' -> 'Lens' m Container (Maybe element) -> 'Lens' ('Control.Monad.Except.ExceptT' 'Prelude.String' m) Container element
-- required fieldName lens = 'liftLens' lens 'Control.Category.>>>'
--     'maybeLens' 'Prelude.True' ('Control.Monad.Except.throwError' $ fieldName++" is undefined") 'Prelude.return'
-- 
-- requireInt :: 'Prelude.Monad' m => 'Lens' ('Control.Monad.Except.ExceptT' String m) Container 'Prelude.Int'
-- requireInt = required "int" maybeInt
-- 
-- requireString :: 'Prelude.Monad' m => 'Lens' ('Control.Monad.Except.ExceptT' String m) Container 'Prelude.String'
-- requireString = required "string" maybeString
-- @
liftLens :: (Monad m, MonadTrans t, Monad (t m), MonadFix (t m)) => Lens m c e -> Lens (t m) c e
liftLens (Lens lens) = Lens $ \element -> case element of
  Nothing      -> StateT $ lift . runStateT (lens Nothing)
  Just element -> StateT $ \st -> mfix $ \ (o, _) -> do
    o <- element o
    lift $ runStateT (lens $ Just $ const $ return o) st
    -- TODO: testing, I am not sure exactly if MonadFix will work as I think it will here.

----------------------------------------------------------------------------------------------------

-- | The 'defaul' 'Lens' operates on the element of a 'Data.Maybe.Maybe' data type given a default
-- value if the structure contains 'Data.Maybe.Nothing'. The structure will not be updated if it is
-- 'Data.Maybe.Nothing', so it will not 'Data.Map.alter' a 'Data.Map.Map' data structure unless the
-- key being updated already exists. This function is not called @default@ because @default@ is a
-- reserved word in Haskell.
defaul :: Monad m => m e -> Lens m (Maybe e) e
defaul o = Lens $ \upd -> case upd of
  Nothing  -> get >>= maybe (lift o) return
  Just upd -> get >>= maybe (lift $ o >>= upd) (lift . upd >=> state . const . (id &&& Just))

-- | The 'orElse' lens operates on the element of a 'Data.Maybe.Maybe' data type given a default
-- value if the structure contains 'Data.Maybe.Nothing'. The structure will be changed to the
-- updated default value if it is 'Data.Maybe.Nothing'. So if this function is used to
-- 'Data.Map.alter' a 'Data.Map.Map' data structure where no element is associated with a given key,
-- this function will force the value to exist and be associated with the given key.
orElse :: Monad m => m e -> Lens m (Maybe e) e
orElse o = Lens $ \upd -> case upd of
  Nothing  -> get >>= maybe (lift o) return
  Just upd -> get >>= maybe (lift $ o >>= upd) return >>= state . const . (id &&& Just)

-- | This is a non-pure 'Lens' that requires the mondic type instantiate 'Control.Monad.MonadPlus'.
-- This 'Lens' operates on a 'Data.Maybe.Maybe' data structure. The 'Lens' will 'fetch' or 'update'
-- a value if and only if the data structure is 'Data.Maybe.Just'. If it is 'Data.Maybe.Nothing'
-- the 'Lens' will evaluate to 'Control.Monad.mzero'.
exists :: MonadPlus m => Lens m (Maybe e) e
exists = Lens $ \upd -> case upd of
  Nothing  -> get >>= maybe mzero return
  Just upd -> get >>= maybe mzero (lift . upd >=> state . const . (id &&& Just))

-- | This is a non-pure 'Lens' that requires the monadic type instantiate 'Control.Monad.MonadPlus'.
-- This 'Lens' operates on a 'Data.Either.EIther' data structure. The 'Lens' will 'fetch' or
-- 'update' a value if and only if the data structure is 'Data.Either.Left', otherwise the 'Lens'
-- evaluates to 'Control.Monad.mzero'.
leftLens :: MonadPlus m => Lens m (Either e anything) e
leftLens = Lens $ \upd -> case upd of
  Nothing  -> get >>= lift . (return ||| const mzero)
  Just upd -> get >>= lift . (upd ||| const mzero) >>= state . const . (id &&& Left)

-- | This is a non-pure 'Lens' that requires the monadic type instantiate 'Control.Monad.MonadPlus'.
-- This 'Lens' operates on a 'Data.Either.Either' data structure. The 'Lens' will 'fetch' or
-- 'update' a value if and only if the data structure is 'Data.Either.Left', otherwise the 'Lens'
-- evaluates to 'Control.Monad.mzero'.
rightLens :: MonadPlus m => Lens m (Either anything e) e
rightLens = Lens $ \upd -> case upd of
  Nothing  -> get >>= lift . (const mzero ||| return)
  Just upd -> get >>= lift . (const mzero ||| upd) >>= state . const . (id &&& Right)

----------------------------------------------------------------------------------------------------

-- | To create a 'Lens' that focuses on an element of a dictionary, provide a lookup function (e.g.
-- 'Data.Map.lookup') and an alter function (e.g. 'Data.Map.alter'). Or just use the 'mapLens' or
-- 'intMapLens' functions predefined for the 'Data.Map.Map' and 'Data.IntMap.IntMap' data types,
-- respectively.
dictionaryLens
  :: (Monad m, Eq key, Ord key)
  => (key -> map o -> Maybe o)
  -> ((Maybe o -> Maybe o) -> key -> map o -> map o)
  -> key -> Lens m (map o) (Maybe o)
dictionaryLens lookup alter key = newLens (lookup key) $ \o -> alter (const o) key

-- | A 'Lens' that focuses on an element of an 'Data.Map.Map' with the key to that element.
mapLens :: (Monad m, Eq key, Ord key) => key -> Lens m (M.Map key o) (Maybe o)
mapLens = dictionaryLens M.lookup M.alter

-- | A 'Lens' that focuses on an element of an 'Data.IntMap.IntMap' with the key to that element.
intMapLens :: Monad m => Int -> Lens m (I.IntMap o) (Maybe o)
intMapLens = dictionaryLens I.lookup I.alter

instance (Monad m, Eq key, Ord key) =>
  FocusesWith key m (M.Map key o) (Maybe o) where { focus=mapLens; }

instance Monad m => FocusesWith Int m (I.IntMap o) (Maybe o) where { focus=intMapLens; }

----------------------------------------------------------------------------------------------------

-- | Create a lens that accesses an element at the given index in an array. Evaluates to
-- 'Prelude.undefined' if the index is out of bounds. This function is used to instantiate 'focus'.
arrayLens :: (Monad m, Ix i, IArray arr o) => i -> Lens m (arr i o) o
arrayLens i = newLens (! i) (\o -> (// [(i, o)]))

instance (Monad m, Ix i, IArray Array o) => FocusesWith i m (Array i o) o where { focus=arrayLens; }

instance (Monad m, Ix i, IArray UArray o) => FocusesWith i m (UArray i o) o where { focus=arrayLens; }

-- | Create a lens that accesses an element at the given index in an array. If the index is out of
-- bounds, calling 'fetch' on the 'Lens' will evaluate to 'Prelude.Nothing', and calling 'fetch'
-- will do nothing at all. This function is used to instantiate 'focus'.
maybeArrayLens :: (Monad m, Ix i, IArray arr o) => i -> Lens m (arr i o) (Maybe o)
maybeArrayLens i = let lens = arrayLens i in Lens $ \o -> get >>= \arr ->
  if inRange (bounds arr) i
  then liftM Just $ case o of
          Nothing -> getWithLens lens
          Just  o -> modifyWithLens lens (o . Just >=> maybe (return $ arr!i) return)
  else return Nothing

instance (Monad m, Ix i, IArray Array o) =>
  FocusesWith i m (Array i o) (Maybe o) where { focus=maybeArrayLens; }

instance (Monad m, Ix i, IArray UArray o) =>
  FocusesWith i m (UArray i o) (Maybe o) where { focus=maybeArrayLens; }

ioArrayLens :: (Monad m, MonadIO m, Ix i, MArray arr o IO) => i -> Lens m (arr i o) o
ioArrayLens i =
  newLensM (liftIO . flip readArray i) (\o arr -> liftIO $ writeArray arr i o >> return arr)

instance (Monad m, Applicative m, MonadIO m, Ix i, MArray IOArray o IO) =>
  FocusesWith i m (IOArray i o) o where { focus=ioArrayLens; }

instance (Monad m, Applicative m, MonadIO m, Ix i, MArray IOUArray o IO) =>
  FocusesWith i m (IOUArray i o) o where { focus=ioArrayLens; }

-- | Checks if the index is within the bounds of the array, does no lookup or update if the index is
-- out of bounds. This function is used to instantiate 'focus'.
ioMaybeArrayLens :: (Monad m, MonadIO m, Ix i, MArray arr o IO) => i -> Lens m (arr i o) (Maybe o)
ioMaybeArrayLens i = let lens = ioArrayLens i in Lens $ \o -> do
  arr      <- get
  inBounds <- liftM (`inRange` i) $ liftIO $ getBounds arr
  if not inBounds then return Nothing else liftM Just $ case o of
    Nothing -> getWithLens lens
    Just  o -> modifyWithLens lens (o . Just >=> maybe (liftIO $ readArray arr i) return)

instance (Monad m, MonadIO m, Ix i, MArray IOArray o IO) =>
  FocusesWith i m (IOArray i o) (Maybe o) where { focus=ioMaybeArrayLens; }

instance (Monad m, MonadIO m, Ix i, MArray IOUArray o IO) =>
  FocusesWith i m (IOUArray i o) (Maybe o) where { focus=ioMaybeArrayLens; }

----------------------------------------------------------------------------------------------------

ioRefLens :: (Monad m, MonadIO m) => Lens m (IORef o) o
ioRefLens = newLensM (liftIO . readIORef) (\o ref -> liftIO $ writeIORef ref o >> return ref)

mVarLens :: (Monad m, MonadIO m) => Lens m (MVar o) o
mVarLens = newLensM (liftIO . readMVar) $ \o mvar ->
  liftIO $ modifyMVar_ mvar (const $ return o) >> return mvar

----------------------------------------------------------------------------------------------------

class TupleLens0 a o where { tuple0 :: Monad m => Lens m a o }
class TupleLens1 a o where { tuple1 :: Monad m => Lens m a o }
class TupleLens2 a o where { tuple2 :: Monad m => Lens m a o }
class TupleLens3 a o where { tuple3 :: Monad m => Lens m a o }
class TupleLens4 a o where { tuple4 :: Monad m => Lens m a o }
class TupleLens5 a o where { tuple5 :: Monad m => Lens m a o }
class TupleLens6 a o where { tuple6 :: Monad m => Lens m a o }
class TupleLens7 a o where { tuple7 :: Monad m => Lens m a o }
class TupleLens8 a o where { tuple8 :: Monad m => Lens m a o }
class TupleLens9 a o where { tuple9 :: Monad m => Lens m a o }

instance TupleLens0 (o, b, c, d, e, f, g, h, i, j) o where
  tuple0 = newLens (\ (o, _, _, _, _, _, _, _, _, _) -> o) (\o (_, b, c, d, e, f, g, h, i, j) -> (o, b, c, d, e, f, g, h, i, j))

instance TupleLens0 (o, b, c, d, e, f, g, h, i) o where
  tuple0 = newLens (\ (o, _, _, _, _, _, _, _, _) -> o) (\o (_, b, c, d, e, f, g, h, i) -> (o, b, c, d, e, f, g, h, i))

instance TupleLens0 (o, b, c, d, e, f, g, h) o where
  tuple0 = newLens (\ (o, _, _, _, _, _, _, _) -> o) (\o (_, b, c, d, e, f, g, h) -> (o, b, c, d, e, f, g, h))

instance TupleLens0 (o, b, c, d, e, f, g) o where
  tuple0 = newLens (\ (o, _, _, _, _, _, _) -> o) (\o (_, b, c, d, e, f, g) -> (o, b, c, d, e, f, g))

instance TupleLens0 (o, b, c, d, e, f) o where
  tuple0 = newLens (\ (o, _, _, _, _, _) -> o) (\o (_, b, c, d, e, f) -> (o, b, c, d, e, f))

instance TupleLens0 (o, b, c, d, e) o where
  tuple0 = newLens (\ (o, _, _, _, _) -> o) (\o (_, b, c, d, e) -> (o, b, c, d, e))

instance TupleLens0 (o, b, c, d) o where
  tuple0 = newLens (\ (o, _, _, _) -> o) (\o (_, b, c, d) -> (o, b, c, d))

instance TupleLens0 (o, b, c) o where
  tuple0 = newLens (\ (o, _, _) -> o) (\o (_, b, c) -> (o, b, c))

instance TupleLens0 (o, b) o where
  tuple0 = newLens (\ (o, _) -> o) (\o (_, b) -> (o, b))


instance TupleLens1 (a, o, c, d, e, f, g, h, i, j) o where
  tuple1 = newLens (\ (_, o, _, _, _, _, _, _, _, _) -> o) (\o (a, _, c, d, e, f, g, h, i, j) -> (a, o, c, d, e, f, g, h, i, j))

instance TupleLens1 (a, o, c, d, e, f, g, h, i) o where
  tuple1 = newLens (\ (_, o, _, _, _, _, _, _, _) -> o) (\o (a, _, c, d, e, f, g, h, i) -> (a, o, c, d, e, f, g, h, i))

instance TupleLens1 (a, o, c, d, e, f, g, h) o where
  tuple1 = newLens (\ (_, o, _, _, _, _, _, _) -> o) (\o (a, _, c, d, e, f, g, h) -> (a, o, c, d, e, f, g, h))

instance TupleLens1 (a, o, c, d, e, f, g) o where
  tuple1 = newLens (\ (_, o, _, _, _, _, _) -> o) (\o (a, _, c, d, e, f, g) -> (a, o, c, d, e, f, g))

instance TupleLens1 (a, o, c, d, e, f) o where
  tuple1 = newLens (\ (_, o, _, _, _, _) -> o) (\o (a, _, c, d, e, f) -> (a, o, c, d, e, f))

instance TupleLens1 (a, o, c, d, e) o where
  tuple1 = newLens (\ (_, o, _, _, _) -> o) (\o (a, _, c, d, e) -> (a, o, c, d, e))

instance TupleLens1 (a, o, c, d) o where
  tuple1 = newLens (\ (_, o, _, _) -> o) (\o (a, _, c, d) -> (a, o, c, d))

instance TupleLens1 (a, o, c) o where
  tuple1 = newLens (\ (_, o, _) -> o) (\o (a, _, c) -> (a, o, c))

instance TupleLens1 (a, o) o where
  tuple1 = newLens (\ (_, o) -> o) (\o (a, _) -> (a, o))


instance TupleLens2 (a, b, o, d, e, f, g, h, i, j) o where
  tuple2 = newLens (\ (_, _, o, _, _, _, _, _, _, _) -> o) (\o (a, b, _, d, e, f, g, h, i, j) -> (a, b, o, d, e, f, g, h, i, j))

instance TupleLens2 (a, b, o, d, e, f, g, h, i) o where
  tuple2 = newLens (\ (_, _, o, _, _, _, _, _, _) -> o) (\o (a, b, _, d, e, f, g, h, i) -> (a, b, o, d, e, f, g, h, i))

instance TupleLens2 (a, b, o, d, e, f, g, h) o where
  tuple2 = newLens (\ (_, _, o, _, _, _, _, _) -> o) (\o (a, b, _, d, e, f, g, h) -> (a, b, o, d, e, f, g, h))

instance TupleLens2 (a, b, o, d, e, f, g) o where
  tuple2 = newLens (\ (_, _, o, _, _, _, _) -> o) (\o (a, b, _, d, e, f, g) -> (a, b, o, d, e, f, g))

instance TupleLens2 (a, b, o, d, e, f) o where
  tuple2 = newLens (\ (_, _, o, _, _, _) -> o) (\o (a, b, _, d, e, f) -> (a, b, o, d, e, f))

instance TupleLens2 (a, b, o, d, e) o where
  tuple2 = newLens (\ (_, _, o, _, _) -> o) (\o (a, b, _, d, e) -> (a, b, o, d, e))

instance TupleLens2 (a, b, o, d) o where
  tuple2 = newLens (\ (_, _, o, _) -> o) (\o (a, b, _, d) -> (a, b, o, d))

instance TupleLens2 (a, b, o) o where
  tuple2 = newLens (\ (_, _, o) -> o) (\o (a, b, _) -> (a, b, o))


instance TupleLens3 (a, b, c, o, e, f, g, h, i, j) o where
  tuple3 = newLens (\ (_, _, _, o, _, _, _, _, _, _) -> o) (\o (a, b, c, _, e, f, g, h, i, j) -> (a, b, c, o, e, f, g, h, i, j))

instance TupleLens3 (a, b, c, o, e, f, g, h, i) o where
  tuple3 = newLens (\ (_, _, _, o, _, _, _, _, _) -> o) (\o (a, b, c, _, e, f, g, h, i) -> (a, b, c, o, e, f, g, h, i))

instance TupleLens3 (a, b, c, o, e, f, g, h) o where
  tuple3 = newLens (\ (_, _, _, o, _, _, _, _) -> o) (\o (a, b, c, _, e, f, g, h) -> (a, b, c, o, e, f, g, h))

instance TupleLens3 (a, b, c, o, e, f, g) o where
  tuple3 = newLens (\ (_, _, _, o, _, _, _) -> o) (\o (a, b, c, _, e, f, g) -> (a, b, c, o, e, f, g))

instance TupleLens3 (a, b, c, o, e, f) o where
  tuple3 = newLens (\ (_, _, _, o, _, _) -> o) (\o (a, b, c, _, e, f) -> (a, b, c, o, e, f))

instance TupleLens3 (a, b, c, o, e) o where
  tuple3 = newLens (\ (_, _, _, o, _) -> o) (\o (a, b, c, _, e) -> (a, b, c, o, e))

instance TupleLens3 (a, b, c, o) o where
  tuple3 = newLens (\ (_, _, _, o) -> o) (\o (a, b, c, _) -> (a, b, c, o))


instance TupleLens4 (a, b, c, d, o, f, g, h, i, j) o where
  tuple4 = newLens (\ (_, _, _, _, o, _, _, _, _, _) -> o) (\o (a, b, c, d, _, f, g, h, i, j) -> (a, b, c, d, o, f, g, h, i, j))

instance TupleLens4 (a, b, c, d, o, f, g, h, i) o where
  tuple4 = newLens (\ (_, _, _, _, o, _, _, _, _) -> o) (\o (a, b, c, d, _, f, g, h, i) -> (a, b, c, d, o, f, g, h, i))

instance TupleLens4 (a, b, c, d, o, f, g, h) o where
  tuple4 = newLens (\ (_, _, _, _, o, _, _, _) -> o) (\o (a, b, c, d, _, f, g, h) -> (a, b, c, d, o, f, g, h))

instance TupleLens4 (a, b, c, d, o, f, g) o where
  tuple4 = newLens (\ (_, _, _, _, o, _, _) -> o) (\o (a, b, c, d, _, f, g) -> (a, b, c, d, o, f, g))

instance TupleLens4 (a, b, c, d, o, f) o where
  tuple4 = newLens (\ (_, _, _, _, o, _) -> o) (\o (a, b, c, d, _, f) -> (a, b, c, d, o, f))

instance TupleLens4 (a, b, c, d, o) o where
  tuple4 = newLens (\ (_, _, _, _, o) -> o) (\o (a, b, c, d, _) -> (a, b, c, d, o))


instance TupleLens5 (a, b, c, d, e, o, g, h, i, j) o where
  tuple5 = newLens (\ (_, _, _, _, _, o, _, _, _, _) -> o) (\o (a, b, c, d, e, _, g, h, i, j) -> (a, b, c, d, e, o, g, h, i, j))

instance TupleLens5 (a, b, c, d, e, o, g, h, i) o where
  tuple5 = newLens (\ (_, _, _, _, _, o, _, _, _) -> o) (\o (a, b, c, d, e, _, g, h, i) -> (a, b, c, d, e, o, g, h, i))

instance TupleLens5 (a, b, c, d, e, o, g, h) o where
  tuple5 = newLens (\ (_, _, _, _, _, o, _, _) -> o) (\o (a, b, c, d, e, _, g, h) -> (a, b, c, d, e, o, g, h))

instance TupleLens5 (a, b, c, d, e, o, g) o where
  tuple5 = newLens (\ (_, _, _, _, _, o, _) -> o) (\o (a, b, c, d, e, _, g) -> (a, b, c, d, e, o, g))

instance TupleLens5 (a, b, c, d, e, o) o where
  tuple5 = newLens (\ (_, _, _, _, _, o) -> o) (\o (a, b, c, d, e, _) -> (a, b, c, d, e, o))


instance TupleLens6 (a, b, c, d, e, f, o, h, i, j) o where
  tuple6 = newLens (\ (_, _, _, _, _, _, o, _, _, _) -> o) (\o (a, b, c, d, e, f, _, h, i, j) -> (a, b, c, d, e, f, o, h, i, j))

instance TupleLens6 (a, b, c, d, e, f, o, h, i) o where
  tuple6 = newLens (\ (_, _, _, _, _, _, o, _, _) -> o) (\o (a, b, c, d, e, f, _, h, i) -> (a, b, c, d, e, f, o, h, i))

instance TupleLens6 (a, b, c, d, e, f, o, h) o where
  tuple6 = newLens (\ (_, _, _, _, _, _, o, _) -> o) (\o (a, b, c, d, e, f, _, h) -> (a, b, c, d, e, f, o, h))

instance TupleLens6 (a, b, c, d, e, f, o) o where
  tuple6 = newLens (\ (_, _, _, _, _, _, o) -> o) (\o (a, b, c, d, e, f, _) -> (a, b, c, d, e, f, o))


instance TupleLens7 (a, b, c, d, e, f, g, o, i, j) o where
  tuple7 = newLens (\ (_, _, _, _, _, _, _, o, _, _) -> o) (\o (a, b, c, d, e, f, g, _, i, j) -> (a, b, c, d, e, f, g, o, i, j))

instance TupleLens7 (a, b, c, d, e, f, g, o, i) o where
  tuple7 = newLens (\ (_, _, _, _, _, _, _, o, _) -> o) (\o (a, b, c, d, e, f, g, _, i) -> (a, b, c, d, e, f, g, o, i))

instance TupleLens7 (a, b, c, d, e, f, g, o) o where
  tuple7 = newLens (\ (_, _, _, _, _, _, _, o) -> o) (\o (a, b, c, d, e, f, g, _) -> (a, b, c, d, e, f, g, o))


instance TupleLens8 (a, b, c, d, e, f, g, h, o, j) o where
  tuple8 = newLens (\ (_, _, _, _, _, _, _, _, o, _) -> o) (\o (a, b, c, d, e, f, g, h, _, j) -> (a, b, c, d, e, f, g, h, o, j))

instance TupleLens8 (a, b, c, d, e, f, g, h, o) o where
  tuple8 = newLens (\ (_, _, _, _, _, _, _, _, o) -> o) (\o (a, b, c, d, e, f, g, h, _) -> (a, b, c, d, e, f, g, h, o))


instance TupleLens9 (a, b, c, d, e, f, g, h, i, o) o where
  tuple9 = newLens (\ (_, _, _, _, _, _, _, _, _, o) -> o) (\o (a, b, c, d, e, f, g, h, i, _) -> (a, b, c, d, e, f, g, h, i, o))