{-|
Module      : Data.Vinyl.Utils.Const
Copyright   : (c) Marcin Mrotek, 2014
License     : BSD3
Maintainer  : marcin.jan.mrotek@gmail.com

Operations on constant type records.
-}


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

{-# OPTIONS_HADDOCK show-extensions #-}

module Data.Vinyl.Utils.Const
  ( cfmap
  , cpure
  , capp
  , rconst
  , constCommute
  , rtraverseconst
  , Record (..)
  ) where

import Data.Vinyl.Utils.Compose
import Data.Vinyl.Utils.Proxy

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

cpure :: Record rs => a -> Rec (Const a) rs
-- ^Extension of 'pure' to constant type records.
cpure = cpure' proxyRecord

cpure' :: Rec Proxy rs -> a -> Rec (Const a) rs
cpure' RNil _ = RNil
cpure' (Proxy :& ps) a = Const a :& cpure' ps a

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