diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for e11y + +## 0.1.0.0 -- 2024-01-16 + +* Initial release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/compat/new/Observe/Event/Compat.hs b/compat/new/Observe/Event/Compat.hs new file mode 100644 --- /dev/null +++ b/compat/new/Observe/Event/Compat.hs @@ -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 diff --git a/compat/old/Observe/Event/Compat.hs b/compat/old/Observe/Event/Compat.hs new file mode 100644 --- /dev/null +++ b/compat/old/Observe/Event/Compat.hs @@ -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)) diff --git a/e11y.cabal b/e11y.cabal new file mode 100644 --- /dev/null +++ b/e11y.cabal @@ -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 diff --git a/src/Observe/Event.hs b/src/Observe/Event.hs new file mode 100644 --- /dev/null +++ b/src/Observe/Event.hs @@ -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 diff --git a/src/Observe/Event/Backend.hs b/src/Observe/Event/Backend.hs new file mode 100644 --- /dev/null +++ b/src/Observe/Event/Backend.hs @@ -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 diff --git a/src/Observe/Event/Backend/Data.hs b/src/Observe/Event/Backend/Data.hs new file mode 100644 --- /dev/null +++ b/src/Observe/Event/Backend/Data.hs @@ -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 diff --git a/test/Test.hs b/test/Test.hs new file mode 100644 --- /dev/null +++ b/test/Test.hs @@ -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