module Data.Record.Combinators (
withStyle,
(!!!),
(\\\),
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)
infixl 2 `withStyle`
withStyle :: (Record (Domain style) rec) => rec style -> style -> rec style
withStyle = const
infixl 2 !!!, \\\
(!!!) :: (Separation rec remain sepName sepSort) => rec style -> sepName -> App style sepSort
rec !!! name = let
_ := sepVal = snd (separate rec) `asTypeOf` (name := undefined)
in sepVal
(\\\) :: (Separation rec remain sepName sepSort) => rec style -> sepName -> remain style
rec \\\ name = let
(remain,_) = separate rec `asTypeOf` (undefined,name := undefined)
in remain
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
infixl 1 ///
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
(///) :: (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
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)