{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}

{-|
Module      : Data.As
Description : Simple extensible sum
Copyright   : (c) incertia, 2020
License     : MIT
Maintainer  : incertia@incertia.net
Stability   : experimental
Portability : portable

This module provides the 'As' class which is a multi parameter classy prism,
much like how 'Data.Has.Has' is a multi parameter classy lens.

We have the following primary use case for 'As'.

@
 -- some library code
 throwE :: (As e err, MonadError err m) => e -> m ()
 throwE = throwError . review asPrism
@
-}

module Data.As
  ( As(..)
  ) where

import Data.Functor.Const
  (Const(..))
import Data.Functor.Identity
  (Identity(..))
import Data.Monoid
  (First(..))
import Data.Profunctor
  (Profunctor, Choice(..), dimap, right')
import Data.Profunctor.Unsafe
  ((.#), (#.))
import Data.Void
  (Void, absurd)
import Text.Read
  (readMaybe)

-- inline our own Tagged
newtype Tagged s b = Tagged { Tagged s b -> b
unTagged :: b }

instance Profunctor Tagged where
  dimap :: (a -> b) -> (c -> d) -> Tagged b c -> Tagged a d
dimap a -> b
_ c -> d
f (Tagged c
s) = d -> Tagged a d
forall s b. b -> Tagged s b
Tagged (c -> d
f c
s)

instance Choice Tagged where
  left' :: Tagged a b -> Tagged (Either a c) (Either b c)
left' (Tagged b
b) = Either b c -> Tagged (Either a c) (Either b c)
forall s b. b -> Tagged s b
Tagged (b -> Either b c
forall a b. a -> Either a b
Left b
b)
  right' :: Tagged a b -> Tagged (Either c a) (Either c b)
right' (Tagged b
b) = Either c b -> Tagged (Either c a) (Either c b)
forall s b. b -> Tagged s b
Tagged (b -> Either c b
forall a b. b -> Either a b
Right b
b)

-- inline local Prism type so we don't depend on lens
-- unfortunately this means we need to depend on profunctor
type Prism t a = forall p f. (Choice p, Applicative f) => p a (f a) -> p t (f t)

-- these definitions are ripped directly from lens
-- | A typeclass for extensible sums.
--
-- The provided instances were inspired from the lens library.
--
-- Making your own instances when you actually depend on lens should be as easy
-- as @instance As Foo Bar where asPrism = _Foo@.
class As a t where
  {-# MINIMAL previewer, reviewer | asPrism #-}
  previewer :: t -> Maybe a
  previewer = First a -> Maybe a
forall a. First a -> Maybe a
getFirst (First a -> Maybe a) -> (t -> First a) -> t -> Maybe a
forall (p :: * -> * -> *) a b c (q :: * -> * -> *).
(Profunctor p, Coercible c b) =>
q b c -> p a b -> p a c
#. Const (First a) t -> First a
forall a k (b :: k). Const a b -> a
getConst (Const (First a) t -> First a)
-> (t -> Const (First a) t) -> t -> First a
forall (p :: * -> * -> *) a b c (q :: * -> * -> *).
(Profunctor p, Coercible c b) =>
q b c -> p a b -> p a c
#. (a -> Const (First a) a) -> t -> Const (First a) t
forall a t. As a t => Prism t a
asPrism (First a -> Const (First a) a
forall k a (b :: k). a -> Const a b
Const (First a -> Const (First a) a)
-> (a -> First a) -> a -> Const (First a) a
forall (p :: * -> * -> *) a b c (q :: * -> * -> *).
(Profunctor p, Coercible c b) =>
q b c -> p a b -> p a c
#. Maybe a -> First a
forall a. Maybe a -> First a
First (Maybe a -> First a) -> (a -> Maybe a) -> a -> First a
forall (p :: * -> * -> *) a b c (q :: * -> * -> *).
(Profunctor p, Coercible c b) =>
q b c -> p a b -> p a c
#. a -> Maybe a
forall a. a -> Maybe a
Just)

  reviewer :: a -> t
  reviewer = Identity t -> t
forall a. Identity a -> a
runIdentity (Identity t -> t)
-> (Tagged a (Identity a) -> Identity t)
-> Tagged a (Identity a)
-> t
forall (p :: * -> * -> *) a b c (q :: * -> * -> *).
(Profunctor p, Coercible c b) =>
q b c -> p a b -> p a c
#. Tagged t (Identity t) -> Identity t
forall s b. Tagged s b -> b
unTagged (Tagged t (Identity t) -> Identity t)
-> (Tagged a (Identity a) -> Tagged t (Identity t))
-> Tagged a (Identity a)
-> Identity t
forall (p :: * -> * -> *) a b c (q :: * -> * -> *).
(Profunctor p, Coercible c b) =>
q b c -> p a b -> p a c
#. Tagged a (Identity a) -> Tagged t (Identity t)
forall a t. As a t => Prism t a
asPrism (Tagged a (Identity a) -> t)
-> (Identity a -> Tagged a (Identity a)) -> Identity a -> t
forall (p :: * -> * -> *) a b c (q :: * -> * -> *).
(Profunctor p, Coercible b a) =>
p b c -> q a b -> p a c
.# Identity a -> Tagged a (Identity a)
forall s b. b -> Tagged s b
Tagged (Identity a -> t) -> (a -> Identity a) -> a -> t
forall (p :: * -> * -> *) a b c (q :: * -> * -> *).
(Profunctor p, Coercible b a) =>
p b c -> q a b -> p a c
.# a -> Identity a
forall a. a -> Identity a
Identity

  asPrism :: Prism t a
  asPrism = (t -> Either t a)
-> (Either t (f a) -> f t)
-> p (Either t a) (Either t (f a))
-> p t (f t)
forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap (\t
a -> Either t a -> (a -> Either t a) -> Maybe a -> Either t a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (t -> Either t a
forall a b. a -> Either a b
Left t
a) a -> Either t a
forall a b. b -> Either a b
Right (t -> Maybe a
forall a t. As a t => t -> Maybe a
previewer t
a)) ((t -> f t) -> (f a -> f t) -> Either t (f a) -> f t
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either t -> f t
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((a -> t) -> f a -> f t
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> t
forall a t. As a t => a -> t
reviewer)) (p (Either t a) (Either t (f a)) -> p t (f t))
-> (p a (f a) -> p (Either t a) (Either t (f a)))
-> p a (f a)
-> p t (f t)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p a (f a) -> p (Either t a) (Either t (f a))
forall (p :: * -> * -> *) a b c.
Choice p =>
p a b -> p (Either c a) (Either c b)
right'

  modifier :: (a -> a) -> t -> t
  modifier a -> a
f = Identity t -> t
forall a. Identity a -> a
runIdentity (Identity t -> t) -> (t -> Identity t) -> t -> t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Identity a) -> t -> Identity t
forall a t. As a t => Prism t a
asPrism (a -> Identity a
forall a. a -> Identity a
Identity (a -> Identity a) -> (a -> a) -> a -> Identity a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a
f)

-- some instances based on the lens library
instance As a a where
  asPrism :: p a (f a) -> p a (f a)
asPrism = p a (f a) -> p a (f a)
forall a. a -> a
id
  {-# INLINABLE asPrism #-}

instance As a (Maybe a) where
  previewer :: Maybe a -> Maybe a
previewer = Maybe a -> Maybe a
forall a. a -> a
id
  {-# INLINABLE previewer #-}
  reviewer :: a -> Maybe a
reviewer = a -> Maybe a
forall a. a -> Maybe a
Just
  {-# INLINABLE reviewer #-}

instance As () (Maybe a) where
  previewer :: Maybe a -> Maybe ()
previewer Maybe a
ma = case Maybe a
ma of
                   Maybe a
Nothing -> () -> Maybe ()
forall a. a -> Maybe a
Just ()
                   Just a
_  -> Maybe ()
forall a. Maybe a
Nothing
  {-# INLINABLE previewer #-}
  reviewer :: () -> Maybe a
reviewer () = Maybe a
forall a. Maybe a
Nothing
  {-# INLINABLE reviewer #-}

instance As a (Either a b) where
  previewer :: Either a b -> Maybe a
previewer Either a b
eab = case Either a b
eab of
                    Left a
a  -> a -> Maybe a
forall a. a -> Maybe a
Just a
a
                    Right b
_ -> Maybe a
forall a. Maybe a
Nothing
  {-# INLINABLE previewer #-}
  reviewer :: a -> Either a b
reviewer = a -> Either a b
forall a b. a -> Either a b
Left
  {-# INLINABLE reviewer #-}

instance As b (Either a b) where
  previewer :: Either a b -> Maybe b
previewer Either a b
eab = case Either a b
eab of
                    Right b
b -> b -> Maybe b
forall a. a -> Maybe a
Just b
b
                    Left a
_  -> Maybe b
forall a. Maybe a
Nothing
  {-# INLINABLE previewer #-}
  reviewer :: b -> Either a b
reviewer = b -> Either a b
forall a b. b -> Either a b
Right
  {-# INLINABLE reviewer #-}

instance (Read a, Show a) => As a String where
  previewer :: String -> Maybe a
previewer = String -> Maybe a
forall a. Read a => String -> Maybe a
readMaybe
  {-# INLINABLE previewer #-}
  reviewer :: a -> String
reviewer = a -> String
forall a. Show a => a -> String
show
  {-# INLINABLE reviewer #-}

instance As Void a where
  previewer :: a -> Maybe Void
previewer a
_ = Maybe Void
forall a. Maybe a
Nothing
  {-# INLINABLE previewer #-}
  reviewer :: Void -> a
reviewer = Void -> a
forall a. Void -> a
absurd
  {-# INLINABLE reviewer #-}