{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE DeriveDataTypeable #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Control.Lens.Iso
-- Copyright   :  (C) 2012 Edward Kmett
-- License     :  BSD-style (see the file LICENSE)
-- Maintainer  :  Edward Kmett <ekmett@gmail.com>
-- Stability   :  provisional
-- Portability :  Rank2Types
--
----------------------------------------------------------------------------
module Control.Lens.Iso
  (
  -- * Isomorphisms
    Isomorphic(..)
  , Isomorphism(..)
  , iso
  , isos
  , from
  , via
  , Iso
  , SimpleIso
  , _const
  , identity
  ) where

import Control.Applicative
import Control.Category
import Data.Functor.Identity
import Data.Typeable
import Prelude hiding ((.),id)

----------------------------------------------------------------------------
-- Isomorphism Implementation Details
-----------------------------------------------------------------------------

-- | Used to provide overloading of isomorphism application
--
-- This is a 'Category' with a canonical mapping to it from the
-- category of isomorphisms over Haskell types.
class Category k => Isomorphic k where
  -- | Build this morphism out of an isomorphism
  --
  -- The intention is that by using 'isomorphic', you can supply both halves of an
  -- isomorphism, but k can be instantiated to (->), so you can freely use
  -- the resulting isomorphism as a function.
  isomorphic :: (a -> b) -> (b -> a) -> k a b

  -- | Map a morphism in the target category using an isomorphism between morphisms
  -- in Hask.
  isomap :: ((a -> b) -> c -> d) -> ((b -> a) -> d -> c) -> k a b -> k c d

instance Isomorphic (->) where
  isomorphic = const
  {-# INLINE isomorphic #-}
  isomap = const
  {-# INLINE isomap #-}

-- | A concrete data type for isomorphisms.
--
-- This lets you place an isomorphism inside a container without using @ImpredicativeTypes@.
data Isomorphism a b = Isomorphism (a -> b) (b -> a)
  deriving Typeable

instance Category Isomorphism where
  id = Isomorphism id id
  {-# INLINE id #-}
  Isomorphism bc cb . Isomorphism ab ba = Isomorphism (bc . ab) (ba . cb)
  {-# INLINE (.) #-}

instance Isomorphic Isomorphism where
  isomorphic = Isomorphism
  {-# INLINE isomorphic #-}
  isomap abcd badc (Isomorphism ab ba) = Isomorphism (abcd ab) (badc ba)
  {-# INLINE isomap #-}

-- | Invert an isomorphism.
--
-- Note to compose an isomorphism and receive an isomorphism in turn you'll need to use
-- 'Control.Category.Category'
--
-- > from (from l) = l
--
-- If you imported 'Control.Category.(.)', then:
--
-- > from l . from r = from (r . l)
--
-- > from :: (a :~> b) -> (b :~> a)
from :: Isomorphic k => Isomorphism a b -> k b a
from (Isomorphism a b) = isomorphic b a
{-# INLINE from #-}
{-# SPECIALIZE from :: Isomorphism a b -> b -> a #-}
{-# SPECIALIZE from :: Isomorphism a b -> Isomorphism b a #-}

-- |
-- > via :: Isomorphism a b -> (a :~> b)
via :: Isomorphic k => Isomorphism a b -> k a b
via (Isomorphism a b) = isomorphic a b
{-# INLINE via #-}
{-# SPECIALIZE via :: Isomorphism a b -> a -> b #-}
{-# SPECIALIZE via :: Isomorphism a b -> Isomorphism a b #-}

-----------------------------------------------------------------------------
-- Isomorphisms families as Lenses
-----------------------------------------------------------------------------

-- | Isomorphim families can be composed with other lenses using either' (.)' and 'id'
-- from the Prelude or from Control.Category. However, if you compose them
-- with each other using '(.)' from the Prelude, they will be dumbed down to a
-- mere 'Lens'.
--
-- > import Control.Category
-- > import Prelude hiding ((.),id)
--
-- > type Iso a b c d = forall k f. (Isomorphic k, Functor f) => Overloaded k f a b c d
type Iso a b c d = forall k f. (Isomorphic k, Functor f) => k (c -> f d) (a -> f b)

-- | > type SimpleIso a b = Simple Iso a b
type SimpleIso a b = Iso a a b b

-- | Build an isomorphism family from two pairs of inverse functions
--
-- > isos :: (a -> c) -> (c -> a) -> (b -> d) -> (d -> b) -> Iso a b c d
isos :: (Isomorphic k, Functor f) => (a -> c) -> (c -> a) -> (b -> d) -> (d -> b) -> k (c -> f d) (a -> f b)
isos ac ca bd db = isomorphic
  (\cfd a -> db <$> cfd (ac a))
  (\afb c -> bd <$> afb (ca c))
{-# INLINE isos #-}
{-# SPECIALIZE isos :: Functor f => (a -> c) -> (c -> a) -> (b -> d) -> (d -> b) -> (c -> f d) -> a -> f b #-}
{-# SPECIALIZE isos :: Functor f => (a -> c) -> (c -> a) -> (b -> d) -> (d -> b) -> Isomorphism (c -> f d) (a -> f b) #-}

-- | Build a simple isomorphism from a pair of inverse functions
--
-- > iso :: (a -> b) -> (b -> a) -> Simple Iso a b
iso :: (Isomorphic k, Functor f) => (a -> b) -> (b -> a) -> k (b -> f b) (a -> f a)
iso ab ba = isos ab ba ab ba
{-# INLINE iso #-}
{-# SPECIALIZE iso :: Functor f => (a -> b) -> (b -> a) -> (b -> f b) -> a -> f a #-}
{-# SPECIALIZE iso :: Functor f => (a -> b) -> (b -> a) -> Isomorphism (b -> f b) (a -> f a) #-}

-----------------------------------------------------------------------------
-- Isomorphisms
-----------------------------------------------------------------------------

-- | This isomorphism can be used to wrap or unwrap a value in 'Identity'.
--
-- > x^.identity = Identity x
-- > Identity x^.from identity = x
identity :: Iso a b (Identity a) (Identity b)
identity = isos Identity runIdentity Identity runIdentity
{-# INLINE identity #-}

-- | This isomorphism can be used to wrap or unwrap a value in 'Const'
--
-- > x^._const = Const x
-- > Const x^.from _const = x
_const :: Iso a b (Const a c) (Const b d)
_const = isos Const getConst Const getConst
{-# INLINE _const #-}