diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,5 @@ Copyright © 2007–2009 Brandenburgische Technische Universität Cottbus +Copyright © 2011 Wolfgang Jeltsch All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted diff --git a/grapefruit-records.cabal b/grapefruit-records.cabal --- a/grapefruit-records.cabal +++ b/grapefruit-records.cabal @@ -1,16 +1,16 @@ Name: grapefruit-records -Version: 0.0.0.0 -Cabal-Version: >= 1.2.3 +Version: 0.1.0.0 +Cabal-Version: >= 1.6 Build-Type: Simple License: BSD3 License-File: LICENSE -Copyright: © 2007–2009 Brandenburgische Technische Universität Cottbus +Copyright: © 2007–2009 Brandenburgische Technische Universität Cottbus; © 2011 Wolfgang Jeltsch Author: Wolfgang Jeltsch -Maintainer: jeltsch@informatik.tu-cottbus.de +Maintainer: wolfgang@cs.ioc.ee Stability: provisional -Homepage: http://haskell.org/haskellwiki/Grapefruit -Package-URL: http://hackage.haskell.org/packages/archive/grapefruit-records/0.0.0.0/grapefruit-records-0.0.0.0.tar.gz -Synopsis: A record system +Homepage: http://grapefruit-project.org/ +Package-URL: http://hackage.haskell.org/packages/archive/grapefruit-records/0.1.0.0/grapefruit-records-0.1.0.0.tar.gz +Synopsis: A record system for Functional Reactive Programming Description: Grapefruit is a library for Functional Reactive Programming (FRP) with a focus on user interfaces. FRP makes it possible to implement reactive and interactive systems in a declarative style. To learn more about FRP, have a look at @@ -18,26 +18,38 @@ . This package provides a record system for use with FRP. Category: Data, FRP, Reactivity -Tested-With: GHC == 6.8.3 - GHC == 6.10.1 +Tested-With: GHC == 7.0.4 +Source-Repository head + type: darcs + location: http://darcs.grapefruit-project.org/main + +Source-Repository this + type: darcs + location: http://darcs.grapefruit-project.org/main + tag: grapefruit-0.1.0.0 + Library - Build-Depends: arrows >= 0.2 && < 0.5, - base >= 3.0 && < 4.1, - grapefruit-frp >= 0.0 && < 0.1, - type-level >= 0.1 && < 0.3, - type-equality-check >= 0.0 && < 0.1 + Build-Depends: arrows >= 0.2 && < 0.5, + base >= 3.0 && < 4.4, + grapefruit-frp >= 0.1 && < 0.2 Extensions: Arrows EmptyDataDecls FlexibleContexts FlexibleInstances FunctionalDependencies MultiParamTypeClasses - Rank2Types + OverlappingInstances + RankNTypes + ScopedTypeVariables + -- only needed for workaround in consConsumeThing and consProduceThing TypeFamilies TypeOperators UndecidableInstances - Exposed-Modules: FRP.Grapefruit.Record - FRP.Grapefruit.Record.Context - FRP.Grapefruit.Record.Optionality + Exposed-Modules: Data.Record + Data.Record.Context + Data.Record.Plain + Data.Record.Optionality + Data.Record.Signal + Data.Record.Signal.Context HS-Source-Dirs: src diff --git a/src/Data/Record.hs b/src/Data/Record.hs new file mode 100644 --- /dev/null +++ b/src/Data/Record.hs @@ -0,0 +1,250 @@ +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 diff --git a/src/Data/Record/Context.hs b/src/Data/Record/Context.hs new file mode 100644 --- /dev/null +++ b/src/Data/Record/Context.hs @@ -0,0 +1,40 @@ +module Data.Record.Context ( + + ContextStyle, + app + +) where + + -- Data + import Data.Record as Record + + -- Fixities + infixr 0 `app` + + {-| + The context consumer and context producer record styles. + + @ContextConnectorStyle /context/ 'Consumer'@ is the style of context consumer records with + context @/context/@ and @ContextConnectorStyle /context/ 'Producer'@ is the style of context + producer records with context @/context/@. Fields of context connector style records have + the form @/name/ ::~~ /connectorGenerator/@. + -} + data ContextStyle context style + + instance (Style style) => Style (ContextStyle context style) where + + type K (ContextStyle context style) = K style + + type instance Value (ContextStyle context style) sort = context -> Value style sort + + {-| + Applies all values of a context connector record to a given context to form an ordinary + context record. + -} + app :: (Style style, Record (K style) record) + => record (ContextStyle context style) + -> context + -> record style + app contextRecord context = Record.map transformer contextRecord where + + transformer = encase (TransformerPiece (\valInContext -> valInContext context)) diff --git a/src/Data/Record/Optionality.hs b/src/Data/Record/Optionality.hs new file mode 100644 --- /dev/null +++ b/src/Data/Record/Optionality.hs @@ -0,0 +1,59 @@ +{-| + This module provides support for optionality records. + + Optionality records are used to specify interfaces with optional input data. Compared to an + ordinary record type, an optionality record type states for every field whether it is required + or optional. This is done by a slight abuse of field names. A field name @/name/@ is replaced by + either @'Req' /name/@ or @'Opt' /name/@. Optionality record types are never used directly in + types of actual values. Instead, they are converted into ordinary record types with the type + functions 'All' and 'Required'. +-} +module Data.Record.Optionality ( + + Req, + Opt, + OptRecord (type All, type Required) + +) where + + -- Data + import Data.Record as Record + + -- |A marker for required fields. + data Req name + + -- |A marker for optional fields. + data Opt name + + -- |The class of all optionality record types. + class OptRecord (optRecord :: * -> *) where + + {-| + Converts an optionality record type into an ordinary record type by dropping all 'Req' + and 'Opt' annotations. + -} + type All optRecord :: * -> * + + {-| + Extracts all required fields from an optionality record type and drops their 'Req' + annotations. + -} + type Required optRecord :: * -> * + + instance OptRecord X where + + type All X = X + + type Required X = X + + instance (OptRecord optRecord) => OptRecord (optRecord :& Req name ::: sort) where + + type All (optRecord :& Req name ::: sort) = All optRecord :& name ::: sort + + type Required (optRecord :& Req name ::: sort) = Required optRecord :& name ::: sort + + instance (OptRecord optRecord) => OptRecord (optRecord :& Opt name ::: sort) where + + type All (optRecord :& Opt name ::: sort) = All optRecord :& name ::: sort + + type Required (optRecord :& Opt name ::: sort) = Required optRecord diff --git a/src/Data/Record/Plain.hs b/src/Data/Record/Plain.hs new file mode 100644 --- /dev/null +++ b/src/Data/Record/Plain.hs @@ -0,0 +1,30 @@ +module Data.Record.Plain ( + + PlainKind, + Forall (PlainForall), + PlainStyle + +) where + + -- Data + import Data.Record as Record + + data PlainKind + + instance Kind PlainKind where + + data Forall PlainKind piece = PlainForall (forall val. piece val) + + encase piece = PlainForall piece + + instance Sort PlainKind val where + + specialize (PlainForall piece) = piece + + data PlainStyle + + instance Style PlainStyle where + + type K PlainStyle = PlainKind + + type instance Value PlainStyle val = val diff --git a/src/Data/Record/Signal.hs b/src/Data/Record/Signal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Record/Signal.hs @@ -0,0 +1,184 @@ +-- FIXME: Introduce hyperlinks to type operators once this is supported by Haddock. +{-| + This module provides records of signals and signal-related data. + + A record has a type of the following form: + + @ + (X :& /name_1/ ::: /signal_1/ `'Of'` /val_1/ :& ... :& /name_n/ ::: /signal_n/ `'Of'` /val_n/) /style/ + @ + + A value of such a type is a list of /fields/ where the /i/th field has type @(/name_i/ ::: + /signal_i/ `'Of'` /val_i/) /style/@. + + @(:::)@ is a data family. Its @/style/@ parameter is a phantom type which selects the instance + of the family. For a concrete @/style/@ type, the type @(/name/ ::: /signal/ `'Of'` + /val/) /style/@ covers name-value pairs where the type of the values depends on @/signal/@ and + @/val/@. For example, if @/style/@ is of the form @'SignalStyle' /era/@, the values have type + @/signal/ /era/ /val/@. This leads to records of signals with identical era. With the styles + @'Connector' 'Consumer'@ and @'Connector' 'Producer'@, it is possible to form records of + consumers and producers. + + Field names are represented by types which are declared as follows: + + @ + data /Name/ = /Name/ + @ + + This makes it possible to use names as types (allowing the use of names in compile-time checks) + but also as expressions and patterns. +-} +module Data.Record.Signal ( + + -- * Signal kind + SignalKind, + Forall (SignalForall), + + -- * Signal records + SignalRecord, + SignalStyle, + -- (:::) ((::=)), + + -- * Connector records + ConsumerRecord, + ProducerRecord, + ConnectorRecord, + ConnectorStyle, + -- (:::) ((::~)), + consume, + produce + +) where + + -- Control + import Control.Arrow as Arrow + + -- Data + import Data.Record as Record + + -- FRP.Grapefruit + import FRP.Grapefruit.Circuit as Circuit + import FRP.Grapefruit.Signal as Signal (Of, Consumer, Producer) + import qualified FRP.Grapefruit.Signal as Signal + + -- * Signal kind + data SignalKind + + instance Kind SignalKind where + + data Forall SignalKind func = SignalForall (forall signal val. func (signal `Of` val)) + + encase piece = SignalForall piece + + instance Sort SignalKind (signal `Of` val) where + + specialize (SignalForall piece) = piece + + -- * Signal records + -- |Records which contain signals of a common era as values. + type SignalRecord era record = record (SignalStyle era) + + {-| + The style of signal records of a specific era. + + Fields of signal style records have the form @/name/ ::= /signal/@. + -} + data SignalStyle era + + instance Style (SignalStyle era) where + + type K (SignalStyle era) = SignalKind + + type instance Value (SignalStyle era) (signal `Of` val) = signal era val + + -- * Connector records + -- ** Records + -- |Records which contain signal consumers as values. + type ConsumerRecord record = ConnectorRecord Consumer record + + -- |Records which contain signal producers as values. + type ProducerRecord record = ConnectorRecord Producer record + + -- |Records which which contain signal connectors (producers or consumers) as values. + type ConnectorRecord connector record = record (ConnectorStyle connector) + + {-| + The consumer and producer record styles. + + @ConnectorStyle 'Consumer'@ is the style of consumer records and @ConnectorStyle 'Producer'@ + is the style of producer records. Fields of connector style records have the form @/name/ + ::~ /connector/@. + -} + data ConnectorStyle (connector :: (* -> * -> *) -> * -> *) + + instance Style (ConnectorStyle connector) where + + type K (ConnectorStyle connector) = SignalKind + + type instance Value (ConnectorStyle connector) (signal `Of` val) = connector signal val + + -- ** Consumption + {-| + Converts a record of consumers into a circuit that consumes a corresponding record of + signals. + -} + consume :: (Record SignalKind record) => + ConsumerRecord record -> Circuit era (SignalRecord era record) () + consume = case build nilConsumeThing consumeExtender of ConsumeThing result -> result + + newtype ConsumeThing era record = ConsumeThing (ConsumerRecord record -> + Circuit era (SignalRecord era record) ()) + + nilConsumeThing :: ConsumeThing era X + nilConsumeThing = ConsumeThing $ \X -> arr (\X -> ()) + + consumeExtender :: Forall SignalKind (ExtenderPiece (ConsumeThing era) record name) + consumeExtender = SignalForall (ExtenderPiece consConsumeThing) + + {-FIXME: + The explicit type signature for the local function consume' (and therefore also the use of + scoped type variables) is currently necessary. If it is left out, GHC 6.10.1 panics with + the message “initC: srt_lbl”. Analogous for consProduceThing. Note that GHC doesn’t panic if + consume and produce are not exported. It also doesn’t panic if Signal.consume consumer and + Signal.produce producer are replaced by undefined. + -} + consConsumeThing :: forall era record name signal val. + ConsumeThing era record + -> ConsumeThing era (record :& name ::: signal `Of` val) + consConsumeThing (ConsumeThing consume) = ConsumeThing consume' where + + consume' :: ConsumerRecord (record :& name ::: signal `Of` val) + -> Circuit era (SignalRecord era (record :& name ::: signal `Of` val)) () + consume' (consumerRecord :& _ := consumer) = proc (signalRecord :& _ := signal) -> do + consume consumerRecord -< signalRecord + Signal.consume consumer -< signal + + -- ** Production + {-| + Converts a record of producers into a circuit that produces a corresponding record of + signals. + -} + produce :: (Record SignalKind record) => + ProducerRecord record -> Circuit era () (SignalRecord era record) + produce = case build nilProduceThing produceExtender of ProduceThing result -> result + + newtype ProduceThing era record = ProduceThing (ProducerRecord record -> + Circuit era () (SignalRecord era record)) + + nilProduceThing :: ProduceThing era X + nilProduceThing = ProduceThing $ \X -> arr (const X) + + produceExtender :: Forall SignalKind (ExtenderPiece (ProduceThing era) record name) + produceExtender = SignalForall (ExtenderPiece consProduceThing) + + consProduceThing :: forall era record name signal val. + ProduceThing era record + -> ProduceThing era (record :& name ::: signal `Of` val) + consProduceThing (ProduceThing produce) = ProduceThing produce' where + + produce' :: ProducerRecord (record :& name ::: signal `Of` val) + -> Circuit era () (SignalRecord era (record :& name ::: signal `Of` val)) + produce' (producerRecord :& name := producer) = proc _ -> do + signalRecord <- produce producerRecord -< () + signal <- Signal.produce producer -< () + returnA -< signalRecord :& name := signal diff --git a/src/Data/Record/Signal/Context.hs b/src/Data/Record/Signal/Context.hs new file mode 100644 --- /dev/null +++ b/src/Data/Record/Signal/Context.hs @@ -0,0 +1,76 @@ +{-| + This module provides context connector records. + + A context connector record is a record of connectors (consumers or producers) which depend on + some data, called the context. +-} +module Data.Record.Signal.Context ( + + -- * Context connector records + ContextConsumerRecord, + ContextProducerRecord, + ContextConnectorRecord, + ContextConnectorStyle, + consume, + produce + +) where + + -- Control + import Control.Arrow.Operations as ArrowOperations + import Control.Arrow.Transformer.Reader as ReaderArrow + + -- Data + import Data.Record as Record + import Data.Record.Context as ContextRecord + import Data.Record.Signal as SignalRecord hiding (consume, produce) + import qualified Data.Record.Signal as SignalRecord + + -- FRP.Grapefruit + import FRP.Grapefruit.Circuit as Circuit + import FRP.Grapefruit.Signal as Signal hiding (consume, produce) + + -- |Records which contain functions from contexts to consumers as values. + type ContextConsumerRecord context record = ContextConnectorRecord context Consumer record + + -- |Records which contain functions from contexts to producers as values. + type ContextProducerRecord context record = ContextConnectorRecord context Producer record + + {-| + Records which contain functions from contexts to connectors (consumers or producers) as + values. + -} + type ContextConnectorRecord context connector record = record (ContextConnectorStyle context + connector) + + type ContextConnectorStyle context connector = ContextStyle context (ConnectorStyle connector) + + {-| + Converts a record of context consumers into a reader arrow which consumes a corresponding + record of signals. The concrete context has to be provided as the environment of the reader + arrow. + -} + consume :: (Record SignalKind record) + => ContextConsumerRecord context record + -> ReaderArrow context (Circuit era) (SignalRecord era record) () + consume = connect SignalRecord.consume + + {-| + Converts a record of context producers into a reader arrow which produces a corresponding + record of signals. The concrete context has to be provided as the environment of the reader + arrow. + -} + produce :: (Record SignalKind record) + => ContextProducerRecord context record + -> ReaderArrow context (Circuit era) () (SignalRecord era record) + produce = connect SignalRecord.produce + + connect :: (Record SignalKind record) + => (ConnectorRecord connector record -> Circuit era i o) + -> ContextConnectorRecord context connector record + -> ReaderArrow context (Circuit era) i o + connect signalRecordConnect contextConnectorRecord = arrow' where + + arrow' = proc i -> do + context <- readState -< () + liftReader $ signalRecordConnect (contextConnectorRecord `app` context) -<< i diff --git a/src/FRP/Grapefruit/Record.hs b/src/FRP/Grapefruit/Record.hs deleted file mode 100644 --- a/src/FRP/Grapefruit/Record.hs +++ /dev/null @@ -1,313 +0,0 @@ --- FIXME: Introduce hyperlinks to type operators once this is supported by Haddock. -{-| - This module provides records of signals and signal-related data. - - A record has a type of the following form: - - @ - (X :& /name_1/ ::: /signal_1/ `'Of'` /val_1/ :& ... :& /name_n/ ::: /signal_n/ `'Of'` /val_n/) /style/ - @ - - A value of such a type is a list of /fields/ where the /i/th field has type @(/name_i/ ::: - /signal_i/ `'Of'` /val_i/) /style/@. - - @(:::)@ is a data family. Its @/style/@ parameter is a phantom type which selects the instance - of the family. For a concrete @/style/@ type, the type @(/name/ ::: /signal/ `'Of'` - /val/) /style/@ covers name-value pairs where the type of the values depends on @/signal/@ and - @/val/@. For example, if @/style/@ is of the form @'SignalStyle' /era/@, the values have type - @/signal/ /era/ /val/@. This leads to records of signals with identical era. With the styles - @'Connector' 'Consumer'@ and @'Connector' 'Producer'@, it is possible to form records of - consumers and producers. - - Field names are represented by types which are declared as follows: - - @ - data /Name/ = /Name/ - @ - - This makes it possible to use names as types (allowing the use of names in compile-time checks) - but also as expressions and patterns. --} -module FRP.Grapefruit.Record ( - - -- * Records - Record (build), - X (X), - (:&) ((:&)), - (:::) ((::=), (::~)), -- data constructors exported here to avoid (:::) double export warning - - -- * Catenation - Cat, - cat, - - -- * Subrecords - Subrecord (narrow), - - -- * Signal records - SignalRecord, - SignalStyle, - -- (:::) ((::=)), - - -- * Connector records - ConsumerRecord, - ProducerRecord, - ConnectorRecord, - ConnectorStyle, - -- (:::) ((::~)), - consume, - produce - -) where - - -- Control - import Control.Arrow as Arrow - - -- Data - import Data.TypeLevel.Bool - import Data.TypeEq - - -- FRP.Grapefruit - import FRP.Grapefruit.Circuit as Circuit - import FRP.Grapefruit.Signal as Signal (Of, Consumer, Producer) - import qualified FRP.Grapefruit.Signal as Signal - - -- Fixities - infixl 2 :& - infix 3 :::, ::=, ::~ - - -- * Records - {-| - The class of all record types. - - A record type is a type of records without the style parameter. Therefore, it has kind @* -> - *@. - -} - class Record 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 signal val. (Record record) => - thing record -> thing (record :& name ::: signal `Of` val)) - -> thing record - - instance Record X where - - build nilThing _ = nilThing - - instance (Record record) => Record (record :& name ::: signal `Of` val) where - - build nilThing consThing = consThing (build nilThing consThing) - - -- |The type of empty records. - data X style = X - - -- |The type of non-empty records, consisting of an initial record and a last field. - data (record :& field) style = !(record style) :& !(field style) - - {-| - 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 family (name ::: signalOfVal) style :: * - - undefinedName :: (name ::: val) style -> name - undefinedName = undefined - - -- * 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 :: (Record record1, Record record2) => - record1 style -> record2 style -> Cat record1 record2 style - cat record1 = case build (nilCatThing record1) consCatThing 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 - - consCatThing :: CatThing style record1 record2 - -> CatThing style record1 (record2 :& name ::: val) - consCatThing (CatThing attach) = CatThing $ \(record2 :& field2) -> attach record2 :& field2 - - -- * 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 (Record subrecord, Record record) => Subrecord subrecord record where - - -- |Converts a record into a subrecord by dropping and reordering fields appropriately. - narrow :: record style -> subrecord style - - instance (Record record) => Subrecord X record where - - narrow _ = X - - instance (Dissection record remainder subname subsignal subval, - Subrecord subrecord remainder) => - Subrecord (subrecord :& subname ::: subsignal `Of` subval) record where - - narrow record = narrow remainder :& lookupField where - - (remainder,lookupField) = dissect record - - class (Record record, Record remainder) => - Dissection record remainder lookupName lookupSignal lookupVal - | record lookupName -> remainder where - - dissect :: record style - -> (remainder style,(lookupName ::: lookupSignal `Of` lookupVal) style) - - instance (Present lookupName, Record remainder) => - Dissection X remainder lookupName lookupSignal lookupVal where - - dissect = undefined - - instance (TypeEq name lookupName namesAreEq, - NameMatchDep namesAreEq - record name signal val - remainder lookupName lookupSignal lookupVal) => - Dissection (record :& name ::: signal `Of` val) - remainder lookupName lookupSignal lookupVal where - - dissect (record :& field) = (remainder,lookupField) where - - (remainder,lookupField) = nameMatchDepExtract (typeEq name lookupName) record field - - name = undefinedName field - - lookupName = undefinedName lookupField - - class (Record record, Record remainder) => - NameMatchDep namesAreEq record name signal val remainder lookupName lookupSignal lookupVal - | namesAreEq record name signal val lookupName -> remainder where - - nameMatchDepExtract :: namesAreEq - -> record style - -> (name ::: signal `Of` val) style - -> (remainder style,(lookupName ::: lookupSignal `Of` lookupVal) style) - - instance (Dissection record remainder lookupName lookupSignal lookupVal) => - NameMatchDep False - record name signal val - remainder lookupName lookupSignal lookupVal where - - nameMatchDepExtract _ record _ = dissect record - - instance (Record record, lookupSignal ~ signal, lookupVal ~ val) => - NameMatchDep True - record lookupName signal val - record lookupName lookupSignal lookupVal where - - nameMatchDepExtract _ record field = (record,field) - - class Present lookupName - - -- * Signal records - -- |Records which contain signals of a common era as values. - type SignalRecord era record = record (SignalStyle era) - - {-| - The style of signal records of a specific era. - - Fields of signal style records have the form @/name/ ::= /signal/@. - -} - data SignalStyle era - - data instance (name ::: signal `Of` val) (SignalStyle era) = !name ::= signal era val - - -- * Connector records - -- ** Records - -- |Records which contain signal consumers as values. - type ConsumerRecord record = ConnectorRecord Consumer record - - -- |Records which contain signal producers as values. - type ProducerRecord record = ConnectorRecord Producer record - - -- |Records which which contain signal connectors (producers or consumers) as values. - type ConnectorRecord connector record = record (ConnectorStyle connector) - - {-| - The consumer and producer record styles. - - @ConnectorStyle 'Consumer'@ is the style of consumer records and @ConnectorStyle 'Producer'@ - is the style of producer records. Fields of connector style records have the form @/name/ - ::~ /connector/@. - -} - data ConnectorStyle (connector :: (* -> * -> *) -> * -> *) - - data instance (:::) name - (signal `Of` val) - (ConnectorStyle connector) = !name ::~ connector signal val - - -- ** Consumption - {-| - Converts a record of consumers into a circuit that consumes a corresponding record of - signals. - -} - consume :: (Record record) => ConsumerRecord record -> Circuit era (SignalRecord era record) () - consume = case build nilConsumeThing consConsumeThing of ConsumeThing result -> result - - newtype ConsumeThing era record = ConsumeThing (ConsumerRecord record -> - Circuit era (SignalRecord era record) ()) - - nilConsumeThing :: ConsumeThing era X - nilConsumeThing = ConsumeThing $ \X -> arr (\X -> ()) - - consConsumeThing :: ConsumeThing era record - -> ConsumeThing era (record :& name ::: signal `Of` val) - consConsumeThing (ConsumeThing consume) = ConsumeThing consume' where - - consume' (consumerRecord :& _ ::~ consumer) = proc (signalRecord :& _ ::= signal) -> do - consume consumerRecord -< signalRecord - Signal.consume consumer -< signal - - -- ** Production - {-| - Converts a record of producers into a circuit that produces a corresponding record of - signals. - -} - produce :: (Record record) => ProducerRecord record -> Circuit era () (SignalRecord era record) - produce = case build nilProduceThing consProduceThing of ProduceThing result -> result - - newtype ProduceThing era record = ProduceThing (ProducerRecord record -> - Circuit era () (SignalRecord era record)) - - nilProduceThing :: ProduceThing era X - nilProduceThing = ProduceThing $ \X -> arr (const X) - - consProduceThing :: ProduceThing era record - -> ProduceThing era (record :& name ::: signal `Of` val) - consProduceThing (ProduceThing produce) = ProduceThing produce' where - - produce' (producerRecord :& name ::~ producer) = proc () -> do - signalRecord <- produce producerRecord -< () - signal <- Signal.produce producer -< () - returnA -< signalRecord :& name ::= signal diff --git a/src/FRP/Grapefruit/Record/Context.hs b/src/FRP/Grapefruit/Record/Context.hs deleted file mode 100644 --- a/src/FRP/Grapefruit/Record/Context.hs +++ /dev/null @@ -1,122 +0,0 @@ -{-| - This module provides context connector records. - - A context connector record is a record of connectors (consumers or producers) which depend on - some data, called the context. --} -module FRP.Grapefruit.Record.Context ( - - -- * Context connector records - ContextConsumerRecord, - ContextProducerRecord, - ContextConnectorRecord, - ContextConnectorStyle, - consume, - produce, - app, - - -- * Field family instance for context connector records - (:::) ((::~~)) - -) where - - -- Control - import Control.Arrow.Operations as ArrowOperations - import Control.Arrow.Transformer.Reader as ReaderArrow - - -- FRP.Grapefruit - import FRP.Grapefruit.Circuit as Circuit - import FRP.Grapefruit.Signal as Signal hiding (consume, produce) - import FRP.Grapefruit.Record as Record hiding (consume, produce) - import qualified FRP.Grapefruit.Record as Record - - -- Fixities - infixr 0 `app` - infix 3 ::~~ - - -- |Records which contain functions from contexts to consumers as values. - type ContextConsumerRecord context record = ContextConnectorRecord context Consumer record - - -- |Records which contain functions from contexts to producers as values. - type ContextProducerRecord context record = ContextConnectorRecord context Producer record - - {-| - Records which contain functions from contexts to connectors (consumers or producers) as - values. - -} - type ContextConnectorRecord context connector record = record (ContextConnectorStyle context - connector) - - {-| - The context consumer and context producer record styles. - - @ContextConnectorStyle /context/ 'Consumer'@ is the style of context consumer records with - context @/context/@ and @ContextConnectorStyle /context/ 'Producer'@ is the style of context - producer records with context @/context/@. Fields of context connector style records have - the form @/name/ ::~~ /connectorGenerator/@. - -} - data ContextConnectorStyle context connector - - data instance (:::) name - (signal `Of` val) - (ContextConnectorStyle context - connector) = (::~~) !name - (context -> connector signal val) - - {-| - Converts a record of context consumers into a reader arrow which consumes a corresponding - record of signals. The concrete context has to be provided as the environment of the reader - arrow. - -} - consume :: (Record record) - => ContextConsumerRecord context record - -> ReaderArrow context (Circuit era) (SignalRecord era record) () - consume = connect Record.consume - - {-| - Converts a record of context producers into a reader arrow which produces a corresponding - record of signals. The concrete context has to be provided as the environment of the reader - arrow. - -} - produce :: (Record record) - => ContextProducerRecord context record - -> ReaderArrow context (Circuit era) () (SignalRecord era record) - produce = connect Record.produce - - connect :: (Record record) - => (ConnectorRecord connector record -> Circuit era i o) - -> ContextConnectorRecord context connector record - -> ReaderArrow context (Circuit era) i o - connect signalRecordConnect contextConnectorRecord = arrow' where - - arrow' = proc i -> do - context <- readState -< () - liftReader $ signalRecordConnect (contextConnectorRecord `app` context) -<< i - - {-| - Applies all values of a context connector record to a given context to form an ordinary - context record. - -} - app :: (Record record) - => ContextConnectorRecord context connector record - -> context - -> ConnectorRecord connector record - app = case build nilAppThing consAppThing of AppThing apply -> apply - - newtype AppThing context connector record = AppThing (ContextConnectorRecord context - connector - record -> - context -> - ConnectorRecord connector record) - - nilAppThing :: AppThing context connector X - nilAppThing = AppThing $ \X _ -> X - - consAppThing :: AppThing context connector record - -> AppThing context connector (record :& name ::: signal `Of` val) - consAppThing (AppThing apply) = AppThing apply' where - - apply' ((:&) contextConnectorRecord - (name ::~~ contextConnector)) - context = apply contextConnectorRecord context :& - name ::~ contextConnector context diff --git a/src/FRP/Grapefruit/Record/Optionality.hs b/src/FRP/Grapefruit/Record/Optionality.hs deleted file mode 100644 --- a/src/FRP/Grapefruit/Record/Optionality.hs +++ /dev/null @@ -1,64 +0,0 @@ -{-| - This module provides support for optionality records. - - Optionality records are used to specify interfaces with optional input data. Compared to an - ordinary record type, an optionality record type states for every field whether it is required - or optional. This is done by a slight abuse of field names. A field name @/name/@ is replaced by - either @'Req' /name/@ or @'Opt' /name/@. Optionality record types are never used directly in - types of actual values. Instead, they are converted into ordinary record types with the type - functions 'All' and 'Required'. --} -module FRP.Grapefruit.Record.Optionality ( - - Req, - Opt, - OptRecord (type All, type Required) - -) where - - -- FRP.Grapefruit - import FRP.Grapefruit.Signal as Signal - import FRP.Grapefruit.Record as Record - - -- |A marker for required fields. - data Req name - - -- |A marker for optional fields. - data Opt name - - -- |The class of all optionality record types. - class (Record (All optRecord), Record (Required optRecord)) => - OptRecord (optRecord :: * -> *) where - - {-| - Converts an optionality record type into an ordinary record type by dropping all 'Req' - and 'Opt' annotations. - -} - type All optRecord :: * -> * - - {-| - Extracts all required fields from an optionality record type and drops their 'Req' - annotations. - -} - type Required optRecord :: * -> * - - instance OptRecord X where - - type All X = X - - type Required X = X - - instance (OptRecord optRecord) => OptRecord (optRecord :& Req name ::: signal `Of` val) where - - type All (optRecord :& Req name ::: signal `Of` val) = All optRecord :& - name ::: signal `Of` val - - type Required (optRecord :& Req name ::: signal `Of` val) = Required optRecord :& - name ::: signal `Of` val - - instance (OptRecord optRecord) => OptRecord (optRecord :& Opt name ::: signal `Of` val) where - - type All (optRecord :& Opt name ::: signal `Of` val) = All optRecord :& - name ::: signal `Of` val - - type Required (optRecord :& Opt name ::: signal `Of` val) = Required optRecord