e11y (empty) → 0.1.0.0
raw patch · 9 files changed
+1735/−0 lines, 9 filesdep +basedep +containersdep +e11y
Dependencies added: base, containers, e11y, exceptions, general-allocate, parametric-functor, primitive, strict-identity, sydtest, transformers
Files
- CHANGELOG.md +5/−0
- LICENSE +202/−0
- compat/new/Observe/Event/Compat.hs +29/−0
- compat/old/Observe/Event/Compat.hs +29/−0
- e11y.cabal +106/−0
- src/Observe/Event.hs +468/−0
- src/Observe/Event/Backend.hs +268/−0
- src/Observe/Event/Backend/Data.hs +188/−0
- test/Test.hs +440/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for e11y++## 0.1.0.0 -- 2024-01-16++* Initial release
+ LICENSE view
@@ -0,0 +1,202 @@++ Apache License+ Version 2.0, January 2004+ http://www.apache.org/licenses/++ TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION++ 1. Definitions.++ "License" shall mean the terms and conditions for use, reproduction,+ and distribution as defined by Sections 1 through 9 of this document.++ "Licensor" shall mean the copyright owner or entity authorized by+ the copyright owner that is granting the License.++ "Legal Entity" shall mean the union of the acting entity and all+ other entities that control, are controlled by, or are under common+ control with that entity. For the purposes of this definition,+ "control" means (i) the power, direct or indirect, to cause the+ direction or management of such entity, whether by contract or+ otherwise, or (ii) ownership of fifty percent (50%) or more of the+ outstanding shares, or (iii) beneficial ownership of such entity.++ "You" (or "Your") shall mean an individual or Legal Entity+ exercising permissions granted by this License.++ "Source" form shall mean the preferred form for making modifications,+ including but not limited to software source code, documentation+ source, and configuration files.++ "Object" form shall mean any form resulting from mechanical+ transformation or translation of a Source form, including but+ not limited to compiled object code, generated documentation,+ and conversions to other media types.++ "Work" shall mean the work of authorship, whether in Source or+ Object form, made available under the License, as indicated by a+ copyright notice that is included in or attached to the work+ (an example is provided in the Appendix below).++ "Derivative Works" shall mean any work, whether in Source or Object+ form, that is based on (or derived from) the Work and for which the+ editorial revisions, annotations, elaborations, or other modifications+ represent, as a whole, an original work of authorship. For the purposes+ of this License, Derivative Works shall not include works that remain+ separable from, or merely link (or bind by name) to the interfaces of,+ the Work and Derivative Works thereof.++ "Contribution" shall mean any work of authorship, including+ the original version of the Work and any modifications or additions+ to that Work or Derivative Works thereof, that is intentionally+ submitted to Licensor for inclusion in the Work by the copyright owner+ or by an individual or Legal Entity authorized to submit on behalf of+ the copyright owner. For the purposes of this definition, "submitted"+ means any form of electronic, verbal, or written communication sent+ to the Licensor or its representatives, including but not limited to+ communication on electronic mailing lists, source code control systems,+ and issue tracking systems that are managed by, or on behalf of, the+ Licensor for the purpose of discussing and improving the Work, but+ excluding communication that is conspicuously marked or otherwise+ designated in writing by the copyright owner as "Not a Contribution."++ "Contributor" shall mean Licensor and any individual or Legal Entity+ on behalf of whom a Contribution has been received by Licensor and+ subsequently incorporated within the Work.++ 2. Grant of Copyright License. Subject to the terms and conditions of+ this License, each Contributor hereby grants to You a perpetual,+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable+ copyright license to reproduce, prepare Derivative Works of,+ publicly display, publicly perform, sublicense, and distribute the+ Work and such Derivative Works in Source or Object form.++ 3. Grant of Patent License. Subject to the terms and conditions of+ this License, each Contributor hereby grants to You a perpetual,+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable+ (except as stated in this section) patent license to make, have made,+ use, offer to sell, sell, import, and otherwise transfer the Work,+ where such license applies only to those patent claims licensable+ by such Contributor that are necessarily infringed by their+ Contribution(s) alone or by combination of their Contribution(s)+ with the Work to which such Contribution(s) was submitted. If You+ institute patent litigation against any entity (including a+ cross-claim or counterclaim in a lawsuit) alleging that the Work+ or a Contribution incorporated within the Work constitutes direct+ or contributory patent infringement, then any patent licenses+ granted to You under this License for that Work shall terminate+ as of the date such litigation is filed.++ 4. Redistribution. You may reproduce and distribute copies of the+ Work or Derivative Works thereof in any medium, with or without+ modifications, and in Source or Object form, provided that You+ meet the following conditions:++ (a) You must give any other recipients of the Work or+ Derivative Works a copy of this License; and++ (b) You must cause any modified files to carry prominent notices+ stating that You changed the files; and++ (c) You must retain, in the Source form of any Derivative Works+ that You distribute, all copyright, patent, trademark, and+ attribution notices from the Source form of the Work,+ excluding those notices that do not pertain to any part of+ the Derivative Works; and++ (d) If the Work includes a "NOTICE" text file as part of its+ distribution, then any Derivative Works that You distribute must+ include a readable copy of the attribution notices contained+ within such NOTICE file, excluding those notices that do not+ pertain to any part of the Derivative Works, in at least one+ of the following places: within a NOTICE text file distributed+ as part of the Derivative Works; within the Source form or+ documentation, if provided along with the Derivative Works; or,+ within a display generated by the Derivative Works, if and+ wherever such third-party notices normally appear. The contents+ of the NOTICE file are for informational purposes only and+ do not modify the License. You may add Your own attribution+ notices within Derivative Works that You distribute, alongside+ or as an addendum to the NOTICE text from the Work, provided+ that such additional attribution notices cannot be construed+ as modifying the License.++ You may add Your own copyright statement to Your modifications and+ may provide additional or different license terms and conditions+ for use, reproduction, or distribution of Your modifications, or+ for any such Derivative Works as a whole, provided Your use,+ reproduction, and distribution of the Work otherwise complies with+ the conditions stated in this License.++ 5. Submission of Contributions. Unless You explicitly state otherwise,+ any Contribution intentionally submitted for inclusion in the Work+ by You to the Licensor shall be under the terms and conditions of+ this License, without any additional terms or conditions.+ Notwithstanding the above, nothing herein shall supersede or modify+ the terms of any separate license agreement you may have executed+ with Licensor regarding such Contributions.++ 6. Trademarks. This License does not grant permission to use the trade+ names, trademarks, service marks, or product names of the Licensor,+ except as required for reasonable and customary use in describing the+ origin of the Work and reproducing the content of the NOTICE file.++ 7. Disclaimer of Warranty. Unless required by applicable law or+ agreed to in writing, Licensor provides the Work (and each+ Contributor provides its Contributions) on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or+ implied, including, without limitation, any warranties or conditions+ of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A+ PARTICULAR PURPOSE. You are solely responsible for determining the+ appropriateness of using or redistributing the Work and assume any+ risks associated with Your exercise of permissions under this License.++ 8. Limitation of Liability. In no event and under no legal theory,+ whether in tort (including negligence), contract, or otherwise,+ unless required by applicable law (such as deliberate and grossly+ negligent acts) or agreed to in writing, shall any Contributor be+ liable to You for damages, including any direct, indirect, special,+ incidental, or consequential damages of any character arising as a+ result of this License or out of the use or inability to use the+ Work (including but not limited to damages for loss of goodwill,+ work stoppage, computer failure or malfunction, or any and all+ other commercial damages or losses), even if such Contributor+ has been advised of the possibility of such damages.++ 9. Accepting Warranty or Additional Liability. While redistributing+ the Work or Derivative Works thereof, You may choose to offer,+ and charge a fee for, acceptance of support, warranty, indemnity,+ or other liability obligations and/or rights consistent with this+ License. However, in accepting such obligations, You may act only+ on Your own behalf and on Your sole responsibility, not on behalf+ of any other Contributor, and only if You agree to indemnify,+ defend, and hold each Contributor harmless for any liability+ incurred by, or claims asserted against, such Contributor by reason+ of your accepting any such warranty or additional liability.++ END OF TERMS AND CONDITIONS++ APPENDIX: How to apply the Apache License to your work.++ To apply the Apache License to your work, attach the following+ boilerplate notice, with the fields enclosed by brackets "[]"+ replaced with your own identifying information. (Don't include+ the brackets!) The text should be enclosed in the appropriate+ comment syntax for the file format. We also recommend that a+ file or class name and description of purpose be included on the+ same "printed page" as the copyright notice for easier+ identification within third-party archives.++ Copyright 2024 Shea Levy++ Licensed under the Apache License, Version 2.0 (the "License");+ you may not use this file except in compliance with the License.+ You may obtain a copy of the License at++ http://www.apache.org/licenses/LICENSE-2.0++ Unless required by applicable law or agreed to in writing, software+ distributed under the License is distributed on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+ See the License for the specific language governing permissions and+ limitations under the License.
+ compat/new/Observe/Event/Compat.hs view
@@ -0,0 +1,29 @@+-- Copyright 2024 Shea Levy+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+-- http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.+{-# LANGUAGE UnicodeSyntax #-}++{- |+Description : Compatibility shims for old libraries+Copyright : Copyright 2024 Shea Levy.+License : Apache-2.0+Maintainer : shea@shealevy.com+-}+module Observe.Event.Compat where++import Data.Kind++{- | Work around lack of t'Control.Monad.Trans.Class.MonadTrans' monad-preserving superconstraint in+older @transformers@.+-}+type MonadTransMonadConstraint (t ∷ (Type → Type) → (Type → Type)) (m ∷ Type → Type) = () ∷ Constraint
+ compat/old/Observe/Event/Compat.hs view
@@ -0,0 +1,29 @@+-- Copyright 2024 Shea Levy+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+-- http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.+{-# LANGUAGE UnicodeSyntax #-}++{- |+Description : Compatibility shims for old libraries+Copyright : Copyright 2024 Shea Levy.+License : Apache-2.0+Maintainer : shea@shealevy.com+-}+module Observe.Event.Compat where++import Data.Kind++{- | Work around lack of t'Control.Monad.Trans.Class.MonadTrans' monad-preserving superconstraint in+older @transformers@.+-}+type MonadTransMonadConstraint t (m ∷ Type → Type) = (Monad (t m))
+ e11y.cabal view
@@ -0,0 +1,106 @@+cabal-version: 3.0+name: e11y+version: 0.1.0.0+synopsis: An event-oriented observability library+description:+ Instrument your Haskell codebase with [wide, semantically meaningful events](https://charity.wtf/2022/08/15/live-your-best-life-with-structured-events/).++ This library is designed with separating the following concerns in mind:++ [@Writing instrumentation@] When instrumenting code, I want to think in terms of my+ application domain and report any information I might need in order to infer internal+ application-level state and understand the behavior of my program/library.++ [@Consuming instrumentation@] When consuming instrumentation, I want to think in+ terms of the API of the specific backend I'm supporting (writing to @stderr@,+ serving a @Prometheus@ page, posting to @OpenTelemetry@) and what is needed to+ render to that API.++ [@Initializing instrumentation in an application@] When I'm ready to tie it all+ together, I want to identify the specific backends I want to post to and provide+ the bridge code to render the domain-specific instrumentation as needed for those+ backends. I also want to handle concerns like sampling or client-side aggregation+ of domain-specific instrumentation to keep usage manageable.++ See "Observe.Event" for detailed documentation on instrumenting your code.++ See "Observe.Event.Backend" for creating a new @EventBackend@ to consume instrumentation.++ See "Observe.Event.Backend.Data" for an @EventBackend@ that represents the stream of events as+ ordinary Haskell data.++ See [e11y-otel](https://hackage.haskell.org/package/e11y-otel) for an OpenTelemetry-based+ backend.++ This is a rewrite of [eventuo11y](https://hackage.haskell.org/package/eventuo11y), designed+ to be easier to use, less intrusive, and not nearly as annoying to write/say. The name+ is a shortening of "event-based observability" (event-based -> e, observability -> o11y), and+ can be pronounced "eh-lee" or "ee-eleven-why".+bug-reports: https://github.com/shlevy/e11y/issues+homepage: https://github.com/shlevy/e11y+license: Apache-2.0+license-file: LICENSE+author: Shea Levy+maintainer: shea@shealevy.com+copyright:+ Copyright 2024 Shea Levy++ Licensed under the Apache License, Version 2.0 (the "License");+ you may not use this file except in compliance with the License.+ You may obtain a copy of the License at++ http://www.apache.org/licenses/LICENSE-2.0++ Unless required by applicable law or agreed to in writing, software+ distributed under the License is distributed on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+ See the License for the specific language governing permissions and+ limitations under the License.+category: Observability+build-type: Simple+extra-doc-files: CHANGELOG.md+tested-with: GHC == { 9.2.8, 9.4.8, 9.6.4, 9.8.1 }++source-repository head+ type: git+ location: https://github.com/shlevy/e11y++library+ exposed-modules:+ Observe.Event+ Observe.Event.Backend+ Observe.Event.Backend.Data+ Observe.Event.Compat++ build-depends:+ , base ^>= { 4.16, 4.17, 4.18, 4.19 }+ , containers ^>= { 0.6, 0.7 }+ , general-allocate ^>= { 0.2.3 }+ , parametric-functor ^>= { 0.1.1 }+ , primitive ^>= { 0.9 }+ , transformers ^>= { 0.5, 0.6 }++ hs-source-dirs: src+ if impl(ghc >= 9.6)+ hs-source-dirs: compat/new+ else+ hs-source-dirs: compat/old++ default-language: GHC2021++test-suite e11y+ type: exitcode-stdio-1.0+ main-is: Test.hs+ hs-source-dirs: test+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ , base+ , containers+ , e11y+ , exceptions ^>= { 0.10 }+ , general-allocate+ , strict-identity ^>= { 0.1 }+ , sydtest ^>= { 0.15 }+ , transformers++ default-language: GHC2021
+ src/Observe/Event.hs view
@@ -0,0 +1,468 @@+-- Copyright 2024 Shea Levy+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+-- http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE StandaloneKindSignatures #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE UnicodeSyntax #-}++{- |+Description : Event-oriented instrumentation+Copyright : Copyright 2024 Shea Levy.+License : Apache-2.0+Maintainer : shea@shealevy.com++This is the primary module needed to instrument code with @e11y@.++To /consume/ instrumentation, see "Observe.Event.Backend".+-}+module Observe.Event+ ( -- * Selectors and fields #selectorAndField#++ -- | Instrumentors should first define selector and field types appropriate+ -- to the unit of code they're instrumenting:+ --+ -- Selectors are values which designate the general category of event+ -- being [created](#g:init), parameterized by the type of fields that can be added to it.+ -- For example, a web service's selector type may have a @ServicingRequest@+ -- constructor, whose field type includes a @ResponseCode@ constructor which+ -- records the HTTP status code. Selectors are intended to be of a domain-specific+ -- type per unit of functionality within an instrumented codebase, implemented as a GADT.+ --+ -- Fields make up the basic data captured in an event. They should be added+ -- to an 'Event' (with 'addEventField') as the code progresses through various+ -- phases of work, and can be both milestone markers ("we got this far in the process")+ -- or more detailed instrumentation ("we've processed N records"). They are intended to+ -- be of a domain-specific type per unit of functionality within an instrumented codebase.+ SubSelector+ , NoEventsSelector++ -- ** Selector rendering++ -- | 'EventBackend's will typically require the user to provide a "rendering function"+ -- to translate 'Event'-based instrumentation into the format required for the backend.+ -- The full type of this will depend on the backend in question, but it will typically+ -- involve a function of the form @Selectors selector field -> T field@ for some @T@+ -- (perhaps a function type taking further arguments). The 'Selectors' type is not+ -- the simplest to work with, but in most cases the 'selectorRendering' function can+ -- be used to write your renderer.+ --+ -- Consider the following selector tree:+ --+ -- > module Parent where+ -- >+ -- > import Child+ -- >+ -- > data ParentSelector field where+ -- > ParentA :: ParentSelector AField+ -- > ParentB :: ParentSelector BField+ -- >+ -- > data AField = AField Int+ -- > type instance SubSelector AField = NoEventsSelector+ -- >+ -- > data BField = BYes | BNo+ -- > type instance SubSelector BField = ChildSelector+ --+ -- > module Child where+ -- >+ -- > data ChildSelector field where+ -- > Child :: ChildSelector CField+ -- >+ -- > data CField = CField+ -- > type instance SubSelector CField = NoEventsSelector+ --+ -- You could write renderers for these as follows:+ --+ -- > module Parent where -- Or it could be in a separate module if you want to keep instrumentation and rendering apart+ -- >+ -- > renderParentSelector :: Selectors ParentSelector field -> Identity field -- Obviously in a real case it wouldn't be Identity+ -- > renderParentSelector = selectorRendering $ \case+ -- > ParentA -> noSubEventsSelectorRendering (Identity $ AField 0)+ -- > ParentB -> SelectorRendering+ -- > { renderTopSelector = Identity BYes+ -- > , renderSubSelector = renderChildSelector -- You could also modify the T CField after calling the child renderer+ -- > }+ --+ -- > module Child where+ -- >+ -- > renderChildSelector :: Selectors ChildSelector field -> Identity field+ -- > renderChildSelector = selectorRendering $ \Child ->+ -- > noSubEventsSelectorRendering $ Identity CField+ , selectorRendering+ , SelectorRendering (..)+ , noSubEventsSelectorRendering+ , Selectors (..)++ -- * Event initialization #init#++ -- | Actual instrumentation centers around t'Event's, which can+ -- be initialized in the appropriate [computational contexts](#g:contexts)+ -- given an appropriate [selector](#g:selectorAndField) value.+ , withEvent+ , instantEvent+ , Event++ -- ** Event relationships #relationships#++ -- | 'Event's can be related to each other in two ways: An 'Event' can have+ -- another 'Event' as a parent, and an 'Event' can have any number of other+ -- 'Event's as proximate causes.+ --+ -- In normal usage, these relationships are handled for you: 'withEvent'+ -- automatically marks new 'Event's created in the scope of the 'Event'+ -- as children.+ --+ -- If you need to specify more complex relationships, you can get a reference+ -- to an 'Event' using 'eventReference'. References are monad-independent data+ -- that can outlive the 'Event' itself, and are used to tell an 'EventBackend'+ -- which other 'Event's are involved in a new one.+ , eventReference+ , withRelatedEvent+ , allocateRelatedEvent+ , instantRelatedEvent++ -- ** 'Event'-supporting computational contexts #contexts#+ , HasEvents+ , HasEvent+ , HasEventIn+ , HasSubEvents++ -- ** Lower-level 'Event' allocation management+ , SubEventBackend (..)+ , allocateEventArgs+ , instantEventArgs++ -- * Event manipulation+ , addEventField+ , finalizeEvent+ )+where++import Control.Applicative+import Control.Exception+import Control.Monad.With+import Data.Coerce+import Data.Exceptable+import Data.Functor.Parametric+import Data.GeneralAllocate+import Data.Kind+import Observe.Event.Backend++-- * Event initialization #initialization#++{- | Run a computation during an 'Event' selected by the [selector](#g:selectorAndField).++Parentless 'Event's created during the computation will be marked as children of the+new 'Event'.++The 'Event' will be 'finalize'd at the end of the computation.++See 'withRelatedEvent' if you need to specify [relationships](#g:relationships).+-}+withEvent+ ∷ (HasEvents m backend selector, MonadWithExceptable m)+ ⇒ selector field+ -- ^ The event [selector](#g:selectorAndField)+ → ((HasSubEvents m backend field) ⇒ m a)+ -- ^ The eventful computation+ → m a+withEvent selector = withRelatedEvent selector Nothing []++{- | Emit an instantaneous 'Event' with the given [selector and fields](#g:selectorAndField).++See 'instantRelatedEvent' if you need to specify [relationships](#g:relationships).+-}+instantEvent+ ∷ (HasEvents m backend selector)+ ⇒ selector field+ -- ^ The event [selector](#g:selectorAndField)+ → [field]+ -- ^ The [fields](#g:selectorAndField) of the event.+ → m (EventReference (BackendEvent backend))+instantEvent selector fields = instantRelatedEvent selector fields Nothing []++{- | Emit an instantaneous 'Event' with the given [selector and fields](#g:selectorAndField)+and the given [parent and causes](#g:relationships).++See 'instantEvent' if you don't need to specify any relationships.++See 'instantEventArgs' for full control over 'Event' configuration.+-}+instantRelatedEvent+ ∷ (HasEvents m backend selector)+ ⇒ selector field+ -- ^ The event [selector](#g:selectorAndField)+ → [field]+ -- ^ The [fields](#g:selectorAndField) of the event.+ → Maybe (EventReference (BackendEvent backend))+ -- ^ The [parent](#g:relationships) of this event+ → [EventReference (BackendEvent backend)]+ -- ^ The [causes](#g:relationships) of this event+ → m (EventReference (BackendEvent backend))+instantRelatedEvent selector initialFields parent causes =+ instantEventArgs $+ EventParams+ { selectors = Leaf selector+ , parent+ , causes+ , initialFields+ }++{- | Emit an instantaneous 'Event' described by t'EventParams'++You probably want 'instantEvent' or 'instantRelatedEvent'+-}+instantEventArgs+ ∷ (HasEvents m backend selector)+ ⇒ EventParams selector field (EventReference (BackendEvent backend))+ → m (EventReference (BackendEvent backend))+instantEventArgs = newInstantEvent ?e11yBackend++{- | Run a computation during an 'Event' selected by the [selector](#g:selectorAndField) and with the given [parent and causes](#g:relationships).++Parentless 'Event's created during the computation will be marked as children of the+new 'Event'.++The 'Event' will be 'finalize'd at the end of the computation.++See 'withEvent' if you don't need to specify any relationships.++For a more flexible allocation, see 'allocateRelatedEvent'.+-}+withRelatedEvent+ ∷ (HasEvents m backend selector, MonadWithExceptable m)+ ⇒ selector field+ -- ^ The event [selector](#g:selectorAndField)+ → Maybe (EventReference (BackendEvent backend))+ -- ^ The [parent](#g:relationships) of this event+ → [EventReference (BackendEvent backend)]+ -- ^ The [causes](#g:relationships) of this event+ → ((HasSubEvents m backend field) ⇒ m a)+ -- ^ The eventful computation+ → m a+withRelatedEvent selector parent causes go = generalWith (allocateRelatedEvent selector parent causes) $+ \ev →+ let+ ?e11yEvent = ev+ ?e11yBackend = SubEventBackend selector ?e11yBackend $ reference ev+ in+ go++{- | A t'GeneralAllocate'-ion of a new 'Event', selected by the [selector](#g:selectorAndField)+and with the given [parent and causes](#g:relationships).++The 'Event' with be 'finalize'd upon release.++See 'allocateEventArgs' for full flexibility in specifying allocation.++You will likely want to construct a t'SubEventBackend' to create a+'HasSubEvents' context when using this 'Event'.+-}+allocateRelatedEvent+ ∷ (HasEvents m backend selector, Exceptable e)+ ⇒ selector field+ -- ^ The event [selector](#g:selectorAndField)+ → Maybe (EventReference (BackendEvent backend))+ -- ^ The [parent](#g:relationships) of this event+ → [EventReference (BackendEvent backend)]+ -- ^ The [causes](#g:relationships) of this event+ → GeneralAllocate m e () releaseArg (BackendEvent backend field)+allocateRelatedEvent selector parent causes =+ allocateEventArgs $+ EventParams+ { selectors = Leaf selector+ , causes+ , parent+ , initialFields = []+ }++-- | Get a [reference](#g:relationships) to the current 'Event'.+eventReference ∷ (HasEvent event field) ⇒ EventReference event+eventReference = reference ?e11yEvent++{- | A t'GeneralAllocate'-ion of a new 'Event' described by t'EventParams'++The 'Event' with be 'finalize'd upon release.++You probably want 'allocateRelatedEvent'.++You will likely want to construct a t'SubEventBackend' to construct a 'HasSubEvents'+context when using this 'Event'.+-}+allocateEventArgs+ ∷ (HasEvents m backend selector, Exceptable e)+ ⇒ EventParams selector field (EventReference (BackendEvent backend))+ -- ^ Specify the event, matching the appropriate [selector](Observe-Event.html#g:selectorAndField)+ -- type for this 'EventBackend'.+ → GeneralAllocate m e () releaseArg (BackendEvent backend field)+allocateEventArgs params = GeneralAllocate $ \unmask → do+ ev ← unmask $ newEvent ?e11yBackend params+ let release (ReleaseFailure e) = finalize ev . Just $ toSomeException e+ release (ReleaseSuccess _) = finalize ev Nothing+ pure $ GeneralAllocated ev release++{- | End the running 'Event' manually, perhaps due to an exception.++It is implementation-specific whether 'addEventField' after 'finalizeEvent'+has any effect (but it is not an error).++Subsequent 'finalize'ations, including those that result from leaving the+'withEvent' scope or releasing the 'allocateEventArgs' allocation, will be+no-ops.+-}+finalizeEvent+ ∷ (HasEventIn m event field)+ ⇒ Maybe SomeException+ → m ()+finalizeEvent = finalize ?e11yEvent++{- | A computational context supporting creating 'Event's from a given [selector](#g:selectorAndField) family.++In typical usage, @backend@ will be kept as a type parameter, to be determined+at the call site by the dynamically-scoped @?e11yBackend@ parameter.++'HasEvents' can be satisfied by binding the @?e11yBackend@ [implicit parameter](https://downloads.haskell.org/ghc/latest/docs/users_guide/exts/implicit_parameters.html)+to an appropriate value. v'Data.Proxy.Proxy' @selector@ can be used as a no-op 'EventBackend', and a pair of backends with the same 'RootSelector' can be used as a backend as well.+-}+type HasEvents m backend selector = (?e11yBackend ∷ backend, EventBackendIn m backend, selector ~ RootSelector backend)++{- | A scope containing an event of the given @field@ type.++In typical usage, @event@ will be kept as a type parameter,+to be determined at the call site by the dynamically-scoped @?e11yEvent@ parameter.++'HasEvent' can be satisfied by binding the @?e11yEvent@ [implicit parameter](https://downloads.haskell.org/ghc/latest/docs/users_guide/exts/implicit_parameters.html)+to an appropriate value. 'withEvent' handles this for you.+-}+type HasEvent event field = (?e11yEvent ∷ event field, Event event)++{- | A computational context occurring during an event of the given @field@ type.++In typical usage, @event@ will be kept as a type parameter,+to be determined at the call site by the dynamically-scoped @?e11yEvent@ parameter.++'HasEventIn' can be satisfied by binding the @?e11yEvent@ [implicit parameter](https://downloads.haskell.org/ghc/latest/docs/users_guide/exts/implicit_parameters.html)+to an appropriate value. 'withEvent' handles this for you.+-}+type HasEventIn m event field = (HasEvent event field, EventIn m event)++{- | A computational context occurring during an event of the given @field@ type, allowing+the creation of new 'Event's according to its 'SubSelector' which are children of the given+event.++In typical usage, @backend@ will be kept as a type parameter,+to be determined at the call site by the dynamically-scoped @?e11yBackend@ parameter.++'HasSubEvents' can be satisfied by binding the @?e11yEvent@ and @?e11yBackend@ [implicit parameters](https://downloads.haskell.org/ghc/latest/docs/users_guide/exts/implicit_parameters.html)+to appropriate values, the latter via v'SubEventBackend'. 'withEvent' handles this for you.+-}+type HasSubEvents m backend field = (HasEventIn m (BackendEvent backend) field, ?e11yBackend ∷ SubEventBackend backend field)++{- | A selector type with no values.++This results in an 'EventBackend' which cannot create+any 'Event's, which is useful to terminate the tree of+event types generated by 'SubSelector'+-}+type NoEventsSelector ∷ Type → Type+data NoEventsSelector f++-- | Generate a rendering function from a t'SelectorRendering' for each top-level selector.+selectorRendering+ ∷ (∀ field. selector field → SelectorRendering t field)+ → ∀ field+ . Selectors selector field+ → t field+selectorRendering getRendering (Leaf s) = (getRendering s).renderTopSelector+selectorRendering getRendering (s :/ tl) = renderSubSelector (getRendering s) tl++-- | Generate a t'SelectorRendering' for events with no sub-events.+noSubEventsSelectorRendering ∷ (SubSelector field ~ NoEventsSelector) ⇒ t field → SelectorRendering t field+noSubEventsSelectorRendering renderTopSelector =+ SelectorRendering+ { renderTopSelector+ , renderSubSelector = selectorRendering $ \case {}+ }++-- | Data needed to define a rendering of 'Selectors' of a given field type.+data SelectorRendering t field = SelectorRendering+ { renderTopSelector ∷ !(t field)+ -- ^ Handle the case where the top of the tree was selected+ , renderSubSelector ∷ !(∀ field'. Selectors (SubSelector field) field' → t field')+ -- ^ Handle a sub-event+ }++{- | An 'EventBackend' to use in the context of a running 'Event'.++It creates events selected by the 'SubSelector' of the event's @field@ type,+and any parentless events created by it are made children of the event.+-}+data SubEventBackend backend field = SubEventBackend+ { selector ∷ !(RootSelector backend field)+ -- ^ The selector of the @backend@ which 'Event's should be nested under.+ , backend ∷ !backend+ -- ^ The underlying @backend@+ , parentReference ∷ !(EventReference (BackendEvent backend))+ -- ^ A [reference](#g:relationships) to the running 'Event'+ }++newtype SubEventBackendEvent backend field = SubEventBackendEvent (BackendEvent backend field)++deriving newtype instance (EventBackend backend) ⇒ Event (SubEventBackendEvent backend)++deriving newtype instance (EventBackendIn m backend, Monad m) ⇒ EventIn m (SubEventBackendEvent backend)++{- | Create 'Event's in the parent 'EventBackend' which are children+of the running 'Event' and are selected by the 'SubSelector' of its+@field@ type.+-}+instance (EventBackend backend) ⇒ EventBackend (SubEventBackend backend field) where+ type BackendEvent (SubEventBackend backend field) = SubEventBackendEvent backend+ type RootSelector (SubEventBackend backend field) = SubSelector field++subEventParams ∷ SubEventBackend backend field → EventParams (SubSelector field) field' (EventReference (BackendEvent backend)) → EventParams (RootSelector backend) field' (EventReference (BackendEvent backend))+subEventParams backend params =+ params+ { selectors = backend.selector :/ params.selectors+ , parent = params.parent <|> Just backend.parentReference+ }++{- | Create 'Event's in the parent 'EventBackend' which are children+of the running 'Event' and are selected by the 'SubSelector' of its+@field@ type.+-}+instance (EventBackendIn m backend, ParametricFunctor m) ⇒ EventBackendIn m (SubEventBackend backend field) where+ newEvent ∷ ∀ field'. SubEventBackend backend field → EventParams (SubSelector field) field' (EventReference (BackendEvent backend)) → m (SubEventBackendEvent backend field')+ newEvent backend params =+ coerce $+ newEvent @m @backend @field'+ backend.backend+ (subEventParams backend params)+ newInstantEvent ∷ ∀ field'. SubEventBackend backend field → EventParams (SubSelector field) field' (EventReference (BackendEvent backend)) → m (EventReference (BackendEvent backend))+ newInstantEvent backend params =+ coerce $+ newInstantEvent @m @backend @field'+ backend.backend+ (subEventParams backend params)++-- | Add a [field](Observe-Event.html#g:selectorAndField) to the running 'Event'.+addEventField+ ∷ (HasEventIn m event field)+ ⇒ field+ → m ()+addEventField = addField ?e11yEvent
+ src/Observe/Event/Backend.hs view
@@ -0,0 +1,268 @@+-- Copyright 2024 Shea Levy+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+-- http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE UnicodeSyntax #-}+{-# OPTIONS_HADDOCK not-home #-}++{- |+Description : Interface for implementing EventBackends+Copyright : Copyright 2024 Shea Levy.+License : Apache-2.0+Maintainer : shea@shealevy.com++This is the primary module needed to write a new 'EventBackend' and make it an 'EventBackendIn' relevant monads.+-}+module Observe.Event.Backend+ ( -- * Defining backends+ EventBackend (..)+ , EventBackendIn (..)+ , EventParams (..)++ -- ** Defining event types+ , Event (..)+ , EventIn (..)++ -- * Selectors+ , Selectors (..)+ , SubSelector+ )+where++import Control.Exception+import Control.Monad.Trans.Class+import Control.Monad.Trans.Class.Parametric+import Control.Monad.Zip+import Data.Functor.Const+import Data.Functor.Parametric+import Data.Functor.Product+import Data.Kind+import Data.Proxy+import Observe.Event.Compat++{- | A resource allowing creation of new 'Event's.++It must be an 'EventBackendIn' some monad to be useful.+-}+class (Event (BackendEvent backend)) ⇒ EventBackend (backend ∷ Type) where+ -- | The 'Event' type this 'EventBackend' can generate.+ --+ -- 'Event's are parameterized by the type of [fields](Observe-Event.html#g:selectorAndField)+ -- they support.+ type BackendEvent backend ∷ Type → Type++ -- | The root of the [selector tree](Observe-Event.html#g:selectorAndField) this 'EventBackend' supports.+ type RootSelector backend ∷ Type → Type++-- | An 'EventBackend' which can be used in a given @m@onad+class (EventBackend backend, EventIn m (BackendEvent backend)) ⇒ EventBackendIn m backend where+ -- | Create a new 'Event' with the given @field@ type.+ --+ -- Callers must ensure the resulting 'Event' is+ -- 'finalize'd; the higher-level [event initialization functions](Observe-Event.html#g:init)+ -- take care of this for you.+ newEvent+ ∷ backend+ → EventParams (RootSelector backend) field (EventReference (BackendEvent backend))+ -- ^ Specify the event, matching the appropriate [selector](Observe-Event.html#g:selectorAndField)+ -- type for this 'EventBackend'.+ → m (BackendEvent backend field)++ -- | Create an event which has no duration.+ --+ -- Returns a reference to the event.+ newInstantEvent+ ∷ backend+ → EventParams (RootSelector backend) field (EventReference (BackendEvent backend))+ → m (EventReference (BackendEvent backend))++-- | Parameters specifying a new 'Event'+data EventParams selector field reference = EventParams+ { selectors ∷ !(Selectors selector field)+ -- ^ [Select](Observe-Event.html#g:selectorAndField) the type of the new 'Event'+ , parent ∷ !(Maybe reference)+ -- ^ A [reference](Observe-Event.html#g:relationships) to the parent of the new 'Event', if it has one.+ , causes ∷ ![reference]+ -- ^ [References](Observe-Event.html#g:relationships) to the (proximate) causes of the new 'Event', if any.+ , initialFields ∷ ![field]+ -- ^ Fields to add to the 'Event' upon initialization.+ --+ -- This is especially useful in conjunction with 'newInstantEvent'+ }++-- | An 'EventBackend' that does nothing.+instance EventBackend (Proxy (selector ∷ Type → Type)) where+ type BackendEvent (Proxy selector) = Const ()+ type RootSelector (Proxy selector) = selector++-- | An 'EventBackend' that does nothing.+instance (Monad m, ParametricFunctor m) ⇒ EventBackendIn m (Proxy (selector ∷ Type → Type)) where+ newEvent _ _ = pure $ Const ()+ newInstantEvent _ _ = pure ()++{- | Combine two 'EventBackend's.++All operations are performed sequentially, with no+exception safety between calls.+-}+instance (EventBackend b1, EventBackend b2, RootSelector b1 ~ RootSelector b2) ⇒ EventBackend (b1, b2) where+ type BackendEvent (b1, b2) = Product (BackendEvent b1) (BackendEvent b2)+ type RootSelector (b1, b2) = RootSelector b1++{- | Combine two 'EventBackend's.++All operations are performed sequentially, with no+exception safety between calls.+-}+instance (EventBackendIn m b1, EventBackendIn m b2, RootSelector b1 ~ RootSelector b2) ⇒ EventBackendIn m (b1, b2) where+ newEvent (b1, b2) args = Pair <$> newEvent b1 args1 <*> newEvent b2 args2+ where+ (args1, args2) = unwrapPairParams args+ newInstantEvent (b1, b2) args = (,) <$> newInstantEvent b1 args1 <*> newInstantEvent b2 args2+ where+ (args1, args2) = unwrapPairParams args++{- | Lift an 'EventBackend' into a 'MonadTrans'formed @m@onad.++Note that this instance is [incoherent](https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/instances.html#overlapping-instances),+so it can be overridden for your @backend@ if need be. This instance will still be used in monad-generic code, however.+-}+instance {-# INCOHERENT #-} (EventBackendIn m backend, ParametricMonadTrans t, MonadTransMonadConstraint t m) ⇒ EventBackendIn (t m) backend where+ newEvent = (lift .) . newEvent+ newInstantEvent = (lift .) . newInstantEvent++{- | A resource allowing instrumentation of code via [fields](Observe-Event.html#g:selectorAndField) of+a given type.++It must be an 'EventIn' some monad to be useful.+-}+class Event (event ∷ Type → Type) where+ -- | The type of [references](Observe-Event.html#g:relationships) to an 'Event'.+ type EventReference event ∷ Type++ -- | Get a [reference](Observe-Event.html#g:relationships) to this 'Event'+ reference ∷ event field → EventReference event++{- | An 'Event' which can be used in a given @m@onad.++Laws:++ * @finalize x >> finalize y@ = @finalize x@+-}+class (Event event, Monad m, ParametricFunctor m) ⇒ EventIn m event where+ -- | End the 'Event', perhaps due to an exception.+ --+ -- It is implementation-specific whether 'addField' after+ -- 'finalize' has any effect (but it is not an error).+ --+ -- Implementations should ensure that subsequent 'finalize'ations+ -- are no-ops.+ finalize ∷ event field → Maybe SomeException → m ()++ -- | Add a [field](Observe-Event.html#g:selectorAndField) to an 'Event'.+ addField ∷ event field → field → m ()++-- | An 'EventBackend' that does nothing.+instance Event (Const ()) where+ type EventReference (Const ()) = ()+ reference _ = ()++-- | An 'EventBackend' that does nothing.+instance (Monad m, ParametricFunctor m) ⇒ EventIn m (Const ()) where+ finalize _ _ = pure ()+ addField _ _ = pure ()++{- | Combine two 'EventBackend's.++All operations are performed sequentially, with no+exception safety between calls.+-}+instance (Event e1, Event e2) ⇒ Event (Product e1 e2) where+ type EventReference (Product e1 e2) = (EventReference e1, EventReference e2)+ reference (Pair e1 e2) = (reference e1, reference e2)++{- | Combine two 'EventBackend's.++All operations are performed sequentially, with no+exception safety between calls.+-}+instance (EventIn m e1, EventIn m e2) ⇒ EventIn m (Product e1 e2) where+ finalize (Pair e1 e2) err = finalize e1 err >> finalize e2 err+ addField (Pair e1 e2) f = addField e1 f >> addField e2 f++unwrapPairParams ∷ EventParams selector field (r1, r2) → (EventParams selector field r1, EventParams selector field r2)+unwrapPairParams params =+ ( params{parent = parent1, causes = causes1}+ , params{parent = parent2, causes = causes2}+ )+ where+ (parent1, parent2) = munzip params.parent+ (causes1, causes2) = munzip params.causes++{- | Lift an 'Event' into a 'MonadTrans'formed @m@onad.++Note that this instance is [incoherent](https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/instances.html#overlapping-instances),+so it can be overridden for your @event@ type if need be. This instance will still be used in monad-generic code, however.+-}+instance {-# INCOHERENT #-} (EventIn m event, ParametricMonadTrans t, MonadTransMonadConstraint t m) ⇒ EventIn (t m) event where+ finalize = (lift .) . finalize+ addField = (lift .) . addField++-- * Selectors++{- | A nested sequence of selectors, starting from a+given root @selector@ family and ending in a selector+selecting a given @field@ type.++For example, given:++> data FooSelector :: Type -> Type where Foo :: FooSelector FooField+> data FooField+> type instance SubSelector FooField = BarSelector+> data BarSelector :: Type -> Type where Bar :: BarSelector BarField+> data BarField+> type instance SubSelector BarField = NoEventsSelector++Then @Leaf Foo@ is a sequence 'Selectors' picking out an 'Event' with field+type @FooField@, and @Foo :\/ Leaf Bar@ is a sequence of 'Selectors' picking out+an 'Event' with field type @BarField@ underneath an 'Event' with field type @FooField@.++See the [selector and field documentation](Observe-Event.html#g:selectorAndField) for more details.+-}+data Selectors selector field where+ Leaf ∷ selector field → Selectors selector field+ (:/) ∷ selector field → Selectors (SubSelector field) field' → Selectors selector field'++infixr 5 :/++{- | The [selector](Observe-Event.html#g:selectorAndField) type for sub-'Event's underneath+an 'Event' of the given @field@ type.++Instrumented code will typically involve nested scopes of events, including calls across+different modules, with different types of events expected in different contexts. To support+this, each field type has an associated 'SubSelector' type to identify the kind of events+that can occur in the scope where the event is active. This results in a tree of event+types represented by a tree of selectors, reflecting the tree of instrumented source+components: Each selector of the root selector type specifies a field type, which in turn+specifies yet another selector (and, with it, its sub-tree). Use cases which require picking+out a linear path through this tree can use 'Selectors'.++If there are no sub-'Event's under 'Event's with field type @f@, then you can use+ t'Observe.Event.NoEventsSelector': @type instance SubSelector f = NoEventsSelector@.++If you want to retain the set of possible event types as in the parent scope, simply set+'SubSelector' to the very same selector type that the parent selector came from.+-}+type family SubSelector field ∷ Type → Type
+ src/Observe/Event/Backend/Data.hs view
@@ -0,0 +1,188 @@+-- Copyright 2024 Shea Levy+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+-- http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UnicodeSyntax #-}+{-# OPTIONS_HADDOCK not-home #-}++{- |+Description : Consuming events as data+Copyright : Copyright 2024 Shea Levy.+License : Apache-2.0+Maintainer : shea@shealevy.com++This module provides the t'DataEventBackend' 'EventBackend' for consuming events+by representing them as ordinary Haskell data.+-}+module Observe.Event.Backend.Data+ ( newDataEventBackend+ , getEvents+ , DataEvent (..)+ , Selectors (..)+ , DataEventBackend+ )+where++import Control.Exception+import Control.Monad.Primitive+import Data.Coerce+import Data.Functor.Parametric+import Data.Primitive.MutVar+import Data.Sequence as Seq+import Observe.Event.Backend++{- | An 'EventBackend' for consuming events by representing them as+ordinary Haskell data.++Create a new one with 'newDataEventBackend'. Get the event data with 'getEvents'.+-}+newtype DataEventBackend m selector = DataEventBackend (MutVar (PrimState m) (Seq (MutVar (PrimState m) (Maybe (PendingDataEvent selector)))))++-- | Allocate a new t'DataEventBackend'+newDataEventBackend ∷ ∀ m selector. (PrimMonad m, ParametricFunctor m) ⇒ m (DataEventBackend m selector)+newDataEventBackend = coerce $ newMutVar @m (empty @(MutVar (PrimState m) (Maybe (PendingDataEvent selector))))++{- | Read the events that have been emitted using the t'DataEventBackend'++A 'Nothing' indicates an event that hasn't been 'finalize'd.+-}+getEvents+ ∷ (PrimMonad m)+ ⇒ DataEventBackend m selector+ → m (Seq (Maybe (DataEvent selector)))+getEvents eb = do+ pendingEvVars ← readMutVar $ coerce eb+ pendingEvs ← traverse readMutVar pendingEvVars+ let+ res = unPend <$> pendingEvs+ find n = case index res n of+ Just ev → Right ev+ Nothing → Left n+ unPend (Just ev@(PendingDataEvent _ selectors _ _ _ fields _)) =+ Just $+ DataEvent+ { idx = ev.reference+ , parent = find <$> ev.parent+ , causes = find <$> ev.causes+ , selectors+ , err = ev.err+ , fields+ , instant = ev.instant+ }+ unPend Nothing = Nothing+ pure res++-- | A representation of an event.+data DataEvent selector = ∀ f.+ DataEvent+ { idx ∷ !Int+ -- ^ This event's index in the sequence of event creations.+ , selectors ∷ !(Selectors selector f)+ -- ^ The [selector](Observe-Event.html#g:selectorAndField) used to initialize the event+ , parent ∷ !(Maybe (Either Int (DataEvent selector)))+ -- ^ The [parent](Observe-Event.html#g:relationships) of this t'DataEvent', if any.+ --+ -- @Left n@ means the parent was the n'th event but wasn't 'finalize'd.+ , causes ∷ ![Either Int (DataEvent selector)]+ -- ^ The [causes](Observe-Event.html#g:relationships) of this t'DataEvent'.+ --+ -- @Left n@ means the cause was the n'th event but wasn't 'finalize'd.+ , err ∷ !(Maybe SomeException)+ -- ^ The error which ended the event, if any+ , fields ∷ !(Seq f)+ -- ^ The fields which were added to the event+ , instant ∷ !Bool+ -- ^ Whether the event was emitted instantly.+ }++-- | An in-progress representation of an event.+data PendingDataEvent selector = ∀ f.+ PendingDataEvent+ { reference ∷ !Int+ , selectors ∷ !(Selectors selector f)+ , parent ∷ !(Maybe Int)+ , causes ∷ ![Int]+ , err ∷ !(Maybe SomeException)+ , fields ∷ !(Seq f)+ , instant ∷ !Bool+ }++-- | The 'Event' associated with t'DataEventBackend'.+data DataEventBackendEvent m selector f = DataEventBackendEvent+ { reference ∷ !Int+ , cell ∷ !(MutVar (PrimState m) (Maybe (PendingDataEvent selector)))+ , params ∷ !(EventParams selector f Int)+ , fields ∷ !(MutVar (PrimState m) (Seq f))+ }++-- | Consume events by representing them as ordinary Haskell data.+instance Event (DataEventBackendEvent m selector) where+ type EventReference (DataEventBackendEvent m selector) = Int+ reference ev = ev.reference++-- | Consume events by representing them as ordinary Haskell data.+instance (PrimMonad m, ParametricFunctor m) ⇒ EventIn m (DataEventBackendEvent m selector) where+ finalize ev err = do+ fields ← readMutVar ev.fields+ let+ modify ∷ Maybe (PendingDataEvent selector) → (Maybe (PendingDataEvent selector), ())+ modify Nothing =+ ( Just $+ PendingDataEvent+ { reference = ev.reference+ , selectors = ev.params.selectors+ , parent = ev.params.parent+ , causes = ev.params.causes+ , err+ , fields+ , instant = False+ }+ , ()+ )+ modify n = (n, ())+ atomicModifyMutVar' ev.cell modify+ addField ev f =+ atomicModifyMutVar' ev.fields $ \fs → (fs |> f, ())++-- | Consume events by representing them as ordinary Haskell data.+instance EventBackend (DataEventBackend m selector) where+ type BackendEvent (DataEventBackend m selector) = DataEventBackendEvent m selector+ type RootSelector (DataEventBackend m selector) = selector++newCell ∷ (PrimMonad m) ⇒ DataEventBackend m selector → m (MutVar (PrimState m) (Maybe (PendingDataEvent selector)), Int)+newCell eb = do+ cell ← newMutVar Nothing+ ref ← atomicModifyMutVar' (coerce eb) (\evs → (evs |> cell, Seq.length evs))+ pure (cell, ref)++-- | Consume events by representing them as ordinary Haskell data.+instance (PrimMonad m, ParametricFunctor m) ⇒ EventBackendIn m (DataEventBackend m selector) where+ newEvent eb params = do+ (cell, ref) ← newCell eb+ fields ← newMutVar $ Seq.fromList params.initialFields+ pure DataEventBackendEvent{fields, reference = ref, params, cell}+ newInstantEvent eb params = do+ (cell, ref) ← newCell eb+ writeMutVar cell . Just $+ PendingDataEvent+ { reference = ref+ , selectors = params.selectors+ , parent = params.parent+ , causes = params.causes+ , err = Nothing+ , fields = Seq.fromList params.initialFields+ , instant = True+ }+ pure ref
+ test/Test.hs view
@@ -0,0 +1,440 @@+-- Copyright 2024 Shea Levy+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+-- http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE UnicodeSyntax #-}+{-# LANGUAGE NoFieldSelectors #-}+{-# OPTIONS_GHC -Wno-orphans #-}++module Main where++import Control.Exception+import Control.Monad.Catch.Pure (CatchT (..))+import Control.Monad.Catch.Pure qualified as Catch+import Control.Monad.ST+import Control.Monad.StrictIdentity+import Control.Monad.Trans.Class+import Control.Monad.With+import Data.Coerce+import Data.Either+import Data.Foldable+import Data.Functor.Identity+import Data.GeneralAllocate+import Data.Kind+import Data.Maybe+import Data.Proxy+import Data.Sequence+import Observe.Event+import Observe.Event.Backend.Data+import Test.Syd++deriving via WithNoContinuation StrictIdentity instance MonadWith StrictIdentity++data TestSelector ∷ Type → Type where+ Test ∷ TestSelector TestField++data TestField = TestField deriving (Eq, Show)++type instance SubSelector TestField = SubTestSelector++data SubTestSelector ∷ Type → Type where+ SubTest ∷ SubTestSelector SubTestField++data SubTestField = SubTestField deriving (Eq, Show)++type instance SubSelector SubTestField = NoEventsSelector++newtype EqSomeException = EqSomeException SomeException deriving newtype (Show)++instance Eq EqSomeException where+ EqSomeException e1 == EqSomeException e2 = show e1 == show e2++data DataEventTestSelectorFields+ = DataEventTestSelectorTestFields [TestField]+ | DataEventTestSelectorSubTestFields [SubTestField]+ deriving (Eq, Show)++data DataEventTestSelectorSelector+ = DataEventTestSelectorTest+ | DataEventTestSelectorTestSubTest+ deriving (Eq, Show)++data DataEventTestSelector = DataEventTestSelector+ { idx ∷ !Int+ , selector ∷ !DataEventTestSelectorSelector+ , parent ∷ !(Maybe (Either Int DataEventTestSelector))+ , causes ∷ ![Either Int DataEventTestSelector]+ , err ∷ !(Maybe EqSomeException)+ , fields ∷ !DataEventTestSelectorFields+ , instant ∷ !Bool+ }+ deriving (Eq, Show)++convDataEventTestSelector ∷ DataEvent TestSelector → DataEventTestSelector+convDataEventTestSelector ev@(DataEvent _ selectors _ _ _ fields _) =+ DataEventTestSelector+ { idx = ev.idx+ , parent = fmap convDataEventTestSelector <$> ev.parent+ , causes = fmap convDataEventTestSelector <$> ev.causes+ , err = coerce ev.err+ , fields = fields'+ , selector+ , instant = ev.instant+ }+ where+ (fields', selector) = case selectors of+ Leaf Test → (DataEventTestSelectorTestFields (toList fields), DataEventTestSelectorTest)+ Test :/ Leaf SubTest → (DataEventTestSelectorSubTestFields (toList fields), DataEventTestSelectorTestSubTest)+ Test :/ SubTest :/ Leaf impossible → case impossible of {}+ Test :/ SubTest :/ impossible :/ _ → case impossible of {}++newtype TestException = TestException Int deriving (Show)++instance Exception TestException++data ParentSelector field where+ ParentA ∷ ParentSelector AField+ ParentB ∷ ParentSelector BField++newtype AField = AField Int deriving (Eq)++type instance SubSelector AField = NoEventsSelector++data BField = BYes | BNo deriving (Eq)++type instance SubSelector BField = ChildSelector++data ChildSelector field where+ Child ∷ ChildSelector CField++data CField = CField deriving (Eq)++type instance SubSelector CField = NoEventsSelector++data SomeSelectors = ∀ field. (Eq field) ⇒ SomeSelectors (Selectors ParentSelector field)++main ∷ IO ()+main = sydTest $ do+ describe "withEvent" $ do+ it "creates the event" $+ let+ m_ev = runST $ do+ be ← newDataEventBackend+ let+ ?e11yBackend = be+ idx ← withEvent Test $ do+ pure eventReference+ evs ← (fmap convDataEventTestSelector <$>) <$> getEvents be+ pure $ index evs idx+ in+ shouldSatisfyNamed m_ev "was finalized and selected with the Test selector" (maybe False (\ev → ev.selector == DataEventTestSelectorTest))++ it "sets the backend to accept sub-selectors in the inner scope" $+ let+ m_ev = runST $ do+ be ← newDataEventBackend+ let+ ?e11yBackend = be+ idx ← withEvent Test $ do+ withEvent SubTest $ do+ addEventField SubTestField+ pure eventReference+ evs ← (fmap convDataEventTestSelector <$>) <$> getEvents be+ pure $ index evs idx+ in+ shouldSatisfyNamed m_ev "was finalized and selected with the SubTest selector" (maybe False (\ev → ev.selector == DataEventTestSelectorTestSubTest))++ it "sets the backend to create child events" $+ let+ m_evs = runST $ do+ be ← newDataEventBackend+ let+ ?e11yBackend = be+ (parentIdx, childIdx) ← withEvent Test $ do+ let parentIdx = eventReference+ withEvent SubTest $ do+ pure (parentIdx, eventReference)+ evs ← (fmap convDataEventTestSelector <$>) <$> getEvents be+ pure (index evs parentIdx, index evs childIdx)+ in+ case m_evs of+ (Just parent, Just child) →+ shouldSatisfyNamed+ child+ "is a child of the parent"+ (\child' → child'.parent == Just (Right parent))+ (Nothing, _) → expectationFailure "Parent event was not finalized"+ (_, Nothing) → expectationFailure "Child event was not finalized"++ it "records and propagates exceptions" $+ let+ m_m_ev = runST $ do+ be ← newDataEventBackend+ let+ ?e11yBackend = be+ e_res ← runCatchT $ withEvent Test $ do+ Catch.throwM $ TestException eventReference+ case e_res of+ Left e → case fromException e of+ Just (TestException idx) → do+ evs ← (fmap convDataEventTestSelector <$>) <$> getEvents be+ pure . Just $ index evs idx+ Nothing → pure Nothing+ _ → pure Nothing+ in+ case m_m_ev of+ Nothing → expectationFailure "TestException not thrown"+ Just m_ev →+ shouldSatisfyNamed+ m_ev+ "was finalized with a TestException"+ (maybe False (\ev → ev.err == (Just . EqSomeException . SomeException $ TestException ev.idx)))++ describe "the MonadTrans EventBackendIn instance" $+ it "lifts the EventBackend instance through a transformer" $+ runST $ do+ be ← newDataEventBackend @_ @TestSelector+ let+ ?e11yBackend = be+ e_res ← runCatchT $ withEvent Test $ do+ addEventField TestField+ subRef ← instantEvent SubTest []+ evs ← (fmap convDataEventTestSelector <$>) <$> lift (getEvents be)+ pure $ case index evs subRef of+ Nothing → False+ Just ev → ev.fields == DataEventTestSelectorSubTestFields []++ pure $ fromRight False e_res++ describe "finalizeEvent" $+ it "finalizes the event" $+ let+ m_ev = runST $ do+ be ← newDataEventBackend+ let+ ?e11yBackend = be+ idx ← withEvent Test $ do+ finalizeEvent $ Just (SomeException $ TestException 0)+ pure eventReference+ evs ← (fmap convDataEventTestSelector <$>) <$> getEvents be+ pure $ index evs idx+ in+ shouldSatisfyNamed+ m_ev+ "was finalized with a manual exception"+ (maybe False (\ev → ev.err == (Just . EqSomeException $ SomeException $ TestException 0)))++ describe "addEventField" $+ it "adds a field to the event" $+ let+ m_ev = runST $ do+ be ← newDataEventBackend+ let+ ?e11yBackend = be+ idx ← withEvent Test $ do+ addEventField TestField+ pure eventReference+ evs ← (fmap convDataEventTestSelector <$>) <$> getEvents be+ pure $ index evs idx+ in+ shouldSatisfyNamed+ m_ev+ "was finalized and has a TestField field"+ (maybe False (\ev → ev.fields == DataEventTestSelectorTestFields [TestField]))+ describe "DataEventBackend" $ do+ it "captures the first event finalization" $+ let+ m_ev = runST $ do+ be ← newDataEventBackend+ let ?e11yBackend = be+ idx ← withEvent Test $ do+ finalizeEvent Nothing+ finalizeEvent $ Just (SomeException $ TestException 0)+ pure eventReference+ evs ← (fmap convDataEventTestSelector <$>) <$> getEvents be+ pure $ index evs idx+ in+ shouldSatisfyNamed+ m_ev+ "was finalized without error"+ (maybe False (\ev → isNothing ev.err))++ it "emits incomplete events as Nothing" $+ let+ -- The parentIdx type annotation is needed because its+ -- type inside the block is EventReference (DataEventBackend (ST s) TestSelector.+ -- s cannot escape from runST, and even though that type is always Int regardless+ -- of s GHC doesn't know that.++ -- The m_ev type annotation is needed because of https://gitlab.haskell.org/ghc/ghc/-/issues/24333+ (parentIdx ∷ Int, m_ev ∷ Maybe DataEventTestSelector) = runST $ do+ be ← newDataEventBackend+ let ?e11yBackend = be+ withEvent Test $ do+ let parentIdx' = eventReference+ withEvent SubTest $ do+ finalizeEvent Nothing+ evs ← (fmap convDataEventTestSelector <$>) <$> getEvents be+ pure (parentIdx', index evs eventReference)+ in+ case m_ev of+ Nothing → expectationFailure "child event not finalized"+ Just ev →+ shouldSatisfyNamed+ ev+ "parent is unknown"+ (\ev' → ev'.parent == Just (Left parentIdx))++ describe "withRelatedEvent" $+ it "sets specified causes" $+ let+ m_cause_effect = runST $ do+ be ← newDataEventBackend+ let ?e11yBackend = be+ (causeIdx, effectIdx) ← do+ withEvent Test $ do+ let causeIdx = eventReference+ withRelatedEvent SubTest Nothing [causeIdx] $ do+ pure (causeIdx, eventReference)+ evs ← (fmap convDataEventTestSelector <$>) <$> getEvents be+ pure (index evs causeIdx, index evs effectIdx)+ in+ case m_cause_effect of+ (Just cause, Just effect) →+ shouldSatisfyNamed+ (cause, effect)+ "fst causes snd"+ (\(cause', effect') → effect'.causes == [Right cause'])+ (Nothing, _) → expectationFailure "cause not finalized"+ (_, Nothing) → expectationFailure "effect not finalized"++ describe "instantEvent" $+ it "emits an event" $+ let+ m_ev = runST $ do+ be ← newDataEventBackend+ let ?e11yBackend = be+ idx ← instantEvent Test [TestField]+ evs ← (fmap convDataEventTestSelector <$>) <$> getEvents be+ pure $ index evs idx+ in+ case m_ev of+ Nothing → expectationFailure "event not finalized"+ Just ev →+ shouldSatisfyNamed+ ev+ "is instant has a TestField field"+ (\ev' → ev'.instant && ev'.fields == DataEventTestSelectorTestFields [TestField])++ describe "the no-op EventBackend instance for Proxy" $+ it "does nothing successfully" $+ runStrictIdentity $ do+ let ?e11yBackend = Proxy @TestSelector+ () ← withEvent Test $ do+ addEventField TestField+ let !_ = eventReference+ finalizeEvent Nothing+ instantEvent SubTest [SubTestField]+ pure True++ describe "the backend-combining EventBackend instance for (,)" $+ it "sequentially calls both backends" $+ let+ (evs1, evs2, idx1s ∷ (Int, Int), idx2s ∷ (Int, Int)) = runST $ do+ be1 ← newDataEventBackend+ be2 ← newDataEventBackend+ let ?e11yBackend = (be1, be2)+ (idx1, idx2) ← withEvent Test $ do+ addEventField TestField+ let idx1 = eventReference+ idx2 ← instantEvent SubTest [SubTestField]+ finalizeEvent Nothing+ pure (idx1, idx2)+ (,,idx1,idx2)+ <$> ((fmap convDataEventTestSelector <$>) <$> getEvents be1)+ <*> ((fmap convDataEventTestSelector <$>) <$> getEvents be2)+ (idx11, idx12) = idx1s+ (idx21, idx22) = idx2s+ expectedEv1 =+ DataEventTestSelector+ { idx = 0+ , selector = DataEventTestSelectorTest+ , parent = Nothing+ , causes = []+ , err = Nothing+ , fields = DataEventTestSelectorTestFields [TestField]+ , instant = False+ }+ expectedEv2 =+ DataEventTestSelector+ { idx = 1+ , selector = DataEventTestSelectorTestSubTest+ , parent = Just (Right expectedEv1)+ , causes = []+ , err = Nothing+ , fields = DataEventTestSelectorSubTestFields [SubTestField]+ , instant = True+ }+ in+ do+ shouldBe idx11 idx12+ shouldBe idx21 idx22+ evs ←+ if evs1 == evs2+ then pure evs1+ else expectationFailure "event lists don't match"+ shouldBe evs $ fromList [Just expectedEv1, Just expectedEv2]+ describe "selectorRendering" $+ it "matches a manual definition" $+ let+ possibleSelectors =+ [ SomeSelectors (Leaf ParentA)+ , SomeSelectors (Leaf ParentB)+ , SomeSelectors (ParentB :/ Leaf Child)+ ]+ manual ∷ Selectors ParentSelector field → field+ manual (Leaf ParentA) = AField 0+ manual (ParentA :/ Leaf impossible) = case impossible of {}+ manual (ParentA :/ impossible :/ _) = case impossible of {}+ manual (Leaf ParentB) = BYes+ manual (ParentB :/ Leaf Child) = CField+ manual (ParentB :/ Child :/ Leaf impossible) = case impossible of {}+ manual (ParentB :/ Child :/ impossible :/ _) = case impossible of {}++ usingSelectorRendering ∷ Selectors ParentSelector field → field+ usingSelectorRendering =+ runIdentity+ . selectorRendering+ ( \case+ ParentA → noSubEventsSelectorRendering (Identity $ AField 0)+ ParentB →+ SelectorRendering+ { renderTopSelector = Identity BYes+ , renderSubSelector = renderChildSelector+ }+ )+ renderChildSelector ∷ Selectors ChildSelector field → Identity field+ renderChildSelector = selectorRendering $ \Child →+ noSubEventsSelectorRendering $ Identity CField++ predicate ∷ SomeSelectors → Bool+ predicate (SomeSelectors sel) = manual sel == usingSelectorRendering sel+ in+ all predicate possibleSelectors