--------------------------------------------------------------------------------
-- |
-- Module      :  Data.Ext
-- Copyright   :  (C) Frank Staals
-- License     :  see the LICENSE file
-- Maintainer  :  Frank Staals
--
-- A pair-like data type to represent a 'core' type that has extra information
-- as well.
--
--------------------------------------------------------------------------------
module Data.Ext.Multi where

import Control.DeepSeq
import Control.Lens
import Data.Coerce
import Data.Vinyl
import GHC.Generics (Generic)
import Test.QuickCheck

--------------------------------------------------------------------------------

data family core :+ (extras :: [*]) :: *

newtype instance core :+ '[]    = Only core deriving ((core :+ '[]) -> (core :+ '[]) -> Bool
((core :+ '[]) -> (core :+ '[]) -> Bool)
-> ((core :+ '[]) -> (core :+ '[]) -> Bool) -> Eq (core :+ '[])
forall core. Eq core => (core :+ '[]) -> (core :+ '[]) -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: (core :+ '[]) -> (core :+ '[]) -> Bool
$c/= :: forall core. Eq core => (core :+ '[]) -> (core :+ '[]) -> Bool
== :: (core :+ '[]) -> (core :+ '[]) -> Bool
$c== :: forall core. Eq core => (core :+ '[]) -> (core :+ '[]) -> Bool
Eq,Eq (core :+ '[])
Eq (core :+ '[])
-> ((core :+ '[]) -> (core :+ '[]) -> Ordering)
-> ((core :+ '[]) -> (core :+ '[]) -> Bool)
-> ((core :+ '[]) -> (core :+ '[]) -> Bool)
-> ((core :+ '[]) -> (core :+ '[]) -> Bool)
-> ((core :+ '[]) -> (core :+ '[]) -> Bool)
-> ((core :+ '[]) -> (core :+ '[]) -> core :+ '[])
-> ((core :+ '[]) -> (core :+ '[]) -> core :+ '[])
-> Ord (core :+ '[])
(core :+ '[]) -> (core :+ '[]) -> Bool
(core :+ '[]) -> (core :+ '[]) -> Ordering
(core :+ '[]) -> (core :+ '[]) -> core :+ '[]
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. Ord core => Eq (core :+ '[])
forall core. Ord core => (core :+ '[]) -> (core :+ '[]) -> Bool
forall core. Ord core => (core :+ '[]) -> (core :+ '[]) -> Ordering
forall core.
Ord core =>
(core :+ '[]) -> (core :+ '[]) -> core :+ '[]
min :: (core :+ '[]) -> (core :+ '[]) -> core :+ '[]
$cmin :: forall core.
Ord core =>
(core :+ '[]) -> (core :+ '[]) -> core :+ '[]
max :: (core :+ '[]) -> (core :+ '[]) -> core :+ '[]
$cmax :: forall core.
Ord core =>
(core :+ '[]) -> (core :+ '[]) -> core :+ '[]
>= :: (core :+ '[]) -> (core :+ '[]) -> Bool
$c>= :: forall core. Ord core => (core :+ '[]) -> (core :+ '[]) -> Bool
> :: (core :+ '[]) -> (core :+ '[]) -> Bool
$c> :: forall core. Ord core => (core :+ '[]) -> (core :+ '[]) -> Bool
<= :: (core :+ '[]) -> (core :+ '[]) -> Bool
$c<= :: forall core. Ord core => (core :+ '[]) -> (core :+ '[]) -> Bool
< :: (core :+ '[]) -> (core :+ '[]) -> Bool
$c< :: forall core. Ord core => (core :+ '[]) -> (core :+ '[]) -> Bool
compare :: (core :+ '[]) -> (core :+ '[]) -> Ordering
$ccompare :: forall core. Ord core => (core :+ '[]) -> (core :+ '[]) -> Ordering
$cp1Ord :: forall core. Ord core => Eq (core :+ '[])
Ord,(core :+ '[]) -> ()
((core :+ '[]) -> ()) -> NFData (core :+ '[])
forall core. NFData core => (core :+ '[]) -> ()
forall a. (a -> ()) -> NFData a
rnf :: (core :+ '[]) -> ()
$crnf :: forall core. NFData core => (core :+ '[]) -> ()
NFData,Gen (core :+ '[])
Gen (core :+ '[])
-> ((core :+ '[]) -> [core :+ '[]]) -> Arbitrary (core :+ '[])
(core :+ '[]) -> [core :+ '[]]
forall core. Arbitrary core => Gen (core :+ '[])
forall core. Arbitrary core => (core :+ '[]) -> [core :+ '[]]
forall a. Gen a -> (a -> [a]) -> Arbitrary a
shrink :: (core :+ '[]) -> [core :+ '[]]
$cshrink :: forall core. Arbitrary core => (core :+ '[]) -> [core :+ '[]]
arbitrary :: Gen (core :+ '[])
$carbitrary :: forall core. Arbitrary core => Gen (core :+ '[])
Arbitrary,(forall x. (core :+ '[]) -> Rep (core :+ '[]) x)
-> (forall x. Rep (core :+ '[]) x -> core :+ '[])
-> Generic (core :+ '[])
forall x. Rep (core :+ '[]) x -> core :+ '[]
forall x. (core :+ '[]) -> Rep (core :+ '[]) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall core x. Rep (core :+ '[]) x -> core :+ '[]
forall core x. (core :+ '[]) -> Rep (core :+ '[]) x
$cto :: forall core x. Rep (core :+ '[]) x -> core :+ '[]
$cfrom :: forall core x. (core :+ '[]) -> Rep (core :+ '[]) x
Generic,Int -> (core :+ '[]) -> ShowS
[core :+ '[]] -> ShowS
(core :+ '[]) -> String
(Int -> (core :+ '[]) -> ShowS)
-> ((core :+ '[]) -> String)
-> ([core :+ '[]] -> ShowS)
-> Show (core :+ '[])
forall core. Show core => Int -> (core :+ '[]) -> ShowS
forall core. Show core => [core :+ '[]] -> ShowS
forall core. Show core => (core :+ '[]) -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [core :+ '[]] -> ShowS
$cshowList :: forall core. Show core => [core :+ '[]] -> ShowS
show :: (core :+ '[]) -> String
$cshow :: forall core. Show core => (core :+ '[]) -> String
showsPrec :: Int -> (core :+ '[]) -> ShowS
$cshowsPrec :: forall core. Show core => Int -> (core :+ '[]) -> ShowS
Show)
data    instance core :+ (t:ts) = WithExtra !core (HList (t:ts))


infixr 1 :+

pattern (:+)   :: c -> HList (e:extras) -> c :+ (e:extras)
pattern c $b:+ :: c -> HList (e : extras) -> c :+ (e : extras)
$m:+ :: forall r c e (extras :: [*]).
(c :+ (e : extras))
-> (c -> HList (e : extras) -> r) -> (Void# -> r) -> r
:+ r = WithExtra c r
{-# COMPLETE (:+) #-}

ext :: c -> c :+ '[]
ext :: c -> c :+ '[]
ext = c -> c :+ '[]
forall core. core -> core :+ '[]
Only

--------------------------------------------------------------------------------

class HasCore extras where
  core :: Lens (core :+ extras) (core' :+ extras) core core'

instance HasCore '[] where
  core :: (core -> f core') -> (core :+ '[]) -> f (core' :+ '[])
core = ((core :+ '[]) -> core)
-> ((core :+ '[]) -> core' -> core' :+ '[])
-> Lens (core :+ '[]) (core' :+ '[]) core core'
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens (core :+ '[]) -> core
coerce ((core' -> core' :+ '[]) -> (core :+ '[]) -> core' -> core' :+ '[]
forall a b. a -> b -> a
const core' -> core' :+ '[]
coerce)
instance HasCore (t:ts) where
  core :: (core -> f core') -> (core :+ (t : ts)) -> f (core' :+ (t : ts))
core = ((core :+ (t : ts)) -> core)
-> ((core :+ (t : ts)) -> core' -> core' :+ (t : ts))
-> Lens (core :+ (t : ts)) (core' :+ (t : ts)) core core'
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens (\(core
c :+ HList (t : ts)
_) -> core
c) (\(core
_ :+ HList (t : ts)
r) core'
c -> core'
c core' -> HList (t : ts) -> core' :+ (t : ts)
forall c e (extras :: [*]).
c -> HList (e : extras) -> c :+ (e : extras)
:+ HList (t : ts)
r)

--------------------------------------------------------------------------------

class HasExtras extras extras' where
  extra :: Lens (core :+ extras) (core :+ extras') (HList extras) (HList extras')

instance HasExtras '[] '[] where
  extra :: (HList '[] -> f (HList '[])) -> (core :+ '[]) -> f (core :+ '[])
extra = ((core :+ '[]) -> HList '[])
-> ((core :+ '[]) -> HList '[] -> core :+ '[])
-> Lens (core :+ '[]) (core :+ '[]) (HList '[]) (HList '[])
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens (HList '[] -> (core :+ '[]) -> HList '[]
forall a b. a -> b -> a
const HList '[]
forall u (a :: u -> *). Rec a '[]
RNil) (core :+ '[]) -> HList '[] -> core :+ '[]
forall a b. a -> b -> a
const
instance HasExtras '[] (t:ts) where
  extra :: (HList '[] -> f (HList (t : ts)))
-> (core :+ '[]) -> f (core :+ (t : ts))
extra = ((core :+ '[]) -> HList '[])
-> ((core :+ '[]) -> HList (t : ts) -> core :+ (t : ts))
-> Lens
     (core :+ '[]) (core :+ (t : ts)) (HList '[]) (HList (t : ts))
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens (HList '[] -> (core :+ '[]) -> HList '[]
forall a b. a -> b -> a
const HList '[]
forall u (a :: u -> *). Rec a '[]
RNil) (\(Only c) HList (t : ts)
r -> core
c core -> HList (t : ts) -> core :+ (t : ts)
forall c e (extras :: [*]).
c -> HList (e : extras) -> c :+ (e : extras)
:+ HList (t : ts)
r)
instance HasExtras (t:ts) '[] where
  extra :: (HList (t : ts) -> f (HList '[]))
-> (core :+ (t : ts)) -> f (core :+ '[])
extra = ((core :+ (t : ts)) -> HList (t : ts))
-> ((core :+ (t : ts)) -> HList '[] -> core :+ '[])
-> Lens
     (core :+ (t : ts)) (core :+ '[]) (HList (t : ts)) (HList '[])
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens (\(core
_ :+ HList (t : ts)
r) -> HList (t : ts)
r) (\(core
c :+ HList (t : ts)
_) HList '[]
_ -> core -> core :+ '[]
forall core. core -> core :+ '[]
Only core
c)
instance HasExtras (t:ts) (a:as) where
  extra :: (HList (t : ts) -> f (HList (a : as)))
-> (core :+ (t : ts)) -> f (core :+ (a : as))
extra = ((core :+ (t : ts)) -> HList (t : ts))
-> ((core :+ (t : ts)) -> HList (a : as) -> core :+ (a : as))
-> Lens
     (core :+ (t : ts))
     (core :+ (a : as))
     (HList (t : ts))
     (HList (a : as))
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens (\(core
_ :+ HList (t : ts)
r) -> HList (t : ts)
r) (\(core
c :+ HList (t : ts)
_) HList (a : as)
r' -> core
c core -> HList (a : as) -> core :+ (a : as)
forall c e (extras :: [*]).
c -> HList (e : extras) -> c :+ (e : extras)
:+ HList (a : as)
r')

--------------------------------------------------------------------------------