Internal.hs

{-# LANGUAGE ConstraintKinds        #-}
{-# LANGUAGE DataKinds              #-}
{-# LANGUAGE FlexibleContexts       #-}
{-# LANGUAGE FlexibleInstances      #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs                  #-}
{-# LANGUAGE MultiParamTypeClasses  #-}
{-# LANGUAGE OverlappingInstances   #-}
{-# LANGUAGE ScopedTypeVariables    #-}
{-# LANGUAGE TypeFamilies           #-}
{-# LANGUAGE TypeOperators          #-}
{-# LANGUAGE UndecidableInstances   #-}

module Data.OpenUnion.Internal where
import           Control.Applicative
import           Data.Monoid         hiding (All)
import           GHC.Exts            (Constraint)

data Union (as :: [*]) where
  Single    :: a -> Union (a ': as)
  Union     :: Union as -> Union (a ': as)
  Exhausted :: Union '[] -> Union '[]

exhaust :: Union '[] -> a
exhaust (Exhausted x) = exhaust x
{-# INLINE exhaust #-}

type family All (ca :: * -> Constraint) (as :: [*]) :: Constraint
type instance All ca '[] = ()
type instance All ca (a ': as) = (ca a, All ca as)

instance (All Show r) => Show (Union r) where
  show (Single x) = show x
  show (Union u)  = show u
  show _ = undefined

(||>) :: (a -> r) -> (Union as -> r) -> (Union (a ': as) -> r)
(||>) f _ (Single x) = f x
(||>) _ g (Union u) = g u
infixr 2 ||>
{-# INLINE (||>) #-}

data Position (a :: *) (as :: [*]) where
  Zero :: Position a (a ': as)
  Succ :: Position a as -> Position a (b ': as)

class Member a as | as -> a where
  position :: Position a as

instance Member a (a ': as) where
  position = Zero

instance Member a as => Member a (b ': as) where
  position = Succ position

-- | Lift a value into a Union.
liftU :: forall a as. Member a as => a -> Union as
liftU x = go (position :: Position a as)
  where
    go :: Position a bs -> Union bs
    go Zero     = Single x
    go (Succ n) = Union $ go n
{-# INLINE liftU #-}

-- | Traversal for a specific element.
picked :: forall a as f. (Applicative f, Member a as) => (a -> f a) -> Union as -> f (Union as)
picked k = go (position :: Position a as)
  where
    go :: Position a bs -> Union bs -> f (Union bs)
    go Zero (Single x)       = Single <$> k x
    go Zero u@(Union _)      = pure u
    go (Succ _) u@(Single _) = pure u
    go (Succ n) (Union u)    = Union <$> go n u
{-# INLINE picked #-}

-- | Retrieve the value from a Union.
retractU :: Member a as => Union as -> Maybe a
retractU = getFirst . getConst . picked (Const . First . Just)
{-# INLINE retractU #-}

-- | Lift a function into @Union@.
hoistU :: Member a as => (a -> a) -> Union as -> Union as
hoistU f = getId . picked (Id . f)
{-# INLINE hoistU #-}

-- | Instead of Identity.
newtype Id a = Id { getId :: a }

instance Functor Id where
  fmap f (Id a) = Id (f a)

instance Applicative Id where
  pure = Id
  Id f <*> Id a = Id (f a)

class Include as bs where
  reunion :: Union as -> Union bs

instance (Member a bs, Include as bs) => Include (a ': as) bs where
  reunion (Single x) = liftU x
  reunion (Union u)  = reunion u

instance (Include '[] bs) where
  reunion = exhaust

type a ∈ as  = Member a as
type as ⊆ bs = Include as bs
type as ＝ bs = (Include as bs, Include bs as)

infix 4 ∈
infix 4 ⊆
infix 4 ＝