diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,7 @@ +# Changelog + +## 1.0.0 (2020-03-05) + +#### Added + +- Initial version of all `Html` conversion functions. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Colin Woodbury (c) 2020 + +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 Author name here 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/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,5 @@ +# ord-mode-lucid + +This is a child library of `org-mode` that allows its types to be converted into +`Html` structures from the `lucid` library. This allows one to easily parse and +embed Org content directly into a Lucid-based website. diff --git a/lib/Data/Org/Lucid.hs b/lib/Data/Org/Lucid.hs new file mode 100644 --- /dev/null +++ b/lib/Data/Org/Lucid.hs @@ -0,0 +1,203 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : Data.Org.Lucid +-- Copyright : (c) Colin Woodbury, 2020 +-- License : BSD3 +-- Maintainer: Colin Woodbury +-- +-- This library converts `OrgFile` values into `Html` structures from the Lucid +-- library. This allows one to generate valid, standalone HTML pages from an Org +-- file, but also to inject that HTML into a preexisting Lucid `Html` structure, +-- such as a certain section of a web page. + +module Data.Org.Lucid + ( -- * HTML Conversion + -- | Consider `defaultStyle` as the style to pass to these functions. + html + , body + -- * Styling + , OrgStyle(..) + , defaultStyle + , TOC(..) + ) where + +import Control.Monad (when) +import Data.Foldable (fold, traverse_) +import Data.Hashable (hash) +import Data.List (intersperse) +import Data.List.NonEmpty (NonEmpty(..)) +import qualified Data.List.NonEmpty as NEL +import Data.Org +import qualified Data.Text as T +import Lucid +import Text.Printf (printf) + +-------------------------------------------------------------------------------- +-- HTML Generation + +-- | Rendering options. +data OrgStyle = OrgStyle + { includeTitle :: Bool + -- ^ Whether to include the @#+TITLE: ...@ value as an @

@ tag at the top + -- of the document. + , tableOfContents :: Maybe TOC + -- ^ Optionally include a Table of Contents after the title. The displayed + -- depth is configurable. + , bootstrap :: Bool + -- ^ Whether to add Twitter Bootstrap classes to certain elements. + } + +-- | Options for rendering a Table of Contents in the document. +data TOC = TOC + { tocTitle :: T.Text + -- ^ The text of the TOC to be rendered in an @

@ element. + , tocDepth :: Word + -- ^ The number of levels to give the TOC. + } + +-- | Include the title and 3-level TOC named @Table of Contents@, and don't +-- include Twitter Bootstrap classes. This mirrors the behaviour of Emacs' +-- native HTML export functionality. +defaultStyle :: OrgStyle +defaultStyle = OrgStyle True (Just $ TOC "Table of Contents" 3) False + +-- | Convert a parsed `OrgFile` into a full HTML document readable in a browser. +html :: OrgStyle -> OrgFile -> Html () +html os o@(OrgFile m _) = html_ $ do + head_ $ title_ (maybe "" toHtml $ metaTitle m) + body_ $ body os o + +-- | Convert a parsed `OrgFile` into the body of an HTML document, so that it +-- could be injected into other Lucid `Html` structures. +-- +-- Does __not__ wrap contents in a @\@ tag. +body :: OrgStyle -> OrgFile -> Html () +body os (OrgFile m od) = do + when (includeTitle os) $ traverse_ (h1_ [class_ "title"] . toHtml) $ metaTitle m + traverse_ (`toc` od) $ tableOfContents os + orgHTML os od + +-- | A unique identifier that can be used as an HTML @id@ attribute. +tocLabel :: NonEmpty Words -> T.Text +tocLabel = ("org" <>) . T.pack . take 6 . printf "%x" . hash + +toc :: TOC -> OrgDoc -> Html () +toc _ (OrgDoc _ []) = pure () +toc t od = h2_ (toHtml $ tocTitle t) *> toc' t 1 od + +toc' :: TOC -> Word -> OrgDoc -> Html () +toc' _ _ (OrgDoc _ []) = pure () +toc' t depth (OrgDoc _ ss) + | depth > tocDepth t = pure () + | otherwise = ul_ $ traverse_ f ss + where + f :: Section -> Html () + f (Section ws od) = do + li_ $ a_ [href_ $ "#" <> tocLabel ws] $ lineHTML ws + toc' t (succ depth) od + +orgHTML :: OrgStyle -> OrgDoc -> Html () +orgHTML os = orgHTML' os 1 + +orgHTML' :: OrgStyle -> Int -> OrgDoc -> Html () +orgHTML' os depth (OrgDoc bs ss) = do + traverse_ (blockHTML os) bs + traverse_ (sectionHTML os depth) ss + +sectionHTML :: OrgStyle -> Int -> Section -> Html () +sectionHTML os depth (Section ws od) = do + heading [id_ $ tocLabel ws] $ lineHTML ws + orgHTML' os (succ depth) od + where + heading :: [Attribute] -> Html () -> Html () + heading as h = case depth of + 1 -> h2_ as h + 2 -> h3_ as h + 3 -> h4_ as h + 4 -> h5_ as h + 5 -> h6_ as h + _ -> h + +blockHTML :: OrgStyle -> Block -> Html () +blockHTML os b = case b of + Quote t -> blockquote_ . p_ $ toHtml t + Example t -> pre_ [class_ "example"] $ toHtml t + Code l t -> div_ [class_ "org-src-container"] + $ pre_ [classes_ $ "src" : maybe [] (\(Language l') -> ["src-" <> l']) l] + $ toHtml t + List is -> listItemsHTML is + Table rw -> tableHTML os rw + Paragraph ws -> p_ $ paragraphHTML ws + +paragraphHTML :: NonEmpty Words -> Html () +paragraphHTML (h :| t) = wordsHTML h <> para h t + where + para :: Words -> [Words] -> Html () + para _ [] = "" + para pr (w:ws) = case pr of + Punct '(' -> wordsHTML w <> para w ws + _ -> case w of + Punct '(' -> " " <> wordsHTML w <> para w ws + Punct _ -> wordsHTML w <> para w ws + _ -> " " <> wordsHTML w <> para w ws + +-- | Render a grouping of `Words` that you expect to appear on a single line. +lineHTML :: NonEmpty Words -> Html () +lineHTML = fold . intersperse " " . map wordsHTML . NEL.toList + +listItemsHTML :: ListItems -> Html () +listItemsHTML (ListItems is) = ul_ [class_ "org-ul"] $ traverse_ f is + where + f :: Item -> Html () + f (Item ws next) = li_ $ lineHTML ws >> maybe (pure ()) listItemsHTML next + +tableHTML :: OrgStyle -> NonEmpty Row -> Html () +tableHTML os rs = table_ tblClasses $ do + thead_ headClasses toprow + tbody_ $ traverse_ f rest + where + tblClasses + | bootstrap os = [classes_ ["table", "table-bordered", "table-hover"]] + | otherwise = [] + + headClasses + | bootstrap os = [class_ "thead-dark"] + | otherwise = [] + + toprow = tr_ $ maybe (pure ()) (traverse_ g) h + (h, rest) = j $ NEL.toList rs + + -- | Restructure the input such that the first `Row` is not a `Break`. + j :: [Row] -> (Maybe (NonEmpty Column), [Row]) + j [] = (Nothing, []) + j (Break : r) = j r + j (Row cs : r) = (Just cs, r) + + -- | Potentially render a `Row`. + f :: Row -> Html () + f Break = pure () + f (Row cs) = tr_ $ traverse_ k cs + + -- | Render a header row. + g :: Column -> Html () + g Empty = th_ [scope_ "col"] "" + g (Column ws) = th_ [scope_ "col"] $ lineHTML ws + + -- | Render a normal row. + k :: Column -> Html () + k Empty = td_ "" + k (Column ws) = td_ $ lineHTML ws + +wordsHTML :: Words -> Html () +wordsHTML ws = case ws of + Bold t -> b_ $ toHtml t + Italic t -> i_ $ toHtml t + Highlight t -> code_ $ toHtml t + Underline t -> span_ [style_ "text-decoration: underline;"] $ toHtml t + Verbatim t -> toHtml t + Strike t -> span_ [style_ "text-decoration: line-through;"] $ toHtml t + Link (URL u) mt -> a_ [href_ u] $ maybe "" toHtml mt + Image (URL u) -> img_ [src_ u] + Punct c -> toHtml $ T.singleton c + Plain t -> toHtml t diff --git a/org-mode-lucid.cabal b/org-mode-lucid.cabal new file mode 100644 --- /dev/null +++ b/org-mode-lucid.cabal @@ -0,0 +1,33 @@ +cabal-version: 2.2 +name: org-mode-lucid +version: 1.0.0 +description: Lucid integration for org-mode. +homepage: https://github.com/fosskers/org-mode +author: Colin Woodbury +maintainer: colin@fosskers.ca +copyright: 2020 Colin Woodbury +license: BSD-3-Clause +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + CHANGELOG.md + +common commons + default-language: Haskell2010 + default-extensions: OverloadedStrings + ghc-options: + -Wall -Wpartial-fields -Wincomplete-record-updates + -Wincomplete-uni-patterns -Widentities + + build-depends: + , base >=4.12 && <5 + , hashable >=1.2 && <1.4 + , lucid ^>=2.9 + , org-mode ^>=1.0 + , text + +library + import: commons + hs-source-dirs: lib + exposed-modules: Data.Org.Lucid