--------------------------------------------------------------------------------
-- |
-- 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 (Eq,Ord,NFData,Arbitrary,Generic,Show)
data instance core :+ (t:ts) = WithExtra !core (HList (t:ts))
infixr 1 :+
pattern (:+) :: c -> HList (e:extras) -> c :+ (e:extras)
pattern c :+ r = WithExtra c r
{-# COMPLETE (:+) #-}
ext :: c -> c :+ '[]
ext = Only
--------------------------------------------------------------------------------
class HasCore extras where
core :: Lens (core :+ extras) (core' :+ extras) core core'
instance HasCore '[] where
core = lens coerce (const coerce)
instance HasCore (t:ts) where
core = lens (\(c :+ _) -> c) (\(_ :+ r) c -> c :+ r)
--------------------------------------------------------------------------------
class HasExtras extras extras' where
extra :: Lens (core :+ extras) (core :+ extras') (HList extras) (HList extras')
instance HasExtras '[] '[] where
extra = lens (const RNil) const
instance HasExtras '[] (t:ts) where
extra = lens (const RNil) (\(Only c) r -> c :+ r)
instance HasExtras (t:ts) '[] where
extra = lens (\(_ :+ r) -> r) (\(c :+ _) _ -> Only c)
instance HasExtras (t:ts) (a:as) where
extra = lens (\(_ :+ r) -> r) (\(c :+ _) r' -> c :+ r')
--------------------------------------------------------------------------------