{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE OverloadedStrings #-}
module HGeometry.Ext where
import Control.DeepSeq
import Control.Lens hiding ((.=))
import Data.Aeson
import Data.Aeson.Types (typeMismatch)
import Data.Biapplicative
import Data.Bifoldable
import Data.Bifunctor.Apply
import Data.Bitraversable
import Data.Default.Class
import Data.Functor.Apply (liftF2)
import Data.Semigroup.Bifoldable
import Data.Semigroup.Bitraversable
import GHC.Generics (Generic)
import System.Random.Stateful (Uniform(..), UniformRange(..))
data core :+ extra = core :+ extra deriving (Int -> (core :+ extra) -> ShowS
[core :+ extra] -> ShowS
(core :+ extra) -> String
(Int -> (core :+ extra) -> ShowS)
-> ((core :+ extra) -> String)
-> ([core :+ extra] -> ShowS)
-> Show (core :+ extra)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall core extra.
(Show core, Show extra) =>
Int -> (core :+ extra) -> ShowS
forall core extra.
(Show core, Show extra) =>
[core :+ extra] -> ShowS
forall core extra.
(Show core, Show extra) =>
(core :+ extra) -> String
$cshowsPrec :: forall core extra.
(Show core, Show extra) =>
Int -> (core :+ extra) -> ShowS
showsPrec :: Int -> (core :+ extra) -> ShowS
$cshow :: forall core extra.
(Show core, Show extra) =>
(core :+ extra) -> String
show :: (core :+ extra) -> String
$cshowList :: forall core extra.
(Show core, Show extra) =>
[core :+ extra] -> ShowS
showList :: [core :+ extra] -> ShowS
Show,ReadPrec [core :+ extra]
ReadPrec (core :+ extra)
Int -> ReadS (core :+ extra)
ReadS [core :+ extra]
(Int -> ReadS (core :+ extra))
-> ReadS [core :+ extra]
-> ReadPrec (core :+ extra)
-> ReadPrec [core :+ extra]
-> Read (core :+ extra)
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
forall core extra.
(Read core, Read extra) =>
ReadPrec [core :+ extra]
forall core extra.
(Read core, Read extra) =>
ReadPrec (core :+ extra)
forall core extra.
(Read core, Read extra) =>
Int -> ReadS (core :+ extra)
forall core extra. (Read core, Read extra) => ReadS [core :+ extra]
$creadsPrec :: forall core extra.
(Read core, Read extra) =>
Int -> ReadS (core :+ extra)
readsPrec :: Int -> ReadS (core :+ extra)
$creadList :: forall core extra. (Read core, Read extra) => ReadS [core :+ extra]
readList :: ReadS [core :+ extra]
$creadPrec :: forall core extra.
(Read core, Read extra) =>
ReadPrec (core :+ extra)
readPrec :: ReadPrec (core :+ extra)
$creadListPrec :: forall core extra.
(Read core, Read extra) =>
ReadPrec [core :+ extra]
readListPrec :: ReadPrec [core :+ extra]
Read,(core :+ extra) -> (core :+ extra) -> Bool
((core :+ extra) -> (core :+ extra) -> Bool)
-> ((core :+ extra) -> (core :+ extra) -> Bool)
-> Eq (core :+ extra)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall core extra.
(Eq core, Eq extra) =>
(core :+ extra) -> (core :+ extra) -> Bool
$c== :: forall core extra.
(Eq core, Eq extra) =>
(core :+ extra) -> (core :+ extra) -> Bool
== :: (core :+ extra) -> (core :+ extra) -> Bool
$c/= :: forall core extra.
(Eq core, Eq extra) =>
(core :+ extra) -> (core :+ extra) -> Bool
/= :: (core :+ extra) -> (core :+ extra) -> Bool
Eq,Eq (core :+ extra)
Eq (core :+ extra) =>
((core :+ extra) -> (core :+ extra) -> Ordering)
-> ((core :+ extra) -> (core :+ extra) -> Bool)
-> ((core :+ extra) -> (core :+ extra) -> Bool)
-> ((core :+ extra) -> (core :+ extra) -> Bool)
-> ((core :+ extra) -> (core :+ extra) -> Bool)
-> ((core :+ extra) -> (core :+ extra) -> core :+ extra)
-> ((core :+ extra) -> (core :+ extra) -> core :+ extra)
-> Ord (core :+ extra)
(core :+ extra) -> (core :+ extra) -> Bool
(core :+ extra) -> (core :+ extra) -> Ordering
(core :+ extra) -> (core :+ extra) -> core :+ extra
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall core extra. (Ord core, Ord extra) => Eq (core :+ extra)
forall core extra.
(Ord core, Ord extra) =>
(core :+ extra) -> (core :+ extra) -> Bool
forall core extra.
(Ord core, Ord extra) =>
(core :+ extra) -> (core :+ extra) -> Ordering
forall core extra.
(Ord core, Ord extra) =>
(core :+ extra) -> (core :+ extra) -> core :+ extra
$ccompare :: forall core extra.
(Ord core, Ord extra) =>
(core :+ extra) -> (core :+ extra) -> Ordering
compare :: (core :+ extra) -> (core :+ extra) -> Ordering
$c< :: forall core extra.
(Ord core, Ord extra) =>
(core :+ extra) -> (core :+ extra) -> Bool
< :: (core :+ extra) -> (core :+ extra) -> Bool
$c<= :: forall core extra.
(Ord core, Ord extra) =>
(core :+ extra) -> (core :+ extra) -> Bool
<= :: (core :+ extra) -> (core :+ extra) -> Bool
$c> :: forall core extra.
(Ord core, Ord extra) =>
(core :+ extra) -> (core :+ extra) -> Bool
> :: (core :+ extra) -> (core :+ extra) -> Bool
$c>= :: forall core extra.
(Ord core, Ord extra) =>
(core :+ extra) -> (core :+ extra) -> Bool
>= :: (core :+ extra) -> (core :+ extra) -> Bool
$cmax :: forall core extra.
(Ord core, Ord extra) =>
(core :+ extra) -> (core :+ extra) -> core :+ extra
max :: (core :+ extra) -> (core :+ extra) -> core :+ extra
$cmin :: forall core extra.
(Ord core, Ord extra) =>
(core :+ extra) -> (core :+ extra) -> core :+ extra
min :: (core :+ extra) -> (core :+ extra) -> core :+ extra
Ord,core :+ extra
(core :+ extra) -> (core :+ extra) -> Bounded (core :+ extra)
forall a. a -> a -> Bounded a
forall core extra. (Bounded core, Bounded extra) => core :+ extra
$cminBound :: forall core extra. (Bounded core, Bounded extra) => core :+ extra
minBound :: core :+ extra
$cmaxBound :: forall core extra. (Bounded core, Bounded extra) => core :+ extra
maxBound :: core :+ extra
Bounded,(forall x. (core :+ extra) -> Rep (core :+ extra) x)
-> (forall x. Rep (core :+ extra) x -> core :+ extra)
-> Generic (core :+ extra)
forall x. Rep (core :+ extra) x -> core :+ extra
forall x. (core :+ extra) -> Rep (core :+ extra) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall core extra x. Rep (core :+ extra) x -> core :+ extra
forall core extra x. (core :+ extra) -> Rep (core :+ extra) x
$cfrom :: forall core extra x. (core :+ extra) -> Rep (core :+ extra) x
from :: forall x. (core :+ extra) -> Rep (core :+ extra) x
$cto :: forall core extra x. Rep (core :+ extra) x -> core :+ extra
to :: forall x. Rep (core :+ extra) x -> core :+ extra
Generic,(core :+ extra) -> ()
((core :+ extra) -> ()) -> NFData (core :+ extra)
forall a. (a -> ()) -> NFData a
forall core extra.
(NFData core, NFData extra) =>
(core :+ extra) -> ()
$crnf :: forall core extra.
(NFData core, NFData extra) =>
(core :+ extra) -> ()
rnf :: (core :+ extra) -> ()
NFData)
infixr 1 :+
instance Functor ((:+) c) where
fmap :: forall a b. (a -> b) -> (c :+ a) -> c :+ b
fmap a -> b
f (c
c :+ a
e) = c
c c -> b -> c :+ b
forall core extra. core -> extra -> core :+ extra
:+ a -> b
f a
e
{-# INLINE fmap #-}
instance Foldable ((:+) c) where
foldMap :: forall m a. Monoid m => (a -> m) -> (c :+ a) -> m
foldMap a -> m
f (c
_ :+ a
e) = a -> m
f a
e
{-# INLINE foldMap #-}
instance Traversable ((:+) c) where
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> (c :+ a) -> f (c :+ b)
traverse a -> f b
f (c
c :+ a
e) = c -> b -> c :+ b
forall core extra. core -> extra -> core :+ extra
(:+) c
c (b -> c :+ b) -> f b -> f (c :+ b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f b
f a
e
{-# INLINE traverse #-}
instance Bifunctor (:+) where
bimap :: forall a b c d. (a -> b) -> (c -> d) -> (a :+ c) -> b :+ d
bimap a -> b
f c -> d
g (a
c :+ c
e) = a -> b
f a
c b -> d -> b :+ d
forall core extra. core -> extra -> core :+ extra
:+ c -> d
g c
e
{-# INLINE bimap #-}
instance Biapply (:+) where
(a -> b
f :+ c -> d
g) <<.>> :: forall a b c d. ((a -> b) :+ (c -> d)) -> (a :+ c) -> b :+ d
<<.>> (a
c :+ c
e) = a -> b
f a
c b -> d -> b :+ d
forall core extra. core -> extra -> core :+ extra
:+ c -> d
g c
e
{-# INLINE (<<.>>) #-}
instance Biapplicative (:+) where
bipure :: forall core extra. core -> extra -> core :+ extra
bipure = a -> b -> a :+ b
forall core extra. core -> extra -> core :+ extra
(:+)
{-# INLINE bipure #-}
(a -> b
f :+ c -> d
g) <<*>> :: forall a b c d. ((a -> b) :+ (c -> d)) -> (a :+ c) -> b :+ d
<<*>> (a
c :+ c
e) = a -> b
f a
c b -> d -> b :+ d
forall core extra. core -> extra -> core :+ extra
:+ c -> d
g c
e
{-# INLINE (<<*>>) #-}
instance Bifoldable (:+) where
bifoldMap :: forall m a b. Monoid m => (a -> m) -> (b -> m) -> (a :+ b) -> m
bifoldMap a -> m
f b -> m
g (a
c :+ b
e) = a -> m
f a
c m -> m -> m
forall a. Monoid a => a -> a -> a
`mappend` b -> m
g b
e
{-# INLINE bifoldMap #-}
instance Bitraversable (:+) where
bitraverse :: forall (f :: * -> *) a c b d.
Applicative f =>
(a -> f c) -> (b -> f d) -> (a :+ b) -> f (c :+ d)
bitraverse a -> f c
f b -> f d
g (a
c :+ b
e) = c -> d -> c :+ d
forall core extra. core -> extra -> core :+ extra
(:+) (c -> d -> c :+ d) -> f c -> f (d -> c :+ d)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f c
f a
c f (d -> c :+ d) -> f d -> f (c :+ d)
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> b -> f d
g b
e
{-# INLINE bitraverse #-}
instance Bifoldable1 (:+) where
bifoldMap1 :: forall m a b. Semigroup m => (a -> m) -> (b -> m) -> (a :+ b) -> m
bifoldMap1 a -> m
f b -> m
g (a
c :+ b
e) = a -> m
f a
c m -> m -> m
forall a. Semigroup a => a -> a -> a
<> b -> m
g b
e
{-# INLINE bifoldMap1 #-}
instance Bitraversable1 (:+) where
bitraverse1 :: forall (f :: * -> *) a b c d.
Apply f =>
(a -> f b) -> (c -> f d) -> (a :+ c) -> f (b :+ d)
bitraverse1 a -> f b
f c -> f d
g (a
c :+ c
e) = (b -> d -> b :+ d) -> f b -> f d -> f (b :+ d)
forall a b c. (a -> b -> c) -> f a -> f b -> f c
forall (f :: * -> *) a b c.
Apply f =>
(a -> b -> c) -> f a -> f b -> f c
liftF2 b -> d -> b :+ d
forall core extra. core -> extra -> core :+ extra
(:+) (a -> f b
f a
c) (c -> f d
g c
e)
{-# INLINE bitraverse1 #-}
instance (Semigroup core, Semigroup extra) => Semigroup (core :+ extra) where
(core
c :+ extra
e) <> :: (core :+ extra) -> (core :+ extra) -> core :+ extra
<> (core
c' :+ extra
e') = core
c core -> core -> core
forall a. Semigroup a => a -> a -> a
<> core
c' core -> extra -> core :+ extra
forall core extra. core -> extra -> core :+ extra
:+ extra
e extra -> extra -> extra
forall a. Semigroup a => a -> a -> a
<> extra
e'
{-# INLINE (<>) #-}
instance (ToJSON core, ToJSON extra) => ToJSON (core :+ extra) where
toJSON :: (core :+ extra) -> Value
toJSON (core
c :+ extra
e) = [Pair] -> Value
object [Key
"core" Key -> core -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= core
c, Key
"extra" Key -> extra -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= extra
e]
toEncoding :: (core :+ extra) -> Encoding
toEncoding (core
c :+ extra
e) = Series -> Encoding
pairs (Key
"core" Key -> core -> Series
forall v. ToJSON v => Key -> v -> Series
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= core
c Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<> Key
"extra" Key -> extra -> Series
forall v. ToJSON v => Key -> v -> Series
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= extra
e)
instance (FromJSON core, FromJSON extra) => FromJSON (core :+ extra) where
parseJSON :: Value -> Parser (core :+ extra)
parseJSON (Object Object
v) = core -> extra -> core :+ extra
forall core extra. core -> extra -> core :+ extra
(:+) (core -> extra -> core :+ extra)
-> Parser core -> Parser (extra -> core :+ extra)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Key -> Parser core
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"core" Parser (extra -> core :+ extra)
-> Parser extra -> Parser (core :+ extra)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Key -> Parser extra
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"extra"
parseJSON Value
invalid = String -> Value -> Parser (core :+ extra)
forall a. String -> Value -> Parser a
typeMismatch String
"Ext (:+)" Value
invalid
instance (Uniform core, Uniform extra) => Uniform (core :+ extra)
instance (UniformRange core, UniformRange extra) => UniformRange (core :+ extra) where
uniformRM :: forall g (m :: * -> *).
StatefulGen g m =>
(core :+ extra, core :+ extra) -> g -> m (core :+ extra)
uniformRM (core
lc :+ extra
le, core
hc :+ extra
he) g
g = core -> extra -> core :+ extra
forall core extra. core -> extra -> core :+ extra
(:+) (core -> extra -> core :+ extra)
-> m core -> m (extra -> core :+ extra)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (core, core) -> g -> m core
forall a g (m :: * -> *).
(UniformRange a, StatefulGen g m) =>
(a, a) -> g -> m a
forall g (m :: * -> *).
StatefulGen g m =>
(core, core) -> g -> m core
uniformRM (core
lc, core
hc) g
g m (extra -> core :+ extra) -> m extra -> m (core :+ extra)
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (extra, extra) -> g -> m extra
forall a g (m :: * -> *).
(UniformRange a, StatefulGen g m) =>
(a, a) -> g -> m a
forall g (m :: * -> *).
StatefulGen g m =>
(extra, extra) -> g -> m extra
uniformRM (extra
le,extra
he) g
g
instance (Default core, Default extra) => Default (core :+ extra) where
def :: core :+ extra
def = core
forall a. Default a => a
def core -> extra -> core :+ extra
forall core extra. core -> extra -> core :+ extra
:+ extra
forall a. Default a => a
def
_core :: (core :+ extra) -> core
_core :: forall core extra. (core :+ extra) -> core
_core (core
c :+ extra
_) = core
c
{-# INLINE _core #-}
_extra :: (core :+ extra) -> extra
(core
_ :+ extra
e) = extra
e
{-# INLINE _extra #-}
core :: Lens (core :+ extra) (core' :+ extra) core core'
core :: forall core extra core' (f :: * -> *).
Functor f =>
(core -> f core') -> (core :+ extra) -> f (core' :+ extra)
core = ((core :+ extra) -> core)
-> ((core :+ extra) -> core' -> core' :+ extra)
-> Lens (core :+ extra) (core' :+ extra) core core'
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens (core :+ extra) -> core
forall core extra. (core :+ extra) -> core
_core (\(core
_ :+ extra
e) core'
c -> core'
c core' -> extra -> core' :+ extra
forall core extra. core -> extra -> core :+ extra
:+ extra
e)
{-# INLINE core #-}
extra :: Lens (core :+ extra) (core :+ extra') extra extra'
= ((core :+ extra) -> extra)
-> ((core :+ extra) -> extra' -> core :+ extra')
-> Lens (core :+ extra) (core :+ extra') extra extra'
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens (core :+ extra) -> extra
forall core extra. (core :+ extra) -> extra
_extra (\(core
c :+ extra
_) extra'
e -> core
c core -> extra' -> core :+ extra'
forall core extra. core -> extra -> core :+ extra
:+ extra'
e)
{-# INLINE extra #-}
ext :: a -> a :+ ()
ext :: forall a. a -> a :+ ()
ext a
x = a
x a -> () -> a :+ ()
forall core extra. core -> extra -> core :+ extra
:+ ()
{-# INLINE ext #-}
class AsA t c | t -> c where
asCore :: t -> c
type t :~ c = t `AsA` c
pattern AsA :: t :~ c => c -> t
pattern $mAsA :: forall {r} {t} {c}. (t :~ c) => t -> (c -> r) -> ((# #) -> r) -> r
AsA c <- (asCore -> c)
{-# INLINE AsA #-}
instance (t ~ c) => AsA t c where
asCore :: t -> c
asCore = t -> t
t -> c
forall a. a -> a
id
{-# INLINE asCore #-}
instance {-# OVERLAPPING #-} AsA (c :+ e) c where
asCore :: (c :+ e) -> c
asCore = Getting c (c :+ e) c -> (c :+ e) -> c
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting c (c :+ e) c
forall core extra core' (f :: * -> *).
Functor f =>
(core -> f core') -> (core :+ extra) -> f (core' :+ extra)
core
{-# INLINE asCore #-}
class AsExt t where
type CoreOf t
type t
_Ext :: Iso' t (CoreOf t :+ ExtraOf t)
instance AsExt (c :+ e) where
type CoreOf (c :+ e) = c
type (c :+ e) = e
_Ext :: Iso' (c :+ e) (CoreOf (c :+ e) :+ ExtraOf (c :+ e))
_Ext = ((c :+ e) -> c :+ e)
-> ((c :+ e) -> c :+ e) -> Iso (c :+ e) (c :+ e) (c :+ e) (c :+ e)
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso (c :+ e) -> c :+ e
forall a. a -> a
id (c :+ e) -> c :+ e
forall a. a -> a
id
{-# INLINE _Ext #-}
asIndexedExt :: (Indexable i p, Functor f)
=> p (s :+ i) (f (t :+ j))
-> Indexed i s (f t)
asIndexedExt :: forall i (p :: * -> * -> *) (f :: * -> *) s t j.
(Indexable i p, Functor f) =>
p (s :+ i) (f (t :+ j)) -> Indexed i s (f t)
asIndexedExt p (s :+ i) (f (t :+ j))
f = (i -> s -> f t) -> Indexed i s (f t)
forall i a b. (i -> a -> b) -> Indexed i a b
Indexed ((i -> s -> f t) -> Indexed i s (f t))
-> (i -> s -> f t) -> Indexed i s (f t)
forall a b. (a -> b) -> a -> b
$ \i
i s
a -> Getting t (t :+ j) t -> (t :+ j) -> t
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting t (t :+ j) t
forall core extra core' (f :: * -> *).
Functor f =>
(core -> f core') -> (core :+ extra) -> f (core' :+ extra)
core ((t :+ j) -> t) -> f (t :+ j) -> f t
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> p (s :+ i) (f (t :+ j)) -> i -> (s :+ i) -> f (t :+ j)
forall a b. p a b -> i -> a -> b
forall i (p :: * -> * -> *) a b.
Indexable i p =>
p a b -> i -> a -> b
indexed p (s :+ i) (f (t :+ j))
f i
i (s
a s -> i -> s :+ i
forall core extra. core -> extra -> core :+ extra
:+ i
i)
{-# INLINE asIndexedExt #-}