{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes        #-}
{-# LANGUAGE BangPatterns #-}

module Blagda.Rename where

import           Agda.Utils.Functor ((<&>))
import           Blagda.Markdown (renderHTML5)
import           Blagda.Types
import           Data.Text (Text)
import qualified Data.Text as T
import           Text.HTML.TagSoup (Tag(TagOpen), parseTags)
import           Text.Pandoc.Definition
import           Text.Pandoc.Walk (walk)

rename :: (FilePath -> FilePath) -> [Post Pandoc a] -> [Post Pandoc a]
rename :: (FilePath -> FilePath) -> [Post Pandoc a] -> [Post Pandoc a]
rename FilePath -> FilePath
f [Post Pandoc a]
posts = do
  let rn :: Text -> Text
rn Text
fp =
        let segs :: [Text]
segs = (Char -> Bool) -> Text -> [Text]
T.split ((Char -> FilePath -> Bool) -> FilePath -> Char -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip Char -> FilePath -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem [Char
'?', Char
'#']) Text
fp
         in Text -> [Text] -> Text
T.intercalate Text
"#" ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ [Text] -> (Text -> Text) -> [Text]
forall a. [a] -> (a -> a) -> [a]
onHead [Text]
segs ((Text -> Text) -> [Text]) -> (Text -> Text) -> [Text]
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack (FilePath -> Text) -> (Text -> FilePath) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath
f (FilePath -> FilePath) -> (Text -> FilePath) -> Text -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FilePath
T.unpack
  Post Pandoc a
p <- [Post Pandoc a]
posts
  let res :: Pandoc
res = (Block -> Block) -> Pandoc -> Pandoc
forall a b. Walkable a b => (a -> a) -> b -> b
walk ((Text -> Text) -> Block -> Block
replaceBlock Text -> Text
rn) (Pandoc -> Pandoc) -> Pandoc -> Pandoc
forall a b. (a -> b) -> a -> b
$ (Inline -> Inline) -> Pandoc -> Pandoc
forall a b. Walkable a b => (a -> a) -> b -> b
walk ((Text -> Text) -> Inline -> Inline
replaceInline Text -> Text
rn) (Pandoc -> Pandoc) -> Pandoc -> Pandoc
forall a b. (a -> b) -> a -> b
$ Post Pandoc a -> Pandoc
forall contents meta. Post contents meta -> contents
p_contents Post Pandoc a
p
  Post Pandoc a -> [Post Pandoc a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Post Pandoc a -> [Post Pandoc a])
-> Post Pandoc a -> [Post Pandoc a]
forall a b. (a -> b) -> a -> b
$ Post Pandoc a
p
    { p_path :: FilePath
p_path = FilePath -> FilePath
f (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ Post Pandoc a -> FilePath
forall contents meta. Post contents meta -> FilePath
p_path Post Pandoc a
p
    , p_contents :: Pandoc
p_contents = Pandoc
res
    }

onHead :: [a] -> (a -> a) -> [a]
onHead :: [a] -> (a -> a) -> [a]
onHead [] a -> a
_ = []
onHead (a
a : [a]
as) a -> a
faa = a -> a
faa a
a a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a]
as

replaceInline :: (Text -> Text) -> Inline -> Inline
replaceInline :: (Text -> Text) -> Inline -> Inline
replaceInline Text -> Text
f (Link Attr
attrs [Inline]
txt (Text
url, Text
tg))
  = Attr -> [Inline] -> (Text, Text) -> Inline
Link Attr
attrs [Inline]
txt (Text -> Text
f Text
url, Text
tg)
replaceInline Text -> Text
f (RawInline (Format Text
"html") Text
t)
  = Format -> Text -> Inline
RawInline Format
"html" (Text -> Inline) -> Text -> Inline
forall a b. (a -> b) -> a -> b
$ (Text -> Text) -> Text -> Text
replaceHtml Text -> Text
f Text
t
replaceInline Text -> Text
_ Inline
i = Inline
i

replaceBlock :: (Text -> Text) -> Block -> Block
replaceBlock :: (Text -> Text) -> Block -> Block
replaceBlock Text -> Text
f (RawBlock (Format Text
"html") Text
t) = Format -> Text -> Block
RawBlock Format
"html" (Text -> Block) -> Text -> Block
forall a b. (a -> b) -> a -> b
$ (Text -> Text) -> Text -> Text
replaceHtml Text -> Text
f Text
t
replaceBlock Text -> Text
_ Block
i = Block
i

replaceHtml :: (Text -> Text) -> Text -> Text
replaceHtml :: (Text -> Text) -> Text -> Text
replaceHtml Text -> Text
f Text
t =
  let tags :: [Tag Text]
tags = Text -> [Tag Text]
forall str. StringLike str => str -> [Tag str]
parseTags Text
t
   in [Tag Text] -> Text
renderHTML5 ([Tag Text] -> Text) -> [Tag Text] -> Text
forall a b. (a -> b) -> a -> b
$ [Tag Text]
tags [Tag Text] -> (Tag Text -> Tag Text) -> [Tag Text]
forall (m :: * -> *) a b. Functor m => m a -> (a -> b) -> m b
<&> \case
        TagOpen Text
"a" [(Text, Text)]
as -> Text -> [(Text, Text)] -> Tag Text
forall str. str -> [Attribute str] -> Tag str
TagOpen Text
"a" ([(Text, Text)] -> Tag Text) -> [(Text, Text)] -> Tag Text
forall a b. (a -> b) -> a -> b
$ [(Text, Text)]
as [(Text, Text)] -> ((Text, Text) -> (Text, Text)) -> [(Text, Text)]
forall (m :: * -> *) a b. Functor m => m a -> (a -> b) -> m b
<&> (Text -> Text) -> (Text, Text) -> (Text, Text)
replaceAttr Text -> Text
f
        Tag Text
x -> Tag Text
x

replaceAttr :: (Text -> Text) -> (Text, Text) -> (Text, Text)
replaceAttr :: (Text -> Text) -> (Text, Text) -> (Text, Text)
replaceAttr Text -> Text
f (Text
"href", Text
v) = (Text
"href", Text -> Text
f Text
v)
replaceAttr Text -> Text
_ (Text, Text)
kv = (Text, Text)
kv