{-# LANGUAGE Rank2Types, MultiParamTypeClasses, FunctionalDependencies, ViewPatterns, TupleSections #-}
{-|
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 SimpleH.Lens(
  -- * The lens types
  Iso,Iso',(:<->:),
  LensLike,LensLike',
  Getter,Getter',
  Lens,Lens',
  Traversal,Traversal',

  -- * Constructing lenses
  iso,from,lens,getter,prism,

  -- * Extracting values
  (^.),(^..),(^?),(%~),(%-),at,at',warp,set,
  (-.),(.-),
  
  -- * Basic lenses
  _1,_2,_l,_r,Compound(..),
  _list,_head,_tail,

  -- * Isomorphisms
  Isomorphic(..),
  adding,
  _Id,_OrdList,_Const,_Dual,_Endo,_Flip,_maybe,_Max,_Compose,_Backwards,
  warp2,_mapping,_promapping,
  IsoFunctor(..),IsoFunctor2(..),
  _thunk
  ) where

import SimpleH.Core
import SimpleH.Functor
import SimpleH.Applicative
import System.IO.Unsafe (unsafePerformIO)
import Control.Exception (evaluate)

type LensLike f s t a b = (s -> f t) -> (a -> f b)
type LensLike' f a b = LensLike 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 = Lens b b a a
type Getter s t a b = LensLike (Const s) s t a b
type Getter' u v a b = Getter b u a v
type Traversal s t a b = forall f. Applicative f => LensLike f s t a b
type Traversal' a b = Traversal b b a a
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 = Iso b b a a
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) -> Getter' u v a b
getter f = lens f undefined

-- |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)

-- |Retrieve a value from a structure using a 'Lens' (or 'Iso')
infixl 8 ^.,^..,^?,%~
(^.) = flip at
(^..) = flip at'
-- |
(%~) = warp
(%-) = set
(^?) :: (Unit f,Monoid (f b)) => a -> Traversal' a b -> f b
x^?l = getConst $ l (Const . pure) x

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

_1 :: Lens a b (a:*:c) (b:*:c)
_1 = lens fst (flip (first . const))
_2 :: Lens a b (c:*:a) (c:*:b)
_2 = lens snd (flip (second . const))
_l :: Traversal a b (a:+:c) (b:+:c)
_l = prism ((id ||| Right) >>> swapE) (flip (left . const))
_r :: Traversal a b (c:+:a) (c:+:b)
_r = prism (Left ||| id) (flip (right . const))

swapE = Right<|>Left

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''
_list :: [a] :<->: (():+:(a:*:[a]))
_list = iso (\l -> case l of
                [] -> Left ()
                (x:t) -> Right (x,t)) (const [] <|> uncurry (:))

_head :: Traversal' [a] a
_head = _list._r._1
_tail :: Traversal' [a] [a]
_tail = _list._r._2

_mapping :: 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)
_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
  _iso :: Iso s t a b
instance Isomorphic a b (Id a) (Id b) where
  _iso = iso Id getId
instance Isomorphic [a] [b] (OrdList a) (OrdList b) where
  _iso = iso OrdList getOrdList
instance Isomorphic a b (Const a c) (Const b c) where
  _iso = iso Const getConst
instance Isomorphic a b (Dual a) (Dual b) where
  _iso = iso Dual getDual
instance Isomorphic a b (Max a) (Max b) where
  _iso = iso Max getMax
instance Isomorphic (k a a) (k b b) (Endo k a) (Endo k b) where
  _iso = iso Endo runEndo
instance Isomorphic (f a b) (f c d) (Flip f b a) (Flip f d c) where
  _iso = iso Flip unFlip
instance Isomorphic Bool Bool (Maybe Void) (Maybe Void) where
  _iso = iso (bool (Just zero) Nothing) (maybe False (const True))
instance Isomorphic (f (g a)) (f' (g' b)) (Compose f g a) (Compose f' g' b) where
  _iso = iso Compose getCompose
instance Isomorphic a b (Void,a) (Void,b) where
  _iso = iso (vd,) snd
_Id = _iso :: Iso' a (Id a)
_OrdList = _iso :: Iso' [a] (OrdList a)
_Dual = _iso :: Iso' a (Dual a)
_Const = _iso :: Iso' a (Const a b)
_Max = _iso :: Iso' a (Max a)
_Endo = _iso :: Iso' (k a a) (Endo k a)
_maybe = _iso :: Iso' Bool (Maybe Void)
_Flip = _iso :: Iso' (f a b) (Flip f b a)
_Compose = _iso :: Iso (Compose f g a) (Compose f' g' b) (f (g a)) (f' (g' b))
_Backwards = iso Backwards forwards
_Accum = iso Accum getAccum

warp2 :: Iso s t a b -> (s -> s -> t) -> (a -> a -> b)
warp2 i (**) = (\b b' -> ((b^.i) ** (b'^.i))^..i)

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

instance IsoFunctor ((->) a) where mapIso = _mapping
instance IsoFunctor2 (->) where mapIso2 i j = _promapping i._mapping j
instance IsoFunctor2 (,) where
  mapIso2 i j = iso (at i <#> at j) (at' i <#> at' j)
instance IsoFunctor2 Either where
  mapIso2 i j = iso (at i ||| at j) (at' i ||| at' j)

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

_thunk :: Iso a b (IO a) (IO b)
_thunk = iso unsafePerformIO evaluate