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

import           Control.Monad            (liftM2)
import           Data.Char                (isAlphaNum, isSpace, toLower)
import           Data.List                (isInfixOf, isPrefixOf)
import           Data.Text                (Text)
import qualified Data.Text                as T
import           Hakyll
import           System.FilePath          (isRelative, normalise, takeDirectory,
                                           takeFileName, (</>))
import qualified Text.HTML.TagSoup        as TS
import           Text.Pandoc.Definition
import           Text.Pandoc.Options
import           Text.Pandoc.Walk
import           Text.Pandoc.Writers.HTML

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


injectTableOfContents :: Pandoc -> Pandoc
injectTableOfContents :: Pandoc -> Pandoc
injectTableOfContents doc :: Pandoc
doc@(Pandoc Meta
meta [Block]
blocks) =
    let headers :: [Block]
headers = (Block -> [Block]) -> Pandoc -> [Block]
forall c. Monoid c => (Block -> c) -> Pandoc -> c
forall a b c. (Walkable a b, Monoid c) => (a -> c) -> b -> c
query Block -> [Block]
collectHeaders Pandoc
doc
        toc :: [Block]
toc = PageNumber -> [Block] -> [Block]
buildTOC PageNumber
3 [Block]
headers
        updatedBlocks :: [Block]
updatedBlocks = [Block] -> [Block] -> [Block]
replaceTOCMarker [Block]
toc [Block]
blocks
    in Meta -> [Block] -> Pandoc
Pandoc Meta
meta [Block]
updatedBlocks
    where
        collectHeaders :: Block -> [Block]
        collectHeaders :: Block -> [Block]
collectHeaders h :: Block
h@(Header PageNumber
_ Attr
_ [Inline]
_) = [Block
h]
        collectHeaders Block
_                = []

        buildTOC :: Int -> [Block] -> [Block]
        buildTOC :: PageNumber -> [Block] -> [Block]
buildTOC PageNumber
maxDepth [Block]
headers =
            let filteredHeaders :: [Block]
filteredHeaders = (Block -> Bool) -> [Block] -> [Block]
forall a. (a -> Bool) -> [a] -> [a]
filter ((PageNumber -> PageNumber -> Bool
forall a. Ord a => a -> a -> Bool
<= PageNumber
maxDepth) (PageNumber -> Bool) -> (Block -> PageNumber) -> Block -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Block -> PageNumber
getLevel) [Block]
headers
            in case [Block] -> [[Block]]
buildNestedList [Block]
filteredHeaders of
                []    -> []
                [[Block]]
items -> [Attr -> [Block] -> Block
Div (Text
"toc", [], []) [
                            PageNumber -> Attr -> [Inline] -> Block
Header PageNumber
2 (Text
"", [], []) [Text -> Inline
Str Text
"目次"],
                            ListAttributes -> [[Block]] -> Block
OrderedList (PageNumber
1, ListNumberStyle
Decimal, ListNumberDelim
Period) [[Block]]
items
                         ]]

        buildNestedList :: [Block] -> [[Block]]
        buildNestedList :: [Block] -> [[Block]]
buildNestedList = [[Block]] -> [Block] -> [[Block]]
go []
            where
                go :: [[Block]] -> [Block] -> [[Block]]
go [[Block]]
acc [] = [[Block]] -> [[Block]]
forall a. [a] -> [a]
reverse [[Block]]
acc
                go [[Block]]
acc (h :: Block
h@(Header PageNumber
2 Attr
_ [Inline]
_):[Block]
rest) =
                    let ([Block]
h3s, [Block]
remaining) = (Block -> Bool) -> [Block] -> ([Block], [Block])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span Block -> Bool
isH3 [Block]
rest
                        item :: [Block]
item = if [Block] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Block]
h3s
                               then [[Inline] -> Block
Plain [Block -> Inline
headerToLink Block
h]]
                               else [[Inline] -> Block
Plain [Block -> Inline
headerToLink Block
h],
                                     ListAttributes -> [[Block]] -> Block
OrderedList (PageNumber
1, ListNumberStyle
Decimal, ListNumberDelim
Period) ((Block -> [Block]) -> [Block] -> [[Block]]
forall a b. (a -> b) -> [a] -> [b]
map (\Block
h3 -> [[Inline] -> Block
Plain [Block -> Inline
headerToLink Block
h3]]) [Block]
h3s)]
                    in [[Block]] -> [Block] -> [[Block]]
go ([Block]
item [Block] -> [[Block]] -> [[Block]]
forall a. a -> [a] -> [a]
: [[Block]]
acc) [Block]
remaining
                go [[Block]]
acc (Block
_:[Block]
rest) = [[Block]] -> [Block] -> [[Block]]
go [[Block]]
acc [Block]
rest

                isH3 :: Block -> Bool
isH3 (Header PageNumber
3 Attr
_ [Inline]
_) = Bool
True
                isH3 Block
_              = Bool
False

        getLevel :: Block -> Int
        getLevel :: Block -> PageNumber
getLevel (Header PageNumber
level Attr
_ [Inline]
_) = PageNumber
level
        getLevel Block
_                  = PageNumber
0

        headerToLink :: Block -> Inline
        headerToLink :: Block -> Inline
headerToLink (Header PageNumber
_ (Text
ident, [Text]
_, [(Text, Text)]
_) [Inline]
inlines) =
            Attr -> [Inline] -> (Text, Text) -> Inline
Link Attr
nullAttr [Inline]
inlines (Text
"#" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
ident, Text
"")
        headerToLink Block
_ = Text -> Inline
Str Text
""

        replaceTOCMarker :: [Block] -> [Block] -> [Block]
        replaceTOCMarker :: [Block] -> [Block] -> [Block]
replaceTOCMarker [Block]
toc = (Block -> [Block]) -> [Block] -> [Block]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Block -> [Block]
replaceBlock
            where
                replaceBlock :: Block -> [Block]
replaceBlock b :: Block
b@(RawBlock (Format Text
"html") Text
text)
                    | Text
"<!--toc-->" Text -> Text -> Bool
`T.isInfixOf` Text
text = [Block]
toc
                    | Bool
otherwise = [Block
b]
                replaceBlock Block
b = [Block
b]