-- | Small post-render HTML transforms, applied once a page is fully assembled
module MathiasSM.Html (readonlyCheckboxes) where

import Data.List (isInfixOf, words)
import Data.Maybe (fromMaybe)
import Hakyll.Web.Html (withTagList)
import Text.HTML.TagSoup (Tag (TagClose, TagOpen))

{- | Makes every pandoc task-list checkbox read-only, unless it sits inside an
`interactive`-classed element.

Pandoc renders `- [ ]` / `- [x]` as `<input type="checkbox">` inside a
`<ul class="task-list">`. On a static page those invite interaction that can't
be persisted, so this adds `aria-readonly` and drops each one from the tab
order, and the stylesheet stops pointer events on them (and their `<label>`).
A checkbox inside `<div class="interactive">` is left editable, as is any
checkbox outside a task list (e.g. a hand-authored control).
-}
readonlyCheckboxes :: String -> String
readonlyCheckboxes :: String -> String
readonlyCheckboxes String
html
    | String
"checkbox" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` String
html = ([Tag String] -> [Tag String]) -> String -> String
withTagList ([(Bool, Bool)] -> [Tag String] -> [Tag String]
walk []) String
html
    | Bool
otherwise = String
html
  where
    -- Each open `<div>`/`<ul>` pushes the current (interactive, task-list) flags.
    walk :: [(Bool, Bool)] -> [Tag String] -> [Tag String]
    walk :: [(Bool, Bool)] -> [Tag String] -> [Tag String]
walk [(Bool, Bool)]
_ [] = []
    walk [(Bool, Bool)]
stack (t :: Tag String
t@(TagOpen String
"div" [Attribute String]
attrs) : [Tag String]
rest) =
        let (Bool
interactive, Bool
taskList) = [(Bool, Bool)] -> (Bool, Bool)
top [(Bool, Bool)]
stack
         in Tag String
t Tag String -> [Tag String] -> [Tag String]
forall a. a -> [a] -> [a]
: [(Bool, Bool)] -> [Tag String] -> [Tag String]
walk (([Attribute String] -> Bool
forall {a}. (Eq a, IsString a) => [(a, String)] -> Bool
interactiveDiv [Attribute String]
attrs Bool -> Bool -> Bool
|| Bool
interactive, Bool
taskList) (Bool, Bool) -> [(Bool, Bool)] -> [(Bool, Bool)]
forall a. a -> [a] -> [a]
: [(Bool, Bool)]
stack) [Tag String]
rest
    walk [(Bool, Bool)]
stack (t :: Tag String
t@(TagOpen String
"ul" [Attribute String]
attrs) : [Tag String]
rest) =
        let (Bool
interactive, Bool
taskList) = [(Bool, Bool)] -> (Bool, Bool)
top [(Bool, Bool)]
stack
         in Tag String
t Tag String -> [Tag String] -> [Tag String]
forall a. a -> [a] -> [a]
: [(Bool, Bool)] -> [Tag String] -> [Tag String]
walk ((Bool
interactive, [Attribute String] -> Bool
forall {a}. (Eq a, IsString a) => [(a, String)] -> Bool
taskListUl [Attribute String]
attrs Bool -> Bool -> Bool
|| Bool
taskList) (Bool, Bool) -> [(Bool, Bool)] -> [(Bool, Bool)]
forall a. a -> [a] -> [a]
: [(Bool, Bool)]
stack) [Tag String]
rest
    walk ((Bool, Bool)
_ : [(Bool, Bool)]
stack') (t :: Tag String
t@(TagClose String
name) : [Tag String]
rest)
        | String
name String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"div" Bool -> Bool -> Bool
|| String
name String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"ul" = Tag String
t Tag String -> [Tag String] -> [Tag String]
forall a. a -> [a] -> [a]
: [(Bool, Bool)] -> [Tag String] -> [Tag String]
walk [(Bool, Bool)]
stack' [Tag String]
rest
    walk [(Bool, Bool)]
stack (t :: Tag String
t@(TagOpen String
"input" [Attribute String]
attrs) : [Tag String]
rest)
        | [Attribute String] -> Bool
forall {b} {a}.
(Eq b, Eq a, IsString a, IsString b) =>
[(a, b)] -> Bool
isCheckbox [Attribute String]
attrs Bool -> Bool -> Bool
&& Bool
taskList Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
interactive =
            String -> [Attribute String] -> Tag String
forall str. str -> [Attribute str] -> Tag str
TagOpen String
"input" (Attribute String -> [Attribute String] -> [Attribute String]
forall {b} {b}. Eq b => (b, b) -> [(b, b)] -> [(b, b)]
addIfMissing (String
"tabindex", String
"-1") (Attribute String -> [Attribute String] -> [Attribute String]
forall {b} {b}. Eq b => (b, b) -> [(b, b)] -> [(b, b)]
addIfMissing (String
"aria-readonly", String
"true") [Attribute String]
attrs)) Tag String -> [Tag String] -> [Tag String]
forall a. a -> [a] -> [a]
: [(Bool, Bool)] -> [Tag String] -> [Tag String]
walk [(Bool, Bool)]
stack [Tag String]
rest
        | Bool
otherwise = Tag String
t Tag String -> [Tag String] -> [Tag String]
forall a. a -> [a] -> [a]
: [(Bool, Bool)] -> [Tag String] -> [Tag String]
walk [(Bool, Bool)]
stack [Tag String]
rest
      where
        (Bool
interactive, Bool
taskList) = [(Bool, Bool)] -> (Bool, Bool)
top [(Bool, Bool)]
stack
    walk [(Bool, Bool)]
stack (Tag String
t : [Tag String]
rest) = Tag String
t Tag String -> [Tag String] -> [Tag String]
forall a. a -> [a] -> [a]
: [(Bool, Bool)] -> [Tag String] -> [Tag String]
walk [(Bool, Bool)]
stack [Tag String]
rest

    top :: [(Bool, Bool)] -> (Bool, Bool)
top [] = (Bool
False, Bool
False)
    top ((Bool, Bool)
scope : [(Bool, Bool)]
_) = (Bool, Bool)
scope

    interactiveDiv :: [(a, String)] -> Bool
interactiveDiv [(a, String)]
attrs = String
"interactive" String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String -> [String]
words (String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" (a -> [(a, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup a
"class" [(a, String)]
attrs))
    taskListUl :: [(a, String)] -> Bool
taskListUl [(a, String)]
attrs = String
"task-list" String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String -> [String]
words (String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"" (a -> [(a, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup a
"class" [(a, String)]
attrs))
    isCheckbox :: [(a, b)] -> Bool
isCheckbox [(a, b)]
attrs = a -> [(a, b)] -> Maybe b
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup a
"type" [(a, b)]
attrs Maybe b -> Maybe b -> Bool
forall a. Eq a => a -> a -> Bool
== b -> Maybe b
forall a. a -> Maybe a
Just b
"checkbox"

    addIfMissing :: (b, b) -> [(b, b)] -> [(b, b)]
addIfMissing (b, b)
attr [(b, b)]
attrs
        | ((b, b) -> Bool) -> [(b, b)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((b -> b -> Bool
forall a. Eq a => a -> a -> Bool
== (b, b) -> b
forall a b. (a, b) -> a
fst (b, b)
attr) (b -> Bool) -> ((b, b) -> b) -> (b, b) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b, b) -> b
forall a b. (a, b) -> a
fst) [(b, b)]
attrs = [(b, b)]
attrs
        | Bool
otherwise = [(b, b)]
attrs [(b, b)] -> [(b, b)] -> [(b, b)]
forall a. [a] -> [a] -> [a]
++ [(b, b)
attr]