|
|
- {-# LANGUAGE OverloadedStrings #-}
- module Main where
-
- import qualified Data.HashMap.Strict as HashMap
- import Data.HashMap.Strict (HashMap)
- import qualified Data.Text as T
- import Data.Text (Text)
- import Data.Maybe
- import Data.List
-
- import System.Environment
- import System.Exit
-
- import Text.Pandoc.Definition
- import Text.HTML.TagSoup
- import Text.Pandoc.Walk
- import Text.Pandoc.JSON
-
-
- main :: IO ()
- main = toJSONFilter linkDocument
-
- linkDocument :: Pandoc -> Pandoc
- linkDocument (Pandoc meta blocks) =
- let hm = parseSymbolRefs blocks
- in Pandoc meta (walk (link hm) blocks)
-
- link :: HashMap Text Reference -> Inline -> Inline
- link hm inline@(Code (_, classes, kv) text)
- | isToBeLinked =
- case HashMap.lookup identifier hm of
- Just ref -> RawInline "html" (renderReference ref text)
- Nothing -> inline
- where
- classes' = map T.toLower classes
-
- isToBeLinked = ("agda" `elem` classes')
- && ("nolink" `notElem` classes')
-
- identifier =
- case lookup "ident" kv of
- Just id -> id
- _ -> text
- link _ x = x
-
- renderReference :: Reference -> Text -> Text
- renderReference (Reference href cls) t =
- renderTags [ TagOpen "span" [("class", "Agda")]
- , TagOpen "a" [("href", href), ("class", cls)]
- , TagText t
- , TagClose "a"
- , TagClose "span"
- ]
-
- data Reference =
- Reference { refHref :: Text
- , refClass :: Text
- }
- deriving (Eq, Show)
-
- parseSymbolRefs :: [Block] -> HashMap Text Reference
- parseSymbolRefs = go mempty . concat . mapMaybe getHTML where
- getHTML :: Block -> Maybe ([Tag Text])
- getHTML (RawBlock (Format x) xs)
- | x == "html" = Just (concatMap parseTags' (parseTags xs))
- getHTML _ = Nothing
-
- parseTags' (TagComment x) = parseTags x >>= parseTags'
- parseTags' t = pure t
-
- go :: HashMap Text Reference -> [Tag Text] -> HashMap Text Reference
- go map (TagOpen a meta:TagText t:TagClose a':xs)
- | a == "a"
- , a' == a
- , Just id <- lookup "id" meta
- , Just cls <- lookup "class" meta
- , Just href <- lookup "href" meta
- = go (addIfNotPresent t (Reference href cls) map) xs
-
- | otherwise = go map xs
- where
- tags = [ TagOpen "span" [("class", "Agda")], TagOpen "a" meta', TagText t, TagClose "a", TagClose "span" ]
- meta' = filter ((/= "id") . fst) meta
-
- go map (_:xs) = go map xs
- go map [] = map
-
- addIfNotPresent :: Text -> v -> HashMap Text v -> HashMap Text v
- addIfNotPresent = HashMap.insertWith (\_ old -> old)
|