{-# LANGUAGE TypeFamilies #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Data.Extensible.League
-- Copyright   :  (c) Fumiaki Kinoshita 2018
-- License     :  BSD3
--
-- Maintainer  :  Fumiaki Kinoshita <fumiexcel@gmail.com>
--
-- Pattern matching
------------------------------------------------------------------------
module Data.Extensible.Match (
  matchWith
  , Match(..)
  , match
  , mapMatch
  , caseOf) where

import Data.Extensible.Internal.Rig
import Data.Extensible.Class
import Data.Extensible.Product
import Data.Extensible.Sum
import Data.Extensible.Wrapper
import Data.Typeable (Typeable)
import Data.Profunctor.Unsafe
import GHC.Generics (Generic)

-- | Retrieve the contents so that they matches and pass both to the given function.
matchWith :: (forall x. f x -> g x -> r) -> xs :& f -> xs :/ g -> r
matchWith :: forall {k} (f :: k -> Type) (g :: k -> Type) r (xs :: [k]).
(forall (x :: k). f x -> g x -> r) -> (xs :& f) -> (xs :/ g) -> r
matchWith forall (x :: k). f x -> g x -> r
f xs :& f
p = \(EmbedAt Membership xs x
i g x
h) -> Optic' (->) (Const (g x -> r)) (xs :& f) (f x)
-> (f x -> g x -> r) -> (xs :& f) -> g x -> r
forall r s a. Optic' (->) (Const r) s a -> (a -> r) -> s -> r
views (Membership xs x -> Optic' (->) (Const (g x -> r)) (xs :& f) (f x)
forall (xs :: [k]) (h :: k -> Type) (x :: k).
ExtensibleConstr (:&) xs h x =>
Membership xs x -> Optic' (->) (Const (g x -> r)) (xs :& h) (h x)
forall k (f :: Type -> Type) (p :: Type -> Type -> Type)
       (t :: [k] -> (k -> Type) -> Type) (xs :: [k]) (h :: k -> Type)
       (x :: k).
(Extensible f p t, ExtensibleConstr t xs h x) =>
Membership xs x -> Optic' p f (t xs h) (h x)
pieceAt Membership xs x
i) f x -> g x -> r
forall (x :: k). f x -> g x -> r
f xs :& f
p g x
h
{-# INLINE matchWith #-}

-- | Applies a function to the result of 'Match'.
mapMatch :: (a -> b) -> Match h a x -> Match h b x
mapMatch :: forall {k} a b (h :: k -> Type) (x :: k).
(a -> b) -> Match h a x -> Match h b x
mapMatch a -> b
f = (h x -> b) -> Match h b x
forall {k} (h :: k -> Type) r (x :: k). (h x -> r) -> Match h r x
Match ((h x -> b) -> Match h b x)
-> ((h x -> a) -> h x -> b) -> (h x -> a) -> Match h b x
forall a b c (q :: Type -> Type -> Type).
Coercible c b =>
q b c -> (a -> b) -> a -> c
forall (p :: Type -> Type -> Type) a b c
       (q :: Type -> Type -> Type).
(Profunctor p, Coercible c b) =>
q b c -> p a b -> p a c
#. (a -> b
f(a -> b) -> (h x -> a) -> h x -> b
forall b c a. (b -> c) -> (a -> b) -> a -> c
.) ((h x -> a) -> Match h b x)
-> (Match h a x -> h x -> a) -> Match h a x -> Match h b x
forall a b c (q :: Type -> Type -> Type).
Coercible b a =>
(b -> c) -> q a b -> a -> c
forall (p :: Type -> Type -> Type) a b c
       (q :: Type -> Type -> Type).
(Profunctor p, Coercible b a) =>
p b c -> q a b -> p a c
.# Match h a x -> h x -> a
forall {k} (h :: k -> Type) r (x :: k). Match h r x -> h x -> r
runMatch
{-# INLINE mapMatch #-}

-- | /O(1)/ Perform pattern matching.
match :: xs :& Match h a -> xs :/ h -> a
match :: forall {k} (xs :: [k]) (h :: k -> Type) a.
(xs :& Match h a) -> (xs :/ h) -> a
match = (forall (x :: k). Match h a x -> h x -> a)
-> (xs :& Match h a) -> (xs :/ h) -> a
forall {k} (f :: k -> Type) (g :: k -> Type) r (xs :: [k]).
(forall (x :: k). f x -> g x -> r) -> (xs :& f) -> (xs :/ g) -> r
matchWith Match h a x -> h x -> a
forall (x :: k). Match h a x -> h x -> a
forall {k} (h :: k -> Type) r (x :: k). Match h r x -> h x -> r
runMatch
{-# INLINE match #-}

-- | Flipped `match`
caseOf :: xs :/ h -> xs :& Match h a -> a
caseOf :: forall {k} (xs :: [k]) (h :: k -> Type) a.
(xs :/ h) -> (xs :& Match h a) -> a
caseOf = ((xs :& Match h a) -> (xs :/ h) -> a)
-> (xs :/ h) -> (xs :& Match h a) -> a
forall a b c. (a -> b -> c) -> b -> a -> c
flip (xs :& Match h a) -> (xs :/ h) -> a
forall {k} (xs :: [k]) (h :: k -> Type) a.
(xs :& Match h a) -> (xs :/ h) -> a
match
{-# INLINE caseOf #-}
infix 0 `caseOf`

-- | Turn a wrapper type into a clause for it.
newtype Match h r x = Match { forall {k} (h :: k -> Type) r (x :: k). Match h r x -> h x -> r
runMatch :: h x -> r }
  deriving (Typeable, (forall x. Match h r x -> Rep (Match h r x) x)
-> (forall x. Rep (Match h r x) x -> Match h r x)
-> Generic (Match h r x)
forall x. Rep (Match h r x) x -> Match h r x
forall x. Match h r x -> Rep (Match h r x) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall k (h :: k -> Type) r (x :: k) x.
Rep (Match h r x) x -> Match h r x
forall k (h :: k -> Type) r (x :: k) x.
Match h r x -> Rep (Match h r x) x
$cfrom :: forall k (h :: k -> Type) r (x :: k) x.
Match h r x -> Rep (Match h r x) x
from :: forall x. Match h r x -> Rep (Match h r x) x
$cto :: forall k (h :: k -> Type) r (x :: k) x.
Rep (Match h r x) x -> Match h r x
to :: forall x. Rep (Match h r x) x -> Match h r x
Generic, NonEmpty (Match h r x) -> Match h r x
Match h r x -> Match h r x -> Match h r x
(Match h r x -> Match h r x -> Match h r x)
-> (NonEmpty (Match h r x) -> Match h r x)
-> (forall b. Integral b => b -> Match h r x -> Match h r x)
-> Semigroup (Match h r x)
forall b. Integral b => b -> Match h r x -> Match h r x
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
forall k (h :: k -> Type) r (x :: k).
Semigroup r =>
NonEmpty (Match h r x) -> Match h r x
forall k (h :: k -> Type) r (x :: k).
Semigroup r =>
Match h r x -> Match h r x -> Match h r x
forall k (h :: k -> Type) r (x :: k) b.
(Semigroup r, Integral b) =>
b -> Match h r x -> Match h r x
$c<> :: forall k (h :: k -> Type) r (x :: k).
Semigroup r =>
Match h r x -> Match h r x -> Match h r x
<> :: Match h r x -> Match h r x -> Match h r x
$csconcat :: forall k (h :: k -> Type) r (x :: k).
Semigroup r =>
NonEmpty (Match h r x) -> Match h r x
sconcat :: NonEmpty (Match h r x) -> Match h r x
$cstimes :: forall k (h :: k -> Type) r (x :: k) b.
(Semigroup r, Integral b) =>
b -> Match h r x -> Match h r x
stimes :: forall b. Integral b => b -> Match h r x -> Match h r x
Semigroup, Semigroup (Match h r x)
Match h r x
Semigroup (Match h r x) =>
Match h r x
-> (Match h r x -> Match h r x -> Match h r x)
-> ([Match h r x] -> Match h r x)
-> Monoid (Match h r x)
[Match h r x] -> Match h r x
Match h r x -> Match h r x -> Match h r x
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
forall k (h :: k -> Type) r (x :: k).
Monoid r =>
Semigroup (Match h r x)
forall k (h :: k -> Type) r (x :: k). Monoid r => Match h r x
forall k (h :: k -> Type) r (x :: k).
Monoid r =>
[Match h r x] -> Match h r x
forall k (h :: k -> Type) r (x :: k).
Monoid r =>
Match h r x -> Match h r x -> Match h r x
$cmempty :: forall k (h :: k -> Type) r (x :: k). Monoid r => Match h r x
mempty :: Match h r x
$cmappend :: forall k (h :: k -> Type) r (x :: k).
Monoid r =>
Match h r x -> Match h r x -> Match h r x
mappend :: Match h r x -> Match h r x -> Match h r x
$cmconcat :: forall k (h :: k -> Type) r (x :: k).
Monoid r =>
[Match h r x] -> Match h r x
mconcat :: [Match h r x] -> Match h r x
Monoid)

instance Wrapper h => Wrapper (Match h r) where
  type Repr (Match h r) x = Repr h x -> r
  _Wrapper :: forall (f :: Type -> Type) (p :: Type -> Type -> Type) (v :: k).
(Functor f, Profunctor p) =>
Optic' p f (Match h r v) (Repr (Match h r) v)
_Wrapper = Optic
  (Exchange (Repr h v) (Repr h v))
  Identity
  (h v)
  (h v)
  (Repr h v)
  (Repr h v)
-> ((h v -> Repr h v)
    -> (Repr h v -> h v)
    -> Optic' p f (Match h r v) (Repr (Match h r) v))
-> Optic' p f (Match h r v) (Repr (Match h r) v)
forall a b s t r.
Optic (Exchange a b) Identity s t a b
-> ((s -> a) -> (b -> t) -> r) -> r
withIso Optic
  (Exchange (Repr h v) (Repr h v))
  Identity
  (h v)
  (h v)
  (Repr h v)
  (Repr h v)
forall k (h :: k -> Type) (f :: Type -> Type)
       (p :: Type -> Type -> Type) (v :: k).
(Wrapper h, Functor f, Profunctor p) =>
Optic' p f (h v) (Repr h v)
forall (f :: Type -> Type) (p :: Type -> Type -> Type) (v :: k).
(Functor f, Profunctor p) =>
Optic' p f (h v) (Repr h v)
_Wrapper (((h v -> Repr h v)
  -> (Repr h v -> h v)
  -> Optic' p f (Match h r v) (Repr (Match h r) v))
 -> Optic' p f (Match h r v) (Repr (Match h r) v))
-> ((h v -> Repr h v)
    -> (Repr h v -> h v)
    -> Optic' p f (Match h r v) (Repr (Match h r) v))
-> Optic' p f (Match h r v) (Repr (Match h r) v)
forall a b. (a -> b) -> a -> b
$ \h v -> Repr h v
f Repr h v -> h v
g -> (Match h r v -> Repr h v -> r)
-> (f (Repr h v -> r) -> f (Match h r v))
-> p (Repr h v -> r) (f (Repr h v -> r))
-> p (Match h r v) (f (Match h r v))
forall a b c d. (a -> b) -> (c -> d) -> p b c -> p a d
forall (p :: Type -> Type -> Type) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap (((h v -> r) -> (Repr h v -> h v) -> Repr h v -> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Repr h v -> h v
g) ((h v -> r) -> Repr h v -> r)
-> (Match h r v -> h v -> r) -> Match h r v -> Repr h v -> r
forall a b c (q :: Type -> Type -> Type).
Coercible b a =>
(b -> c) -> q a b -> a -> c
forall (p :: Type -> Type -> Type) a b c
       (q :: Type -> Type -> Type).
(Profunctor p, Coercible b a) =>
p b c -> q a b -> p a c
.# Match h r v -> h v -> r
forall {k} (h :: k -> Type) r (x :: k). Match h r x -> h x -> r
runMatch) (((Repr h v -> r) -> Match h r v)
-> f (Repr h v -> r) -> f (Match h r v)
forall a b. (a -> b) -> f a -> f b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap ((h v -> r) -> Match h r v
forall {k} (h :: k -> Type) r (x :: k). (h x -> r) -> Match h r x
Match ((h v -> r) -> Match h r v)
-> ((Repr h v -> r) -> h v -> r) -> (Repr h v -> r) -> Match h r v
forall a b c (q :: Type -> Type -> Type).
Coercible c b =>
q b c -> (a -> b) -> a -> c
forall (p :: Type -> Type -> Type) a b c
       (q :: Type -> Type -> Type).
(Profunctor p, Coercible c b) =>
q b c -> p a b -> p a c
#. ((Repr h v -> r) -> (h v -> Repr h v) -> h v -> r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. h v -> Repr h v
f)))
  {-# INLINE _Wrapper #-}