Upcast.hs

{-# LANGUAGE
      DataKinds
    , MultiParamTypeClasses
    , FlexibleContexts
    , FlexibleInstances
    , PolyKinds
    , ScopedTypeVariables
    , TypeFamilies
    , TypeOperators
    , UndecidableInstances
    #-}

{-# OPTIONS_HADDOCK show-extensions #-}

{-|
Module      : Data.Vinyl.Upcast
Description : Upward cast and slicing.
Copyright   : (c) Marcin Mrotek, 2014
License     : BSD3
Maintainer  : marcin.jan.mrotek@gmail.com
-}

module Data.Vinyl.Upcast (
      Overwrite(..)
    , slice
    , (:>)(..)
    , AltRec(..)
) where

import Control.Applicative
import Data.Monoid
import Data.Vinyl
import Data.Vinyl.TyFun

-- |Overwrite a wider record with a narrower record.
class Overwrite (xs :: [k]) (ys :: [k]) where
    overwrite :: Rec el f xs -> Rec el f ys -> Rec el f xs

instance Overwrite xs '[] where
    overwrite xs _ = xs

instance (IElem y xs, Overwrite xs ys) => Overwrite xs (y ': ys) where
    overwrite xs (y :& ys) = overwrite (ith (implicitly :: Elem y xs) y xs) ys
        where 
            ith :: Elem x rs ->  f (el $ x) -> Rec el f rs -> Rec el f rs
            ith Here      y (_ :& xs) = y :& xs 
            ith (There p) y (x :& xs) = x :& ith p y xs

slice :: (Functor f, Overwrite xs ys, xs <: ys) 
      => (Rec el g ys -> f (Rec el g ys))
      ->  Rec el g xs -> f (Rec el g xs)
-- ^A lens from a record to a portion of it.
slice k x = overwrite x <$> k (cast x)

-- |Wrapper for Rec with a different Monoid instance. Instead of lifting mappend, it acts on (f (el $ r)) directly, to support temporarily turning records into monoids by changing functors.
newtype AltRec el f rs = AltRec {getRec :: Rec el f rs}

instance Monoid (AltRec el f '[]) where
    mempty = AltRec RNil
    _ `mappend` _ = AltRec RNil

instance (Monoid (f (el $ r)), Monoid (AltRec el f rs)) => Monoid (AltRec el f (r ': rs)) where
    mempty = AltRec $ mempty :& getRec mempty
    (AltRec (x :& xs)) `mappend` (AltRec (y :& ys)) = AltRec $ (x <> y) :& getRec (AltRec xs `mappend` AltRec ys)

-- |Upward record casting.
class (Overwrite ys xs, ys <: xs) => (xs :: [k]) :> (ys :: [k]) where
    upcast :: (Monoid (AltRec el f ys)) => Rec el f xs -> Rec el f ys

instance (Overwrite ys xs, ys <: xs) => xs :> ys where
    upcast xs = overwrite (getRec mempty) xs