{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
-- | A variant of 'Rec' whose values have eliminated common syntactic
-- clutter due to 'Identity', 'Compose', and 'ElField' type
-- constructors.
--
-- A common pain point with using 'Rec' is the mandatory /context/ of
-- each value. A basic record might look like this, @Identity "joe" :&
-- Identity 23 :& RNil :: Rec Identity '[String, Int]@. The 'Identity'
-- constructors are a nuisance, so we offer a way of avoiding them:
-- @"joe" ::& 23 ::& XRNil :: XRec Identity '[String,Int]@. Facilities
-- are provided for converting between 'XRec' and 'Rec' so that the
-- 'Rec' API is available even if you choose to use 'XRec' for
-- construction or pattern matching.
module Data.Vinyl.XRec where
import Data.Vinyl.Core (Rec(..))
import Data.Vinyl.Functor
import Data.Monoid
import GHC.TypeLits (KnownSymbol)

type XRec f = Rec (XData f)
pattern (::&) :: HKD f r -> XRec f rs -> XRec f (r ': rs)
pattern x ::& xs = XData x :& xs
{-# COMPLETE (::&) #-}

infixr 7 ::&

pattern XRNil :: XRec f '[]
pattern XRNil = RNil
{-# COMPLETE XRNil #-}

-- | Like 'rmap', but the supplied function is written against the
-- 'HKD'-simplified types. This is 'xrmap' sandwiched in between
-- 'fromXRec' and 'toXRec'.
rmapX :: forall f g rs. (XRMap f g rs, IsoXRec f rs, IsoXRec g rs)
      => (forall a. HKD f a -> HKD g a) -> Rec f rs -> Rec g rs
rmapX f = fromXRec . xrmapAux aux . toXRec
  where aux :: forall a. XData f a -> XData g a
        aux = XData . f @a . unX

-- | This is 'rmapX' specialized to a type at which it does not change
-- interpretation functor. This can help with type inference.
rmapXEndo :: forall f rs. (XRMap f f rs, IsoXRec f rs)
          => (forall a. HKD f a -> HKD f a) -> Rec f rs -> Rec f rs
rmapXEndo f = fromXRec . xrmapAux aux . toXRec
  where aux :: forall a. XData f a -> XData f a
        aux = XData . f @a . unX

-- | This is 'rmap' for 'XRec'. We apply a natural transformation
-- between interpretation functors to transport a record value between
-- interpretations.
xrmap :: forall f g rs. XRMap f g rs
      => (forall a. HKD f a -> HKD g a) -> XRec f rs -> XRec g rs
xrmap f = xrmapAux aux
  where aux :: forall a. XData f a -> XData g a
        aux = XData . f @a . unX

-- | A wrapper for an 'HKD'-simplified value. That is, noisy value
-- constructors like 'Identity' and 'Compose' are ellided. This is
-- used in the 'xrmapAux' type class method, but may be ignored by
-- users whose needs are met by 'xrmap' and 'rmapX'.
newtype XData t a = XData { unX :: HKD t a }

-- | The implementation of 'xrmap' is broken into a type class to
-- permit unrolling of the recursion across a record. The function
-- mapped across the vector hides the 'HKD' type family under a newtype
-- constructor to help the type checker.
class XRMap (f :: u -> *) (g :: u -> *) (rs :: [u]) where
  xrmapAux :: (forall (a :: u) . XData f a -> XData g a) -> XRec f rs -> XRec g rs

instance XRMap f g '[] where
  xrmapAux _ RNil = RNil

instance forall f g r rs. (XRMap f g rs, IsoHKD f r, IsoHKD g r)
  => XRMap f g (r ': rs) where
  xrmapAux f (x :& xs) = f x :& xrmapAux f xs

-- | Like 'rapply': record of components @f r -> g r@ may be applied
-- to a record of @f@ to get a record of @g@.
class XRApply f g rs where
  xrapply :: XRec (Lift (->) f g) rs -> XRec f rs -> XRec g rs

instance XRApply f g '[] where
  xrapply RNil RNil = RNil

instance XRApply f g rs => XRApply f g (r ': rs) where
  xrapply (XData f :& fs) (XData x :& xs) = XData (f x) :& xrapply fs xs

-- | Conversion between 'XRec' and 'Rec'. It is convenient to build
-- and consume 'XRec' values to reduce syntactic noise, but 'Rec' has
-- a richer API that is difficult to build around the 'HKD' type
-- family.
class IsoXRec f ts where
  fromXRec :: XRec f ts -> Rec f ts
  toXRec :: Rec f ts -> XRec f ts

instance IsoXRec f '[] where
  fromXRec RNil = RNil
  toXRec RNil = XRNil

instance (IsoXRec f ts, IsoHKD f t) => IsoXRec f (t ': ts) where
  fromXRec (x ::& xs) = unHKD x :& fromXRec xs
  toXRec (x :& xs) = toHKD x ::& toXRec xs

-- | Isomorphism between a syntactically noisy value and a concise
-- one. For types like, 'Identity', we prefer to work with values of
-- the underlying type without writing out the 'Identity'
-- constructor. For @'Compose' f g a@, aka @(f :. g) a@, we prefer to
-- work directly with values of type @f (g a)@.
--
-- This involves the so-called /higher-kinded data/ type family. See
-- <http://reasonablypolymorphic.com/blog/higher-kinded-data> for more
-- discussion.
class IsoHKD (f :: u -> *) (a :: u) where
  type HKD f a
  type HKD f a = f a
  unHKD :: HKD f a -> f a
  default unHKD :: HKD f a ~ f a => HKD f a -> f a
  unHKD = id
  toHKD :: f a -> HKD f a
  default toHKD :: (HKD f a ~ f a) => f a -> HKD f a
  toHKD = id

-- | Work with values of type 'Identity' @a@ as if they were simple of
-- type @a@.
instance IsoHKD Identity a where
  type HKD Identity a = a
  unHKD = Identity
  toHKD (Identity x) = x

-- | Work with values of type 'ElField' @'(s,a)@ as if they were of
-- type @a@.
instance KnownSymbol s => IsoHKD ElField '(s,a) where
  type HKD ElField '(s,a) = a
  unHKD = Field
  toHKD (Field x) = x

-- | Work with values of type 'Compose' @f g a@ as if they were of
-- type @f (g a)@.
instance (IsoHKD f (HKD g a), IsoHKD g a, Functor f) => IsoHKD (Compose f g) a where
  type HKD (Compose f g) a = HKD f (HKD g a)
  unHKD x = Compose (unHKD <$> unHKD x)
  toHKD (Compose fgx) = toHKD (toHKD <$> fgx)

-- | Work with values of type 'Lift' @(->) f g a@ as if they were of
-- type @f a -> g a@.
instance (IsoHKD f a, IsoHKD g a) => IsoHKD (Lift (->) f g) a where
  type HKD (Lift (->) f g) a = HKD f a -> HKD g a
  unHKD x = Lift (unHKD . x . toHKD)
  toHKD (Lift x) = toHKD . x . unHKD

instance IsoHKD IO a where
instance IsoHKD (Either a) b where
instance IsoHKD Maybe a where
instance IsoHKD First a where
instance IsoHKD Last a where

-- | Work with values of type 'Sum' @a@ as if they were of type @a@.
instance IsoHKD Sum a where
  type HKD Sum a = a
  unHKD = Sum
  toHKD (Sum x) = x

-- | Work with values of type 'Product' @a@ as if they were of type @a@.
instance IsoHKD Product a where
  type HKD Product a = a
  unHKD = Product
  toHKD (Product x) = x