{-# LANGUAGE MultiParamTypeClasses, ScopedTypeVariables, TypeFamilies, RankNTypes, DefaultSignatures, TypeApplications, UndecidableInstances, PackageImports #-}

module Data.Reflection.Constraint where

import Prelude hiding (Functor, (<$>), map)
import Control.Categorical.Functor
import Data.Constraint
import Data.Function (on)
import Data.Morphism.Iso
import Data.Proxy
import Data.Reflection (Reifies (..), reify)

newtype Reflected c s a = Reflected { Reflected c s a -> a
unReflected :: a }

unReflected' :: proxy s -> Reflected c s a -> a
unReflected' :: proxy s -> Reflected c s a -> a
unReflected' _ = Reflected c s a -> a
forall k (c :: k) k (s :: k) a. Reflected c s a -> a
unReflected

class Functor (Iso (->)) (->) (Methods c) => Reifiable c where
    data Methods c a
    reifiable :: Reifies s (Methods c a) => Dict (c (Reflected c s a))
    default reifiable :: c (Reflected c s a) => Dict (c (Reflected c s a))
    reifiable = Dict (c (Reflected c s a))
forall (a :: Constraint). a => Dict a
Dict

reifiable' :: (Reifiable c, Reifies s (Methods c a)) => proxy s -> Dict (c (Reflected c s a))
reifiable' :: proxy s -> Dict (c (Reflected c s a))
reifiable' _ = Dict (c (Reflected c s a))
forall (c :: * -> Constraint) k (s :: k) a.
(Reifiable c, Reifies s (Methods c a)) =>
Dict (c (Reflected c s a))
reifiable

by ::  c f a . (Reifiable c, Functor (Iso (->)) (->) f) => Methods c a -> ( a . c a => f a) -> f a
by :: Methods c a -> (forall a. c a => f a) -> f a
by methods :: Methods c a
methods a :: forall a. c a => f a
a = Methods c a
-> (forall s. Reifies s (Methods c a) => Proxy s -> f a) -> f a
forall a r. a -> (forall s. Reifies s a => Proxy s -> r) -> r
reify Methods c a
methods (\ proxy :: Proxy s
proxy -> (Reflected c s a -> a)
-> (a -> Reflected c s a) -> Iso (->) (Reflected c s a) a
forall k (s :: k -> k -> *) (a :: k) (b :: k).
s a b -> s b a -> Iso s a b
Iso (Proxy s -> Reflected c s a -> a
forall k k (proxy :: k -> *) (s :: k) (c :: k) a.
proxy s -> Reflected c s a -> a
unReflected' Proxy s
proxy) (forall s a. a -> Reflected c s a
forall k k (c :: k) (s :: k) a. a -> Reflected c s a
Reflected @c) Iso (->) (Reflected c s a) a -> f (Reflected c s a) -> f a
forall α (s :: α -> α -> *) (f :: α -> *) (a :: α) (b :: α).
Functor s (->) f =>
s a b -> f a -> f b
<$> Dict (c (Reflected c s a))
-> (c (Reflected c s a) => f (Reflected c s a))
-> f (Reflected c s a)
forall (a :: Constraint) b. Dict a -> (a => b) -> b
withDict (Proxy s -> Dict (c (Reflected c s a))
forall k (c :: * -> Constraint) (s :: k) a (proxy :: k -> *).
(Reifiable c, Reifies s (Methods c a)) =>
proxy s -> Dict (c (Reflected c s a))
reifiable' Proxy s
proxy) c (Reflected c s a) => f (Reflected c s a)
forall a. c a => f a
a)

instance Reifiable Eq  where newtype Methods Eq  a = EqMethods  { Methods Eq a -> a -> a -> Bool
eqMethod      :: a -> a -> Bool }
instance Reifiable Ord where newtype Methods Ord a = OrdMethods { Methods Ord a -> a -> a -> Ordering
compareMethod :: a -> a -> Ordering }

instance Reifiable Semigroup where newtype Methods Semigroup a = SemigroupMethods { Methods Semigroup a -> a -> a -> a
combineMethod :: a -> a -> a }
instance Reifiable Monoid    where data    Methods Monoid    a = MonoidMethods    { Methods Monoid a -> Methods Semigroup a
semigroupMethods :: Methods Semigroup a
                                                                                  , Methods Monoid a -> a
memptyMethod :: a }

instance {-# OVERLAPPING #-} Functor (Iso (->)) (->) (Methods Ord) where map :: Iso (->) a b -> Methods Ord a -> Methods Ord b
map (Iso _ f :: b -> a
f) (OrdMethods cmp) = (b -> b -> Ordering) -> Methods Ord b
forall a. (a -> a -> Ordering) -> Methods Ord a
OrdMethods (a -> a -> Ordering
cmp (a -> a -> Ordering) -> (b -> a) -> b -> b -> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` b -> a
f)
instance {-# OVERLAPPING #-} Functor (Iso (->)) (->) (Methods Eq)  where map :: Iso (->) a b -> Methods Eq a -> Methods Eq b
map (Iso _ f :: b -> a
f) (EqMethods  eq)  = (b -> b -> Bool) -> Methods Eq b
forall a. (a -> a -> Bool) -> Methods Eq a
EqMethods  (a -> a -> Bool
eq  (a -> a -> Bool) -> (b -> a) -> b -> b -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` b -> a
f)

instance {-# OVERLAPPING #-} Functor (Iso (->)) (->) (Methods Semigroup) where map :: Iso (->) a b -> Methods Semigroup a -> Methods Semigroup b
map (Iso f :: a -> b
f f' :: b -> a
f') (SemigroupMethods (<>))  = (b -> b -> b) -> Methods Semigroup b
forall a. (a -> a -> a) -> Methods Semigroup a
SemigroupMethods (\ a :: b
a b :: b
b -> a -> b
f (b -> a
f' b
a a -> a -> a
<> b -> a
f' b
b))
instance {-# OVERLAPPING #-} Functor (Iso (->)) (->) (Methods Monoid)    where map :: Iso (->) a b -> Methods Monoid a -> Methods Monoid b
map φ :: Iso (->) a b
φ@(Iso f :: a -> b
f _) (MonoidMethods sg mempty)  = Methods Semigroup b -> b -> Methods Monoid b
forall a. Methods Semigroup a -> a -> Methods Monoid a
MonoidMethods (Iso (->) a b
φ Iso (->) a b -> Methods Semigroup a -> Methods Semigroup b
forall α (s :: α -> α -> *) (f :: α -> *) (a :: α) (b :: α).
Functor s (->) f =>
s a b -> f a -> f b
<$> Methods Semigroup a
sg) (a -> b
f a
mempty)

instance Reifies s (Methods Eq a) => Eq (Reflected Eq s a) where
    == :: Reflected Eq s a -> Reflected Eq s a -> Bool
(==) = (Methods Eq a -> a -> a -> Bool
forall a. Methods Eq a -> a -> a -> Bool
eqMethod (Methods Eq a -> a -> a -> Bool)
-> (Proxy s -> Methods Eq a) -> Proxy s -> a -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy s -> Methods Eq a
forall k (s :: k) a (proxy :: k -> *). Reifies s a => proxy s -> a
reflect) (Proxy s
forall k (t :: k). Proxy t
Proxy @s) (a -> a -> Bool)
-> (Reflected Eq s a -> a)
-> Reflected Eq s a
-> Reflected Eq s a
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Reflected Eq s a -> a
forall k (c :: k) k (s :: k) a. Reflected c s a -> a
unReflected

instance Reifies s (Methods Ord a) => Eq (Reflected Ord s a) where
    x :: Reflected Ord s a
x == :: Reflected Ord s a -> Reflected Ord s a -> Bool
== y :: Reflected Ord s a
y = Ordering
EQ Ordering -> Ordering -> Bool
forall a. Eq a => a -> a -> Bool
== Reflected Ord s a -> Reflected Ord s a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Reflected Ord s a
x Reflected Ord s a
y

instance Reifies s (Methods Ord a) => Ord (Reflected Ord s a) where
    compare :: Reflected Ord s a -> Reflected Ord s a -> Ordering
compare = (Methods Ord a -> a -> a -> Ordering
forall a. Methods Ord a -> a -> a -> Ordering
compareMethod (Methods Ord a -> a -> a -> Ordering)
-> (Proxy s -> Methods Ord a) -> Proxy s -> a -> a -> Ordering
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy s -> Methods Ord a
forall k (s :: k) a (proxy :: k -> *). Reifies s a => proxy s -> a
reflect) (Proxy s
forall k (t :: k). Proxy t
Proxy @s) (a -> a -> Ordering)
-> (Reflected Ord s a -> a)
-> Reflected Ord s a
-> Reflected Ord s a
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Reflected Ord s a -> a
forall k (c :: k) k (s :: k) a. Reflected c s a -> a
unReflected

instance Reifies s (Methods Semigroup a) => Semigroup (Reflected Semigroup s a) where
    a :: Reflected Semigroup s a
a <> :: Reflected Semigroup s a
-> Reflected Semigroup s a -> Reflected Semigroup s a
<> b :: Reflected Semigroup s a
b = a -> Reflected Semigroup s a
forall k k (c :: k) (s :: k) a. a -> Reflected c s a
Reflected (a -> Reflected Semigroup s a) -> a -> Reflected Semigroup s a
forall a b. (a -> b) -> a -> b
$ ((Methods Semigroup a -> a -> a -> a
forall a. Methods Semigroup a -> a -> a -> a
combineMethod (Methods Semigroup a -> a -> a -> a)
-> (Proxy s -> Methods Semigroup a) -> Proxy s -> a -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy s -> Methods Semigroup a
forall k (s :: k) a (proxy :: k -> *). Reifies s a => proxy s -> a
reflect) (Proxy s
forall k (t :: k). Proxy t
Proxy @s) (a -> a -> a)
-> (Reflected Semigroup s a -> a)
-> Reflected Semigroup s a
-> Reflected Semigroup s a
-> a
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Reflected Semigroup s a -> a
forall k (c :: k) k (s :: k) a. Reflected c s a -> a
unReflected) Reflected Semigroup s a
a Reflected Semigroup s a
b

instance Reifies s (Methods Monoid a) => Semigroup (Reflected Monoid s a) where
    a :: Reflected Monoid s a
a <> :: Reflected Monoid s a
-> Reflected Monoid s a -> Reflected Monoid s a
<> b :: Reflected Monoid s a
b = a -> Reflected Monoid s a
forall k k (c :: k) (s :: k) a. a -> Reflected c s a
Reflected (a -> Reflected Monoid s a) -> a -> Reflected Monoid s a
forall a b. (a -> b) -> a -> b
$ ((Methods Semigroup a -> a -> a -> a
forall a. Methods Semigroup a -> a -> a -> a
combineMethod (Methods Semigroup a -> a -> a -> a)
-> (Proxy s -> Methods Semigroup a) -> Proxy s -> a -> a -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Methods Monoid a -> Methods Semigroup a
forall a. Methods Monoid a -> Methods Semigroup a
semigroupMethods (Methods Monoid a -> Methods Semigroup a)
-> (Proxy s -> Methods Monoid a) -> Proxy s -> Methods Semigroup a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy s -> Methods Monoid a
forall k (s :: k) a (proxy :: k -> *). Reifies s a => proxy s -> a
reflect) (Proxy s
forall k (t :: k). Proxy t
Proxy @s) (a -> a -> a)
-> (Reflected Monoid s a -> a)
-> Reflected Monoid s a
-> Reflected Monoid s a
-> a
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Reflected Monoid s a -> a
forall k (c :: k) k (s :: k) a. Reflected c s a -> a
unReflected) Reflected Monoid s a
a Reflected Monoid s a
b

instance Reifies s (Methods Monoid a) => Monoid (Reflected Monoid s a) where
    mempty :: Reflected Monoid s a
mempty = a -> Reflected Monoid s a
forall k k (c :: k) (s :: k) a. a -> Reflected c s a
Reflected (a -> Reflected Monoid s a) -> a -> Reflected Monoid s a
forall a b. (a -> b) -> a -> b
$ (Methods Monoid a -> a
forall a. Methods Monoid a -> a
memptyMethod (Methods Monoid a -> a)
-> (Proxy s -> Methods Monoid a) -> Proxy s -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy s -> Methods Monoid a
forall k (s :: k) a (proxy :: k -> *). Reifies s a => proxy s -> a
reflect) (Proxy s
forall k (t :: k). Proxy t
Proxy @s)