{-# 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