-- | Build-time accessibility checks on the final rendered HTML of a page.
module MathiasSM.Accessibility (checkAccessibility, checkHtml) where

import Control.Monad (unless)
import Control.Monad.Except (throwError)
import Data.Char (isSpace)
import Data.List (group, sort)
import Data.Maybe (isNothing, mapMaybe)
import Hakyll (Compiler, Item (itemBody), getUnderlying, toFilePath)
import Text.HTML.TagSoup (
    Tag (..),
    innerText,
    isTagCloseName,
    isTagOpenName,
    parseTags,
    sections,
 )

-- | Runs every check against the given HTML and returns each problem found
checkHtml :: String -> [String]
checkHtml :: String -> [String]
checkHtml String
html = (([Tag String] -> [String]) -> [String])
-> [[Tag String] -> [String]] -> [String]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\[Tag String] -> [String]
check -> [Tag String] -> [String]
check [Tag String]
tags) [[Tag String] -> [String]]
checks
  where
    tags :: [Tag String]
tags = String -> [Tag String]
forall str. StringLike str => str -> [Tag str]
parseTags String
html

checks :: [[Tag String] -> [String]]
checks :: [[Tag String] -> [String]]
checks =
    [ [Tag String] -> [String]
checkImages
    , [Tag String] -> [String]
checkTitle
    , [Tag String] -> [String]
checkLanguage
    , [Tag String] -> [String]
checkH1
    , [Tag String] -> [String]
checkHeadingOrder
    , [Tag String] -> [String]
checkEmptyHeadings
    , [Tag String] -> [String]
checkLinks
    , [Tag String] -> [String]
checkIds
    , [Tag String] -> [String]
checkMain
    ]

-- | Fails the compilation if the page fails any accessibility check
checkAccessibility :: Item String -> Compiler (Item String)
checkAccessibility :: Item String -> Compiler (Item String)
checkAccessibility Item String
item = do
    ident <- Compiler Identifier
getUnderlying
    let problems = String -> [String]
checkHtml (Item String -> String
forall a. Item a -> a
itemBody Item String
item)
        path = Identifier -> String
toFilePath Identifier
ident
    unless (null problems) $
        throwError (map ((path ++ ": ") ++) problems)
    pure item

-- Checks ---------------------------------------------------------------------

-- | Every @img@ must have an @alt@ attribute (empty is allowed for decorative images)
checkImages :: [Tag String] -> [String]
checkImages :: [Tag String] -> [String]
checkImages [Tag String]
tags =
    [String
"image missing an `alt` attribute" | TagOpen String
"img" [Attribute String]
attrs <- [Tag String]
tags, Maybe String -> Bool
forall a. Maybe a -> Bool
isNothing (String -> [Attribute String] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"alt" [Attribute String]
attrs)]

{- | Exactly one non-empty document @title@ (the one in @head@).

@<title>@ elements inside inline SVGs (e.g. the site logo) are SVG accessible
names, not document titles, so they are ignored.
-}
checkTitle :: [Tag String] -> [String]
checkTitle :: [Tag String] -> [String]
checkTitle [Tag String]
tags =
    case String -> [Tag String] -> [String]
innerTextsOf String
"title" [Tag String]
headTags of
        [] -> [String
"no <title>"]
        [String
t]
            | (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace String
t -> [String
"empty <title>"]
            | Bool
otherwise -> []
        [String]
_ -> [String
"multiple <title> elements"]
  where
    -- The document title always lives in @head@, before the @body@ opens.
    headTags :: [Tag String]
headTags = (Tag String -> Bool) -> [Tag String] -> [Tag String]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Bool -> Bool
not (Bool -> Bool) -> (Tag String -> Bool) -> Tag String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Tag String -> Bool
forall str. Eq str => str -> Tag str -> Bool
isTagOpenName String
"body") [Tag String]
tags

-- | A non-empty @lang@ on the single @html@ element
checkLanguage :: [Tag String] -> [String]
checkLanguage :: [Tag String] -> [String]
checkLanguage [Tag String]
tags =
    case [String -> [Attribute String] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"lang" [Attribute String]
attrs | TagOpen String
"html" [Attribute String]
attrs <- [Tag String]
tags] of
        [] -> [String
"no <html> element"]
        [Just String
lang]
            | Bool -> Bool
not ((Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace String
lang) -> []
        [Maybe String]
_ -> [String
"missing non-empty `lang` on <html>"]

-- | Exactly one @h1@ (its content is checked by 'checkEmptyHeadings')
checkH1 :: [Tag String] -> [String]
checkH1 :: [Tag String] -> [String]
checkH1 [Tag String]
tags =
    case [Tag String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((Tag String -> Bool) -> [Tag String] -> [Tag String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> Tag String -> Bool
forall str. Eq str => str -> Tag str -> Bool
isTagOpenName String
"h1") [Tag String]
tags) of
        Int
0 -> [String
"no <h1>"]
        Int
1 -> []
        Int
_ -> [String
"multiple <h1> elements"]

-- | No skipped heading levels (e.g. @h1@ straight to @h3@)
checkHeadingOrder :: [Tag String] -> [String]
checkHeadingOrder :: [Tag String] -> [String]
checkHeadingOrder =
    [Int] -> [String]
skipProblems ([Int] -> [String])
-> ([Tag String] -> [Int]) -> [Tag String] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tag String -> Maybe Int) -> [Tag String] -> [Int]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Tag String -> Maybe Int
headingLevel
  where
    headingLevel :: Tag String -> Maybe Int
headingLevel (TagOpen String
name [Attribute String]
_) = String -> Maybe Int
headingLevelOf String
name
    headingLevel Tag String
_ = Maybe Int
forall a. Maybe a
Nothing

skipProblems :: [Int] -> [String]
skipProblems :: [Int] -> [String]
skipProblems [Int]
levels =
    [ String
"heading level skips from h" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
prev String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" to h" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
cur
    | (Int
prev, Int
cur) <- [Int] -> [Int] -> [(Int, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int]
levels (Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
drop Int
1 [Int]
levels)
    , Int
cur Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
prev Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
    ]

headingLevelOf :: String -> Maybe Int
headingLevelOf :: String -> Maybe Int
headingLevelOf String
"h1" = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1
headingLevelOf String
"h2" = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
2
headingLevelOf String
"h3" = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
3
headingLevelOf String
"h4" = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
4
headingLevelOf String
"h5" = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
5
headingLevelOf String
"h6" = Int -> Maybe Int
forall a. a -> Maybe a
Just Int
6
headingLevelOf String
_ = Maybe Int
forall a. Maybe a
Nothing

-- | No empty headings
checkEmptyHeadings :: [Tag String] -> [String]
checkEmptyHeadings :: [Tag String] -> [String]
checkEmptyHeadings [Tag String]
tags =
    [ String
"empty <" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
">"
    | String
name <- [String
"h1", String
"h2", String
"h3", String
"h4", String
"h5", String
"h6"]
    , String
text <- String -> [Tag String] -> [String]
innerTextsOf String
name [Tag String]
tags
    , (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace String
text
    ]

{- | Every @a@ has an accessible name: text, `aria-label`, @title@, or an inner image @alt@
(links marked `aria-hidden="true"`, like pandoc's code-block line anchors, are skipped)
-}
checkLinks :: [Tag String] -> [String]
checkLinks :: [Tag String] -> [String]
checkLinks [Tag String]
tags =
    [ String
"link has no accessible name" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Attribute String] -> String
forall {a}. (Eq a, IsString a) => [(a, String)] -> String
hrefOf [Attribute String]
attrs
    | (TagOpen String
"a" [Attribute String]
attrs : [Tag String]
rest) <- (Tag String -> Bool) -> [Tag String] -> [[Tag String]]
forall a. (a -> Bool) -> [a] -> [[a]]
sections (String -> Tag String -> Bool
forall str. Eq str => str -> Tag str -> Bool
isTagOpenName String
"a") [Tag String]
tags
    , String -> [Attribute String] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"aria-hidden" [Attribute String]
attrs Maybe String -> Maybe String -> Bool
forall a. Eq a => a -> a -> Bool
/= String -> Maybe String
forall a. a -> Maybe a
Just String
"true"
    , let content :: [Tag String]
content = (Tag String -> Bool) -> [Tag String] -> [Tag String]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Bool -> Bool
not (Bool -> Bool) -> (Tag String -> Bool) -> Tag String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Tag String -> Bool
forall str. Eq str => str -> Tag str -> Bool
isTagCloseName String
"a") [Tag String]
rest
    , Bool -> Bool
not ([Attribute String] -> [Tag String] -> Bool
forall {t :: * -> *} {t :: * -> *} {t :: * -> *} {a}.
(Foldable t, Foldable t, Foldable t, Eq a, Eq (t Char), IsString a,
 IsString (t Char)) =>
[(a, t Char)] -> t (Tag (t Char)) -> Bool
hasAccessibleName [Attribute String]
attrs [Tag String]
content)
    ]
  where
    hasAccessibleName :: [(a, t Char)] -> t (Tag (t Char)) -> Bool
hasAccessibleName [(a, t Char)]
attrs t (Tag (t Char))
content =
        Maybe (t Char) -> Bool
forall {t :: * -> *}. Foldable t => Maybe (t Char) -> Bool
nonEmpty (a -> [(a, t Char)] -> Maybe (t Char)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup a
"aria-label" [(a, t Char)]
attrs)
            Bool -> Bool -> Bool
|| Maybe (t Char) -> Bool
forall {t :: * -> *}. Foldable t => Maybe (t Char) -> Bool
nonEmpty (a -> [(a, t Char)] -> Maybe (t Char)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup a
"title" [(a, t Char)]
attrs)
            Bool -> Bool -> Bool
|| (Tag (t Char) -> Bool) -> t (Tag (t Char)) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Tag (t Char) -> Bool
forall {t :: * -> *}. Foldable t => Tag (t Char) -> Bool
hasText t (Tag (t Char))
content
            Bool -> Bool -> Bool
|| (Tag (t Char) -> Bool) -> t (Tag (t Char)) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Tag (t Char) -> Bool
forall {t :: * -> *}.
(Eq (t Char), IsString (t Char), Foldable t) =>
Tag (t Char) -> Bool
hasImgAlt t (Tag (t Char))
content

    hasText :: Tag (t Char) -> Bool
hasText (TagText t Char
t) = Bool -> Bool
not ((Char -> Bool) -> t Char -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace t Char
t)
    hasText Tag (t Char)
_ = Bool
False

    hasImgAlt :: Tag (t Char) -> Bool
hasImgAlt (TagOpen t Char
"img" [Attribute (t Char)]
iattrs) = Maybe (t Char) -> Bool
forall {t :: * -> *}. Foldable t => Maybe (t Char) -> Bool
nonEmpty (t Char -> [Attribute (t Char)] -> Maybe (t Char)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup t Char
"alt" [Attribute (t Char)]
iattrs)
    hasImgAlt Tag (t Char)
_ = Bool
False

    nonEmpty :: Maybe (t Char) -> Bool
nonEmpty (Just t Char
s) = Bool -> Bool
not ((Char -> Bool) -> t Char -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace t Char
s)
    nonEmpty Maybe (t Char)
Nothing = Bool
False

    hrefOf :: [(a, String)] -> String
hrefOf [(a, String)]
attrs = String -> (String -> String) -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (\String
h -> String
" (href \"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
h String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\")") (a -> [(a, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup a
"href" [(a, String)]
attrs)

-- | No duplicate `id` values
checkIds :: [Tag String] -> [String]
checkIds :: [Tag String] -> [String]
checkIds [Tag String]
tags =
    [ String
"duplicate id: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
i
    | (String
i : String
_ : [String]
_) <- [String] -> [[String]]
forall a. Eq a => [a] -> [[a]]
group ([String] -> [String]
forall a. Ord a => [a] -> [a]
sort [String
i | TagOpen String
_ [Attribute String]
attrs <- [Tag String]
tags, Just String
i <- [String -> [Attribute String] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"id" [Attribute String]
attrs]])
    ]

-- | Exactly one @main@
checkMain :: [Tag String] -> [String]
checkMain :: [Tag String] -> [String]
checkMain [Tag String]
tags =
    case [Tag String] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((Tag String -> Bool) -> [Tag String] -> [Tag String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> Tag String -> Bool
forall str. Eq str => str -> Tag str -> Bool
isTagOpenName String
"main") [Tag String]
tags) of
        Int
0 -> [String
"no <main>"]
        Int
1 -> []
        Int
_ -> [String
"multiple <main> elements"]

-- Helpers --------------------------------------------------------------------

-- | The inner text of every element with the given name ("" for an empty element)
innerTextsOf :: String -> [Tag String] -> [String]
innerTextsOf :: String -> [Tag String] -> [String]
innerTextsOf String
name =
    ([Tag String] -> String) -> [[Tag String]] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ([Tag String] -> String
forall str. StringLike str => [Tag str] -> str
innerText ([Tag String] -> String)
-> ([Tag String] -> [Tag String]) -> [Tag String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tag String -> Bool) -> [Tag String] -> [Tag String]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Bool -> Bool
not (Bool -> Bool) -> (Tag String -> Bool) -> Tag String -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Tag String -> Bool
forall str. Eq str => str -> Tag str -> Bool
isTagCloseName String
name) ([Tag String] -> [Tag String])
-> ([Tag String] -> [Tag String]) -> [Tag String] -> [Tag String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [Tag String] -> [Tag String]
forall a. Int -> [a] -> [a]
drop Int
1)
        ([[Tag String]] -> [String])
-> ([Tag String] -> [[Tag String]]) -> [Tag String] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tag String -> Bool) -> [Tag String] -> [[Tag String]]
forall a. (a -> Bool) -> [a] -> [[a]]
sections (String -> Tag String -> Bool
forall str. Eq str => str -> Tag str -> Bool
isTagOpenName String
name)