{-# LANGUAGE Rank2Types, MultiParamTypeClasses, FunctionalDependencies, ViewPatterns, TupleSections, LiberalTypeSynonyms #-}
{-|
A module providing simple Lens functionality.

Lenses are a Haskell abstraction that allows you to access and modify
part of a structure, compensating for and improving upon Haskell's
horrendous record syntax and giving Haskell a first-class record system.

This module defines three kinds of Lenses : Lenses that allow you to
access part of a structure; Traversals that allow you to modify part
of a structure; and Isos which may be reversed. Lenses of any kind can
be composed with @(.)@, yielding a Lens of the most general kind, so
that composing a Lens with a Traversal or Iso yields a Lens, and a
Traversal with an Iso yields a Traversal.
-}
module Algebra.Lens(
  -- * The lens types
  Iso,Iso',(:<->:),
  LensLike,
  Fold,Fold',
  Getter,Getter',
  Lens,Lens',
  Traversal,Traversal',
  
  -- * Constructing lenses
  iso,from,lens,getter,prism,sat,simple,(.+),forl,forl_,

  -- * Extracting values
  (^.),(^..),(^?),has,(^??),(%~),(%-),(%%~),(%%-),by,yb,warp,set,
  (-.),(.-),
  
  -- * Basic lenses
  Lens1(..),Lens2(..),Lens3(..),Lens4(..),
  Trav1(..),Trav2(..),
  Compound(..),
  i'list,i'pair,t'head,t'tail,
  
  -- * Isomorphisms
  Isomorphic(..),

  -- ** Miscellaneous
  thunk,chunk,curried,

  -- ** Type wrappers
  i'Id,i'OrdList,i'Const,i'Dual,i'Endo,i'Flip,i'maybe,i'Max,i'Compose,i'Backwards,i'Accum,

  -- ** Algebraic isomorphisms
  negated,commuted,adding,
  
  -- ** Higher-order isomorphisms
  warp2,mapping,mapping',promapping,

  IsoFunctor(..),(<.>),IsoFunctor2(..)
  ) where

import Algebra.Core hiding (flip)
import Algebra.Functor
import Algebra.Applicative
import System.IO.Unsafe (unsafePerformIO)
import Control.Exception (evaluate)
import Data.ByteString.Lazy (toStrict,fromStrict)

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

type Lens s t a b = forall f.Functor f => LensLike f s t a b
type Lens' a b = Simple Lens a b
type Getter s t a b = LensLike (Const s) s t a b
type Getter' a b = Simple Getter a b
type Traversal s t a b = forall f. Applicative f => LensLike f s t a b
type Traversal' a b = Simple Traversal a b
type Fold s t a b = forall f. (Semigroup (f b),Applicative f) => LensLike f s t a b
type Fold' a b = Simple Fold a b
type Iso s t a b = forall p f. (Functor f,Bifunctor p) => p s (f t) -> p a (f b)
type Iso' a b = Simple Iso a b
type a :<->: b = Iso' a b

data IsoT a b s t = IsoT (s -> a) (b -> t)
instance Functor (IsoT a b s) where map f (IsoT u v) = IsoT u (map f v)
instance Cofunctor (Flip (IsoT a b) t) where
  comap f (Flip (IsoT u v)) = Flip (IsoT (promap f u) v)
instance Bifunctor (IsoT a b)

-- |Create an 'Iso' from two inverse functions.
iso :: (a -> s) -> (t -> b) -> Iso s t a b
iso f g = dimap f (map g)
isoT :: Iso s t a b -> IsoT s t a b
isoT i = getId<$>i (IsoT id Id)
unIsoT :: IsoT s t a b -> Iso s t a b
unIsoT (IsoT u v) = iso u v
-- |Reverse an 'Iso'
--
-- @
-- from :: 'Iso'' a b -> 'Iso'' b a
-- @
from :: Iso s t a b -> Iso b a t s
from = isoT >>> (\ ~(IsoT u v) -> IsoT v u) >>> unIsoT
-- |Create a 'Lens' from a getter and setter function.
-- 
-- @
-- lens :: (a -> b) -> (a -> b -> a) -> 'Lens'' a b
-- @
lens :: (a -> s) -> (a -> t -> b) -> Lens s t a b
lens f g = \k a -> g a <$> k (f a) 

getter :: (a -> b) -> Traversal' a b
getter f = \k a -> a<$k (f a)

-- |Create a 'Traversal' from a maybe getter and setter function.
--
-- @
-- prism :: (a -> (a:+:b)) -> (a -> b -> a) -> 'Traversal'' a b
-- @
prism :: (a -> (b:+:s)) -> (a -> t -> b) -> Traversal s t a b 
prism f g = \k a -> (pure <|> map (g a) . k) (f a)

simple :: LensLike f a b a b -> LensLike f a b a b
simple l = l

sat :: (a -> Bool) -> Traversal' a a
sat p = \k a -> (if p a then k else pure) a

(.+) :: Fold s t a b -> Fold s t a b -> Fold s t a b
f .+ f' = \k a -> f k a + f' k a
infixr 8 .+

-- |Retrieve a value from a structure using a 'Lens' (or 'Iso')
infixl 8 ^.,^..,^?,^??,%~,%-,%%~,%%-
(^.) :: a -> Getter b b a a -> b
(^.) = flip by
(^..) :: a -> Iso a a b b -> b
(^..) = flip yb
-- |
(%~) :: LensLike Id s t a b -> (s -> t) -> (a -> b)
(%~) = warp
(%%~) :: Iso s t a b -> (b -> a) -> (t -> s)
(%%~) i = warp (from i)
(%-) :: LensLike Id s t a b -> t -> (a -> b)
(%-) = set
(%%-) :: Iso s t a b -> a -> (t -> s)
(%%-) i = set (from i)
(^?) :: (Unit f,Monoid (f b)) => a -> Fold' a b -> f b
x^?l = getConst $ l (Const . pure) x
(^??) :: a -> ((b -> Const [b] b) -> a -> Const [b] a) -> [b]
x^??l = getConst $ l (Const . pure) x

(-.) :: Getter c u b v -> (a -> b) -> a -> c
l-.f = by l.f
(.-) :: (b -> c) -> Iso a a b b -> a -> c
f.-i = f.yb i
infixr 9 -.,.-
by :: Getter b u a v -> a -> b
by l = getConst . l Const
yb :: Iso s t a b -> t -> b
yb i = by (from i)
warp :: LensLike Id s t a b -> (s -> t) -> (a -> b)
warp l = map getId . l . map Id
set :: LensLike Id s t a b -> t -> (a -> b)
set l = warp l . const 

forl :: LensLike f a b c d -> c -> (a -> f b) -> f d
forl l c f = l f c
forl_ :: Functor f => LensLike f a a c c -> c -> (a -> f ()) -> f ()
forl_ l c f = void $ l (\a -> a<$f a) c

class Lens1 s t a b | a -> s, a t -> b where
  l'1 :: Lens s t a b
class Lens2 s t a b | a -> s, a t -> b where
  l'2 :: Lens s t a b
class Lens3 s t a b | a -> s, a t -> b where
  l'3 :: Lens s t a b
class Lens4 s t a b | a -> s, a t -> b where
  l'4 :: Lens s t a b
class Trav1 s t a b | a -> s, a t -> b where
  t'l :: Traversal s t a b
class Trav2 s t a b | a -> s, a t -> b where
  t'r :: Traversal s t a b
instance Lens1 a a [a] [a] where
  l'1 = lens (\ ~(a:_) -> a ) (\ ~(_:t) a -> a:t )
instance Lens1 a b (a:*:c) (b:*:c) where
  l'1 = lens fst (flip (first . const))
instance Lens1 a b (a,c,d) (b,c,d) where
  l'1 = lens (\ ~(a,_,_) -> a) (\ (_,c,d) b -> (b,c,d))
instance Lens1 a b (a,c,d,e) (b,c,d,e) where
  l'1 = lens (\ ~(a,_,_,_) -> a) (\ (_,c,d,e) b -> (b,c,d,e))
instance Lens2 a b (c:*:a) (c:*:b) where
  l'2 = lens snd (flip (second . const))
instance Lens2 a b (c,a,d) (c,b,d) where
  l'2 = lens (\ ~(_,a,_) -> a ) (\ ~(c,_,d) b -> (c,b,d))
instance Lens2 a b (c,a,d,e) (c,b,d,e) where
  l'2 = lens (\ ~(_,a,_,_) -> a ) (\ ~(c,_,d,e) b -> (c,b,d,e))
instance Lens3 a b (c,d,a) (c,d,b) where
  l'3 = lens (\ ~(_,_,a) -> a ) (\ ~(c,d,_) b -> (c,d,b))
instance Lens3 a b (c,d,a,e) (c,d,b,e) where
  l'3 = lens (\ ~(_,_,a,_) -> a ) (\ ~(c,d,_,e) b -> (c,d,b,e))
instance Lens4 a b (c,d,e,a) (c,d,e,b) where
  l'4 = lens (\ ~(_,_,_,a) -> a ) (\ ~(c,d,e,_) b -> (c,d,e,b))
instance Trav1 a b (a:+:c) (b:+:c) where
  t'l = prism ((id ||| Right) >>> swapE) (flip (left . const))
    where swapE :: (b:+:a) -> (a:+:b)
          swapE = Right<|>Left
instance Trav1 a b [a] [b] where
  t'l = prism f g
    where f [] = Left []
          f (a:_) = Right a
          g [] _ = []
          g _ b = [b]
instance Trav2 a b (c:+:a) (c:+:b) where
  t'r = prism (Left ||| id) (flip (right . const))
instance Trav2 a b (Maybe a) (Maybe b) where
  t'r = prism (\a -> maybe (Left Nothing) Right a) (flip (<$))

class Compound a b s t | s -> a, b s -> t where
  _each :: Traversal a b s t
instance Compound a b (a,a) (b,b) where
  _each k (a,a') = (,)<$>k a<*>k a'
instance Compound a b (a,a,a) (b,b,b) where
  _each k (a,a',a'') = (,,)<$>k a<*>k a'<*>k a''
instance Compound a b (a:+:a) (b:+:b) where
  _each k = map Left . k <|> map Right . k
i'list :: [a] :<->: (():+:(a:*:[a]))
i'list = iso (\l -> case l of
                [] -> Left ()
                (x:t) -> Right (x,t)) (const [] <|> uncurry (:))

t'head :: Traversal' [a] a
t'head = t'l
t'tail :: Traversal' [a] [a]
t'tail = i'list.t'r.l'2

mapping :: (Functor f,Functor f') => Iso s t a b -> Iso (f s) (f' t) (f a) (f' b)
mapping (isoT -> IsoT u v) = map u `dimap` map (map v)
mapping' :: Functor f => Iso s t a b -> Iso (f s) (f t) (f a) (f b)
mapping' = mapping
promapping :: Bifunctor f => Iso s t a b -> Iso (f t x) (f s y) (f b x) (f a y)
promapping (isoT -> IsoT u v) = dimap v id`dimap` map (dimap u id)
-- ^promapping :: Bifunctor f => Iso' a b -> Iso' (f a c) (f b c)

class Isomorphic b a t s | t -> b, t a -> s where
  i'_ :: Iso s t a b
instance Isomorphic a b (Id a) (Id b) where
  i'_ = iso Id getId
instance Isomorphic [a] [b] (OrdList a) (OrdList b) where
  i'_ = iso OrdList getOrdList
instance Isomorphic a b (Const a c) (Const b c) where
  i'_ = iso Const getConst
instance Isomorphic a b (Dual a) (Dual b) where
  i'_ = iso Dual getDual
instance Isomorphic a b (Product a) (Product b) where
  i'_ = iso Product getProduct
instance Isomorphic a b (Max a) (Max b) where
  i'_ = iso Max getMax
instance Isomorphic (k a a) (k b b) (Endo k a) (Endo k b) where
  i'_ = iso Endo runEndo
instance Isomorphic (f a b) (f c d) (Flip f b a) (Flip f d c) where
  i'_ = iso Flip unFlip
instance Isomorphic Bool Bool (Maybe a) (Maybe Void) where
  i'_ = iso (bool (Just zero) Nothing) (maybe False (const True))
instance Isomorphic (f (g a)) (f' (g' b)) ((f:.:g) a) ((f':.:g') b) where
  i'_ = iso Compose getCompose
instance Isomorphic a b (Void,a) (Void,b) where
  i'_ = iso (zero,) snd
i'Id :: Iso (Id a) (Id b) a b
i'Id = i'_
i'OrdList :: Iso (OrdList a) (OrdList b) [a] [b]
i'OrdList = i'_
i'Dual :: Iso (Dual a) (Dual b) a b
i'Dual = i'_
i'Const :: Iso (Const a c) (Const b c) a b
i'Const = i'_
i'Max :: Iso (Max a) (Max b) a b 
i'Max = i'_
i'Endo :: Iso (Endo k a) (Endo k b) (k a a) (k b b)
i'Endo = i'_ 
i'maybe :: Iso (Maybe Void) (Maybe a) Bool Bool
i'maybe = i'_ 
i'Flip :: Iso (Flip f b a) (Flip f d c) (f a b) (f c d)
i'Flip = i'_
i'Compose :: Iso ((f:.:g) a) ((f':.:g') b) (f (g a)) (f' (g' b))
i'Compose = i'_
i'Backwards :: Iso (Backwards f a) (Backwards g b) (f a) (g b)
i'Backwards = iso Backwards forwards
i'Accum :: Iso (Accum a) (Accum b) (Maybe a) (Maybe b)
i'Accum = iso Accum getAccum

curried :: Iso (a -> b -> c) (a' -> b' -> c') ((a,b) -> c) ((a',b') -> c')
curried = iso curry uncurry

warp2 :: Iso s t a b -> (s -> s -> t) -> (a -> a -> b)
warp2 i f = \a a' -> yb i (by i a`f`by i a')

class IsoFunctor f where
  mapIso :: Iso s t a b -> Iso (f s) (f t) (f a) (f b)
class IsoFunctor2 f where
  mapIso2 :: (a:<->:c) -> (b:<->:d) -> (f a b:<->:f c d)

-- | An infix synonym for 'mapIso2'
(<.>) :: IsoFunctor2 f => (a:<->:c) -> (b:<->:d) -> (f a b:<->:f c d)
(<.>) = mapIso2
infixr 9 <.>

i'pair :: Iso s t a b -> Iso s' t' a' b' -> Iso (s,s') (t,t') (a,a') (b,b')
i'pair i i' = let IsoT u v = isoT i ; IsoT u' v' = isoT i' in iso (u<#>u') (v<#>v')

instance IsoFunctor ((->) a) where mapIso = mapping
instance IsoFunctor2 (->) where mapIso2 i j = promapping i.mapping j
instance IsoFunctor2 (,) where
  mapIso2 = i'pair
instance IsoFunctor2 Either where
  mapIso2 i j = iso (by i ||| by j) (yb i ||| yb j)

adding :: (Num n,Semigroup n) => n -> Iso' n n
adding n = iso (+n) (subtract n)

thunk :: Iso a b (IO a) (IO b)
thunk = iso unsafePerformIO evaluate
chunk :: Bytes:<->:Chunk
chunk = iso toStrict fromStrict

negated :: (Negative a,Negative b) => Iso a b a b
negated = iso negate negate
commuted :: Commutative f => Iso (f a b) (f c d) (f b a) (f d c)
commuted = iso commute commute

newtype Test a = Test (Const (Product Bool) a)
               deriving (Semigroup,Monoid,Functor,Unit
                        ,Applicative)
has :: Fold' a b -> a -> Bool
has l x = x^?l & \(Test (Const (Product b))) -> b