diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,2 @@ +v 0.1.0.0 +* Initial version diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/examples/MtlExample.hs b/examples/MtlExample.hs new file mode 100644 --- /dev/null +++ b/examples/MtlExample.hs @@ -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]: +|] + +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 [] ] diff --git a/examples/RandomExample.hs b/examples/RandomExample.hs new file mode 100644 --- /dev/null +++ b/examples/RandomExample.hs @@ -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]: +|] + +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 [] ] diff --git a/examples/SimpleExample.hs b/examples/SimpleExample.hs new file mode 100644 --- /dev/null +++ b/examples/SimpleExample.hs @@ -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]: +|] + +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 [] ] diff --git a/knit-haskell.cabal b/knit-haskell.cabal new file mode 100644 --- /dev/null +++ b/knit-haskell.cabal @@ -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 rather than mtl) + which includes logging, randomness + (via ), + 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 + or html. + Support is also included for including + visualizations. + More information is available in the . +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 diff --git a/src/Knit/Effect/Docs.hs b/src/Knit/Effect/Docs.hs new file mode 100644 --- /dev/null +++ b/src/Knit/Effect/Docs.hs @@ -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 + + 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 + diff --git a/src/Knit/Effect/Html.hs b/src/Knit/Effect/Html.hs new file mode 100644 --- /dev/null +++ b/src/Knit/Effect/Html.hs @@ -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' 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 + diff --git a/src/Knit/Effect/Logger.hs b/src/Knit/Effect/Logger.hs new file mode 100644 --- /dev/null +++ b/src/Knit/Effect/Logger.hs @@ -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 + + logger effect, +using pretty-printing and severity based on . 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 @[]) +-} diff --git a/src/Knit/Effect/Pandoc.hs b/src/Knit/Effect/Pandoc.hs new file mode 100644 --- /dev/null +++ b/src/Knit/Effect/Pandoc.hs @@ -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 + diff --git a/src/Knit/Effect/PandocMonad.hs b/src/Knit/Effect/PandocMonad.hs new file mode 100644 --- /dev/null +++ b/src/Knit/Effect/PandocMonad.hs @@ -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) diff --git a/src/Knit/Effect/RandomFu.hs b/src/Knit/Effect/RandomFu.hs new file mode 100644 --- /dev/null +++ b/src/Knit/Effect/RandomFu.hs @@ -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 + |]) diff --git a/src/Knit/Report.hs b/src/Knit/Report.hs new file mode 100644 --- /dev/null +++ b/src/Knit/Report.hs @@ -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. + + 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 +-} diff --git a/src/Knit/Report/Input/Html.hs b/src/Knit/Report/Input/Html.hs new file mode 100644 --- /dev/null +++ b/src/Knit/Report/Input/Html.hs @@ -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 diff --git a/src/Knit/Report/Input/Html/Blaze.hs b/src/Knit/Report/Input/Html/Blaze.hs new file mode 100644 --- /dev/null +++ b/src/Knit/Report/Input/Html/Blaze.hs @@ -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 diff --git a/src/Knit/Report/Input/Html/Lucid.hs b/src/Knit/Report/Input/Html/Lucid.hs new file mode 100644 --- /dev/null +++ b/src/Knit/Report/Input/Html/Lucid.hs @@ -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 diff --git a/src/Knit/Report/Input/Latex.hs b/src/Knit/Report/Input/Latex.hs new file mode 100644 --- /dev/null +++ b/src/Knit/Report/Input/Latex.hs @@ -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 diff --git a/src/Knit/Report/Input/MarkDown/PandocMarkDown.hs b/src/Knit/Report/Input/MarkDown/PandocMarkDown.hs new file mode 100644 --- /dev/null +++ b/src/Knit/Report/Input/MarkDown/PandocMarkDown.hs @@ -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 + diff --git a/src/Knit/Report/Input/Table/Colonnade.hs b/src/Knit/Report/Input/Table/Colonnade.hs new file mode 100644 --- /dev/null +++ b/src/Knit/Report/Input/Table/Colonnade.hs @@ -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 , 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 Html Table +addColonnadeHtmlTable + :: (PM.PandocEffects effs, P.Member PE.ToPandoc effs, Foldable f) + => BH.Attribute -- ^ Attributes of 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 Cell Table +addColonnadeCellTable + :: (PM.PandocEffects effs, P.Member PE.ToPandoc effs, Foldable f) + => BH.Attribute -- ^ Attributes of
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 diff --git a/src/Knit/Report/Input/Visualization/Hvega.hs b/src/Knit/Report/Input/Visualization/Hvega.hs new file mode 100644 --- /dev/null +++ b/src/Knit/Report/Input/Visualization/Hvega.hs @@ -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 + + + + + + diff --git a/src/Knit/Report/Other/Blaze.hs b/src/Knit/Report/Other/Blaze.hs new file mode 100644 --- /dev/null +++ b/src/Knit/Report/Other/Blaze.hs @@ -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 + diff --git a/src/Knit/Report/Other/Lucid.hs b/src/Knit/Report/Other/Lucid.hs new file mode 100644 --- /dev/null +++ b/src/Knit/Report/Other/Lucid.hs @@ -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 -}] + diff --git a/src/Knit/Report/Output.hs b/src/Knit/Report/Output.hs new file mode 100644 --- /dev/null +++ b/src/Knit/Report/Output.hs @@ -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 + , templateVars :: M.Map String String + -- ^ variable substitutions for the + , optionsF :: (PA.WriterOptions -> PA.WriterOptions) + -- ^ change default + } diff --git a/src/Knit/Report/Output/Html.hs b/src/Knit/Report/Output/Html.hs new file mode 100644 --- /dev/null +++ b/src/Knit/Report/Output/Html.hs @@ -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 }