    {-# LANGUAGE CPP                #-}
    {-# LANGUAGE DeriveDataTypeable #-}
    {-# LANGUAGE RecordWildCards    #-}
    {-| The \"markdown\" splice formats markdown content as HTML and inserts
    it into the document.

    If the file attribute is present the contents of the tag is ignored and
    the file specified is converted to HTML.

    Otherwise the non-markup children of the tag are processed as markdown
    and converted to HTML.

    This splice requires that the \"pandoc\" executable is in your path.

    You can add custom pandoc splice with 'pandocSplice'. It is not limited to
    markdown input, and can process anything pandoc can.

    For example you can create a page with generated table of contents, using
    heist template as pandoc template.

    >  <!-- _wrap.tpl -->
    >  <html>
    >    <head> <title> <pageTitle/> </title> </head>
    >
    >    <div class="nav"> <pageToc/> </div>
    >    <apply-content/>
    >  </html>

    And pandoc template, which would bind @pageTitle@ and @pageToc@ splices and
    applies "_wrap" template.

    >  <!-- _pandoc.tpl -->
    >  <apply template="_wrap.tpl">
    >    <bind tag="pageTitle"> $title$</bind>
    >    <bind tag="pageToc"> $toc$</bind>
    >    $body$
    >  </apply>

    Bind splice pandoc splice. Set it to not wrap in div, or it will break html
    from _wrap.tpl

    >  splices = "docmarkdown" ## pandocSplice opts
    >    where
    >      opts = setPandocArgs  ["-S", "--no-wrap", "--toc"
    >                            , "--standalone"
    >                            , "--template", "_pandoc.tpl"
    >                            , "--html5"]
    >             $ setPandocWrapDiv Nothing
    >             $ defaultPandocOptions
    >

    And then use it to render your markdown file

    >  <!-- apidocs.tpl -->
    >  <DOCTYPE html>
    >  <html lang="en">
    >  <head>
    >    <link href="/static/css/site.css rel="stylesheet">
    >  </head>
    >  <body>
    >    <apply template="_navbar.tpl" />
    >    <docmarkdown file="apidocs.md"/>
    >  </body>

    -}
    module Heist.Splices.Markdown
      (
      -- * Exceptions
        PandocMissingException
      , MarkdownException
      , NoMarkdownFileException
      -- * Markdown Splice
      , markdownTag
      , markdownSplice
      -- * Generic pandoc splice
      , pandocSplice
      -- ** Pandoc Options
      , PandocOptions
      , defaultPandocOptions
      , setPandocExecutable
      , setPandocArgs
      , setPandocBaseDir
      , setPandocWrapDiv
      -- ** Lens for 'PandocOptions'
      , pandocExecutable
      , pandocArgs
      , pandocBaseDir
      , pandocWrapDiv
      ) where

    ------------------------------------------------------------------------------
    import           Control.Concurrent
    import           Control.Exception.Lifted
    import           Control.Monad
    import           Control.Monad.Trans
    import           Data.ByteString                 (ByteString)
    import qualified Data.ByteString                 as B
    import qualified Data.ByteString.Char8           as BC
    import           Data.Maybe                      (fromMaybe)
    import           Data.Text                       (Text)
    import qualified Data.Text                       as T
    import qualified Data.Text.Encoding              as T
    import           Data.Typeable
    import           System.Directory
    import           System.Exit
    import           System.FilePath.Posix
    import           System.IO
    import           System.Process
    import           Text.XmlHtml

    #if !MIN_VERSION_base(4,8,0)
    import           Control.Applicative             ((<$>))
    #endif

    ------------------------------------------------------------------------------
    import           Heist.Common
    import           Heist.Internal.Types.HeistState
    import           Heist.Interpreted.Internal

    data PandocMissingException = PandocMissingException
       deriving (Typeable)

    instance Show PandocMissingException where
        show :: PandocMissingException -> String
    show PandocMissingException
    PandocMissingException =
            String
    "Cannot find the \"pandoc\" executable.  If you have Haskell, then install it with \"cabal install\".  Otherwise you can download it from http://johnmacfarlane.net/pandoc/installing.html.  Then make sure it is in your $PATH."

    instance Exception PandocMissingException

    data MarkdownException = MarkdownException ByteString
       deriving (Typeable)

    instance Show MarkdownException where
        show :: MarkdownException -> String
    show (MarkdownException ByteString
    e) =
            String
    "Markdown error: pandoc replied:\n\n" String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ ByteString -> String
    BC.unpack ByteString
    e

    instance Exception MarkdownException

    data NoMarkdownFileException = NoMarkdownFileException
        deriving (Typeable)

    instance Show NoMarkdownFileException where
        show :: NoMarkdownFileException -> String
    show NoMarkdownFileException
    NoMarkdownFileException =
            String
    "Markdown error: no file or template in context" String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++
            String
    " during processing of markdown tag"

    instance Exception NoMarkdownFileException where

    --------------------------------------------------------------------------------

    data PandocOptions = PandocOptions
         { PandocOptions -> String
    _pandocExecutable :: FilePath
         , PandocOptions -> [String]
    _pandocArgs       :: [String]         -- ^ Arguments to pandoc
         , PandocOptions -> Maybe String
    _pandocBaseDir    :: Maybe FilePath   -- ^ Base directory for input files
                                                 --   defaults to template path
         , PandocOptions -> Maybe Text
    _pandocWrapDiv    :: Maybe Text       -- ^ Wrap content in div with class
         } deriving (PandocOptions -> PandocOptions -> Bool
    (PandocOptions -> PandocOptions -> Bool)
    -> (PandocOptions -> PandocOptions -> Bool) -> Eq PandocOptions
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    $c== :: PandocOptions -> PandocOptions -> Bool
    == :: PandocOptions -> PandocOptions -> Bool
    $c/= :: PandocOptions -> PandocOptions -> Bool
    /= :: PandocOptions -> PandocOptions -> Bool
    Eq, Eq PandocOptions
    Eq PandocOptions =>
    (PandocOptions -> PandocOptions -> Ordering)
    -> (PandocOptions -> PandocOptions -> Bool)
    -> (PandocOptions -> PandocOptions -> Bool)
    -> (PandocOptions -> PandocOptions -> Bool)
    -> (PandocOptions -> PandocOptions -> Bool)
    -> (PandocOptions -> PandocOptions -> PandocOptions)
    -> (PandocOptions -> PandocOptions -> PandocOptions)
    -> Ord PandocOptions
    PandocOptions -> PandocOptions -> Bool
    PandocOptions -> PandocOptions -> Ordering
    PandocOptions -> PandocOptions -> PandocOptions
    forall a.
    Eq a =>
    (a -> a -> Ordering)
    -> (a -> a -> Bool)
    -> (a -> a -> Bool)
    -> (a -> a -> Bool)
    -> (a -> a -> Bool)
    -> (a -> a -> a)
    -> (a -> a -> a)
    -> Ord a
    $ccompare :: PandocOptions -> PandocOptions -> Ordering
    compare :: PandocOptions -> PandocOptions -> Ordering
    $c< :: PandocOptions -> PandocOptions -> Bool
    < :: PandocOptions -> PandocOptions -> Bool
    $c<= :: PandocOptions -> PandocOptions -> Bool
    <= :: PandocOptions -> PandocOptions -> Bool
    $c> :: PandocOptions -> PandocOptions -> Bool
    > :: PandocOptions -> PandocOptions -> Bool
    $c>= :: PandocOptions -> PandocOptions -> Bool
    >= :: PandocOptions -> PandocOptions -> Bool
    $cmax :: PandocOptions -> PandocOptions -> PandocOptions
    max :: PandocOptions -> PandocOptions -> PandocOptions
    $cmin :: PandocOptions -> PandocOptions -> PandocOptions
    min :: PandocOptions -> PandocOptions -> PandocOptions
    Ord, Int -> PandocOptions -> ShowS
    [PandocOptions] -> ShowS
    PandocOptions -> String
    (Int -> PandocOptions -> ShowS)
    -> (PandocOptions -> String)
    -> ([PandocOptions] -> ShowS)
    -> Show PandocOptions
    forall a.
    (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
    $cshowsPrec :: Int -> PandocOptions -> ShowS
    showsPrec :: Int -> PandocOptions -> ShowS
    $cshow :: PandocOptions -> String
    show :: PandocOptions -> String
    $cshowList :: [PandocOptions] -> ShowS
    showList :: [PandocOptions] -> ShowS
    Show)

    -- | Default options
    defaultPandocOptions :: PandocOptions
    defaultPandocOptions :: PandocOptions
    defaultPandocOptions = String -> [String] -> Maybe String -> Maybe Text -> PandocOptions
    PandocOptions String
    "pandoc"
                                         []
                                         Maybe String
    forall a. Maybe a
    Nothing
                                         (Text -> Maybe Text
    forall a. a -> Maybe a
    Just Text
    "markdown")

    -- | Name of pandoc executable
    setPandocExecutable :: FilePath -> PandocOptions -> PandocOptions
    setPandocExecutable :: String -> PandocOptions -> PandocOptions
    setPandocExecutable String
    e PandocOptions
    opt = PandocOptions
    opt { _pandocExecutable = e }

    -- | Arguments passed to pandoc
    setPandocArgs :: [String] -> PandocOptions -> PandocOptions
    setPandocArgs :: [String] -> PandocOptions -> PandocOptions
    setPandocArgs [String]
    args PandocOptions
    opt = PandocOptions
    opt { _pandocArgs = args }

    -- | Base directory for input files, defaults to current template dir
    setPandocBaseDir :: Maybe FilePath -> PandocOptions -> PandocOptions
    setPandocBaseDir :: Maybe String -> PandocOptions -> PandocOptions
    setPandocBaseDir Maybe String
    bd PandocOptions
    opt = PandocOptions
    opt { _pandocBaseDir = bd }

    -- | Wrap pandoc output in div with class. Appends node attributes to
    --   div and appends class to ones specified on node.
    setPandocWrapDiv :: Maybe Text -> PandocOptions -> PandocOptions
    setPandocWrapDiv :: Maybe Text -> PandocOptions -> PandocOptions
    setPandocWrapDiv Maybe Text
    wd PandocOptions
    opt = PandocOptions
    opt { _pandocWrapDiv = wd }

    pandocExecutable :: Functor f =>
         (FilePath -> f FilePath) -> PandocOptions -> f PandocOptions
    pandocExecutable :: forall (f :: * -> *).
    Functor f =>
    (String -> f String) -> PandocOptions -> f PandocOptions
    pandocExecutable String -> f String
    f PandocOptions
    po = (\String
    e -> PandocOptions
    po { _pandocExecutable = e})
                           (String -> PandocOptions) -> f String -> f PandocOptions
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> String -> f String
    f (PandocOptions -> String
    _pandocExecutable PandocOptions
    po)

    pandocArgs :: Functor f =>
         ([String] -> f [String]) -> PandocOptions -> f PandocOptions
    pandocArgs :: forall (f :: * -> *).
    Functor f =>
    ([String] -> f [String]) -> PandocOptions -> f PandocOptions
    pandocArgs [String] -> f [String]
    f PandocOptions
    po = (\[String]
    a -> PandocOptions
    po { _pandocArgs = a}) ([String] -> PandocOptions) -> f [String] -> f PandocOptions
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> [String] -> f [String]
    f (PandocOptions -> [String]
    _pandocArgs PandocOptions
    po)

    pandocBaseDir :: Functor f =>
         (Maybe FilePath -> f (Maybe FilePath)) -> PandocOptions -> f PandocOptions
    pandocBaseDir :: forall (f :: * -> *).
    Functor f =>
    (Maybe String -> f (Maybe String))
    -> PandocOptions -> f PandocOptions
    pandocBaseDir Maybe String -> f (Maybe String)
    f PandocOptions
    po = (\Maybe String
    b -> PandocOptions
    po {_pandocBaseDir = b }) (Maybe String -> PandocOptions)
    -> f (Maybe String) -> f PandocOptions
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Maybe String -> f (Maybe String)
    f (PandocOptions -> Maybe String
    _pandocBaseDir PandocOptions
    po)

    pandocWrapDiv :: Functor f =>
         (Maybe Text -> f (Maybe Text)) -> PandocOptions -> f PandocOptions
    pandocWrapDiv :: forall (f :: * -> *).
    Functor f =>
    (Maybe Text -> f (Maybe Text)) -> PandocOptions -> f PandocOptions
    pandocWrapDiv Maybe Text -> f (Maybe Text)
    f PandocOptions
    po = (\Maybe Text
    w -> PandocOptions
    po {_pandocWrapDiv = w}) (Maybe Text -> PandocOptions) -> f (Maybe Text) -> f PandocOptions
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Maybe Text -> f (Maybe Text)
    f (PandocOptions -> Maybe Text
    _pandocWrapDiv PandocOptions
    po)

    ------------------------------------------------------------------------------
    -- | Default name for the markdown splice.
    markdownTag :: Text
    markdownTag :: Text
    markdownTag = Text
    "markdown"

    ------------------------------------------------------------------------------
    -- | Default markdown splice with executable "pandoc"
    markdownSplice :: MonadIO m => Splice m
    markdownSplice :: forall (m :: * -> *). MonadIO m => Splice m
    markdownSplice= PandocOptions -> Splice m
    forall (m :: * -> *). MonadIO m => PandocOptions -> Splice m
    pandocSplice PandocOptions
    defaultPandocOptions

    -- | Implementation of the markdown splice.
    pandocSplice :: MonadIO m => PandocOptions -> Splice m
    pandocSplice :: forall (m :: * -> *). MonadIO m => PandocOptions -> Splice m
    pandocSplice PandocOptions{String
    [String]
    Maybe String
    Maybe Text
    _pandocExecutable :: PandocOptions -> String
    _pandocArgs :: PandocOptions -> [String]
    _pandocBaseDir :: PandocOptions -> Maybe String
    _pandocWrapDiv :: PandocOptions -> Maybe Text
    _pandocExecutable :: String
    _pandocArgs :: [String]
    _pandocBaseDir :: Maybe String
    _pandocWrapDiv :: Maybe Text
    ..} = do
        templateDir <- (Maybe String -> Maybe String)
    -> HeistT m m (Maybe String) -> HeistT m m (Maybe String)
    forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
    liftM (ShowS -> Maybe String -> Maybe String
    forall a b. (a -> b) -> Maybe a -> Maybe b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap ShowS
    takeDirectory) HeistT m m (Maybe String)
    forall (m :: * -> *) (n :: * -> *).
    Monad m =>
    HeistT n m (Maybe String)
    getTemplateFilePath
        pdMD <- liftIO $ findExecutable _pandocExecutable

        pandocExe <- case pdMD of
           Maybe String
    Nothing -> IO String -> HeistT m m String
    forall a. IO a -> HeistT m m a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO String -> HeistT m m String) -> IO String -> HeistT m m String
    forall a b. (a -> b) -> a -> b
    $ PandocMissingException -> IO String
    forall (m :: * -> *) e a. (MonadBase IO m, Exception e) => e -> m a
    throwIO PandocMissingException
    PandocMissingException
           Just String
    pd -> String -> HeistT m m String
    forall a. a -> HeistT m m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return String
    pd
        let withDir String
    tp = String -> Maybe String -> String
    forall a. a -> Maybe a -> a
    fromMaybe String
    tp Maybe String
    _pandocBaseDir
            pandocFile String
    f String
    tp = String -> [String] -> String -> String -> IO ByteString
    pandocWith String
    pandocExe [String]
    _pandocArgs (ShowS
    withDir String
    tp) String
    f
        tree <- getParamNode
        (source,markup) <- liftIO $
            case getAttribute "file" tree of
                Just Text
    f  -> do
                    m <- IO ByteString
    -> (String -> IO ByteString) -> Maybe String -> IO ByteString
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe (IO ByteString -> IO ByteString
    forall a. IO a -> IO a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO ByteString -> IO ByteString) -> IO ByteString -> IO ByteString
    forall a b. (a -> b) -> a -> b
    $ NoMarkdownFileException -> IO ByteString
    forall (m :: * -> *) e a. (MonadBase IO m, Exception e) => e -> m a
    throwIO NoMarkdownFileException
    NoMarkdownFileException )
                               (String -> String -> IO ByteString
    pandocFile (Text -> String
    T.unpack Text
    f))
                               Maybe String
    templateDir
                    return (T.unpack f,m)
                Maybe Text
    Nothing -> do
                    m <- String -> [String] -> ByteString -> IO ByteString
    pandocWithBS String
    pandocExe [String]
    _pandocArgs (ByteString -> IO ByteString) -> ByteString -> IO ByteString
    forall a b. (a -> b) -> a -> b
    $ Text -> ByteString
    T.encodeUtf8 (Text -> ByteString) -> Text -> ByteString
    forall a b. (a -> b) -> a -> b
    $ Node -> Text
    nodeText Node
    tree
                    return ("inline_splice",m)

        let ee = String -> ByteString -> Either String Document
    parseHTML String
    source ByteString
    markup
            nodeAttrs = case Node
    tree of
              Element Text
    _ [(Text, Text)]
    a Template
    _ -> [(Text, Text)]
    a
              Node
    _ -> []
            nodeClass = Text -> [(Text, Text)] -> Maybe Text
    forall a b. Eq a => a -> [(a, b)] -> Maybe b
    lookup Text
    "class" [(Text, Text)]
    nodeAttrs
            attrs = ((Text, Text) -> Bool) -> [(Text, Text)] -> [(Text, Text)]
    forall a. (a -> Bool) -> [a] -> [a]
    filter (\(Text
    name, Text
    _) -> Text
    name Text -> Text -> Bool
    forall a. Eq a => a -> a -> Bool
    /= Text
    "class" Bool -> Bool -> Bool
    && Text
    name Text -> Text -> Bool
    forall a. Eq a => a -> a -> Bool
    /= Text
    "file") [(Text, Text)]
    nodeAttrs
        case ee of
          Left String
    e  -> MarkdownException -> HeistT m m Template
    forall a e. (HasCallStack, Exception e) => e -> a
    throw (MarkdownException -> HeistT m m Template)
    -> MarkdownException -> HeistT m m Template
    forall a b. (a -> b) -> a -> b
    $ ByteString -> MarkdownException
    MarkdownException
                           (ByteString -> MarkdownException)
    -> ByteString -> MarkdownException
    forall a b. (a -> b) -> a -> b
    $ String -> ByteString
    BC.pack (String
    "Error parsing markdown output: " String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    e)
          Right Document
    d -> Template -> HeistT m m Template
    forall a. a -> HeistT m m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Template -> HeistT m m Template)
    -> Template -> HeistT m m Template
    forall a b. (a -> b) -> a -> b
    $ Maybe Text -> [(Text, Text)] -> Template -> Template
    wrapResult Maybe Text
    nodeClass [(Text, Text)]
    attrs (Document -> Template
    docContent Document
    d)

      where
        wrapResult :: Maybe Text -> [(Text, Text)] -> Template -> Template
    wrapResult Maybe Text
    nodeClass [(Text, Text)]
    attrs Template
    body = case Maybe Text
    _pandocWrapDiv of
            Maybe Text
    Nothing -> Template
    body
            Just Text
    cls -> let finalAttrs :: [(Text, Text)]
    finalAttrs = (Text
    "class", Maybe Text -> Text -> Text
    appendClass Maybe Text
    nodeClass Text
    cls)(Text, Text) -> [(Text, Text)] -> [(Text, Text)]
    forall a. a -> [a] -> [a]
    :[(Text, Text)]
    attrs
                        in [Text -> [(Text, Text)] -> Template -> Node
    Element Text
    "div" [(Text, Text)]
    finalAttrs  Template
    body]
        appendClass :: Maybe Text -> Text -> Text
    appendClass Maybe Text
    Nothing Text
    cls = Text
    cls
        appendClass (Just Text
    orig) Text
    cls = [Text] -> Text
    T.concat [Text
    orig, Text
    " ", Text
    cls]

    pandocWith :: FilePath -> [String] -> FilePath -> FilePath -> IO ByteString
    pandocWith :: String -> [String] -> String -> String -> IO ByteString
    pandocWith String
    path [String]
    args String
    templateDir String
    inputFile = do
        (ex, sout, serr) <- String
    -> [String] -> ByteString -> IO (ExitCode, ByteString, ByteString)
    readProcessWithExitCode' String
    path [String]
    args' ByteString
    ""

        when (isFail ex) $ throw $ MarkdownException serr
        return sout

      where
        isFail :: ExitCode -> Bool
    isFail ExitCode
    ExitSuccess = Bool
    False
        isFail ExitCode
    _           = Bool
    True

        args' :: [String]
    args' = [String]
    args [String] -> [String] -> [String]
    forall a. [a] -> [a] -> [a]
    ++ [String
    templateDir String -> ShowS
    </> String
    inputFile ]

    pandocWithBS :: FilePath -> [String] -> ByteString -> IO ByteString
    pandocWithBS :: String -> [String] -> ByteString -> IO ByteString
    pandocWithBS String
    pandocPath [String]
    args ByteString
    s = do
        -- using the crummy string functions for convenience here
        (ex, sout, serr) <- String
    -> [String] -> ByteString -> IO (ExitCode, ByteString, ByteString)
    readProcessWithExitCode' String
    pandocPath [String]
    args ByteString
    s

        when (isFail ex) $ throw $ MarkdownException serr
        return sout

      where
        isFail :: ExitCode -> Bool
    isFail ExitCode
    ExitSuccess = Bool
    False
        isFail ExitCode
    _           = Bool
    True

    -- a version of readProcessWithExitCode that does I/O properly
    readProcessWithExitCode'
        :: FilePath                 -- ^ command to run
        -> [String]                 -- ^ any arguments
        -> ByteString               -- ^ standard input
        -> IO (ExitCode,ByteString,ByteString) -- ^ exitcode, stdout, stderr
    readProcessWithExitCode' :: String
    -> [String] -> ByteString -> IO (ExitCode, ByteString, ByteString)
    readProcessWithExitCode' String
    cmd [String]
    args ByteString
    input = do
        (Just inh, Just outh, Just errh, pid) <-
            CreateProcess
    -> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
    createProcess (String -> [String] -> CreateProcess
    proc String
    cmd [String]
    args){ std_in  = CreatePipe,
                                           std_out = CreatePipe,
                                           std_err = CreatePipe }
        outMVar <- newEmptyMVar

        outM <- newEmptyMVar
        errM <- newEmptyMVar

        -- fork off a thread to start consuming stdout
        _ <- forkIO $ do
            out <- B.hGetContents outh
            putMVar outM out
            putMVar outMVar ()

        -- fork off a thread to start consuming stderr
        _ <- forkIO $ do
            err  <- B.hGetContents errh
            putMVar errM err
            putMVar outMVar ()

        -- now write and flush any input
        when (not (B.null input)) $ do B.hPutStr inh input; hFlush inh
        hClose inh -- done with stdin

        -- wait on the output
        takeMVar outMVar
        takeMVar outMVar
        hClose outh

        -- wait on the process
        ex <- waitForProcess pid

        out <- readMVar outM
        err <- readMVar errM

        return (ex, out, err)