{-# 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',
  Fold,Fold',
  Getter,Getter',
  Lens,Lens',
  Traversal,Traversal',

  -- * Constructing lenses
  iso,from,lens,getter,prism,sat,simple,(.+),

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

  -- * Isomorphisms
  Isomorphic(..),
  adding,
  _Id,_OrdList,_Const,_Dual,_Endo,_Flip,_maybe,_Max,_Compose,_Backwards,
  warp2,_mapping,_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' a b = Getter b b a a
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 Fold s t a b = forall f. (Semigroup (f b),Applicative f) => LensLike f s t a b
type Fold' a b = Fold 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) -> 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)

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 at
(^..) :: a -> Iso a a b b -> b
(^..) = flip at'
-- |
(%~) :: Traversal s t a b -> (s -> t) -> (a -> b)
(%~) = warp
(%%~) :: Iso s t a b -> (b -> a) -> (t -> s)
(%%~) i = warp (from i)
(%-) :: Traversal 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

simple :: Iso' a b -> Iso' a b
simple i = i

(-.) :: Getter c u b v -> (a -> b) -> a -> c
l-.f = at l.f
(.-) :: (b -> c) -> Iso a a b b -> a -> c
f.-i = f.at' i
infixr 9 -.,.-
at :: Getter b u a v -> 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))
_Just :: Traversal a b (Maybe a) (Maybe b)
_Just = prism (\a -> maybe (Left Nothing) Right a) (flip (<$))

swapE :: (b:+:a) -> (a:+:b)
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''
instance Compound a b (a:+:a) (b:+:b) where
  _each k = map Left . k <|> map Right . k
_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,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
  _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)) ((f:.:g) a) ((f':.:g') b) where
  _iso = iso Compose getCompose
instance Isomorphic a b (Void,a) (Void,b) where
  _iso = iso (zero,) snd
_Id :: Iso (Id a) (Id b) a b
_Id = _iso
_OrdList :: Iso (OrdList a) (OrdList b) [a] [b]
_OrdList = _iso
_Dual :: Iso (Dual a) (Dual b) a b
_Dual = _iso
_Const :: Iso (Const a c) (Const b c) a b
_Const = _iso
_Max :: Iso (Max a) (Max b) a b 
_Max = _iso
_Endo :: Iso (Endo k a) (Endo k b) (k a a) (k b b)
_Endo = _iso 
_maybe :: Iso' Bool (Maybe Void)
_maybe = _iso 
_Flip :: Iso (Flip f b a) (Flip f d c) (f a b) (f c d)
_Flip = _iso
_Compose :: Iso ((f:.:g) a) ((f':.:g') b) (f (g a)) (f' (g' b))
_Compose = _iso
_Backwards :: Iso (Backwards f a) (Backwards f b) (f a) (f b)
_Backwards = iso Backwards forwards
_Accum :: Iso (Accum a) (Accum b) (Maybe a) (Maybe b)
_Accum = iso Accum getAccum

warp2 :: Iso s t a b -> (s -> s -> t) -> (a -> a -> b)
warp2 i f = \a a' -> at' i (at i a`f`at 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 <.>

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,Semigroup n) => n -> Iso' n n
adding n = iso (+n) (subtract n)

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