work

5 files changed, 321 insertions, 125 deletions

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: