module Data.Record (
Kind (type Forall, encase),
Sort (specialize),
Style (type K),
Value,
Record (build),
ExtenderPiece (ExtenderPiece),
X (X),
(:&) ((:&)),
(:::) ((:=)),
Cat,
cat,
map,
TransformerPiece (TransformerPiece),
Subrecord (narrow)
) where
import Prelude hiding (map)
infixl 2 :&
infix 3 :::, :=
class Kind kind where
data Forall kind :: (* -> *) -> *
encase :: (forall sort. (Sort kind sort) => piece sort) -> Forall kind piece
class Sort kind sort where
specialize :: Forall kind piece -> piece sort
class (Kind (K style)) => Style style where
type K style :: *
type family Value style sort :: *
class (Kind kind) => Record kind record where
build :: thing X
-> (forall record name. (Record kind record) =>
Forall kind (ExtenderPiece thing record name))
-> thing record
instance (Kind kind) => Record kind X where
build nilThing _ = nilThing
instance (Kind kind, Record kind record, Sort kind sort) =>
Record kind (record :& name ::: sort) where
build nilThing extender = let
ExtenderPiece consThing = specialize extender
in consThing (build nilThing extender)
newtype ExtenderPiece thing record name sort = ExtenderPiece (thing record ->
thing (record :& name ::: sort))
data X style = X deriving (Show)
data (record :& field) style = !(record style) :& !(field style)
instance (Show (init style), Show (last style)) => Show ((init :& last) style) where
showsPrec enclPrec (init :& last) = showParen (enclPrec > snocPrec) $
showsPrec snocPrec init .
showString " :& " .
showsPrec (succ snocPrec) last where
snocPrec = 2
data (name ::: sort) style = !name := Value style sort
instance (Show name, Show (Value style sort)) => Show ((name ::: sort) style) where
showsPrec enclPrec (name := val) = showParen (enclPrec > assignPrec) $
showsPrec (succ assignPrec) name .
showString " := " .
showsPrec (succ assignPrec) val where
assignPrec = 3
type family Cat (record1 :: * -> *) (record2 :: * -> *) :: * -> *
type instance Cat record1 X = record1
type instance Cat record1 (record2 :& field2) = Cat record1 record2 :& field2
cat :: (Style style, Record (K style) record1, Record (K style) record2) =>
record1 style -> record2 style -> Cat record1 record2 style
cat record1 = case build (nilCatThing record1) catExtender of CatThing attach -> attach
newtype CatThing style record1 record2 = CatThing (record2 style -> Cat record1 record2 style)
nilCatThing :: record1 style -> CatThing style record1 X
nilCatThing record1 = CatThing $ \X -> record1
catExtender :: (Style style) =>
Forall (K style) (ExtenderPiece (CatThing style record1) record name)
catExtender = encase (ExtenderPiece consCatThing)
consCatThing :: CatThing style record1 record2
-> CatThing style record1 (record2 :& name ::: sort)
consCatThing (CatThing attach) = CatThing $ \(record2 :& field2) -> attach record2 :& field2
map :: (Style style, Style style', K style ~ K style', Record (K style) record)
=> Forall (K style) (TransformerPiece style style')
-> record style -> record style'
map = case build nilMapThing mapExtender of MapThing map -> map
newtype TransformerPiece style style' sort = TransformerPiece (Value style sort ->
Value style' sort)
newtype MapThing style
style'
record = MapThing (Forall (K style) (TransformerPiece style style') ->
record style -> record style')
nilMapThing :: MapThing style style' X
nilMapThing = MapThing $ \_ X -> X
mapExtender :: (Style style) =>
Forall (K style) (ExtenderPiece (MapThing style style') record name)
mapExtender = encase (ExtenderPiece consMapThing)
consMapThing :: forall style style' record name sort.
(Sort (K style) sort)
=> MapThing style style' record
-> MapThing style style' (record :& name ::: sort)
consMapThing (MapThing map) = MapThing $ \transformer (record :& name := val) -> let
TransformerPiece fun = specialize transformer :: TransformerPiece style style' sort
in map transformer record :& name := fun val
class Subrecord subrecord record where
narrow :: (Style style) => record style -> subrecord style
instance Subrecord X record where
narrow _ = X
instance (Dissection record remainder subname subsort, Subrecord subrecord remainder) =>
Subrecord (subrecord :& subname ::: subsort) record where
narrow record = narrow remainder :& lookupField where
(remainder,lookupField) = dissect record
class Dissection record remainder lookupName lookupSort | record lookupName -> remainder where
dissect :: record style -> (remainder style,(lookupName ::: lookupSort) style)
instance (Present lookupName) => Dissection X remainder lookupName lookupSort where
dissect = undefined
instance (lastSort ~ lookupSort) =>
Dissection (init :& lookupName ::: lastSort) init lookupName lookupSort where
dissect (init :& last) = (init,last)
instance (Dissection init initRemainder lookupName lookupSort,
(initRemainder :& lastName ::: lastSort) ~ remainder) =>
Dissection (init :& lastName ::: lastSort) remainder lookupName lookupSort where
dissect (init :& last) = (initRemainder :& last,lookupField) where
(initRemainder,lookupField) = dissect init
class Present lookupName