{-# LANGUAGE LambdaCase #-}
module Utils.Hakyll (
    absolutizeUrls
  , modifyExternalLinkAttr
  , sanitizeTagName
  , sanitizeDisqusName
  , makePageIdentifier
  , getStringField
) where

import           Control.Monad     (liftM2)
import           Data.Char         (isAlphaNum, isSpace, toLower)
import           Hakyll
import           System.FilePath   (isRelative, normalise, takeDirectory,
                                    takeFileName, (</>))
import qualified Text.HTML.TagSoup as TS

absolutizeUrls :: Item String -> Compiler (Item String)
absolutizeUrls :: Item String -> Compiler (Item String)
absolutizeUrls Item String
item = Compiler Identifier
getUnderlying Compiler Identifier
-> (Identifier -> Compiler (Item String)) -> Compiler (Item String)
forall a b. Compiler a -> (a -> Compiler b) -> Compiler b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Maybe String -> Item String)
-> Compiler (Maybe String) -> Compiler (Item String)
forall a b. (a -> b) -> Compiler a -> Compiler b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Item String
-> (String -> Item String) -> Maybe String -> Item String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Item String
item (((String -> String) -> Item String -> Item String)
-> Item String -> (String -> String) -> Item String
forall a b c. (a -> b -> c) -> b -> a -> c
flip (String -> String) -> Item String -> Item String
forall a b. (a -> b) -> Item a -> Item b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Item String
item ((String -> String) -> Item String)
-> (String -> String -> String) -> String -> Item String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String) -> String -> String
withUrls ((String -> String) -> String -> String)
-> (String -> String -> String) -> String -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String
f)) (Compiler (Maybe String) -> Compiler (Item String))
-> (Identifier -> Compiler (Maybe String))
-> Identifier
-> Compiler (Item String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Identifier -> Compiler (Maybe String)
getRoute
    where
        f :: String -> String -> String
f String
r String
u
            | Bool -> Bool
not (String -> Bool
isExternal String
u) Bool -> Bool -> Bool
&& String -> Bool
isRelative String
u = String -> String
normalise (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
"/" String -> String -> String
</> String -> String
takeDirectory String
r String -> String -> String
</> String
u
            | Bool
otherwise = String
u

modifyExternalLinkAttr :: Item String -> Compiler (Item String)
modifyExternalLinkAttr :: Item String -> Compiler (Item String)
modifyExternalLinkAttr = Item String -> Compiler (Item String)
forall a. a -> Compiler a
forall (m :: * -> *) a. Monad m => a -> m a
return (Item String -> Compiler (Item String))
-> (Item String -> Item String)
-> Item String
-> Compiler (Item String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> String) -> Item String -> Item String
forall a b. (a -> b) -> Item a -> Item b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Tag String -> Tag String) -> String -> String
withTags Tag String -> Tag String
f)
    where
        f :: Tag String -> Tag String
f Tag String
t
            | Tag String -> Bool
isExternalLink Tag String
t = case Tag String
t of
                (TS.TagOpen String
"a" [Attribute String]
as) -> String -> [Attribute String] -> Tag String
forall str. str -> [Attribute str] -> Tag str
TS.TagOpen String
"a" ([Attribute String] -> Tag String)
-> [Attribute String] -> Tag String
forall a b. (a -> b) -> a -> b
$ [Attribute String]
as [Attribute String] -> [Attribute String] -> [Attribute String]
forall a. Semigroup a => a -> a -> a
<> [Attribute String]
extraAttributes
                Tag String
_                   -> Tag String
t
            | Bool
otherwise = Tag String
t
        isExternalLink :: Tag String -> Bool
isExternalLink = (Bool -> Bool -> Bool)
-> (Tag String -> Bool)
-> (Tag String -> Bool)
-> Tag String
-> Bool
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 Bool -> Bool -> Bool
(&&) (String -> Tag String -> Bool
forall str. Eq str => str -> Tag str -> Bool
TS.isTagOpenName String
"a") (String -> Bool
isExternal (String -> Bool) -> (Tag String -> String) -> Tag String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Tag String -> String
forall str.
(Show str, Eq str, StringLike str) =>
str -> Tag str -> str
TS.fromAttrib String
"href")
        extraAttributes :: [Attribute String]
extraAttributes = [(String
"target", String
"_blank"), (String
"rel", String
"nofollow noopener")]

sanitizeTagName :: String -> String
sanitizeTagName :: String -> String
sanitizeTagName = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map (\Char
x -> if Char -> Bool
isSpace Char
x then Char
'-' else Char -> Char
toLower Char
x) (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
filter ((Bool -> Bool -> Bool)
-> (Char -> Bool) -> (Char -> Bool) -> Char -> Bool
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 Bool -> Bool -> Bool
(||) Char -> Bool
isSpace ((Bool -> Bool -> Bool)
-> (Char -> Bool) -> (Char -> Bool) -> Char -> Bool
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 Bool -> Bool -> Bool
(||) Char -> Bool
isAlphaNum (Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
'-', Char
'_'])))

makePageIdentifier :: FilePath -> PageNumber -> Identifier
makePageIdentifier :: String -> PageNumber -> Identifier
makePageIdentifier String
p PageNumber
1 = String -> Identifier
fromFilePath String
p
makePageIdentifier String
p PageNumber
n = String -> Identifier
fromFilePath (String -> Identifier) -> String -> Identifier
forall a b. (a -> b) -> a -> b
$ String -> String
takeDirectory' String
p String -> String -> String
</> String
"page" String -> String -> String
</> PageNumber -> String
forall a. Show a => a -> String
show PageNumber
n String -> String -> String
</> String -> String
takeFileName String
p
    where
        takeDirectory' :: String -> String
takeDirectory' String
x = let x' :: String
x' = String -> String
takeDirectory String
x in if String
x' String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"." then String
forall a. Monoid a => a
mempty else String
x'

getStringField :: String -> Context String -> Compiler (Maybe String)
getStringField :: String -> Context String -> Compiler (Maybe String)
getStringField String
key Context String
cs = Context String
-> String -> [String] -> Item String -> Compiler ContextField
forall a.
Context a -> String -> [String] -> Item a -> Compiler ContextField
unContext Context String
cs String
key [String]
forall a. Monoid a => a
mempty (Identifier -> String -> Item String
forall a. Identifier -> a -> Item a
Item (String -> Identifier
fromFilePath String
forall a. Monoid a => a
mempty) String
forall a. Monoid a => a
mempty) Compiler ContextField
-> (ContextField -> Compiler (Maybe String))
-> Compiler (Maybe String)
forall a b. Compiler a -> (a -> Compiler b) -> Compiler b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    StringField String
x -> Maybe String -> Compiler (Maybe String)
forall a. a -> Compiler a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe String -> Compiler (Maybe String))
-> Maybe String -> Compiler (Maybe String)
forall a b. (a -> b) -> a -> b
$ String -> Maybe String
forall a. a -> Maybe a
Just String
x
    ContextField
_             -> Maybe String -> Compiler (Maybe String)
forall a. a -> Compiler a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe String
forall a. Maybe a
Nothing

sanitizeDisqusName :: String -> String
sanitizeDisqusName :: String -> String
sanitizeDisqusName = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map (\Char
x -> if Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.' then Char
'-' else Char
x)