-- |
-- Module      :  Text.MMark.Extension.Common
-- Copyright   :  © 2017–2018 Mark Karpov
-- License     :  BSD 3 clause
--
-- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>
-- Stability   :  experimental
-- Portability :  portable
--
-- Commonly useful extensions for MMark markdown processor.
--
-- We suggest using a qualified import, like this:
--
-- > import qualified Text.MMark.Extension.Common as Ext
--
-- Here is an example that uses several extensions from this module at the
-- same time, it should give you an idea where to start:
--
-- > {-# LANGUAGE OverloadedStrings #-}
-- >
-- > module Main (main) where
-- >
-- > import Data.Default.Class
-- > import qualified Data.Text.IO                as T
-- > import qualified Data.Text.Lazy.IO           as TL
-- > import qualified Lucid                       as L
-- > import qualified Text.MMark                  as MMark
-- > import qualified Text.MMark.Extension.Common as Ext
-- >
-- > main :: IO ()
-- > main = do
-- >   let input = "input.md"
-- >   txt <- T.readFile input
-- >   case MMark.parse input txt of
-- >     Left errs -> putStrLn (MMark.parseErrorsPretty txt errs)
-- >     Right r ->
-- >       let toc = MMark.runScanner r (Ext.tocScanner 4)
-- >       in TL.writeFile "output.html"
-- >           . L.renderText
-- >           . MMark.render
-- >           . MMark.useExtensions
-- >               [ Ext.toc "toc" toc
-- >               , Ext.punctuationPrettifier def
-- >               , Ext.obfuscateEmail "protected-email"
-- >               , Ext.fontAwesome ]
-- >           $ r

{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric      #-}
{-# LANGUAGE LambdaCase         #-}
{-# LANGUAGE OverloadedStrings  #-}
{-# LANGUAGE RecordWildCards    #-}

module Text.MMark.Extension.Common
  ( -- * Table of contents
    -- $table-of-contents
    Toc
  , tocScanner
  , toc
    -- * Punctuation prettifier
  , Punctuation (..)
  , punctuationPrettifier
    -- * Email address obfuscation
  , obfuscateEmail
    -- * Font Awesome icons
  , fontAwesome )
where

import Data.Data (Data)
import Data.Default.Class
import Data.List.NonEmpty (NonEmpty (..))
import Data.Maybe (maybeToList, fromJust)
import Data.Monoid ((<>))
import Data.Text (Text)
import Data.Typeable (Typeable)
import GHC.Generics
import Lens.Micro ((^.))
import Lucid
import Text.MMark
import Text.MMark.Extension (Bni, Block (..), Inline (..))
import Text.URI.Lens (uriPath)
import qualified Control.Foldl        as L
import qualified Data.List.NonEmpty   as NE
import qualified Data.Text            as T
import qualified Text.MMark.Extension as Ext
import qualified Text.URI             as URI

----------------------------------------------------------------------------
-- Table of contents

-- $table-of-contents
--
-- Place this markup in markdown document where you want table of contents
-- to be inserted:
--
-- > ```toc
-- > ```
--
-- You may use something different than @\"toc\"@ as the info string of the
-- code block.

-- | An opaque type representing table of contents produced by the
-- 'tocScanner' scanner.

newtype Toc = Toc [(Int, NonEmpty Inline)]

-- | The scanner builds table of contents 'Toc' that can then be passed to
-- 'toc' to obtain an extension that renders the table of contents in HTML.
--
-- __Note__: Top level header (level 1) is never added to the table of
-- contents. Open an issue if you think it's not a good behavior.

tocScanner
  :: Int -- ^ Up to which level (inclusive) to collect headers? Values from
         -- 2 to 6 make sense here.
  -> L.Fold Bni Toc
tocScanner cutoff = fmap (Toc . reverse) . Ext.scanner [] $ \xs block ->
  case block of
    Heading2 x -> f 2 x xs
    Heading3 x -> f 3 x xs
    Heading4 x -> f 4 x xs
    Heading5 x -> f 5 x xs
    Heading6 x -> f 6 x xs
    _          -> xs
  where
    f n a as =
      if n > cutoff
        then as
        else (n, a) : as

-- | Create an extension that replaces a certain code block with previously
-- constructed table of contents.

toc
  :: Text -- ^ Label of the code block to replace by the table of contents
  -> Toc  -- ^ Previously generated by 'tocScanner'
  -> Extension
toc label (Toc xs) = Ext.blockTrans $ \case
  old@(CodeBlock mlabel _) ->
    case NE.nonEmpty xs of
      Nothing -> old
      Just ns ->
        if mlabel == pure label
          then renderToc ns
          else old
  other -> other

-- | Construct 'Bni' for a table of contents from given collection of
-- headers. This is a non-public helper.

renderToc :: NonEmpty (Int, NonEmpty Inline) -> Bni
renderToc = UnorderedList . NE.unfoldr f
  where
    f ((n,x) :| xs) =
      let (sitems, fitems) = span ((> n) . fst) xs
          url = Ext.headerFragment (Ext.headerId x)
      in ( Naked (Link x url Nothing :| [])
           : maybeToList (renderToc <$> NE.nonEmpty sitems)
         , NE.nonEmpty fitems )

----------------------------------------------------------------------------
-- Punctuation prettifier

-- | Settings for the punctuation-prettifying extension.

data Punctuation = Punctuation
  { punctEnDash :: !Bool
    -- ^ Whether to replace double hyphen @--@ by an en dash @–@ (default:
    -- 'True')
  , punctEmDash :: !Bool
    -- ^ Whether to replace triple hyphen @---@ by an em dash @—@ (default:
    -- 'True')
  } deriving (Eq, Ord, Show, Read, Data, Typeable, Generic)

instance Default Punctuation where
  def = Punctuation
    { punctEnDash = True
    , punctEmDash = True }

-- | Prettify punctuation according to the settings in 'Punctuation'.

punctuationPrettifier :: Punctuation -> Extension
punctuationPrettifier Punctuation {..} = Ext.inlineTrans $ \case
  Plain txt -> Plain
    . f punctEnDash (T.replace "--"  "–")
    . f punctEmDash (T.replace "---" "—")
    $ txt
  other -> other
  where
    f b g = if b then g else id

----------------------------------------------------------------------------
-- Email address obfuscation

-- | This extension makes email addresses in links be rendered as something
-- like this:
--
-- > <a class="protected-email"
-- >    data-email="something@example.org"
-- >    href="javascript:void(0)">Enable JavaScript to see the email</a>
--
-- You'll also need to include jQuery and this bit of JS code for the magic
-- to work:
--
-- > $(document).ready(function () {
-- >     $(".protected-email").each(function () {
-- >         var item = $(this);
-- >         var email = item.data('email');
-- >         item.attr('href', 'mailto:' + email);
-- >         item.html(email);
-- >     });
-- > });

obfuscateEmail
  :: Text
     -- ^ Name of class to assign to the links, e.g. @\"protected-email\"@
  -> Extension
obfuscateEmail class' = Ext.inlineRender $ \old inline ->
  case inline of
    l@(Link _ email mtitle) ->
      if URI.uriScheme email == URI.mkScheme "mailto"
        then let txt = Plain "Enable JavaScript to see the email" :| []
                 js  = fromJust (URI.mkURI "javascript:void(0)")
             in with (old (Link txt js mtitle))
                  [ class_ class'
                  , data_ "email"
                    (URI.render email { URI.uriScheme = Nothing }) ]
        else old l
    other -> old other

----------------------------------------------------------------------------
-- Font Awesome icons

-- | Allow to insert @span@s with font awesome icons using autolinks like
-- this:
--
-- > <fa:user>
--
-- This @user@ identifier is the name of icon you want to insert. You can
-- also control the size of the icon like this:
--
-- > <fa:user/fw> -- fixed width
-- > <fa:user/lg> -- large
-- > <fa:user/2x>
-- > <fa:user/3x>
-- > <fa:user/4x>
-- > <fa:user/5x>
--
-- In general, all path components in this URI that go after the name of
-- icon will be prefixed with @\"fa-\"@ and added as classes, so you can do
-- a lot of fancy stuff, see <http://fontawesome.io/examples/>:
--
-- > <fa:quote-left/3x/pull-left/border>
--
-- See also: <http://fontawesome.io>.

fontAwesome :: Extension
fontAwesome = Ext.inlineRender $ \old inline ->
  case inline of
    l@(Link _ fa _) ->
      if URI.uriScheme fa == URI.mkScheme "fa"
        then case fa ^. uriPath of
               [] -> old l
               xs ->
                 let g x = "fa-" <> URI.unRText x
                 in span_
                    [ (class_ . T.intercalate " ") ("fa" : fmap g xs) ]
                    ""
        else old l
    other -> old other