knit-haskell 0.7.0.0 → 0.8.0.0

raw patch · 28 files changed

+3227/−344 lines, 28 filesdep +cerealdep +doctemplatesdep +exceptionsdep −logging-effectdep ~basedep ~base64-bytestringdep ~blaze-colonnadePVP ok

version bump matches the API change (PVP)

Dependencies added: cereal, doctemplates, exceptions, monad-control, say, stm, store, streamly, streamly-bytestring, transformers-base

Dependencies removed: logging-effect

Dependency ranges changed: base, base64-bytestring, blaze-colonnade, blaze-html, bytestring, case-insensitive, constraints, containers, here, http-client, http-client-tls, http-types, hvega, network, network-uri, pandoc, plots, polysemy, polysemy-plugin, polysemy-zoo, prettyprinter, random, random-fu, random-source, text

API changes (from Hackage documentation)

Files

• ChangeLog.md +29/−0
• Readme.md +225/−14
• examples/AsyncExample.hs +139/−0
• examples/CacheExample.hs +186/−0
• examples/CacheExample2.hs +209/−0
• examples/ErrorExample.hs +7/−5
• examples/MtlExample.hs +7/−1
• examples/MultiDocExample.hs +7/−1
• examples/RandomExample.hs +9/−3
• examples/SimpleExample.hs +10/−7
• knit-haskell.cabal +99/−25
• src/Knit/Effect/AtomicCache.hs +767/−0
• src/Knit/Effect/Docs.hs +1/−3
• src/Knit/Effect/Logger.hs +130/−60
• src/Knit/Effect/Pandoc.hs +10/−10
• src/Knit/Effect/PandocMonad.hs +197/−46
• src/Knit/Effect/Serialize.hs +193/−0
• src/Knit/Effect/UnusedId.hs +3/−0
• src/Knit/Report.hs +36/−149
• src/Knit/Report/Cache.hs +315/−0
• src/Knit/Report/EffectStack.hs +294/−0
• src/Knit/Report/Error.hs +74/−0
• src/Knit/Report/Input/Visualization/Diagrams.hs +4/−3
• src/Knit/Report/Other/Blaze.hs +0/−1
• src/Knit/Report/Other/Lucid.hs +0/−1
• src/Knit/Report/Output/Html.hs +75/−15
• src/Knit/Utilities/Streamly.hs +72/−0
• src/Streamly/External/Cereal.hs +129/−0

@@ -1,3 +1,32 @@+v0.8.0.0+* BREAKING: moved config arguments to ```knit-html``` and ```knit-htmls``` into a data structure ```KnitConfig```.  This breaks+all existing uses of those functions but is designed to future-proof against additions to the knit configuration.  A breaking+change was more-or-less necessitated by the addition of a cache directory parameter for the persistent caching effect. See below.++* New persistent caching effect.  Anything which has an instance of ```Serialize``` (from the cereal package) may be cached,+in memory and backed by a disk-based cache (cache effect will attempt to create +directories as required).  When knit-html(s) is next run, the cached version can be used in +place of running an expensive computation. This comes with some built-in dependency management, via modification times of the+files in cache or user-provided time for dependencies on non-cached assets. For more information, +see the [Readme](https://github.com/adamConnerSax/knit-haskell/blob/master/Readme.md).+For an example, see examples/CacheExample.hs.++* Added Async into knit-haskell effects.  For an example, see examples/AsyncExample.hs.++* Logging changes:++1. Added a ```Debug Int``` level below ```Diagnostic``` with an integer argument to allow various and unlimited debug levels+2. Changed the previous ```[LogSeverity]``` argument given to run functions to ```(LogSeverity -> Bool)``` +to accomdate the non-Boundedness of the new ```Debug Int``` levels.+3. Made logging thread-aware by making prefixes thread-local  +and doing IO output of logs via the [```Say``` library](https://hackage.haskell.org/package/say)+4. Added type synonyms ```PrefixedLogEffects``` and ```PrefixedLogEffectsLE``` for type-level-lists of logging effects ++* Added functions to handle the failure branch of ```Maybe``` and ```Either Text``` as errors.+* Added ```knitMapError``` to absorb other types of errors.+* Updated some dependency bounds (NB: tests now depend on random-fu >= 2.7.3 since previous versions had bad log-domain bounds)+* Updated for Pandoc >= 2.8.  String to Text and template handling changes.  All conditional (via CPP) so should work with < 2.8 as well.+ v0.7.0.0 * Updated vega versions in pandoc templates * removed (internal) datadir function because we now use the function

@@ -1,18 +1,205 @@-# knit-haskell v0.7.0.0+# knit-haskell v0.8.0.0  [![Build Status][travis-badge]][travis] [![Hackage][hackage-badge]][hackage] [![Hackage Dependencies][hackage-deps-badge]][hackage-deps] +## Breaking Changes+To move from v0.7.x.x to v0.8.x.x requires a change in how configuration parameters given to ```knit-html``` and ```knit-htmls``` are +handled: they are now all placed inside a ```KnitConfig```.  +It's a trivial change to make and should make the configuration more future-proof as long as you build your ```KnitConfig``` like, e.g., +```haskell+myConfig :: KnitConfig+myConfig = (defaultKnitConfig $ Just "myCache") { outerLogPrefix = Just "MyReport"}+```++Also note that newer versions of Pandoc (2.9+) have their own breaking changes.  knit-haskell can be +compiled against these as+well as the older versions, but there are some major changes which may affect you should you use any of the pandoc +functions directly.  In particular, Pandoc has now switched to using ```Text``` instead of ```String``` for+most (all ?) things.+ ## Introduction knit-haskell is an attempt to emulate parts of the RMarkdown/knitR experience in haskell.  The idea is to be able to build HTML (or, perhaps, some other things [Pandoc](http://hackage.haskell.org/package/pandoc) can write)  inside a haskell executable.  -This package has some wrapping around Pandoc and the [PandocMonad](http://hackage.haskell.org/package/pandoc-2.7.2/docs/Text-Pandoc-Class.html#t:PandocMonad) -as well as logging facilities -and some support for inserting [hvega](http://hackage.haskell.org/package/hvega) visualizations.  -All of that is handled via writer-like effects, so additions to the documents can be interspersed with regular haskell code.+This package wraps Pandoc and the +[PandocMonad](http://hackage.haskell.org/package/pandoc-2.7.2/docs/Text-Pandoc-Class.html#t:PandocMonad), +has logging facilities and support for inserting [hvega](http://hackage.haskell.org/package/hvega), +[diagrams](https://hackage.haskell.org/package/diagrams), and +[plots](https://hackage.haskell.org/package/plots) based +visualizations.  +All of that is handled via writer-like effects, so additions to the documents can be interspersed with regular haskell code.  +As of version 0.8.0.0, the effect stack includes a couple of new features. +Firstly, an "Async" effect ([Polysemy.Async](https://hackage.haskell.org/package/polysemy-1.2.3.0/docs/Polysemy-Async.html)) +for running computations concurrently. Combinators for launching a concurrent action (```async```), +awaiting (```await```) it's result and running some traversable structure of concurrent actions+(```sequenceConcurrently```) are re-exported via ```Knit.Report```.  NB: Polysemy returns a ```Maybe a``` where+the traditional interface returns an ```a```. +From the docs "The Maybe returned by async is due to the fact that we can't be sure an Error effect didn't fail locally."++A persistent (using memory and disk) cache for "shelving" the results of computations during and between runs.  +Using the default setup, anything which has+a ```Serialize``` instance from the [cereal](https://hackage.haskell.org/package/cereal) +package can be cached. You can use a different serializer if you so choose, but you will have write+a bit of code to bridge the serializer's interface and, depending on what the serializer encodes to, +you may also  have to write your own persistence functions for saving/loading that type to/from disk.  See +```Knit.Effect.Serialize``` and ```Knit.Effect.AtomicCache``` for details.++If you use the cache, and you are running in a version-controlled directory,+you probably want to add your cache directory, specified in ```KnitConfigure``` and defaulting to+".knit-haskell-cache", to ".gitignore" or equivalent.++Once data has been loaded from disk/produced once, it remains available in memory (in serialized form) via its key. +The cache handles multi-threading gracefully.  The in-memory cache is stored in a TVar so only one thread +may make requests at a time.+If multiple threads request the same item, one not currently in-memory--a +relatively common pattern if multiple analyses of the same data are +run asynchronously--the first request will fetch or create the data and the rest will block until the first one+gets a result, at which point the blocked threads will received the now in-memory data and proceed.++Data can be put into the cache via ```store```, and retrieved via ```retrieve```. Retrieval from cache+does not actually retrieve the data, but a structure with a time-stamp +([```Maybe Time.Clock.UTCTime```](https://hackage.haskell.org/package/time-1.10/docs/Data-Time-Clock.html#t:UTCTime))+and a monadic computation which can produce the data:+```haskell+data WithCacheTime m a where+  WithCacheTime :: Maybe Time.UTCTime -> m a -> WithCacheTime m a+```++To get the data from a ```WithCacheTime``` you can use functions from the +library to "ignore" the time and bind the result:+```ignoreCacheTime :: WithCacheData m a -> m a```+or+```haskell+ignoreCacheTimeM :: m (WithCacheData m a) -> ma +ignoreCacheTimeM = join . ignoreCacheTime+```++Though direct storage and retrieval is useful, typically, one would use the cache to store +the result of a long-running computation so it need only be run once.  This pattern is +facilitated via +```+retrieveOrMake :: k -> WithCacheTime m b -> (b -> m a) -> m (WithCacheTime m a)+```++which takes a key, a set of dependencies, of type ```b```, with a time-stamp,+a (presumably expensive) function taking those dependencies and producing a +time-stamped monadic computation for the desired result. If the requested+data is cached, the time stamp (modification time of the file in cache, more or less) +is compared to the time-stamp on the dependencies.  As long as the dependencies are older+than the cached data, an action producing the cached result is returned.  If there is no+data in the cache for that key or the in-cache data is too old, the action producing the dependencies+is "run" and those dependencies are fed to the computation given, producing the data and +caching the result.++NB: The returned monadic computation is *not* simply the result of applying the dependencies to+the given function.  That computation is run, if necessary, in order to produce the data, which+is then serialized and cached.  The returned monadic computation is either the data produced+by the given computation, put into the monad via ```pure```, or the result pulled from the +cache *before* it is deserialized.  Running the returned computation performs the deserialization+so the data can be used.  This allows checking the time-stamp of data without deserializing it+in order to make the case where it's never actually used more efficient.  ++```WithCacheTime``` is an applicative functor, which facilitates its primary use, to store +a set of dependencies *and* the latest time at which something which depends on them could+have been computed and still be valid. As an example, suppose you have three long-running+computations, the last of which depends on the first two:+```haskell+longTimeA :: AData+longTimeB :: BData+longTimeC :: AData -> BData -> CData+```++You might approach caching this sequence thusly:+```+cachedA <- retrieveOrMake "A.bin" (pure ()) (const longTimeA)+cachedB <- retrieveOrMake "B.bin" (pure ()) (const longTimeB)+let cDeps = (,) <$> cachedA <*> cachedB+cachedC <- retrieveOrMake "C.bin" cDeps $ \(a, b) -> longTimeC a b+```+and each piece of data will get cached when this is first run.  Now suppose you change the computation+```longTimeA```.  You realize that the cached data is invalid, so you delete "A.bin" from the+cache.  The next time this code runs, it will recompute and cache the result of ```longTimeA```, +load the ```BData```  (serialized) from cache, see that+the cached version of ```CData``` is out of date, +and then deserialize ```BData````, and use it and the new ```AData``` +to recompute and re-cache ```CData```.  This doesn't eliminate the +need for user intervention: the user still had to manually delete "A.bin" to force re-running ```longTimeA```, +but it handles the downstream work of tracking the uses of that data and recomputing where required. +I've found this extremely useful.++Entries can be cleared from the cache via ```clear```.++The cache types are flexible:++-The default key type is ```Text``` but you may use anything with an ```Ord``` and ```Show``` +instance (the latter for logging).  The persistence layer will need to be able to turn the key+into a key in that layer, e.g., a ```FilePath```.++-The default serializer is the +[cereal](https://hackage.haskell.org/package/cereal) package but you may+use another (e.g., the +[binary](https://hackage.haskell.org/package/binary-0.8.7.0/docs/Data-Binary.html) +package or +[store](https://hackage.haskell.org/package/store).++-The default in-memory storage is a [streamly](https://hackage.haskell.org/package/streamly) +[array](https://hackage.haskell.org/package/streamly-0.7.2/docs/Streamly-Memory-Array.html) of bytes +([```Word8```](https://hackage.haskell.org/package/base-4.14.0.0/docs/Data-Word.html)) but this can+also be changed.++To change these, the user must provide a serializer capable of serializing any data-type to be stored into+the desired in-memory storage type,  and a persistence layer which can persist that in-memory type.++Please see  [CacheExample](https://github.com/adamConnerSax/knit-haskell/blob/master/examples/CacheExample.hs) for an example using+the default serializer and in-memory storage type. +See [CacheExample2](https://github.com/adamConnerSax/knit-haskell/blob/master/examples/CacheExample2.hs) for an+identical example, but with a custom serializer (based on the +[store](https://hackage.haskell.org/package/store)) package and using strict ```ByteStreams``` as the in-memory cache type. ++Notes:+1. Using Streamly requires some additional support for both Cereal and Polysemy.  The encoding/decoding +for Cereal are in this library, in ```Streamly.External.Cereal```. The Polysemy issue is more complex.+Since concurrent streamly streams can only be run over a monad with instances of ```MonadCatch``` and +```MonadBaseControl```. The former is +[complex](https://hackage.haskell.org/package/polysemy-zoo-0.7.0.0/docs/Polysemy-ConstraintAbsorber-MonadCatch.html) +in Polysemy and the latter impossible, [for good reason](https://github.com/polysemy-research/polysemy/issues/73). +So knit-haskell contains some helpers for Streamly streams: basically a wrapper over IO which allows use of+knit-haskell logging.  Concurrent streaming operations can be done over this monad and then, once the stream+is serial or the result computed, that monad can be lifted into the regular knit-haskell Polysemy stack.  +See ```Knit.Utilities.Streamly``` for more details.++2. ```Knit.Report```, the main import, provides constraint helpers to use these effects.  The clearest way to+see how they are used is to look at the examples.  The Cache effects are split into their own constraint helper+because they have type-parameters and thus add a lot of inference complications.  If you don't need them in a +function, you need not specify them.  Some of that inference can be improved using the +[polysemy-plugin](https://hackage.haskell.org/package/polysemy-plugin) in the source files where you+have issues.  Otherwise, you may need to use +[type applications](https://gitlab.haskell.org/ghc/ghc/-/wikis/type-application)+when calling some functions in +```Knit.Report.Cache```.++- ```KnitEffects r```: All effects except caching or the addition of document fragments.  +Includes logging, error handling, and any direct use of funtions in PandocMonad or IO.  +This is often useful to wrap computations that need logging and perhaps IO but that don't +write any part of your document.  This is a constraint on the polysemy ```EffectRow```, +```r```, typically part of the return type of the function: ```Sem r a```.++- ```CacheEffects sc ct k r```: Effects related to caching. ```sc``` is the Serializer constraint, e.g.,+```Serialize``` for cereal (the default) or ```Store``` for store. ```ct``` is the in-memory data type,+```Streamly.Memory.Array.Array Word8``` by default but some flavor of ```ByteStream``` could also make sense. +```k``` is the key type, ```Text``` by default but anything with ```Ord``` and ```Show``` instances will do.++- ```CacheEffectsD r```: provides the same effects as ```CacheEffects``` but sets the various types to their defaults.++- ```KnitOne r```: ```KnitEffects r``` and the additional effect required to write Pandoc fragments.++- ```KnitMany r```: ```KnitEffects r``` and the additional effects required to write multiple Pandoc +documents.++ ## Supported Inputs * [markdown](https://pandoc.org/MANUAL.html#pandocs-markdown) * HTML ([blaze](http://hackage.haskell.org/package/blaze-html), [lucid](http://hackage.haskell.org/package/lucid) or Text)@@ -39,28 +226,51 @@ for adding a formatted table to the document. * [ErrorExample](https://github.com/adamConnerSax/knit-haskell/blob/master/examples/ErrorExample.hs).   Similar to "SimpleExample" but throws a user error during document assembly.+* [AsyncExample](https://github.com/adamConnerSax/knit-haskell/blob/master/examples/AsyncExample.hs).  +Similar to "SimpleExample" but uses Polysemy's ```sequenceConcurrently``` to run some example+computations concurrently (as long as you compile with "-threaded")+* [CacheExample](https://github.com/adamConnerSax/knit-haskell/blob/master/examples/CacheExample.hs).  +Similar to "SimpleExample" but uses the "AtomicCache" effect to store the result of a computation. +Demonstrates the behavior of the cache when multiple threads attempt to access the same item--the first+thread loads/creates the data while the other blocks until the data is in-memory.  Also demonstrates+use of time-stamps to force rebuilding when tracked inputs change.+* [CacheExample2](https://github.com/adamConnerSax/knit-haskell/blob/master/examples/CacheExample2.hs).  +Similar to "CacheExample" but implements and uses a different serializer and persistence layer than the+default. + ## Notes-* You should be able to get everything you need by just importing the +* You can often get everything you need by just importing the  [Knit.Report](https://github.com/adamConnerSax/knit-haskell/blob/master/src/Knit/Report.hs) -module.  That has the main functions for "knitting" documents from fragments -and re-exports all the required functions to input the supported fragment types and create/write Html.-* This uses [polysemy](https://github.com/isovector/polysemy#readme) for its effect management rather than mtl.  -Polysemy's inference and performance are greatly improved if you enable the [polysemy-plugin](https://hackage.haskell.org/package/polysemy-plugin),+module. It's meant to be "batteries included."  +This re-exports the main functions for "knitting" documents and re-exports +all the required functions to input the supported fragment types and create/write Html, +as well as various utilties and+combinators for logging, using the cache facility, or throwing errors.+* This uses [polysemy](https://github.com/polysemy-research/polysemy#readme) for its effect management rather than mtl.  +Polysemy's inference (and performance?) are greatly improved if you enable +the [polysemy-plugin](https://hackage.haskell.org/package/polysemy-plugin), which involves: 1. adding "polysemy-plugin" in build-depends and-2. Add "ghc-options: -fplugin=Polysemy.Plugin" to your package configuration.+2. Add "ghc-options: -fplugin=Polysemy.Plugin" to your package configuration or+```{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-}``` at the top of any source file+with inference issues. + Pandoc effects and writer effects for document building are also provided.+ * Polysemy is capable of "absorbing" some mtl-style monad constraints.  This is demonstrated in [RandomExample](https://github.com/adamConnerSax/knit-haskell/blob/master/examples/RandomExample.hs#L113) and composable absorbers for MonadReader, MonadWriter, MonadState and MonadError can be found in the [polysemy-zoo](https://github.com/isovector/polysemy-zoo).+ * Pandoc templates are included for HTML output.  See the examples for how to access them or specify others.+ * If you use knit-haskell via an installed executable, it will find the templates that  cabal installs.  But if you use from a local build directory and use "cabal new-" or "cabal v2-" style commands, you will need to run the executable via some "cabal v2-" command as well, e.g.,-"cabal v2-run" otherwise the templates--installed in the nix-style-build store--won't be found.+"cabal v2-run" (but not "cabal v2-exec") otherwise the +templates--installed in the nix-style-build store--won't be found. * Though you can theoretically output to any format Pandoc can  write--and it would be great to add some output formats!--some  features only work with some output formats. @@ -68,12 +278,13 @@ since hvega itself is just a wrapper that builds javascript to render in a browser.   And so far that is the only supported output format. -* This is very much a WIP. So it's rough around the edges and in the middle.  If you find it useful but have suggestions, please submit issues on github.+* This is very much a WIP. So it's rough around the edges and in the middle.  +If you find it useful but have suggestions, please submit issues on github.+ * I'm very interested in adding to the "zoo" of input fragments.  Any PRs of that sort would be most welcome! * I'm also interested in widening the possible output types--currently only HTML is supported--but  that is quite limited now by hvega which only works in html output.   But support could be added for other output types if hvega input is not required.-  [travis]:        <https://travis-ci.org/adamConnerSax/knit-haskell> [travis-badge]:  <https://travis-ci.org/adamConnerSax/knit-haskell.svg?branch=master>

@@ -0,0 +1,139 @@+{-# LANGUAGE QuasiQuotes       #-}+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications  #-}+{-# LANGUAGE GADTs             #-}+module Main where++import qualified Knit.Report                   as K++import qualified Data.Map                      as M+import qualified Data.Text                     as T+import           Data.String.Here               ( here )+import qualified Graphics.Vega.VegaLite        as V+import qualified Plots                         as P++import           Control.Concurrent            (threadDelay)++templateVars :: M.Map String String+templateVars = M.fromList+  [ ("lang"     , "English")+  , ("author"   , "Adam Conner-Sax")+  , ("pagetitle", "knit-haskell async example")+--  , ("tufte","True")+  ]++main :: IO ()+main = do+  let template = K.DefaultTemplate --K.FromIncludedTemplateDir "mindoc-pandoc-KH.html"+  pandocWriterConfig <- K.mkPandocWriterConfig template+                                               templateVars+                                               K.mindocOptionsF+  let knitConfig = (K.defaultKnitConfig Nothing)+                   { K.outerLogPrefix = Just "AsyncExample.Main"+                   , K.logIf = K.logAll+                   , K.pandocWriterConfig = pandocWriterConfig+                   }+  resE <- K.knitHtml knitConfig makeDoc+  +  case resE of+    Right htmlAsText ->+      K.writeAndMakePathLT "examples/html/async_example.html" htmlAsText+    Left err -> putStrLn $ "Pandoc Error: " ++ show err++md1 :: T.Text+md1 = [here|+## Some example markdown+* [Markdown][MarkdownLink] is a nice way to write formatted notes with a minimum of code.+* It supports links and tables and some *styling* information.++[MarkDownLink]:<https://pandoc.org/MANUAL.html#pandocs-markdown>+|]++makeDoc :: K.KnitOne effs => K.Sem effs ()+makeDoc = K.wrapPrefix "makeDoc" $ do+  K.logLE K.Info "adding some markdown..."+  K.addMarkDown md1+  K.logLE K.Info "adding some latex..."+  K.addMarkDown "## Some example latex"+  K.addLatex "Overused favorite equation: $e^{i\\pi} + 1 = 0$"+  K.logLE K.Info "Launching some concurrent long-running computations..."+  asyncResultsM <- sequence <$> K.sequenceConcurrently [delay 800 1, delay 1000 2, delay 1200 3]+  case asyncResultsM of+    Nothing -> K.logLE K.Error "One or more concurrent calculations failed."+    Just results -> do+      K.logLE K.Info "Concurrent calculations succeeded."+      K.addMarkDown $ "## Some concurrent calculation results: " <> (T.pack $ show results) +  K.logLE K.Info "adding a visualization..."+  K.addMarkDown "## An example hvega visualization"+  _ <- K.addHvega Nothing (Just "From the cars data-set") exampleVis+  K.addMarkDown+    "## Example Diagrams visualizations, the second using the plots library."+  K.logLE K.Info "adding a Diagrams example and plots example..."+  _ <- K.addDiagramAsSVG Nothing (Just "Example diagram") 300 300 exampleDiagram+  _ <- K.addDiagramAsSVG+    Nothing+    (Just "Example diagrams visualization using the Plots library")+    300+    300+    samplePlot+  return ()++-- long running computation+delay :: K.KnitEffects effs => Int -> Int -> K.Sem effs Int+delay msDelay val = K.wrapPrefix ("delay") $ do+  K.logLE K.Info $ "delaying " <> (T.pack $ show val) <> " for " <> (T.pack $ show msDelay) <> " ms"+  K.liftKnit (threadDelay $ 1000 * msDelay)+  K.logLE K.Info "done"+  return val+  ++-- example using HVega  +exampleVis :: V.VegaLite+exampleVis =+  let cars =+          V.dataFromUrl "https://vega.github.io/vega-datasets/data/cars.json" []+      enc =+          V.encoding+            . V.position V.X [V.PName "Horsepower", V.PmType V.Quantitative]+            . V.position V.Y [V.PName "Miles_per_Gallon", V.PmType V.Quantitative]+            . V.color [V.MName "Origin", V.MmType V.Nominal]+      bkg = V.background "rgba(0, 0, 0, 0.05)"+  in  V.toVegaLite [bkg, cars, V.mark V.Circle [], enc []]+++-- sampleDiagram+-- from <https://archives.haskell.org/projects.haskell.org/diagrams/gallery/Hilbert.html>++hilbert 0 = mempty+hilbert n =+  hilbert' (n - 1)+    K.# K.reflectY+    <>  K.vrule 1+    <>  hilbert (n - 1)+    <>  K.hrule 1+    <>  hilbert (n - 1)+    <>  K.vrule (-1)+    <>  hilbert' (n - 1)+    K.# K.reflectX+  where hilbert' m = hilbert m K.# K.rotateBy (1 / 4)++exampleDiagram :: K.Diagram K.SVG+exampleDiagram =+  K.frame 1 . K.lw K.medium . K.lc K.darkred . K.strokeT $ hilbert 5+++-- example using Plots (as an example of using Diagrams)+samplePlot :: K.Diagram K.SVG+samplePlot = P.renderAxis logAxis++logData = [K.V2 1 10, K.V2 2 100, K.V2 2.5 316, K.V2 3 1000]++logAxis :: P.Axis K.SVG K.V2 Double+logAxis = P.r2Axis K.&~ do+  P.scatterPlot' logData++  P.yAxis P.&= do+    P.logScale K..= P.LogAxis+    P.majorTicksFunction K..= P.logMajorTicks 5 -- <> pure [1]+

@@ -0,0 +1,186 @@+{-# LANGUAGE ConstraintKinds   #-}+{-# LANGUAGE DataKinds         #-}+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE GADTs             #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes       #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications  #-}++module Main where++import qualified Knit.Report                   as Knit+import qualified Knit.Utilities.Streamly       as Knit.Streamly++import qualified Streamly.Prelude as Streamly++import qualified Control.Concurrent            as CC+import qualified Data.Map                      as M+import qualified Data.Text                     as T+import           Data.String.Here               ( here )+import qualified Graphics.Vega.VegaLite        as V+import qualified Plots                         as P+++templateVars :: M.Map String String+templateVars = M.fromList+  [ ("lang"     , "English")+  , ("author"   , "Adam Conner-Sax")+  , ("pagetitle", "knit-haskell cache example")+--  , ("tufte","True")+  ]++main :: IO ()+main = do+  let template = Knit.DefaultTemplate --K.FromIncludedTemplateDir "mindoc-pandoc-KH.html"+  pandocWriterConfig <- Knit.mkPandocWriterConfig template+                                               templateVars+                                               Knit.mindocOptionsF++  let knitConfig = (Knit.defaultKnitConfig Nothing)+        { Knit.outerLogPrefix = Just "CacheExample.Main"+        , Knit.logIf = Knit.logAll+        , Knit.pandocWriterConfig = pandocWriterConfig+        }                                               +  resE <- Knit.knitHtml knitConfig makeDoc++  case resE of+    Right htmlAsText ->+      Knit.writeAndMakePathLT "examples/html/cache_example.html" htmlAsText+    Left err -> putStrLn $ "Pandoc Error: " ++ show err++md1 :: T.Text+md1 = [here|+## Some example markdown+* [Markdown][MarkdownLink] is a nice way to write formatted notes with a minimum of code.+* It supports links and tables and some *styling* information.++[MarkDownLink]:<https://pandoc.org/MANUAL.html#pandocs-markdown>+|]++makeDoc :: (Knit.KnitOne r, Knit.CacheEffectsD r) => Knit.Sem r ()+makeDoc = Knit.wrapPrefix "makeDoc" $ do+  Knit.logLE Knit.Info "adding some markdown..."+  Knit.addMarkDown md1+  Knit.logLE Knit.Info "adding some latex..."+  Knit.addMarkDown "## Some example latex"+  Knit.addLatex "Overused favorite equation: $e^{i\\pi} + 1 = 0$"+  Knit.logLE Knit.Info "Clearing \"cacheExample/test.bin\" and \"cacheExample/test2.bin\" from cache..."+  Knit.clearIfPresent "cacheExample/test.sbin"+  Knit.clearIfPresent "cacheExample/test2.sbin"+  Knit.logLE Knit.Info $ "asynchronously retrieveOrMake stream of data, then retrieveOrMake on this thread, after a small delay, to test atomic cache."+    <> "the async retrieveOrMake will try the cache first"+    <> ", in-memory, then disk, then makes the data if those come up empty."+  Knit.logLE Knit.Info "At which point the main thread, blocked on the TMVar in the cache, will unblock and see the data in the in-memory-cache."+  testListA <- Knit.async $ Knit.wrapPrefix "ASYNC" $ do+    dat <- streamLoader+    Knit.logLE Knit.Diagnostic "Waiting to return from Async"+    Knit.liftKnit $ CC.threadDelay 1000000+    return dat+  Knit.liftKnit $ CC.threadDelay 100000    +  testList <- streamLoader+  testListM <- Knit.await testListA+  case testListM of+    Nothing -> Knit.logLE Knit.Diagnostic "Error in async retrieve"+    Just l -> do+      Knit.logLE Knit.Diagnostic "List returned from async.  Logging async then sync."+      Knit.logLE Knit.Diagnostic $ "async:" <> (T.pack $ show l)+      Knit.logLE Knit.Diagnostic $ "sync:" <> (T.pack $ show testList)+  Knit.logLE Knit.Info "Demonstrating cache dependencies"+  Knit.logLE Knit.Info "streamLoader2 depends on streamLoader and should rebuild if streamLoader has been rebuilt since streamLoader2 was cached."+  Knit.logLE Knit.Info "Calling streamLoader2 the first time"+  sl2a <- streamLoader2 -- builds the first time+  Knit.logLE Knit.Info "Calling streamLoader2 again. Should load from cache."+  sl2b <- streamLoader2 -- loads from cache+  Knit.logLE Knit.Info "Removing cached streamLoader1 result, then calling streamLoader 2 again. Should rebuild."+  Knit.clear "cacheExample/test.sbin" -- remove sl1+  sl2c <- streamLoader2 -- should rebuild+  Knit.logLE Knit.Info $ "streamLoader2=" <> (T.pack $ show sl2c)+  Knit.logLE Knit.Info "adding a visualization..."+  Knit.addMarkDown "## An example hvega visualization"+  _ <- Knit.addHvega Nothing (Just "From the cars data-set") exampleVis+  Knit.addMarkDown+    "## Example Diagrams visualizations, the second using the plots library."+  Knit.logLE Knit.Info "adding a Diagrams example and plots example..."+  _ <- Knit.addDiagramAsSVG Nothing (Just "Example diagram") 300 300 exampleDiagram+  _ <- Knit.addDiagramAsSVG+    Nothing+    (Just "Example diagrams visualization using the Plots library")+    300+    300+    samplePlot+  Knit.logLE Knit.Info "Retrieving that stuff from the cache or running if required."+  Knit.addMarkDown $ "## Caching: List=" <> (T.pack $ show testList)+  return ()++streamLoader :: (Knit.KnitEffects q, Knit.CacheEffectsD q) => Knit.Sem q [Int]+streamLoader = Streamly.toList $ Knit.ignoreCacheTimeStream $ streamLoaderWC++streamLoaderWC :: (Knit.KnitEffects q, Knit.CacheEffectsD q)+               => Knit.Sem q (Knit.StreamWithCacheTime q Int)+streamLoaderWC = Knit.wrapPrefix "streamLoaderWC" $ do+  Knit.logLE Knit.Diagnostic $ "streamLoaderWC called"+  Knit.retrieveOrMakeStream "cacheExample/test.sbin" (pure ()) $ const $ do               +    Streamly.yieldM $ Knit.logLE Knit.Diagnostic "Waiting to make..."+    Streamly.yieldM $ Knit.liftKnit $ CC.threadDelay 1000000                           +    Streamly.yieldM $ Knit.logLE Knit.Diagnostic "Making test data"+    Knit.Streamly.streamlyToKnitS+      $ Streamly.fromList  [1,10,100]+               ++streamLoader2 ::(Knit.KnitEffects q, Knit.CacheEffectsD q)+              => Knit.Sem q [Int]+streamLoader2 = Streamly.toList $ Knit.ignoreCacheTimeStream $ do+  cachedStream <- Knit.streamAsAction <$> streamLoaderWC+  Knit.retrieveOrMakeStream "cacheExample/test2.sbin" cachedStream $ \sInt -> do+    Streamly.map (*2) sInt+               +-- example using HVega  +exampleVis :: V.VegaLite+exampleVis =+  let cars =+          V.dataFromUrl "https://vega.github.io/vega-datasets/data/cars.json" []+      enc =+          V.encoding+            . V.position V.X [V.PName "Horsepower", V.PmType V.Quantitative]+            . V.position V.Y [V.PName "Miles_per_Gallon", V.PmType V.Quantitative]+            . V.color [V.MName "Origin", V.MmType V.Nominal]+      bkg = V.background "rgba(0, 0, 0, 0.05)"+  in  V.toVegaLite [bkg, cars, V.mark V.Circle [], enc []]+++-- sampleDiagram+-- from <https://archives.haskell.org/projects.haskell.org/diagrams/gallery/Hilbert.html>++hilbert 0 = mempty+hilbert n =+  hilbert' (n - 1)+    Knit.# Knit.reflectY+    <>  Knit.vrule 1+    <>  hilbert (n - 1)+    <>  Knit.hrule 1+    <>  hilbert (n - 1)+    <>  Knit.vrule (-1)+    <>  hilbert' (n - 1)+    Knit.# Knit.reflectX+  where hilbert' m = hilbert m Knit.# Knit.rotateBy (1 / 4)++exampleDiagram :: Knit.Diagram Knit.SVG+exampleDiagram =+  Knit.frame 1 . Knit.lw Knit.medium . Knit.lc Knit.darkred . Knit.strokeT $ hilbert 5+++-- example using Plots (as an example of using Diagrams)+samplePlot :: Knit.Diagram Knit.SVG+samplePlot = P.renderAxis logAxis++logData = [Knit.V2 1 10, Knit.V2 2 100, Knit.V2 2.5 316, Knit.V2 3 1000]++logAxis :: P.Axis Knit.SVG Knit.V2 Double+logAxis = P.r2Axis Knit.&~ do+  P.scatterPlot' logData++  P.yAxis P.&= do+    P.logScale Knit..= P.LogAxis+    P.majorTicksFunction Knit..= P.logMajorTicks 5 -- <> pure [1]+

@@ -0,0 +1,209 @@+{-# LANGUAGE ConstraintKinds   #-}+{-# LANGUAGE DataKinds         #-}+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE GADTs             #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes       #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications  #-}++module Main where++import qualified Knit.Report                   as Knit+import qualified Knit.Utilities.Streamly       as Knit.Streamly++import qualified Knit.Effect.Serialize as Knit+import qualified Knit.Effect.AtomicCache as Knit++import qualified Data.Store as Store+import qualified Data.ByteString as BS++import qualified Streamly.Prelude as Streamly++import qualified Control.Concurrent            as CC+import qualified Data.Map                      as M+import qualified Data.Text                     as T+import           Data.String.Here               ( here )+import qualified Graphics.Vega.VegaLite        as V+import qualified Plots                         as P++-- map Store exception to Knit.SerializationException+peekExceptionToSerializationError :: Store.PeekException -> Knit.SerializationError+peekExceptionToSerializationError (Store.PeekException offset msg) =+  Knit.SerializationError $ "Store decoding error: offset=" <> (T.pack $ show offset) <> " bytes; msg=" <> msg++-- custom serializer+storeByteStreamDict :: Knit.SerializeDict Store.Store BS.ByteString+storeByteStreamDict =+  Knit.SerializeDict+  Store.encode+  (either (Left . peekExceptionToSerializationError) Right . Store.decode)+  (fromIntegral . BS.length)++-- type-alias to simplify constraints below+type CacheEffects r = Knit.CacheEffects Store.Store BS.ByteString T.Text r++templateVars :: M.Map String String+templateVars = M.fromList+  [ ("lang"     , "English")+  , ("author"   , "Adam Conner-Sax")+  , ("pagetitle", "knit-haskell cache example 2")+  ]++main :: IO ()+main = do+  let template = Knit.DefaultTemplate --K.FromIncludedTemplateDir "mindoc-pandoc-KH.html"+  pandocWriterConfig <- Knit.mkPandocWriterConfig template+                                               templateVars+                                               Knit.mindocOptionsF++  let knitConfig :: Knit.KnitConfig Store.Store BS.ByteString T.Text+      knitConfig = (Knit.defaultKnitConfig Nothing)+        { Knit.outerLogPrefix = Just "CacheExample2.Main"+        , Knit.logIf = Knit.logAll+        , Knit.pandocWriterConfig = pandocWriterConfig+        , Knit.serializeDict = storeByteStreamDict+        , Knit.persistCache = (Knit.persistStrictByteString (\t  -> T.unpack (".knit-haskell-cache/" <> t)))+        }                                               +  resE <- Knit.knitHtml knitConfig makeDoc++  case resE of+    Right htmlAsText ->+      Knit.writeAndMakePathLT "examples/html/cache_examples.html" htmlAsText+    Left err -> putStrLn $ "Pandoc Error: " ++ show err++md1 :: T.Text+md1 = [here|+## Some example markdown+* [Markdown][MarkdownLink] is a nice way to write formatted notes with a minimum of code.+* It supports links and tables and some *styling* information.++[MarkDownLink]:<https://pandoc.org/MANUAL.html#pandocs-markdown>+|]++makeDoc :: (Knit.KnitOne r, CacheEffects r) => Knit.Sem r ()+makeDoc = Knit.wrapPrefix "makeDoc" $ do+  Knit.logLE Knit.Info "adding some markdown..."+  Knit.addMarkDown md1+  Knit.logLE Knit.Info "adding some latex..."+  Knit.addMarkDown "## Some example latex"+  Knit.addLatex "Overused favorite equation: $e^{i\\pi} + 1 = 0$"+  Knit.logLE Knit.Info "Clearing \"cacheExample2/test.bin\" and \"cacheExample2/test2.bin\" from cache..."+  Knit.clearIfPresent "cacheExample/test.sbin"+  Knit.clearIfPresent "cacheExample/test2.sbin"+  Knit.logLE Knit.Info $ "asynchronously retrieveOrMake stream of data, then retrieveOrMake on this thread, after a small delay, to test atomic cache."+    <> "the async retrieveOrMake will try the cache first"+    <> ", in-memory, then disk, then makes the data if those come up empty."+  Knit.logLE Knit.Info "At which point the main thread, blocked on the TMVar in the cache, will unblock and see the data in the in-memory-cache."+  testListA <- Knit.async $ Knit.wrapPrefix "ASYNC" $ do+    dat <- streamLoader+    Knit.logLE Knit.Diagnostic "Waiting to return from Async"+    Knit.liftKnit $ CC.threadDelay 1000000+    return dat+  Knit.liftKnit $ CC.threadDelay 100000    +  testList <- streamLoader+  testListM <- Knit.await testListA+  case testListM of+    Nothing -> Knit.logLE Knit.Diagnostic "Error in async retrieve"+    Just l -> do+      Knit.logLE Knit.Diagnostic "List returned from async.  Logging async then sync."+      Knit.logLE Knit.Diagnostic $ "async:" <> (T.pack $ show l)+      Knit.logLE Knit.Diagnostic $ "sync:" <> (T.pack $ show testList)+  Knit.logLE Knit.Info "Demonstrating cache dependencies"+  Knit.logLE Knit.Info "streamLoader2 depends on streamLoader and should rebuild if streamLoader has been rebuilt since streamLoader2 was cached."+  Knit.logLE Knit.Info "Calling streamLoader2 the first time"+  sl2a <- streamLoader2 -- builds the first time+  Knit.logLE Knit.Info "Calling streamLoader2 again. Should load from cache."+  sl2b <- streamLoader2 -- loads from cache+  Knit.logLE Knit.Info "Removing cached streamLoader1 result, then calling streamLoader 2 again. Should rebuild."+  Knit.clear "cacheExample/test.sbin" -- remove sl1+  sl2c <- streamLoader2 -- should rebuild+  Knit.logLE Knit.Info $ "streamLoader2=" <> (T.pack $ show sl2c)+  Knit.logLE Knit.Info "adding a visualization..."+  Knit.addMarkDown "## An example hvega visualization"+  _ <- Knit.addHvega Nothing (Just "From the cars data-set") exampleVis+  Knit.addMarkDown+    "## Example Diagrams visualizations, the second using the plots library."+  Knit.logLE Knit.Info "adding a Diagrams example and plots example..."+  _ <- Knit.addDiagramAsSVG Nothing (Just "Example diagram") 300 300 exampleDiagram+  _ <- Knit.addDiagramAsSVG+    Nothing+    (Just "Example diagrams visualization using the Plots library")+    300+    300+    samplePlot+  Knit.logLE Knit.Info "Retrieving that stuff from the cache or running if required."+  Knit.addMarkDown $ "## Caching: List=" <> (T.pack $ show testList)+  return ()++streamLoader :: (Knit.KnitEffects q, CacheEffects q) => Knit.Sem q [Int]+streamLoader = Streamly.toList $ Knit.ignoreCacheTimeStream $ streamLoaderWC++streamLoaderWC :: (Knit.KnitEffects q, CacheEffects q)+               => Knit.Sem q (Knit.StreamWithCacheTime q Int)+streamLoaderWC = Knit.wrapPrefix "streamLoaderWC" $ do+  Knit.logLE Knit.Diagnostic $ "streamLoaderWC called"+  Knit.retrieveOrMakeStream "cacheExample2/test.sbin" (pure ()) $ const $ do               +    Streamly.yieldM $ Knit.logLE Knit.Diagnostic "Waiting to make..."+    Streamly.yieldM $ Knit.liftKnit $ CC.threadDelay 1000000                           +    Streamly.yieldM $ Knit.logLE Knit.Diagnostic "Making test data"+    Knit.Streamly.streamlyToKnitS+      $ Streamly.fromList  [1,10,100]+               ++streamLoader2 ::(Knit.KnitEffects q, CacheEffects q)+              => Knit.Sem q [Int]+streamLoader2 = Streamly.toList $ Knit.ignoreCacheTimeStream $ do+  cachedStream <- Knit.streamAsAction <$> streamLoaderWC+  Knit.retrieveOrMakeStream "cacheExample2/test2.sbin" cachedStream $ \sInt -> do+    Streamly.map (*2) sInt+               +-- example using HVega  +exampleVis :: V.VegaLite+exampleVis =+  let cars =+          V.dataFromUrl "https://vega.github.io/vega-datasets/data/cars.json" []+      enc =+          V.encoding+            . V.position V.X [V.PName "Horsepower", V.PmType V.Quantitative]+            . V.position V.Y [V.PName "Miles_per_Gallon", V.PmType V.Quantitative]+            . V.color [V.MName "Origin", V.MmType V.Nominal]+      bkg = V.background "rgba(0, 0, 0, 0.05)"+  in  V.toVegaLite [bkg, cars, V.mark V.Circle [], enc []]+++-- sampleDiagram+-- from <https://archives.haskell.org/projects.haskell.org/diagrams/gallery/Hilbert.html>++hilbert 0 = mempty+hilbert n =+  hilbert' (n - 1)+    Knit.# Knit.reflectY+    <>  Knit.vrule 1+    <>  hilbert (n - 1)+    <>  Knit.hrule 1+    <>  hilbert (n - 1)+    <>  Knit.vrule (-1)+    <>  hilbert' (n - 1)+    Knit.# Knit.reflectX+  where hilbert' m = hilbert m Knit.# Knit.rotateBy (1 / 4)++exampleDiagram :: Knit.Diagram Knit.SVG+exampleDiagram =+  Knit.frame 1 . Knit.lw Knit.medium . Knit.lc Knit.darkred . Knit.strokeT $ hilbert 5+++-- example using Plots (as an example of using Diagrams)+samplePlot :: Knit.Diagram Knit.SVG+samplePlot = P.renderAxis logAxis++logData = [Knit.V2 1 10, Knit.V2 2 100, Knit.V2 2.5 316, Knit.V2 3 1000]++logAxis :: P.Axis Knit.SVG Knit.V2 Double+logAxis = P.r2Axis Knit.&~ do+  P.scatterPlot' logData++  P.yAxis P.&= do+    P.logScale Knit..= P.LogAxis+    P.majorTicksFunction Knit..= P.logMajorTicks 5 -- <> pure [1]+

@@ -26,11 +26,13 @@   pandocWriterConfig <- K.mkPandocWriterConfig template                                                templateVars                                                K.mindocOptionsF-  resSimpleE <- K.knitHtml (Just "ErrorExample.Main")-                           K.logAll-                           pandocWriterConfig-                           makeDocWithKnitError-  case resSimpleE of+  let knitConfig = (K.defaultKnitConfig Nothing)+                   { K.outerLogPrefix = Just "ErrorExample.Main"+                   , K.logIf = K.logAll+                   , K.pandocWriterConfig = pandocWriterConfig+                   }                                               +  resE <- K.knitHtml knitConfig makeDocWithKnitError+  case resE of     Right htmlAsText ->       K.writeAndMakePathLT "examples/html/error_example.html" htmlAsText     Left err -> putStrLn $ "Pandoc Error: " ++ show err

@@ -49,8 +49,14 @@   pandocWriterConfig <- K.mkPandocWriterConfig template                                                templateVarsWithCss                                                K.mindocOptionsF++  let knitConfig = (K.defaultKnitConfig Nothing)+        { K.outerLogPrefix = Just "MtlExample.Main"+        , K.logIf = K.logAll+        , K.pandocWriterConfig = pandocWriterConfig+        }   resE <- runExampleApp "This is from the MyApp environment."-    $ K.knitHtml (Just "MtlExample.Main") K.logAll pandocWriterConfig makeDoc+    $ K.knitHtml knitConfig makeDoc   case resE of     Right htmlAsText ->       K.writeAndMakePathLT "examples/html/mtl_example.html" htmlAsText

@@ -30,7 +30,13 @@   pandocWriterConfig <- K.mkPandocWriterConfig template                                                tvWithCss                                                K.mindocOptionsF-  resE <- K.knitHtmls (Just "MTLExample.Main") K.logAll pandocWriterConfig $ do+  let knitConfig = (K.defaultKnitConfig Nothing)+        { K.outerLogPrefix = Just "MultiDocExample.Main"+        , K.logIf = K.logAll+        , K.pandocWriterConfig = pandocWriterConfig+        }++  resE <- K.knitHtmls knitConfig $ do     K.newPandoc (K.PandocInfo "multi_doc1" M.empty) makeDoc1     K.newPandoc (K.PandocInfo "multi_doc2" M.empty) makeDoc2   case resE of

@@ -55,10 +55,15 @@   pandocWriterConfig <- K.mkPandocWriterConfig template                                                templateVars                                                K.mindocOptionsF+  let knitConfig = (K.defaultKnitConfig Nothing)+        { K.outerLogPrefix = Just "RandomExample.Main"+        , K.logIf = K.logAll+        , K.pandocWriterConfig = pandocWriterConfig+        }                                                pureMTSource <- newPureMT   resE         <-     runExampleApp "This is from the MyApp environment."-    $ K.knitHtml (Just "RandomExample.Main") K.logAll pandocWriterConfig+    $ K.knitHtml knitConfig     $ PR.runRandomIOPureMT pureMTSource     $ makeDoc   case resE of@@ -76,8 +81,9 @@ |]  makeDoc-  :: (K.KnitOne effs, K.Member PR.RandomFu effs -- this one needs to be handled before knitting-                                               , K.KnitBase ExampleApp effs)+  :: (K.KnitOne effs+     , K.Member PR.RandomFu effs -- this one needs to be handled before knitting+     , K.KnitBase ExampleApp effs)   => K.Sem effs () makeDoc = K.wrapPrefix "makeDoc" $ do   K.logLE K.Info "adding some markdown..."

@@ -26,12 +26,15 @@ main = do   let template = K.DefaultTemplate --K.FromIncludedTemplateDir "mindoc-pandoc-KH.html"   pandocWriterConfig <- K.mkPandocWriterConfig template-                                               templateVars-                                               K.mindocOptionsF-  resE <- K.knitHtml (Just "SimpleExample.Main")-                     K.logAll-                     pandocWriterConfig-                     makeDoc+                        templateVars+                        K.mindocOptionsF+                   +  let knitConfig = (K.defaultKnitConfig Nothing)+        { K.outerLogPrefix = Just "SimpleExample.Main"+        , K.logIf = K.logAll+        , K.pandocWriterConfig = pandocWriterConfig+        }+  resE <- K.knitHtml knitConfig makeDoc   case resE of     Right htmlAsText ->       K.writeAndMakePathLT "examples/html/simple_example.html" htmlAsText@@ -57,7 +60,7 @@   K.addMarkDown "## An example hvega visualization"   _ <- K.addHvega Nothing (Just "From the cars data-set") exampleVis   K.addMarkDown-    "## Example Diagrams visualizations, the lsecond using the plots library."+    "## Example Diagrams visualizations, the second using the plots library."   K.logLE K.Info "adding a Diagrams example and plots example..."   _ <- K.addDiagramAsSVG Nothing (Just "Example diagram") 300 300 exampleDiagram   _ <- K.addDiagramAsSVG

@@ -4,12 +4,12 @@ -- -- see: https://github.com/sol/hpack ----- hash: fc512e9236fe676c2be3010fe2354011663fe3c2e4c1cd9703f1f0c0bf9194e2+-- hash: f84555425a577ba3122d3c52935bc2ea4bfb22a0ab91de305fa9ed20849ffefa  name:           knit-haskell-version:        0.7.0.0+version:        0.8.0.0 synopsis:       a minimal Rmarkdown sort-of-thing for haskell, by way of Pandoc-description:    knit-haskell is a beginning attempt at bringing some of the benefits of Rmarkdown to Haskell. It includes an effects stack (using <https://github.com/isovector/polysemy#readme polysemy> rather than mtl) which includes logging, a simplified interface to Pandoc and various writer-like effects to intersperse document building with regular code. Various helper functions are provided to simplify common operations, making it especially straightforward to build an HTML document from bits of markdown, latex and <http://hackage.haskell.org/package/lucid Lucid> or <http://hackage.haskell.org/package/blaze-html Blaze> html. Support is also included for including <http://hackage.haskell.org/package/hvega hvega> visualizations and diagrams from the <https://archives.haskell.org/projects.haskell.org/diagrams/ diagrams> package. More information is available in the <https://github.com/adamConnerSax/knit-haskell/blob/master/Readme.md readme>.+description:    knit-haskell is a beginning attempt at bringing some of the benefits of Rmarkdown to Haskell. It includes an effects stack (using <https://github.com/isovector/polysemy#readme polysemy> rather than mtl) which includes logging, a simplified interface to Pandoc and various writer-like effects to intersperse document building with regular code. Also included is a cache (in-memory and persisted to disk) to make caching results of long running computations simple. The cache provides tools for basic dependency tracking. Various helper functions are provided to simplify common operations, making it especially straightforward to build an HTML document from bits of markdown, latex and <http://hackage.haskell.org/package/lucid Lucid> or <http://hackage.haskell.org/package/blaze-html Blaze> html. Support is also included for including <http://hackage.haskell.org/package/hvega hvega> visualizations and diagrams from the <https://archives.haskell.org/projects.haskell.org/diagrams/ diagrams> package. More information is available in the <https://github.com/adamConnerSax/knit-haskell/blob/master/Readme.md readme>. bug-reports:    https://github.com/adamConnerSax/knit-haskell/issues license:        BSD3 license-file:   LICENSE@@ -42,13 +42,15 @@ library   ghc-options: -Wall -fno-warn-unused-top-binds -funbox-strict-fields -fplugin=Polysemy.Plugin   exposed-modules:+      Knit.Effect.AtomicCache+      Knit.Effect.Serialize       Knit.Effect.Logger       Knit.Effect.Docs-      Knit.Effect.Html       Knit.Effect.PandocMonad       Knit.Effect.Pandoc       Knit.Effect.UnusedId       Knit.Report+      Knit.Report.Cache       Knit.Report.Input.Table.Colonnade       Knit.Report.Input.Html       Knit.Report.Input.Html.Lucid@@ -61,47 +63,119 @@       Knit.Report.Output.Html       Knit.Report.Other.Lucid       Knit.Report.Other.Blaze+      Knit.Utilities.Streamly   other-modules:+      Knit.Effect.Html+      Knit.Report.EffectStack+      Knit.Report.Error+      Streamly.External.Cereal       Paths_knit_haskell   build-depends:       Glob >=0.10.0 && <0.11.0     , aeson-pretty >=0.8.7 && <0.9-    , base >=4.12.0 && <4.13-    , base64-bytestring >=1.0.0.2 && <1.1.0.0-    , blaze-colonnade >=1.2.2 && <1.3.0.0+    , base >=4.12.0 && <4.15+    , base64-bytestring >=1.0.0.2 && <1.2+    , blaze-colonnade >=1.2.2 && <1.3     , blaze-html >=0.9.1 && <0.10     , bytestring >=0.10.8 && <0.11-    , case-insensitive >=1.2.0.11 && <1.3.0.0+    , case-insensitive >=1.2.0.11 && <1.3+    , cereal >=0.5.7 && <0.6     , colonnade >=1.1 && <1.3-    , constraints >=0.10 && <0.12+    , constraints >=0.10 && <0.13     , containers >=0.5.0 && <0.7     , diagrams-lib >=1.4 && <1.5.0.0     , diagrams-svg >=1.4.1 && <1.5.0.0     , directory >=1.3.3.0 && <1.4.0.0-    , http-client >=0.6.4 && <0.7.0-    , http-client-tls >=0.3.5.3 && <0.4.0.0-    , http-types >=0.12.3 && <0.13.0-    , hvega >=0.2.0 && <=0.5-    , logging-effect >=1.3.3 && <1.4+    , doctemplates >=0.2 && <0.9+    , exceptions >=0.10.0 && <0.11+    , http-client >=0.6.4 && <0.8+    , http-client-tls >=0.3.5.3 && <0.4+    , http-types >=0.12.3 && <0.13+    , hvega >=0.2.0 && <0.11     , lucid >=2.9.11 && <2.10+    , monad-control >=1.0.2 && <1.1     , mtl >=2.2.2 && <2.3-    , network >=2.8.0.0 && <3.2.0.0-    , network-uri >=2.6.1.0 && <2.7.0.0-    , pandoc >=2.7.2 && <2.8-    , polysemy >=1.0.0.0 && <1.3-    , polysemy-plugin >=0.2.0.0 && <0.3.0.0-    , polysemy-zoo >=0.6.0 && <0.7-    , prettyprinter >=1.2.1 && <1.4-    , random >=1.1 && <1.2-    , random-fu >=0.2.7 && <0.3-    , random-source >=0.3.0 && <0.4+    , network >=2.8.0.0 && <3.2+    , network-uri >=2.6.1.0 && <2.8+    , pandoc >=2.7.2 && <2.11+    , polysemy >=1.3.0 && <1.4+    , polysemy-plugin >=0.2.0.0 && <0.3+    , polysemy-zoo >=0.6.0 && <0.8+    , prettyprinter >=1.2.1 && <1.7+    , random >=1.1 && <1.3+    , say >=0.1.0 && <0.2+    , stm >=2.4.5.1 && <2.6+    , streamly >=0.7.2 && <0.7.3+    , streamly-bytestring >=0.1.0 && <0.2     , svg-builder >=0.1.1 && <0.2     , text >=1.2.3 && <1.3     , time >=1.8.0 && <2.0.0+    , transformers-base >=0.4.5 && <0.5   hs-source-dirs:       src   default-language: Haskell2010 +test-suite AsyncExample+  type: exitcode-stdio-1.0+  main-is: AsyncExample.hs+  hs-source-dirs:+      examples+  ghc-options: -fplugin=Polysemy.Plugin -threaded+  build-depends:+      base+    , blaze-html+    , containers+    , here+    , hvega+    , knit-haskell+    , plots+    , polysemy+    , polysemy-plugin+    , text+  default-language: Haskell2010++test-suite CacheExample+  type: exitcode-stdio-1.0+  main-is: CacheExample.hs+  hs-source-dirs:+      examples+  ghc-options: -fplugin=Polysemy.Plugin -threaded+  build-depends:+      base+    , blaze-html+    , containers+    , here+    , hvega+    , knit-haskell+    , plots+    , polysemy+    , polysemy-plugin+    , streamly+    , text+  default-language: Haskell2010++test-suite CacheExample2+  type: exitcode-stdio-1.0+  main-is: CacheExample2.hs+  hs-source-dirs:+      examples+  ghc-options: -fplugin=Polysemy.Plugin -threaded+  build-depends:+      base+    , blaze-html+    , bytestring+    , containers+    , here+    , hvega+    , knit-haskell+    , plots+    , polysemy+    , polysemy-plugin+    , store+    , streamly+    , text+  default-language: Haskell2010+ test-suite ErrorExample   type: exitcode-stdio-1.0   main-is: ErrorExample.hs@@ -176,7 +250,7 @@     , polysemy     , polysemy-RandomFu >=0.4.0 && <0.5     , polysemy-plugin-    , random-fu >=0.2.7.0+    , random-fu >=0.2.7.3 && <0.3     , random-source >=0.3.0.6     , text   default-language: Haskell2010

@@ -0,0 +1,767 @@+{-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE ConstraintKinds     #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE DeriveFunctor       #-}+{-# LANGUAGE PolyKinds           #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE LambdaCase          #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell     #-}+{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE TypeFamilies        #-}+{-# LANGUAGE TypeOperators       #-}+{-# OPTIONS_GHC -O2 -fdicts-strict -fspec-constr-recursive=16 -fmax-worker-args=16 #-} -- for Streamly+{-|+Module      : Knit.Effect.AtomicCache+Description : Effect for managing a persistent cache of serializable things to avoid redoing computations+Copyright   : (c) Adam Conner-Sax 2019+License     : BSD-3-Clause+Maintainer  : adam_conner_sax@yahoo.com+Stability   : experimental++This module defines a key/value store (Polysemy) effect. Rather than return the usual @Maybe v@ from a lookup,+the cache returns a @Maybe (WithCacheTime v)@, where @WithCacheTime a@ wraps a value of type a along with a+time-stamp (of type @UTCTime@). This module provides a thread-safe in-memory implementation as well as+a disk-based persistent implementation and a combination of the two, where the disk-based layer sits behind the+in-memory layer.  In our use case, the stored values will be arrays of bytes, the result of serializing+whatever data we wish to cache.++@WithCacheTime@ is intended to simplify tracking dependencies among cached computations.  For example, imagine+you have two long running computations which you wish to cache so you need only run those computations once:++@+computeA :: m a+computeA = ...++computeB :: m b+computeB = ...++cachedA :: WithCacheTime m a +cachedA :: retrieveOrMake serialize "a.bin" (pure ()) (const computeA)++cachedB :: WithCacheTime m b+cachedB = retrieveOrMake serialize "b.bin" (pure ()) (const computeB)+@++and you have a computation which depends on @a@ and @b@ and should also be cached, but we+want to make sure it gets recomputed if either @a@ or @b@ do. We use the applicative instance of+@WithCacheTime@ to combine cached results into and inject them into later computations while+taking into account the newest time-stamp among the dependencies:++@+computeC :: a -> b -> m c+computeC a b = ...++cDeps :: WithCachedTime m (a, b)+cDeps = (,) <$> cachedA \<*\> cachedB++cachedC :: WithCacheTime m c+cachedC = retrieveOrMake serialize "c.bin" cDeps $ \\(a, b) -> computeC a b+@++As with @cachedA@ and @cachedB@, @cachedC@ will run the computation if the key, "c.bin" in this case,+is absent from the cache.+In addition, @cachedC@ will be recomputed even if it is in the cache, if the time-stamp of the cached value+is older than either the time stamp of @cachedA@ or @cachedB@.++@WithCacheTime m a@ holds the time-stamp and a monadic computation which will produce an @a@. This allows+deferral of the deserialization of cached data until we know that we need to use it.  In the example above,+suppose @a@ is retrieved from cache, and @b@ is computed fresh.  @cachedA@ holds a timestamp+(the modification time of the file in cache or the time a was cached in memory) and a monadic+computation which will deserialize the cached byte array retrieved for a.  @cachedB@ holds a time-stamp+(the time the computation of b completes) and the trivial monadic action @return b@.  Since @b@ was+just computed, the cached @c@ is outdated and will be recomputed.  At that point @a@ is deserialized, @b@+is unwrapped and thse are given to the function to compute @c@, which is then +stored in cache as well as returned in the @WithCacheTime m c@, holding a new time-stamp.++If multiple threads attempt to lookup or 'retrieveOrMake' at the same key+at close to the same time, the first request will proceed,+loading from cache if possible, and the other threads will block until+the in-memory cache is populated or the first thread fails to fill in data.++This is intended to save CPU in the relatively common case that, e.g., several threads+are launched to analyze the same data.  The functions which load that data+from on-disk-cache or produce it from other analyses need only be run once.  Using the cache+to facilitate this sharing still requires each thread to deserialize the data.  If that cost is+significant, you may want to compute the data before launching the threads.++NB: Should the action given to create the data, the @(b -> m a)@ argument of 'retrieveOrMake' somehow+fail, this may lead to a situation where it runs on the first thread, fails, then runs on all the other threads+simultaneously, presumably failing all those times as well.  ++<https://github.com/adamConnerSax/knit-haskell/tree/master/examples Examples> are available, and might be useful for seeing how all this works.+-}+module Knit.Effect.AtomicCache+  (+    -- * Effect+    Cache+    -- * Time Stamps+    -- ** Types+  , WithCacheTime+  , ActionWithCacheTime+    -- ** Constructors+  , withCacheTime+  , onlyCacheTime+    -- ** Combinators+  , ignoreCacheTime+  , ignoreCacheTimeM+  , cacheTime+    -- ** Utilities+  , wctMapAction  +    -- ** Cache Actions+  , encodeAndStore+  , retrieveAndDecode+  , lookupAndDecode+  , retrieveOrMake+  , clear+  , clearIfPresent+    -- * Effect Interpretations+    -- ** Persist To Disk+  , persistStreamlyByteArray+  , persistLazyByteString+  , persistStrictByteString+    -- ** Thread-safe Map+  , AtomicMemCache+  , runAtomicInMemoryCache+    -- ** Combined Map/Disk+  , runBackedAtomicInMemoryCache+  , runPersistenceBackedAtomicInMemoryCache+  , runPersistenceBackedAtomicInMemoryCache'+    -- * Exceptions+  , CacheError(..)+  )+where++import qualified Polysemy                      as P+import qualified Polysemy.Error                as P+import qualified Knit.Effect.Logger            as K+import qualified Knit.Effect.Serialize         as KS++import qualified Data.ByteString               as BS+import qualified Data.ByteString.Lazy          as BL+import           Data.Functor.Identity          (Identity(..))+import qualified Data.Map                      as M+import qualified Data.Text                     as T+import qualified Data.Time.Clock               as Time+import qualified Data.Word                     as Word++import qualified Control.Concurrent.STM        as C+import qualified Control.Exception             as Exception+import           Control.Monad                  ( join )++import qualified Streamly.Internal.Memory.Array    as Streamly.Array+import qualified Streamly.Internal.FileSystem.File as Streamly.File++import qualified System.Directory              as System+import qualified System.IO.Error               as IO.Error+++{- TODO:+1. Can this design be simplified, part 1. The Maybe in the TMVar seems like it should be uneccessary.+2. It'd be nice to make sure we can't leave the empty TMVar. Can this be done in a way so that it must be filled?+3. We should be able to factor out some things around handling the returned TMVar+-}+-- | Error Type for Cache errors.  Simplifies catching and reporting them.+data CacheError =+  ItemNotFoundError T.Text+  | ItemTooOldError T.Text+  | DeSerializationError T.Text+  | PersistError T.Text+  | OtherCacheError T.Text deriving (Show, Eq)++-- | Wrapper to hold (deserializable, if necessary) content and a timestamp.+-- The stamp must be at or after the time the data was constructed+data WithCacheTime m a where+  WithCacheTime :: Maybe Time.UTCTime -> m a -> WithCacheTime m a+  deriving (Show)++instance Functor m => Functor (WithCacheTime m) where+  fmap f (WithCacheTime tM ma) = WithCacheTime tM (fmap f ma)+  {-# INLINE fmap #-}+  +instance Applicative m => Applicative (WithCacheTime m) where+  pure x = WithCacheTime Nothing (pure x)+  {-# INLINE pure #-}+  WithCacheTime t1M mf <*> WithCacheTime t2M ma = WithCacheTime (max t1M t2M) (mf <*> ma)+  {-# INLINE (<*>) #-}+{-+NB: The applicative instance allows merging dependencies+for passing to things which need them+as in:+let cachedDeps = (,,) <$> cached1 <*> cached2 <*> cached3++NB: There is no Monad instance for WithCacheTime.  We would need+'join :: WithCacheTime t1M (m (WithCacheTime t2M (m b)) -> WithCacheTime (max t1M t2M) (m b)+but we cannot get t2M "outside" m.+-}++-- | Specialize `WithCacheTime` for use with a Polysemy effects stack.+type ActionWithCacheTime r a = WithCacheTime (P.Sem r) a++-- | Construct a WithCacheTime with a time and no action.  +onlyCacheTime :: Applicative m => Maybe Time.UTCTime -> WithCacheTime m ()+onlyCacheTime tM = WithCacheTime tM (pure ())+{-# INLINEABLE onlyCacheTime #-}++-- | Construct a WithCacheTime from a @Maybe Time.UTCTime@ and an action.+withCacheTime :: Maybe Time.UTCTime -> m a -> WithCacheTime m a+withCacheTime = WithCacheTime+{-# INLINEABLE withCacheTime #-}++-- | Map one type of action to another via a natural transformation.+-- Specifically useful for mapping from @WithCacheTime Identity a@+-- to @WithCacheTime m a@+wctApplyNat :: (forall a. f a -> g a) -> WithCacheTime f b -> WithCacheTime g b+wctApplyNat nat (WithCacheTime tM fb) = WithCacheTime tM (nat fb)+{-# INLINEABLE wctApplyNat #-}++-- | Map one type of action to another.  NB: 'WithCacheTime m' is a functor+-- (as long as @m@ is), so if @m@ is not changing, you should prefer 'fmap'+-- to this function.  +wctMapAction :: (m a -> n b) -> WithCacheTime m a -> WithCacheTime n b+wctMapAction f (WithCacheTime tM ma) = WithCacheTime tM (f ma)+{-# INLINEABLE wctMapAction #-}++-- | natural transformation which is useful for interoperation between+-- the cache storage and the values returned to the user.+toSem :: Identity a -> P.Sem r a+toSem = pure . runIdentity+{-# INLINE toSem #-}++-- | Access the computation part of a @WithCacheTime a@. This or+-- 'ignoreCacheTimeM' is required to use the cached value as anything but input+-- to another cached computation.+ignoreCacheTime :: WithCacheTime m a -> m a+ignoreCacheTime (WithCacheTime _ ma) = ma+{-# INLINEABLE ignoreCacheTime #-}++-- | Access the computation part of an @m (WithCacheTime a)@. This or+-- 'ignoreCacheTime' is required to use the cached value as anything but input+-- to another cached computation.+ignoreCacheTimeM :: Monad m => m (WithCacheTime m a) -> m a+ignoreCacheTimeM = join . fmap ignoreCacheTime+{-# INLINEABLE ignoreCacheTimeM #-}++-- | Access the @Maybe Time.UTCTime@ part of a 'WithCacheTime'+cacheTime :: WithCacheTime m a -> Maybe Time.UTCTime+cacheTime (WithCacheTime tM _) = tM+{-# INLINEABLE cacheTime #-}++-- | Key/Value store effect requiring its implementation to return values with time-stamps.+data Cache k v m a where+  CacheLookup :: k -> Cache k v m (Maybe (WithCacheTime Identity v))+  CacheUpdate :: k -> Maybe v -> Cache k v m () -- NB: this requires some way to attach a cache time during update+  +P.makeSem ''Cache++debugLogSeverity :: K.LogSeverity+debugLogSeverity  = K.Debug 3+{-# INLINE debugLogSeverity #-}++-- | Combine the action of serializing and caching+encodeAndStore+  :: ( Show k+     , P.Member (Cache k ct) r+     , K.LogWithPrefixesLE r+     )+  => KS.Serialize CacheError r a ct -- ^ Record-Of-Functions for serialization/deserialization+  -> k                              -- ^ Key+  -> a                              -- ^ Data to encode and cache+  -> P.Sem r ()+encodeAndStore (KS.Serialize encode _ encBytes) k x =+  K.wrapPrefix ("AtomicCache.encodeAndStore (key=" <> (T.pack $ show k) <> ")") $ do+    K.logLE K.Diagnostic $ "encoding (serializing) data for key=" <> (T.pack $ show k) +    encoded <- fst <$> encode x+    let nBytes = encBytes encoded+    K.logLE K.Diagnostic $ "Storing " <> (T.pack $ show nBytes) <> " bytes of encoded data in cache for key=" <> (T.pack $ show k) +    cacheUpdate k (Just encoded)+{-# INLINEABLE encodeAndStore #-}++-- | Lookup key and, if that fails, run an action to update the cache.+-- Further, if the item is in cache, but older than time-stamp of the+-- supplied 'ActionWithCacheTime r b', this function calls the given+-- @b -> P.Sem r (Maybe a)@ with the cached value from the supplied+-- 'ActionWithCacheTime m b'.++-- TODO: We need some exception handling here to make sure, in the case of an Atomic cache,+-- the TMVar gets filled somehow and the key deleted from cache.+-- NB: This returns an action with the cache time and another action to get the data.  This allows us+-- to defer deserialization (and maybe loading??) until we actually want to use the data...++-- IDEA: when too old, make new, retrieve old and compare?  If same, use older date? Costs time, but saves downstream rebuilds.+retrieveOrMakeAndUpdateCache+  :: forall ct k r b a.+     ( P.Members [Cache k ct, P.Embed IO] r+     ,  K.LogWithPrefixesLE r+     , Show k+     )+  => KS.Serialize CacheError r a ct            -- ^ Record-Of-Functions for serialization/deserialization+  -> (b -> P.Sem r (Maybe a))                  -- ^ Computation to run to make @a@ if cache is empty or expired.+  -> k                                         -- ^ Key+  -> ActionWithCacheTime r b                   -- ^ Cached dependencies of the computation.+  -> P.Sem r (Maybe (ActionWithCacheTime r a)) -- ^ Result of lookup or running computation, wrapped as 'ActionWithCacheTime'. Returns 'Nothing" if lookup fails.+retrieveOrMakeAndUpdateCache (KS.Serialize encode decode encBytes) tryIfMissing key (WithCacheTime newestM bA) =+  K.wrapPrefix ("AtomicCache.retrieveOrMakeAndUpdateCache (key=" <> (T.pack $ show key) <> ")") $ do+    let+      makeAndUpdate :: P.Sem r (Maybe (ActionWithCacheTime r a))+      makeAndUpdate = do+        K.logLE debugLogSeverity $ "key=" <> (T.pack $ show key) <> ": Trying to make from given action."+        K.logLE debugLogSeverity $ "key=" <> (T.pack $ show key) <> ": running actions for dependencies."+        b <- bA+        K.logLE debugLogSeverity $ "key=" <> (T.pack $ show key) <> ": making new item."+        ma <- tryIfMissing b+        case ma of+          Nothing -> do+            K.logLE K.Error $ "key=" <> (T.pack $ show key) <> ": Making failed."+            cacheUpdate key Nothing+            return Nothing+          Just a -> do+            K.logLE debugLogSeverity $ "key=" <> (T.pack $ show key) <> ": Making/Encoding..."+            (ct', a') <- encode a -- a' is the buffered version of a (if necessary)+            let nBytes = encBytes ct'+            K.logLE debugLogSeverity $ "key=" <> (T.pack $ show key) <> ": serialized to " <> (T.pack $ show nBytes) <> " bytes."+            K.logLE debugLogSeverity $ "Updating cache..."          +            cacheUpdate key (Just ct') +            curTime <- P.embed Time.getCurrentTime -- Should this come from the cache so the times are the same?  Or is it safe enough that this is later?+            K.logLE debugLogSeverity $ "Finished making and updating."          +            return $ Just (WithCacheTime (Just curTime) (return a'))+    fromCache <- cacheLookup key+    case fromCache of+      Just (WithCacheTime cTimeM mct) -> do+        if cTimeM >= newestM --maybe True (\newest -> cTimeM > newest) newestM+          then do+            let ct = runIdentity mct -- we do this out here only because we want the length.  We could defer this unpacking to the decodeAction+            let nBytes = encBytes ct+            K.logLE K.Diagnostic $ "key=" <> (T.pack $ show key) <> ": Retrieved " <> (T.pack $ show nBytes) <> " bytes from cache."+            let decodeAction :: P.Sem r a+                decodeAction = do+                   K.logLE debugLogSeverity $ "key=" <> (T.pack $ show key) <> ": deserializing."  +                   a <- decode ct -- a <- mct >>= decode+                   K.logLE debugLogSeverity $ "key=" <> (T.pack $ show key) <> ": deserializing complete."  +                   return a+            return (Just $ WithCacheTime cTimeM decodeAction)             +          else do+            K.logLE K.Diagnostic $ "key=" <> (T.pack $ show key) <> ": Item in cache too old. Making new."+            makeAndUpdate+      Nothing -> do+        K.logLE K.Diagnostic $ "key=" <> (T.pack $ show key) <> ": Item not found in cache. Making new."+        makeAndUpdate+{-# INLINEABLE retrieveOrMakeAndUpdateCache #-}  ++-- | Combine the action of retrieving from cache and deserializing.+-- | Throws if item not found or any other error during retrieval+retrieveAndDecode+  :: forall ct k r a .+     (P.Member (Cache k ct) r+     , P.Member (P.Embed IO) r+     , P.MemberWithError (P.Error CacheError) r+     , K.LogWithPrefixesLE r+     , Show k+     )+  => KS.Serialize CacheError r a ct    -- ^ Record-Of-Functions for serialization/deserialization+  -> k                                 -- ^ Key+  -> Maybe Time.UTCTime                -- ^ 'Time.UTCTime' which cached data must be newer than.  Use 'Nothing' if any cached data is acceptable.+  -> P.Sem r (ActionWithCacheTime r a) -- ^ Result of lookup or running computation, wrapped as 'ActionWithCacheTime'. Throws 'CacheError' if lookup fails.+retrieveAndDecode s k newestM = K.wrapPrefix ("AtomicCache.retrieveAndDecode (key=" <> (T.pack $ show k) <> ")") $ do+  fromCache <- retrieveOrMakeAndUpdateCache s (const $ return Nothing) k (onlyCacheTime newestM)+  case fromCache of+    Nothing -> P.throw $ ItemNotFoundError $ "No item found/item too old for key=" <> (T.pack $ show k) <> "."+    Just x -> return x+{-# INLINEABLE retrieveAndDecode #-}++-- | Combine the action of retrieving from cache and deserializing.+-- | Returns @Nothing@ if item not found, and throws on any other error.+lookupAndDecode+  :: forall ct k r a+   . ( P.Member (Cache k ct) r+     , K.LogWithPrefixesLE r+     , P.Member (P.Embed IO) r+     , P.MemberWithError (P.Error CacheError) r+     , Show k+     )+  => KS.Serialize CacheError r a ct            -- ^ Record-Of-Functions for serialization/deserialization+  -> k                                         -- ^ Key+  -> Maybe Time.UTCTime                        -- ^ 'Time.UTCTime' which cached data must be newer than.  Use 'Nothing' if any cached data is acceptable.+  -> P.Sem r (Maybe (ActionWithCacheTime r a)) -- ^ Result of lookup or running computation, wrapped as 'ActionWithCacheTime'. Returns 'Nothing" if lookup fails.+lookupAndDecode s k newestM = K.wrapPrefix ("AtomicCache.lookupAndDecode (key=" <> (T.pack $ show k) <> ")")+                              $ retrieveOrMakeAndUpdateCache s (const $ return Nothing) k (onlyCacheTime newestM)+{-# INLINEABLE lookupAndDecode #-}++-- | Lookup key and, if that fails, run an action to update the cache.+-- Further, if the item is in cache, but older than time-stamp of the+-- supplied 'ActionWithCacheTime r b', this function calls the given+-- @b -> P.Sem r (Maybe a)@ with the cached value from the supplied+-- 'ActionWithCacheTime m b'.+--  Throws if item not found *and* making fails.+retrieveOrMake+  :: forall ct k r a b.+     ( P.Member (Cache k ct) r+     , K.LogWithPrefixesLE r+     , P.Member (P.Embed IO) r+     , P.MemberWithError (P.Error CacheError) r+     , Show k+     )+  => KS.Serialize CacheError r a ct      -- ^ Record-Of-Functions for serialization/deserialization+  -> k                                   -- ^ Key +  -> ActionWithCacheTime r b             -- ^ Cached Dependencies+  -> (b -> P.Sem r a)                    -- ^ Computation to produce @a@ if lookup fails.+  -> P.Sem r (ActionWithCacheTime r a)   -- ^ Result of lookup or running computation, wrapped as 'ActionWithCacheTime'+retrieveOrMake s key cachedDeps makeAction = K.wrapPrefix ("retrieveOrMake (key=" <> (T.pack $ show key) <> ")") $ do+  let makeIfMissing x = K.wrapPrefix "retrieveOrMake.makeIfMissing" $ do+        K.logLE debugLogSeverity $ "Item (at key=" <> (T.pack $ show key) <> ") not found/too old. Making..."+        fmap Just $ makeAction x+  fromCache <- retrieveOrMakeAndUpdateCache s makeIfMissing key cachedDeps +  case fromCache of+    Just x -> return x+    Nothing -> P.throw $ OtherCacheError $ "retrieveOrMake returned with Nothing.  Which should be impossible, unless called with action which produced Nothing."+{-# INLINEABLE retrieveOrMake #-}++-- | Clear the cache at a given key.  Throws an exception if item is not present.+clear :: P.Member (Cache k ct) r => k -> P.Sem r ()+clear k = cacheUpdate k Nothing+{-# INLINEABLE clear #-}++-- | Clear the cache at a given key.  Doesn't throw if item is missing.+clearIfPresent :: (P.Member (Cache k ct) r, P.MemberWithError (P.Error CacheError) r) => k -> P.Sem r ()+clearIfPresent k = cacheUpdate k Nothing `P.catch` (\(_ :: CacheError) -> return ())+{-# INLINEABLE clearIfPresent #-}++-- structure for in-memory atomic cache+-- outer TVar so only one thread can get the inner TMVar at a time+-- TMVar so we can block if mulitple threads are trying to read or update+-- the @Maybe@ inside so we can notify waiting threads that whatever they were waiting on+-- to fill the TMVar failed.++-- | Specific type of in-memory cache.  +type AtomicMemCache k v = C.TVar (M.Map k (C.TMVar (Maybe (WithCacheTime Identity v))))++-- | lookup combinator for in-memory AtomicMemCache+atomicMemLookup :: (Ord k+                   , Show k+                   , P.Member (P.Embed IO) r+                   , K.LogWithPrefixesLE r+                   )+              => AtomicMemCache k ct+              -> k+              -> P.Sem r (Maybe (WithCacheTime Identity ct))+atomicMemLookup cache key = K.wrapPrefix "atomicMemLookup" $ do+  K.logLE debugLogSeverity $ "key=" <> (T.pack $ show key) <> ": Called."+  P.embed $ C.atomically $ do+    mv <- (C.readTVar cache >>= fmap join . traverse C.readTMVar . M.lookup key)+    case mv of+      Just wctv -> return $ Just wctv+      Nothing -> do+        newTMV <- C.newEmptyTMVar+        C.modifyTVar cache (M.insert key newTMV)+        return Nothing+{-# INLINEABLE atomicMemLookup #-}++-- | data type to simplify logging in AtomicMemCache updates+data MemUpdateAction = Deleted | Replaced | Filled deriving (Show)++-- | update combinator for in-memory AtomicMemCache+atomicMemUpdate :: (Ord k+                   , Show k+                   , P.Member (P.Embed IO) r+                   , K.LogWithPrefixesLE r+                   )+                => AtomicMemCache k ct+                -> k+                -> Maybe ct+                -> P.Sem r ()+atomicMemUpdate cache key mct =+  K.wrapPrefix "atomicMemUpdate" $ do+  let keyText = "key=" <> (T.pack $ show key) <> ": "+  K.logLE debugLogSeverity $ keyText <> "called."+  updateAction <- case mct of+    Nothing -> (P.embed $ C.atomically $ C.modifyTVar cache (M.delete key)) >> return Deleted+    Just ct -> do+      curTime <- P.embed Time.getCurrentTime+      let wct = WithCacheTime (Just curTime) (Identity ct)+      P.embed $ C.atomically $ do+        m <- C.readTVar cache+        case M.lookup key m of+          Nothing -> do+            newTMV <- C.newTMVar (Just wct)+            C.modifyTVar cache (M.insert key newTMV)+            return Filled+          Just tmvM -> do+            wasEmptyTMVar <- C.tryPutTMVar tmvM (Just wct)+            if wasEmptyTMVar+              then return Filled+              else (C.swapTMVar tmvM (Just wct)) >> return Replaced+  case updateAction of+    Deleted -> K.logLE debugLogSeverity $ keyText <> "deleted"+    Replaced -> K.logLE debugLogSeverity $ keyText <> "replaced"+    Filled -> K.logLE debugLogSeverity $ keyText <> "filled"+{-# INLINEABLE atomicMemUpdate #-}++-- | Interpreter for in-memory only AtomicMemCache+runAtomicInMemoryCache :: (Ord k+                          , Show k+                          , P.Member (P.Embed IO) r+                          , K.LogWithPrefixesLE r+                          )+                       => AtomicMemCache k ct+                       -> P.InterpreterFor (Cache k ct) r+runAtomicInMemoryCache cache =+  P.interpret $ \case+    CacheLookup key -> atomicMemLookup cache key+    CacheUpdate key mct -> atomicMemUpdate cache key mct+{-# INLINEABLE runAtomicInMemoryCache #-}+++-- Backed by Another Cache+-- lookup is the hard case.  If we don't find it, we want to check the backup cache+-- and fill in this cache from there, if possible+-- | lookup for an AtomicMemCache which is backed by some other cache, probably a persistence layer.+atomicMemLookupB :: (Ord k+                    , P.Members '[P.Embed IO, Cache k ct] r+                    , K.LogWithPrefixesLE r+                    , Show k+                    )+                 =>  AtomicMemCache k ct+                 -> k+                 -> P.Sem r (Maybe (WithCacheTime Identity ct))+atomicMemLookupB cache key = K.wrapPrefix "atomicMemLookupB" $ do+  let keyText = "key=" <> (T.pack $ show key) <> ": "+  K.logLE debugLogSeverity $ keyText <> "checking in mem cache..."+  x <- P.embed $ C.atomically $ do+    mTMV <- M.lookup key <$> C.readTVar cache+    case mTMV of+      Just tmv -> do+        mv <- C.takeTMVar tmv  +        case mv of+          Just wct -> do -- in cache with value (and time)+            C.putTMVar tmv (Just wct)+            return $ Right wct+          Nothing -> return $ Left tmv  -- in cache but set to Nothing+      Nothing -> do -- not found+        newTMV <- C.newEmptyTMVar+        C.modifyTVar cache (M.insert key newTMV)+        return $ Left newTMV+  case x of+    Right wct -> K.logLE debugLogSeverity (keyText <> "found.") >> return (Just wct)+    Left emptyTMV -> do+      K.logLE debugLogSeverity (keyText <> "not found.  Holding empty TMVar. Checking backup cache...")+      inOtherM <- cacheLookup key      +      case inOtherM of+        Nothing -> K.logLE debugLogSeverity (keyText <> "not found in backup cache.") >> return Nothing+        Just (WithCacheTime tM mct) -> do+          K.logLE debugLogSeverity (keyText <> "Found in backup cache.  Filling empty TMVar.")+          let ct = runIdentity mct+          P.embed $ C.atomically $ C.putTMVar emptyTMV (Just $ WithCacheTime tM (Identity ct)) +          K.logLE debugLogSeverity (keyText <> "Returning")+          return $ Just $ WithCacheTime tM (pure ct) +{-# INLINEABLE atomicMemLookupB #-}++-- | update for an AtomicMemCache which is backed by some other cache, probably a persistence layer.+-- This just does the update in both caches+atomicMemUpdateB ::  (Ord k+                     , Show k+                     , K.LogWithPrefixesLE r+                     , P.Members '[P.Embed IO, Cache k ct] r)+                 => AtomicMemCache k ct+                 -> k+                 -> Maybe ct+                 -> P.Sem r ()+atomicMemUpdateB cache key mct = K.wrapPrefix "atomicMemUpdateB" $ do+  let keyText = "key=" <> (T.pack $ show key) <> ": "+  K.logLE debugLogSeverity $ keyText <> "Calling atomicMemUpdate"+  atomicMemUpdate cache key mct+  K.logLE debugLogSeverity $ keyText <> "Calling cacheUpdate in backup cache."+  cacheUpdate key mct+{-# INLINEABLE atomicMemUpdateB #-}++-- | interpret Cache via a different-Cache-backed AtomicMemCache+runBackedAtomicInMemoryCache :: (Ord k+                                , Show k+                                , K.LogWithPrefixesLE r+                                , P.Members '[P.Embed IO, Cache k ct] r+                                )+                             => AtomicMemCache k ct+                             -> P.InterpreterFor (Cache k ct) r+runBackedAtomicInMemoryCache cache =+  P.interpret $ \case+    CacheLookup k -> atomicMemLookupB cache k+    CacheUpdate k mct -> atomicMemUpdateB cache k mct+{-# INLINEABLE runBackedAtomicInMemoryCache #-}++-- | re-interpret Cache, using AtomicMemCache for in-memory store, into another cache, usually a persistent store.+backedAtomicInMemoryCache :: (Ord k+                             , Show k+                             , P.Member (P.Embed IO) r+                             , K.LogWithPrefixesLE r+                             )+                          => AtomicMemCache k ct+                          -> P.Sem ((Cache k ct) ': r) a+                          -> P.Sem ((Cache k ct) ': r) a+backedAtomicInMemoryCache cache =+  P.reinterpret $ \case+    CacheLookup k -> atomicMemLookupB cache k+    CacheUpdate k mct -> atomicMemUpdateB cache k mct    +{-# INLINEABLE backedAtomicInMemoryCache #-} +++-- | Interpret Cache via AtomicMemCache and an interpreter for a backing cache,+-- usually a persistence layer.+runPersistenceBackedAtomicInMemoryCache :: (Ord k+                                           , Show k+                                           , P.Member (P.Embed IO) r+                                           , P.MemberWithError (P.Error CacheError) r+                                           , K.LogWithPrefixesLE r+                                           )+                                        => P.InterpreterFor (Cache k ct) r -- persistence layer interpreter+                                        -> AtomicMemCache k ct+                                        -> P.InterpreterFor (Cache k ct) r+runPersistenceBackedAtomicInMemoryCache runPersistentCache cache = runPersistentCache . backedAtomicInMemoryCache cache+{-# INLINEABLE runPersistenceBackedAtomicInMemoryCache #-}++-- | Interpret Cache via AtomicMemCache and an interpreter for a backing cache,+-- usually a persistence layer.  Create a new, empty, AtomicMemCache to begin.+runPersistenceBackedAtomicInMemoryCache' :: (Ord k+                                            , Show k+                                            , P.Member (P.Embed IO) r+                                            , P.MemberWithError (P.Error CacheError) r+                                            , K.LogWithPrefixesLE r+                                            )+                                        => P.InterpreterFor (Cache k ct) r+                                        -> P.InterpreterFor (Cache k ct) r+runPersistenceBackedAtomicInMemoryCache' runPersistentCache x = do+  cache <- P.embed $ C.atomically $ C.newTVar mempty+  runPersistenceBackedAtomicInMemoryCache runPersistentCache cache x +{-# INLINEABLE runPersistenceBackedAtomicInMemoryCache' #-}++-- | Interpreter for Cache via persistence to disk as a Streamly Memory.Array (Contiguous storage of Storables) of Bytes (Word8)+persistStreamlyByteArray+  :: (Show k, P.Member (P.Embed IO) r, P.MemberWithError (P.Error CacheError) r, K.LogWithPrefixesLE r)+  => (k -> FilePath)+  -> P.InterpreterFor (Cache k (Streamly.Array.Array Word.Word8)) r+persistStreamlyByteArray keyToFilePath =+  P.interpret $ \case+    CacheLookup k -> K.wrapPrefix "persistAsByteArray.CacheLookup" $ do+      let filePath = keyToFilePath k+      getContentsWithCacheTime (Streamly.Array.fromStream . Streamly.File.toBytes) filePath+    CacheUpdate k mct -> K.wrapPrefix "persistAsByteStreamly.CacheUpdate" $ do+      let keyText = "key=" <> (T.pack $ show k) <> ": "+      case mct of+        Nothing -> do+           K.logLE debugLogSeverity $ keyText <> "called with Nothing. Deleting file."+           rethrowIOErrorAsCacheError $ System.removeFile (keyToFilePath k)+        Just ct -> do+          K.logLE debugLogSeverity $ keyText <> "called with content. Writing file."+          let filePath     = (keyToFilePath k)+              (dirPath, _) = T.breakOnEnd "/" (T.pack filePath)+          _ <- createDirIfNecessary dirPath+          K.logLE debugLogSeverity  "Writing serialization to disk."+          K.logLE debugLogSeverity $ keyText <> "Writing " <> (T.pack $ show $ Streamly.Array.length ct) <> " bytes to disk." +          rethrowIOErrorAsCacheError $ Streamly.File.writeArray filePath ct+{-# INLINEABLE persistStreamlyByteArray #-}++-- | Interpreter for Cache via persistence to disk as a strict ByteString+persistStrictByteString+  :: (P.Members '[P.Embed IO] r, P.MemberWithError (P.Error CacheError) r, K.LogWithPrefixesLE r, Show k)+  => (k -> FilePath)+  -> P.InterpreterFor (Cache k BS.ByteString) r+persistStrictByteString keyToFilePath =+  P.interpret $ \case+    CacheLookup k -> K.wrapPrefix "persistStrictByteString.CacheLookup" $ getContentsWithCacheTime BS.readFile (keyToFilePath k)+    CacheUpdate k mct -> K.wrapPrefix "persistStrictByteString.CacheUpdate" $ do+      let keyText = "key=" <> (T.pack $ show k) <> ": "+      case mct of+        Nothing -> do+          K.logLE debugLogSeverity $ keyText <> "called with Nothing. Deleting file."+          rethrowIOErrorAsCacheError $ System.removeFile (keyToFilePath k)+        Just ct -> do+          K.logLE debugLogSeverity $ keyText <> "called with content. Writing file."+          let filePath     = (keyToFilePath k)+              (dirPath, _) = T.breakOnEnd "/" (T.pack filePath)+          _ <- createDirIfNecessary dirPath+          K.logLE debugLogSeverity $ "Writing serialization to disk."+          let bsLength = BS.length ct+          K.logLE debugLogSeverity $ keyText <> "Writing " <> (T.pack $ show bsLength) <> " bytes to disk." +          rethrowIOErrorAsCacheError $ BS.writeFile filePath ct  -- maybe we should do this in another thread?+{-# INLINEABLE persistStrictByteString #-}++-- | Interpreter for Cache via persistence to disk as a lazy ByteString+persistLazyByteString+  :: (P.Members '[P.Embed IO] r, P.MemberWithError (P.Error CacheError) r, K.LogWithPrefixesLE r, Show k)+  => (k -> FilePath)+  -> P.InterpreterFor (Cache k BL.ByteString) r+persistLazyByteString keyToFilePath =+  P.interpret $ \case+    CacheLookup k -> K.wrapPrefix "persistAsLazyByteString.CacheLookup" $ getContentsWithCacheTime BL.readFile (keyToFilePath k)+    CacheUpdate k mct -> K.wrapPrefix "persistAsLazyByteString.CacheUpdate" $ do+      let keyText = "key=" <> (T.pack $ show k) <> ": "+      case mct of+        Nothing -> do+          K.logLE debugLogSeverity $ keyText <> "called with Nothing. Deleting file."+          rethrowIOErrorAsCacheError $ System.removeFile (keyToFilePath k)+        Just ct -> do+          K.logLE debugLogSeverity $ keyText <> "called with content. Writing file."+          let filePath     = (keyToFilePath k)+              (dirPath, _) = T.breakOnEnd "/" (T.pack filePath)+          _ <- createDirIfNecessary dirPath+          K.logLE debugLogSeverity  "Writing serialization to disk."+          let bsLength = BL.length ct+          K.logLE debugLogSeverity $ keyText <> "Writing " <> (T.pack $ show bsLength) <> " bytes to disk." +          rethrowIOErrorAsCacheError $ BL.writeFile filePath ct  -- maybe we should do this in another thread?+{-# INLINEABLE persistLazyByteString #-}+++createDirIfNecessary+  :: (P.Members '[P.Embed IO] r, K.LogWithPrefixesLE r)+  => T.Text+  -> P.Sem r ()+createDirIfNecessary dir = K.wrapPrefix "createDirIfNecessary" $ do+  K.logLE debugLogSeverity $ "Checking if cache path (\"" <> dir <> "\") exists."+  existsB <- P.embed $ (System.doesDirectoryExist (T.unpack dir))+  case existsB of+    True -> do+      K.logLE K.Diagnostic $ "\"" <> dir <> "\" exists."+      return ()+    False -> do+      K.logLE K.Info+        $  "Cache directory (\""+        <> dir+        <> "\") not found. Atttempting to create."+      P.embed+        $ System.createDirectoryIfMissing True (T.unpack dir)+{-# INLINEABLE createDirIfNecessary #-}+++getContentsWithCacheTime :: (P.Members '[P.Embed IO] r+                            , P.MemberWithError (P.Error CacheError) r+                            , K.LogWithPrefixesLE r)+                         => (FilePath -> IO a)+                         -> FilePath+                         -> P.Sem r (Maybe (WithCacheTime Identity a))+getContentsWithCacheTime f fp =  K.wrapPrefix "getContentsWithCacheTime" $ do+  K.logLE debugLogSeverity $ "Reading serialization from disk."+  rethrowIOErrorAsCacheError $ fileNotFoundToMaybe $ do+    ct <- f fp+    cTime <- System.getModificationTime fp+    return $ WithCacheTime (Just cTime) (Identity ct)+{-# INLINE getContentsWithCacheTime #-}++fileNotFoundToEither :: IO a -> IO (Either () a)+fileNotFoundToEither x = (fmap Right x) `Exception.catch` f where+  f :: Exception.IOException -> IO (Either () a)+  f e = if IO.Error.isDoesNotExistError e then return (Left ()) else Exception.throw e +{-# INLINEABLE fileNotFoundToEither #-}++fileNotFoundToMaybe :: IO a -> IO (Maybe a)+fileNotFoundToMaybe x = (fmap Just x) `Exception.catch` f where+  f :: Exception.IOException -> IO (Maybe a)+  f e = if IO.Error.isDoesNotExistError e then return Nothing else Exception.throw e +{-# INLINEABLE fileNotFoundToMaybe #-}+++rethrowIOErrorAsCacheError :: (P.Member (P.Embed IO) r, P.MemberWithError (P.Error CacheError) r) => IO a -> P.Sem r a+rethrowIOErrorAsCacheError x = P.fromExceptionVia (\(e :: IO.Error.IOError) -> PersistError $ "IOError: " <> (T.pack $ show e)) x+{-# INLINEABLE rethrowIOErrorAsCacheError #-}++

@@ -48,9 +48,7 @@ import           Polysemy.Internal              ( send ) import qualified Polysemy.Writer               as P -import           Control.Monad                  ( sequence-                                                , join-                                                )+import           Control.Monad                  ( join )  -- | GADT to represent storing a document and some info for processing it. data Docs i a m r where

@@ -1,9 +1,11 @@ {-# LANGUAGE ConstraintKinds       #-} {-# LANGUAGE DataKinds             #-}+{-# LANGUAGE DeriveDataTypeable    #-} {-# LANGUAGE PolyKinds             #-} {-# LANGUAGE FlexibleContexts      #-} {-# LANGUAGE FlexibleInstances     #-} {-# LANGUAGE GADTs                 #-}+{-# LANGUAGE InstanceSigs          #-} {-# LANGUAGE LambdaCase            #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings     #-}@@ -12,7 +14,6 @@ {-# LANGUAGE TypeApplications      #-} {-# LANGUAGE TypeOperators         #-} {-# LANGUAGE UndecidableInstances  #-}-{-# LANGUAGE InstanceSigs    #-} {-# OPTIONS_GHC -fwarn-incomplete-patterns #-} {-| Module      : Knit.Effect.Logger@@ -35,51 +36,57 @@    -- * Effects   , Logger(..)-  , PrefixLog+  , PrefixLog      -- * Actions   , log   , logLE   , wrapPrefix-+  , getPrefix+  , logWithPrefixToIO+     -- * Interpreters   , filteredLogEntriesToIO    -- * Subsets for filtering   , logAll+  , logDebug+  , logDiagnostic   , nonDiagnostic -  -- * Constraints for convenience +  -- * Type Synonyms and Constraints for convenience+  , PrefixedLogEffects+  , PrefixedLogEffectsLE   , LogWithPrefixes   , LogWithPrefixesLE--  -- * Re-Exports-  , Sem-  , Member-  , Handler+  , LogWithPrefixIO   ) where  import qualified Polysemy                      as P-import           Polysemy                       ( Member-                                                , Sem-                                                )+                  import           Polysemy.Internal              ( send ) import qualified Polysemy.State                as P  import           Control.Monad                  ( when ) import           Control.Monad.IO.Class         ( MonadIO(..) )-import           Control.Monad.Log              ( Handler )-import qualified Control.Monad.Log             as ML import qualified Data.List                     as List import qualified Data.Text                     as T-import qualified Data.Text.IO                  as T+import qualified Data.Text.Lazy                as LT import qualified Data.Text.Prettyprint.Doc     as PP import qualified Data.Text.Prettyprint.Doc.Render.Text                                                as PP+import           Data.Data (Data, Typeable)                                                import           Prelude                 hiding ( log ) +import           System.IO                      ( hFlush+                                                , stdout+                                                ) +import qualified Say                           as S+++ -- TODO: consider a more interesting Handler type.  As in co-log (https://hackage.haskell.org/package/co-log-core) -- where you newtype it and then can exploit its profunctoriality. -- I got lost here.  Was trying to be compatible with logging-effect but I'm not sure why@@ -89,51 +96,73 @@ -- conversion is uneccessary if we throw a message away?  But still, the interpreters could take the pretty-printers as arguments? -- Parking this for now, since it has absorbed outsize time for no benefit except some understanding. --- | Severity of message.  Based on monad-logger.-data LogSeverity = Diagnostic | Info | Warning | Error deriving (Show, Eq, Ord, Enum, Bounded)+-- | Severity/importance of message.+data LogSeverity =+  -- | Most detailed levels of logging.  Int argument can be used adding fine distinctions between debug levels.+  Debug Int+  -- | Minimal details about effects and what is being called. +  | Diagnostic+  -- | Informational messages about progress of compuation or document knitting.+  | Info+  -- | Messages intended to alert the user to an issue in the computation or document production.+  | Warning+  -- | Likely unrecoverable issue in computation or document production.+  | Error+  deriving (Show, Eq, Ord, Typeable, Data) --- | Map between @LogSeverity@ and monad-logger severity.-logSeverityToSeverity :: LogSeverity -> ML.Severity-logSeverityToSeverity Diagnostic = ML.Debug-logSeverityToSeverity Info       = ML.Informational-logSeverityToSeverity Warning    = ML.Warning-logSeverityToSeverity Error      = ML.Error+-- NB: Cribbed from monad-logger.  Thanks ocharles!+-- TODO: add colors for ansi-terminal output+instance PP.Pretty LogSeverity where+  pretty = PP.pretty . LT.pack . show --- | A basic LogEntry with a severity and a (Text) message+-- | A basic log entry with a severity and a ('Text') message data LogEntry = LogEntry { severity :: LogSeverity, message :: T.Text } --- | Convert @LogEntry@ to monad-logger style.-logEntryToWithSeverity :: LogEntry -> ML.WithSeverity T.Text-logEntryToWithSeverity (LogEntry s t) =-  ML.WithSeverity (logSeverityToSeverity s) t+-- | log everything.+logAll :: LogSeverity -> Bool+logAll = const True+{-# INLINEABLE logAll #-} +-- | log all but 'Debug' messages.+logDiagnostic :: LogSeverity -> Bool+logDiagnostic (Debug _) = False+logDiagnostic _         = True+{-# INLINEABLE logDiagnostic #-} --- | "LogSeverity" list used in order to output everything.-logAll :: [LogSeverity]-logAll = [minBound .. maxBound]+-- | log everything above 'Diagnostic'.+nonDiagnostic :: LogSeverity -> Bool+nonDiagnostic ls = ls `elem` [Info, Warning, Error]+{-# INLINEABLE nonDiagnostic #-} --- | 'LogSeverity' list used to output all but 'Diagnostic'.--- 'Diagnostic' messages are sometimes useful for debugging but can get noisy depending on how you use it.-nonDiagnostic :: [LogSeverity]-nonDiagnostic = List.tail logAll+-- | log debug messages with level lower than or equal to the given @Int@.+logDebug :: Int -> LogSeverity -> Bool+logDebug l (Debug n) = n <= l+logDebug _ _         = True+{-# INLINEABLE logDebug #-} --- | The Logger effect+-- | The Logger effect (the same as the 'Polysemy.Output' effect).  data Logger a m r where   Log :: a -> Logger a m ()  -- | Add one log entry of arbitrary type.  If you want to log with another type besides @LogEntry. log :: P.Member (Logger a) effs => a -> P.Sem effs () log = send . Log+{-# INLINEABLE log #-}  -- | Add one log-entry of the @LogEntry@ type. logLE   :: P.Member (Logger LogEntry) effs => LogSeverity -> T.Text -> P.Sem effs () logLE ls lm = log (LogEntry ls lm)+{-# INLINEABLE logLE #-} +-- | Type-alias for handler functions (unexported).+type Handler m msg = msg -> m ()+ -- | Helper function for logging with monad-logger handler. logWithHandler   :: Handler (P.Sem effs) a -> P.Sem (Logger a ': effs) x -> P.Sem effs x logWithHandler handler = P.interpret (\(Log a) -> handler a)+{-# INLINEABLE logWithHandler #-}  -- | Prefix Effect data PrefixLog m r where@@ -144,14 +173,17 @@ -- | Add one level of prefix. addPrefix :: P.Member PrefixLog effs => T.Text -> P.Sem effs () addPrefix = send . AddPrefix+{-# INLINEABLE addPrefix #-}  -- | Remove last prefix. removePrefix :: P.Member PrefixLog effs => P.Sem effs () removePrefix = send RemovePrefix+{-# INLINEABLE removePrefix #-}  -- | Get current prefix  getPrefix :: P.Member PrefixLog effs => P.Sem effs T.Text getPrefix = send $ GetPrefix+{-# INLINEABLE getPrefix #-}  -- | Add a prefix for the block of code. wrapPrefix :: P.Member PrefixLog effs => T.Text -> P.Sem effs a -> P.Sem effs a@@ -160,8 +192,9 @@   res <- l   removePrefix   return res+{-# INLINEABLE wrapPrefix #-} --- | Interpret LogPrefix in @Polysemy.State [T.Text]@.+-- | Interpret PrefixLog in @Polysemy.State [T.Text]@. prefixInState   :: forall effs a    . P.Sem (PrefixLog ': effs) a@@ -170,18 +203,29 @@   AddPrefix t  -> P.modify (t :)   RemovePrefix -> P.modify @[T.Text] tail -- type application required here since tail is polymorphic   GetPrefix    -> fmap (T.intercalate "." . List.reverse) P.get+{-# INLINEABLE prefixInState #-} --- | Interpret the 'LogPrefix' effect in State and run that.+-- | Interpret the 'PrefixLog' effect in State and run that. runPrefix :: P.Sem (PrefixLog ': effs) a -> P.Sem effs a runPrefix = fmap snd . P.runState [] . prefixInState+{-# INLINEABLE runPrefix #-}  -- | Monad-logger style wrapper to add prefixes to log messages. data WithPrefix a = WithPrefix { msgPrefix :: T.Text, discardPrefix :: a }+data WithSeverity a = WithSeverity { msgSeverity :: LogSeverity, discardSeverity :: a }  -- | Render a prefixed log message with the pretty-printer. renderWithPrefix :: (a -> PP.Doc ann) -> WithPrefix a -> PP.Doc ann renderWithPrefix k (WithPrefix pr a) = PP.pretty pr PP.<+> PP.align (k a)+{-# INLINEABLE renderWithPrefix #-} +-- | Render a prefixed log message with the pretty-printer.+renderLogEntry+  :: (T.Text -> PP.Doc ann) -> (LogEntry -> PP.Doc ann)+renderLogEntry k (LogEntry s t) =+  PP.brackets (PP.pretty s) PP.<+> PP.align (k t)++ -- | Use @PrefixLog@ Effect to re-interpret all the logged messages to WithPrefix form. logPrefixed   :: P.Member PrefixLog effs@@ -189,6 +233,7 @@   -> P.Sem (Logger (WithPrefix a) ': effs) x logPrefixed =   P.reinterpret (\(Log a) -> getPrefix >>= (\p -> log (WithPrefix p a)))+{-# INLINEABLE logPrefixed #-}  -- the use of "raise" below is there since we are running the handler in the stack that still has the LogPrefix effect. -- I couldn't figure out how to write this the other way.@@ -203,40 +248,65 @@   runPrefix     . logWithHandler (P.raise . handler)     . logPrefixed @(PrefixLog ': effs)+{-# INLINEABLE logAndHandlePrefixed #-}  -- | Add a severity filter to a handler.-filterLog-  :: Monad m-  => ([LogSeverity] -> a -> Bool)-  -> [LogSeverity]-  -> Handler m a-  -> Handler m a-filterLog filterF lss h a = when (filterF lss a) $ h a+filterLog :: Monad m => (a -> Bool) -> Handler m a -> Handler m a+filterLog filterF h a = when (filterF a) $ h a+{-# INLINEABLE filterLog #-} --- | Simple handler, uses a function from message to Text and then outputs all messages in IO.+-- | Simple handler, uses a function from message to Text and then outputs all messages in 'IO'.+-- Uses "Say" to insure messages issued from each thread are output coherently. -- Can be used as base for any other handler that gives @Text@. logToIO :: MonadIO m => (a -> T.Text) -> Handler m a-logToIO toText = liftIO . T.putStrLn . toText+logToIO toText a = liftIO $ do+  S.say $ toText a+  hFlush stdout+{-# INLINEABLE logToIO #-} --- | Preferred handler for @LogEntry@ type with prefixes.-prefixedLogEntryToIO :: MonadIO m => Handler m (WithPrefix LogEntry)-prefixedLogEntryToIO = logToIO++-- | '(a -> Text)' function for prefixedLogEntries+prefixedLogEntryToText :: WithPrefix LogEntry -> T.Text+prefixedLogEntryToText =   (PP.renderStrict . PP.layoutPretty PP.defaultLayoutOptions . renderWithPrefix-    (ML.renderWithSeverity PP.pretty . logEntryToWithSeverity)+    (renderLogEntry PP.pretty)   )+{-# INLINEABLE prefixedLogEntryToText #-} --- | Run the Logger and PrefixLog effects using the preferred handler and filter output in any Polysemy monad with IO in the union.+-- | log prefixed entries directly to IO+prefixedLogEntryToIO :: MonadIO m => Handler m (WithPrefix LogEntry)+prefixedLogEntryToIO = logToIO prefixedLogEntryToText+{-# INLINEABLE prefixedLogEntryToIO #-}++-- | This function can be used to log directly to IO, bypassing the effect.+-- It's here to allow logging from within functions that must be run under more+-- limited stacks and then embedded.+logWithPrefixToIO :: LogWithPrefixIO+logWithPrefixToIO prefix le = let wp = WithPrefix prefix le in prefixedLogEntryToIO wp+{-# INLINEABLE logWithPrefixToIO #-}++-- | A synonym for a function to handle direct logging from IO.  Used to allow logging from any stack with IO.+type LogWithPrefixIO = T.Text -> LogEntry -> IO ()++-- | Run the 'Logger' and 'PrefixLog' effects in 'IO': filtered via the severity of the message and formatted using "prettyprinter". filteredLogEntriesToIO-  :: MonadIO (P.Sem effs)-  => [LogSeverity]-  -> P.Sem (Logger LogEntry ': (PrefixLog ': effs)) x-  -> P.Sem effs x-filteredLogEntriesToIO lss = logAndHandlePrefixed-  (filterLog f lss $ prefixedLogEntryToIO)-  where f lss' a = (severity $ discardPrefix a) `List.elem` lss'+  :: MonadIO (P.Sem r) +  => (LogSeverity -> Bool) +  -> P.Sem (Logger LogEntry ': (PrefixLog ': r)) x+  -> P.Sem r x+filteredLogEntriesToIO lsF mx = do+  let f a = lsF (severity $ discardPrefix a)+  logAndHandlePrefixed (filterLog f $ prefixedLogEntryToIO) mx +{-# INLINEABLE filteredLogEntriesToIO #-} +-- | List of Logger effects for a prefixed log of type @a@+type PrefixedLogEffects a = [PrefixLog, Logger a]++-- | List of Logger effects for a prefixed log of type @LogEntry@+type PrefixedLogEffectsLE = PrefixedLogEffects LogEntry+ -- | Constraint helper for logging with prefixes-type LogWithPrefixes a effs = (P.Member PrefixLog effs, P.Member (Logger a) effs)+type LogWithPrefixes a effs = P.Members (PrefixedLogEffects a) effs --(P.Member PrefixLog effs, P.Member (Logger a) effs)  -- | Constraint helper for @LogEntry@ type with prefixes type LogWithPrefixesLE effs = LogWithPrefixes LogEntry effs --(P.Member PrefixLog effs, P.Member (Logger a) effs)

@@ -1,13 +1,14 @@+{-# LANGUAGE DataKinds           #-} {-# LANGUAGE FlexibleContexts    #-}-{-# LANGUAGE RankNTypes          #-} {-# LANGUAGE GADTs               #-}-{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE LambdaCase          #-}+{-# LANGUAGE OverloadedStrings   #-} {-# LANGUAGE PolyKinds           #-}-{-# LANGUAGE TypeOperators       #-}+{-# LANGUAGE RankNTypes          #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving  #-} {-# LANGUAGE TypeApplications    #-}-{-# LANGUAGE LambdaCase          #-}+{-# LANGUAGE TypeOperators       #-} {-# OPTIONS_GHC -fwarn-incomplete-patterns #-} {-| Module      : Knit.Effect.Pandoc@@ -60,7 +61,6 @@      -- * Re-exports   , DocWithInfo(..)-   ) where @@ -214,10 +214,11 @@   False ->     throwError       $  PA.PandocSomeError+      $  PM.textToPandocText       $  "One of "-      ++ (show $ S.toList rs)-      ++ " cannot be output to "-      ++ show pwf+      <> (T.pack $ show $ S.toList rs)+      <> " cannot be output to "+      <> (T.pack $ show pwf)   True -> write pwo pdoc    where     write = case pwf of@@ -290,8 +291,7 @@   -> P.Sem (Pandocs ': effs) () -- ^ effects stack to be (partially) run to get documents   -> P.Sem effs [DocWithInfo PandocInfo a] -- ^ documents in requested format, within the effects monad pandocsToDocs pwf pwo =-  (traverse (\x -> PM.absorbPandocMonad $ pandocFrom pwf pwo x) =<<)-    . toDocList+  (traverse (\x -> PM.absorbPandocMonad $ pandocFrom pwf pwo x) =<<) . toDocList  -- | Given a write format and options, run the writer-style ToPandoc effect and produce a doc of requested type fromPandocE

@@ -1,4 +1,5 @@ {-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE CPP                   #-} {-# LANGUAGE DataKinds             #-} {-# LANGUAGE PolyKinds             #-} {-# LANGUAGE FlexibleContexts      #-}@@ -36,7 +37,7 @@   , PandocEffects   , PandocEffectsIO -  -- * Actions+    -- * Actions   , lookupEnv   , getCurrentTime   , getCurrentTimeZone@@ -56,21 +57,31 @@   , logOutput   , trace -  -- * Interpreters+    -- * Pandoc <2.8 compatibility+  , textToPandocText+  , pandocTextToText+#if   MIN_VERSION_pandoc(2,8,0) +  , absorbTemplateMonad+  , Template+  , interpretTemplateIO+#endif  +  +    -- * Interpreters   , interpretInPandocMonad   , interpretInIO -  -- * Runners-  , runIO+    -- * Runners+--  , runIO -  -- * Interop+    -- * Interop   , absorbPandocMonad -  -- * Re-Exports+    -- * Re-Exports   , PA.PandocError   ) where +import Prelude hiding (takeWhile, dropWhile,drop) import qualified Knit.Effect.Logger            as Log import qualified Paths_knit_haskell            as Paths @@ -84,11 +95,12 @@ import qualified Text.Pandoc.MIME              as PA import qualified Text.Pandoc.UTF8              as UTF8 + import qualified Data.ByteString               as BS-import           Data.ByteString.Lazy          as LBS+import qualified Data.ByteString.Lazy          as LBS import           Data.ByteString.Base64         ( decodeLenient ) import qualified Data.CaseInsensitive          as CI-import qualified Data.List                     as L+ import qualified Data.Text                     as T import           Control.Monad                  ( when ) import           Control.Monad.Except           ( MonadError(..)@@ -133,30 +145,136 @@ import qualified Debug.Trace import qualified Control.Exception             as E +#if MIN_VERSION_pandoc(2,8,0)+import qualified Text.DocTemplates             as DT+import           Data.Functor.Identity          (runIdentity)+#else+import qualified Data.List as L+#endif++#if MIN_VERSION_pandoc(2,8,0)+type PandocText = T.Text++pandocTextToText :: PandocText -> T.Text+pandocTextToText = id++textToPandocText :: T.Text -> PandocText+textToPandocText = id++pandocTextToString :: PandocText -> String+pandocTextToString = T.unpack++stringToPandocText :: String -> PandocText+stringToPandocText = T.pack++pandocTextToBS :: PandocText -> BS.ByteString+pandocTextToBS = UTF8.fromText++stripPrefix :: T.Text -> T.Text -> Maybe T.Text +stripPrefix = T.stripPrefix++takeWhile :: (Char -> Bool) -> T.Text -> T.Text+takeWhile = T.takeWhile++drop :: Int -> T.Text -> T.Text+drop = T.drop++dropWhile :: (Char -> Bool) -> T.Text -> T.Text+dropWhile = T.dropWhile++#else+type PandocText = String++pandocTextToText :: PandocText -> T.Text+pandocTextToText = T.pack++textToPandocText :: T.Text -> PandocText+textToPandocText = T.unpack++pandocTextToString :: PandocText -> String+pandocTextToString = id++stringToPandocText :: String -> PandocText+stringToPandocText = id++pandocTextToBS :: PandocText -> BS.ByteString+pandocTextToBS = UTF8.fromString++stripPrefix :: String -> String -> Maybe String +stripPrefix = L.stripPrefix++takeWhile :: (Char -> Bool) -> String -> String+takeWhile = L.takeWhile++drop :: Int -> String -> String+drop = L.drop++dropWhile :: (Char -> Bool) -> String -> String+dropWhile = L.dropWhile++#endif+ -- | Pandoc Effect data Pandoc m r where-  LookupEnv ::String -> Pandoc m (Maybe String)-  GetCurrentTime ::Pandoc m UTCTime-  GetCurrentTimeZone ::Pandoc m TimeZone-  NewStdGen ::Pandoc m StdGen-  NewUniqueHash ::Pandoc m Int-  OpenURL ::String -> Pandoc m (BS.ByteString, Maybe PA.MimeType)-  ReadFileLazy ::FilePath -> Pandoc m LBS.ByteString+  LookupEnv :: PandocText -> Pandoc m (Maybe PandocText)+  GetCurrentTime :: Pandoc m UTCTime+  GetCurrentTimeZone :: Pandoc m TimeZone+  NewStdGen :: Pandoc m StdGen+  NewUniqueHash :: Pandoc m Int+  OpenURL :: PandocText -> Pandoc m (BS.ByteString, Maybe PA.MimeType)+  ReadFileLazy :: FilePath -> Pandoc m LBS.ByteString   ReadFileStrict ::FilePath -> Pandoc m BS.ByteString   Glob ::String -> Pandoc m [FilePath]-  FileExists ::FilePath -> Pandoc m Bool-  GetDataFileName ::FilePath -> Pandoc m FilePath-  GetModificationTime ::FilePath -> Pandoc m UTCTime-  GetCommonState ::Pandoc m PA.CommonState-  PutCommonState ::PA.CommonState -> Pandoc m ()+  FileExists :: FilePath -> Pandoc m Bool+  GetDataFileName :: FilePath -> Pandoc m FilePath+  GetModificationTime :: FilePath -> Pandoc m UTCTime+  GetCommonState :: Pandoc m PA.CommonState+  PutCommonState :: PA.CommonState -> Pandoc m ()   GetsCommonState ::(PA.CommonState -> a) -> Pandoc m a   ModifyCommonState ::(PA.CommonState -> PA.CommonState) -> Pandoc m  ()   LogOutput ::PA.LogMessage -> Pandoc m ()-  Trace ::String -> Pandoc m ()+  Trace :: PandocText -> Pandoc m ()  P.makeSem ''Pandoc +#if MIN_VERSION_pandoc(2,8,0)+data Template m a where+  GetPartial :: FilePath -> Template m T.Text +P.makeSem ''Template++-- | Interpret a Template effect in any stack with IO (via the IO instance in DocTemplates)+interpretTemplateIO+  :: forall effs a+  . P.Member (P.Embed IO) effs+  => P.Sem (Template ': effs) a+  -> P.Sem effs a+interpretTemplateIO =  P.interpret $ \case+  GetPartial x -> P.embed $ DT.getPartial x++-- NB: This one ignores whatever getPartial is supposed to do but that's the only non-IO intepretation, I think?+-- | Interpret a Template effect in any stack (via the identity instance in DocTemplates)+interpretTemplatePure+  :: P.Sem (Template ': effs) a -> P.Sem effs a+interpretTemplatePure = P.interpret $ \case+  GetPartial x -> return . runIdentity $ DT.getPartial x++-- | use a Polysemy stack containing the 'Template` effect to run an TemplateMonad m action.+absorbTemplateMonad+  :: P.Member Template r => (DT.TemplateMonad (P.Sem r) => P.Sem r a) -> P.Sem r a+absorbTemplateMonad = P.absorbWithSem @DT.TemplateMonad @TemplateAction (TemplateDict getPartial) (P.Sub P.Dict)++-- | absorption gear for Template+newtype TemplateAction m s' a =+  TemplateAction { templateAction :: m a} deriving (Functor, Applicative, Monad)++data TemplateDict m = TemplateDict { getPartial_ :: FilePath -> m T.Text }++instance (Monad m, P.Reifies s' (TemplateDict m)) => DT.TemplateMonad (TemplateAction m s') where+  getPartial = TemplateAction . getPartial_ (P.reflect $ P.Proxy @s')++#endif+   -- we handle logging within the existing effect system -- | Map pandoc severities to our logging system. pandocSeverity :: PA.LogMessage -> Log.LogSeverity@@ -170,16 +288,25 @@   :: P.Member (Log.Logger Log.LogEntry) effs => PA.LogMessage -> P.Sem effs () logPandocMessage lm = send $ Log.Log $ Log.LogEntry   (pandocSeverity lm)-  (T.pack . PA.showLogMessage $ lm)+  (pandocTextToText . PA.showLogMessage $ lm)  -- | Constraint helper for using this set of effects in IO.+#if MIN_VERSION_pandoc(2,8,0) type PandocEffects effs   = ( P.Member Pandoc effs-  , P.Member (P.Error PA.PandocError) effs-  , P.Member Log.PrefixLog effs-  , P.Member (Log.Logger Log.LogEntry) effs-  )-+    , P.Member Template effs+    , P.Member (P.Error PA.PandocError) effs+    , P.Member Log.PrefixLog effs+    , P.Member (Log.Logger Log.LogEntry) effs+    )+#else+type PandocEffects effs+  = ( P.Member Pandoc effs+    , P.Member (P.Error PA.PandocError) effs+    , P.Member Log.PrefixLog effs+    , P.Member (Log.Logger Log.LogEntry) effs+    )+#endif     -- absorption gear -- | absorb a @PandocMonad@ constraint into --  @Members [Pandoc, Error PandocError] r => Sem r@@@ -222,12 +349,12 @@ -- which we need because of the MonadError superclass. data PandocDict m = PandocDict   {-    lookupEnv_ :: String -> m (Maybe String)+    lookupEnv_ :: PandocText -> m (Maybe PandocText)   , getCurrentTime_ :: m UTCTime   , getCurrentTimeZone_ :: m TimeZone   , newStdGen_ ::m StdGen   , newUniqueHash_ :: m Int-  , openURL_ :: String ->  m (BS.ByteString, Maybe PA.MimeType)+  , openURL_ :: PandocText ->  m (BS.ByteString, Maybe PA.MimeType)   , readFileLazy_ :: FilePath ->  m LBS.ByteString   , readFileStrict_ :: FilePath ->  m BS.ByteString   , glob_ :: String ->  m [FilePath]@@ -239,7 +366,7 @@   , getsCommonState_ :: forall a. (PA.CommonState -> a) ->  m a   , modifyCommonState_ :: (PA.CommonState -> PA.CommonState) ->  m  ()   , logOutput_ :: PA.LogMessage ->  m ()-  , trace_ :: String ->  m ()+  , trace_ :: PandocText ->  m ()   , throwError_ :: forall a. PA.PandocError -> m a   , catchError_ :: forall a. m a -> (PA.PandocError -> m a) -> m a   }@@ -290,7 +417,7 @@   liftPair :: forall f x y . Functor f => (x, f y) -> f (x, y)   liftPair (x, fy) = fmap (x, ) fy   f :: Pandoc m x -> PA.CommonState -> P.Sem effs (PA.CommonState, x)-  f (LookupEnv s)         cs = liftPair (cs, liftIO $ IO.lookupEnv s)+  f (LookupEnv s)         cs = liftPair (cs, liftIO $ fmap (fmap stringToPandocText) $ IO.lookupEnv (pandocTextToString s))   f GetCurrentTime        cs = liftPair (cs, liftIO $ IO.getCurrentTime)   f GetCurrentTimeZone    cs = liftPair (cs, liftIO IO.getCurrentTimeZone)   f NewStdGen             cs = liftPair (cs, liftIO IO.newStdGen)@@ -310,9 +437,10 @@   f (LogOutput         msg) cs = liftPair (cs, logPandocMessage msg)   f (Trace             msg) cs = liftPair     ( cs-    , when (PA.stTrace cs) $ Debug.Trace.trace ("[trace]" ++ msg) (return ())+    , when (PA.stTrace cs) $ Debug.Trace.trace ("[trace]" ++ (pandocTextToString msg)) (return ())     ) + -- | Interpret the Pandoc effect in another monad (which must satisy the PandocMonad constraint) and @Knit.Effect.Logger@ interpretInPandocMonad   :: forall m effs a@@ -344,18 +472,41 @@     Trace             s    -> P.embed @m $ PA.trace s   ) +{- -- | Run the Pandoc effects, -- and log messages with the given severity, over IO. -- If there is a Pandoc error, you will get a Left in the resulting Either.+#if MIN_VERSION_pandoc(2,8,0) runIO-  :: [Log.LogSeverity]+  :: (Log.LogSeverity -> Bool)   -> P.Sem-       '[Pandoc, Log.Logger Log.LogEntry, Log.PrefixLog, P.Error-         PA.PandocError, P.Embed IO]-       a+     '[Template+      , Pandoc+      , P.Reader Log.LogWithPrefixIO+      , Log.Logger Log.LogEntry+      , Log.PrefixLog+      , P.Error PA.PandocError+      , P.Embed IO]+     a   -> IO (Either PA.PandocError a)-runIO lss =-  P.runM . P.runError . Log.filteredLogEntriesToIO lss . interpretInIO+runIO logIf =+  P.runM . P.runError . Log.filteredLogEntriesToIO logIf . interpretInIO . interpretTemplateIO+#else+runIO+  :: (Log.LogSeverity -> Bool)+  -> P.Sem+     '[Pandoc+      , P.Reader Log.LogWithPrefixIO+      , Log.Logger Log.LogEntry+      , Log.PrefixLog+      , P.Error PA.PandocError+      , P.Embed IO]+     a+  -> IO (Either PA.PandocError a)+runIO logIf =+  P.runM . P.runError . Log.filteredLogEntriesToIO logIf . interpretInIO+#endif+-}  -- copied from Pandoc code and modified as needed for Polysemy and my implementation of interpretInIO (PandocIO) openURLWithState@@ -365,17 +516,17 @@      , P.Member (P.Error PA.PandocError) effs      )   => PA.CommonState-  -> String+  -> PandocText   -> P.Sem effs (PA.CommonState, (BS.ByteString, Maybe PA.MimeType)) openURLWithState cs u-  | Just u'' <- L.stripPrefix "data:" u = do-    let mime = L.takeWhile (/= ',') u''-    let contents = UTF8.fromString $ NU.unEscapeString $ L.drop 1 $ L.dropWhile+  | Just u'' <- stripPrefix "data:" u = do+    let mime = takeWhile (/= ',') u''+    let contents = UTF8.fromString $ (NU.unEscapeString . pandocTextToString) $ drop 1 $ dropWhile           (/= ',')           u''     return (cs, (decodeLenient contents, Just mime))   | otherwise = do-    let toReqHeader (n, v) = (CI.mk (UTF8.fromString n), UTF8.fromString v)+    let toReqHeader (n, v) = (CI.mk (pandocTextToBS n), pandocTextToBS v)         customHeaders = fmap toReqHeader $ PA.stRequestHeaders cs     cs' <- report cs $ PA.Fetching u     res <- liftIO $ E.try $ withSocketsDo $ do@@ -385,7 +536,7 @@             Left  _  -> return x             Right pr -> parseReq pr               >>= \r -> return (NHC.addProxy (NHC.host r) (NHC.port r) x)-      req <- parseReq u >>= addProxy'+      req <- parseReq (pandocTextToString u) >>= addProxy'       let req' = req             { NHC.requestHeaders = customHeaders ++ NHC.requestHeaders req             }@@ -395,7 +546,7 @@         , UTF8.toString `fmap` lookup NH.hContentType (NHC.responseHeaders resp)         )     case res of-      Right r -> return (cs', r)+      Right r -> return (cs', (\(x,y) -> (x, stringToPandocText <$> y))  r)       Left  e -> P.throw $ PA.PandocHttpError u e  -- | Stateful version of the Pandoc @report@ function, outputting relevant log messages@@ -422,7 +573,7 @@ liftIOError f u = do   res <- liftIO $ IO.tryIOError $ f u   case res of-    Left  e -> P.throw $ PA.PandocIOError u e+    Left  e -> P.throw $ PA.PandocIOError (stringToPandocText u) e     Right r -> return r  -- | adjust the directory the PandocMonad sees so that it will get

@@ -0,0 +1,193 @@+{-# LANGUAGE BangPatterns        #-}+{-# LANGUAGE ConstraintKinds     #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE DeriveFunctor       #-}+{-# LANGUAGE PolyKinds           #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE LambdaCase          #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell     #-}+{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE TypeFamilies        #-}+{-# LANGUAGE TypeOperators       #-}++{-|+Module      : Knit.Effect.Serialize+Description : Effect for serializing and deserializing data+Copyright   : (c) Adam Conner-Sax 2019+License     : BSD-3-Clause+Maintainer  : adam_conner_sax@yahoo.com+Stability   : experimental++This module provides the types and supporting functions to use various serializers+with the caching framework in knit-haskell.+A <https://hackage.haskell.org/package/cereal Cereal> implementation is+provided, but using a different implementation is straightforward.+See <https://github.com/adamConnerSax/knit-haskell/blob/master/examples/CacheExample2.hs CacheExample2>+for an example.++The cache framework expects an explicit dictionary (i.e., record-of-functions)+rather than a Typeclass for serialization. +Since various serializers use slightly different Typeclass structures and function names,+we can't write code which is polynorphic in the serialization type-class. But with an +explicit dictionary we get that flexibility.  Once a dictionary for encoding and decoding+objects of arbitrary type is provided, along with the typeclass constraint required to use it,+the code in this module can convert that into all the functions the caching effect+requires to cache that data type or streams of it.++This could be implemented as a more straightforward effect but at the cost of complicating+the use for streams.  Making the explicit dictionary available balances the flexibility of+being able to change serializers with the relative ease of bootstrapping the single item serializer+into a serializer for streams, etc.+-}+module Knit.Effect.Serialize+  (+    -- * Types+    SerializeDict(..)+  , Serialize(..)+  , SerializeEnv++    -- * Deploy Implementations+  , serializeOne+  , serializeStreamlyViaList++    -- * Implementations+  , DefaultCacheData+  , DefaultSerializer+  , cerealStreamlyDict++    -- * Reader for Serializer Dictionary+  , getSerializeDict+  , runSerializeEnv++    -- * Errors+  , SerializationError(..)+  )+where++import qualified Polysemy                      as P+import qualified Polysemy.Error                as P+import qualified Polysemy.Reader               as PR+import           Data.Int (Int64)+import qualified Data.Serialize                as S+import qualified Data.Text                     as T+import qualified Data.Word                     as Word++import qualified Streamly                      as Streamly+import qualified Streamly.Prelude              as Streamly+import qualified Streamly.Data.Fold                 as Streamly.Fold+import qualified Streamly.Memory.Array         as Streamly.Array+import qualified Streamly.Internal.Data.Array           as Streamly.Data.Array+import qualified Streamly.External.Cereal      as Streamly.Cereal++-- | Error Type for Serialization errors.  Simplifies catching and reporting them.+data SerializationError = SerializationError T.Text deriving (Show)+++{- |+Encoding/decoding functions for Serializing data, made explicit+here so we can pass them around as part of a configuration.+Allows for different Serializers as well as+Serializing to different types of in-memory store.++NB: The first parameter is of kind @Type -> Constraint@, e.g., @S.Serialize@,+which must be satisfied by anything serializable by+the implementation.++This should be straightforward to write for any serializer, and is all that's required to use+a non-default serializer as long as it serializes to @ByteStream@+(or, less likely, @Streamly.Memory.Array.Array@)+-}+data SerializeDict c ct =+  SerializeDict+  { encodeOne :: forall a. c a => a -> ct+  , decodeOne :: forall a. c a => ct -> Either SerializationError a+  , encBytes :: ct -> Int64+  }++-- | Make the dictionary available within effect stacks+type SerializeEnv c ct = PR.Reader (SerializeDict c ct)++-- | access the dictionary+getSerializeDict :: P.Member (SerializeEnv c ct) r => P.Sem r (SerializeDict c ct)+getSerializeDict = PR.ask+{-# INLINEABLE getSerializeDict #-}++-- | run the SerializeEnv effect by giving it the dictionary for use by the cache functions+runSerializeEnv :: SerializeDict c ct -> P.InterpreterFor (SerializeEnv c ct) r+runSerializeEnv = PR.runReader+{-# INLINEABLE runSerializeEnv #-}++{- |+Record-of-functions type to carry encoding/decoding functions for Serializing data.+Allows for different Serializers as well as+Serializing to different types of in memory store.+@encode@ returns the encoded value *and* a (possibly buffered) copy of its input. +This is designed around serialization of streams, where the original (effectful) stream may be expensive to run. But once run,+we can return a "buffered" stream which just unfolds from a memory buffer.+In many cases, we will just return the input in that slot.+-}+data Serialize e r a ct where+  Serialize :: (P.MemberWithError (P.Error e) r)+            => (a -> P.Sem r (ct, a)) -- ^ Encode+            -> (ct -> P.Sem r a)      -- ^ Decode+            -> (ct -> Int64)          -- ^ Size (in Bytes)+            -> Serialize e r a ct++-- | Given a @'SerializeDict' c ct@ and @a@ satisfying @c a@,+-- produce the (trivial) 'Serialize' record-of-functions to encode/decode a single @a@.+serializeOne :: (c a, P.MemberWithError (P.Error SerializationError) r)+             => SerializeDict c ct+             -> Serialize SerializationError r a ct+serializeOne (SerializeDict encOne decOne bytes) =+  let enc a = return (encOne a, a)+      {-# INLINEABLE enc #-}      +      dec = P.fromEither @SerializationError . decOne+      {-# INLINEABLE dec #-}+  in Serialize enc dec bytes+{-# INLINEABLE serializeOne #-}++-- | Given a @'SerializeDict' c ct@ and @a@ satisfying @c [a]@--usually+-- true as long as @a@ satisfies @c a@--produce+-- the 'Serialize' record-of-functions to encode/decode @Streamly.SerialT (P.Sem r) a@,+-- by mapping the stream to a (lazy) list, and encoding that and+-- decoding as a list and creating the stream from that.+serializeStreamlyViaList ::+  (P.MemberWithError (P.Error SerializationError) r, P.Member (P.Embed IO) r, c [a])+  => SerializeDict c ct+  -> Serialize SerializationError r (Streamly.SerialT (P.Sem r) a) ct +serializeStreamlyViaList (SerializeDict encOne decOne bytes) =+  let enc = Streamly.fold (Streamly.Fold.tee+                           (fmap encOne $ Streamly.Fold.toList) +                           (fmap (Streamly.Data.Array.toStream) Streamly.Data.Array.write)+                          )+      {-# INLINEABLE enc #-}+      dec = P.fromEither . fmap Streamly.fromList . decOne+      {-# INLINEABLE dec #-}+  in Serialize enc dec bytes+{-# INLINEABLE serializeStreamlyViaList #-}+++-- | type-alias for default in-memory storage type.+type DefaultCacheData = Streamly.Array.Array Word.Word8++-- | type-alias for default Serializer+type DefaultSerializer = S.Serialize++-- | Implementation of `SerializeDict` for the cereal serializer,+-- encoding to/decoding from `Streamly.Memory.Array.Array`+cerealStreamlyDict :: SerializeDict DefaultSerializer DefaultCacheData+cerealStreamlyDict =+  SerializeDict+  Streamly.Cereal.encodeStreamlyArray+  (mapLeft SerializationError .  Streamly.Cereal.decodeStreamlyArray)+  (fromIntegral . Streamly.Array.length)+{-# INLINEABLE cerealStreamlyDict #-}++-- | Map the left side of an Either+mapLeft :: (a -> b) -> Either a c -> Either b c+mapLeft f = either (Left . f) Right+{-# INLINEABLE mapLeft #-}

@@ -15,6 +15,9 @@ Maintainer  : adam_conner_sax@yahoo.com Stability   : experimental +This module contains a state effect used to maintain a map of unused id numbers which can be used for HTML+ids or figure numbering.+ -} module Knit.Effect.UnusedId   (

@@ -1,14 +1,15 @@+{-# LANGUAGE ConstraintKinds      #-}+{-# LANGUAGE DataKinds            #-} {-# LANGUAGE ExtendedDefaultRules #-}-{-# LANGUAGE ScopedTypeVariables  #-} {-# LANGUAGE FlexibleContexts     #-}-{-# LANGUAGE TypeOperators        #-}-{-# LANGUAGE TypeFamilies         #-}-{-# LANGUAGE DataKinds            #-}-{-# LANGUAGE PolyKinds            #-} {-# LANGUAGE GADTs                #-}-{-# LANGUAGE TypeApplications     #-}+{-# LANGUAGE OverloadedStrings    #-}+{-# LANGUAGE PolyKinds            #-} {-# LANGUAGE Rank2Types           #-}-{-# LANGUAGE ConstraintKinds      #-}+{-# LANGUAGE ScopedTypeVariables  #-}+{-# LANGUAGE TypeOperators        #-}+{-# LANGUAGE TypeApplications     #-}+{-# LANGUAGE TypeFamilies         #-} {-# LANGUAGE UndecidableInstances #-} {-| Module      : Knit.Report@@ -18,8 +19,7 @@ Maintainer  : adam_conner_sax@yahoo.com Stability   : experimental -This module re-exports the basic pieces to build reports using Pandoc-as well as providing functions to do the "knitting"--produce the documents.+This module re-exports the basic pieces to build reports using Pandoc. That is, it is intended as one-stop-shopping for using this library to produce Html from various fragments which Pandoc can read. @@ -34,15 +34,9 @@ -} module Knit.Report   (-    -- * Knit-    knitHtml-  , knitHtmls-  , liftKnit-  , knitError-  , KnitEffects-  , KnitOne-  , KnitMany-  , KnitBase+    -- * Report Building+    module Knit.Report.EffectStack+  , module Knit.Report.Error      -- * Inputs   , module Knit.Report.Input.Table.Colonnade@@ -65,13 +59,31 @@   , module Knit.Effect.PandocMonad   , module Knit.Effect.Logger   , module Knit.Effect.UnusedId+  , module Knit.Effect.Serialize+  , module Polysemy.Async+  , module Knit.Report.Cache   ) where +import           Knit.Report.EffectStack+import           Knit.Report.Error+import           Knit.Report.Cache+import           Knit.Report.Output+import           Knit.Report.Output.Html        ( pandocWriterToBlazeDocument+                                                , mindocOptionsF+                                                , writeAllPandocResultsWithInfoAsHtml+                                                , writePandocResultWithInfoAsHtml+                                                )+ import           Polysemy                       ( Member+                                                , Members                                                 , Sem-                                                , Embed                                                 )+import           Polysemy.Async                 ( async+                                                , await+                                                , sequenceConcurrently+                                                )+ import           Knit.Effect.Pandoc             ( ToPandoc                                                 , Requirement(..)                                                 , PandocReadFormat(..)@@ -85,11 +97,16 @@ import           Knit.Effect.Logger             ( LogSeverity(..)                                                 , logAll                                                 , nonDiagnostic+                                                , logDebug+                                                , logDiagnostic                                                 , logLE                                                 , wrapPrefix                                                 , filteredLogEntriesToIO+                                                , PrefixedLogEffectsLE                                                 , LogWithPrefixesLE                                                 )+import           Knit.Effect.UnusedId           ( getNextUnusedId )+import           Knit.Effect.Serialize          (DefaultCacheData, DefaultSerializer) import           Knit.Report.Input.Table.Colonnade import           Knit.Report.Input.MarkDown.PandocMarkDown                                                 ( addMarkDown )@@ -102,133 +119,3 @@ import           Knit.Report.Input.Visualization.Hvega                                                 ( addHvega ) import           Knit.Report.Input.Visualization.Diagrams---                                         hiding ( trace ) -- trace conflicts with Pandoc.trace--import           Knit.Report.Output-import           Knit.Report.Output.Html        ( pandocWriterToBlazeDocument-                                                , mindocOptionsF-                                                , writeAllPandocResultsWithInfoAsHtml-                                                , writePandocResultWithInfoAsHtml-                                                )--import           Text.Pandoc                    ( PandocError )--import           Control.Monad.Except           ( MonadIO )-import qualified Data.Text                     as T-import qualified Data.Text.Lazy                as TL--import qualified Polysemy                      as P-import qualified Polysemy.Error                as PE-import qualified Polysemy.IO                   as PI--import qualified Text.Pandoc                   as PA-import qualified Text.Blaze.Html.Renderer.Text as BH--import qualified Knit.Report.Output.Html       as KO-import qualified Knit.Effect.Docs              as KD-import qualified Knit.Effect.Pandoc            as KP-import qualified Knit.Effect.PandocMonad       as KPM-import qualified Knit.Effect.Logger            as KLog-import qualified Knit.Effect.UnusedId          as KUI-import           Knit.Effect.UnusedId           ( getNextUnusedId )----- | Create multiple HTML docs (as Text) from the named sets of pandoc fragments.--- In use, you may need a type-application to specify m.--- This allows use of any underlying monad to handle the Pandoc effects.--- NB: Resulting documents are *Lazy* Text, as produced by the Blaze render function.-knitHtmls-  :: MonadIO m-  => Maybe T.Text -- ^ outer logging prefix-  -> [KLog.LogSeverity] -- ^ what to output in log-  -> PandocWriterConfig -- ^ configuration for the Pandoc Html Writer-  -> P.Sem (KnitEffectDocsStack m) ()-  -> m-       ( Either-           PA.PandocError-           [KP.DocWithInfo KP.PandocInfo TL.Text]-       )-knitHtmls loggingPrefixM ls (PandocWriterConfig mFP tv oF) =-  consumeKnitEffectStack loggingPrefixM ls . KD.toDocListWithM-    (\(KP.PandocInfo _ tv') a ->-      fmap BH.renderHtml-        . KO.toBlazeDocument (PandocWriterConfig mFP (tv' <> tv) oF)-        $ a-    )---- | Create HTML Text from pandoc fragments--- In use, you may need a type-application to specify m.--- This allows use of any underlying monad to handle the Pandoc effects.--- NB: Resulting document is *Lazy* Text, as produced by the Blaze render function.-knitHtml-  :: MonadIO m-  => Maybe T.Text -- ^ outer logging prefix-  -> [KLog.LogSeverity] -- ^ what to output in log-  -> PandocWriterConfig -- ^ configuration for the Pandoc Html Writer-  -> P.Sem (KnitEffectDocStack m) ()-  -> m (Either PA.PandocError TL.Text)-knitHtml loggingPrefixM ls writeConfig =-  fmap (fmap (fmap BH.renderHtml)) (consumeKnitEffectStack loggingPrefixM ls)-    . KO.pandocWriterToBlazeDocument writeConfig---- | Constraints required to knit a document using effects from a base monad m.-type KnitBase m effs = (MonadIO m, P.Member (P.Embed m) effs)---- | lift an action in a base monad into a Polysemy monad.  This is just a renaming for convenience.-liftKnit :: Member (Embed m) r => m a -> Sem r a-liftKnit = P.embed---- | Throw an error with a specific message.  This will emerge as a 'PandocSomeError' in order--- to avoid complicating the error type.--- NB: The Member constraint is satisfied by KnitEffectStack m.-knitError :: P.Member (PE.Error PA.PandocError) r => T.Text -> P.Sem r a-knitError msg =-  PE.throw (PA.PandocSomeError $ "Knit User Error: " ++ T.unpack msg)---- | Constraint alias for the effects we need (and run)--- when calling Knit.--- Anything inside a call to Knit can use any of these effects.--- Any other effects will need to be run before @knitHtml(s)@-type KnitEffects r = (KPM.PandocEffects r-                     , P.Members [ KUI.UnusedId-                                 , KLog.Logger KLog.LogEntry-                                 , KLog.PrefixLog-                                 , PE.Error PA.PandocError-                                 , P.Embed IO] r-                     )---- | Constraint alias for the effects we need to knit one document-type KnitOne r = (KnitEffects r, P.Member KP.ToPandoc r)---- | Constraint alias for the effects we need to knit multiple documents.-type KnitMany r = (KnitEffects r, P.Member KP.Pandocs r)----- From here down is unexported.  --- | The exact stack we are interpreting when we knit-type KnitEffectStack m-  = '[KUI.UnusedId, KPM.Pandoc, KLog.Logger KLog.LogEntry, KLog.PrefixLog, PE.Error-    PA.PandocError, P.Embed IO, P.Embed m]--- | Add a Multi-doc writer to the front of the effect list-type KnitEffectDocsStack m = (KP.Pandocs ': KnitEffectStack m)---- | Add a single-doc writer to the front of the effect list-type KnitEffectDocStack m = (KP.ToPandoc ': KnitEffectStack m)---- | run all knit-effects in @KnitEffectStack m@-consumeKnitEffectStack-  :: forall m a-   . MonadIO m-  => Maybe T.Text -- ^ outer logging prefix-  -> [KLog.LogSeverity] -- ^ what to output in log-  -> P.Sem (KnitEffectStack m) a-  -> m (Either PA.PandocError a)-consumeKnitEffectStack loggingPrefixM ls =-  P.runM-    . PI.embedToMonadIO @m -- interpret (Embed IO) using m-    . PE.runError-    . KLog.filteredLogEntriesToIO ls-    . KPM.interpretInIO -- PA.PandocIO-    . KUI.runUnusedId-    . maybe id KLog.wrapPrefix loggingPrefixM-

@@ -0,0 +1,315 @@+{-# LANGUAGE ConstraintKinds      #-}+{-# LANGUAGE DataKinds            #-}+{-# LANGUAGE DeriveFunctor        #-}+{-# LANGUAGE FlexibleContexts     #-}+{-# LANGUAGE GADTs                #-}+{-# LANGUAGE OverloadedStrings    #-}+{-# LANGUAGE PolyKinds            #-}+{-# LANGUAGE Rank2Types           #-}+{-# LANGUAGE ScopedTypeVariables  #-}+{-# LANGUAGE TypeApplications     #-}+{-# LANGUAGE TypeFamilies         #-}+{-# LANGUAGE TypeOperators        #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -O2 -fdicts-strict -fspec-constr-recursive=16 -fmax-worker-args=16 #-} -- for streamly+{-|+Module      : Knit.Report.Cache+Description : Combinators for using the AtomicCache effect+Copyright   : (c) Adam Conner-Sax 2019+License     : BSD-3-Clause+Maintainer  : adam_conner_sax@yahoo.com+Stability   : experimental++This module adds types, combinators and knit functions for using knit-haskell with the 'Knit.Effect.AtomicCache' effect+to implement a disk-persisted, in-memory key-value store with some support dependency tracking. The+knit-haskell stack uses "Text" keys, performs binary serialization using "Cereal" and uses 'Streamly.Memory.Array' from+"Streamly" as values for the in-memory Map.++For details about the cache itself, please see the documentation for 'Knit.Effect.AtomicCache'.++<https://github.com/adamConnerSax/knit-haskell/tree/master/examples Examples> are available, and might be useful for seeing how all this works.+-}+module Knit.Report.Cache+  (+    -- * Dependency Tracking+   WithCacheTime+  , ActionWithCacheTime+  , ignoreCacheTime+  , ignoreCacheTimeM+  , withCacheTime+  , onlyCacheTime+    -- * Cache Combinators+  , store  +  , clear+  , clearIfPresent+  , retrieve+  , retrieveOrMake+  , retrieveOrMakeTransformed+    -- * Streamly-Based+    -- ** Dependency Tracking+  , StreamWithCacheTime+  , ignoreCacheTimeStream+    -- ** Interoperation with non-stream actions+  , streamToAction+  , streamAsAction+    -- ** Cache Combinators+  , storeStream+  , retrieveStream+  , retrieveOrMakeStream+  , retrieveOrMakeTransformedStream +    -- * Re-Exports+  , UTCTime+  )+where++import qualified Knit.Effect.AtomicCache       as C+import           Knit.Effect.AtomicCache        (clear+                                                , clearIfPresent+                                                , WithCacheTime                                                +                                                , withCacheTime+                                                , ignoreCacheTime+                                                , ignoreCacheTimeM+                                                , ActionWithCacheTime+                                                , onlyCacheTime)+import qualified Knit.Effect.Serialize         as KS                 +import qualified Knit.Effect.Logger            as K++import qualified Control.Monad.Catch.Pure      as Exceptions++import qualified Data.Text                     as T+import qualified Data.Time.Clock               as Time+import           Data.Time.Clock                (UTCTime)++import qualified Polysemy                      as P+import qualified Polysemy.Error                as P++import qualified Streamly                      as Streamly+import qualified Streamly.Prelude              as Streamly+import qualified Streamly.Internal.Prelude     as Streamly+++-- | type used by the AtomicCache for in-memory storage.+-- type CacheData = Streamly.Array.Array Word.Word8++-- | AtomicCache with 'T.Text' keys and using 'Streamly.Array.Array Word.Word8' to store serialized data in memory.+--type KnitCache ct = C.Cache T.Text ct++serializationToCacheError :: KS.SerializationError -> C.CacheError+serializationToCacheError (KS.SerializationError msg) = C.DeSerializationError msg++mapSerializationErrorsOne ::+  P.MemberWithError (P.Error C.CacheError) r+  => KS.Serialize KS.SerializationError (P.Error KS.SerializationError ': r) a ct+  -> KS.Serialize C.CacheError r a ct+mapSerializationErrorsOne (KS.Serialize encode decode encBytes) =+  let f = P.mapError serializationToCacheError+  in KS.Serialize+  (f . encode)+  (f . decode)+  encBytes++-- | Serialize a Serializable structure to the CacheData type.+knitSerialize+  :: ( sc a+     , P.Member (P.Embed IO) r+     , P.MemberWithError (P.Error C.CacheError) r+     )+  => KS.SerializeDict sc ct+  -> KS.Serialize C.CacheError r a ct+knitSerialize = mapSerializationErrorsOne . KS.serializeOne --KS.cerealStreamlyDict+{-# INLINEABLE knitSerialize #-}++mapSerializationErrorsStreamly ::+  P.MemberWithError (P.Error C.CacheError) r+  => KS.Serialize KS.SerializationError (P.Error KS.SerializationError ': r) (Streamly.SerialT (P.Sem (P.Error KS.SerializationError ': r)) a) ct+  -> KS.Serialize C.CacheError r (Streamly.SerialT (P.Sem r) a) ct+mapSerializationErrorsStreamly (KS.Serialize encode decode encBytes) =+  let f =  P.mapError serializationToCacheError+  in KS.Serialize+     (f . fmap (\(ct, a) -> (ct, Streamly.hoist f a)) . encode . Streamly.hoist P.raise)+     (f . fmap (Streamly.hoist f) . decode)+     encBytes++-- | Serialize a Streamly stream of Serializable structures to the CacheData type.+knitSerializeStream :: (sc [a]+                       , P.Member (P.Embed IO) r                +                       , P.MemberWithError (P.Error C.CacheError) r+                       )+                       => KS.SerializeDict sc ct+                       -> KS.Serialize C.CacheError r (Streamly.SerialT (P.Sem r) a) ct+knitSerializeStream = mapSerializationErrorsStreamly . KS.serializeStreamlyViaList --KS.cerealStreamlyDict+{-# INLINEABLE knitSerializeStream #-}++-- | Store an @a@ (serialized) at key k. Throw PandocIOError on IOError.+store+  :: forall sc ct k r a.+     ( P.Members '[KS.SerializeEnv sc ct, C.Cache k ct, P.Error C.CacheError, P.Embed IO] r+     , K.LogWithPrefixesLE r+     , Show k+     , sc a+     )+  => k -- ^ Key+  -> a -- ^ (Serializable) Data to store+  -> P.Sem r ()+store k a = K.wrapPrefix ("Knit.store (key=" <> (T.pack $ show k) <> ")") $ do+  cacheSD <- KS.getSerializeDict+  K.logLE (K.Debug 3) $ "Called with k=" <> (T.pack $ show k)+  C.encodeAndStore (knitSerialize cacheSD) k a+{-# INLINEABLE store #-}++-- | Retrieve an @a@ from the store at key. Throw if not found or I/O Error.+retrieve+  :: forall sc ct k r a.+  (P.Members '[KS.SerializeEnv sc ct, C.Cache k ct, P.Error C.CacheError, P.Embed IO] r+  ,  K.LogWithPrefixesLE r+  , Show k+  , sc a)+  => k                                   -- ^ Key+  -> P.Sem r (C.ActionWithCacheTime r a) -- ^ Time-stamped return from cache.+retrieve k =  K.wrapPrefix ("Cache.retrieve (key=" <> (T.pack $ show k) <> ")") $ do+  cacheSD <- KS.getSerializeDict+  C.retrieveAndDecode (knitSerialize cacheSD) k Nothing+{-# INLINEABLE retrieve #-}++-- | Retrieve an a from the store at key k.+-- If retrieve fails then perform the action and store the resulting a at key k.+retrieveOrMake+  :: forall sc ct k r a b.+  ( P.Members '[KS.SerializeEnv sc ct, C.Cache k ct, P.Error C.CacheError, P.Embed IO] r+  , K.LogWithPrefixesLE r+  , Show k+  , sc a     +  )+  => k                                   -- ^ Key+  -> C.ActionWithCacheTime r b           -- ^ Cached dependencies with time-stamp+  -> (b -> P.Sem r a)                    -- ^ Computation to produce @a@ if absent from cache or cached version is older than dependencies.+  -> P.Sem r (C.ActionWithCacheTime r a) -- ^ Time-stamped return from cache.+retrieveOrMake k cachedDeps toMake =+  K.wrapPrefix ("Cache.retrieveOrMake (key=" <> (T.pack $ show k) <> ")") $ do+   cacheSD <- KS.getSerializeDict+   C.retrieveOrMake (knitSerialize cacheSD) k cachedDeps toMake+{-# INLINEABLE retrieveOrMake #-}++-- | Retrieve an a from the store at key k.+-- If retrieve fails then perform the action and store the resulting a at key k.+-- Also has functions for mapping the input and output: useful for+-- caching something without a 'Serialize' instance but which is isomorphic to+-- something with one.+retrieveOrMakeTransformed+  :: forall sc ct k r a b c.+  ( P.Members '[KS.SerializeEnv sc ct, C.Cache k ct, P.Error C.CacheError, P.Embed IO] r+  , K.LogWithPrefixesLE r+  , Show k+  , sc b+  )+  => (a -> b)                            -- ^ Transform @a@ to Serializable @b@+  -> (b -> a)                            -- ^ Transform Serializable @b@ to @a@+  -> k                                   -- ^ Key+  -> C.ActionWithCacheTime r c           -- ^ Cached dependencies with time-stamp+  -> (c -> P.Sem r a)                    -- ^ Computation to produce @a@ if absent from cache or cached version is older than dependencies.+  -> P.Sem r (C.ActionWithCacheTime r a) -- ^ Time-stamped @a@ from cache.+retrieveOrMakeTransformed toSerializable fromSerializable k newestM toMake =+  K.wrapPrefix "retrieveOrMakeTransformed" +  $ fmap (fmap fromSerializable)+  $ retrieveOrMake k newestM (fmap toSerializable . toMake)+{-# INLINEABLE retrieveOrMakeTransformed #-}++--+-- | Store a Streamly stream of @a@ at key k. Throw @PandocIOError@ on 'IOError'.+storeStream+  :: forall sc ct k r a.+  ( P.Members '[KS.SerializeEnv sc ct, C.Cache k ct, P.Error C.CacheError, P.Embed IO] r+  , P.MemberWithError (P.Error Exceptions.SomeException) r+  , K.LogWithPrefixesLE r+  , Show k+  , sc [a]+  )+  => k                            -- ^ Key+  -> Streamly.SerialT (P.Sem r) a -- ^ Streamly stream to store+  -> P.Sem r ()+storeStream k aS = K.wrapPrefix ("Cache.storeStream key=" <> (T.pack $ show k) <> ")") $ do+  K.logLE(K.Debug 3) $ "Called with k=" <> (T.pack $ show k)+  cacheSD <- KS.getSerializeDict+  C.encodeAndStore (knitSerializeStream cacheSD) k aS+{-# INLINEABLE storeStream #-}++-- | Specify a Streamly Stream as the action in a 'C.WithCacheTime'+type StreamWithCacheTime r a = C.WithCacheTime (Streamly.SerialT (P.Sem r)) a++-- | Use a function from a @Stream (Sem r) a@  to @Sem r a@ to map from a stream action to a plain action over Sem. +streamToAction :: (Streamly.SerialT (P.Sem r) a -> P.Sem r b) -> StreamWithCacheTime r a -> C.ActionWithCacheTime r b+streamToAction = C.wctMapAction+{-# INLINEABLE streamToAction #-}++-- | Wrap a stream action in @Sem r@ to make a stream action into a plain one holding the (still effectful) stream.+streamAsAction :: StreamWithCacheTime r a -> C.ActionWithCacheTime r (Streamly.SerialT (P.Sem r) a)+streamAsAction = streamToAction return+{-# INLINEABLE streamAsAction #-}++-- | Wrapper for AtomicCache.ignoreCacheTime, plus the concatM bit for streamly+ignoreCacheTimeStream :: P.Sem r (StreamWithCacheTime r a) -> Streamly.SerialT (P.Sem r) a+ignoreCacheTimeStream = Streamly.concatM . fmap C.ignoreCacheTime+{-# INLINEABLE ignoreCacheTimeStream #-}++-- | Retrieve a Streamly stream of @a@ from the store at key k. Throw if not found or 'IOError'+-- ignore dependency info+retrieveStream+  :: forall sc k ct r a.+  (P.Members '[KS.SerializeEnv sc ct, C.Cache k ct, P.Error C.CacheError, P.Embed IO] r+  , K.LogWithPrefixesLE r+  , P.MemberWithError (P.Error Exceptions.SomeException) r+  , Show k+  , sc [a])+  => k                                 -- ^ Key+  -> Maybe Time.UTCTime                -- ^ Cached item invalidation time.  Supply @Nothing@ to retrieve regardless of time-stamp.+  -> P.Sem r (StreamWithCacheTime r a) -- ^ Time-stamped stream from cache.+retrieveStream k newestM =  K.wrapPrefix ("Cache.retrieveStream (key=" <> (T.pack $ show k) <> ")") $ do+  cacheSD <- KS.getSerializeDict+  fmap (C.wctMapAction Streamly.concatM)+    $ C.retrieveAndDecode (knitSerializeStream cacheSD) k newestM+{-# INLINEABLE retrieveStream #-}++-- | Retrieve a Streamly stream of @a@ from the store at key @k@.+-- If retrieve fails then perform the action and store the resulting stream at key @k@. +retrieveOrMakeStream+  :: forall sc k ct r a b.+     ( P.Members '[KS.SerializeEnv sc ct, C.Cache k ct, P.Error C.CacheError, P.Embed IO] r+     , K.LogWithPrefixesLE r+     , P.MemberWithError (P.Error Exceptions.SomeException) r+     , Show k+     , sc [a]+     )+  => k                                   -- ^ Key +  -> C.ActionWithCacheTime r b           -- ^ Cached dependencies with time-stamp+  -> (b -> Streamly.SerialT (P.Sem r) a) -- ^ Computation to produce Stream of @a@ if absent from cache or cached version is older than dependencies.+  -> P.Sem r (StreamWithCacheTime r a)   -- ^ Time-stamped stream.+retrieveOrMakeStream k cachedDeps toMake = K.wrapPrefix ("Cache.retrieveOrMakeStream (key=" <> (T.pack $ show k) <> ")") $ do+  cacheSD <- KS.getSerializeDict+  fmap (C.wctMapAction Streamly.concatM)+    $ C.retrieveOrMake (knitSerializeStream cacheSD) k cachedDeps (return . toMake)+{-# INLINEABLE retrieveOrMakeStream #-}++-- | Retrieve a Streamly stream of @a@ from the store at key @k@.+-- If retrieve fails then perform the action and store the resulting stream at key @k@.+-- Also has functions for mapping the input and output: useful for+-- caching something without a 'Serialize' instance but which is isomorphic to+-- something with one.+retrieveOrMakeTransformedStream+  :: forall sc ct k r a b c.+  ( P.Members '[KS.SerializeEnv sc ct, C.Cache k ct, P.Error C.CacheError, P.Embed IO] r+  , K.LogWithPrefixesLE r+  , P.MemberWithError (P.Error Exceptions.SomeException) r+  , Show k+  , sc [b]+  )+  => (a -> b)                            -- ^ Transform @a@ to Serializable @b@+  -> (b -> a)                            -- ^ Transform Serializable @b@ to @a@+  -> k                                   -- ^ Key +  -> C.ActionWithCacheTime r c           -- ^ Cached dependencies with time-stamp+  -> (c -> Streamly.SerialT (P.Sem r) a) -- ^ Computation to produce Stream of @a@ if absent from cache or cached version is older than dependencies.+  -> P.Sem r (StreamWithCacheTime r a)   -- ^ Time-stamped stream.+retrieveOrMakeTransformedStream toSerializable fromSerializable k cachedDeps toMake =+  K.wrapPrefix ("retrieveOrMakeTransformedStream (key=" <> (T.pack $ show k) <> ")")+  $ fmap (C.wctMapAction $ Streamly.map fromSerializable)+  $ retrieveOrMakeStream k cachedDeps (Streamly.map toSerializable . toMake)+{-# INLINEABLE retrieveOrMakeTransformedStream #-}

@@ -0,0 +1,294 @@+{-# LANGUAGE ConstraintKinds      #-}+{-# LANGUAGE CPP                  #-}+{-# LANGUAGE DataKinds            #-}+{-# LANGUAGE ExtendedDefaultRules #-}+{-# LANGUAGE FlexibleContexts     #-}+{-# LANGUAGE GADTs                #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE PolyKinds            #-}+{-# LANGUAGE Rank2Types           #-}+{-# LANGUAGE ScopedTypeVariables  #-}+{-# LANGUAGE TypeOperators        #-}+{-# LANGUAGE TypeApplications     #-}+{-# LANGUAGE TypeFamilies         #-}+{-# LANGUAGE UndecidableInstances #-}+{-|+Module      : Knit.Report.EffectStack+Description : Knit effects stack, interpreters and configuration for Html reports+Copyright   : (c) Adam Conner-Sax 2019+License     : BSD-3-Clause+Maintainer  : adam_conner_sax@yahoo.com+Stability   : experimental++This module contains the core effect stack, interpreter and configurations for building Html reports.++<https://github.com/adamConnerSax/knit-haskell/tree/master/examples Examples> are available, and might be useful for seeing how all this works.+-}+module Knit.Report.EffectStack+  (+    -- * Configuraiton+    KnitConfig(..)+  , defaultKnitConfig++    -- * Knit documents+  , knitHtml+  , knitHtmls++    -- * helpers+  , liftKnit++    -- * Constraints for knit-haskell actions (see examples)+  , KnitEffects+  , CacheEffects+  , CacheEffectsD+  , KnitOne+  , KnitMany+  , KnitBase+  )+where++import           Control.Monad.Except           ( MonadIO )+import qualified Control.Monad.Catch as Exceptions (SomeException, displayException) +import qualified Data.Map                      as M+import           Data.Maybe (fromMaybe)+import qualified Data.Text                     as T+--import qualified Data.Serialize                as S+import qualified Data.Text.Lazy                as TL+import qualified Polysemy                      as P+import qualified Polysemy.Async                as P+import qualified Polysemy.Error                as PE+import qualified Polysemy.IO                   as PI+import qualified System.IO.Error               as IE++import qualified Text.Pandoc                   as PA+import qualified Text.Blaze.Html.Renderer.Text as BH++import qualified Knit.Report.Output            as KO+import qualified Knit.Report.Output.Html       as KO+import qualified Knit.Effect.Docs              as KD+import qualified Knit.Effect.Pandoc            as KP+import qualified Knit.Effect.PandocMonad       as KPM+import qualified Knit.Effect.Logger            as KLog+import qualified Knit.Effect.UnusedId          as KUI+import qualified Knit.Effect.AtomicCache       as KC+import qualified Knit.Effect.Serialize         as KS++{- |+Parameters for knitting. If possible, create this via, e.g., ++@+myConfig = (defaultKnitConfig $ Just "myCacheDir") { pandocWriterConfig = myConfig }+@+so that your code will still compile if parameters are added to this structure.++NB: the type parameters of this configuration specify the cache types:++- @sc :: Type -> Constraint@, where @c a@ is the constraint to be satisfied for serializable @a@.+- @ct :: Type@, is the value type held in the in-memory cache.+- @k  :: Type@, is the key type of the cache.++The @serializeDict@ field holds functions for encoding (@forall a. c a=> a -> ct@)+and decoding (@forall a. c a => ct -> Either SerializationError a@).++The @persistCache@ field holds an interpreter for the persistence layer of+the cache. See 'Knit.AtomicCache' for examples of persistence layers.++If you want to use a different serializer ("binary" or "store") and/or a different type to hold cached+values in-memory, you can set these fields accordingly.+-}+data KnitConfig sc ct k = KnitConfig { outerLogPrefix :: Maybe T.Text+                                     , logIf :: KLog.LogSeverity -> Bool+                                     , pandocWriterConfig :: KO.PandocWriterConfig+                                     , serializeDict :: KS.SerializeDict sc ct+                                     , persistCache :: forall r. (P.Member (P.Embed IO) r+                                                                 , P.MemberWithError (PE.Error KC.CacheError) r+                                                                 , KLog.LogWithPrefixesLE r)+                                                    => P.InterpreterFor (KC.Cache k ct) r+                                     }+++-- | Sensible defaults for a knit configuration.+defaultKnitConfig :: Maybe T.Text -- ^ Optional cache-directory.  Defaults to ".knit-haskell-cache".+                  -> KnitConfig KS.DefaultSerializer KS.DefaultCacheData T.Text -- ^ configuration+defaultKnitConfig cacheDirM =+  let cacheDir = fromMaybe ".knit-haskell-cache" cacheDirM+  in KnitConfig+     (Just "knit-haskell")+     KLog.nonDiagnostic+     (KO.PandocWriterConfig Nothing M.empty id)+     KS.cerealStreamlyDict+     (KC.persistStreamlyByteArray (\t -> T.unpack (cacheDir <> "/" <> t)))+{-# INLINEABLE defaultKnitConfig #-}                               ++-- | Create multiple HTML docs (as Text) from the named sets of pandoc fragments.+-- In use, you may need a type-application to specify @m@.+-- This allows use of any underlying monad to handle the Pandoc effects.+-- NB: Resulting documents are *Lazy* Text, as produced by the Blaze render function.+knitHtmls+  :: (MonadIO m, Ord k, Show k)+  => KnitConfig c ct k -- ^ configuration+  -> P.Sem (KnitEffectDocsStack c ct k m) () -- ^ computation producing a list of documents+  -> m (Either PA.PandocError [KP.DocWithInfo KP.PandocInfo TL.Text]) -- ^ Resulting docs or error, in base monad, usually IO.+knitHtmls config =+  let KO.PandocWriterConfig mFP tv oF = pandocWriterConfig config+  in  consumeKnitEffectStack config . KD.toDocListWithM+        (\(KP.PandocInfo _ tv') a ->+          fmap BH.renderHtml+            . KO.toBlazeDocument (KO.PandocWriterConfig mFP (tv' <> tv) oF)+            $ a+        )+{-# INLINEABLE knitHtmls #-}++-- | Create HTML Text from pandoc fragments.+-- In use, you may need a type-application to specify @m@.+-- This allows use of any underlying monad to handle the Pandoc effects.+-- NB: Resulting document is *Lazy* Text, as produced by the Blaze render function.+knitHtml+  :: (MonadIO m, Ord k, Show k)+  => KnitConfig c ct k -- ^ configuration+  -> P.Sem (KnitEffectDocStack c ct k m) () -- ^ computation producing a single document+  -> m (Either PA.PandocError TL.Text) -- ^ Resulting document or error, in base monad.  Usually IO.+knitHtml config =+  fmap (fmap (fmap BH.renderHtml)) (consumeKnitEffectStack config)+    . KO.pandocWriterToBlazeDocument (pandocWriterConfig config)+{-# INLINEABLE knitHtml #-}                               ++-- | Constraints required to knit a document using effects from a base monad m.+type KnitBase m effs = (MonadIO m, P.Member (P.Embed m) effs)++-- | lift an action in a base monad into a Polysemy monad.  This is just a renaming of `P.embed` for convenience.+liftKnit :: P.Member (P.Embed m) r => m a -> P.Sem r a+liftKnit = P.embed+{-# INLINE liftKnit #-}                               ++-- | Constraint alias for the effects we need (and run)+-- when calling 'knitHtml' or 'knitHtmls'.+-- Anything inside a call to Knit can use any of these effects.+-- Any other effects added to this stack will need to be run before @knitHtml(s)@+type KnitEffects r = (KPM.PandocEffects r+                     , P.Members [ KUI.UnusedId+                                 , KLog.Logger KLog.LogEntry+                                 , KLog.PrefixLog+                                 , P.Async+                                 , PE.Error KC.CacheError+                                 , PE.Error Exceptions.SomeException+                                 , PE.Error PA.PandocError+                                 , P.Embed IO] r+                     )+                     +-- | Constraint alias for the effects we need to use the cache.+type CacheEffects c ct k r = (P.Members [KS.SerializeEnv c ct, KC.Cache k ct] r)++-- | Constraint alias for the effects we need to use the default cache with @Text@ keys.+type CacheEffectsD r = CacheEffects KS.DefaultSerializer KS.DefaultCacheData T.Text r++-- | Constraint alias for the effects we need to knit one document.+type KnitOne r = (KnitEffects r, P.Member KP.ToPandoc r)++-- | Constraint alias for the effects we need to knit multiple documents.+type KnitMany r = (KnitEffects r, P.Member KP.Pandocs r)++-- From here down is unexported.  +-- | The exact stack we are interpreting when we knit+#if MIN_VERSION_pandoc(2,8,0)+type KnitEffectStack c ct k m+  = '[ KUI.UnusedId+     , KPM.Template+     , KPM.Pandoc+     , KS.SerializeEnv c ct+     , KC.Cache k ct+     , KLog.Logger KLog.LogEntry+     , KLog.PrefixLog+     , P.Async+     , PE.Error IOError+     , PE.Error KC.CacheError+     , PE.Error Exceptions.SomeException+     , PE.Error PA.PandocError+     , P.Embed IO+     , P.Embed m+     , P.Final m]+#else+type KnitEffectStack c ct k m+  = '[ KUI.UnusedId+     , KPM.Pandoc+     , KS.SerializeEnv c ct+     , KC.Cache k ct+     , KLog.Logger KLog.LogEntry+     , KLog.PrefixLog+     , P.Async+     , PE.Error IOError+     , PE.Error KC.CacheError+     , PE.Error Exceptions.SomeException+     , PE.Error PA.PandocError+     , P.Embed IO+     , P.Embed m+     , P.Final m]+#endif++-- | Add a Multi-doc writer to the front of the effect list+type KnitEffectDocsStack c ct k m = (KP.Pandocs ': KnitEffectStack c ct k m)++-- | Add a single-doc writer to the front of the effect list+type KnitEffectDocStack c ct k m = (KP.ToPandoc ': KnitEffectStack c ct k m)++-- | run all knit-effects in @KnitEffectStack m@+#if MIN_VERSION_pandoc(2,8,0)+consumeKnitEffectStack+  :: forall c ct k m a+   . (MonadIO m, Ord k, Show k)+  => KnitConfig c ct k+  -> P.Sem (KnitEffectStack c ct k m) a+  -> m (Either PA.PandocError a)+consumeKnitEffectStack config =+  P.runFinal+  . P.embedToFinal+  . PI.embedToMonadIO @m -- interpret (Embed IO) using m+  . PE.runError @KPM.PandocError+  . PE.mapError someExceptionToPandocError+  . PE.mapError cacheErrorToPandocError+  . PE.mapError ioErrorToPandocError -- (\e -> PA.PandocSomeError ("Exceptions.Exception thrown: " <> (T.pack $ show e)))+  . P.asyncToIO -- this has to run after (above) the log, partly so that the prefix state is thread-local.+  . KLog.filteredLogEntriesToIO (logIf config)+  . KC.runPersistenceBackedAtomicInMemoryCache' (persistCache config)+  . KS.runSerializeEnv (serializeDict config)+  . KPM.interpretInIO -- PA.PandocIO+  . KPM.interpretTemplateIO    +  . KUI.runUnusedId+  . maybe id KLog.wrapPrefix (outerLogPrefix config)+#else+consumeKnitEffectStack+  :: forall c ct k m a+   . (MonadIO m, Ord k, Show k)+  => KnitConfig c ct k+  -> P.Sem (KnitEffectStack c ct k m) a+  -> m (Either PA.PandocError a)+consumeKnitEffectStack config =+  P.runFinal+  . P.embedToFinal+  . PI.embedToMonadIO @m -- interpret (Embed IO) using m+  . PE.runError+  . PE.mapError someExceptionToPandocError+  . PE.mapError cacheErrorToPandocError+  . PE.mapError ioErrorToPandocError -- (\e -> PA.PandocSomeError ("Exceptions.Exception thrown: " <> (T.pack $ show e)))+  . P.asyncToIO -- this has to run after (above) the log, partly so that the prefix state is thread-local.+  . KLog.filteredLogEntriesToIO (logIf config)+  . KC.runPersistenceBackedAtomicInMemoryCache' (persistCache config)+  . KS.runSerializeEnv (serializeDict config)+  . KPM.interpretInIO -- PA.PandocIO        +  . KUI.runUnusedId+  . maybe id KLog.wrapPrefix (outerLogPrefix config)+#endif+{-# INLINEABLE consumeKnitEffectStack #-}+++ioErrorToPandocError :: IE.IOError -> KPM.PandocError+ioErrorToPandocError e = PA.PandocIOError (KPM.textToPandocText $ ("IOError: " <> (T.pack $ show e))) e+{-# INLINEABLE ioErrorToPandocError #-}++cacheErrorToPandocError :: KC.CacheError -> KPM.PandocError+cacheErrorToPandocError e = PA.PandocSomeError (KPM.textToPandocText $ ("CacheError: " <> (T.pack $ show e)))+{-# INLINEABLE cacheErrorToPandocError #-}++someExceptionToPandocError :: Exceptions.SomeException -> KPM.PandocError+someExceptionToPandocError = PA.PandocSomeError . KPM.textToPandocText . T.pack . Exceptions.displayException +{-# INLINEABLE someExceptionToPandocError #-}

@@ -0,0 +1,74 @@+{-# LANGUAGE ConstraintKinds      #-}+{-# LANGUAGE DataKinds            #-}+{-# LANGUAGE ExtendedDefaultRules #-}+{-# LANGUAGE FlexibleContexts     #-}+{-# LANGUAGE GADTs                #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE PolyKinds            #-}+{-# LANGUAGE Rank2Types           #-}+{-# LANGUAGE ScopedTypeVariables  #-}+{-# LANGUAGE TypeOperators        #-}+{-# LANGUAGE TypeApplications     #-}+{-# LANGUAGE TypeFamilies         #-}+{-# LANGUAGE UndecidableInstances #-}+{-|+Module      : Knit.Report.Error+Description : knit-haskell functions to handle and raise errors in knit-haskell reports.+Copyright   : (c) Adam Conner-Sax 2019+License     : BSD-3-Clause+Maintainer  : adam_conner_sax@yahoo.com+Stability   : experimental++This module has various combinators for simplifying the throwing of Errors in knit-haskell.++<https://github.com/adamConnerSax/knit-haskell/tree/master/examples Examples> are available, and might be useful for seeing how all this works.++-}+module Knit.Report.Error+  (+    -- * Error combinators+    knitError+  , knitMaybe+  , knitEither+  , knitMapError+  )+where++import qualified Knit.Report.EffectStack       as K+import qualified Text.Pandoc.Error             as PA+import           Knit.Effect.PandocMonad        ( textToPandocText )++import qualified Data.Text                     as T++import qualified Polysemy                      as P+import qualified Polysemy.Error                as PE++++-- | Throw an error with a specific message.  This will emerge as a 'PandocSomeError' in order+-- to avoid complicating the error type.+-- NB: The Member constraint is satisfied by KnitEffectStack m.+knitError :: P.Member (PE.Error PA.PandocError) r => T.Text -> P.Sem r a+knitError msg =+  PE.throw (PA.PandocSomeError $ textToPandocText $ "Knit User Error: " <> msg)++-- | Throw on 'Nothing' with given message.  This will emerge as a 'PandocSomeError' in order+-- to avoid complicating the error type.+knitMaybe+  :: P.Member (PE.Error PA.PandocError) r => T.Text -> Maybe a -> P.Sem r a+knitMaybe msg = maybe (knitError msg) return++-- | Throw on 'Left' with message.  This will emerge as a 'PandocSomeError' in order+-- to avoid complicating the error type.+knitEither+  :: P.Member (PE.Error PA.PandocError) r => Either T.Text a -> P.Sem r a+knitEither = either knitError return++-- | Map an error type, @e, into a 'PandocError' so it will be handled in this stack+knitMapError+  :: forall e r a+   . K.KnitEffects r+  => (e -> T.Text)+  -> P.Sem (PE.Error e ': r) a+  -> P.Sem r a+knitMapError f = PE.mapError $ PA.PandocSomeError . textToPandocText . f

@@ -19,7 +19,7 @@   (     -- * Add Diagrams Inputs     addDiagramAsSVG-    -- * re-exports+    -- * Diagrams Re-Exports   , module Diagrams.Prelude   , module Diagrams.Backend.SVG   )@@ -36,7 +36,7 @@ --import           Data.Maybe                     ( fromMaybe )  import qualified Diagrams.Prelude              as D-import           Diagrams.Prelude        hiding ( trace ) -- this conflicts with Pandoc trace.  TO get it, you'll need to import it directly+import           Diagrams.Prelude         hiding ( trace ) -- this conflicts with Pandoc trace.  TO get it, you'll need to import it directly --import qualified Diagrams.TwoD.Size            as D import qualified Diagrams.Backend.SVG          as DSVG import           Diagrams.Backend.SVG@@ -47,7 +47,7 @@ import qualified Knit.Effect.PandocMonad       as PM import qualified Knit.Effect.UnusedId          as KUI --- | Add diagram (via svg inserted as html).+-- | Add diagram (via SVG inserted as HTML) with user supplied width and height. addDiagramAsSVG   :: ( PM.PandocEffects effs      , P.Member PE.ToPandoc effs@@ -65,6 +65,7 @@         DSVG.SVGOptions (D.dims2D wPixels hPixels) Nothing idText [] False   addDiagramAsSVGWithOptions (Just idText) captionTextM svgOptions diagram +-- | Add diagram (via SVG inserted as HTML) with user-supplied options. addDiagramAsSVGWithOptions   :: ( PM.PandocEffects effs      , P.Member PE.ToPandoc effs

@@ -27,7 +27,6 @@  import qualified Data.Aeson.Encode.Pretty      as A import qualified Data.ByteString.Lazy.Char8    as BS-import           Data.Monoid                    ( (<>) ) import qualified Data.Text                     as T import qualified Data.Text.Encoding            as T import qualified Graphics.Vega.VegaLite        as GV

@@ -26,7 +26,6 @@  import qualified Data.Aeson.Encode.Pretty   as A import qualified Data.ByteString.Lazy.Char8 as BS-import           Data.Monoid                ((<>)) import qualified Data.Text                  as T import qualified Data.Text.Encoding         as T import qualified Graphics.Vega.VegaLite     as GV

@@ -1,10 +1,12 @@+{-# LANGUAGE CPP                  #-}+{-# LANGUAGE DataKinds            #-} {-# LANGUAGE ExtendedDefaultRules #-}+{-# LANGUAGE FlexibleContexts     #-}+{-# LANGUAGE GADTs                #-} {-# LANGUAGE OverloadedStrings    #-} {-# LANGUAGE ScopedTypeVariables  #-}-{-# LANGUAGE FlexibleContexts     #-} {-# LANGUAGE TypeOperators        #-}-{-# LANGUAGE DataKinds            #-}-{-# LANGUAGE GADTs                #-}+ {-| Module      : Knit.Report.Output.Html Description : Output Pandoc as Html@@ -44,6 +46,7 @@ import qualified Text.Blaze.Html               as BH import qualified Text.Pandoc                   as PA + import qualified Polysemy                      as P import qualified Knit.Effect.Pandoc            as PE import qualified Knit.Effect.PandocMonad       as PM@@ -52,6 +55,11 @@                                                 ( markDownReaderOptions ) import           Knit.Report.Output            as KO +#if MIN_VERSION_pandoc (2,8,0)+import qualified Text.DocTemplates             as DT+import qualified Control.Monad.Except           as X+#endif+ -- | Base Html writer options, with support for MathJax htmlWriterOptions :: PA.WriterOptions htmlWriterOptions = PA.def@@ -60,7 +68,52 @@   }  -- | Full writer options which use pandoc monad for template access+#if MIN_VERSION_pandoc (2,8,0) htmlFullDocWriterOptions+  :: forall m. (PA.PandocMonad m, DT.TemplateMonad m)+  => Maybe FilePath -- ^ path to template to include, @Nothing@ for no template.+  -> M.Map String String -- ^ template Variable substitutions+  -> m PA.WriterOptions+htmlFullDocWriterOptions pathM tVars = do+  let tContext = DT.Context $ M.mapKeys T.pack $ fmap (DT.toVal . T.pack) tVars+      makeTemplateM :: FilePath -> m T.Text -> m (Maybe (DT.Template T.Text))+      makeTemplateM pfp getText = do+        txt <- getText+        compiled <- PA.compileTemplate pfp txt+        case compiled of+          Left msg -> X.throwError $ PA.PandocTemplateError $  T.pack msg+          Right tmplt -> return $ Just $ fmap T.pack tmplt+      defaultTemplateM = makeTemplateM "default.Html5" (PA.getDefaultTemplate "Html5")+  templateM <- case pathM of+    Nothing -> defaultTemplateM+    Just fp -> do+      exists <- PA.fileExists fp+      if exists+        then makeTemplateM "" $ fmap (T.pack . BS.unpack) (PA.readFileStrict fp)+        else+          PA.logOutput+              (PA.IgnoredIOError+                (PM.textToPandocText $ "Couldn't find " <> (T.pack $ show fp))+              )+            >> defaultTemplateM+  return $ htmlWriterOptions { PA.writerTemplate      = templateM+                             , PA.writerVariables     = tContext --M.toList tVars+                             , PA.writerSetextHeaders = True+                             }++-- Incudes support for template and template variables and changes to the default writer options+toBlazeDocument+  :: PM.PandocEffects effs+  => KO.PandocWriterConfig+  -> PE.PandocWithRequirements -- ^ Document and union of input requirements +  -> P.Sem effs BH.Html+toBlazeDocument writeConfig pdocWR = PM.absorbTemplateMonad $ PM.absorbPandocMonad $ do+  writerOptions <- htmlFullDocWriterOptions (templateFP writeConfig)+                                            (templateVars writeConfig)+  PE.fromPandoc PE.WriteHtml5 (optionsF writeConfig writerOptions) pdocWR++#else  +htmlFullDocWriterOptions   :: PA.PandocMonad m   => Maybe FilePath -- ^ path to template to include, @Nothing@ for no template.   -> M.Map String String -- ^ template Variable substitutions@@ -72,13 +125,28 @@       exists <- PA.fileExists fp       if exists         then fmap BS.unpack (PA.readFileStrict fp)-        else PA.logOutput (PA.IgnoredIOError ("Couldn't find " ++ show fp))-          >> PA.getDefaultTemplate "Html5"+        else+          PA.logOutput+              (PA.IgnoredIOError+                (PM.textToPandocText $ "Couldn't find " <> (T.pack $ show fp))+              )+            >> PA.getDefaultTemplate "Html5"   return $ htmlWriterOptions { PA.writerTemplate      = Just template                              , PA.writerVariables     = M.toList tVars                              , PA.writerSetextHeaders = True                              } +-- Incudes support for template and template variables and changes to the default writer options+toBlazeDocument+  :: PM.PandocEffects effs+  => KO.PandocWriterConfig+  -> PE.PandocWithRequirements -- ^ Document and union of input requirements +  -> P.Sem effs BH.Html+toBlazeDocument writeConfig pdocWR = PM.absorbPandocMonad $ do+  writerOptions <- htmlFullDocWriterOptions (templateFP writeConfig)+                                            (templateVars writeConfig)+  PE.fromPandoc PE.WriteHtml5 (optionsF writeConfig writerOptions) pdocWR+#endif  -- | Convert markDown to Blaze markDownTextToBlazeFragment@@ -90,17 +158,9 @@     . PE.addFrom PE.ReadMarkDown markDownReaderOptions  ++ -- | Convert given Pandoc to Blaze Html.--- Incudes support for template and template variables and changes to the default writer options-toBlazeDocument-  :: PM.PandocEffects effs-  => KO.PandocWriterConfig-  -> PE.PandocWithRequirements -- ^ Document and union of input requirements -  -> P.Sem effs BH.Html-toBlazeDocument writeConfig pdocWR = PM.absorbPandocMonad $ do-  writerOptions <- htmlFullDocWriterOptions (templateFP writeConfig)-                                            (templateVars writeConfig)-  PE.fromPandoc PE.WriteHtml5 (optionsF writeConfig writerOptions) pdocWR  -- | Convert current Pandoc document (from the ToPandoc effect) into a Blaze Html document. -- Incudes support for template and template variables and changes to the default writer options. 

@@ -0,0 +1,72 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}+{-# LANGUAGE UndecidableInstances #-}+module Knit.Utilities.Streamly+  (+    StreamlyM+  , StreamlyEffects(..)+  , streamlyToKnit+  , streamlyToKnitS+  , logStreamly  +  )+where++import qualified Knit.Report as Knit+import qualified Knit.Effect.Logger as Knit.Logger++import qualified Streamly+import qualified Streamly.Internal.Prelude as Streamly++import qualified Polysemy ++--import qualified Polysemy.Error+--import           Control.Monad.Catch  (SomeException)++import qualified Control.Monad.Reader as Reader++import           Control.Monad.Catch  (MonadThrow, MonadCatch)+import Control.Monad.Base (MonadBase)+import Control.Monad.Trans.Control (MonadBaseControl)++import qualified Data.Text as Text++-- | record-of-functions to hold access to effects we want to have available in this+-- ReaderT over IO wrapper for Streamly+data StreamlyEffects = StreamlyEffects { logIO :: Knit.Logger.LogSeverity -> Text.Text -> IO () }++-- | Use the logging function in the Reader to log in a StreamlyM context.+logStreamly :: Knit.Logger.LogSeverity -> Text.Text -> StreamlyM ()+logStreamly ls t = do+  logFunction <- Reader.asks logIO+  Reader.liftIO $ logFunction ls t+{-# INLINEABLE logStreamly #-}++-- | IO with a ReaderTlayer we can use to expose effects we need.  For now just logging.+newtype StreamlyM a = StreamlyM { unStreamlyM :: Reader.ReaderT StreamlyEffects IO a }+  deriving newtype (Functor, Applicative, Monad, Reader.MonadReader StreamlyEffects)+  deriving (MonadThrow, MonadCatch, Reader.MonadIO, MonadBase IO, MonadBaseControl IO) via (Reader.ReaderT StreamlyEffects IO)++-- | lift a 'StreamlyM' computation into a 'Knit.Sem' computation+streamlyToKnit :: (Polysemy.Member (Polysemy.Embed IO) r+                  , Knit.Logger.LogWithPrefixesLE r+                  )+  => StreamlyM a -> Knit.Sem r a+streamlyToKnit sa = do+  curPrefix <- Knit.Logger.getPrefix+  let logFunction = Knit.Logger.logWithPrefixToIO +      se = StreamlyEffects (\ls lmsg -> logFunction curPrefix (Knit.Logger.LogEntry ls lmsg))+  Polysemy.embed $ Reader.runReaderT (unStreamlyM sa) se+{-# INLINEABLE streamlyToKnit #-}++-- | Serial streams work fine over Sem, so we can lift the effectful serial stream into @Sem r@ without running.+streamlyToKnitS :: (Polysemy.Member (Polysemy.Embed IO) r+                  , Knit.Logger.LogWithPrefixesLE r+                  )+                => Streamly.SerialT StreamlyM a -> Streamly.SerialT (Knit.Sem r) a+streamlyToKnitS = Streamly.hoist streamlyToKnit+{-# INLINEABLE streamlyToKnitS #-}

@@ -0,0 +1,129 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -O2 -fdicts-strict -fspec-constr-recursive=16 -fmax-worker-args=16 #-} -- for streamly+module Streamly.External.Cereal+  (+    encodeStreamly+  , decodeStreamly+  , encodeStreamlyArray+  , decodeStreamlyArray  +  , encodeStream+  , decodeStream+  , encodeStreamArray+  , decodeStreamArray+  , putStreamOf+  , getStreamOf+  )+where++import qualified Streamly as Streamly+import qualified Streamly.Prelude as Streamly+import qualified Streamly.Internal.Prelude as Streamly (splitParse)+import qualified Streamly.Internal.Memory.Array as Streamly.Array+import qualified Streamly.Internal.Memory.ArrayStream as Streamly.Array+import qualified Streamly.Internal.Data.Parser.Types as Streamly.Parser+import qualified Streamly.External.ByteString as Streamly.ByteString++import qualified Control.Monad.Catch as Exceptions (MonadThrow(..), MonadCatch(..))+import Control.Monad.IO.Class (MonadIO)++import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BL+import           Data.Functor.Identity (Identity(..))+import qualified Data.Serialize as Cereal+import qualified Data.Text as Text+import qualified Data.Word as Word++-- These go through []. I'm hoping the list fuses away.+-- One issue is that Cereal wants a length first and that requires spine strictness+-- on the encoding side.+-- | Convert something which can encode an @a@ to something which can encode a (non-effectful) stream of @a@+putStreamOf :: Cereal.Putter a -> Cereal.Putter (Streamly.SerialT Identity a)+putStreamOf pa = runIdentity . fmap (Cereal.putListOf pa) . Streamly.toList +{-# INLINEABLE putStreamOf #-}++-- | Convert something which can decode an @a@ to something which can decode a (possibly-effectful) stream of @a@+getStreamOf :: Monad m => Cereal.Get a -> Cereal.Get (Streamly.SerialT m a)+getStreamOf ga = fmap Streamly.fromList $ Cereal.getListOf ga+{-# INLINEABLE getStreamOf #-}++-- | Given @Serialize a@, encode to a Stream of bytes +encodeStreamly :: (Cereal.Serialize a, Monad m) => a -> Streamly.SerialT m Word.Word8+encodeStreamly = encodePut . Cereal.put+{-# INLINEABLE encodeStreamly #-}++-- | Given @Serialize a@, encode to n array of bytes+encodeStreamlyArray :: Cereal.Serialize a => a -> Streamly.Array.Array Word.Word8+encodeStreamlyArray = encodePutArray . Cereal.put+{-# INLINEABLE encodeStreamlyArray #-}++-- | Given a Cereal "Putter", encode to a byte stream+encodePut :: Monad m => Cereal.Put -> Streamly.SerialT m Word.Word8+encodePut = Streamly.unfoldr BL.uncons . Cereal.runPutLazy+{-# INLINEABLE encodePut #-}++-- | Given a Cereal "Putter", encode to a byte array+encodePutArray :: Cereal.Put -> Streamly.Array.Array Word.Word8+encodePutArray = Streamly.ByteString.toArray  . Cereal.runPut+{-# INLINEABLE encodePutArray #-}++-- | Give an instance of `@Serialize` for @a@, attempt to decode a byte-stream into an a.+decodeStreamly :: (Cereal.Serialize a, Monad m) => Streamly.SerialT m Word.Word8 -> m (Either Text.Text a)+decodeStreamly = decodeGet Cereal.get+{-# INLINEABLE decodeStreamly #-}++-- | Given a Cereal @Getter@, decode one @a@ from an effectful stream on bytes. +decodeGet :: Monad m => Cereal.Get a -> Streamly.SerialT m Word.Word8 -> m (Either Text.Text a)+decodeGet g s = go s $ Cereal.runGetPartial g where+  go x f = do+    y <- Streamly.uncons x +    case y of+      Nothing -> return $ Left "Premature end of stream reached."+      Just (b, tx) -> case f $ BS.singleton b of+        Cereal.Fail e _ -> return $ Left $ "Cereal Error: " <> (Text.pack e)+        Cereal.Done a _ -> return $ Right a+        Cereal.Partial f' -> go tx f'+{-# INLINEABLE decodeGet #-}++-- | Given @Serialize a@, attempt to decode a Streamly array of bytes into an @a@+decodeStreamlyArray :: (Cereal.Serialize a) => Streamly.Array.Array Word.Word8 -> Either Text.Text a+decodeStreamlyArray = either (Left . Text.pack) Right . Cereal.decode . Streamly.ByteString.fromArray +{-# INLINEABLE decodeStreamlyArray #-}++-- | Given @Serialize a@, attempt to encode a stream of @a@s as a Streamly stream of bytes.+encodeStream :: (Monad m, Cereal.Serialize a) => Streamly.SerialT m a -> Streamly.SerialT m Word.Word8+encodeStream = Streamly.concatMap encodeStreamly+{-# INLINEABLE encodeStream #-}++-- | Given @Serialize a@, attempt to encode a sterm of @a@s as a Streamly array of bytes.+encodeStreamArray :: (Monad m, MonadIO m, Cereal.Serialize a) => Streamly.SerialT m a -> m (Streamly.Array.Array Word.Word8)+encodeStreamArray = Streamly.Array.toArray . Streamly.map encodeStreamlyArray +{-# INLINEABLE encodeStreamArray #-}++-- NB this will keep decoding as until failure.  But it can't know why it failed so it+-- assumes failure indicates end of the input stream.+-- Parser state is (Maybe a, ByteStream -> Cereal.Result a)+-- | Streamly Parser for decoding bytes into @a@s (given @Serialize a@) +streamlyDecodeParser :: (Monad m, Exceptions.MonadThrow m, Cereal.Serialize a) => Streamly.Parser.Parser m Word.Word8 a+streamlyDecodeParser = Streamly.Parser.Parser step (return $ (Nothing, Cereal.runGetPartial Cereal.get)) extract where+  step (_, f) w = case f $ BS.singleton w of+    Cereal.Fail e _ -> return $ Streamly.Parser.Error e+    Cereal.Done a _ -> return $ Streamly.Parser.Yield 0 (Just a, Cereal.runGetPartial Cereal.get)+    Cereal.Partial f' -> return $ Streamly.Parser.Skip 0 (Nothing, f')+  extract (ma, _)  = case ma of+    Just a -> return a+    Nothing -> Exceptions.throwM $ Streamly.Parser.ParseError "Parsing error in streamlyDecodeParser (\"extract\" called on incomplete parse.)."   +{-# INLINEABLE streamlyDecodeParser #-}++-- | Given @Serialize a@, decode a Stream of bytes into a stream of @a@s+decodeStream :: (Monad m, Exceptions.MonadCatch m, Cereal.Serialize a)+             => Streamly.SerialT m Word.Word8 -> Streamly.SerialT m a+decodeStream = Streamly.splitParse streamlyDecodeParser+{-# INLINEABLE decodeStream #-}++-- we convert the array to a stream so we can decode lazily (?)+-- | Given @Serialize a@, decode an array of bytes into a stream of @a@s+decodeStreamArray :: (Monad m, Exceptions.MonadCatch m, Cereal.Serialize a)+                  => Streamly.Array.Array Word.Word8 -> Streamly.SerialT m a+decodeStreamArray = decodeStream . Streamly.Array.toStream +{-# INLINEABLE decodeStreamArray #-}+