{-# LANGUAGE MagicHash #-}
{-# LANGUAGE RoleAnnotations #-}
{-# LANGUAGE ViewPatterns #-}
{-|
Module: Data.Label
Description: Field label type, for use with @OverloadedLabels@.
This module provides syntax for labelling values with symbolic field names.
Given @ val :: a @, we can specify a label by using the syntax
@ #field := val @, which has type @ "field" := a @.
For instance, we can pass a record of three arguments with the syntax:
@
myRecord :: ( "field1" := Int, "field2" := Bool, "field3" := Float )
myRecord = ( #field1 := 3, #field2 := True, #field3 := 7.7 )
@
This is a simple triple of labelled types, so the order matters.
However, this library provides functionality which will automatically
handle re-ordering fields when needed, see "Data.Generic.Labels".
-}
module Data.Label
( (:=)
( .., (:=) )
, Label
( Label )
) where
-- base
import Data.Kind
( Type )
import GHC.Exts
( proxy# )
import GHC.OverloadedLabels
( IsLabel
( fromLabel )
)
import GHC.TypeLits
( Symbol, KnownSymbol, symbolVal' )
--------------------------------------------------------------------------------
-- Field labels.
-- | 'Data.Proxy.Proxy'-like label type,
-- used to pass the label name at the type-level.
--
-- With @OverloadedLabels@:
--
-- @ #foo :: Label "foo" @
data Label ( lbl :: Symbol ) = Label
type role Label nominal
instance ( lbl' ~ lbl ) => IsLabel lbl ( Label lbl' ) where
fromLabel = Label
instance KnownSymbol lbl => Show ( Label lbl ) where
show _ = "#" <> symbolVal' @lbl proxy#
-- | A type with a 'Label'.
--
-- With @OverloadedLabels@:
--
-- @ ( #bar := Just 'c' ) :: ( "bar" := Maybe Char ) @
newtype ( lbl :: Symbol ) := ( a :: Type ) = Labelled { unLabel :: a }
instance ( KnownSymbol lbl, Show a ) => Show ( lbl := a ) where
showsPrec p ( Labelled a ) =
showParen ( p > 1 )
( showString ( show ( Label @lbl ) <> " := " ) . showsPrec 2 a )
infix 1 :=
-- | Add a 'Label' to a type.
--
-- With @OverloadedLabels@:
--
-- @ ( #bar := Just 'c' ) :: ( "bar" := Maybe Char ) @
pattern (:=) :: Label lbl -> a -> lbl := a
pattern lbl := a <- ( ( \ ( Labelled a ) -> LabelPair Label a ) -> LabelPair lbl a )
where
_ := a = Labelled a
{-# COMPLETE (:=) #-}
data LabelPair lbl a = LabelPair !( Label lbl ) !a