{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}

-- |
-- Module      :  Text.MMark.Extension.FontAwesome
-- Copyright   :  © 2017–present Mark Karpov
-- License     :  BSD 3 clause
--
-- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>
-- Stability   :  experimental
-- Portability :  portable
--
-- Turn links into Font Awesome icons.
module Text.MMark.Extension.FontAwesome
  ( fontAwesome,
  )
where

import qualified Data.Text as T
import Lens.Micro ((^.))
import Lucid
import Text.MMark.Extension (Extension, Inline (..))
import qualified Text.MMark.Extension as Ext
import qualified Text.URI as URI
import Text.URI.Lens (uriPath)
import Text.URI.QQ (scheme)

-- | 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 :: Extension
fontAwesome = ((Inline -> Html ()) -> Inline -> Html ()) -> Extension
Ext.inlineRender (((Inline -> Html ()) -> Inline -> Html ()) -> Extension)
-> ((Inline -> Html ()) -> Inline -> Html ()) -> Extension
forall a b. (a -> b) -> a -> b
$ \Inline -> Html ()
old Inline
inline ->
  case Inline
inline of
    l :: Inline
l@(Link NonEmpty Inline
_ URI
uri Maybe Text
_) ->
      if URI -> Maybe (RText 'Scheme)
URI.uriScheme URI
uri Maybe (RText 'Scheme) -> Maybe (RText 'Scheme) -> Bool
forall a. Eq a => a -> a -> Bool
== RText 'Scheme -> Maybe (RText 'Scheme)
forall a. a -> Maybe a
Just [scheme|fa|]
        then case URI
uri URI
-> Getting [RText 'PathPiece] URI [RText 'PathPiece]
-> [RText 'PathPiece]
forall s a. s -> Getting a s a -> a
^. Getting [RText 'PathPiece] URI [RText 'PathPiece]
Lens' URI [RText 'PathPiece]
uriPath of
          [] -> Inline -> Html ()
old Inline
l
          [RText 'PathPiece]
xs ->
            let g :: RText l -> Text
g RText l
x = Text
"fa-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> RText l -> Text
forall (l :: RTextLabel). RText l -> Text
URI.unRText RText l
x
             in [Attribute] -> Html () -> Html ()
forall arg result. Term arg result => arg -> result
span_
                  [(Text -> Attribute
class_ (Text -> Attribute) -> ([Text] -> Text) -> [Text] -> Attribute
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text] -> Text
T.intercalate Text
" ") (Text
"fa" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: (RText 'PathPiece -> Text) -> [RText 'PathPiece] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RText 'PathPiece -> Text
forall (l :: RTextLabel). RText l -> Text
g [RText 'PathPiece]
xs)]
                  Html ()
""
        else Inline -> Html ()
old Inline
l
    Inline
other -> Inline -> Html ()
old Inline
other