packages feed

knit-haskell (empty) → 0.1.0.0

raw patch · 24 files changed

+2707/−0 lines, 24 filesdep +Globdep +aeson-prettydep +base

Dependencies added: Glob, aeson-pretty, base, base64-bytestring, blaze-colonnade, blaze-html, bytestring, case-insensitive, colonnade, containers, directory, here, http-client, http-client-tls, http-types, hvega, knit-haskell, logging-effect, lucid, mtl, network, network-uri, pandoc, polysemy, prettyprinter, random, random-fu, random-source, text, time

Files

+ ChangeLog.md view
@@ -0,0 +1,2 @@+v 0.1.0.0  +* Initial version
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2018, Adam Conner-Sax++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Adam Conner-Sax nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ examples/MtlExample.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE QuasiQuotes                #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE TypeApplications           #-}+{-# LANGUAGE GADTs                      #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Main where++import qualified Knit.Report as K    ++import           Control.Monad.IO.Class          (MonadIO)+import qualified Data.Map                      as M+import qualified Data.Text.IO                  as T+import qualified Data.Text.Lazy                as TL+import qualified Data.Text                as T+import           Data.String.Here (here)+import qualified Graphics.Vega.VegaLite        as V++import           Control.Monad.Reader (ReaderT, ask, runReaderT)++templateVars :: M.Map String String+templateVars = M.fromList+  [ ("lang"     , "English")+  , ("author"   , "Adam Conner-Sax")+  , ("pagetitle", "knit-haskell mtl example")+--  , ("tufte","True")+  ]++-- A demo application stack +newtype MyApp env a = MyStack { unMyApp :: ReaderT env IO a } deriving (Functor, Applicative, Monad, MonadIO)++type ExampleApp = MyApp T.Text++runExampleApp :: T.Text -> ExampleApp a -> IO a+runExampleApp t = flip runReaderT t . unMyApp++getEnv :: MyApp env env+getEnv = MyStack $ ask++main :: IO ()+main = do+  let pandocWriterConfig =+        K.PandocWriterConfig (Just "pandoc-templates/minWithVega-pandoc.html")  templateVars K.mindocOptionsF+  resE <- runExampleApp "This is from the MyApp environment."+    $ K.knitHtml (Just "MtlExample.Main") K.logAll pandocWriterConfig makeDoc+  case resE of+    Right htmlAsText ->+      T.writeFile "examples/html/mtl_example.html"+        $ TL.toStrict+        $ 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.Member K.ToPandoc effs+           , K.PandocEffects effs+           , K.KnitBase ExampleApp effs) => K.Semantic 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 "adding a visualization..."+  K.addMarkDown "## An example hvega visualization"+  K.addHvega "someID" exampleVis++  K.logLE K.Info "Retrieving some text from the base monad and current date-time."+  envText <- K.liftKnit @ExampleApp getEnv+  curTime <- K.getCurrentTime +  K.addMarkDown "## An example of getting env from a base monad, and time from the Pandoc Effects."+  K.addMarkDown $ envText <> "\n\n" <> (T.pack $ show curTime)++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 [] ]
+ examples/RandomExample.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE QuasiQuotes                #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE TypeApplications           #-}+{-# LANGUAGE GADTs                      #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module Main where++import qualified Knit.Report               as K+import qualified Knit.Effect.RandomFu      as KR+import qualified Colonnade                 as C++import           Control.Monad.IO.Class     (MonadIO)+import qualified Data.Map                  as M+import qualified Data.Random               as R+import qualified Data.Text.IO              as T+import qualified Data.Text.Lazy            as TL+import qualified Data.Text                 as T+import           Data.String.Here           (here)+import qualified Graphics.Vega.VegaLite    as V++import           Control.Monad.Reader       (ReaderT+                                            , ask+                                            , runReaderT+                                            )++templateVars :: M.Map String String+templateVars = M.fromList+  [ ("lang"     , "English")+  , ("author"   , "Adam Conner-Sax")+  , ("pagetitle", "knit-haskell mtl example with random effect")+--  , ("tufte","True")+  ]++-- A demo application stack +newtype MyApp env a = MyStack { unMyApp :: ReaderT env IO a } deriving (Functor, Applicative, Monad, MonadIO)++type ExampleApp = MyApp T.Text++runExampleApp :: T.Text -> ExampleApp a -> IO a+runExampleApp t = flip runReaderT t . unMyApp++getEnv :: MyApp env env+getEnv = MyStack $ ask++main :: IO ()+main = do+  let pandocWriterConfig =+        K.PandocWriterConfig (Just "pandoc-templates/minWithVega-pandoc.html")  templateVars K.mindocOptionsF+  resE <- runExampleApp "This is from the MyApp environment."+          $ K.knitHtml (Just "RandomExample.Main") K.logAll pandocWriterConfig+          $ KR.runRandomIOSimple $ makeDoc+  case resE of+    Right htmlAsText ->+      T.writeFile "examples/html/random_example.html"+        $ TL.toStrict+        $ 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.Member K.ToPandoc effs+           , K.PandocEffects effs+           , K.Member KR.Random effs -- this one needs to be handled before knitting+           , K.KnitBase ExampleApp effs) => K.Semantic 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 "adding a visualization..."+  K.addMarkDown "## An example hvega visualization"+  K.addHvega "someID" exampleVis++  K.logLE K.Info "Retrieving some text from the base monad and current date-time."+  envText <- K.liftKnit @ExampleApp getEnv+  curTime <- K.getCurrentTime +  K.addMarkDown "## An example of getting env from a base monad, and time from the Pandoc Effects."  +  K.addMarkDown $ envText <> "\n\n" <> (T.pack $ show curTime)++  K.logLE K.Info "Using another polysemy effect, here RandomFu"+  let draws = [1..20 :: Int]+  someNormalDoubles <- KR.sampleRVar $ mapM (const $ R.stdNormal @Double) draws+  K.addMarkDown "## An example of using the RandomFu effect to get random numbers and using Colonnade to make tables."+  K.addMarkDown $ "some std normal draws: "+  K.addColonnadeTextTable (C.headed "#" (T.pack . show . fst) <> C.headed "Draw" (T.pack . show . snd)) $ zip draws someNormalDoubles+  +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 [] ]
+ examples/SimpleExample.hs view
@@ -0,0 +1,67 @@+{-# 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.IO                  as T+import qualified Data.Text.Lazy                as TL+import qualified Data.Text                as T+import           Data.String.Here (here)+import qualified Graphics.Vega.VegaLite        as V++templateVars :: M.Map String String+templateVars = M.fromList+  [ ("lang"     , "English")+  , ("author"   , "Adam Conner-Sax")+  , ("pagetitle", "knit-haskell simple example")+--  , ("tufte","True")+  ]++main :: IO ()+main = do+  let pandocWriterConfig = K.PandocWriterConfig (Just "pandoc-templates/minWithVega-pandoc.html")  templateVars K.mindocOptionsF+  resE <- K.knitHtml (Just "SimpleExample.Main") K.logAll pandocWriterConfig makeDoc+  case resE of+    Right htmlAsText ->+      T.writeFile "examples/html/example_simple.html"+        $ TL.toStrict+        $ 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.Member K.ToPandoc effs -- required for the single-document variant+           , K.PandocEffects effs -- all effects for knitting+           ) +        => K.Semantic 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 "adding a visualization..."+  K.addMarkDown "## An example hvega visualization"+  K.addHvega "someID" exampleVis++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 [] ]
+ knit-haskell.cabal view
@@ -0,0 +1,135 @@+cabal-version:       2.2++name:                knit-haskell+version:             0.1.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, randomness+                     (via <http://hackage.haskell.org/package/random-fu random-fu>),+                     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.+                     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:             BSD-3-Clause+license-file:        LICENSE+author:              Adam Conner-Sax+maintainer:          adam_conner_sax@yahoo.com+copyright:           2019 Adam Conner-Sax+category:            Text+extra-source-files:  ChangeLog.md+tested-with: GHC ==8.6.4 || ==8.6.2                     +Build-type: Simple++source-repository head+    Type: git+    Location: https://github.com/adamConnerSax/knit-haskell+                                      +library+  ghc-options: -Wall -funbox-strict-fields+  exposed-modules: Knit.Effect.Logger+                 , Knit.Effect.Docs+                 , Knit.Effect.Html+                 , Knit.Effect.RandomFu+                 , Knit.Effect.PandocMonad+                 , Knit.Effect.Pandoc+                 , Knit.Report.Input.Table.Colonnade+                 , Knit.Report.Input.Html+                 , Knit.Report.Input.Html.Lucid+                 , Knit.Report.Input.Html.Blaze+                 , Knit.Report.Input.Latex+                 , Knit.Report.Input.MarkDown.PandocMarkDown+                 , Knit.Report.Input.Visualization.Hvega+                 , Knit.Report.Output+                 , Knit.Report.Output.Html+                 , Knit.Report+                 , Knit.Report.Other.Lucid+                 , Knit.Report.Other.Blaze++  build-depends:    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,+                    bytestring                        >= 0.10.8 && < 0.11,+                    case-insensitive                  >= 1.2.0.11 && < 1.3.0.0,+                    colonnade                         >= 1.1 && < 1.3,+                    containers                        >= 0.6.0 && < 0.7,+                    directory                         >= 1.3.3.0 && < 1.4.0.0,+                    Glob                              >= 0.10.0 && < 0.11.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,+                    network                           >= 2.8.0.0 && < 3.1.0.0,+                    network-uri                       >= 2.6.1.0 && < 2.7.0.0,+                    text                              >= 1.2.3 && < 1.3,+                    time                              >= 1.8.0 && < 1.9,+                    random                            >= 1.1 && < 1.2,+                    blaze-html                        >= 0.9.1 && < 0.10,+                    hvega                             >= 0.1.0 && <= 0.2.0.0,+                    logging-effect                    >= 1.3.3 && < 1.4,+                    mtl                               >= 2.2.2 && < 2.3,+                    polysemy                          >= 0.1.1.0 && < 0.2.0.0,+                    prettyprinter                     >= 1.2.1 && < 1.3,+                    lucid                             >= 2.9.11 && < 2.10,+                    pandoc                            >= 2.7.2 && < 2.8,+                    random-fu                         >= 0.2.7 && < 0.3,+                    random-source                     >= 0.3.0 && < 0.4,++  hs-source-dirs:      src+  default-language:    Haskell2010+++executable SimpleExample+    main-is: SimpleExample.hs+    hs-source-dirs: examples+    ghc-options: -Wall +    build-depends: base,+                   blaze-html,+                   containers,+                   here                              >= 1.2.10 && < 1.3.0,+                   hvega,     +                   knit-haskell                      -any,+                   polysemy,  +                   text      +    default-language: Haskell2010++executable MtlExample+    main-is: MtlExample.hs+    hs-source-dirs: examples+    ghc-options: -Wall +    build-depends: base,+                   blaze-html,+                   containers,+                   here,+                   hvega,+                   knit-haskell                      -any,+                   mtl,+                   polysemy,+                   text+    default-language: Haskell2010++executable RandomExample+    main-is: RandomExample.hs+    hs-source-dirs: examples+    ghc-options: -Wall +    build-depends: base,+                   blaze-html,+                   colonnade,+                   containers,+                   here,+                   hvega,+                   knit-haskell                      -any,+                   mtl,+                   polysemy,+                   random-fu,+                   text+    default-language: Haskell2010
+ src/Knit/Effect/Docs.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE PolyKinds           #-}+{-# LANGUAGE TypeOperators       #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DeriveFunctor       #-}+{-# LANGUAGE DeriveTraversable   #-}+{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}+{-|+Module      : Knit.Effect.Docs+Description : Polysemy effect for creating a list of named documents+Copyright   : (c) Adam Conner-Sax 2019+License     : BSD-3-Clause+Maintainer  : adam_conner_sax@yahoo.com+Stability   : experimental++<https://github.com/isovector/polysemy#readme Polysemy> effect used by knit-haskell when one code-base is used to create multiple docs.+Each can be created and then stored in the+list maintained by this effect.  Then, when the effects are "run", this list can be processed to produce the required+output.+-}+module Knit.Effect.Docs+  (+    -- * Effect+    Docs++    -- * Actions+  , newDoc++    -- * Interpretations+  , toNamedDocList+  , toNamedDocListWith+  , toNamedDocListWithM++    -- * Helper Types+  , NamedDoc(..)++    -- * Helper Functions+  , mapNamedDocs+  , mapNamedDocsM+  )+where++import qualified Data.Text                     as T+import qualified Polysemy                      as P+import           Polysemy.Internal              ( send )+import qualified Polysemy.Writer               as P+++-- | GADT to represent storing a named document.+data Docs a m r where+  NewDoc :: T.Text -> a -> Docs a m ()++-- | Action of the 'Docs' Effect.  Store a named document.+newDoc :: P.Member (Docs a) effs => T.Text -> a -> P.Semantic effs ()+newDoc name doc = send $ NewDoc name doc++-- | Data type to hold one named document of type @a@. +data NamedDoc a = NamedDoc { ndName :: T.Text, ndDoc :: a } deriving (Functor, Foldable, Traversable)++-- | Intepret 'Docs' in @Polysemy.Writer [NamedDoc a]'+toWriter+  :: P.Semantic (Docs a ': effs) ()+  -> P.Semantic (P.Writer [NamedDoc a] ': effs) ()+toWriter = P.reinterpret f+ where+  f :: Docs a m x -> P.Semantic (P.Writer [NamedDoc a] ': effs) x+  f (NewDoc n d) = P.tell [NamedDoc n d]++-- | Interpret 'Docs' (via 'Polysemy.Writer'), producing a list of @NamedDoc a@+toNamedDocList+  :: P.Typeable a+  => P.Semantic (Docs a ': effs) ()+  -> P.Semantic effs [NamedDoc a]+toNamedDocList = fmap fst . P.runWriter . toWriter++-- | Map over the doc part of @Functor m => m [NamedDoc a]@ with an @a->b@ resulting in @m [NamedDoc b]@+mapNamedDocs :: Monad m => (a -> b) -> m [NamedDoc a] -> m [NamedDoc b]+mapNamedDocs f = fmap (fmap (fmap f))++-- | Map over the doc part of @Monad m => m [NamedDoc a]@ with @a -> m b@ resulting in @m [NamedDoc b]@+mapNamedDocsM :: Monad m => (a -> m b) -> m [NamedDoc a] -> m [NamedDoc b]+mapNamedDocsM f = (traverse (traverse f) =<<)++-- | Combine the interpretation and mapping step.  Commonly used to "run" the effect and map the results to your deisred output format.+toNamedDocListWith+  :: P.Typeable a+  => (a -> b)+  -> P.Semantic (Docs a ': effs) ()+  -> P.Semantic effs [NamedDoc b]+toNamedDocListWith f = mapNamedDocs f . toNamedDocList++-- | Combine the interpretation and effectful mapping step.  Commonly used to "run" the effect and map the results to your deisred output format.+toNamedDocListWithM+  :: P.Typeable a+  => (a -> P.Semantic effs b)+  -> P.Semantic (Docs a ': effs) ()+  -> P.Semantic effs [NamedDoc b]+toNamedDocListWithM f = mapNamedDocsM f . toNamedDocList+
+ src/Knit/Effect/Html.hs view
@@ -0,0 +1,141 @@+{-# LANGUAGE FlexibleContexts              #-}+{-# LANGUAGE DataKinds                     #-}+{-# LANGUAGE PolyKinds                     #-}+{-# LANGUAGE GADTs                         #-}+{-# LANGUAGE TypeOperators                 #-}+{-# LANGUAGE ScopedTypeVariables           #-}+{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}+{-|+Module      : Knit.Effect.Html+Description : Polysemy writer effects for creating Lucid/Blaze documents+Copyright   : (c) Adam Conner-Sax 2019+License     : BSD-3-Clause+Maintainer  : adam_conner_sax@yahoo.com+Stability   : experimental++Create a Lucid or Blaze html document (using a Writer to intersperse html and other code) and then use the 'Knit.Haskell.Docs' <https://github.com/isovector/polysemy#readme polysemy> effect+to store that document for processing/output later.+-}+module Knit.Effect.Html+  (+    -- * Lucid++    -- ** Effects+    Lucid+  , LucidDocs++    -- ** Actions+  , lucid++    -- ** Intepretations+  , lucidToNamedText+  , lucidHtml+  , lucidToText+  , newLucidDoc++  -- * Blaze++  -- ** Effects+  , Blaze+  , BlazeDocs++  -- ** Actions+  , blaze++  -- ** Interpretations+  , blazeToNamedText+  , blazeHtml+  , blazeToText+  , newBlazeDoc++    -- * Re-exports+  , NamedDoc(..)+  )+where++import qualified Polysemy                      as P+import qualified Polysemy.Writer               as P++import qualified Lucid                         as LH+import qualified Text.Blaze.Html               as BH+import qualified Text.Blaze.Html.Renderer.Text as BH+import qualified Data.Text.Lazy                as TL+import qualified Data.Text                     as T++import           Knit.Effect.Docs               ( Docs+                                                , NamedDoc(..)+                                                , newDoc+                                                , toNamedDocList+                                                )++-- For now, just handle the Html () case since then it's monoidal and we can interpret via writer+--newtype FreerHtml = FreerHtml { unFreer :: H.Html () }++-- | Type-Alias for a single Lucid document writer.+type Lucid = P.Writer (LH.Html ())++-- | Type-Alias for a single Blaze document writer.+type Blaze = P.Writer BH.Html++-- | Add a Lucid html fragment to the current Lucid doc.+lucid :: P.Member Lucid effs => LH.Html () -> P.Semantic effs ()+lucid = P.tell++-- | Add a Blaze html fragment to the current Blaze doc.+blaze :: P.Member Blaze effs => BH.Html -> P.Semantic effs ()+blaze = P.tell++-- | Type-Alias for the 'Knit.Effects.Docs' effect (multi-document Writer), specialized to Lucid docs.+-- To be used in an app that produces multiple html outputs, built up from Lucid bits.+type LucidDocs = Docs (LH.Html ())++-- | Type-Alias for the 'Knit.Effects.Docs' effect (multi-document Writer) specialized to Blaze docs.+-- To be used in an app that produces multiple html outputs, built up from Blaze bits.+type BlazeDocs = Docs BH.Html++-- | Take the current Lucid HTML in the writer and add it to the set of named docs with the given name.+-- NB: Only use this function for making sets of documents built exclusively from Lucid.  Otherwise use the more general Pandoc infrastructure in+-- 'Knit.Effects.Pandoc'.+newLucidDoc+  :: P.Member LucidDocs effs+  => T.Text+  -> P.Semantic (Lucid ': effs) ()+  -> P.Semantic effs ()+newLucidDoc n l = (fmap fst $ P.runWriter l) >>= newDoc n++-- | take the current Blaze HTML in the writer and add it to the set of named docs with the given name+-- NB: Only use this function for making sets of documents built exclusively from Blaze. Otherwise use the more general Pandoc infrastructure in+-- 'Knit.Effects.Pandoc'.+newBlazeDoc+  :: P.Member BlazeDocs effs+  => T.Text+  -> P.Semantic (Blaze ': effs) ()+  -> P.Semantic effs ()+newBlazeDoc n l = (fmap fst $ P.runWriter l) >>= newDoc n++-- | Interpret the LucidDocs effect (via Writer), producing a list of named Lucid docs, suitable for writing to disk.+lucidToNamedText+  :: P.Semantic (LucidDocs ': effs) () -> P.Semantic effs [NamedDoc TL.Text]+lucidToNamedText = fmap (fmap (fmap LH.renderText)) . toNamedDocList -- monad, list, NamedDoc itself++-- | Interpret the BlazeDocs effect (via Writer), producing a list of named Blaze docs.+blazeToNamedText+  :: P.Semantic (BlazeDocs ': effs) () -> P.Semantic effs [NamedDoc TL.Text]+blazeToNamedText = fmap (fmap (fmap BH.renderHtml)) . toNamedDocList -- monad, list, NamedDoc itself++-- | Interprest the Lucid effect (via Writer), producing a Lucid @Html ()@ from the currently written doc+lucidHtml :: P.Semantic (Lucid ': effs) () -> P.Semantic effs (LH.Html ())+lucidHtml = fmap fst . P.runWriter++-- | Interpret the Lucid effect (via Writer), producing @Text@ from the currently written doc+lucidToText :: P.Semantic (Lucid ': effs) () -> P.Semantic effs TL.Text+lucidToText = fmap LH.renderText . lucidHtml++-- | Interpret the Blaze effect (via Writer), producing a Blaze @Html@ from the currently written doc.+blazeHtml :: P.Semantic (Blaze ': effs) () -> P.Semantic effs BH.Html+blazeHtml = fmap fst . P.runWriter++-- | Interpret the Blaze effect (via Writer), producing @Text@ from the currently written doc.+blazeToText :: P.Semantic (Blaze ': effs) () -> P.Semantic effs TL.Text+blazeToText = fmap BH.renderHtml . blazeHtml+
+ src/Knit/Effect/Logger.hs view
@@ -0,0 +1,270 @@+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE PolyKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE LambdaCase            #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE RankNTypes            #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeApplications      #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE UndecidableInstances  #-}+{-# LANGUAGE InstanceSigs    #-}+{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}+{-|+Module      : Knit.Effect.Logger+Description : Polysemy logging effect+Copyright   : (c) Adam Conner-Sax 2019+License     : BSD-3-Clause+Maintainer  : adam_conner_sax@yahoo.com+Stability   : experimental++<https://github.com/isovector/polysemy#readme Polysemy> logger effect,+using pretty-printing and severity based on <http://hackage.haskell.org/package/logging-effect logging-effect>. Adds a Prefixing effect so that it's easy to wrap entire+functions, etc. in logging prefixes and thus to distinguish where things are being logged from more easily.  Also allows filtering+by severity.+-}+module Knit.Effect.Logger+  (+    -- * Logging Types+    LogSeverity(..)+  , LogEntry(..)++  -- * Effects+  , Logger(..)+  , PrefixLog++  -- * Actions+  , log+  , logLE+  , wrapPrefix++  -- * Interpreters+  , filteredLogEntriesToIO++  -- * Subsets for filtering+  , logAll+  , nonDiagnostic++  -- * Constraints for convenience +  , LogWithPrefixes+  , LogWithPrefixesLE++  -- * Re-Exports+  , Semantic+  , Member+  , Handler+  )+where++import qualified Polysemy                      as P+import           Polysemy                       ( Member+                                                , Semantic+                                                )+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.Prettyprint.Doc     as PP+import qualified Data.Text.Prettyprint.Doc.Render.Text+                                               as PP+import           Prelude                 hiding ( log )+++-- 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+-- the idea that the runner takes a function to handle the logging in the rest of the stack seems okay.  Though why not be more direct+-- once we are using effects in the first place?  Isn't that handler a mix of pretty-printing and interpreting and we would+-- rather separate those concerns?  So we should have an (a -> Text) and then interpreters in whatever?  I guess we merge them because+-- 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)++-- | 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++-- | A basic LogEntry 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+++-- | "LogSeverity" list used in order to output everything.+logAll :: [LogSeverity]+logAll = [minBound .. maxBound]++-- | '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++-- | The Logger 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.Semantic effs ()+log = send . Log++-- | Add one log-entry of the @LogEntry@ type.+logLE+  :: P.Member (Logger LogEntry) effs+  => LogSeverity+  -> T.Text+  -> P.Semantic effs ()+logLE ls lm = log (LogEntry ls lm)++-- | Helper function for logging with monad-logger handler.+logWithHandler+  :: Handler (P.Semantic effs) a+  -> P.Semantic (Logger a ': effs) x+  -> P.Semantic effs x+logWithHandler handler = P.interpret (\(Log a) -> handler a)++-- | Prefix Effect+data PrefixLog m r where+  AddPrefix :: T.Text -> PrefixLog m () -- ^ Represents adding a prefix to the logging output+  RemovePrefix :: PrefixLog m () -- ^ Represents removing one level of prefixing+  GetPrefix :: PrefixLog m T.Text -- ^ Represents retrieving the current prefix++-- | Add one level of prefix.+addPrefix :: P.Member PrefixLog effs => T.Text -> P.Semantic effs ()+addPrefix = send . AddPrefix++-- | Remove last prefix.+removePrefix :: P.Member PrefixLog effs => P.Semantic effs ()+removePrefix = send RemovePrefix++-- | Get current prefix +getPrefix :: P.Member PrefixLog effs => P.Semantic effs T.Text+getPrefix = send $ GetPrefix++-- | Add a prefix for the block of code.+wrapPrefix+  :: P.Member PrefixLog effs => T.Text -> P.Semantic effs a -> P.Semantic effs a+wrapPrefix p l = do+  addPrefix p+  res <- l+  removePrefix+  return res++-- | Interpret LogPrefix in @Polysemy.State [T.Text]@.+prefixInState+  :: forall effs a+   . P.Semantic (PrefixLog ': effs) a+  -> P.Semantic (P.State [T.Text] ': effs) a+prefixInState = P.reinterpret $ \case+  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++-- | Interpret the 'LogPrefix' effect in State and run that.+runPrefix :: P.Semantic (PrefixLog ': effs) a -> P.Semantic effs a+runPrefix = fmap snd . P.runState [] . prefixInState++-- | Monad-logger style wrapper to add prefixes to log messages.+data WithPrefix a = WithPrefix { msgPrefix :: T.Text, discardPrefix :: 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)++-- | Use @PrefixLog@ Effect to re-interpret all the logged messages to WithPrefix form.+logPrefixed+  :: P.Member PrefixLog effs+  => P.Semantic (Logger a ': effs) x+  -> P.Semantic (Logger (WithPrefix a) ': effs) x+logPrefixed =+  P.reinterpret (\(Log a) -> getPrefix >>= (\p -> log (WithPrefix p a)))++-- 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.+-- | Given a handler for @WithPrefix a@ in the remaining effects (IO, e.g.,), run the Logger and Prefix effects and handle all the logging+-- messages via that handler.+logAndHandlePrefixed+  :: forall effs a x+   . Handler (P.Semantic effs) (WithPrefix a)+  -> P.Semantic (Logger a ': (PrefixLog ': effs)) x+  -> P.Semantic effs x+logAndHandlePrefixed handler =+  runPrefix+    . logWithHandler (P.raise . handler)+    . logPrefixed @(PrefixLog ': effs)++-- | 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++-- | Simple handler, uses a function from message to Text and then outputs all messages in IO.+-- 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++-- | Preferred handler for @LogEntry@ type with prefixes.+prefixedLogEntryToIO :: MonadIO m => Handler m (WithPrefix LogEntry)+prefixedLogEntryToIO = logToIO+  (PP.renderStrict . PP.layoutPretty PP.defaultLayoutOptions . renderWithPrefix+    (ML.renderWithSeverity PP.pretty . logEntryToWithSeverity)+  )++-- | Run the Logger and PrefixLog effects using the preferred handler and filter output in any Polysemy monad with IO in the union.+filteredLogEntriesToIO+  :: MonadIO (P.Semantic effs)+  => [LogSeverity]+  -> P.Semantic (Logger LogEntry ': (PrefixLog ': effs)) x+  -> P.Semantic effs x+filteredLogEntriesToIO lss = logAndHandlePrefixed+  (filterLog f lss $ prefixedLogEntryToIO)+  where f lss' a = (severity $ discardPrefix a) `List.elem` lss'++-- | Constraint helper for logging with prefixes+type LogWithPrefixes 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)++{-+TODO: Working instance of logging-effect MonadLog.  Maybe.++• Illegal instance declaration for+        ‘ML.MonadLog a (P.Semantic effs)’+        The liberal coverage condition fails in class ‘ML.MonadLog’+          for functional dependency: ‘m -> message’+        Reason: lhs type ‘P.Semantic effs’ does not determine rhs type ‘a’+        Un-determined variable: a+    • In the instance declaration for ‘ML.MonadLog a (P.Semantic effs)’+++-- not sure how to use this in practice but we might need it if we call a function with a MonadLog constraint.+-- | instance to support using an existing function with a MonadLog constraint from a freer-simple stack. +instance (ML.MonadLog a m, P.Member (P.Lift m) effs) => ML.MonadLog a (P.Semantic effs) where+  logMessageFree :: (ML.MonadLog a m, P.Member (P.Lift m) effs,forall n. Monoid n => (a -> n) -> n) -> P.Semantic effs ()+  logMessageFree inj = P.sendM @m $ ML.logMessageFree inj++instance (P.Member (Logger a) effs) => ML.MonadLog a (P.Semantic effs) where+  logMessageFree inj = mapM_ log (inj $ pure @[])+-}
+ src/Knit/Effect/Pandoc.hs view
@@ -0,0 +1,290 @@+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE RankNTypes          #-}+{-# LANGUAGE GADTs               #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE PolyKinds           #-}+{-# LANGUAGE TypeOperators       #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE LambdaCase  #-}+{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}+{-|+Module      : Knit.Effect.Pandoc+Description : Polysemy writer-like effect+Copyright   : (c) Adam Conner-Sax 2019+License     : BSD-3-Clause+Maintainer  : adam_conner_sax@yahoo.com+Stability   : experimental++Polysemy Pandoc effect.+This is writer-like, allowing the interspersed addition of various Pandoc-readable formats into one doc and then rendering+to many Pandoc-writeable formats.  Currently only a subset of formats are supported.  Inputs can express requirements,+e.g., hvega requires html output because it uses javascript.+Those requirements are then checked before output is rendered and an error thrown if the input is not supported.+-}+module Knit.Effect.Pandoc+  (+    -- * Effects+    ToPandoc+  , FromPandoc++  -- * Requirement Support+  , Requirement(..)+  , PandocWithRequirements+  -- * Format ADTs+  , PandocReadFormat(..)+  , PandocWriteFormat(..)++  -- * Combinators+  , addFrom+  , require+  , writeTo+  , toPandoc+  , fromPandoc++  -- * Interpreters+  , runPandocWriter++  -- * Docs effect type-aliases+  , Pandocs+  , NamedDoc(..)++  -- * Docs Effect Interpreters +  , newPandoc+  , pandocsToNamed+  , fromPandocE+  )+where++import qualified Text.Pandoc                   as PA+import qualified Data.Text                     as T+import           Data.ByteString.Lazy          as LBS+import qualified Data.Foldable                 as F+import qualified Data.Monoid                   as Mon+import           Data.Set                      as S+import qualified Text.Blaze.Html               as Blaze+import           Control.Monad.Except           ( throwError )++++import qualified Polysemy                      as P+import           Polysemy.Internal              ( send )+import qualified Polysemy.Writer               as P+++import qualified Knit.Effect.PandocMonad       as PM++import           Knit.Effect.Docs               ( Docs+                                                , NamedDoc(..)+                                                , newDoc+                                                , toNamedDocList+                                                )++-- For now, just handle the Html () case since then it's monoidal and we can interpret via writer+--newtype FreerHtml = FreerHtml { unFreer :: H.Html () }+-- | Supported formats for adding to current Pandoc+data PandocReadFormat a where+  ReadDocX :: PandocReadFormat LBS.ByteString+  ReadMarkDown :: PandocReadFormat T.Text+  ReadCommonMark :: PandocReadFormat T.Text+  ReadRST :: PandocReadFormat T.Text+  ReadLaTeX :: PandocReadFormat T.Text+  ReadHtml :: PandocReadFormat T.Text++deriving instance Show (PandocReadFormat a)++-- | Supported formats for writing current Pandoc+data PandocWriteFormat a where+  WriteDocX :: PandocWriteFormat LBS.ByteString+  WriteMarkDown :: PandocWriteFormat T.Text+  WriteCommonMark :: PandocWriteFormat T.Text+  WriteRST :: PandocWriteFormat T.Text+  WriteLaTeX :: PandocWriteFormat T.Text+  WriteHtml5 :: PandocWriteFormat Blaze.Html -- Blaze+  WriteHtml5String :: PandocWriteFormat T.Text++deriving instance Show (PandocWriteFormat a)++-- | ADT to allow inputs to request support, if necessary or possible, in the output format.+-- E.g., Latex output in Html needs MathJax. But Latex needs to nothing to output in Latex.+-- Vega-lite needs some script headers to output in Html and can't be output in other formats.+-- For now, we support all the things we can in any output format so this just results+-- in a runtime test.++-- TODO (?): Allow headers/extensions to be added/switched based on this.+data Requirement+  =+    VegaSupport -- ^ Supported only for Html output.+  | LatexSupport -- ^ Supported in Html output (via MathJax) and Latex output.+  deriving (Show, Ord, Eq, Bounded, Enum)++handlesAll :: PandocWriteFormat a -> S.Set Requirement -> Bool+handlesAll f rs = Mon.getAll+  $ F.fold (fmap (Mon.All . handles f) $ S.toList rs)+ where+  handles :: PandocWriteFormat a -> Requirement -> Bool+  handles WriteHtml5       VegaSupport  = True+  handles WriteHtml5String VegaSupport  = True+  handles WriteHtml5       LatexSupport = True+  handles WriteHtml5String LatexSupport = True+  handles WriteLaTeX       LatexSupport = True+  handles _                _            = False++data PandocWithRequirements = PandocWithRequirements { doc :: PA.Pandoc, reqs :: S.Set Requirement }+instance Semigroup PandocWithRequirements where+  (PandocWithRequirements da ra) <> (PandocWithRequirements db rb)+    = PandocWithRequirements (da <> db) (ra <> rb)++instance Monoid PandocWithRequirements where+  mempty = PandocWithRequirements mempty mempty+++justDoc :: PA.Pandoc -> PandocWithRequirements+justDoc d = PandocWithRequirements d mempty++justRequirement :: Requirement -> PandocWithRequirements+justRequirement r = PandocWithRequirements mempty (S.singleton r)++-- | Pandoc writer, add any read format to current doc+data ToPandoc m r where+  AddFrom  :: PandocReadFormat a -> PA.ReaderOptions -> a -> ToPandoc m () -- ^ add to current doc+  Require :: Requirement -> ToPandoc m () -- ^ require specific support++-- | Pandoc output effect, take given doc and produce formatted output+data FromPandoc m r where+  WriteTo  :: PandocWriteFormat a -> PA.WriterOptions -> PA.Pandoc -> FromPandoc m a -- convert to given format++-- | Add a piece of a Pandoc readable type to the current doc+addFrom+  :: P.Member ToPandoc effs+  => PandocReadFormat a+  -> PA.ReaderOptions+  -> a+  -> P.Semantic effs ()+addFrom prf pro doc' = send $ AddFrom prf pro doc'++-- | Add a requirement that the output format must satisfy.+require :: P.Member ToPandoc effs => Requirement -> P.Semantic effs ()+require r = send $ Require r++-- | Write given doc in requested format+writeTo+  :: P.Member FromPandoc effs+  => PandocWriteFormat a+  -> PA.WriterOptions+  -> PA.Pandoc+  -> P.Semantic effs a+writeTo pwf pwo pdoc = send $ WriteTo pwf pwo pdoc++-- | Convert a to Pandoc with the given options+toPandoc+  :: PA.PandocMonad m+  => PandocReadFormat a+  -> PA.ReaderOptions+  -> a+  -> m PA.Pandoc+toPandoc prf pro x = readF pro x+ where+  readF = case prf of+    ReadDocX       -> PA.readDocx+    ReadMarkDown   -> PA.readMarkdown+    ReadCommonMark -> PA.readCommonMark+    ReadRST        -> PA.readRST+    ReadLaTeX      -> PA.readLaTeX+    ReadHtml       -> PA.readHtml++-- | Convert Pandoc to requested format with the given options.+-- | Throw a PandocError if the output format is unsupported given the inputs.+fromPandoc+  :: PA.PandocMonad m+  => PandocWriteFormat a+  -> PA.WriterOptions+  -> PandocWithRequirements+  -> m a+fromPandoc pwf pwo (PandocWithRequirements pdoc rs) = case handlesAll pwf rs of+  False ->+    throwError+      $  PA.PandocSomeError+      $  "One of "+      ++ (show $ S.toList rs)+      ++ " cannot be output to "+      ++ show pwf+  True -> write pwo pdoc+   where+    write = case pwf of+      WriteDocX        -> PA.writeDocx+      WriteMarkDown    -> PA.writeMarkdown+      WriteCommonMark  -> PA.writeCommonMark+      WriteRST         -> PA.writeRST+      WriteLaTeX       -> PA.writeLaTeX+      WriteHtml5       -> PA.writeHtml5+      WriteHtml5String -> PA.writeHtml5String++-- | Re-interpret ToPandoc in Writer+toWriter+  :: PM.PandocEffects effs+  => P.Semantic (ToPandoc ': effs) a+  -> P.Semantic (P.Writer PandocWithRequirements ': effs) a+toWriter = P.reinterpret $ \case+  (AddFrom rf ro x) ->+    P.raise (fmap justDoc $ toPandoc rf ro x) >>= P.tell @PandocWithRequirements+  (Require r) -> P.tell (justRequirement r)++-- | Run ToPandoc by interpreting in Writer and then running that Writer.+runPandocWriter+  :: PM.PandocEffects effs+  => P.Semantic (ToPandoc ': effs) ()+  -> P.Semantic effs PandocWithRequirements+runPandocWriter = fmap fst . P.runWriter . toWriter++-- | Type-alias for use with the @Docs@ effect.+type Pandocs = Docs PandocWithRequirements++-- | Add a new named Pandoc to a Pandoc Docs collection.+newPandocPure+  :: P.Member Pandocs effs+  => T.Text -- ^ name for document+  -> PandocWithRequirements -- ^ document and union of all input requirements+  -> P.Semantic effs ()+newPandocPure = newDoc++-- | Add the Pandoc stored in the writer-style ToPandoc effect to the named docs collection with the given name.+newPandoc+  :: (PM.PandocEffects effs, P.Member Pandocs effs)+  => T.Text -- ^ name of document+  -> P.Semantic (ToPandoc ': effs) ()+  -> P.Semantic effs ()+newPandoc n l = fmap fst (P.runWriter $ toWriter l) >>= newPandocPure n++-- | Given a write format and options, convert the NamedDoc to the requested format+namedPandocFrom+  :: PA.PandocMonad m+  => PandocWriteFormat a -- ^ format for Pandoc output+  -> PA.WriterOptions -- ^ options for the Pandoc Writer+  -> NamedDoc PandocWithRequirements -- ^ named Pandoc with its union of requirements+  -> m (NamedDoc a) -- ^ document in output format (in the effects monad).+namedPandocFrom pwf pwo (NamedDoc n pdoc) = do+  doc' <- fromPandoc pwf pwo pdoc+  return $ NamedDoc n doc'++-- | Given a write format and options,+-- convert a list of named Pandocs to a list of named docs in the requested format+pandocsToNamed+  :: PM.PandocEffects effs+  => PandocWriteFormat a -- ^ format for Pandoc output+  -> PA.WriterOptions -- ^ options for the Pandoc Writer+  -> P.Semantic (Pandocs ': effs) () -- ^ effects stack to be (partially) run to get documents+  -> P.Semantic effs [NamedDoc a] -- ^ documents in requested format, within the effects monad+pandocsToNamed pwf pwo =+  (traverse (namedPandocFrom pwf pwo) =<<) . toNamedDocList++-- | Given a write format and options, run the writer-style ToPandoc effect and produce a doc of requested type+fromPandocE+  :: PM.PandocEffects effs+  => PandocWriteFormat a -- ^ format for Pandoc output+  -> PA.WriterOptions -- ^ options for the Pandoc Writer+  -> P.Semantic (ToPandoc ': effs) () -- ^ effects stack to be (partially) run to get document+  -> P.Semantic effs a -- ^ document in requested format, within the effects monad+fromPandocE pwf pwo = ((fromPandoc pwf pwo . fst) =<<) . P.runWriter . toWriter+
+ src/Knit/Effect/PandocMonad.hs view
@@ -0,0 +1,372 @@+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE PolyKinds             #-}+{-# LANGUAGE DeriveFunctor         #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE GADTs                 #-}+{-# LANGUAGE LambdaCase            #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE RankNTypes            #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TemplateHaskell       #-}+{-# LANGUAGE TypeApplications      #-}+{-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE UndecidableInstances  #-}+{-# LANGUAGE AllowAmbiguousTypes   #-}+{-# LANGUAGE TupleSections         #-}+{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}+{-|+Module      : Knit.Effect.PandocMonad+Description : Polysemy PandocMonad effect+Copyright   : (c) Adam Conner-Sax 2019+License     : BSD-3-Clause+Maintainer  : adam_conner_sax@yahoo.com+Stability   : experimental++Polysemy PandocMonad effect.+Allows a polysemy "stack" to satisfy a PandocMonad constraint.+This still needs to run on top of PandocIO+but that will likely be addressed at some point in the future,+just requiring IO at base and the Logging and Random effects.+-}+module Knit.Effect.PandocMonad+  (+    -- * Types+    Pandoc+  , PandocEffects+  , PandocEffectsIO++  -- * Actions+  , lookupEnv+  , getCurrentTime+  , getCurrentTimeZone+  , newStdGen+  , newUniqueHash+  , openURL+  , readFileLazy+  , readFileStrict+  , glob+  , fileExists+  , getDataFileName+  , getModificationTime+  , getCommonState+  , putCommonState+  , getsCommonState+  , modifyCommonState+  , logOutput+  , trace++  -- * Interpreters+  , interpretInPandocMonad+  , interpretInIO++  -- * Runners+  , runIO++  -- * Re-Exports+  , PA.PandocError+  )+where++import qualified Knit.Effect.Logger            as Log++import qualified Polysemy                      as P+import qualified Polysemy.IO                   as P+import           Polysemy.Internal              ( send )+import           Polysemy.Internal.Combinators  ( stateful )+import qualified Polysemy.Error                as P+import qualified Text.Pandoc                   as PA+import qualified Text.Pandoc.MIME              as PA+import qualified Text.Pandoc.UTF8              as UTF8+--import qualified Text.Pandoc.Logging           as PA++import qualified Data.ByteString               as BS+import           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(..)+                                                , liftIO+                                                )+import qualified Network.URI                   as NU+import           Network.Socket                 ( withSocketsDo )+import qualified Network.HTTP.Client           as NHC+import qualified Network.HTTP.Client.TLS       as NHC+                                                ( tlsManagerSettings )+import qualified Network.HTTP.Client.Internal  as NHC+                                                ( addProxy )+import qualified Network.HTTP.Types.Header     as NH+                                                ( hContentType )++import qualified System.Environment            as IO+                                                ( lookupEnv+                                                , getEnv+                                                )+import qualified System.IO.Error               as IO+                                                ( tryIOError )+import qualified Data.Time                     as IO+                                                ( getCurrentTime )+import           Data.Time.Clock                ( UTCTime )+import           Data.Time.LocalTime            ( TimeZone )+import qualified Data.Time.LocalTime           as IO+                                                ( getCurrentTimeZone )+import           System.Random                  ( StdGen )+import qualified System.Random                 as IO+                                                ( newStdGen )+import           Data.Unique                    ( hashUnique )+import qualified Data.Unique                   as IO+                                                ( newUnique )+import qualified System.FilePath.Glob          as IO+                                                ( glob )+import qualified System.Directory              as IO+                                                ( getModificationTime )+import qualified System.Directory              as Directory+import qualified Debug.Trace+import qualified Control.Exception             as E++-- | 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+  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 ()+  GetsCommonState :: (PA.CommonState -> a) -> Pandoc m a+  ModifyCommonState :: (PA.CommonState -> PA.CommonState) -> Pandoc m  ()+  LogOutput :: PA.LogMessage -> Pandoc m ()+  Trace :: String -> Pandoc m ()++P.makeSemantic ''Pandoc++-- TODO: Understand the error pieces better.  Some things are thrown in IO, not sure we catch those??+-- | Split off the error piece. We will handle directly with the polysemy @Error@ effect+instance (P.Member (P.Error PA.PandocError) effs) => MonadError PA.PandocError (P.Semantic effs) where+  throwError = P.throw+  catchError = P.catch++-- we handle logging within the existing effect system+-- | Map pandoc severities to our logging system.+pandocSeverity :: PA.LogMessage -> Log.LogSeverity+pandocSeverity lm = case PA.messageVerbosity lm of+  PA.ERROR   -> Log.Error+  PA.WARNING -> Log.Warning+  PA.INFO    -> Log.Info++-- | Handle the logging with the knit-haskell logging effect.+logPandocMessage+  :: P.Member (Log.Logger Log.LogEntry) effs+  => PA.LogMessage+  -> P.Semantic effs ()+logPandocMessage lm = send $ Log.Log $ Log.LogEntry+  (pandocSeverity lm)+  (T.pack . PA.showLogMessage $ lm)++-- | Constraint helper for using this set of effects in IO.+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)++-- | PandocMonad instance so that pandoc functions can be run in the polysemy union effect+instance PandocEffects effs => PA.PandocMonad (P.Semantic effs) where+  lookupEnv = lookupEnv+  getCurrentTime = getCurrentTime+  getCurrentTimeZone = getCurrentTimeZone+  newStdGen = newStdGen+  newUniqueHash = newUniqueHash+  openURL = openURL+  readFileLazy = readFileLazy+  readFileStrict = readFileStrict+  glob = glob+  fileExists = fileExists+  getDataFileName = getDataFileName+  getModificationTime = getModificationTime+  getCommonState = getCommonState+  putCommonState = putCommonState+  getsCommonState = getsCommonState+  modifyCommonState = modifyCommonState+  logOutput = logOutput --logPandocMessage+  trace = trace+++-- | Constraint helper for using this set of effects in IO.+type PandocEffectsIO effs =+  ( PandocEffects effs+  , P.Member (P.Lift IO) effs)++-- | Interpret the Pandoc effect using @IO@, @Knit.Effect.Logger@ and @PolySemy.Error PandocError@ +interpretInIO+  :: forall effs a+   . ( P.Member (Log.Logger Log.LogEntry) effs+     , P.Member (P.Lift IO) effs+     , P.Member (P.Error PA.PandocError) effs+     )+  => P.Semantic (Pandoc ': effs) a+  -> P.Semantic effs a+interpretInIO = fmap snd . stateful f PA.def+ where+  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.Semantic effs (PA.CommonState, x)+  f (LookupEnv s)         cs = liftPair (cs, liftIO $ IO.lookupEnv 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)+  f NewUniqueHash         cs = liftPair (cs, hashUnique <$> liftIO IO.newUnique)+  f (OpenURL         url) cs = openURLWithState cs url+  f (ReadFileLazy    fp ) cs = liftPair (cs, liftIOError LBS.readFile fp)+  f (ReadFileStrict  fp ) cs = liftPair (cs, liftIOError BS.readFile fp)+  f (Glob            s  ) cs = liftPair (cs, liftIOError IO.glob s)+  f (FileExists fp) cs = liftPair (cs, liftIOError Directory.doesFileExist fp)+  f (GetDataFileName s  ) cs = liftPair (cs, liftIOError getDataFileName' s)+  f (GetModificationTime fp) cs =+    liftPair (cs, liftIOError IO.getModificationTime fp)+  f GetCommonState          cs = return (cs, cs)+  f (GetsCommonState   g  ) cs = return (cs, g cs)+  f (ModifyCommonState g  ) cs = return (g cs, ())+  f (PutCommonState    cs') _  = return (cs', ())+  f (LogOutput         msg) cs = liftPair (cs, logPandocMessage msg)+  f (Trace             msg) cs = liftPair+    ( cs+    , when (PA.stTrace cs) $ Debug.Trace.trace ("[trace]" ++ msg) (return ())+    )++-- | Interpret the Pandoc effect in another monad (which must satisy the PandocMonad constraint) and @Knit.Effect.Logger@+interpretInPandocMonad+  :: forall m effs a+   . ( PA.PandocMonad m+     , P.Member (P.Lift m) effs+     , P.Member (Log.Logger Log.LogEntry) effs+     )+  => P.Semantic (Pandoc ': effs) a+  -> P.Semantic effs a+interpretInPandocMonad = P.interpret+  (\case+    LookupEnv s            -> P.sendM @m $ PA.lookupEnv s+    GetCurrentTime         -> P.sendM @m $ PA.getCurrentTime+    GetCurrentTimeZone     -> P.sendM @m $ PA.getCurrentTimeZone+    NewStdGen              -> P.sendM @m $ PA.newStdGen+    NewUniqueHash          -> P.sendM @m $ PA.newUniqueHash+    OpenURL             s  -> P.sendM @m $ PA.openURL s+    ReadFileLazy        fp -> P.sendM @m $ PA.readFileLazy fp+    ReadFileStrict      fp -> P.sendM @m $ PA.readFileStrict fp+    Glob                fp -> P.sendM @m $ PA.glob fp+    FileExists          fp -> P.sendM @m $ PA.fileExists fp+    GetDataFileName     fp -> P.sendM @m $ PA.getDataFileName fp+    GetModificationTime fp -> P.sendM @m $ PA.getModificationTime fp+    GetCommonState         -> P.sendM @m $ PA.getCommonState+    PutCommonState    cs   -> P.sendM @m $ PA.putCommonState cs+    GetsCommonState   f    -> P.sendM @m $ PA.getsCommonState f+    ModifyCommonState f    -> P.sendM @m $ PA.modifyCommonState f+    LogOutput         msg  -> logPandocMessage msg+    Trace             s    -> P.sendM @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.+runIO+  :: [Log.LogSeverity]+  -> P.Semantic+       '[Pandoc, Log.Logger Log.LogEntry, Log.PrefixLog, P.Error+         PA.PandocError, P.Lift IO]+       a+  -> IO (Either PA.PandocError a)+runIO lss =+  P.runM . P.runError . Log.filteredLogEntriesToIO lss . interpretInIO++-- copied from Pandoc code and modified as needed for Polysemy and my implementation of interpretInIO (PandocIO)+openURLWithState+  :: forall effs+   . ( P.Member (Log.Logger Log.LogEntry) effs+     , P.Member (P.Lift IO) effs+     , P.Member (P.Error PA.PandocError) effs+     )+  => PA.CommonState+  -> String+  -> P.Semantic+       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+          (/= ',')+          u''+    return (cs, (decodeLenient contents, Just mime))+  | otherwise = do+    let toReqHeader (n, v) = (CI.mk (UTF8.fromString n), UTF8.fromString v)+        customHeaders = fmap toReqHeader $ PA.stRequestHeaders cs+    cs' <- report cs $ PA.Fetching u+    res <- liftIO $ E.try $ withSocketsDo $ do+      let parseReq = NHC.parseRequest+      proxy <- IO.tryIOError (IO.getEnv "http_proxy")+      let addProxy' x = case proxy of+            Left  _  -> return x+            Right pr -> parseReq pr+              >>= \r -> return (NHC.addProxy (NHC.host r) (NHC.port r) x)+      req <- parseReq u >>= addProxy'+      let req' = req+            { NHC.requestHeaders = customHeaders ++ NHC.requestHeaders req+            }+      resp <- NHC.newManager NHC.tlsManagerSettings >>= NHC.httpLbs req'+      return+        ( BS.concat $ LBS.toChunks $ NHC.responseBody resp+        , UTF8.toString `fmap` lookup NH.hContentType (NHC.responseHeaders resp)+        )+    case res of+      Right r -> return (cs', r)+      Left  e -> P.throw $ PA.PandocHttpError u e++-- | Stateful version of the Pandoc @report@ function, outputting relevant log messages+-- and adding them to the log kept in the state.+report+  :: (P.Member (Log.Logger Log.LogEntry) effs)+  => PA.CommonState+  -> PA.LogMessage+  -> P.Semantic effs PA.CommonState+report cs msg = do+  let verbosity = PA.stVerbosity cs+      level     = PA.messageVerbosity msg+  when (level <= verbosity) $ logPandocMessage msg+  let stLog' = msg : (PA.stLog cs)+      cs'    = cs { PA.stLog = stLog' }+  return cs'++-- | Utility function to lift IO errors into Semantic+liftIOError+  :: (P.Member (P.Error PA.PandocError) effs, P.Member (P.Lift IO) effs)+  => (String -> IO a)+  -> String+  -> P.Semantic effs a+liftIOError f u = do+  res <- liftIO $ IO.tryIOError $ f u+  case res of+    Left  e -> P.throw $ PA.PandocIOError u e+    Right r -> return r++-- this default is built into Pandoc.  I could probably do something more useful here but maybe something depends on it??+-- or maybe the actual version on each machine has a correct local version??+-- TODO: Fix/Understand this+datadir :: FilePath+  = "/home/builder/hackage-server/build-cache/tmp-install/share/x86_64-linux-ghc-8.6.3/pandoc-2.7.2"++getDataFileName' :: FilePath -> IO FilePath+getDataFileName' fp = do+  dir <- E.catch @E.IOException (IO.getEnv "pandoc_datadir")+                                (\_ -> return datadir)+  return (dir ++ "/" ++ fp)
+ src/Knit/Effect/RandomFu.hs view
@@ -0,0 +1,116 @@+{-# LANGUAGE FlexibleContexts              #-}+{-# LANGUAGE OverloadedStrings             #-}+{-# LANGUAGE RankNTypes                    #-}+{-# LANGUAGE GADTs                         #-}+{-# LANGUAGE LambdaCase                    #-}+{-# LANGUAGE DataKinds                     #-}+{-# LANGUAGE PolyKinds                     #-}+{-# LANGUAGE TypeOperators                 #-}+{-# LANGUAGE ScopedTypeVariables           #-}+{-# LANGUAGE TypeApplications              #-}+{-# LANGUAGE TemplateHaskell               #-}+{-# LANGUAGE UndecidableInstances          #-}+{-# LANGUAGE AllowAmbiguousTypes           #-}+{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}+{-|+Module      : Knit.Effect.RandomFu+Description : Polysemy random-fu effect+Copyright   : (c) Adam Conner-Sax 2019+License     : BSD-3-Clause+Maintainer  : adam_conner_sax@yahoo.com+Stability   : experimental++Polysemy "random-fu" effect.+Allows a polysemy "stack" to satisfy a MonadRandom (from "random-fu") constraint.+This can be run in a few ways:++1. Directly in 'IO'+2. Using any 'Data.Random.RandomSource' from "random-fu"+3. In 'IO', using a given 'Data.Random.Source.PureMT' source. ('IO' is used to put the source in an 'IORef')+-}+module Knit.Effect.RandomFu+  (+    -- * Effect+    Random++    -- * Actions+  , sampleRVar+  , sampleDist++  -- * Interpretations +  , runRandomIOSimple+  , runRandomIOPureMT+  , runRandomFromSource+  )+where++import qualified Polysemy                      as P+import           Polysemy.Internal              ( send )++import           Data.IORef                     ( newIORef )+import qualified Data.Random                   as R+import qualified Data.Random.Source            as R+import qualified Data.Random.Internal.Source   as R+import qualified Data.Random.Source.PureMT     as R+++import           Control.Monad.IO.Class         ( MonadIO(..) )++-- | Random Effect+data Random m r where+  SampleRVar ::  R.RVar t -> Random m t+  GetRandomPrim :: R.Prim t -> Random m t++-- | Convert a random-fu RVar to the Random Effect+sampleRVar :: (P.Member Random effs) => R.RVar t -> P.Semantic effs t+sampleRVar = send . SampleRVar++-- | Convert a random-fu Distribution to the Random Effect+sampleDist+  :: (P.Member Random effs, R.Distribution d t) => d t -> P.Semantic effs t+sampleDist = sampleRVar . R.rvar++getRandomPrim :: P.Member Random effs => R.Prim t -> P.Semantic effs t+getRandomPrim = send . GetRandomPrim++-- | Run in IO using default random-fu IO source+runRandomIOSimple+  :: forall effs a+   . MonadIO (P.Semantic effs)+  => P.Semantic (Random ': effs) a+  -> P.Semantic effs a+runRandomIOSimple = P.interpret f+ where+  f :: forall m x . (Random m x -> P.Semantic effs x)+  f r = case r of+    SampleRVar    rv -> liftIO $ R.sample rv+    GetRandomPrim pt -> liftIO $ R.getRandomPrim pt++-- | Run using the given source+runRandomFromSource+  :: forall s effs a+   . R.RandomSource (P.Semantic effs) s+  => s+  -> P.Semantic (Random ': effs) a+  -> P.Semantic effs a+runRandomFromSource source = P.interpret f+ where+  f :: forall m x . (Random m x -> P.Semantic effs x)+  f r = case r of+    SampleRVar    rv -> R.runRVar (R.sample rv) source+    GetRandomPrim pt -> R.runRVar (R.getRandomPrim pt) source++-- | Run in 'IO', using the given 'PureMT' source stored in an 'IORef'+runRandomIOPureMT+  :: MonadIO (P.Semantic effs)+  => R.PureMT+  -> P.Semantic (Random ': effs) a+  -> P.Semantic effs a+runRandomIOPureMT source re =+  liftIO (newIORef source) >>= flip runRandomFromSource re++-- | supply instance of MonadRandom for functions which require it+$(R.monadRandom [d|+        instance P.Member Random effs => R.MonadRandom (P.Semantic effs) where+            getRandomPrim = getRandomPrim+    |])
+ src/Knit/Report.hs view
@@ -0,0 +1,261 @@+{-# LANGUAGE ExtendedDefaultRules #-}+{-# LANGUAGE ScopedTypeVariables  #-}+{-# LANGUAGE FlexibleContexts     #-}+{-# LANGUAGE TypeOperators        #-}+{-# LANGUAGE TypeFamilies         #-}+{-# LANGUAGE DataKinds            #-}+{-# LANGUAGE PolyKinds            #-}+{-# LANGUAGE GADTs                #-}+{-# LANGUAGE TypeApplications     #-}+{-# LANGUAGE Rank2Types           #-}+{-# LANGUAGE ConstraintKinds      #-}+{-# LANGUAGE UndecidableInstances #-}+{-|+Module      : Knit.Report+Description : Re-export all the things required for pandoc-built reports.+Copyright   : (c) Adam Conner-Sax 2019+License     : BSD-3-Clause+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.+That is, it is intended as one-stop-shopping for using this library to produce Html from various fragments which+Pandoc can read.++<https://github.com/adamConnerSax/knit-haskell/tree/master/examples Examples> are available, and might be useful for seeing how all this works.++Notes:++1. The "Knit.Effect.RandomFu" effect is not imported since the names might clash with "Polysemy.Random".+Import either effect directly if you need it.+2. You can add logging from within document creation using 'logLE'.+3. The "Knit.Report.Input.MarkDown.PandocMarkDown" module is exported+so if you want to use a different markdown flavor you may need to hide "addMarkDown" when you import this module.+4. If you use any other effects in your polysemy stack (e.g., Random or RandomFu), you will need to interpret/run them before calling knitHtml/knitHtmls.+-}+module Knit.Report+  (+    -- * Knit+    knitHtml+  , knitHtmls+  , liftKnit+  , KnitBase++    -- * Inputs+  , module Knit.Report.Input.Table.Colonnade+  , module Knit.Report.Input.MarkDown.PandocMarkDown+  , module Knit.Report.Input.Html+  , module Knit.Report.Input.Html.Blaze+  , module Knit.Report.Input.Html.Lucid+  , module Knit.Report.Input.Latex+  , module Knit.Report.Input.Visualization.Hvega++    -- * Output +  , module Knit.Report.Output+  , module Knit.Report.Output.Html++    -- * Effects+  , module Polysemy+  , module Knit.Effect.Pandoc+  , module Knit.Effect.PandocMonad+  , module Knit.Effect.Logger+  )+where++import           Polysemy                       ( Member+                                                , Semantic+                                                , Lift+                                                )+import           Knit.Effect.Pandoc             ( ToPandoc+                                                , Requirement(..)+                                                , PandocReadFormat(..)+                                                , PandocWriteFormat(..)+                                                , Pandocs+                                                )+import           Knit.Effect.PandocMonad+import           Knit.Effect.Logger             ( LogSeverity(..)+                                                , logAll+                                                , nonDiagnostic+                                                , logLE+                                                , wrapPrefix+                                                , filteredLogEntriesToIO+                                                , LogWithPrefixesLE+                                                )+import           Knit.Report.Input.Table.Colonnade+                                                ( addColonnadeTextTable+                                                , addColonnadeHtmlTable+                                                , addColonnadeCellTable+                                                )+import           Knit.Report.Input.MarkDown.PandocMarkDown+                                                ( addMarkDown )+import           Knit.Report.Input.Html         ( addStrictTextHtml+                                                , addLazyTextHtml+                                                )+import           Knit.Report.Input.Html.Blaze   ( addBlaze )+import           Knit.Report.Input.Html.Lucid   ( addLucid )+import           Knit.Report.Input.Latex        ( addLatex )+import           Knit.Report.Input.Visualization.Hvega+                                                ( addHvega )++import           Knit.Report.Output             ( PandocWriterConfig(..) )+import           Knit.Report.Output.Html        ( pandocWriterToBlazeDocument+                                                , mindocOptionsF+                                                )++import           Text.Pandoc                    ( PandocError )++import           Control.Monad.Except           ( MonadIO )+import qualified Data.Text                     as T+import qualified Data.Text.Lazy                as TL+import           GHC.Exts                       ( Constraint )++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++++-- | 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.  +knitHtmls+  :: forall m+   . (MonadIO m, LastMember (P.Lift m) (KnitEffectStack m))+  => Maybe T.Text -- ^ outer logging prefix+  -> [KLog.LogSeverity] -- ^ what to output in log+  -> PandocWriterConfig -- ^ configuration for the Pandoc Html Writer+  -> P.Semantic (KnitEffectDocsStack m) () -- ^ Knit effects "over" m+  -> m (Either PA.PandocError [KP.NamedDoc TL.Text]) -- ^  named documents, converted to Html as Text or error+knitHtmls loggingPrefixM ls writeConfig =+  runSemT (consumeKnitEffectMany loggingPrefixM ls writeConfig)++-- | 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.  +knitHtml+  :: forall m+   . (MonadIO m, LastMember (P.Lift m) (KnitEffectStack m))+  => Maybe T.Text -- ^ outer logging prefix+  -> [KLog.LogSeverity] -- ^ what to output in log+  -> PandocWriterConfig -- ^ configuration for the Pandoc Html Writer+  -> P.Semantic (KnitEffectDocStack m) () -- ^ Knit effects "over" m+  -> m (Either PA.PandocError TL.Text) -- ^  document, converted to Html as Text, or error+knitHtml loggingPrefixM ls writeConfig =+  runSemT (consumeKnitEffectOne loggingPrefixM ls writeConfig)++-- | Constraints required to build a document while also using effects from a base monad m.+type KnitBase m effs = (MonadIO m, P.Member (P.Lift m) effs)++-- | lift an action in a base monad into a Polysemy monad+liftKnit :: Member (Lift m) r => m a -> Semantic r a+liftKnit = P.sendM++-- From here down is unexported.  ++-- | The exact stack we are interpreting when we knit+type KnitEffectStack m =+  '[ KPM.Pandoc+   , KLog.Logger KLog.LogEntry+   , KLog.PrefixLog+   , PE.Error PA.PandocError+   , P.Lift IO+   , P.Lift m+   ]++-- | Add a Multi-doc writer to the front of the effect list+type KnitEffectDocsStack m = (KD.Docs KP.PandocWithRequirements ': KnitEffectStack m)++-- | Add a single-doc writer to the front of the effect list+type KnitEffectDocStack m = (KP.ToPandoc ': KnitEffectStack m)++-- | require that the effect @eff@ be last in the list of effects @r@+type family LastMember (eff :: k) (r :: [k]) :: Constraint where+  LastMember eff '[] = ()+  LastMember eff (e : es) = (P.Member eff (e ': es), LastMember eff es)++-- | run all effects, given that last one is @Lift m@+runSemT+  :: Monad m+  => (P.Semantic r a -> P.Semantic '[P.Lift m] b)+  -> P.Semantic r a+  -> m b+runSemT consume = P.runM . consume++-- | run all effects in @KnitEffectStack m@ except the final @Lift m@+consumeKnitEffectStack+  :: forall m a+   . (MonadIO m, LastMember (P.Lift m) (KnitEffectStack m))+  => Maybe T.Text -- ^ outer logging prefix+  -> [KLog.LogSeverity] -- ^ what to output in log+  -> P.Semantic (KnitEffectStack m) a+  -> P.Semantic '[P.Lift m] (Either PA.PandocError a)+consumeKnitEffectStack loggingPrefixM ls =+  PI.runIO @m -- interpret (Lift IO) using m+    . PE.runError+    . KLog.filteredLogEntriesToIO ls+    . KPM.interpretInIO -- PA.PandocIO+    . maybe id KLog.wrapPrefix loggingPrefixM++-- | run all effects in @KnitEffectDocsStack m@ except the final @Lift m@+consumeKnitEffectMany+  :: forall m+   . (MonadIO m, LastMember (P.Lift m) (KnitEffectStack m))+  => Maybe T.Text -- ^ outer logging prefix+  -> [KLog.LogSeverity] -- ^ what to output in log+  -> PandocWriterConfig -- ^ configuration for the Pandoc Html Writer+  -> P.Semantic (KnitEffectDocsStack m) ()+  -> P.Semantic+       '[P.Lift m]+       (Either PA.PandocError [KP.NamedDoc TL.Text])+consumeKnitEffectMany loggingPrefixM ls writeConfig =+  consumeKnitEffectStack @m loggingPrefixM ls . KD.toNamedDocListWithM+    (fmap BH.renderHtml . KO.toBlazeDocument writeConfig)++-- | run all effects in @KnitEffectDocStack m@ except the final @Lift m@+consumeKnitEffectOne+  :: forall m+   . (MonadIO m, LastMember (P.Lift m) (KnitEffectStack m))+  => Maybe T.Text -- ^ outer logging prefix+  -> [KLog.LogSeverity] -- ^ what to output in log+  -> PandocWriterConfig -- ^ configuration for the Pandoc Html Writer+  -> P.Semantic (KnitEffectDocStack m) ()+  -> P.Semantic '[P.Lift m] (Either PA.PandocError TL.Text)+consumeKnitEffectOne loggingPrefixM ls writeConfig =+  fmap (fmap (fmap BH.renderHtml)) (consumeKnitEffectStack @m loggingPrefixM ls)+    . KO.pandocWriterToBlazeDocument writeConfig+++{-+type KnitEffectC m r = (+    P.Member KPM.Pandoc r+  , KLog.LogWithPrefixesLE r+  , P.Member (PE.Error PA.PandocError) r+  , P.Member (P.Lift IO) r+  , P.Member (P.Lift m) r+  )++consumeKnitEffectPoly+  :: forall m r a+   . (PA.PandocMonad m, MonadIO m, KnitEffectC m r, LastMember (P.Lift m) r)+  => Maybe T.Text -- ^ outer logging prefix+  -> [KLog.LogSeverity] -- ^ what to output in log+  -> P.Semantic r a+  -> P.Semantic '[P.Lift m] (Either PA.PandocError a)+consumeKnitEffectPoly loggingPrefixM ls =+  PI.runIO @m+    . PE.runError+    . KLog.filteredLogEntriesToIO ls+    . KPM.runPandoc @m -- PA.PandocIO+    . maybe id KLog.wrapPrefix loggingPrefixM+-}
+ src/Knit/Report/Input/Html.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE ExtendedDefaultRules #-}+{-# LANGUAGE ScopedTypeVariables  #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DataKinds     #-}+{-# LANGUAGE GADTs         #-}+{-|+Module      : Knit.Report.Input.Html+Description : Support functions for adding Html fragments into a Pandoc document.+Copyright   : (c) Adam Conner-Sax 2019+License     : BSD-3-Clause+Maintainer  : adam_conner_sax@yahoo.com+Stability   : experimental++Functions and Pandoc option sets for adding Html fragments into a Pandoc document. +-}+module Knit.Report.Input.Html+  (+    -- * Add html formatted as Text+    addStrictTextHtml+  , addLazyTextHtml++    -- * Default Options+  , htmlReaderOptions+  , htmlReaderOptionsWithHeader+  )+where++import qualified Data.Text                     as T+import qualified Data.Text.Lazy                as LT+import qualified Text.Pandoc                   as P+import qualified Text.Pandoc.Extensions        as PA++import qualified Polysemy                      as P+import qualified Knit.Effect.Pandoc            as PE+import qualified Knit.Effect.PandocMonad       as PM+++-- | Base Html reader options+htmlReaderOptions :: P.ReaderOptions+htmlReaderOptions =+  P.def { P.readerExtensions = PA.extensionsFromList [PA.Ext_raw_html] }++-- | Html reader options for complete document+htmlReaderOptionsWithHeader :: P.ReaderOptions+htmlReaderOptionsWithHeader = htmlReaderOptions { P.readerStandalone = True }++-- | Add Strict Text Html to current Pandoc+addStrictTextHtml+  :: (PM.PandocEffects effs, P.Member PE.ToPandoc effs)+  => T.Text+  -> P.Semantic effs ()+addStrictTextHtml = PE.addFrom PE.ReadHtml htmlReaderOptions++-- | Add Lazy Text Html to current Pandoc+addLazyTextHtml+  :: (PM.PandocEffects effs, P.Member PE.ToPandoc effs)+  => LT.Text+  -> P.Semantic effs ()+addLazyTextHtml = addStrictTextHtml . LT.toStrict
+ src/Knit/Report/Input/Html/Blaze.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-|+Module      : Knit.Report.Input.Html.Blaze+Description : Support functions for adding Blaze Html fragments into a report+Copyright   : (c) Adam Conner-Sax 2019+License     : BSD-3-Clause+Maintainer  : adam_conner_sax@yahoo.com+Stability   : experimental++Functions to add Blaze fragments into a Pandoc generated report.+-}+module Knit.Report.Input.Html.Blaze+  (+  -- * Add Blaze+    addBlaze+  )+where++import Knit.Report.Input.Html (addLazyTextHtml)+import qualified Text.Blaze.Html               as BH+import qualified Text.Blaze.Html.Renderer.Text as BH++import qualified Polysemy                      as P+import qualified Knit.Effect.Pandoc           as PE+import qualified Knit.Effect.PandocMonad      as PM+++-- | Add Blaze Html +addBlaze+  :: (PM.PandocEffects effs, P.Member PE.ToPandoc effs)+  => BH.Html+  -> P.Semantic effs ()+addBlaze = addLazyTextHtml . BH.renderHtml
+ src/Knit/Report/Input/Html/Lucid.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-|+Module      : Knit.Report.Input.Html.Lucid+Description : Support functions for adding Lucid Html fragments into a report+Copyright   : (c) Adam Conner-Sax 2019+License     : BSD-3-Clause+Maintainer  : adam_conner_sax@yahoo.com+Stability   : experimental++Functions to add Lucid fragments into a Pandoc generated report.+-}+module Knit.Report.Input.Html.Lucid+  (+  -- * Add Lucid +    addLucid+  )+where++import Knit.Report.Input.Html (addLazyTextHtml)+import qualified Lucid                         as LH++import qualified Polysemy                      as P+import qualified Knit.Effect.Pandoc           as PE+import qualified Knit.Effect.PandocMonad      as PM++-- | Add Lucid Html+addLucid+  :: (PM.PandocEffects effs, P.Member PE.ToPandoc effs)+  => LH.Html ()+  -> P.Semantic effs ()+addLucid = addLazyTextHtml . LH.renderText
+ src/Knit/Report/Input/Latex.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-|+Module      : Knit.Report.Input.Latex+Description : Support functions for adding LaTeX fragments into a report+Copyright   : (c) Adam Conner-Sax 2019+License     : BSD-3-Clause+Maintainer  : adam_conner_sax@yahoo.com+Stability   : experimental++Functions to add LaTeX fragments to the current Pandoc.+-}+module Knit.Report.Input.Latex+  (+    -- * Add LaTeX fragments+    addLatex+  )+where++import qualified Data.Text                     as T+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++-- | Add LaTeX+addLatex+  :: (PM.PandocEffects effs, P.Member PE.ToPandoc effs)+  => T.Text+  -> P.Semantic effs ()+addLatex lText = do+  PE.require PE.LatexSupport+  PE.addFrom PE.ReadLaTeX PA.def lText
+ src/Knit/Report/Input/MarkDown/PandocMarkDown.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE ExtendedDefaultRules #-}+{-# LANGUAGE ScopedTypeVariables  #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DataKinds     #-}+{-# LANGUAGE GADTs         #-}+{-|+Module      : Knit.Report.Input.Markdown.PandocMarkdown+Description : Functions to add Pandoc MarkDown fragments to a Pandoc+Copyright   : (c) Adam Conner-Sax 2019+License     : BSD-3-Clause+Maintainer  : adam_conner_sax@yahoo.com+Stability   : experimental++Functions to add Pandoc MarkDown fragments to the current Pandoc.+-}+module Knit.Report.Input.MarkDown.PandocMarkDown+  (+    -- * Default Options+    markDownReaderOptions++    -- * functions to add various thing to the current Pandoc+  , addMarkDown+  , addMarkDownWithOptions+  )+where++import qualified Data.Text                     as T+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++-- | Base Pandoc MarkDown reader options+markDownReaderOptions :: PA.ReaderOptions+markDownReaderOptions = PA.def+  { PA.readerStandalone = True+  , PA.readerExtensions = PA.extensionsFromList+                            [ PA.Ext_auto_identifiers+                            , PA.Ext_backtick_code_blocks+                            , PA.Ext_fancy_lists+                            , PA.Ext_footnotes+                            , PA.Ext_simple_tables+                            , PA.Ext_multiline_tables+                            , PA.Ext_tex_math_dollars+                            , PA.Ext_header_attributes+                            , PA.Ext_implicit_header_references+                            ]+  }++-- | Add a Pandoc MarkDown fragment with the given options+addMarkDownWithOptions+  :: (PM.PandocEffects effs, P.Member PE.ToPandoc effs)+  => PA.ReaderOptions+  -> T.Text+  -> P.Semantic effs ()+addMarkDownWithOptions = PE.addFrom PE.ReadMarkDown++-- | Add a Pandoc MarkDown fragment with default options+addMarkDown+  :: (PM.PandocEffects effs, P.Member PE.ToPandoc effs)+  => T.Text+  -> P.Semantic effs ()+addMarkDown = addMarkDownWithOptions markDownReaderOptions+
+ src/Knit/Report/Input/Table/Colonnade.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs            #-}+{-# LANGUAGE OverloadedStrings #-}+{-|+Module      : Knit.Report.Input.Latex+Description : Support functions for adding LaTeX fragments into a report+Copyright   : (c) Adam Conner-Sax 2019+License     : BSD-3-Clause+Maintainer  : adam_conner_sax@yahoo.com+Stability   : experimental++Functions to add table fragments, using <https://hackage.haskell.org/package/colonnade Colonnade>, to the current Pandoc.++Notes:++1. The way these tables render will depend entirely on how styling is set in the pandoc template.  For Html, this will be determined by css in the template.+Styling put in here does not make it through to Html output.+If you need specific styling, you can use the same colonnade functions these do and embed raw html. Somehow.+-}+module Knit.Report.Input.Table.Colonnade+  (+    -- * Add Colonnade table fragments+    addColonnadeTextTable+  , addColonnadeHtmlTable+  , addColonnadeCellTable+  )+where+++import qualified Colonnade                     as C+import qualified Text.Blaze.Colonnade          as BC+import qualified Text.Blaze.Html               as BH+import qualified Text.Blaze.Html.Renderer.Text as BH+import qualified Text.Blaze.Html5.Attributes   as BHA+import           Knit.Report.Input.Html.Blaze   ( addBlaze )+import           Knit.Report.Input.MarkDown.PandocMarkDown+                                                ( addMarkDown )++import           Data.Text                      ( Text )+import qualified Data.Text.Lazy                as TL+import qualified Polysemy                      as P+import qualified Knit.Effect.Pandoc            as PE+import qualified Knit.Effect.PandocMonad       as PM++-- | Add a table given a Colonnade representation producing text +addColonnadeTextTable+  :: (PM.PandocEffects effs, P.Member PE.ToPandoc effs, Foldable f)+  => C.Colonnade C.Headed a Text -- ^ How to encode data as columns+  -> f a -- ^ collection of data+  -> P.Semantic effs ()+addColonnadeTextTable colonnade rows = do+  let toCell t = BC.Cell (BHA.style "border: 1px solid black") (BH.toHtml t) -- styling here gets lost.  But maybe I can fix?+  addBlaze $ BC.encodeCellTable+    (BHA.style "border: 1px solid black; border-collapse: collapse") -- this gets lost.  Leaving it here in case I fix that!+    (fmap toCell colonnade)+    rows++-- | Add a <https://hackage.haskell.org/package/blaze-colonnade Blaze-Colonnade> Html Table+addColonnadeHtmlTable+  :: (PM.PandocEffects effs, P.Member PE.ToPandoc effs, Foldable f)+  => BH.Attribute -- ^ Attributes of <table> Html element, currently unused by knit-haskell+  -> C.Colonnade C.Headed a BH.Html -- ^ How to encode data as columns+  -> f a -- ^ collection of data+  -> P.Semantic effs ()+addColonnadeHtmlTable attr colonnade rows =+  addBlaze $ BC.encodeHtmlTable attr colonnade rows++-- | Add a <https://hackage.haskell.org/package/blaze-colonnade Blaze-Colonnade> Cell Table+addColonnadeCellTable+  :: (PM.PandocEffects effs, P.Member PE.ToPandoc effs, Foldable f)+  => BH.Attribute -- ^ Attributes of <table> Html element, currently unused by knit-haskell+  -> C.Colonnade C.Headed a BC.Cell -- ^ How to encode data as columns+  -> f a -- ^ collection of data+  -> P.Semantic effs ()+addColonnadeCellTable attr colonnade rows =+  addBlaze $ BC.encodeCellTable attr colonnade rows
+ src/Knit/Report/Input/Visualization/Hvega.hs view
@@ -0,0 +1,75 @@+{-# LANGUAGE ExtendedDefaultRules #-}+{-# LANGUAGE OverloadedStrings    #-}+{-# LANGUAGE ScopedTypeVariables  #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE DataKinds     #-}+{-# LANGUAGE GADTs         #-}+{-|+Module      : Knit.Report.Input.Visualization.Hvega+Description : Support functions for simple reports using Pandoc+Copyright   : (c) Adam Conner-Sax 2019+License     : BSD-3-Clause+Maintainer  : adam_conner_sax@yahoo.com+Stability   : experimental++Functions to add hvega charts (using Blaze Html) to the current Pandoc document.+-}+module Knit.Report.Input.Visualization.Hvega+  (+    -- * Add hvega Inputs+    addHvega+  )+where++import           Knit.Report.Input.Html.Blaze   ( addBlaze )++import qualified Data.Aeson.Encode.Pretty      as A+import qualified Data.ByteString.Lazy.Char8    as BS+import qualified Data.Text                     as T+import qualified Data.Text.Encoding            as T+import qualified Graphics.Vega.VegaLite        as GV+import qualified Text.Blaze.Html5              as BH+import qualified Text.Blaze.Html5.Attributes   as BHA++import qualified Polysemy                      as P+import qualified Knit.Effect.Pandoc            as PE+import qualified Knit.Effect.PandocMonad       as PM+++-- TODO: Add some autogenerated unique id support++-- | Add hvega (via html). Requires html since vega-lite renders using javascript.+addHvega+  :: (PM.PandocEffects effs, P.Member PE.ToPandoc effs)+  => T.Text+  -> GV.VegaLite+  -> P.Semantic effs ()+addHvega vizId vl = do+  PE.require PE.VegaSupport+  addBlaze $ placeVisualization vizId vl+++-- | Build (Blaze) Html for  hvega visualization with the given id+placeVisualization :: T.Text -> GV.VegaLite -> BH.Html+placeVisualization idText vl =+  let vegaScript :: T.Text =+        T.decodeUtf8 $ BS.toStrict $ A.encodePretty $ GV.fromVL vl+      script =+        "var vlSpec=\n"+          <> vegaScript+          <> ";\n"+          <> "vegaEmbed(\'#"+          <> idText+          <> "\',vlSpec);"+  in  BH.figure+      BH.! BHA.id (BH.toValue idText)+      $    BH.script+      BH.! BHA.type_ "text/javascript"+      $    BH.preEscapedToHtml script++++++
+ src/Knit/Report/Other/Blaze.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE ExtendedDefaultRules #-}+{-# LANGUAGE OverloadedStrings    #-}+{-# LANGUAGE ScopedTypeVariables  #-}+{-|+Module      : Knit.Report.Other.Blaze+Description : Support functions for simple reports in Blaze+Copyright   : (c) Adam Conner-Sax 2019+License     : BSD-3-Clause+Maintainer  : adam_conner_sax@yahoo.com+Stability   : experimental++Functions to support some simple reports using only Blaze.++Using the Pandoc framework instead is recommended.  +-}+module Knit.Report.Other.Blaze+  (+    -- * Add relevant headers, scripts+    makeReportHtml+    -- * add report pieces+  , placeVisualization+  , placeTextSection+  , latexToHtml+  , latex_+  )+where++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+import qualified Text.Blaze.Html5              as H+import           Text.Blaze.Html5               ( (!) )+import qualified Text.Blaze.Html5.Attributes   as HA+import qualified Text.Pandoc                   as P++-- | Convert Latex to Blaze Html+latexToHtml :: T.Text -> H.Html+latexToHtml lText = do+  let+    latexReadOptions = P.def+    htmlWriteOptions = P.def { P.writerHTMLMathMethod = P.MathJax "" }+    asHtml =+      P.readLaTeX latexReadOptions lText >>= P.writeHtml5String htmlWriteOptions+  case P.runPure asHtml of+    Left  err      -> H.span (H.toHtml $ show err)+    Right htmlText -> H.span (H.preEscapedToHtml htmlText)++latex_ :: T.Text -> H.Html+latex_ = latexToHtml++mathJaxScript :: H.Html+mathJaxScript =+  H.script+    ! HA.src+        "https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.5/MathJax.js?config=TeX-MML-AM_CHTML"+    ! HA.async ""+    $ ""++++vegaScripts2 :: H.Html+vegaScripts2 = do+  H.script ! HA.src "https://cdn.jsdelivr.net/npm/vega@4.4.0" $ ""+  H.script ! HA.src "https://cdn.jsdelivr.net/npm/vega-lite@3.0.0-rc11" $ ""+  H.script ! HA.src "https://cdn.jsdelivr.net/npm/vega-embed@3.28.0" $ ""++vegaScripts3 :: H.Html+vegaScripts3 = do+  H.script ! HA.src "https://cdn.jsdelivr.net/npm/vega@4.4.0/build/vega.js" $ ""+  H.script+    ! HA.src+        "https://cdn.jsdelivr.net/npm/vega-lite@3.0.0-rc12/build/vega-lite.js"+    $ ""+  H.script+    ! HA.src+        "https://cdn.jsdelivr.net/npm/vega-embed@3.29.1/build/vega-embed.js"+    $ ""++-- | Add headers for using Tufte css+tufteSetup :: H.Html+tufteSetup = do+  H.link ! HA.rel "stylesheet" ! HA.href+    "https://cdnjs.cloudflare.com/ajax/libs/tufte-css/1.4/tufte.min.css"+  H.meta ! HA.name "viewport" ! HA.content "width=device-width, initial-scale=1"++-- | Wrap given html in appropriate headers for the hvega and latex functions to work+makeReportHtml :: T.Text -> H.Html -> H.Html+makeReportHtml title reportHtml = H.html $ H.docTypeHtml $ do+  H.head $ do+    H.title (H.toHtml title)+    tufteSetup+    mathJaxScript+    vegaScripts2+  H.body $ H.article $ reportHtml++-- | Add an hvega visualization with the given id+placeVisualization :: T.Text -> GV.VegaLite -> H.Html+placeVisualization idText vl =+  let vegaScript :: T.Text =+        T.decodeUtf8 $ BS.toStrict $ A.encodePretty $ GV.fromVL vl+      script =+        "var vlSpec=\n"+          <> vegaScript+          <> ";\n"+          <> "vegaEmbed(\'#"+          <> idText+          <> "\',vlSpec);"+  in  H.figure+      ! HA.id (H.toValue idText)+      $ H.script+      ! HA.type_ "text/javascript"+      $ H.preEscapedToHtml script++-- | Add the given Html as a new section+placeTextSection :: H.Html -> H.Html+placeTextSection = H.section+
+ src/Knit/Report/Other/Lucid.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE ExtendedDefaultRules #-}+{-# LANGUAGE OverloadedStrings    #-}+{-# LANGUAGE ScopedTypeVariables  #-}+{-|+Module      : Knit.Report.Other.Lucid+Description : freer-simple random effect+Copyright   : (c) Adam Conner-Sax 2019+License     : BSD-3-Clause+Maintainer  : adam_conner_sax@yahoo.com+Stability   : experimental++Functions to support some simple reports using Lucid.  Particularly to support adding latex and hvega charts.+-}+module Knit.Report.Other.Lucid+  (+    -- * Setup, headers, scripts, etc.+    makeReportHtml+    -- * add specific report bits+  , placeVisualization+  , placeTextSection+  , latexToHtml+  -- * helpers+  , latex_+  )+where++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+import qualified Lucid                      as H+import qualified Text.Pandoc                as P++-- | Convert Latex to Lucid Html+latexToHtml :: T.Text -> H.Html ()+latexToHtml lText = do+  let latexReadOptions = P.def+      htmlWriteOptions = P.def { P.writerHTMLMathMethod = P.MathJax "" }+      asHtml = P.readLaTeX latexReadOptions lText >>= P.writeHtml5String htmlWriteOptions+  case P.runPure asHtml of+    Left err       -> H.span_ (H.toHtml $ show err)+    Right htmlText -> H.span_ (H.toHtmlRaw htmlText)++-- | Convert Latex to Lucid Html+latex_ :: T.Text -> H.Html ()+latex_ = latexToHtml++-- | Add headers for MathJax+mathJaxScript :: H.Html ()+mathJaxScript = H.script_ [H.src_ "https://cdnjs.cloudflare.com/ajax/libs/mathjax/2.7.5/MathJax.js?config=TeX-MML-AM_CHTML", H.async_ ""] ("" :: String)++-- | Add headers to use vega-lite (v2)+vegaScripts2 :: H.Html ()+vegaScripts2 = do+  H.script_ [H.src_ "https://cdn.jsdelivr.net/npm/vega@4.4.0"] ("" :: String)+  H.script_ [H.src_ "https://cdn.jsdelivr.net/npm/vega-lite@3.0.0-rc11"] ("" :: String)+  H.script_ [H.src_ "https://cdn.jsdelivr.net/npm/vega-embed@3.28.0"] ("" :: String)++-- | Add headers to use vega-lite (v3)+vegaScripts3 :: H.Html ()+vegaScripts3 = do+  H.script_ [H.src_ "https://cdn.jsdelivr.net/npm/vega@4.4.0/build/vega.js"] ("" :: String)+  H.script_ [H.src_ "https://cdn.jsdelivr.net/npm/vega-lite@3.0.0-rc12/build/vega-lite.js"] ("" :: String)+  H.script_ [H.src_ "https://cdn.jsdelivr.net/npm/vega-embed@3.29.1/build/vega-embed.js"] ("" :: String)++-- | Add headers to use Tufte css+tufteSetup :: H.Html ()+tufteSetup = do+   H.link_ [H.rel_ "stylesheet", H.href_ "https://cdnjs.cloudflare.com/ajax/libs/tufte-css/1.4/tufte.min.css"]+   H.meta_ [H.name_ "viewport", H.content_"width=device-width, initial-scale=1"]++-- | -- | wrap given html in appropriate headers for the hvega and latex functions to work+makeReportHtml :: T.Text -> H.Html a -> H.Html a+makeReportHtml title reportHtml = H.html_ $ htmlHead >> H.body_ (H.article_ reportHtml) where+  htmlHead :: H.Html () = H.head_ (do+                                  H.title_ (H.toHtmlRaw title)+                                  tufteSetup+                                  mathJaxScript+                                  vegaScripts2+                                  return ()+                              )++-- | add an hvega visualization with the given id+placeVisualization :: T.Text -> GV.VegaLite -> H.Html ()+placeVisualization idText vl =+  let vegaScript :: T.Text = T.decodeUtf8 $ BS.toStrict $ A.encodePretty $ GV.fromVL vl+      script = "var vlSpec=\n" <> vegaScript <> ";\n" <> "vegaEmbed(\'#" <> idText <> "\',vlSpec);"+  in H.figure_ [H.id_ idText] (H.script_ [H.type_ "text/javascript"]  (H.toHtmlRaw script))++-- | add the given Html as a new section+placeTextSection :: H.Html () -> H.Html ()+placeTextSection  = H.section_ [{- attributes/styles here -}]+
+ src/Knit/Report/Output.hs view
@@ -0,0 +1,20 @@+module Knit.Report.Output+  (+    -- * Pandoc Writer Configuration+    PandocWriterConfig(..)+  )+where++import qualified Data.Map                      as M+import qualified Text.Pandoc                   as PA++data PandocWriterConfig =+  PandocWriterConfig+  {+    templateFP :: Maybe FilePath+    -- ^ optional path to pandoc <https://pandoc.org/MANUAL.html#templates template>+  , templateVars :: M.Map String String+  -- ^ variable substitutions for the <https://pandoc.org/MANUAL.html#templates template>+  , optionsF :: (PA.WriterOptions -> PA.WriterOptions)+  -- ^ change default <https://pandoc.org/MANUAL.html#general-writer-options options>+  }
+ src/Knit/Report/Output/Html.hs view
@@ -0,0 +1,112 @@+{-# LANGUAGE ExtendedDefaultRules #-}+{-# LANGUAGE OverloadedStrings    #-}+{-# LANGUAGE ScopedTypeVariables  #-}+{-# LANGUAGE FlexibleContexts     #-}+{-# LANGUAGE TypeOperators        #-}+{-# LANGUAGE DataKinds            #-}+{-# LANGUAGE GADTs                #-}+{-|+Module      : Knit.Report.Output.Html+Description : Output Pandoc as Html+Copyright   : (c) Adam Conner-Sax 2019+License     : BSD-3-Clause+Maintainer  : adam_conner_sax@yahoo.com+Stability   : experimental++Functions to produce Html output for a Pandoc report.+-}+module Knit.Report.Output.Html+  (+    -- * Default Options+    htmlWriterOptions++    -- * Formatted output+  , toBlazeDocument+  , pandocWriterToBlazeDocument++  -- * Options helper  +  , mindocOptionsF++  -- * Other helpers+  , markDownTextToBlazeFragment+  )+where+++import qualified Data.ByteString.Char8         as BS+import qualified Data.Text                     as T+import qualified Data.Map                      as M+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++import           Knit.Report.Input.MarkDown.PandocMarkDown+                                                ( markDownReaderOptions )+import           Knit.Report.Output             ( PandocWriterConfig(..) )++-- | Base Html writer options, with support for MathJax+htmlWriterOptions :: PA.WriterOptions+htmlWriterOptions = PA.def+  { PA.writerExtensions     = PA.extensionsFromList [PA.Ext_raw_html]+  , PA.writerHTMLMathMethod = PA.MathJax ""+  }++-- | Full writer options which use pandoc monad for template access+htmlFullDocWriterOptions+  :: PA.PandocMonad 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+  template <- case pathM of+    Nothing -> PA.getDefaultTemplate "Html5"+    Just fp -> do+      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"+  return $ htmlWriterOptions { PA.writerTemplate      = Just template+                             , PA.writerVariables     = M.toList tVars+                             , PA.writerSetextHeaders = True+                             }+++-- | Convert markDown to Blaze+markDownTextToBlazeFragment+  :: PM.PandocEffects effs+  => T.Text -- ^ markDown Text+  -> P.Semantic effs BH.Html+markDownTextToBlazeFragment =+  PE.fromPandocE PE.WriteHtml5 htmlWriterOptions+    . 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+  => PandocWriterConfig+  -> PE.PandocWithRequirements -- ^ Document and union of input requirements +  -> P.Semantic effs BH.Html+toBlazeDocument writeConfig pdocWR = 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. +pandocWriterToBlazeDocument+  :: PM.PandocEffects effs+  => PandocWriterConfig -- ^ Configuration info for the Pandoc writer+  -> P.Semantic (PE.ToPandoc ': effs) () -- ^ Effects stack to run to get Pandoc+  -> P.Semantic effs BH.Html -- ^ Blaze Html (in remaining effects)+pandocWriterToBlazeDocument writeConfig pw =+  PE.runPandocWriter pw >>= toBlazeDocument writeConfig++-- | options for the mindoc template+mindocOptionsF :: PA.WriterOptions -> PA.WriterOptions+mindocOptionsF op = op { PA.writerSectionDivs = True }