From cc90d67ee353ca62aba43a3dfb4733b12bb72de9 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Tue, 25 Oct 2022 14:59:49 +0200 Subject: work --- hs/Files.hs | 58 ++++++++++ hs/Handlingar.hs | 12 ++- hs/Html.hs | 319 ++++++++++++++++++++++++++++++++++--------------------- hs/Links.hs | 55 ++++++++++ hs/vimwiki.cabal | 2 + 5 files changed, 321 insertions(+), 125 deletions(-) create mode 100644 hs/Files.hs create mode 100644 hs/Links.hs diff --git a/hs/Files.hs b/hs/Files.hs new file mode 100644 index 0000000..1f85297 --- /dev/null +++ b/hs/Files.hs @@ -0,0 +1,58 @@ +module Files +( mkdirP +, fileTree +, isFiletype +) where + +import System.Directory hiding (isSymbolicLink) +import System.Posix.Files + ( FileStatus + , getFileStatus + , isBlockDevice + , isCharacterDevice + , isDirectory + , isNamedPipe + , isRegularFile + , isSocket + , isSymbolicLink + ) +import System.FilePath + ( joinPath + , takeExtension + ) + +import Data.List.Extra (snoc) + +mkdirP = createDirectoryIfMissing True + +fmt :: FileStatus -> String +fmt st | isBlockDevice st = "block" + | isCharacterDevice st = "char" + | isNamedPipe st = "pipe" + | isRegularFile st = "regular" + | isDirectory st = "directory" + | isSymbolicLink st = "symlink" + | isSocket st = "socket" + | otherwise = "UNKNOWN" + +instance Show FileStatus where + show st = fmt st + +fileTree :: [FilePath] -> IO [(FileStatus, [FilePath])] +fileTree base = do + items <- listDirectory (joinPath base) + concat <$> + mapM (\entry -> do + let here = snoc base entry + let path = joinPath here + st <- getFileStatus path + let d = (st, here) + if isDirectory st + then (d :) <$> fileTree here + else return [ d ] + ) items + +isFiletype :: String -> FileStatus -> [FilePath] -> Bool +isFiletype extension st path + = isRegularFile st && (takeExtension . last $ path) == ('.' : extension) + diff --git a/hs/Handlingar.hs b/hs/Handlingar.hs index ea6e1cb..36d1a35 100644 --- a/hs/Handlingar.hs +++ b/hs/Handlingar.hs @@ -18,21 +18,27 @@ import Data.Default (def) import qualified Data.Text.IO as T +oneOf :: (a -> Bool) -> (a -> Bool) -> a -> Bool +oneOf f g x = f x || g x + + +-- Find the first heading matching text in the block findHeading :: Text -> Block -> Bool findHeading target (Header _ (text, _, _) _) = target == text findHeading _ _ = False -oneOf :: (a -> Bool) -> (a -> Bool) -> a -> Bool -oneOf f g x = f x || g x - +-- Find the first heading exactly matching level in block findHeadingByLevel :: Int -> Block -> Bool findHeadingByLevel target (Header level _ _) = target == level findHeadingByLevel _ _ = False +-- Find the first horizontal rule tag in block findHorizontalRule :: Block -> Bool findHorizontalRule HorizontalRule = True findHorizontalRule _ = False +-- Return the level of a heading +-- Can only be called on Blocks which are Header's headingLevel :: Block -> Int headingLevel (Header level _ _) = level headingLevel _ = error "Need header" diff --git a/hs/Html.hs b/hs/Html.hs index a8c6c68..2a9d1e1 100644 --- a/hs/Html.hs +++ b/hs/Html.hs @@ -1,102 +1,98 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings + , ImportQualifiedPost + , ScopedTypeVariables + #-} module Html ( main ) where -import System.Directory hiding (isSymbolicLink) -import System.Posix.Files - ( FileStatus - , getFileStatus - , isBlockDevice - , isCharacterDevice - , isDirectory - , isNamedPipe - , isRegularFile - , isSocket - , isSymbolicLink - ) -import Data.List.Extra ({-takeEnd, -}snoc, isPrefixOf) import System.FilePath ( joinPath - -- , addExtension - -- , dropExtension , takeDirectory - , takeExtension - -- , replaceExtension , () - , (-<.>)) + , (-<.>) + , (<.>) + , hasExtension + , dropExtension + , takeBaseName + ) import Text.Pandoc ( PandocMonad , PandocIO -- , ReaderOptions( readerStandalone -- ) - , WriterOptions( writerTemplate - , writerTableOfContents - , writerVariables - ) + -- , WriterOptions( writerTemplate + -- , writerTableOfContents + -- , writerVariables + -- ) , runIOorExplode -- , compileDefaultTemplate - , compileTemplate - , getTemplate + -- , compileTemplate + -- , getTemplate , writeHtml5 , readVimwiki , toLang , setTranslations ) -import Data.Default (def) +-- import Text.Pandoc.Class +-- ( getsCommonState +-- , CommonState(stLog) +-- ) + +import Text.Pandoc.Shared (stringify) + +import Text.Pandoc.Writers.Shared + ( toTableOfContents + , lookupMetaString + ) + import Data.Text (Text, unpack, pack) -import qualified Data.Text.IO as T +import Data.Text.IO qualified as T import Data.Text.Lazy (toStrict) -import Network.URI (parseURI, uriPath) +import Network.URI (parseURI, uriPath, uriScheme, URI) +import Data.Maybe (listToMaybe) import Control.Monad.IO.Class (liftIO) +import Data.Default (def) + -- import Text.Blaze -import Text.Blaze.Html (Html) +import Text.Blaze.Html () import Text.Blaze.Html.Renderer.Text (renderHtml) import Text.Pandoc.Walk ( Walkable (..) , walk ) -import Text.Pandoc.Builder +import Text.Blaze.Html5 hiding (main, html) +import Text.Blaze.Html5 qualified as H +import Text.Blaze.Html5.Attributes +import Text.Blaze.Html5.Attributes qualified as A + +import Text.Pandoc.Definition + ( Pandoc (Pandoc) + , Inline (..) + , Block (..) + , Format(Format) + ) +-- import Text.Pandoc.Builder + +import Files +import Links +-- import Text.DocTemplates (Context(..), ToContext(toVal)) +import Data.Map qualified as M +import Data.Set (Set) +import Data.Set qualified as S -import Text.DocTemplates (Context(..), ToContext(toVal)) -import qualified Data.Map as M (&) = flip ($) -mkdirP = createDirectoryIfMissing True - -fmt :: FileStatus -> String -fmt st | isBlockDevice st = "block" - | isCharacterDevice st = "char" - | isNamedPipe st = "pipe" - | isRegularFile st = "regular" - | isDirectory st = "directory" - | isSymbolicLink st = "symlink" - | isSocket st = "socket" - | otherwise = "UNKNOWN" - -instance Show FileStatus where - show st = fmt st - -fileTree :: [FilePath] -> IO [(FileStatus, [FilePath])] -fileTree base = do - items <- listDirectory (joinPath base) - concat <$> - mapM (\entry -> do - let here = snoc base entry - let path = joinPath here - st <- getFileStatus path - let d = (st, here) - if isDirectory st - then (d :) <$> fileTree here - else return [ d ] - ) items - -isWikiFile st path = isRegularFile st && (takeExtension . last $ path) == ".wiki" +isWikiFile = isFiletype "wiki" + +-- TODO +-- Colorful headers? +-- All headers should link to themselves {- vimwikiToHTML :: Text -> IO Text @@ -111,20 +107,35 @@ vimwikiToHTML txt = do return $ toStrict . renderHtml $ html -} -handleWikilink :: Inline -> Inline -handleWikilink l@(Link attributes body (url, title)) - | isPrefixOf "mail:" (unpack url) = - case parseURI . unpack $ url of - Just uri -> Link attributes body (pack $ "http://localhost:8090/?id=" <> (uriPath uri), title) - Nothing -> l - -- TODO don't do this for inter-page links - | otherwise = Link attributes body (url <> ".html", title) -handleWikilink l = l - -rebuildLinks l@(Link _ _ (_, title)) - | title == "wikilink" = handleWikilink l - | otherwise = l -rebuildLinks other = other +type UrlRewriter = [Inline] -> URI -> ([Inline], Text) + +mailRewriter :: UrlRewriter +mailRewriter body uri = (body, pack $ "http://localhost:8090/?id=" <> (uriPath uri)) + +urlRewrites :: M.Map String UrlRewriter +urlRewrites = M.fromList [("mail", mailRewriter)] + + +-- -- TODO don't do this for inter-page links +-- | otherwise = Link attributes body (url <> ".html", title) + +fixExtension url + | hasExtension url = url + | otherwise = url <.> "html" + +rebuildLinks :: Inline -> Inline +rebuildLinks l@(Link attributes body (url, title@"wikilink")) + = case parseURI . unpack $ url of + Just uri -> case M.lookup (init . uriScheme $ uri) urlRewrites of + Just proc -> (proc body uri) & (\(body, url) -> Link attributes body (url, title)) + Nothing -> l -- Link attributes body (url <> ".html", title) + Nothing -> case break (== '#') (unpack url) of + ("", '#':_) -> Link attributes body (url, title) + (page, "") -> Link attributes body (pack $ fixExtension page, title) + (page, '#':local) -> Link attributes body (pack $ fixExtension page <> "#" <> local, title) + _ -> l +rebuildLinks l = l + -- Link ("",[],[]) [Str "#M\246te 7"] ("#M\246te 7","wikilink") -- Link ("",[],[]) [Str "https://styrdokument.liu.se/Regelsamling/Fil/1513619"] ("https://styrdokument.liu.se/Regelsamling/Fil/1513619","") -- Link ("",[],[]) [Str "Beslut",Space,Str "LIU-2020-02033"] ("file:LinTek/2021/Beslut om riktlinjer och rutiner f\246r genomf\246rande av skriftliga salsskrivningar inklusive digitala tent.pdf","wikilink") @@ -151,7 +162,7 @@ applyFilters pandoc = pandoc & walk buildCheckboxes & walk buildCheckboxes' -handleSourceText :: PandocMonad m => Text -> m Html +handleSourceText :: PandocMonad m => Text -> m Pandoc handleSourceText text = do pandoc <- readVimwiki def text @@ -167,11 +178,11 @@ handleSourceText text = do let pandoc' = pandoc & applyFilters - & setTitle (str "Some form of title") - & setAuthors [ str "Hugo Hörnquist" ] - & setDate (str "2022-01-26") + -- & setTitle (str "Some form of title") + -- & setAuthors [ str "Hugo Hörnquist" ] + -- & setDate (str "2022-01-26") - template <- compileDefaultTemplate "html5" + -- template <- compileDefaultTemplate "html5" {- templateData <- getTemplate "template.html5" template' <- compileTemplate "template.html5" templateData @@ -180,26 +191,86 @@ handleSourceText text = do Right template -> return template -} - let htmlAttr = def { writerTemplate = Just template - -- Table of content only works if document - -- looks like expected - , writerTableOfContents = True - , writerVariables = Context $ M.fromList - -- Needed to generate header for TOC - [ ("toc-title", toVal ("Table of Contents"::Text)) - -- setting this removes some default styles... - , ("css", toVal ["style.css"::Text]) - ] - } - -- TODO this warns "[WARNING] The term Abstract has no translation defined" - writeHtml5 htmlAttr pandoc' + return pandoc' + +-- Accumulate all sub-sequences, +-- For example, accumulate [1,2,3] == [[1], [1, 2], [1, 2, 3]] +accumulate :: [a] -> [[a]] +accumulate [] = [] +accumulate (x:xs) = (x:) <$> ([]:accumulate xs) + +-- Insert element at every other position of list +intersperse :: a -> [a] -> [a] +intersperse _ [] = [] +intersperse _ [x] = [x] +intersperse y (x:xs) = x : y : intersperse y xs + +joinBy :: Monoid a => a -> [a] -> a +joinBy delim lst = mconcat $ intersperse delim lst -- Becomes wikilink when the URI scheme doesn't match one of -- Text.Pandoc.Shared (schemes) -- Link (_,_,_) _ (_, "wikilink") -handlePart :: FilePath -> [FilePath] -> PandocIO () -handlePart wiki_root parts = do +breadcrumbLinks :: [FilePath] -> [String] +breadcrumbLinks parts = f <$> (accumulate $ "/tmp/wiki" : parts) + where f parts = joinBy "/" parts -<.> "html" + +buildBreadcrumbs :: [String] -> [Html] +-- TODO replace leading string with wiki root +buildBreadcrumbs links = f <$> links + where f :: String -> Html + f link = H.a ! href (textValue . pack $ link) + $ H.string (takeBaseName link) + + +htmlWrap :: String -> [FilePath] -> Html -> Html -> Html -> Html +htmlWrap title parts backlinks toc main = docTypeHtml $ do + H.head $ do + H.meta ! charset "utf-8" + H.meta ! name "generator" ! content "pandoc" + H.meta ! name "viewport" ! content "width=device-width, initial-scale=1.0, user-scalable=yes" + H.link ! rel "stylesheet" ! href "/tmp/wiki/style.css" + H.title $ H.string $ title <> " — Vimwiki" + H.body $ do + -- H.header {} + H.nav ! A.id "TOC" ! role "doc-toc" $ do + H.h2 ! A.id "toc-title" $ "Table of Contents" + toc + H.nav ! A.id "breadcrumb" $ do + let bc = (buildBreadcrumbs . breadcrumbLinks $ init parts) + -- TODO replace /tmp/wiki with wiki-base + let all = [ H.a ! href "/tmp/wiki/index.html" $ "⌂" ] ++ tail bc ++ [ H.span $ H.string . takeBaseName . last $ parts ] + mconcat $ intersperse (H.string "»") all + H.main $ main + H.footer $ do + backlinks + + +firstJust :: a -> [Maybe a] -> a +firstJust x [] = x +firstJust _ (Just x:_) = x +firstJust x (_:xs) = firstJust x xs + + +allHeaders :: Pandoc -> [Block] +allHeaders = query f + where f h@(Header {}) = [h] + f _ = [] + +headerContent :: Block -> Maybe Text +headerContent (Header _ _ inlines) = Just $ stringify inlines +headerContent _ = Nothing + + +nullToMaybe :: (Eq a, Monoid a) => a -> Maybe a +nullToMaybe m + | m == mempty = Nothing + | otherwise = Just m + + +handlePart :: M.Map Text (Set FilePath) -> FilePath -> [FilePath] -> PandocIO () +handlePart backlinks wiki_root parts = do let item_path = joinPath parts let inTarget = wiki_root item_path let outTarget = "/tmp/wiki" item_path -<.> "html" @@ -207,43 +278,47 @@ handlePart wiki_root parts = do text <- liftIO $ T.readFile inTarget - html <- handleSourceText text - let htmlString = toStrict . renderHtml $ html - liftIO $ T.writeFile outTarget htmlString - -extractLink :: Inline -> [Inline] -extractLink l@(Link {}) = [l] -extractLink _ = [] + bl <- case M.lookup (pack . dropExtension $ item_path) backlinks of + Just links -> return $ (H.h2 . H.string $ "Backlinks") + <> (H.ul . mconcat $ (H.li . toHtml) <$> (S.toList links)) + Nothing -> return $ H.b "No backlinks" -findLinks :: FilePath -> [FilePath] -> PandocIO (FilePath, [Inline]) -findLinks wiki_root parts = do - let item_path = joinPath parts - let inTarget = wiki_root item_path - text <- liftIO $ T.readFile inTarget - - pandoc <- readVimwiki def text - - return (item_path, query extractLink pandoc) - - -- let htmlString = toStrict . renderHtml $ html - -- liftIO $ T.writeFile outTarget htmlString + pandoc <- handleSourceText text + let Pandoc meta blocks = pandoc + toc <- writeHtml5 def $ Pandoc meta $ [toTableOfContents def blocks] + -- writeHtml5 htmlAttr pandoc + html <- writeHtml5 def pandoc + -- Since we (explicitly) don't reset the state between invocations + -- the list of log entries continues to grow. We could check if + -- before and after, and check if it is langer + -- log <- getsCommonState stLog + -- liftIO $ print meta + let title :: Text = firstJust (pack $ takeBaseName item_path) + [ nullToMaybe $ lookupMetaString "title" meta + , headerContent =<< (listToMaybe $ allHeaders pandoc) + ] + + -- liftIO $ print log + let htmlString = toStrict . renderHtml . htmlWrap (unpack title) parts bl toc $ html + liftIO $ T.writeFile outTarget htmlString -buildBacklinkSet :: FilePath -> [Inline] -> M.Map Inline [FilePath] -buildBacklinkSet source targets = foldr (M.alter f) M.empty targets - where f Nothing = Just [source] - f (Just lst) = Just (source:lst) main = do - let wiki_root = "/home/hugo/wiki/test" + let wiki_root = "/home/hugo/wiki/private" + -- wiki_files :: [(FileStatus, [FilePath])] wiki_files <- filter (uncurry isWikiFile) <$> fileTree [ wiki_root ] + -- TODO copy remaining files verbatim + -- st <- getFileStatus $ wiki_root "Vimwiki.wiki" + -- wiki_files <- return $ [(st, snoc [ wiki_root ] "Vimwiki.wiki")] let relative_paths = tail . snd <$> wiki_files -- What each page links to -- forwardLinks :: [(FilePath, [String])] forwardLinks <- runIOorExplode $ mapM (findLinks wiki_root) relative_paths - let backLinks = M.unions $ uncurry buildBacklinkSet <$> forwardLinks + let backlinks = M.unions $ uncurry buildBacklinkSet <$> forwardLinks + --print backlinks runIOorExplode $ do mlang <- toLang $ Just "sv-SE" @@ -251,5 +326,5 @@ main = do Nothing -> return () Just l -> setTranslations l - mapM_ (handlePart wiki_root) relative_paths + mapM_ (handlePart backlinks wiki_root) relative_paths -- mapM_ (putStrLn . show) wiki_files diff --git a/hs/Links.hs b/hs/Links.hs new file mode 100644 index 0000000..cb8fd27 --- /dev/null +++ b/hs/Links.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE OverloadedStrings + , ImportQualifiedPost + #-} + +module Links +( extractLinks +, findLinks +, buildBacklinkSet +) where + +import Control.Monad.IO.Class (liftIO) + +import Data.Default (def) + +import Data.Map qualified as M + +import Data.Set (Set) +import Data.Set qualified as S + +import Data.Text (Text) +import Data.Text.IO qualified as T + +import System.FilePath (joinPath, ()) + +import Text.Pandoc (PandocIO, readVimwiki) +import Text.Pandoc.Definition (Pandoc, Inline (Link)) +import Text.Pandoc.Walk (query) + + +-- Find all wikilinks in the given document +extractLinks :: Pandoc -> [Text] +extractLinks = query extractLink + where extractLink :: Inline -> [Text] + extractLink (Link _ _ (target, "wikilink")) = [target] + extractLink _ = [] + + +findLinks :: FilePath -> [FilePath] -> PandocIO (FilePath, [Text]) +findLinks wiki_root parts = do + let item_path = joinPath parts + let inTarget = wiki_root item_path + text <- liftIO $ T.readFile inTarget + + pandoc <- readVimwiki def text + + return (item_path, extractLinks pandoc) + + -- let htmlString = toStrict . renderHtml $ html + -- liftIO $ T.writeFile outTarget htmlString + + +buildBacklinkSet :: FilePath -> [Text] -> M.Map Text (Set FilePath) +buildBacklinkSet source targets = foldr (M.alter f) M.empty targets + where f Nothing = Just $ S.singleton source + f (Just lst) = Just $ S.insert source lst diff --git a/hs/vimwiki.cabal b/hs/vimwiki.cabal index eb84aeb..850461e 100644 --- a/hs/vimwiki.cabal +++ b/hs/vimwiki.cabal @@ -27,6 +27,8 @@ executable Main -Wno-orphans -Wno-type-defaults other-modules: + Files, + Links, Html, Handlingar build-depends: -- cgit v1.2.3