work

4 files changed, 337 insertions, 112 deletions

diff --git a/hs/Handlingar.hs b/hs/Handlingar.hs
new file mode 100644
index 0000000..ea6e1cb
--- /dev/null
+++ b/hs/Handlingar.hs
@@ -0,0 +1,64 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Handlingar
+( main
+) where
+
+import Text.Pandoc
+    ( runIOorExplode
+    , readVimwiki
+    )
+import Text.Pandoc.Builder
+import Data.Text (Text, pack)
+import Text.Show.Pretty (pPrintList)
+import System.Environment (getArgs)
+import Data.Default (def)
+
+
+import qualified Data.Text.IO as T
+
+
+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
+
+findHeadingByLevel :: Int -> Block -> Bool
+findHeadingByLevel target (Header level _ _) = target == level
+findHeadingByLevel _ _ = False
+
+findHorizontalRule :: Block -> Bool
+findHorizontalRule HorizontalRule = True
+findHorizontalRule _ = False
+
+headingLevel :: Block -> Int
+headingLevel (Header level _ _) = level
+headingLevel _ = error "Need header"
+
+getHeadingData :: Text -> [Block] -> [Block]
+getHeadingData heading blocks =
+    let (head:remaining) = dropWhile (not . findHeading heading) blocks
+        items = takeWhile (not . (oneOf (findHorizontalRule)
+                                        (findHeadingByLevel $ headingLevel head)))
+                          remaining
+    in head : items
+
+
+main = do
+    args <- getArgs
+    case args of
+        [file, heading] -> do
+            putStrLn $ "Heading = " <> heading
+            text <- T.readFile file
+
+            -- html <- handleSourceText text
+            pandoc <- runIOorExplode $ readVimwiki def text
+            let Pandoc _ blocks = pandoc
+            -- putStr . valToStr $ blocks
+            pPrintList $ getHeadingData (pack heading) blocks
+            -- let htmlString = toStrict . renderHtml $ html
+            -- liftIO $ T.writeFile outTarget htmlString
+        _ -> error "Invalid command line"
+            
diff --git a/hs/Html.hs b/hs/Html.hs
new file mode 100644
index 0000000..a8c6c68
--- /dev/null
+++ b/hs/Html.hs
@@ -0,0 +1,255 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+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
+    , (</>)
+    , (-<.>))
+import Text.Pandoc
+    ( PandocMonad
+    , PandocIO
+    -- , ReaderOptions( readerStandalone
+    --                )
+    , WriterOptions( writerTemplate
+                   , writerTableOfContents
+                   , writerVariables
+                   )
+    , runIOorExplode
+    -- , compileDefaultTemplate
+    , compileTemplate
+    , getTemplate
+    , writeHtml5
+    , readVimwiki
+    , toLang
+    , setTranslations
+    )
+
+import Data.Default (def)
+import Data.Text (Text, unpack, pack)
+import qualified Data.Text.IO as T
+import Data.Text.Lazy (toStrict)
+import Network.URI (parseURI, uriPath)
+
+import Control.Monad.IO.Class (liftIO)
+
+-- import Text.Blaze
+import Text.Blaze.Html (Html)
+import Text.Blaze.Html.Renderer.Text (renderHtml)
+import Text.Pandoc.Walk
+    ( Walkable (..)
+    , walk )
+
+import Text.Pandoc.Builder
+
+
+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"
+
+{-
+vimwikiToHTML :: Text -> IO Text
+-- vimwikiToHTML txt = runIOorExplode $ do
+--     pdoc <- readVimwiki def txt
+--     html <- writeHtml5 def pdoc
+--     return $ toStrict . renderHtml $ html
+vimwikiToHTML txt = do
+    pdoc <- runIOorExplode $ readVimwiki def txt
+    print pdoc
+    html <- runIOorExplode $ writeHtml5 def pdoc
+    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
+-- 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")
+
+-- buildCheckboxes s@(Span (ids, cls, kvs) _)
+buildCheckboxes s@(Span (_, cls, _) _)
+    | "done0" `elem` cls = RawInline (Format "html") "<input type='checkbox' disabled='true'/>"
+    | "done1" `elem` cls = RawInline (Format "html") "<input type='checkbox' disabled='true'/>"
+    | "done2" `elem` cls = RawInline (Format "html") "<input type='checkbox' disabled='true'/>"
+    | "done3" `elem` cls = RawInline (Format "html") "<input type='checkbox' disabled='true'/>"
+    | "done4" `elem` cls = RawInline (Format "html") "<input type='checkbox' disabled='true' checked/>"
+    | otherwise = s
+buildCheckboxes l = l
+
+buildCheckboxes' (Plain (Str "[-]" : Space : xs)) = Plain
+    [ RawInline (Format "html") "<input type='checkbox' disabled='true' checked/>"
+    , Strikeout xs
+    ]
+buildCheckboxes' l = l
+
+applyFilters :: Pandoc -> Pandoc
+applyFilters pandoc = pandoc
+                    & walk rebuildLinks
+                    & walk buildCheckboxes
+                    & walk buildCheckboxes'
+
+handleSourceText :: PandocMonad m => Text -> m Html
+handleSourceText text = do
+    pandoc <- readVimwiki def text
+
+    --runIO $ print . show $ pandoc
+    -- Pandoc (Meta {unMeta = fromList [ ("date",MetaInlines [Str "2000-01-01"])
+    --                                 , ("title",MetaInlines [Str "Custom",Space,Str "Title"])]})
+    --         [ Header 1 ("Test Wiki",[],[]) [Str "Test",Space,Str "Wiki"]
+    --         , Header 1 ("Generated Tags",[],[]) [Str "Generated",Space,Str "Tags"]]
+
+    let Pandoc meta blocks = pandoc
+    -- let pandoc = Pandoc (meta & setMeta "lang" ("sv-SE"::Text)) blocks
+    let pandoc = Pandoc meta blocks
+
+    let pandoc' = pandoc
+                & applyFilters
+                & setTitle (str "Some form of title")
+                & setAuthors [ str "Hugo Hörnquist" ]
+                & setDate (str "2022-01-26")
+
+    template <- compileDefaultTemplate "html5"
+    {-
+    templateData <- getTemplate "template.html5"
+    template' <- compileTemplate "template.html5" templateData
+    template <- case template' of
+      Left err       -> error err
+      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'
+
+-- 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
+    let item_path = joinPath parts
+    let inTarget  = wiki_root   </> item_path
+    let outTarget = "/tmp/wiki" </> item_path -<.> "html"
+    liftIO $ mkdirP . takeDirectory $ outTarget
+
+    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 _ = []
+
+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
+
+
+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"
+    wiki_files <- filter (uncurry isWikiFile) <$> fileTree [ wiki_root ]
+    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
+
+
+    runIOorExplode $ do
+        mlang <- toLang $ Just "sv-SE"
+        case mlang of
+            Nothing -> return ()
+            Just l -> setTranslations l
+
+        mapM_ (handlePart wiki_root) relative_paths
+    -- mapM_ (putStrLn . show) wiki_files
diff --git a/hs/main.hs b/hs/main.hs
index 227a7cd..1e76f0e 100644
--- a/hs/main.hs
+++ b/hs/main.hs
@@ -1,119 +1,19 @@
 {-# LANGUAGE OverloadedStrings #-}
 
-import System.Directory hiding (isSymbolicLink)
-import System.Posix.Files
-import Data.List.Extra (takeEnd, snoc)
-import System.FilePath (joinPath, addExtension, dropExtension, takeDirectory, takeExtension, replaceExtension, (</>), (-<.>))
-import Text.Pandoc
-import Data.Text (Text)
-import qualified Data.Text.IO as T
-import Data.Text.Lazy (toStrict)
+module Main where
 
-import Text.Blaze
-import Text.Blaze.Html
-import Text.Blaze.Html.Renderer.Text
-import Text.Pandoc.Walk
+import qualified Html
+-- import qualified Handlingar
 
-import Text.Pandoc.Builder
+main = Html.main
 
-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"
-
-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"
-
-vimwikiToHTML :: Text -> IO Text
--- vimwikiToHTML txt = runIOorExplode $ do
---     pdoc <- readVimwiki def txt
---     html <- writeHtml5 def pdoc
---     return $ toStrict . renderHtml $ html
-vimwikiToHTML txt = do
-    pdoc <- runIOorExplode $ readVimwiki def txt
-    print pdoc
-    html <- runIOorExplode $ writeHtml5 def pdoc
-    return $ toStrict . renderHtml $ html
-
-rebuildLinks l@(Link attributes body (url, title))
-    | title == "wikilink" = Link attributes body (url <> ".html", title)
-    | otherwise = l
-rebuildLinks other = other
--- 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")
-
-buildCheckboxes s@(Span (ids, cls, kvs) _)
-    | "done0" `elem` cls = RawInline (Format "html") "<input type='checkbox' disabled='true'/>"
-    | "done1" `elem` cls = RawInline (Format "html") "<input type='checkbox' disabled='true'/>"
-    | "done2" `elem` cls = RawInline (Format "html") "<input type='checkbox' disabled='true'/>"
-    | "done3" `elem` cls = RawInline (Format "html") "<input type='checkbox' disabled='true'/>"
-    | "done4" `elem` cls = RawInline (Format "html") "<input type='checkbox' disabled='true' checked/>"
-    | otherwise = s
-buildCheckboxes l = l
-
-main = do
-    let wiki_root = "/home/hugo/wiki/public"
-    wiki_files <- filter (uncurry isWikiFile) <$> fileTree [ wiki_root ]
-    mapM_ ((\parts -> do
-        print parts
-        let item_path = joinPath parts
-        let inTarget  = wiki_root   </> item_path
-        let outTarget = "/tmp/wiki" </> item_path -<.> "html"
-        mkdirP . takeDirectory $ outTarget
-        text <- T.readFile inTarget
-        pandoc <- runIOorExplode $ readVimwiki def {
-            readerStandalone = True
-        } text
-        let (Pandoc meta blocks) = pandoc
-                                 & walk rebuildLinks
-                                 & walk buildCheckboxes
-        -- let pandoc' = Pandoc meta [Div ("", ["main-content"], []) blocks]
-        let pandoc' = Pandoc meta blocks
-                    & setTitle (str "Some form of title")
-                    & setAuthors [ str "Hugo Hörnquist" ]
-                    & setDate (str "2022-01-26")
-        template <- runIOorExplode $ compileDefaultTemplate "html5"
-        let htmlAttr = def { writerTemplate = Just template
-                           -- Table of content only works if document
-                           -- looks like expected
-                           , writerTableOfContents = True
-                           , writerVariables = Context $ M.fromList 
-                                        [ ("toc-title", toVal ("Table of Contents"::Text))
-                                        -- setting this removes some default styles...
-                                        , ("css", toVal ["style.css"::Text])
-                                        ]
-                           }
-        html <- runIOorExplode $ writeHtml5 htmlAttr pandoc'
-        let htmlString = toStrict . renderHtml $ html
-        T.writeFile outTarget htmlString
-        -- >>= vimwikiToHTML >>= T.writeFile outTarget
-        ) . tail . snd) wiki_files
-    -- mapM_ (putStrLn . show) wiki_files
+-- TODO
+-- at top, trace to go back
+-- in footer,
+-- backlinks
+--
+-- Special url types
+-- - wn.public:
+-- - mail:
diff --git a/hs/vimwiki.cabal b/hs/vimwiki.cabal
index 339f0c3..eb84aeb 100644
--- a/hs/vimwiki.cabal
+++ b/hs/vimwiki.cabal
@@ -24,10 +24,14 @@ executable Main
       -Wno-name-shadowing
       -- this one is just silly
       -Wno-unused-do-bind
+      -Wno-orphans
       -Wno-type-defaults
   other-modules:
+    Html,
+    Handlingar
   build-depends:
     base >=4.9,
+    data-default,
     directory,
     filepath,
     unix,
@@ -38,5 +42,7 @@ executable Main
     blaze-markup,
     blaze-html,
     doctemplates,
+    network-uri,
+    pretty-show,
     extra
   default-language:    Haskell2010