diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Changelog for compdoc + +# v0.1.0.0 + +* Initial data declaration and parsing functions. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,19 @@ +Copyright (c) 2020 Daniel Firth + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,7 @@ +# Compdoc - Composite Pandoc Format + +Compdoc is an alternative format for reading pandoc markdown data using [composite](https://hackage.haskell.org/package/composite-base) and [composite-aeson](https://hackage.haskell.org/package/composite-aeson). + +Compdoc will read a pandoc markdown file according to the `JsonFormat` that you +supply to parse the metadata, and place the main body in an `FContents` fields +that can be accessed with the lens `view fContent`. diff --git a/compdoc.cabal b/compdoc.cabal new file mode 100644 --- /dev/null +++ b/compdoc.cabal @@ -0,0 +1,40 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.34.2. +-- +-- see: https://github.com/sol/hpack + +name: compdoc +version: 0.1.0.0 +synopsis: Parse a Pandoc to a composite value. +description: Provides a functionality for transforming a Pandoc into a vinyl/composite record. +category: Text +author: Daniel Firth +maintainer: dan.firth@homotopic.tech +copyright: 2020 Daniel Firth +license: MIT +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + ChangeLog.md + +library + exposed-modules: + Text.Compdoc + other-modules: + Paths_compdoc + hs-source-dirs: + src + build-depends: + aeson + , base >=4.7 && <5 + , composite-aeson + , composite-aeson-throw + , composite-base + , pandoc + , pandoc-throw + , path + , rio + , vinyl + default-language: Haskell2010 diff --git a/src/Text/Compdoc.hs b/src/Text/Compdoc.hs new file mode 100644 --- /dev/null +++ b/src/Text/Compdoc.hs @@ -0,0 +1,90 @@ +{- | + Module : Text.Compdoc + License : MIT + Stability : experimental + +Provides functionality for transforming a `Pandoc` into a composite record. +-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeOperators #-} +module Text.Compdoc ( + FContent +, fContent +, Compdoc +, readMarkdown' +, readMarkdownFile +, runPandocPureDefault +, pandocToCompdoc +, contentBlock +, writeBlocksDefault +, flattenMeta +) where + +import Composite.Aeson +import Composite.Aeson.Throw +import Composite.Record +import Composite.TH +import Data.Aeson +import Data.Vinyl ((<+>)) +import Data.Vinyl.TypeLevel +import Path +import RIO +import Text.Pandoc +import Text.Pandoc.Readers +import Text.Pandoc.Throw + +withLensesAndProxies [d| + type FContent = "content" :-> Text + |] + +-- | A Compdoc is a Record with at least an FContent field. +type Compdoc a = a ++ (FContent : '[]) + +-- | Write a list of `Block`s to `Text` using `WriterOptions` defaulting to the empty string +-- in the case of error. +writeBlocksDefault :: WriterOptions -> [Block] -> Text +writeBlocksDefault wopts x = runPandocPureDefault "" (writeHtml5String wopts $ Pandoc mempty x) + +-- | Run a `PandocPure` operation with a default value in the event of failure. +runPandocPureDefault :: a -> PandocPure a -> a +runPandocPureDefault x = either (const x) id . runPure + +-- | Read a markdown file from disk, supplying a `JsonFormat` for the metadata. +readMarkdownFile :: (MonadIO m, MonadThrow m, Show e, Typeable e) + => ReaderOptions + -> WriterOptions + -> JsonFormat e (Record a) + -> Path b File + -> m (Record (Compdoc a)) +readMarkdownFile ropts wopts f srcPath = + readFileUtf8 (toFilePath srcPath) >>= readMarkdown' ropts wopts f + +-- | Read some `Pandoc` markdown as `Text` as a `Record (Compdoc a)` supplying a `JsonFormat` for the metadata. +readMarkdown' :: (Show e, Typeable e, MonadThrow m) => ReaderOptions -> WriterOptions -> JsonFormat e (Record a) -> Text -> m (Record (Compdoc a)) +readMarkdown' ropts wopts f x = runPandocPureThrow (Text.Pandoc.Readers.readMarkdown ropts x) >>= pandocToCompdoc writeHtml5String wopts f + +-- | Transform a `Pandoc` to a `Compdoc` supplying a `JsonFormat for the metadata. +pandocToCompdoc :: (Typeable e, Show e, MonadThrow m) => (WriterOptions -> Pandoc -> PandocPure Text) -> WriterOptions -> JsonFormat e (Record a) -> Pandoc -> m (Record (Compdoc a)) +pandocToCompdoc writer wopts f (Pandoc meta xs) = do + k <- flattenMeta (writer wopts) meta >>= parseValue' f + return $ k <+> contentBlock wopts xs + +-- | Create the tail of a `Compdoc` which is just an `FContent` field. +contentBlock :: WriterOptions -> [Block] -> Record (FContent : '[]) +contentBlock wopts x = writeBlocksDefault wopts x :*: RNil + +-- | Flatten pandoc metadata to an aeson value. +flattenMeta :: MonadThrow m => (Pandoc -> PandocPure Text) -> Meta -> m Value +flattenMeta writer (Meta meta) = toJSON <$> traverse go meta + where + go :: MonadThrow m => MetaValue -> m Value + go (MetaMap m) = toJSON <$> traverse go m + go (MetaList m) = toJSONList <$> traverse go m + go (MetaBool m) = pure $ toJSON m + go (MetaString m) = pure $ toJSON m + go (MetaInlines m) = toJSON <$> (runPandocPureThrow . writer . Pandoc mempty . (:[]) . Plain $ m) + go (MetaBlocks m) = toJSON <$> (runPandocPureThrow . writer . Pandoc mempty $ m)