diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,20 @@ +v 0.4.0.0 +* Added ```absorbPandocMonad :: PandocEffects r => (forall m. PandocMonad m => m a) -> Sem r a``` to Knit.Effect.PandocMonad +* Removed (orphan) instances: ```PandocMonad (Sem r)``` and ```MonadError PandocError (Sem r)``` in favor +of using ```absorbPandocMonad``` when required. +* Deprecated name "Random" in favor of "RandomFu" for clarity and eventual consistency with Polysemy +* Added ```absorbMonadRandom :: Member RandomFu r => (forall m. MonadRandom m => m a) -> Sem r a``` to allow some +interoperation with actions constrained by ```MonadRandom``` +* Removed orphan ```Random.MonadRandom``` instance from ```Knit.Effect.RandomFu``` because orphan instances are bad. +* Changed return type of ```Knit.Report.knitError``` to ```Sem r a``` (from ```Sem r ()```) +* Bumped lower bound on polysemy-plugin (because of a buggy version) +* Bumped lower bound on polysemy +* Removed plots example in "SimpleExample" and added a diagrams one. Will add plots back once a version issue +with containers is resolved. + +v 0.3.0.1 +* Examples were "executables" and are now "tests" so that depending on knit-haskell does not pull in the dependencies of the examples. + v 0.3.0.0 * Added exports of "Colonnade" and "Text.Blaze.Colonnade" to "Knit.Report.Input.Table.Colonnade" * Added "knitError" function to Knit.Report to allow user throwing of errors. These will become PandocSomeError and handled as a PandocError. diff --git a/examples/RandomExample.hs b/examples/RandomExample.hs --- a/examples/RandomExample.hs +++ b/examples/RandomExample.hs @@ -10,15 +10,18 @@ import qualified Knit.Effect.RandomFu as KR import qualified Colonnade as C +import Control.Monad (replicateM) 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 Data.Random (MonadRandom, sample, stdNormal) +import Data.Random.Source.PureMT (newPureMT) + import Control.Monad.Reader (ReaderT , ask , runReaderT @@ -47,10 +50,11 @@ main = do let pandocWriterConfig = K.PandocWriterConfig (Just "pandoc-templates/minWithVega-pandoc.html") templateVars K.mindocOptionsF + pureMTSource <- newPureMT resE <- runExampleApp "This is from the MyApp environment." $ K.knitHtml (Just "RandomExample.Main") K.logAll pandocWriterConfig - $ KR.runRandomIOSimple $ makeDoc - case resE of + $ KR.runRandomFuIOPureMT pureMTSource $ makeDoc + case resE of Right htmlAsText -> T.writeFile "examples/html/random_example.html" $ TL.toStrict @@ -67,7 +71,7 @@ |] makeDoc :: ( K.KnitOne effs - , K.Member KR.Random effs -- this one needs to be handled before knitting + , K.Member KR.RandomFu effs -- this one needs to be handled before knitting , K.KnitBase ExampleApp effs) => K.Sem effs () makeDoc = K.wrapPrefix "makeDoc" $ do K.logLE K.Info "adding some markdown..." @@ -88,11 +92,19 @@ 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 + let nDraws = 20 + someNormalDoubles <- KR.sampleRVar $ replicateM nDraws (stdNormal @Double) 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 + K.addColonnadeTextTable (C.headed "#" (T.pack . show . fst) <> C.headed "Draw" (T.pack . show . snd)) $ zip [1..nDraws] someNormalDoubles + moreNormalDoubles <- KR.absorbMonadRandom (monadRandomFunction nDraws) + K.addMarkDown "## This time, using absorbMonadRandom to interoperate with a function using the MonadRandom constraint." + K.addMarkDown $ "some std normal draws: " + K.addColonnadeTextTable (C.headed "#" (T.pack . show . fst) <> C.headed "Draw" (T.pack . show . snd)) $ zip [1..nDraws] moreNormalDoubles + + +monadRandomFunction :: MonadRandom m => Int -> m [Double] +monadRandomFunction = sample . flip replicateM (stdNormal @Double) exampleVis :: V.VegaLite exampleVis = diff --git a/examples/SimpleExample.hs b/examples/SimpleExample.hs --- a/examples/SimpleExample.hs +++ b/examples/SimpleExample.hs @@ -14,7 +14,7 @@ import Data.String.Here (here) import qualified Graphics.Vega.VegaLite as V -import qualified Plots as P +--import qualified Plots as P templateVars :: M.Map String String templateVars = M.fromList @@ -55,8 +55,9 @@ K.addMarkDown "## An example hvega visualization" _ <- K.addHvega Nothing (Just "From the cars data-set") exampleVis K.addMarkDown "## An example Diagrams visualization" - K.logLE K.Info "adding a Diagrams plot..." - _ <- K.addDiagramAsSVG Nothing (Just "Example diagrams visualization using the Plots library") 300 300 samplePlot + K.logLE K.Info "adding a Diagrams plot..." + _ <- K.addDiagramAsSVG Nothing (Just "Example diagram") 300 300 exampleDiagram +-- _ <- K.addDiagramAsSVG Nothing (Just "Example diagrams visualization using the Plots library") 300 300 samplePlot return () -- example using HVega @@ -71,6 +72,27 @@ in V.toVegaLite [ bkg, cars, V.mark V.Circle [], enc [] ] +--sampleDiagram +-- from + +hilbert 0 = mempty +hilbert n = hilbert' (n-1) K.# K.reflectY <> K.vrule 1 + <> hilbert (n-1) <> K.hrule 1 + <> hilbert (n-1) <> K.vrule (-1) + <> hilbert' (n-1) K.# K.reflectX + where + hilbert' m = hilbert m K.# K.rotateBy (1/4) + +exampleDiagram :: K.Diagram K.SVG +exampleDiagram = K.frame 1 . K.lw K.medium . K.lc K.darkred + . K.strokeT $ hilbert 5 + + +{- +This plot example requires the plots library which cannot currently +be compiled with the polysemy plugin unless you use cabal.project +and add "allow-newer : plots:containers" + -- example using Plots (as an example of using Diagrams) samplePlot :: K.Diagram K.SVG samplePlot = P.renderAxis logAxis @@ -87,4 +109,4 @@ P.majorTicksFunction K..= P.logMajorTicks 5 -- <> pure [1] -- minorTicksFunction .= minorTicksHelper 5 ---exampleDiagram :: +-} diff --git a/knit-haskell.cabal b/knit-haskell.cabal --- a/knit-haskell.cabal +++ b/knit-haskell.cabal @@ -1,7 +1,7 @@ cabal-version: 2.2 name: knit-haskell -version: 0.3.0.0 +version: 0.4.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. @@ -27,15 +27,17 @@ copyright: 2019 Adam Conner-Sax category: Text extra-source-files: ChangeLog.md -tested-with: GHC ==8.6.4 || ==8.6.2 +tested-with: GHC ==8.6.4 Build-type: Simple source-repository head Type: git Location: https://github.com/adamConnerSax/knit-haskell - + + + library - ghc-options: -Wall -fno-warn-unused-top-binds -funbox-strict-fields + ghc-options: -Wall -fplugin=Polysemy.Plugin -fno-warn-unused-top-binds -funbox-strict-fields exposed-modules: Knit.Effect.Logger , Knit.Effect.Docs , Knit.Effect.Html @@ -81,8 +83,9 @@ hvega >= 0.1.0 && <= 0.2.0.0, logging-effect >= 1.3.3 && < 1.4, mtl >= 2.2.2 && < 2.3, - polysemy >= 0.1.2.0 && < 0.2.0.0, - prettyprinter >= 1.2.1 && < 1.3, + polysemy >= 0.2.0.0 && < 0.3.0.0, + polysemy-plugin >= 0.2.0.0 && < 0.3.0.0, + prettyprinter >= 1.2.1 && < 1.4, lucid >= 2.9.11 && < 2.10, pandoc >= 2.7.2 && < 2.8, random-fu >= 0.2.7 && < 0.3, @@ -93,22 +96,23 @@ default-language: Haskell2010 -executable SimpleExample +test-suite SimpleExample + type: exitcode-stdio-1.0 main-is: SimpleExample.hs hs-source-dirs: examples - ghc-options: -Wall + ghc-options: -Wall build-depends: base, blaze-html, containers, here >= 1.2.10 && < 1.3.0, hvega, knit-haskell -any, - plots, polysemy, text default-language: Haskell2010 -executable ErrorExample +test-suite ErrorExample + type: exitcode-stdio-1.0 main-is: ErrorExample.hs hs-source-dirs: examples ghc-options: -Wall @@ -122,7 +126,8 @@ text default-language: Haskell2010 -executable MultiDocExample +test-suite MultiDocExample + type: exitcode-stdio-1.0 main-is: MultiDocExample.hs hs-source-dirs: examples ghc-options: -Wall @@ -136,7 +141,8 @@ text default-language: Haskell2010 -executable MtlExample +test-suite MtlExample + type: exitcode-stdio-1.0 main-is: MtlExample.hs hs-source-dirs: examples ghc-options: -Wall @@ -151,7 +157,8 @@ text default-language: Haskell2010 -executable RandomExample +test-suite RandomExample + type: exitcode-stdio-1.0 main-is: RandomExample.hs hs-source-dirs: examples ghc-options: -Wall @@ -165,5 +172,6 @@ mtl, polysemy, random-fu, + random-source, text default-language: Haskell2010 diff --git a/src/Knit/Effect/Pandoc.hs b/src/Knit/Effect/Pandoc.hs --- a/src/Knit/Effect/Pandoc.hs +++ b/src/Knit/Effect/Pandoc.hs @@ -228,7 +228,8 @@ -> P.Sem (P.Writer PandocWithRequirements ': effs) a toWriter = P.reinterpret $ \case (AddFrom rf ro x) -> - P.raise (fmap justDoc $ toPandoc rf ro x) >>= P.tell @PandocWithRequirements + P.raise (fmap justDoc $ PM.absorbPandocMonad $ toPandoc rf ro x) + >>= P.tell @PandocWithRequirements (Require r) -> P.tell (justRequirement r) -- | Run ToPandoc by interpreting in Writer and then running that Writer. @@ -277,7 +278,8 @@ -> P.Sem (Pandocs ': effs) () -- ^ effects stack to be (partially) run to get documents -> P.Sem effs [NamedDoc a] -- ^ documents in requested format, within the effects monad pandocsToNamed pwf pwo = - (traverse (namedPandocFrom pwf pwo) =<<) . toNamedDocList + (traverse (\x -> PM.absorbPandocMonad $ namedPandocFrom pwf pwo x) =<<) + . toNamedDocList -- | Given a write format and options, run the writer-style ToPandoc effect and produce a doc of requested type fromPandocE @@ -286,5 +288,8 @@ -> PA.WriterOptions -- ^ options for the Pandoc Writer -> P.Sem (ToPandoc ': effs) () -- ^ effects stack to be (partially) run to get document -> P.Sem effs a -- ^ document in requested format, within the effects monad -fromPandocE pwf pwo = ((fromPandoc pwf pwo . fst) =<<) . P.runWriter . toWriter +fromPandocE pwf pwo = + (((\x -> PM.absorbPandocMonad $ fromPandoc pwf pwo x) . fst) =<<) + . P.runWriter + . toWriter diff --git a/src/Knit/Effect/PandocMonad.hs b/src/Knit/Effect/PandocMonad.hs --- a/src/Knit/Effect/PandocMonad.hs +++ b/src/Knit/Effect/PandocMonad.hs @@ -16,6 +16,7 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -fwarn-incomplete-patterns #-} {-| Module : Knit.Effect.PandocMonad @@ -26,10 +27,9 @@ 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. +Allows a polysemy monad to handle functions +actions with a PandocMonad contraint via +polysemy effects and IO. -} module Knit.Effect.PandocMonad ( @@ -65,6 +65,9 @@ -- * Runners , runIO + -- * Interop + , absorbPandocMonad + -- * Re-Exports , PA.PandocError ) @@ -73,14 +76,12 @@ 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 @@ -151,11 +152,6 @@ P.makeSem ''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.Sem effs) where - throwError = P.throw - catchError = P.catch -- we handle logging within the existing effect system -- | Map pandoc severities to our logging system. @@ -179,26 +175,43 @@ , 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.Sem 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 +-- | Unexported newtype for creating instances which we then discharge with absorbPandocMonad +newtype PandocMonadSem r a = PandocMonadSem { unPandocMonadSem :: P.Sem r a } deriving (Functor, Applicative, Monad) + +instance (P.Member (P.Error PA.PandocError) r) => MonadError PA.PandocError (PandocMonadSem r) where + throwError = PandocMonadSem . P.throw + catchError (PandocMonadSem sa) h = PandocMonadSem $ P.catch sa (unPandocMonadSem . h) + +instance (P.Member (P.Error PA.PandocError) r, PandocEffects r) => PA.PandocMonad (PandocMonadSem r) where + lookupEnv = PandocMonadSem . lookupEnv + getCurrentTime = PandocMonadSem $ getCurrentTime + getCurrentTimeZone = PandocMonadSem $ getCurrentTimeZone + newStdGen = PandocMonadSem $ newStdGen + newUniqueHash = PandocMonadSem $ newUniqueHash + openURL = PandocMonadSem . openURL + readFileLazy = PandocMonadSem . readFileLazy + readFileStrict = PandocMonadSem . readFileStrict + glob = PandocMonadSem . glob + fileExists = PandocMonadSem . fileExists + getDataFileName = PandocMonadSem . getDataFileName + getModificationTime = PandocMonadSem . getModificationTime + getCommonState = PandocMonadSem $ getCommonState + putCommonState = PandocMonadSem . putCommonState + getsCommonState = PandocMonadSem . getsCommonState + modifyCommonState = PandocMonadSem . modifyCommonState + logOutput = PandocMonadSem . logOutput + trace = PandocMonadSem . trace + + +{- | Given an action constrained only by a PandocMonad constraint, +absorb it into a Polysemy monad whose +effect list contains the required effects. +-} +absorbPandocMonad + :: (P.Member (P.Error PA.PandocError) r, PandocEffects r) + => (forall m . PA.PandocMonad m => m a) + -> P.Sem r a +absorbPandocMonad = unPandocMonadSem -- | Constraint helper for using this set of effects in IO. diff --git a/src/Knit/Effect/RandomFu.hs b/src/Knit/Effect/RandomFu.hs --- a/src/Knit/Effect/RandomFu.hs +++ b/src/Knit/Effect/RandomFu.hs @@ -11,6 +11,9 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fwarn-incomplete-patterns #-} {-| Module : Knit.Effect.RandomFu @@ -31,16 +34,22 @@ module Knit.Effect.RandomFu ( -- * Effect - Random + RandomFu -- * Actions , sampleRVar , sampleDist -- * Interpretations - , runRandomIOSimple - , runRandomIOPureMT - , runRandomFromSource + , runRandomFuIOSimple + , runRandomFuIOPureMT + , runRandomFuFromSource + + -- * Interop + , absorbMonadRandom + + -- * Deprecated, will be removed in next release + , Random ) where @@ -53,63 +62,78 @@ import qualified Data.Random.Internal.Source as R import qualified Data.Random.Source.PureMT as R - import Control.Monad.IO.Class ( MonadIO(..) ) +--import Data.Kind ( Constraint ) + -- | Random Effect -data Random m r where - SampleRVar :: R.RVar t -> Random m t - GetRandomPrim :: R.Prim t -> Random m t +data RandomFu m r where + SampleRVar :: R.RVar t -> RandomFu m t + GetRandomPrim :: R.Prim t -> RandomFu m t +type Random = RandomFu +{-# DEPRECATED Random "Use RandomFu instead" #-} + -- | Convert a random-fu RVar to the Random Effect -sampleRVar :: (P.Member Random effs) => R.RVar t -> P.Sem effs t +sampleRVar :: (P.Member RandomFu effs) => R.RVar t -> P.Sem 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.Sem effs t +sampleDist + :: (P.Member RandomFu effs, R.Distribution d t) => d t -> P.Sem effs t sampleDist = sampleRVar . R.rvar -getRandomPrim :: P.Member Random effs => R.Prim t -> P.Sem effs t +getRandomPrim :: P.Member RandomFu effs => R.Prim t -> P.Sem effs t getRandomPrim = send . GetRandomPrim -- | Run in IO using default random-fu IO source -runRandomIOSimple +runRandomFuIOSimple :: forall effs a . MonadIO (P.Sem effs) - => P.Sem (Random ': effs) a + => P.Sem (RandomFu ': effs) a -> P.Sem effs a -runRandomIOSimple = P.interpret f +runRandomFuIOSimple = P.interpret f where - f :: forall m x . (Random m x -> P.Sem effs x) + f :: forall m x . (RandomFu m x -> P.Sem 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 +runRandomFuFromSource :: forall s effs a . R.RandomSource (P.Sem effs) s => s - -> P.Sem (Random ': effs) a + -> P.Sem (RandomFu ': effs) a -> P.Sem effs a -runRandomFromSource source = P.interpret f +runRandomFuFromSource source = P.interpret f where - f :: forall m x . (Random m x -> P.Sem effs x) + f :: forall m x . (RandomFu m x -> P.Sem 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 +runRandomFuIOPureMT :: MonadIO (P.Sem effs) => R.PureMT - -> P.Sem (Random ': effs) a + -> P.Sem (RandomFu ': effs) a -> P.Sem effs a -runRandomIOPureMT source re = - liftIO (newIORef source) >>= flip runRandomFromSource re +runRandomFuIOPureMT source re = + liftIO (newIORef source) >>= flip runRandomFuFromSource re --- | supply instance of MonadRandom for functions which require it +newtype RandomFuSem r a = RandomFuSem { unRandomFuSem :: P.Sem r a } deriving (Functor, Applicative, Monad) + $(R.monadRandom [d| - instance P.Member Random effs => R.MonadRandom (P.Sem effs) where - getRandomPrim = getRandomPrim + instance P.Member RandomFu r => R.MonadRandom (RandomFuSem r) where + getRandomPrim = RandomFuSem . getRandomPrim |]) + +{- | Given a function that uses the random-fu package and produces a result thusly +constrained by 'MonadRandom', absorb it into a Polysemy monad whose +effect list contains the RandomFu effect. +-} +absorbMonadRandom + :: P.Member RandomFu r => (forall m . R.MonadRandom m => m a) -> P.Sem r a +absorbMonadRandom = unRandomFuSem + diff --git a/src/Knit/Report.hs b/src/Knit/Report.hs --- a/src/Knit/Report.hs +++ b/src/Knit/Report.hs @@ -173,7 +173,7 @@ -- | Throw an error with a specific message. This will emerge as a 'PandocSomeError' in order -- to avoid complicating the error type. -- NB: The Member constraint is satisfied by KnitEffectStack m. -knitError :: P.Member (PE.Error PA.PandocError) r => T.Text -> P.Sem r () +knitError :: P.Member (PE.Error PA.PandocError) r => T.Text -> P.Sem r a knitError msg = PE.throw (PA.PandocSomeError $ "Knit User Error: " ++ T.unpack msg) diff --git a/src/Knit/Report/Input/Table/Colonnade.hs b/src/Knit/Report/Input/Table/Colonnade.hs --- a/src/Knit/Report/Input/Table/Colonnade.hs +++ b/src/Knit/Report/Input/Table/Colonnade.hs @@ -29,7 +29,6 @@ ) where - import qualified Colonnade as C import Colonnade import qualified Text.Blaze.Colonnade as BC diff --git a/src/Knit/Report/Output/Html.hs b/src/Knit/Report/Output/Html.hs --- a/src/Knit/Report/Output/Html.hs +++ b/src/Knit/Report/Output/Html.hs @@ -92,7 +92,7 @@ => PandocWriterConfig -> PE.PandocWithRequirements -- ^ Document and union of input requirements -> P.Sem effs BH.Html -toBlazeDocument writeConfig pdocWR = do +toBlazeDocument writeConfig pdocWR = PM.absorbPandocMonad $ do writerOptions <- htmlFullDocWriterOptions (templateFP writeConfig) (templateVars writeConfig) PE.fromPandoc PE.WriteHtml5 (optionsF writeConfig writerOptions) pdocWR