Link.hs

{-|

Set of Hakyll rules that facilitate including links to markdown files.

-}

{-# LANGUAGE DeriveDataTypeable         #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE Arrows                     #-}

module Hakyll.Contrib.Markdown.Link
       ( -- * Syntax
         -- $syntax
         Link(..)
       , links
       , toString
       , linksCompiler
       , pageWithLinksCompiler
       , include
       , includeList
       , pageCompilerA, readStatePage
       ) where

import Control.Arrow
import Control.Applicative hiding ((<|>))
import Data.Binary
import Data.Typeable
import Data.Char           (isSpace, isAlphaNum)
import Data.List           (groupBy, isPrefixOf)
import Data.Map            (fromList, union)
import Data.String
import Hakyll.Core.Compiler(getResourceString, Compiler, requireA, cached)
import Hakyll.Core.Identifier(Identifier)
import Hakyll.Core.Resource(Resource)
import Hakyll.Core.Writable(Writable(..))
import Hakyll.Web.Pandoc ( defaultHakyllParserState
                         , defaultHakyllWriterOptions
                         , pageReadPandocWithA
                         , writePandocWith
                         )
import Hakyll.Web.Template(applySelf)
import Hakyll.Web.Page(addDefaultFields, readPageCompiler, Page)
import Text.Pandoc(WriterOptions)
import Text.Pandoc.Parsing(toKey, ParserState(..))
import Text.Pandoc.Definition hiding (Link)
import Text.Parsec.String  (Parser)
import Text.Parsec



-- | The link data type.
data Link = Link { linkRef     :: [String] -- ^ reference to this link
                 , linkUrl     ::  String  -- ^ destination url
                 , linkTitle   :: [String] -- ^ link title string.
                 } deriving (Show, Eq, Typeable)

instance IsString Link where
  fromString s = either err id $ parse linkP "<>" s
        where err e = error $ "bad link:" ++ show e


instance Binary Link where
  put lnk = do put $ linkRef lnk
               put $ linkUrl lnk
               put $ linkTitle lnk
  get     = Link <$> get <*> get <*> get

instance Writable [Link] where
  write fp = write fp . unlines . map toString

-- | Cache name used by this module.
cacheName :: String
cacheName = "Hakyll.Contrib.Markdown.Link"

-- | The Hakyll compiler that reads a list of links.
linksCompiler :: Compiler Resource [Link]
linksCompiler = cached cacheName $ getResourceString >>> arr links

-- | Compiles a pandoc page with a give list of links database.
pageWithLinksCompiler :: [Identifier [Link]] -- ^ The links db's
                      -> Compiler Resource (Page String)
pageWithLinksCompiler = pageWithLinksCompiler' defaultHakyllParserState
                                               defaultHakyllWriterOptions

-- | Similar to `pageWithLinksCompiler` but takes additional parser
-- and writer option.
pageWithLinksCompiler' :: ParserState         -- ^ parser state
                       -> WriterOptions       -- ^ pandoc writer options
                       -> [Identifier [Link]] -- ^ The links db's
                       -> Compiler Resource (Page String)
pageWithLinksCompiler' popts wopts ids = cached cacheName $
      readStatePage popts >>> includeList ids >>> pageCompilerA wopts

-- | A compiler that modified the Pandoc parser state to accomodate a
-- set of link definitions.
include :: Identifier [Link]  -- ^ The link database identifier
        -> Compiler (ParserState,a) (ParserState,a)
include ident = first $ requireA ident $ arr combine
   where combine (ps,lns)= ps { stateKeys = stateKeys ps `union`
                                            toKeyTable lns
                              }
         toKeyTable = fromList . map kvPair
         kvPair (Link r u t) = (toKey $ map Str r, (u, unwords t))


-- | Similar to include but includes a list of link definitions.
includeList :: [Identifier [Link]] -- ^ The list of link database
                                   -- identifiers.
            -> Compiler (ParserState,a) (ParserState, a)

includeList =  foldl1 (>>>) . map include

-- | Tags along a given parser state to the page.
readStatePage :: ParserState
              -> Compiler Resource (ParserState, Page String)
readStatePage pstate = proc res -> do page    <- readPageCompiler -< res
                                      returnA -< (pstate, page)

-- | Compiles a given page with pandoc. The writer option can be
-- configured using its argument.
pageCompilerA :: WriterOptions -- ^ Configure writer options
              -> Compiler (ParserState, Page String) (Page String)
pageCompilerA wopts = second fieldsAndTemplate >>> pageReadPandocWithA >>> writer
   where fieldsAndTemplate = addDefaultFields >>> arr applySelf
         writer    = arr $ fmap $ writePandocWith wopts

-- | Convert the link to string.
toString :: Link -> String
toString lnk = concat [ "[", r, "]"
                      , ": "
                      , "<", linkUrl lnk, ">"
                      , t
                      ]
   where r = unwords $ map escapeRef   $ linkRef   lnk
         t = unwords $ map escapeTitle $ linkTitle lnk


escapeRef :: String -> String
escapeRef = concatMap esc
  where esc c | isAlphaNum c || c `elem` refSpChars = [c]
              | otherwise                           = escapeChar : [c]

escapeTitle :: String -> String
escapeTitle = concatMap esc
  where esc c | isSpace c = escapeChar : [c]
              | otherwise = [c]

-- | Link parser
linkP  :: Parser Link


-- | Convert a parser to a lexeme parser.
lexeme :: Parser a -> Parser a
lexeme p = p <* spaces

-- | An escape char
escape :: Parser Char
escape = char escapeChar >> anyChar

-- | The special characters in references.
refSpChars :: [Char]
refSpChars = "#_-:"

-- | A link reference
ref :: Parser [String]
ref     = many1 refWord <?> "link-reference"
   where refChar = escape <|> alphaNum <|> oneOf refSpChars
         refWord = lexeme $ many1 refChar

-- | A url
url  :: Parser String
url  = lexeme (between langle rangle $ many1 $ noneOf ">")
       <?> "URL"
  where langle  = lexeme $ char '<'
        rangle  = lexeme $ char '>'

-- | A link title
title :: Parser [String]
title = many1 titleWord <?> "link-title"
  where titleChar = escape <|> satisfy (not . isSpace)
        titleWord = lexeme $ many1 titleChar

linkP = Link <$> lref <* colon <*> url <*> option [] title
  where lref    = between lbrack rbrack ref <?> "[link-reference]"
        colon    = lexeme $ char ':'
        lbrack   = lexeme $ char '['
        rbrack   = lexeme $ char ']'


-- $syntax
--
-- We use the markdown syntax to provide links namely
--
-- > [linkname]: <url> Comment
--
-- Multiple lines are folded if the are indented by atleast by a
-- space.  All lines that start with a @'--'@ (two hyphens) are
-- treated as comments and skipped.

-- | Convert a set of lines to links.
links :: String -> [Link]
links = map fromString
      . map combine
      . indent
      . filter (not . commentLine)
      . filter (not . null)
      . lines
  where indent = groupBy (\ _ -> isSpace . head)
        combine []     = []
        combine (x:xs) = concat (x: map tail xs)
        commentLine    = isPrefixOf commentStart

escapeChar   :: Char
commentStart :: String
escapeChar   = '\\'
commentStart = "--"