Cleanup.

7 files changed, 163 insertions, 131 deletions

diff --git a/hs/src/Handlingar.hs b/hs/src/Handlingar.hs
index 16d61ce..96ee6cf 100644
--- a/hs/src/Handlingar.hs
+++ b/hs/src/Handlingar.hs
@@ -9,6 +9,27 @@ import Prelude hiding
     , writeFile
     )
 
+import Control.Monad.State.Lazy
+import Data.ByteString (ByteString)
+import Data.Default (def)
+import Data.Map ((!))
+import Data.Maybe (fromMaybe)
+import Data.Set (Set)
+import Data.String (IsString(fromString))
+import Data.Text (Text, pack, unpack, strip)
+import Data.Text.Encoding (decodeLatin1, decodeUtf8)
+import Data.Text.Encoding.Base64 (encodeBase64)
+import Data.Text.IO (putStrLn, writeFile)
+import Mail (getMail, MailPart(..), getBytes, getFile)
+import Network.URI (URI, parseURI, uriScheme, uriPath)
+import Network.URI.Encode (encodeWith, decode)
+import System.Directory (makeAbsolute)
+import System.FilePath (dropFileName, takeExtension, (<.>))
+import System.IO (Handle)
+import System.Posix.Directory (changeWorkingDirectory, getWorkingDirectory)
+import System.Process (cleanupProcess)
+import Tex (toTex, TeX (..))
+import Text.DocTemplates (toVal, Val(SimpleVal, ListVal), Context(Context))
 import Text.Pandoc
     ( runIOorExplode
     , readVimwiki
@@ -19,50 +40,17 @@ import Text.Pandoc
     , PandocMonad
     , PandocIO
     , writePlain
-    -- , ReaderOptions
     )
 import Text.Pandoc.Builder
-import Text.Pandoc.Writers.LaTeX (writeLaTeX)
-import Text.Pandoc.Templates
-    ( compileDefaultTemplate
-    )
+import Text.Pandoc.Extract (AppendixItem, getHeadingData, extractKV) 
+import Text.Pandoc.Items (comment, dlist) 
+import Text.Pandoc.Templates (compileDefaultTemplate)
 import Text.Pandoc.Walk (walk, walkM)
-import Data.Text (Text, pack, unpack, strip)
-import Data.Text.IO
-    ( putStrLn
-    , writeFile
-    )
-import Data.Default (def)
-import Control.Monad.State.Lazy
-import Data.Text.Encoding.Base64 (encodeBase64)
-import Text.DocTemplates (toVal, Val(SimpleVal, ListVal), Context(Context))
-
-import qualified Data.Text.IO as T
+import Text.Pandoc.Writers.LaTeX (writeLaTeX)
+import Util (joinBy, splitBy, uncurry3, (<&>))
 import qualified Data.Map.Lazy as Map
-import Data.Map ((!))
-import System.Posix.Directory (changeWorkingDirectory, getWorkingDirectory)
-import System.Directory (makeAbsolute)
-import System.IO (Handle, hGetLine, hPutStrLn, hFlush)
-import Data.ByteString (ByteString, hGet)
-import Data.Text.Encoding (decodeLatin1, decodeUtf8)
-import System.Process (cleanupProcess)
-import Data.Maybe (fromMaybe)
-import Tex (toTex, TeX (..))
-import Data.String (IsString(fromString))
-
-import System.FilePath
-    ( dropFileName
-    , (<.>)
-    , takeExtension
-    )
-
-import Network.URI (URI, parseURI, uriScheme, uriPath)
-import Network.URI.Encode (encodeWith, decode)
-import Data.Set (Set)
 import qualified Data.Set as Set
-import Util (joinBy, splitBy)
-
-import Mail (getMail, MailPart(..))
+import qualified Data.Text.IO as T
 
 -- TODO pandoc possibly contains a better way to handle attachements,
 --      something about media bag
@@ -76,55 +64,13 @@ import Mail (getMail, MailPart(..))
 --    - Mail, where mail attachements are copied verbatim
 --            other attachements become mail attachments
 
-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 equal to or "higher" than the target
-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"
-
-getHeadingData :: Text -> [Block] -> Maybe [Block]
-getHeadingData heading blocks =
-    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
-        _ -> Nothing
-
-extractKV :: PandocMonad m => [Inline] -> [[Block]] -> m (Text, Text)
-extractKV is bbs = do
-    key <- strip <$> writePlain def (Pandoc nullMeta [Plain is])
-    value <- mconcat <$> mapM (fmap strip . writePlain def . Pandoc nullMeta) bbs
-    return (key, value)
-
+-- Takes a list of Pandoc Blocks starting with a heading. If the first
+-- element after the heading is a Definition list, then parse that to
+-- kv-pairs, and return it also.
 handleBlocks :: PandocMonad m => [Block] -> m (Text, [(Text, Text)], [Block])
 handleBlocks (head:DefinitionList definitions:blocks) = do
     heading <- writePlain def (Pandoc nullMeta [head])
-    kvs <- mapM (uncurry extractKV) definitions
+    kvs <- mapM extractKV definitions
     return (strip heading, kvs, blocks)
 handleBlocks (head:blocks) = do
     heading <- writePlain def (Pandoc nullMeta [head])
@@ -144,6 +90,7 @@ buildPrimary (Pandoc meta blocks) = do
                 $ ("title", heading) : kvs
     return (pandoc', appendices)
 
+
 rewriteLink :: Inline -> State [AppendixItem] Inline
 rewriteLink (Link _ is (target, "wikilink")) = do
     let appendixRef = encodeBase64 target
@@ -182,8 +129,6 @@ getVimwikiPage path = do
     Pandoc _ blocks <- readVimwiki def text
     return blocks
 
-(<&>) = flip (<$>)
-
 handleFile :: FilePath -> String -> PandocIO (Maybe [Block])
 handleFile fname ".txt" = do
     text <- liftIO $ T.readFile fname
@@ -214,36 +159,13 @@ findAlternative (m@MailPart { contentType = contentType }:xs) = case contentType
 
 
 -- TODO where are these strings defined
+-- Strict Bytestring
 decoder :: String -> (ByteString -> Text)
 decoder "iso-8859-1" = decodeLatin1
 decoder "utf-8"      = decodeUtf8
 -- decoder _            = decodeUtf8Lenient
 decoder _            = decodeLatin1
 
-data MailAction = GetBytes
-                | GetFile
-                deriving (Show)
-
-serialize :: MailAction -> String
-serialize GetBytes = "get-bytes"
-serialize GetFile = "get-file"
-
-mailGet :: MailAction -> String -> (Handle, Handle) -> (Handle -> IO a) -> IO a
-mailGet action id (inp, outp) handler = do
-    hPutStrLn outp id
-    hPutStrLn outp $ serialize action
-    hFlush outp
-    handler inp
-
-
-getBytes :: String -> (Handle, Handle) -> IO ByteString
-getBytes id ports = mailGet GetBytes id ports $ \inp -> do
-    count <- readIO =<< hGetLine inp
-    hGet inp count
-
-getFile :: String -> (Handle, Handle) -> IO FilePath
-getFile id ports = mailGet GetFile id ports hGetLine
-
 
 -- https://www.w3.org/Protocols/rfc1341/7_2_Multipart.html
 -- TODO differentiate between inline images (through cid:<> urls), and
@@ -265,6 +187,7 @@ handleMailBody ports mail =
             bytes <- liftIO $ getBytes (partId mail) ports
             let content = decoder (fromMaybe "ASCII" $ charset mail) bytes
             pdoc <- readHtml def content
+            -- TODO renumber links
             let Pandoc _ blocks = walk shorten pdoc
             return blocks
         ("image", _) -> do
@@ -300,15 +223,6 @@ formatMail mail ports = do
 
     return $ DefinitionList kvs : body
 
-comment :: Text -> [Block]
-comment s = [ RawBlock (Format "latex") ("% " <> s)
-            , RawBlock (Format "html") ("<!-- " <> s <> " -->")
-            ]
-
-dlist :: [(String, String)] -> Block
-dlist xs = DefinitionList [ ( [Str . pack $ k]
-                            , [[Plain [Str . pack $ v]]] )
-                          | (k, v) <- xs ]
 
 handleMailLink :: URI -> PandocIO [Block]
 handleMailLink uri = do
diff --git a/hs/src/Html.hs b/hs/src/Html.hs
index b539772..dc3e7db 100644
--- a/hs/src/Html.hs
+++ b/hs/src/Html.hs
@@ -82,7 +82,7 @@ import Text.Pandoc.Writers.Shared (
 
 import Files
 import Links
-import Util
+import Util hiding ((<&>))
 import Config
 -- import System.Home
 import Vimwiki.Man
@@ -230,7 +230,7 @@ htmlWrap conf title parts backlinks mtoc main = docTypeHtml $ do
             Nothing -> return mempty
     H.footer $ do
         backlinks
-
+        -- source_link
 
 
 allHeaders :: Pandoc -> [Block]
diff --git a/hs/src/Mail.hs b/hs/src/Mail.hs
index 505931e..137e237 100644
--- a/hs/src/Mail.hs
+++ b/hs/src/Mail.hs
@@ -3,7 +3,6 @@
 
 module Mail where
 
-import System.Process
 import Data.Aeson ( eitherDecode
                   , FromJSON
                   , ToJSON
@@ -14,15 +13,20 @@ import Data.Aeson ( eitherDecode
                   , withObject
                   , (.:)
                   )
+import Data.ByteString (ByteString, hGet)
+import Data.ByteString.Lazy (fromStrict)
 import Data.Map (Map)
 import GHC.Generics
-import Data.ByteString (hGet)
-import Data.ByteString.Lazy (fromStrict)
-import System.IO (Handle, hGetLine)
+import System.IO (hFlush, hPutStrLn, Handle, hGetLine)
+import System.Process
+
+type Proc = (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
+type MsgID = String
+type PartID = String
 
 data MailPart = MailPart
     { filename :: Maybe String
-    , partId :: String
+    , partId :: PartID
     , headers :: Map String String
     , parts :: [MailPart]
     , contentType :: String
@@ -41,9 +45,9 @@ instance FromJSON MailPart where
         <*> v .: "content-type"
         <*> v .: "charset"
 
-type Proc = (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
 
-getMail :: String -> IO (Either String (MailPart, Proc))
+-- starts a new mail-getter subprocess
+getMail :: MsgID -> IO (Either String (MailPart, Proc))
 getMail id = do
     let prgr = "/home/hugo/code/vimwiki-scripts/hs/mail.py" -- TODO
     let cmd = (proc prgr [id]) { std_out = CreatePipe
@@ -51,10 +55,34 @@ getMail id = do
     proc@(_, Just stdout, _, _) <- createProcess cmd
 
     count <- read <$> hGetLine stdout
-    bytes <- fromStrict <$> hGet stdout count
-    case eitherDecode bytes of
+    bytes <- hGet stdout count
+    case eitherDecode $ fromStrict bytes of
         Left err -> do
             cleanupProcess proc
             print bytes
             return $ Left err
         Right mailpart -> return $ Right (mailpart, proc)
+
+
+data MailAction = GetBytes
+                | GetFile
+                deriving (Show)
+
+serialize :: MailAction -> String
+serialize GetBytes = "get-bytes"
+serialize GetFile = "get-file"
+
+mailGet :: MailAction -> PartID -> (Handle, Handle) -> (Handle -> IO a) -> IO a
+mailGet action id (inp, outp) handler = do
+    hPutStrLn outp id
+    hPutStrLn outp $ serialize action
+    hFlush outp
+    handler inp
+
+getBytes :: PartID -> (Handle, Handle) -> IO ByteString
+getBytes id ports = mailGet GetBytes id ports $ \inp -> do
+    count <- readIO =<< hGetLine inp
+    hGet inp count
+
+getFile :: PartID -> (Handle, Handle) -> IO FilePath
+getFile id ports = mailGet GetFile id ports hGetLine
diff --git a/hs/src/Text/Pandoc/Extract.hs b/hs/src/Text/Pandoc/Extract.hs
new file mode 100644
index 0000000..6fb6016
--- /dev/null
+++ b/hs/src/Text/Pandoc/Extract.hs
@@ -0,0 +1,57 @@
+module Text.Pandoc.Extract where
+
+import Data.Default (def)
+import Data.Text (Text, strip)
+import Text.Pandoc ( PandocMonad
+                   , Inline
+                   , Block (Header, HorizontalRule, Plain)
+                   , Pandoc(..)
+                   , nullMeta
+                   , writePlain
+                   )
+import Util (oneOf)
+
+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 equal to or "higher" than the target
+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"
+
+-- Find heading matching Text, returns rom the initial heading block
+-- until the next header equal or greater than the matched, or the
+-- next horizontal rule
+getHeadingData :: Text -> [Block] -> Maybe [Block]
+getHeadingData heading blocks =
+    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
+        _ -> Nothing
+
+-- Takes one of the pairs form a (Pandoc) DefinitionList, renders
+-- their contents to plain text, and returns the resulting pair
+extractKV :: PandocMonad m => ([Inline], [[Block]]) -> m (Text, Text)
+extractKV (is, bbs) = do
+    key <- strip <$> writePlain def (Pandoc nullMeta [Plain is])
+    value <- mconcat <$> mapM (fmap strip . writePlain def . Pandoc nullMeta) bbs
+    return (key, value)
+
diff --git a/hs/src/Text/Pandoc/Items.hs b/hs/src/Text/Pandoc/Items.hs
new file mode 100644
index 0000000..f8a6cd6
--- /dev/null
+++ b/hs/src/Text/Pandoc/Items.hs
@@ -0,0 +1,19 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Text.Pandoc.Items where
+
+import Data.Text (Text, pack)
+import Text.Pandoc ( Inline (..)
+                   , Block (..)
+                   , Format (Format)
+                   )
+
+comment :: Text -> [Block]
+comment s = [ RawBlock (Format "latex") ("% " <> s)
+            , RawBlock (Format "html") ("<!-- " <> s <> " -->")
+            ]
+
+dlist :: [(String, String)] -> Block
+dlist xs = DefinitionList [ ( [Str . pack $ k]
+                            , [[Plain [Str . pack $ v]]] )
+                          | (k, v) <- xs ]
diff --git a/hs/src/Util.hs b/hs/src/Util.hs
index e3c8d2f..d76c5c7 100644
--- a/hs/src/Util.hs
+++ b/hs/src/Util.hs
@@ -5,6 +5,9 @@ module Util
 , nullToMaybe
 , firstJust
 , splitBy
+, oneOf
+, uncurry3
+, (<&>)
 ) where
 
 swap :: (a, b) -> (b, a)
@@ -44,3 +47,12 @@ firstJust :: a -> [Maybe a] -> a
 firstJust x [] = x
 firstJust _ (Just x:_) = x
 firstJust x (_:xs) = firstJust x xs
+
+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
+
+(<&>) :: Functor f => f a -> (a -> b) -> f b
+(<&>) = flip (<$>)
diff --git a/hs/vimwiki.cabal b/hs/vimwiki.cabal
index d0a0dda..2322521 100644
--- a/hs/vimwiki.cabal
+++ b/hs/vimwiki.cabal
@@ -37,6 +37,8 @@ executable Main
     System.Home,
     Util,
     Tex,
+    Text.Pandoc.Extract,
+    Text.Pandoc.Items,
     Data.Text.Compat,
     System.FilePath.Normalize
   build-depends: