{-# LANGUAGE OverloadedStrings #-}

{-# OPTIONS_GHC -fno-warn-name-shadowing #-}

module Blagda.References where

import           Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import           Data.Maybe
import           Data.Text (Text)
import qualified Data.Text as T
import           Text.HTML.TagSoup
import           Text.Pandoc.Definition
import           Text.Pandoc.Walk


linkDocument :: Pandoc -> Pandoc
linkDocument :: Pandoc -> Pandoc
linkDocument (Pandoc Meta
meta [Block]
blocks) =
  let hm :: HashMap Text Reference
hm = [Block] -> HashMap Text Reference
parseSymbolRefs [Block]
blocks
  in Meta -> [Block] -> Pandoc
Pandoc Meta
meta ((Inline -> Inline) -> [Block] -> [Block]
forall a b. Walkable a b => (a -> a) -> b -> b
walk (HashMap Text Reference -> Inline -> Inline
link HashMap Text Reference
hm) [Block]
blocks)

link :: HashMap Text Reference -> Inline -> Inline
link :: HashMap Text Reference -> Inline -> Inline
link HashMap Text Reference
hm inline :: Inline
inline@(Code (Text
_, [Text]
classes, [(Text, Text)]
kv) Text
text)
  | Bool
isToBeLinked =
    case Text -> HashMap Text Reference -> Maybe Reference
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Text
identifier HashMap Text Reference
hm of
      Just Reference
ref -> Format -> Text -> Inline
RawInline Format
"html" (Reference -> Text -> Text
renderReference Reference
ref Text
text)
      Maybe Reference
Nothing -> Inline
inline
 where
  classes' :: [Text]
classes' = (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
T.toLower [Text]
classes

  isToBeLinked :: Bool
isToBeLinked = (Text
"agda" Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
classes')
    Bool -> Bool -> Bool
&& (Text
"nolink" Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Text]
classes')

  identifier :: Text
identifier =
    case Text -> [(Text, Text)] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"ident" [(Text, Text)]
kv of
      Just Text
id -> Text
id
      Maybe Text
_ -> Text
text
link HashMap Text Reference
_ Inline
x = Inline
x

renderReference :: Reference -> Text -> Text
renderReference :: Reference -> Text -> Text
renderReference (Reference Text
href Text
cls) Text
t =
 [Tag Text] -> Text
forall str. StringLike str => [Tag str] -> str
renderTags [ Text -> [(Text, Text)] -> Tag Text
forall str. str -> [Attribute str] -> Tag str
TagOpen Text
"span" [(Text
"class", Text
"Agda")]
 , Text -> [(Text, Text)] -> Tag Text
forall str. str -> [Attribute str] -> Tag str
TagOpen Text
"a" [(Text
"href", Text
href), (Text
"class", Text
cls)]
 , Text -> Tag Text
forall str. str -> Tag str
TagText Text
t
 , Text -> Tag Text
forall str. str -> Tag str
TagClose Text
"a"
 , Text -> Tag Text
forall str. str -> Tag str
TagClose Text
"span"
 ]

data Reference =
 Reference { Reference -> Text
refHref :: Text
 , Reference -> Text
refClass :: Text
 }
 deriving (Reference -> Reference -> Bool
(Reference -> Reference -> Bool)
-> (Reference -> Reference -> Bool) -> Eq Reference
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Reference -> Reference -> Bool
$c/= :: Reference -> Reference -> Bool
== :: Reference -> Reference -> Bool
$c== :: Reference -> Reference -> Bool
Eq, Int -> Reference -> ShowS
[Reference] -> ShowS
Reference -> String
(Int -> Reference -> ShowS)
-> (Reference -> String)
-> ([Reference] -> ShowS)
-> Show Reference
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Reference] -> ShowS
$cshowList :: [Reference] -> ShowS
show :: Reference -> String
$cshow :: Reference -> String
showsPrec :: Int -> Reference -> ShowS
$cshowsPrec :: Int -> Reference -> ShowS
Show)

parseSymbolRefs :: [Block] -> HashMap Text Reference
parseSymbolRefs :: [Block] -> HashMap Text Reference
parseSymbolRefs = HashMap Text Reference -> [Tag Text] -> HashMap Text Reference
go HashMap Text Reference
forall a. Monoid a => a
mempty ([Tag Text] -> HashMap Text Reference)
-> ([Block] -> [Tag Text]) -> [Block] -> HashMap Text Reference
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Tag Text]] -> [Tag Text]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Tag Text]] -> [Tag Text])
-> ([Block] -> [[Tag Text]]) -> [Block] -> [Tag Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Block -> Maybe [Tag Text]) -> [Block] -> [[Tag Text]]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Block -> Maybe [Tag Text]
getHTML where
  getHTML :: Block -> Maybe ([Tag Text])
  getHTML :: Block -> Maybe [Tag Text]
getHTML (RawBlock (Format Text
x) Text
xs)
    | Text
x Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"html" = [Tag Text] -> Maybe [Tag Text]
forall a. a -> Maybe a
Just ((Tag Text -> [Tag Text]) -> [Tag Text] -> [Tag Text]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Tag Text -> [Tag Text]
forall str. StringLike str => Tag str -> [Tag str]
parseTags' (Text -> [Tag Text]
forall str. StringLike str => str -> [Tag str]
parseTags Text
xs))
  getHTML (BlockQuote [Block]
bs) = [Tag Text] -> Maybe [Tag Text]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Tag Text] -> Maybe [Tag Text])
-> ([[Tag Text]] -> [Tag Text]) -> [[Tag Text]] -> Maybe [Tag Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Tag Text]] -> [Tag Text]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Tag Text]] -> Maybe [Tag Text])
-> [[Tag Text]] -> Maybe [Tag Text]
forall a b. (a -> b) -> a -> b
$ (Block -> Maybe [Tag Text]) -> [Block] -> [[Tag Text]]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Block -> Maybe [Tag Text]
getHTML [Block]
bs
  getHTML (Div (Text, [Text], [(Text, Text)])
_ [Block]
bs) = [Tag Text] -> Maybe [Tag Text]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Tag Text] -> Maybe [Tag Text])
-> ([[Tag Text]] -> [Tag Text]) -> [[Tag Text]] -> Maybe [Tag Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Tag Text]] -> [Tag Text]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Tag Text]] -> Maybe [Tag Text])
-> [[Tag Text]] -> Maybe [Tag Text]
forall a b. (a -> b) -> a -> b
$ (Block -> Maybe [Tag Text]) -> [Block] -> [[Tag Text]]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Block -> Maybe [Tag Text]
getHTML [Block]
bs
  getHTML Block
_ = Maybe [Tag Text]
forall a. Maybe a
Nothing

  parseTags' :: Tag str -> [Tag str]
parseTags' (TagComment str
x) = str -> [Tag str]
forall str. StringLike str => str -> [Tag str]
parseTags str
x [Tag str] -> (Tag str -> [Tag str]) -> [Tag str]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Tag str -> [Tag str]
parseTags'
  parseTags' Tag str
t = Tag str -> [Tag str]
forall (f :: * -> *) a. Applicative f => a -> f a
pure Tag str
t

  go :: HashMap Text Reference -> [Tag Text] -> HashMap Text Reference
  go :: HashMap Text Reference -> [Tag Text] -> HashMap Text Reference
go HashMap Text Reference
map (TagOpen Text
a [(Text, Text)]
meta:TagText Text
t:TagClose Text
a':[Tag Text]
xs)
    | Text
a Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"a"
    , Text
a' Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
a
    -- , Just id <- lookup "id" meta
    , Just Text
cls <- Text -> [(Text, Text)] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"class" [(Text, Text)]
meta
    , Just Text
href <- Text -> [(Text, Text)] -> Maybe Text
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
"href" [(Text, Text)]
meta
    = HashMap Text Reference -> [Tag Text] -> HashMap Text Reference
go (Text
-> Reference -> HashMap Text Reference -> HashMap Text Reference
forall v. Text -> v -> HashMap Text v -> HashMap Text v
addIfNotPresent Text
t (Text -> Text -> Reference
Reference Text
href Text
cls) HashMap Text Reference
map) [Tag Text]
xs
    | Bool
otherwise = HashMap Text Reference -> [Tag Text] -> HashMap Text Reference
go HashMap Text Reference
map [Tag Text]
xs
    -- where
    --   tags = [ TagOpen "span" [("class", "Agda")], TagOpen "a" meta', TagText t, TagClose "a", TagClose "span" ]
    --   meta' = filter ((/= "id") . fst) meta
  go HashMap Text Reference
map (Tag Text
_:[Tag Text]
xs) = HashMap Text Reference -> [Tag Text] -> HashMap Text Reference
go HashMap Text Reference
map [Tag Text]
xs
  go HashMap Text Reference
map [] = HashMap Text Reference
map

addIfNotPresent :: Text -> v -> HashMap Text v -> HashMap Text v
addIfNotPresent :: Text -> v -> HashMap Text v -> HashMap Text v
addIfNotPresent = (v -> v -> v) -> Text -> v -> HashMap Text v -> HashMap Text v
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> k -> v -> HashMap k v -> HashMap k v
HashMap.insertWith (\v
_ v
old -> v
old)