module Data.Record ( -- * Kinds Kind (type Forall, encase), Sort (specialize), -- * Styles Style (type K), -- * ??? Value, -- * Records Record (build), ExtenderPiece (ExtenderPiece), X (X), (:&) ((:&)), (:::) ((:=)), -- * Catenation Cat, cat, -- * Mapping map, TransformerPiece (TransformerPiece), -- * Subrecords Subrecord (narrow) ) where -- Prelude import Prelude hiding (map) -- Fixities infixl 2 :& infix 3 :::, := -- * Kinds 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 -- * Styles class (Kind (K style)) => Style style where type K style :: * -- * ??? type family Value style sort :: * -- * Records {-| The class of all record types. A record type is a type of records without the style parameter. Therefore, it has kind @* -> *@. -} class (Kind kind) => Record kind record where {-| A general method for building record-related “things”. For each record type, this method constructs a value which is somehow related to this record type. Such a value is called a thing. The type parameter @thing@ maps record types to the types of their corresponding things. The first argument of @build@ gives the thing of the empty record type while the second argument tells how to transform a thing of an arbitrary record type into the thing of this record type extended with an arbitrary field type. @build@ is used, for example, to implement the function 'cat'. -} 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)) -- |The type of empty records. data X style = X deriving (Show) -- |The type of non-empty records, consisting of an initial record and a last field. data (record :& field) style = !(record style) :& !(field style) {- explicit instance declaration to avoid parantheses around init records (will lead to missing parantheses if init is constructed by an operator constructor of the same fixity as :& which is right- or non-associative) -} 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 {-| The family of record fields. Each instance of it matches arbitrary @name@ parameters and all @signalOfVal@ parameters which are of the form @/signal/ `'Of'` /val/@. The actual choice of the instance depends only on the @style@ parameter. The structure of fields of a specific style is documented together with the respective style type. -} data (name ::: sort) style = !name := Value style sort {- explicit instance declaration because GHC doesn’t support deriving because of the use of the type family Value -} 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 -- * Catenation -- |The catenation of two record types. type family Cat (record1 :: * -> *) (record2 :: * -> *) :: * -> * type instance Cat record1 X = record1 type instance Cat record1 (record2 :& field2) = Cat record1 record2 :& field2 -- |The catenation of two records. 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 -- * Mapping -- |Application of a function to the fields of a record. 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 -- * Subrecords {-| The class of all pairs of record types where the first is a subrecord of the second. Currenty, the subrecord relation is only defined for records which do not have multiple occurences of the same name. A records is a subrecord of another record if all field types of the first record are also field types of the second, independently of order. The instance declarations of @Subrecord@ use several helper classes which are hidden. One of them is the class @Presence@. You get the error message that no instance of @Presence /name/@ could be found if the alleged subrecord contains a name which is not present in the alleged superrecord. -} class Subrecord subrecord record where -- |Converts a record into a subrecord by dropping and reordering fields appropriately. 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