Const.hs

{-# LANGUAGE
      DataKinds
    , PolyKinds
    , TypeFamilies
    , TypeOperators
    #-}

{-# OPTIONS_HADDOCK show-extensions #-}

{-|
Module      : Data.Vinyl.Utils.Const
Description : Operations on constant type records.
Copyright   : (c) Marcin Mrotek, 2014
License     : BSD3
Maintainer  : marcin.jan.mrotek@gmail.com
-}

module Data.Vinyl.Utils.Const (
      ConstApplicative(..)
    , rconst
    , constCommute
    , rtraverseconst
) where

import Data.Vinyl.Utils.Compose

import Control.Applicative hiding (Const)
import Data.Vinyl.Functor
import Data.Vinyl

cfmap :: (a -> b) -> Rec (Const a) rs -> Rec (Const b) rs
-- ^Map a function over a constant type record.
cfmap _ RNil = RNil
cfmap f (Const r :& rs) = Const (f r) :& cfmap f rs

-- |Extension of 'pure' to constant type records.
class ConstApplicative (rs :: [k]) where
    cpure :: a -> Rec (Const a) rs
 
instance ConstApplicative '[] where
    cpure = const RNil

instance ConstApplicative rs => ConstApplicative (r ': rs) where
    cpure x = Const x :& cpure x

capp  :: (Rec (Const (a -> b)) rs) -> Rec (Const a) rs -> Rec (Const b) rs
-- ^Extension of (<*>) to constant type records.
capp RNil RNil = RNil
capp (Const f :& fs) (Const x :& xs) = Const (f x) :& capp fs xs

rconst :: (Applicative f, RecApplicative rs) => f a -> f (Rec (Const a) rs)
rconst = rtraverse1 . rcpure
    where rcpure a = rpure (Compose $ Const <$> a)

constCommute :: Functor f => Const (f a) b -> Compose f (Const a) b
-- ^Commute a constant functor with another functor.
constCommute (Const a) = Compose $ Const <$> a

rtraverseconst :: Applicative f => Rec (Const (f a)) rs -> f (Rec (Const a) rs)
-- ^Distribute a functor over a constant type record.
rtraverseconst rec = rtraverse1 $ constCommute <<$>> rec