records-0.1.1.1: src/Data/Record/Combinators.hs
-- |Record combinators built on top of the record core that "Data.Record" provides.
module Data.Record.Combinators (
-- * Record styles
withStyle,
-- * Field operations
(!!!),
(\\\),
-- * Catenation
Cat,
cat,
-- * Applicative functor operations
repeat,
(<<*>>),
map,
zipWith,
-- * Modification of fields
{-FIXME:
Actually, all applicative functor operations except repeat are also about modification of
fields.
-}
modify,
(///),
-- * Conversion
-- FIXME: maybe don’t use the term “conversion” because of “record conversion”
toList
) where
-- Prelude
import Prelude hiding (repeat, map, zipWith)
import qualified Prelude -- only for documentation
-- Data
import Data.Kind as Kind
import Data.TypeFun as TypeFun
import Data.Record as Record
-- Control
import Control.Applicative as Applicative hiding (Const) -- only for documentation
-- * Record styles
infixl 2 `withStyle`
--FIXME: There is punctuation missing at the end of certain code blocks.
{-|
Fixes the style of a record. When a record is constructed using @X@, @(:&)@, and @(:=)@,
the style of this record is not fixed. For example, the most general type of the record
@
X :& Surname := \"Jeltsch\" :& Age := 33 :& Room := \"HG/2.39\"
@
is
@
('App' style sortSurname ~ String, Num ('App' style sortAge), 'App' style sortRoom ~ String) =>
(X :& Surname ::: sortSurname :& Age ::: sortAge :& Room ::: sortRoom) style
@
We can fix the style of that record using the expression
@
X :& Surname := \"Jeltsch\" :& Age := 33 :& Room := \"HG/2.39\" \`withStyle\` 'Id' 'KindStar'
@
which has the most general type
@
(Num age) =>
(X :& Surname ::: String :& Age ::: age :& Room ::: String) ('Id' 'KindStar')
@
The @withStyle@ combinator is similar to 'asTypeOf'.
-}
withStyle :: (Record (Domain style) rec) => rec style -> style -> rec style
withStyle = const
-- * Field operations
infixl 2 !!!, \\\
-- |Looks up the value of a record field.
(!!!) :: (Separation rec remain sepName sepSort) => rec style -> sepName -> App style sepSort
rec !!! name = let
_ := sepVal = snd (separate rec) `asTypeOf` (name := undefined)
in sepVal
-- |Removes a record field.
(\\\) :: (Separation rec remain sepName sepSort) => rec style -> sepName -> remain style
rec \\\ name = let
(remain,_) = separate rec `asTypeOf` (undefined,name := undefined)
in remain
-- * Catenation
-- |Catenation of two record schemes.
type family Cat (rec1 :: * -> *) (rec2 :: * -> *) :: * -> *
type instance Cat rec1 X = rec1
type instance Cat rec1 (rec2 :& name2 ::: sort2) = Cat rec1 rec2 :& name2 ::: sort2
-- |Catenation of two records.
cat :: (TypeFun style, Record (Domain style) rec1, Record (Domain style) rec2)
=> rec1 style
-- ^
-> rec2 style
-- ^
-> Cat rec1 rec2 style
-- ^
cat = let
CatThing cat = fold catNilAlt catExpander
in cat
newtype CatThing style rec1 rec2 = CatThing (rec1 style -> rec2 style -> Cat rec1 rec2 style)
catNilAlt:: (TypeFun style, Record (Domain style) rec1) => CatThing style rec1 X
catNilAlt = CatThing nilCat where
nilCat rec1 X = rec1
catSnocAlt :: (TypeFun style, Record (Domain style) rec1,
Record (Domain style) rec2, Name name, Inhabitant (Domain style) sort) =>
CatThing style rec1 rec2 -> CatThing style rec1 (rec2 :& name ::: sort)
catSnocAlt (CatThing cat) = CatThing snocCat where
snocCat rec1 (rec2 :& field2) = cat rec1 rec2 :& field2
catExpander :: (TypeFun style, Record (Domain style) rec1,
Record (Domain style) rec2, Name name) =>
All (Domain style) (Expander (CatThing style rec1) rec2 name)
catExpander = closed (Expander catSnocAlt)
-- * Record schemes as a kind of applicative functor
{-|
Generates a record whose fields all contain the same value. In contrast to the
'Prelude.repeat' function from the Prelude, this function generates a finite data structure.
Thereby, the size of the generated record is determined by its type. @repeat@ is almost a
proper implementation of 'pure' from the 'Applicative' class.
-}
repeat :: (TypeFun style, Record (Domain style) rec)
=> Universal style
-- ^
-> rec style
-- ^
repeat = let
RepeatThing repeat = fold repeatNilAlt repeatExpander
in repeat
newtype RepeatThing style rec = RepeatThing (Universal style -> rec style)
repeatNilAlt :: (TypeFun style) => RepeatThing style X
repeatNilAlt = RepeatThing nilRepeat where
nilRepeat _ = X
repeatSnocAlt :: forall style rec name sort. (TypeFun style,
Record (Domain style) rec,
Name name,
Inhabitant (Domain style) sort) =>
RepeatThing style rec -> RepeatThing style (rec :& name ::: sort)
repeatSnocAlt (RepeatThing repeat) = RepeatThing snocRepeat where
snocRepeat :: Universal style -> (rec :& name ::: sort) style
snocRepeat wrappedVal = repeat wrappedVal :&
name := unwrapApp (wrappedVal :: WrappedApp style sort)
repeatExpander :: (TypeFun style, Record (Domain style) rec, Name name) =>
All (Domain style) (Expander (RepeatThing style) rec name)
repeatExpander = closed (Expander repeatSnocAlt)
zipWithApp :: (TypeFun style, TypeFun style', Domain style ~ Domain style',
Record (Domain (style :-> style')) rec) =>
rec (style :-> style') -> rec style -> rec style'
zipWithApp = let
ZipWithAppThing zipWithApp = fold zipWithAppNilAlt zipWithAppExpander
in zipWithApp
newtype ZipWithAppThing style style' rec = ZipWithAppThing (rec (style :-> style') ->
rec style ->
rec style')
zipWithAppNilAlt :: (TypeFun style, TypeFun style', Domain style ~ Domain style') =>
ZipWithAppThing style style' X
zipWithAppNilAlt = ZipWithAppThing nilZipWithApp where
nilZipWithApp X X = X
zipWithAppSnocAlt :: (TypeFun style, TypeFun style', Domain style ~ Domain style',
Record (Domain (style :-> style')) rec,
Name name,
Inhabitant (Domain style) sort) =>
ZipWithAppThing style style' rec ->
ZipWithAppThing style style' (rec :& name ::: sort)
zipWithAppSnocAlt (ZipWithAppThing zipWithApp) = ZipWithAppThing snocZipWithApp where
snocZipWithApp (funRec :& name := fun)
(argRec :& _ := arg) = zipWithApp funRec argRec :& name := fun arg
zipWithAppExpander :: (TypeFun style, TypeFun style', Domain style ~ Domain style',
Record (Domain (style :-> style')) rec, Name name) =>
All (Domain style) (Expander (ZipWithAppThing style style') rec name)
zipWithAppExpander = closed (Expander zipWithAppSnocAlt)
infixl 4 <<*>>
{-|
Merges a record of functions and a record of arguments by applying the functions to the
corresponding arguments. The @(\<\<*\>\>)@ function is almost a proper implementation
of @(\<*\>)@ from the 'Applicative' class.
-}
(<<*>>) :: (TypeFun style, TypeFun style', Domain style ~ Domain style',
Record (Domain (style :-> style')) rec)
=> rec (style :-> style')
-- ^
-> rec style
-- ^
-> rec style'
-- ^
(<<*>>) = zipWithApp
-- ** Derived combinators
-- |Transforms a record by applying a function to all its field values.
map :: (TypeFun style, TypeFun style', Domain style ~ Domain style',
Record (Domain (style :-> style')) rec)
=> Universal (style :-> style')
-- ^
-> rec style
-- ^
-> rec style'
-- ^
map fun argRec = repeat fun <<*>> argRec
-- |Merges two records by applying a function to each pair of corresponding field values.
zipWith :: (TypeFun style1, TypeFun style2, TypeFun style',
Domain style1 ~ Domain style2, Domain style2 ~ Domain style',
Record (Domain (style1 :-> style2 :-> style')) rec)
=> Universal (style1 :-> style2 :-> style')
-- ^
-> rec style1
-- ^
-> rec style2
-- ^
-> rec style'
-- ^
zipWith fun argRec1 argRec2 = repeat fun <<*>> argRec1 <<*>> argRec2
-- * Modification of multiple fields
infixl 1 ///
{-|
Modifies a record by changing some of its field values. The first argument of @modify@ is
called the modification record, and the second argument is called the data record. The
result is formed by applying each field value of the modification record to the
corresponding field value of the data record and replacing the latter by the result of the
application. Data record fields that have no corresponding field in the modification record
are left unchanged.
-}
modify :: (TypeFun style,
Record (Domain style) rec,
Record (Domain style) modRec,
Convertible rec modRec)
=> modRec (style :-> style)
-- ^
-> rec style
-- ^
-> rec style
-- ^
modify modRec = foldr (.) id $ toList (convert updateFuns <<*>> modRec)
type UpdateFunStyle rec style = (style :-> style) :->
Const (Domain style) (rec style -> rec style)
updateFuns :: (TypeFun style, Record (Domain style) rec) => rec (UpdateFunStyle rec style)
updateFuns = let
UpdateFunsThing updateFuns = fold updateFunsNilAlt updateFunsExpander
in updateFuns
newtype UpdateFunsThing style rec = UpdateFunsThing (rec (UpdateFunStyle rec style))
updateFunsNilAlt :: (TypeFun style) => UpdateFunsThing style X
updateFunsNilAlt = UpdateFunsThing nilUpdateFuns where
nilUpdateFuns = X
updateFunsSnocAlt :: (TypeFun style,
Record (Domain style) rec, Name name, Inhabitant (Domain style) sort) =>
UpdateFunsThing style rec ->
UpdateFunsThing style (rec :& name ::: sort)
updateFunsSnocAlt (UpdateFunsThing updateFuns) = UpdateFunsThing snocUpdateFuns where
snocUpdateFuns = map (WrapApp (onInit .)) updateFuns :&
name := updateFun
updateFun mod (rec :& name := val) = rec :& name := mod val
updateFunsExpander :: (TypeFun style, Record (Domain style) rec, Name name) =>
All (Domain style) (Expander (UpdateFunsThing style) rec name)
updateFunsExpander = closed (Expander updateFunsSnocAlt)
onInit :: (rec style -> rec style) ->
((rec :& name ::: sort) style -> (rec :& name ::: sort) style)
onInit fun (rec :& field) = fun rec :& field
{-|
Overwrites the values of multiple record fields. The first argument is the source record,
and the second argument lists the names of the fields to be modified together with their new
values.
-}
(///) :: (TypeFun style,
Record (Domain style) rec,
Record (Domain style) replRec,
Convertible rec replRec)
=> rec style
-- ^
-> replRec style
-- ^
-> rec style
-- ^
rec /// replRec = modify (map (WrapApp const) replRec) rec
-- * Conversion
-- |Converts a record whose style is a constant function into the list of its field values.
toList :: (Kind kind, Record kind rec) => rec (Const kind val) -> [val]
toList = reverse . toRevList
toRevList :: (Kind kind, Record kind rec) => rec (Const kind val) -> [val]
toRevList = let
ToRevListThing toRevList = fold toRevListNilAlt toRevListExpander
in toRevList
newtype ToRevListThing kind val rec = ToRevListThing (rec (Const kind val) -> [val])
toRevListNilAlt :: (Kind kind) => ToRevListThing kind val X
toRevListNilAlt = ToRevListThing nilToRevList where
nilToRevList X = []
toRevListSnocAlt :: (Kind kind, Record kind rec, Name name, Inhabitant kind sort) =>
ToRevListThing kind val rec ->
ToRevListThing kind val (rec :& name ::: sort)
toRevListSnocAlt (ToRevListThing toRevList) = ToRevListThing snocToRevList where
snocToRevList (rec :& _ := val) = val : toRevList rec
toRevListExpander :: (Kind kind, Record kind rec, Name name) =>
All kind (Expander (ToRevListThing kind val) rec name)
toRevListExpander = closed (Expander toRevListSnocAlt)