{-# OPTIONS_GHC -fno-warn-orphans #-}

module Control.Isomorphism.Partial.Prim
  ( Iso ()
  , inverse
  , apply
  , unapply
  , IsoFunctor ((<$>))
  , ignore
  , (***)
  , (|||)
  , associate
  , commute
  , unit
  , element
  , subset
  , iterate
  , distribute
  ) where

import Prelude ()

import Control.Monad (liftM2, (>=>), fmap, mplus)
import Control.Category (Category (id, (.)))

import Data.Bool (Bool, otherwise)
import Data.Either (Either (Left, Right))
import Data.Eq (Eq ((==)))
import Data.Maybe (Maybe (Just, Nothing))

import Control.Isomorphism.Partial.Unsafe (Iso (Iso))

inverse :: Iso alpha beta -> Iso beta alpha
inverse :: forall alpha beta. Iso alpha beta -> Iso beta alpha
inverse (Iso alpha -> Maybe beta
f beta -> Maybe alpha
g) = (beta -> Maybe alpha) -> (alpha -> Maybe beta) -> Iso beta alpha
forall alpha beta.
(alpha -> Maybe beta) -> (beta -> Maybe alpha) -> Iso alpha beta
Iso beta -> Maybe alpha
g alpha -> Maybe beta
f

apply :: Iso alpha beta -> alpha -> Maybe beta
apply :: forall alpha beta. Iso alpha beta -> alpha -> Maybe beta
apply (Iso alpha -> Maybe beta
f beta -> Maybe alpha
_) = alpha -> Maybe beta
f

unapply  ::  Iso alpha beta -> beta -> Maybe alpha
unapply :: forall alpha beta. Iso alpha beta -> beta -> Maybe alpha
unapply  =   Iso beta alpha -> beta -> Maybe alpha
forall alpha beta. Iso alpha beta -> alpha -> Maybe beta
apply (Iso beta alpha -> beta -> Maybe alpha)
-> (Iso alpha beta -> Iso beta alpha)
-> Iso alpha beta
-> beta
-> Maybe alpha
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. Iso alpha beta -> Iso beta alpha
forall alpha beta. Iso alpha beta -> Iso beta alpha
inverse

instance Category Iso where
  Iso b c
g . :: forall b c a. Iso b c -> Iso a b -> Iso a c
. Iso a b
f  =  (a -> Maybe c) -> (c -> Maybe a) -> Iso a c
forall alpha beta.
(alpha -> Maybe beta) -> (beta -> Maybe alpha) -> Iso alpha beta
Iso  (Iso a b -> a -> Maybe b
forall alpha beta. Iso alpha beta -> alpha -> Maybe beta
apply Iso a b
f (a -> Maybe b) -> (b -> Maybe c) -> a -> Maybe c
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Iso b c -> b -> Maybe c
forall alpha beta. Iso alpha beta -> alpha -> Maybe beta
apply Iso b c
g)
                 (Iso b c -> c -> Maybe b
forall alpha beta. Iso alpha beta -> beta -> Maybe alpha
unapply Iso b c
g (c -> Maybe b) -> (b -> Maybe a) -> c -> Maybe a
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Iso a b -> b -> Maybe a
forall alpha beta. Iso alpha beta -> beta -> Maybe alpha
unapply Iso a b
f)
  id :: forall a. Iso a a
id     =  (a -> Maybe a) -> (a -> Maybe a) -> Iso a a
forall alpha beta.
(alpha -> Maybe beta) -> (beta -> Maybe alpha) -> Iso alpha beta
Iso  a -> Maybe a
forall a. a -> Maybe a
Just a -> Maybe a
forall a. a -> Maybe a
Just

infix 5 <$>

class IsoFunctor f where
  (<$>) :: Iso alpha beta -> (f alpha -> f beta)

ignore :: alpha -> Iso alpha ()
ignore :: forall alpha. alpha -> Iso alpha ()
ignore alpha
x = (alpha -> Maybe ()) -> (() -> Maybe alpha) -> Iso alpha ()
forall alpha beta.
(alpha -> Maybe beta) -> (beta -> Maybe alpha) -> Iso alpha beta
Iso alpha -> Maybe ()
forall {p}. p -> Maybe ()
f () -> Maybe alpha
g where
  f :: p -> Maybe ()
f p
_   =  () -> Maybe ()
forall a. a -> Maybe a
Just ()
  g :: () -> Maybe alpha
g ()  =  alpha -> Maybe alpha
forall a. a -> Maybe a
Just alpha
x

-- | the product type constructor `(,)` is a bifunctor from

-- `Iso` $\times$ `Iso` to `Iso`, so that we have the

-- bifunctorial map `***` which allows two separate isomorphisms

-- to work on the two components of a tuple.

(***) :: Iso alpha beta -> Iso gamma delta -> Iso (alpha, gamma) (beta, delta)
Iso alpha beta
i *** :: forall alpha beta gamma delta.
Iso alpha beta
-> Iso gamma delta -> Iso (alpha, gamma) (beta, delta)
*** Iso gamma delta
j = ((alpha, gamma) -> Maybe (beta, delta))
-> ((beta, delta) -> Maybe (alpha, gamma))
-> Iso (alpha, gamma) (beta, delta)
forall alpha beta.
(alpha -> Maybe beta) -> (beta -> Maybe alpha) -> Iso alpha beta
Iso (alpha, gamma) -> Maybe (beta, delta)
f (beta, delta) -> Maybe (alpha, gamma)
g where
  f :: (alpha, gamma) -> Maybe (beta, delta)
f (alpha
a, gamma
b) = (beta -> delta -> (beta, delta))
-> Maybe beta -> Maybe delta -> Maybe (beta, delta)
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (,) (Iso alpha beta -> alpha -> Maybe beta
forall alpha beta. Iso alpha beta -> alpha -> Maybe beta
apply Iso alpha beta
i alpha
a) (Iso gamma delta -> gamma -> Maybe delta
forall alpha beta. Iso alpha beta -> alpha -> Maybe beta
apply Iso gamma delta
j gamma
b)
  g :: (beta, delta) -> Maybe (alpha, gamma)
g (beta
c, delta
d) = (alpha -> gamma -> (alpha, gamma))
-> Maybe alpha -> Maybe gamma -> Maybe (alpha, gamma)
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (,) (Iso alpha beta -> beta -> Maybe alpha
forall alpha beta. Iso alpha beta -> beta -> Maybe alpha
unapply Iso alpha beta
i beta
c) (Iso gamma delta -> delta -> Maybe gamma
forall alpha beta. Iso alpha beta -> beta -> Maybe alpha
unapply Iso gamma delta
j delta
d)

-- | The mediating arrow for sums constructed with `Either`.

-- This is not a proper partial isomorphism because of `mplus`.

(|||) :: Iso alpha gamma -> Iso beta gamma -> Iso (Either alpha beta) gamma
Iso alpha gamma
i ||| :: forall alpha gamma beta.
Iso alpha gamma -> Iso beta gamma -> Iso (Either alpha beta) gamma
||| Iso beta gamma
j = (Either alpha beta -> Maybe gamma)
-> (gamma -> Maybe (Either alpha beta))
-> Iso (Either alpha beta) gamma
forall alpha beta.
(alpha -> Maybe beta) -> (beta -> Maybe alpha) -> Iso alpha beta
Iso Either alpha beta -> Maybe gamma
f gamma -> Maybe (Either alpha beta)
g where
  f :: Either alpha beta -> Maybe gamma
f (Left alpha
x) = Iso alpha gamma -> alpha -> Maybe gamma
forall alpha beta. Iso alpha beta -> alpha -> Maybe beta
apply Iso alpha gamma
i alpha
x
  f (Right beta
x) = Iso beta gamma -> beta -> Maybe gamma
forall alpha beta. Iso alpha beta -> alpha -> Maybe beta
apply Iso beta gamma
j beta
x
  g :: gamma -> Maybe (Either alpha beta)
g gamma
y = (alpha -> Either alpha beta
forall a b. a -> Either a b
Left (alpha -> Either alpha beta)
-> Maybe alpha -> Maybe (Either alpha beta)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Iso alpha gamma -> gamma -> Maybe alpha
forall alpha beta. Iso alpha beta -> beta -> Maybe alpha
unapply Iso alpha gamma
i gamma
y) Maybe (Either alpha beta)
-> Maybe (Either alpha beta) -> Maybe (Either alpha beta)
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` (beta -> Either alpha beta
forall a b. b -> Either a b
Right (beta -> Either alpha beta)
-> Maybe beta -> Maybe (Either alpha beta)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Iso beta gamma -> gamma -> Maybe beta
forall alpha beta. Iso alpha beta -> beta -> Maybe alpha
unapply Iso beta gamma
j gamma
y)


-- | Nested products associate.

associate :: Iso (alpha, (beta, gamma)) ((alpha, beta), gamma)
associate :: forall alpha beta gamma.
Iso (alpha, (beta, gamma)) ((alpha, beta), gamma)
associate = ((alpha, (beta, gamma)) -> Maybe ((alpha, beta), gamma))
-> (((alpha, beta), gamma) -> Maybe (alpha, (beta, gamma)))
-> Iso (alpha, (beta, gamma)) ((alpha, beta), gamma)
forall alpha beta.
(alpha -> Maybe beta) -> (beta -> Maybe alpha) -> Iso alpha beta
Iso (alpha, (beta, gamma)) -> Maybe ((alpha, beta), gamma)
forall {a} {b} {b}. (a, (b, b)) -> Maybe ((a, b), b)
f ((alpha, beta), gamma) -> Maybe (alpha, (beta, gamma))
forall {a} {a} {b}. ((a, a), b) -> Maybe (a, (a, b))
g where
  f :: (a, (b, b)) -> Maybe ((a, b), b)
f (a
a, (b
b, b
c)) = ((a, b), b) -> Maybe ((a, b), b)
forall a. a -> Maybe a
Just ((a
a, b
b), b
c)
  g :: ((a, a), b) -> Maybe (a, (a, b))
g ((a
a, a
b), b
c) = (a, (a, b)) -> Maybe (a, (a, b))
forall a. a -> Maybe a
Just (a
a, (a
b, b
c))

-- | Products commute.

commute :: Iso (alpha, beta) (beta, alpha)
commute :: forall alpha beta. Iso (alpha, beta) (beta, alpha)
commute = ((alpha, beta) -> Maybe (beta, alpha))
-> ((beta, alpha) -> Maybe (alpha, beta))
-> Iso (alpha, beta) (beta, alpha)
forall alpha beta.
(alpha -> Maybe beta) -> (beta -> Maybe alpha) -> Iso alpha beta
Iso (alpha, beta) -> Maybe (beta, alpha)
forall {b} {a}. (b, a) -> Maybe (a, b)
f (beta, alpha) -> Maybe (alpha, beta)
forall {b} {a}. (b, a) -> Maybe (a, b)
f where
  f :: (b, a) -> Maybe (a, b)
f (b
a, a
b) = (a, b) -> Maybe (a, b)
forall a. a -> Maybe a
Just (a
b, b
a)

-- | `()` is the unit element for products.

unit :: Iso alpha (alpha, ())
unit :: forall alpha. Iso alpha (alpha, ())
unit = (alpha -> Maybe (alpha, ()))
-> ((alpha, ()) -> Maybe alpha) -> Iso alpha (alpha, ())
forall alpha beta.
(alpha -> Maybe beta) -> (beta -> Maybe alpha) -> Iso alpha beta
Iso alpha -> Maybe (alpha, ())
forall {a}. a -> Maybe (a, ())
f (alpha, ()) -> Maybe alpha
forall {a}. (a, ()) -> Maybe a
g where
  f :: a -> Maybe (a, ())
f a
a = (a, ()) -> Maybe (a, ())
forall a. a -> Maybe a
Just (a
a, ())
  g :: (a, ()) -> Maybe a
g (a
a, ()) = a -> Maybe a
forall a. a -> Maybe a
Just a
a

-- | Products distribute over sums.

distribute  ::  Iso (alpha, Either beta gamma) (Either (alpha, beta) (alpha, gamma))
distribute :: forall alpha beta gamma.
Iso
  (alpha, Either beta gamma) (Either (alpha, beta) (alpha, gamma))
distribute  =   ((alpha, Either beta gamma)
 -> Maybe (Either (alpha, beta) (alpha, gamma)))
-> (Either (alpha, beta) (alpha, gamma)
    -> Maybe (alpha, Either beta gamma))
-> Iso
     (alpha, Either beta gamma) (Either (alpha, beta) (alpha, gamma))
forall alpha beta.
(alpha -> Maybe beta) -> (beta -> Maybe alpha) -> Iso alpha beta
Iso (alpha, Either beta gamma)
-> Maybe (Either (alpha, beta) (alpha, gamma))
forall {a} {b} {b}. (a, Either b b) -> Maybe (Either (a, b) (a, b))
f Either (alpha, beta) (alpha, gamma)
-> Maybe (alpha, Either beta gamma)
forall {a} {a} {b}. Either (a, a) (a, b) -> Maybe (a, Either a b)
g where
  f :: (a, Either b b) -> Maybe (Either (a, b) (a, b))
f (a
a, Left   b
b)    =  Either (a, b) (a, b) -> Maybe (Either (a, b) (a, b))
forall a. a -> Maybe a
Just ((a, b) -> Either (a, b) (a, b)
forall a b. a -> Either a b
Left   (a
a, b
b))
  f (a
a, Right  b
c)    =  Either (a, b) (a, b) -> Maybe (Either (a, b) (a, b))
forall a. a -> Maybe a
Just ((a, b) -> Either (a, b) (a, b)
forall a b. b -> Either a b
Right  (a
a, b
c))
  g :: Either (a, a) (a, b) -> Maybe (a, Either a b)
g (Left   (a
a, a
b))  =  (a, Either a b) -> Maybe (a, Either a b)
forall a. a -> Maybe a
Just (a
a,  a -> Either a b
forall a b. a -> Either a b
Left   a
b)
  g (Right  (a
a, b
b))  =  (a, Either a b) -> Maybe (a, Either a b)
forall a. a -> Maybe a
Just (a
a,  b -> Either a b
forall a b. b -> Either a b
Right  b
b)

-- | `element x` is the partial isomorphism between `()` and the

-- singleton set which contains just `x`.

element :: Eq alpha => alpha -> Iso () alpha
element :: forall alpha. Eq alpha => alpha -> Iso () alpha
element alpha
x = (() -> Maybe alpha) -> (alpha -> Maybe ()) -> Iso () alpha
forall alpha beta.
(alpha -> Maybe beta) -> (beta -> Maybe alpha) -> Iso alpha beta
Iso
  (\()
_ -> alpha -> Maybe alpha
forall a. a -> Maybe a
Just alpha
x)
  (\alpha
b -> if alpha
x alpha -> alpha -> Bool
forall a. Eq a => a -> a -> Bool
== alpha
b then () -> Maybe ()
forall a. a -> Maybe a
Just () else Maybe ()
forall a. Maybe a
Nothing)

-- | For a predicate `p`, `subset p` is the identity isomorphism

-- restricted to elements matching the predicate.

subset :: (alpha -> Bool) -> Iso alpha alpha
subset :: forall alpha. (alpha -> Bool) -> Iso alpha alpha
subset alpha -> Bool
p = (alpha -> Maybe alpha) -> (alpha -> Maybe alpha) -> Iso alpha alpha
forall alpha beta.
(alpha -> Maybe beta) -> (beta -> Maybe alpha) -> Iso alpha beta
Iso alpha -> Maybe alpha
f alpha -> Maybe alpha
f where
  f :: alpha -> Maybe alpha
f alpha
x | alpha -> Bool
p alpha
x = alpha -> Maybe alpha
forall a. a -> Maybe a
Just alpha
x | Bool
otherwise = Maybe alpha
forall a. Maybe a
Nothing

iterate :: Iso alpha alpha -> Iso alpha alpha
iterate :: forall alpha. Iso alpha alpha -> Iso alpha alpha
iterate Iso alpha alpha
step = (alpha -> Maybe alpha) -> (alpha -> Maybe alpha) -> Iso alpha alpha
forall alpha beta.
(alpha -> Maybe beta) -> (beta -> Maybe alpha) -> Iso alpha beta
Iso alpha -> Maybe alpha
f alpha -> Maybe alpha
g where
  f :: alpha -> Maybe alpha
f = alpha -> Maybe alpha
forall a. a -> Maybe a
Just (alpha -> Maybe alpha) -> (alpha -> alpha) -> alpha -> Maybe alpha
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (alpha -> Maybe alpha) -> alpha -> alpha
forall alpha. (alpha -> Maybe alpha) -> alpha -> alpha
driver (Iso alpha alpha -> alpha -> Maybe alpha
forall alpha beta. Iso alpha beta -> alpha -> Maybe beta
apply Iso alpha alpha
step)
  g :: alpha -> Maybe alpha
g = alpha -> Maybe alpha
forall a. a -> Maybe a
Just (alpha -> Maybe alpha) -> (alpha -> alpha) -> alpha -> Maybe alpha
forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k).
Category cat =>
cat b c -> cat a b -> cat a c
. (alpha -> Maybe alpha) -> alpha -> alpha
forall alpha. (alpha -> Maybe alpha) -> alpha -> alpha
driver (Iso alpha alpha -> alpha -> Maybe alpha
forall alpha beta. Iso alpha beta -> beta -> Maybe alpha
unapply Iso alpha alpha
step)

  driver :: (alpha -> Maybe alpha) -> (alpha -> alpha)
  driver :: forall alpha. (alpha -> Maybe alpha) -> alpha -> alpha
driver alpha -> Maybe alpha
step' alpha
state
    =  case alpha -> Maybe alpha
step' alpha
state of
         Just alpha
state'  ->  (alpha -> Maybe alpha) -> alpha -> alpha
forall alpha. (alpha -> Maybe alpha) -> alpha -> alpha
driver alpha -> Maybe alpha
step' alpha
state'
         Maybe alpha
Nothing      ->  alpha
state