module Data.Record.Combinators (
Cat,
cat,
repeat,
(<<*>>),
map,
zipWith,
modify,
toList
) where
import Prelude hiding (repeat, map, zipWith)
import qualified Prelude
import Data.Kind as Kind
import Data.TypeFun as TypeFun
import Data.Record as Record
import Control.Applicative as Applicative hiding (Const)
type family Cat (rec1 :: * -> *) (rec2 :: * -> *) :: * -> *
type instance Cat rec1 X = rec1
type instance Cat rec1 (rec2 :& name2 ::: sort2) = Cat rec1 rec2 :& name2 ::: sort2
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)
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 <<*>>
(<<*>>) :: (TypeFun style, TypeFun style', Domain style ~ Domain style',
Record (Domain (style -> style')) rec) =>
rec (style -> style') -> rec style -> rec style'
(<<*>>) = zipWithApp
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
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
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
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)