Extracting math from all posts

1 files changed, 63 insertions, 3 deletions

diff --git a/src/Site.hs b/src/Site.hs
index 25d11d0..279532f 100644
--- a/src/Site.hs
+++ b/src/Site.hs
@@ -3,14 +3,18 @@
 import Hakyll
 
 import Data.Monoid (Monoid(..), mconcat, (<>))
-import Control.Monad (liftM)
+import Control.Monad (liftM, forM_)
 import Data.Char (toLower, isSpace, isAlphaNum)
 import Data.Maybe (mapMaybe, fromMaybe)
 import Data.Map (Map)
 import qualified Data.Map as Map
-import Data.List (take, reverse)
+import qualified Data.Set as Set
+import Data.List (take, reverse, nub, groupBy, concatMap)
+import Data.Function (on)
 import Data.Default
-import Text.Pandoc.Options (WriterOptions(..), ObfuscationMethod(..))
+import Text.Pandoc
+import Text.Pandoc.Walk (query)
+import Text.Pandoc.Error
 import Control.Applicative (Alternative(..), Applicative(..))
 
 import System.FilePath (takeBaseName, (</>), (<.>))
@@ -31,6 +35,14 @@ main = hakyllWith config $ do
         >>= loadAndApplyTemplate "templates/default.html" defaultContext
         >>= relativizeUrls
 
+  math <- getMath "posts/*" mathTranslation'
+  forM_ math $ \(deps, mathStr) ->
+    rulesExtraDependencies (map IdentifierDependency deps) $
+    create [mathTranslation' mathStr] $ do
+      route idRoute
+      compile $ do
+        makeItem $ mathStr
+
   tags <- buildTags "posts/*" tagTranslation' >>= addTag "All Posts" "posts/*"
 
   tagsRules tags $ \tag pattern -> do
@@ -122,11 +134,59 @@ tagTranslation = mapMaybe charTrans
       | isAlphaNum c = Just $ toLower c
       | otherwise = Nothing
 
+mathTranslation' :: String -> Identifier
+mathTranslation' = fromCapture "math/*.svg" . id -- TODO hash math
+
 addTag :: MonadMetadata m => String -> Pattern -> Tags -> m Tags
 addTag name pattern tags = do
   ids <- getMatches pattern
   return $ tags { tagsMap = tagsMap tags ++ [(name, ids)] }
 
+getMath :: Pattern -> (String -> Identifier) -> Rules [([Identifier], String)]
+getMath pattern makeId = do
+  ids <- getMatches pattern
+  mathStrs <- concat `liftM` mapM (\id -> map ((,) [id]) `liftM` getMath' (toFilePath' id)) ids
+  return $ mergeGroups $ groupBy ((==) `on` snd) $ mathStrs
+    where
+      getMath' :: FilePath -> Rules [String]
+      getMath' path = preprocess (query extractMath `liftM` readPandoc' path)
+      extractMath :: Inline -> [String]
+      extractMath (Math _ str) = [str]
+      extractMath _ = []
+      mergeGroups :: [[([Identifier], String)]] -> [([Identifier], String)]
+      mergeGroups = map mergeGroups' . filter (not . null)
+      mergeGroups' :: [([Identifier], String)] -> ([Identifier], String)
+      mergeGroups' xs@((_, str):_) = (concatMap fst xs, str)
+
+readPandoc' :: FilePath -> IO Pandoc
+readPandoc' path = readFile path >>= either fail return . result'
+  where
+    result' str = case result str of
+        Left (ParseFailure err)  -> Left $
+            "parse failed: " ++ err
+        Left (ParsecError _ err) -> Left $
+            "parse failed: " ++ show err
+        Right item'              -> Right item'
+    result str = reader defaultHakyllReaderOptions (fileType path) str
+    reader ro t = case t of
+        DocBook            -> readDocBook ro
+        Html               -> readHtml ro
+        LaTeX              -> readLaTeX ro
+        LiterateHaskell t' -> reader (addExt ro Ext_literate_haskell) t'
+        Markdown           -> readMarkdown ro
+        MediaWiki          -> readMediaWiki ro
+        OrgMode            -> readOrg ro
+        Rst                -> readRST ro
+        Textile            -> readTextile ro
+        _                  -> error $
+            "I don't know how to read a file of " ++
+            "the type " ++ show t ++ " for: " ++ path
+
+    addExt ro e = ro {readerExtensions = Set.insert e $ readerExtensions ro}
+
+toFilePath' :: Identifier -> FilePath
+toFilePath' = (providerDirectory config </>) . toFilePath
+
 config :: Configuration
 config = defaultConfiguration { providerDirectory = "provider"
                               , deployCommand = "rsync -av --progress -c --delete-delay -m  _site/ gkleen@surtr.yggdrasil.li:/var/www/dirty-haskell.org/"