eventuo11y-json 0.1.0.0 → 0.2.0.0
raw patch · 5 files changed
+83/−57 lines, 5 filesdep −th-compatdep ~aesondep ~basedep ~eventuo11yPVP ok
version bump matches the API change (PVP)
Dependencies removed: th-compat
Dependency ranges changed: aeson, base, eventuo11y, eventuo11y-dsl, template-haskell, text, time
API changes (from Hackage documentation)
+ Observe.Event.Render.JSON.Handle: newJSONEvent :: Exception stex => (Object -> IO ()) -> RenderExJSON stex -> RenderFieldJSON f -> IO (Event IO JSONRef f)
- Observe.Event.Dynamic: type DynamicEvent m r = Event m r DynamicEventSelector DynamicField
+ Observe.Event.Dynamic: type DynamicEvent m r = Event m r DynamicField
Files
- CHANGELOG.md +6/−0
- eventuo11y-json.cabal +8/−9
- src/Observe/Event/Dynamic.hs +2/−1
- src/Observe/Event/Render/JSON/DSL/Compile.hs +9/−2
- src/Observe/Event/Render/JSON/Handle.hs +58/−45
CHANGELOG.md view
@@ -1,5 +1,11 @@ # Revision history for eventuo11y-json +## 0.2.0.0 -- 2022-12-23++- Update for eventuo11y 0.6+- Update for 'AnyQuote' change in 'eventuo11y-dsl' version '0.2'+- Export duration on rendered events+ ## 0.1.0.0 -- 2022-10-23 Initial release
eventuo11y-json.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: eventuo11y-json-version: 0.1.0.0+version: 0.2.0.0 synopsis: aeson-based rendering for eventuo11y description: Render [eventuo11y](https://hackage.haskell.org/package/eventuo11y) 'Observe.Event.Event's@@ -39,15 +39,14 @@ Observe.Event.Render.JSON.Handle build-depends:- , base ^>= { 4.14, 4.16 }- , aeson ^>= 2.0+ , base ^>= { 4.14, 4.16, 4.17 }+ , aeson ^>= { 2.0, 2.1 } , bytestring ^>= { 0.10, 0.11 }- , eventuo11y ^>= 0.5.0.0- , eventuo11y-dsl ^>= 0.1.0.0- , template-haskell ^>= { 2.16, 2.18 }- , text ^>= 1.2- , th-compat ^>= 0.1.4- , time ^>= { 1.9, 1.11 }+ , eventuo11y ^>= 0.6+ , eventuo11y-dsl ^>= 0.2+ , template-haskell ^>= { 2.16, 2.18, 2.19 }+ , text ^>= { 1.2, 2.0 }+ , time ^>= { 1.9, 1.11, 1.12 } , uuid ^>= 1.3 hs-source-dirs: src
src/Observe/Event/Dynamic.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeOperators #-} -- | -- Description : "Dynamically typed" Event selectors and fields.@@ -58,4 +59,4 @@ type DynamicEventBackend m r = EventBackend m r DynamicEventSelector -- | Shorthand for an 'Event' using 'DynamicField's.-type DynamicEvent m r = Event m r DynamicEventSelector DynamicField+type DynamicEvent m r = Event m r DynamicField
src/Observe/Event/Render/JSON/DSL/Compile.hs view
@@ -1,5 +1,9 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskellQuotes #-}+#if ! MIN_VERSION_template_haskell(2,18,0)+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE TypeFamilies #-}+#endif -- | -- Description : Compile the "Observe.Event.DSL" and generate "Observe.Event.Render.JSON" instances@@ -11,11 +15,14 @@ import Data.Aeson import GHC.Exts import Language.Haskell.TH-import Language.Haskell.TH.Syntax.Compat as THC import Observe.Event.DSL import qualified Observe.Event.DSL.Compile as DSL import Observe.Event.Render.JSON +#if ! MIN_VERSION_template_haskell(2,18,0)+type Quote m = m ~ Q+#endif+ conPCompat :: Name -> [Pat] -> Pat #if MIN_VERSION_template_haskell(2,18,0) conPCompat n ps = ConP n [] ps@@ -27,7 +34,7 @@ -- -- Assumes leaf types (i.e., those in 'SimpleType' or a 'FieldConstructorSpec') are 'ToJSON', and -- that 'Inject'ed selectors have a 'DefaultRenderSelectorJSON' instance.-compile :: (THC.Quote m) => SelectorSpec -> m [Dec]+compile :: (Quote m) => SelectorSpec -> m [Dec] compile s@(SelectorSpec selectorNameBase selectors) = do -- Walks the selectors twice, will fix when SelectorSpec is extensible (e.g. recursion-schemes) baseDecs <- DSL.compile s
src/Observe/Event/Render/JSON/Handle.hs view
@@ -1,6 +1,7 @@ {-# LANGUAGE BlockArguments #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeApplications #-}@@ -16,6 +17,7 @@ -- * Internals JSONRef (..),+ newJSONEvent, ) where @@ -40,6 +42,60 @@ -- using this one. newtype JSONRef = JSONRef UUID deriving newtype (ToJSON) +-- | Create a new 'Event' in a 'jsonHandleBackend'.+newJSONEvent ::+ (Exception stex) =>+ -- | Emit the final 'Object'. This will be called at most once.+ (Object -> IO ()) ->+ RenderExJSON stex ->+ RenderFieldJSON f ->+ IO (Event IO JSONRef f)+newJSONEvent emit renderEx renderField = do+ eventRef <- coerce nextRandom+ start <- getCurrentTime+ fieldsRef <- newIORef mempty+ parentsRef <- newIORef mempty+ proximatesRef <- newIORef mempty+ finishOnce <- newEmptyMVar+ let finish r =+ tryPutMVar finishOnce () >>= \case+ False -> pure ()+ True -> do+ end <- getCurrentTime+ fields <- readIORef fieldsRef+ parents <- readIORef parentsRef+ proximates <- readIORef proximatesRef+ emit+ ( "event-id" .= eventRef+ <> "start" .= start+ <> "end" .= end+ <> "duration" .= diffUTCTime end start+ <> ifNotNull "fields" fields+ <> ifNotNull "parents" parents+ <> ifNotNull "proximate-causes" proximates+ <> case r of+ StructuredFail e -> "structured-exception" .= renderEx e+ UnstructuredFail e -> "unstructured-exception" .= show e+ Finalized -> mempty+ )+ pure $+ Event+ { reference = eventRef,+ addField = \field ->+ atomicModifyIORef' fieldsRef \fields ->+ (uncurry insert (renderField field) fields, ()),+ addReference = \(Reference ty r) ->+ let refsRef = case ty of+ Parent -> parentsRef+ Proximate -> proximatesRef+ in atomicModifyIORef' refsRef \refs -> (r : refs, ()),+ finalize = \me -> finish $ case me of+ Just e -> case fromException e of+ Just se -> StructuredFail se+ Nothing -> UnstructuredFail e+ Nothing -> Finalized+ }+ -- | An 'EventBackend' which posts events to a given 'Handle' as JSON. -- -- Each 'Event' is posted as a single line, as it's completed. As a result, child events@@ -65,52 +121,9 @@ hPutStrLn h $ encode o pure $ EventBackend- { newEventImpl = \sel -> do+ { newEvent = \sel -> do let (k, renderField) = renderSel sel- eventRef <- coerce nextRandom- start <- getCurrentTime- fieldsRef <- newIORef mempty- parentsRef <- newIORef mempty- proximatesRef <- newIORef mempty- let finish r = do- end <- getCurrentTime- fields <- readIORef fieldsRef- parents <- readIORef parentsRef- proximates <- readIORef proximatesRef- emit- ( k- .= Object- ( "event-id" .= eventRef- <> "start" .= start- <> "end" .= end- <> ifNotNull "fields" fields- <> ifNotNull "parents" parents- <> ifNotNull "proximate-causes" proximates- <> case r of- StructuredFail e -> "structured-exception" .= renderEx e- UnstructuredFail e -> "unstructured-exception" .= show e- Finalized -> mempty- )- )- pure $- EventImpl- { referenceImpl = eventRef,- addFieldImpl = \field ->- atomicModifyIORef' fieldsRef \fields ->- (uncurry insert (renderField field) fields, ()),- addParentImpl = \r ->- atomicModifyIORef' parentsRef \refs -> (r : refs, ()),- addProximateImpl = \r ->- atomicModifyIORef' proximatesRef \refs -> (r : refs, ()),- finalizeImpl = finish Finalized,- failImpl = \e ->- finish- ( case fromException e of- Just se -> StructuredFail se- Nothing -> UnstructuredFail e- )- },- newOnceFlag = newOnceFlagMVar+ newJSONEvent (emit . (k .=)) renderEx renderField } -- | An 'EventBackend' which posts events to @stderr@ as JSON.