work

2 files changed, 117 insertions, 20 deletions

diff --git a/hs/src/Handlingar.hs b/hs/src/Handlingar.hs
index a878da3..431e7a5 100644
--- a/hs/src/Handlingar.hs
+++ b/hs/src/Handlingar.hs
@@ -14,8 +14,9 @@ import Text.Pandoc
     , readVimwiki
     , WriterOptions(writerTemplate, writerVariables)
     , PandocMonad
+    , PandocIO
     , writePlain
-    , ReaderOptions
+    -- , ReaderOptions
     )
 import Text.Pandoc.Builder
 import Text.Pandoc.Writers.LaTeX (writeLaTeX)
@@ -23,7 +24,7 @@ import Text.Pandoc.Templates
     ( compileDefaultTemplate
     )
 import Text.Pandoc.Walk (walkM)
-import Data.Text (Text, pack, strip)
+import Data.Text (Text, pack, unpack, strip)
 import Data.Text.IO
     ( putStrLn
     , writeFile
@@ -32,24 +33,40 @@ import System.Environment (getArgs)
 import Data.Default (def)
 import Control.Monad.State.Lazy
 import Data.Text.Encoding.Base64 (encodeBase64)
-import Text.DocTemplates (toVal, Val(SimpleVal), Context(Context))
+import Text.DocTemplates (toVal, Val(SimpleVal, ListVal), Context(Context))
 
 import qualified Data.Text.IO as T
 import qualified Data.Map.Lazy as Map
+import System.Posix.Directory (changeWorkingDirectory, getWorkingDirectory)
+import System.Directory (makeAbsolute)
 
+import System.FilePath
+    ( dropFileName
+    , (<.>)
+    , takeExtension
+    )
+
+import Network.URI (parseURI, uriScheme, uriPath)
+import Network.URI.Encode (encodeWith, decode)
+import Data.Set (Set)
+import qualified Data.Set as Set
 
 oneOf :: (a -> Bool) -> (a -> Bool) -> a -> Bool
 oneOf f g x = f x || g x
 
+uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d
+uncurry3 f (a, b, c) = f a b c
+
+type AppendixItem = ([Inline], Text, Text)
 
 -- Find the first heading matching text in the block
 findHeading :: Text -> Block -> Bool
 findHeading target (Header _ (text, _, _) _) = target == text
 findHeading _ _ = False
 
--- Find the first heading exactly matching level in block
+-- Find the first heading equal to or "higher" than the target
 findHeadingByLevel :: Int -> Block -> Bool
-findHeadingByLevel target (Header level _ _) = target == level
+findHeadingByLevel target (Header level _ _) = target >= level
 findHeadingByLevel _ _ = False
 
 -- Find the first horizontal rule tag in block
@@ -63,13 +80,15 @@ headingLevel :: Block -> Int
 headingLevel (Header level _ _) = level
 headingLevel _ = error "Need header"
 
-getHeadingData :: Text -> [Block] -> [Block]
+getHeadingData :: Text -> [Block] -> Maybe [Block]
 getHeadingData heading blocks =
-    let (head:remaining) = dropWhile (not . findHeading heading) blocks
-        items = takeWhile (not . oneOf findHorizontalRule
+    case dropWhile (not . findHeading heading) blocks of
+        (head:remaining) -> Just $ head : items
+            where items = takeWhile (not . oneOf findHorizontalRule
+                                       -- TODO change to this level or above
                                        (findHeadingByLevel $ headingLevel head))
                           remaining
-    in head : items
+        _ -> Nothing
 
 extractKV :: PandocMonad m => [Inline] -> [[Block]] -> m (Text, Text)
 extractKV is bbs = do
@@ -88,20 +107,19 @@ handleBlocks (head:blocks) = do
 handleBlocks blocks = return ("Heading missing", [], blocks)
 
 buildPrimary :: PandocMonad m
-             => (ReaderOptions -> Text -> m Pandoc)
-             -> Text
-             -> Text
-             -> m (Pandoc, [([Inline], Text, Text)])
-buildPrimary reader heading text = do
-    Pandoc meta blocks <- reader def text
-    (heading, kvs, wantedBlocks') <- handleBlocks $ getHeadingData heading blocks
+             => Pandoc
+             -> m (Pandoc, [AppendixItem])
+buildPrimary (Pandoc meta blocks) = do
+    -- Pandoc meta blocks <- reader def text
+    -- let Just blocks = getHeadingData heading blocks
+    (heading, kvs, wantedBlocks') <- handleBlocks blocks
     let (pandoc, appendices) = replaceLinks $ Pandoc meta wantedBlocks'
 
     let pandoc' = foldl (flip . uncurry $ setMeta) pandoc
                 $ ("title", heading) : kvs
     return (pandoc', appendices)
 
-rewriteLink :: Inline -> State [([Inline], Text, Text)] Inline
+rewriteLink :: Inline -> State [AppendixItem] Inline
 rewriteLink (Link _ is (target, "wikilink")) = do
     let appendixRef = encodeBase64 target
     let txt = [ Str "(bilaga"
@@ -117,31 +135,109 @@ rewriteLink (Link _ is (target, "wikilink")) = do
     return lnk
 rewriteLink x = return x
 
-replaceLinks :: Pandoc -> (Pandoc, [([Inline], Text, Text)])
+replaceLinks :: Pandoc -> (Pandoc, [AppendixItem])
 replaceLinks = flip runState [] . walkM rewriteLink
 
+handleBilagaHeading :: [Inline] -> Text -> Block
+handleBilagaHeading is ref = Header 1 ("bilaga:" <> ref, [], []) is
+
+
+uriChars :: Set Char
+uriChars = Set.fromList $ ":/?#"  -- Allows us to modifiy existing URL
+                        <> "-._~" -- URL safe
+                        <> ['A'..'Z'] <> ['a'..'z'] <> ['0'..'9']
+
+getVimwikiPage :: FilePath -> PandocIO [Block]
+getVimwikiPage path = do
+    text <- liftIO $ T.readFile path
+    Pandoc _ blocks <- readVimwiki def text
+    return blocks
+
+(<&>) = flip (<$>)
+
+handleFile :: FilePath -> String -> PandocIO (Maybe [Block])
+handleFile fname ".txt" = do
+    text <- liftIO $ T.readFile fname
+    return . Just $ [CodeBlock ("", [], []) text]
+handleFile fname ".pdf" = do
+    aname <- liftIO $ makeAbsolute fname
+    let pagecmd = "\\thispagestyle{fancy}\\lhead{Bilaga \\Alph{section}.\\arabic{subsection}}"
+    let arg = "frame,pages={-},width=\\textwidth,pagecommand=" <> pagecmd
+    let lines = [ "\\phantomsection\\stepcounter{subsection}\\includepdf[" <> arg <> "]{" <> decode aname <> "}"
+                ]
+    let inline = RawInline
+                 (Format "latex")
+                 (pack $ unlines lines)
+    return . Just $ [ Plain [ inline ] ]
+handleFile fname _ = return . Just $ [Para [Str . pack $ fname]]
+
+-- See also: Html rebuildLinks
+handleBilaga :: [Block] -> Text -> PandocIO (Maybe [Block])
+handleBilaga currentPage url = case parseURI . encodeWith (`elem` uriChars) . unpack $ url of
+    Just uri -> case uriScheme uri of
+                    ('w':'n':'.':wikiname) -> return . Just $ [Para [Str $ "Interwiki" <> pack wikiname]]
+                    "file:" -> do
+                        let fname = uriPath uri
+                        handleFile fname $ takeExtension fname
+                    "mail:" -> return $ Just [ Para [ Str "A mail would have gone here" ]]
+                    _ -> return $ Just [Para [Str . pack . show $ uri]]
+    Nothing  -> case break (== '#') (unpack url) of
+        ("", '#':frag)   -> return $ getHeadingData (pack frag) currentPage
+        (page, '#':frag) -> getVimwikiPage (page <.> "wiki") <&> getHeadingData (pack frag)
+        (page, "")       -> Just <$> getVimwikiPage (page <.> "wiki")
+        _                -> return $ Just [Para [Str "ERROR"]]
+
+f :: [Block] -> [Inline] -> Text -> Text -> PandocIO [Block]
+f bs is a b = do
+    let bg = handleBilagaHeading is a
+    mxs <- handleBilaga bs b
+    case mxs of
+        Just xs -> return $ bg : xs
+        Nothing -> return []
+
+-- renumber :: Int -> [Blocks] -> [Blocks]
+
 main = do
     args <- getArgs
     case args of
         [file, heading] -> do
 
+            cwd <- getWorkingDirectory
+            changeWorkingDirectory  (dropFileName file)
+
             text <- T.readFile file
 
+            -- let workdir = dropFileName file
+
             tex <- runIOorExplode $ do
                 texTemplate <- compileDefaultTemplate "latex"
-                (Pandoc meta bs, appendices) <- buildPrimary readVimwiki (pack heading) text
-                let apx = reverse appendices >>= (\(is, a, b) -> [Header 1 ("bilaga:" <> a, [], []) is, Plain [Str b]])
+                Pandoc m' og_bs <- readVimwiki def text
+                let Just better_blocks = getHeadingData (pack heading) og_bs
+                -- TODO limit to only relevant heading
+                (Pandoc meta bs, appendices) <- buildPrimary (Pandoc m' better_blocks)
+                -- apx <- mconcat $ mapM handleBilaga $ reverse appendicies
+                -- TODO this bs should be the initial source, NOT
+                -- the result of buildPrimary
+                fragments <- mapM (uncurry3 (f og_bs)) $ reverse appendices
+                let apx = mconcat fragments
                 let trail = [ RawBlock (Format "latex") "\\appendix" ] <> apx
                 let content = Pandoc meta $ bs <> trail
+                let packages = [ "pdfpages"
+                               , "fancyhdr"
+                               ]
+                let headerIncludes = [ SimpleVal $ "\\usepackage{" <> package <> "}"
+                                     | package <- packages]
                 let opts = [ ("boxlinks",       toVal True)
                            , ("colorlinks",     toVal True)
                            , ("papersize",      SimpleVal "a4")
                            , ("numbersections", toVal True)
                            , ("lang",           SimpleVal "swedish")
+                           , ("header-includes",  ListVal headerIncludes)
                            ]
                 writeLaTeX (def { writerTemplate = Just texTemplate
                                 , writerVariables = Context $ Map.fromList opts }) content
 
+            changeWorkingDirectory cwd
             writeFile "out.tex" tex
             putStrLn "Wrote result to out.tex"
         _ -> error "Usage: ./main handlingar <input-file> <heading>"
diff --git a/hs/src/Html.hs b/hs/src/Html.hs
index d856dcd..0eee74f 100644
--- a/hs/src/Html.hs
+++ b/hs/src/Html.hs
@@ -134,6 +134,7 @@ uriChars = fromList $ ":/?#"  -- Allows us to modifiy existing URL
                     <> "-._~" -- URL safe
                     <> ['A'..'Z'] <> ['a'..'z'] <> ['0'..'9']
 
+-- See also: Handlingar handleBilaga
 rebuildLinks :: Configuration -> Inline -> Inline
 rebuildLinks conf l@(Link attributes body (url, title@"wikilink"))
     = case parseURI . encodeWith (`elem` uriChars) . from $ url of