upgrade to hakyll 4, and rewrite as a result. meta compiler has gone …

…away, so I've rewrittem the git related parts as follows.

1) using the preprocess function to execute before any rules are run, get a list of files in the articles directory and get a list of revision pairs for each one
2) in the normal rules, process each of those entries (now a Map Identifier -> [(Revision, Revision)]) by creating and routing them and applying templates as normal.

still TODO:
1) pretty print the diff
2) rewrite the code that includes the history to use the list of diffs we've already got (instead of computing them again)

src/site.hs

@@ -1,56 +1,57 @@
-{-# LANGUAGE DeriveDataTypeable, Arrows, OverloadedStrings #-}
-import Control.Arrow (returnA, (>>>), arr, (***), (>>^))
+{-# LANGUAGE OverloadedStrings #-}
 import Data.FileStore hiding (create)
 import Prelude hiding (id)
 import Control.Category (id)
 import Hakyll
-import Text.Blaze.Renderer.String (renderHtml)
+import Text.Blaze.Html.Renderer.String (renderHtml)
 import Text.Blaze.Html5 ((!),toValue)
 import qualified Text.Blaze.Html5 as H
 import qualified Text.Blaze.Html5.Attributes as A
-import Data.Monoid (mempty, mconcat, mempty, mappend)
+import Data.Monoid (mempty, mconcat, mempty, mappend,(<>))
 import Data.List (elemIndex, intercalate)
 import Data.Maybe (fromMaybe)
-import Data.Time.Clock (UTCTime)
-import Data.Time.Format (parseTime, formatTime)
-import System.Locale (TimeLocale, defaultTimeLocale)
 import System.FilePath (combine, dropExtension, takeFileName)
-import Text.Pandoc (bottomUp, defaultWriterOptions, Pandoc, WriterOptions(..), writeHtmlString, readMarkdown, defaultParserState, Block(Para), Inline(Link))
-type Diff = [(DI, [String])]
-
+import Text.Pandoc (bottomUp, def, Pandoc,  writeHtmlString, readMarkdown, Block(Para), Inline(Link))
+import Text.Pandoc.Options
+import qualified Data.Map as M
+import Control.Applicative ((<$>))
+import Data.Algorithm.DiffOutput
+import Data.Algorithm.Diff hiding(getDiff)
+import Control.Monad(foldM,forM_,liftM)
+import Control.Monad.Trans (liftIO)
 fileStore :: FileStore
 fileStore = gitFileStore "articles"
 
-getRevisionList :: Compiler String (FilePath, [(Revision, Revision)])
-getRevisionList = unsafeCompiler $ \path -> do
-    lst <- getRevisions $ takeFileName path
-    return (path, lst)
-
-getDiff :: Compiler (FilePath, [(Revision, Revision)]) Diff
-getDiff = unsafeCompiler $ \(page,rl) -> do
-    diffs <- mapM (getFileDiff (takeFileName page) ) rl
-    return $ head diffs
-
-renderDiff :: (DI, [String]) -> String
-renderDiff l =  diffInd (fst l) ++ unlines (snd l) ++ diffInd (fst l) ++ nl (fst l) --renderHtml $ H.pre ! A.class_ (attrCls (fst l)) $ diffCnt l
-    where attrCls c   = toValue $ diffStr "diff" c
-          diffCnt l'   = H.toHtml $ diffInd (fst l') ++ unlines (snd l')
-          diffStr a b = a ++ show b
-          diffInd i   = case i of
-                           F -> "~~" -- strikeout
-                           S -> "**" -- emphasis
-                           B -> ""
-          nl i        = case i of
-                             F -> "\n"
-                             S -> "\n"
-                             otherwise -> ""
-
-getFileDiff :: FilePath -> (Revision, Revision) -> IO Diff
+--getRevisionList :: Compiler [(Revision, Revision)]
+getRevisionList = do
+    path <- toFilePath <$> getUnderlying
+    unsafeCompiler $ getRevisions $ takeFileName path
+
+
+getDiff page =  mapM ( getFileDiff (takeFileName page) )
+
+--renderDiff :: [Diff, [String]] -> String
+--renderDiff :: a -> String
+renderDiff d = return (ppDiff d)
+-- renderDiff l =  diffInd (fst l) ++ unlines (snd l) ++ diffInd (fst l) ++ nl (fst l) --renderHtml $ H.pre ! A.class_ (attrCls (fst l)) $ diffCnt l
+--     where attrCls c   = toValue $ diffStr "diff" c
+--           diffCnt l'   = H.toHtml $ diffInd (fst l') ++ unlines (snd l')
+--           diffStr a b = a ++ show b
+--           diffInd i   = case i of
+--                            First -> "~~" -- strikeout
+--                            Second -> "**" -- emphasis
+--                            Both -> ""
+--           nl i        = case i of
+--                              First -> "\n"
+--                              Second -> "\n"
+--                              otherwise -> ""
+
+--getFileDiff :: FilePath -> (Revision, Revision) -> IO [Diff, [String]]
 getFileDiff f (a,b) = diff fileStore f (Just $ revId b) (Just $ revId a)
 
 getRevisions :: FilePath -> IO [(Revision, Revision)]
 getRevisions f = do
-    revList <- history fileStore [f] (TimeRange Nothing Nothing)
+    revList <- history fileStore [f] (TimeRange Nothing Nothing) Nothing
     return $ makePairList revList
     -- makePairList [1..4] => [(1,2),(2,3),(3,4)]
     where makePairList xs = [(y, x) | x <- xs, y <- xs, y == getListPrev x (reverse xs), x /= y]
@@ -59,142 +60,162 @@ getListPrev :: Eq a => a -> [a] -> a
 getListPrev i l = l !! checkBounds (fromMaybe 0 (i `elemIndex` l) +1 )
     where checkBounds x | x > length l -1 = length l-1 | otherwise = x
 
-constructDiff :: String -> Diff -> Compiler () (Page String)
-constructDiff i d = constA mempty
-    >>> addDefaultFields >>> arr applySelf
---     >>> pageCompiler (fromIdentifier $parseIdentifier i) >>> \res page -> do
---         return page
-    >>> arr (setField "diff" (writeHtmlString options $ readMarkdown defaultParserState $ diff' d))
-    >>> arr (setField "title" ("Changes " ++ i))
-    >>> renderTagsField "prettytags" (fromCapture "tags/*")
-    >>> applyTemplateCompiler "templates/diff.html"
-    >>> applyTemplateCompiler "templates/default.html"
-    >>> relativizeUrlsCompiler
-    where diff' =  concatMap renderDiff
+--constructDiff :: String -> [[Diff, [String]]] -> Compiler (Item String)
+constructDiff i d = makeItem i
+    >>= loadAndApplyTemplate "templates/diff.html" (field "diff" (\_ -> diff' d) <> commonContext)
+    >>= loadAndApplyTemplate "templates/default.html" commonContext
+    >>= relativizeUrls
+    where diff' [] =  return []
+          diff' x = renderDiff $ head x
 
 applyDiffMarkup :: undefined
 applyDiffMarkup = undefined
 
-makeRevisionCompiler ::
-        Compiler (Page String)
-                (Identifier (Page String), Compiler () (Page String))
-makeRevisionCompiler = proc page -> do
-        revisionList <- getRevisionList -< (getField "path" page)
-        diff' <- getDiff -< revisionList
-        let gd = constructDiff (getField "path" page) diff'
-        returnA -< (diff_ident revisionList, gd)
-    where diff_ident i = parseIdentifier $ ("diffs/" ++ revId ( fst $ head $ snd i)) ++ ("_" ++ revId ( snd $ head $ snd i)) ++ ".markdown"
---     where diff_ident (_, (b,c):_) =  parseIdentifier $ "diffs/" ++ (show $ revId b) ++ "_" ++ (show $ revId c)
---           diff_ident (a, []) = parseIdentifier $ a
+-- makeRevisionCompiler ::
+--         Compiler (Page String)
+--                 (Identifier (Page String), Compiler () (Page String))
+makeRevisionCompiler =  do
+        path <- toFilePath <$> getUnderlying
+        revisionList <- getRevisionList
+        diff' <- unsafeCompiler (getDiff path revisionList)
+        unsafeCompiler (putStrLn (takeFileName path))
+        constructDiff (takeFileName path) diff'
+        --createDiffItem [(fromFilePath (takeFileName path))] diff'
+        --let gd = constructDiff path diff'
+--         makeItem (diff_ident revisionList, gd)
+--     where diff_ident i = fromFilePath $ ("diffs/" ++ revId ( fst $ head $ snd i)) ++ ("_" ++ revId ( snd $ head $ snd i)) ++ ".markdown"
+--           diff_ident (_, (b,c):_) =  fromFilePath $ "diffs/" ++ (show $ revId b) ++ "_" ++ (show $ revId c)
+--           diff_ident (a, []) = fromFilePath $ a
 
 routePage :: Routes
 routePage = customRoute fileToDirectory
 
-fileToDirectory :: Identifier a -> FilePath
+--fileToDirectory :: Identifier a -> FilePath
 fileToDirectory = flip combine "index.html" . dropExtension . toFilePath
 
-makeTagList :: String
-            -> [Page String]
-            -> Compiler () (Page String)
-makeTagList tag posts =
-    constA (mempty, posts)
-        >>> addPostList
-        >>> arr (setField "title" ("Posts tagged &#8216;" ++ tag ++ "&#8217;"))
-        >>> applyTemplateCompiler "templates/posts.html"
-        >>> applyTemplateCompiler "templates/default.html"
-        >>> relativizeUrlsCompiler
-
-addPostList :: Compiler (Page String, [Page String]) (Page String)
-addPostList = setFieldA "posts" $
-    arr (reverse . chronological)
-        >>> require "templates/postitem.html" (\p t -> map (applyTemplate t) p)
-        >>> arr mconcat
-        >>> arr pageBody
-
-addRevisionList :: Compiler (Page String) (Page String)
-addRevisionList = unsafeCompiler $ \page -> do
-    let path = getField "path" page
-    lst <- getRevisions $ takeFileName path
-    return $ setField "history" (concatMap renderRevision lst) page
+addRevisionList :: Compiler String
+addRevisionList = do
+    path <- toFilePath <$> getUnderlying
+    lst <- unsafeCompiler $ getRevisions $ takeFileName path
+    return (concatMap renderRevision lst)
 
 renderRevision :: (Revision, Revision) -> String
 renderRevision rl = renderHtml $ H.tr $ do
     H.td $ H.toHtml $ createLink rl
     H.td $ H.toHtml $ revDescription $ fst rl
-    where diffLink (a,b) = "./diffs/" ++ revId a ++ "_" ++ revId b ++ ".html"
+    where diffLink (a,b) = revId a ++ "_" ++ revId b ++ ".html"
           createLink (a,b) = H.a ! A.href (toValue $ diffLink (a,b)) $ H.toHtml (show (revDateTime a))
 
+compressorCompiler :: String -> Item String -> Compiler (Item String)
+compressorCompiler t = withItemBody(unixFilter "yui-compressor" ["--type", t])
+
+--makeDiffIdentifier a b = constRoute "diffs" `composeRoutes`
+
 main :: IO ()
 main = hakyll $ do
     let static = route idRoute >> compile copyFileCompiler
     mapM_ (`match` static ) ["files/**", "js/lib/*", "images/**"]
     match "js/*.js" $ do
         route idRoute
-        compile $ getResourceString >>> unixFilter "yui-compressor" ["--type", "js"]
+        compile $ getResourceString
+            >>= compressorCompiler "js"
+
     match "js/*.coffee" $ do
         route $ setExtension "js"
         compile $ getResourceString
-            >>> unixFilter "coffee" ["--compile", "-s"]
-            >>> unixFilter "yui-compressor" ["--type", "js"]
+            >>= withItemBody(unixFilter "coffee" ["--compile", "-s"])
+            >>= compressorCompiler "js"
+
     match "css/*.css" $ do
         route   idRoute
-        compile $ getResourceString >>> unixFilter "yui-compressor" ["--type", "css"]
-    match "css/*.sass" $ do
+        compile $ getResourceString >>= compressorCompiler "css"
+
+    match "css/*.scss" $ do
         route   idRoute
         compile $ getResourceString
-            >>> unixFilter "sass" ["-s", "--scss"]
-            >>> unixFilter "yui-compressor" ["--type", "css"]
+            >>= withItemBody(unixFilter "sass" ["-s", "--scss"])
+            >>= compressorCompiler "css"
+
     match "about/*" $ do
         route $ setExtension ".html"
-        compile $ pageCompiler
-            >>> applyTemplateCompiler "templates/default.html"
-            >>> relativizeUrlsCompiler
+        compile $ pandocCompiler
+            >>= loadAndApplyTemplate "templates/default.html" commonContext
+            >>= relativizeUrls
+
+    tags <- buildTags "articles/*" (fromCapture "tags/*.html")
+    tagsRules tags $ \tag pattern -> do
+        let title = "Posts tagged " ++ tag
+
+        -- Copied from posts, need to refactor
+        route idRoute
+        compile $ do
+            list <- postList tags pattern recentFirst
+            makeItem ""
+                >>= loadAndApplyTemplate "templates/posts.html"
+                        (constField "title" title `mappend`
+                            constField "posts" list `mappend`
+                            commonContext)
+                >>= loadAndApplyTemplate "templates/default.html" commonContext
+                >>= relativizeUrls
     -- Render articles
-    _ <- ($) match "articles/*" $ do
+    _ <- ($) match "articles/*" $ version "raw" $ do
         route   routePage
-        compile $ pageCompilerWith defaultHakyllParserState options
-            >>> renderModificationTime "modified" "%B %e, %Y"
-            >>> arr(changeField "date" prettyPrintDate)
-            -- >>> copyBodyFromField "date"
-            >>> renderTagsField "prettytags" (fromCapture "tags/*")
-            >>> addRevisionList
-            >>> applyTemplateCompiler "templates/post.html"
-            >>> applyTemplateCompiler "templates/default.html"
-            >>> relativizeUrlsCompiler
-    group "diffs" $ match "articles/*" $
-        metaCompileWith "diffs" $ requireAll_ "articles/*"
-            >>> mapCompiler makeRevisionCompiler
-    match "diffs/*" $ route $( gsubRoute "diffs/" (const "articles/diffs/") `composeRoutes` setExtension "html")
+        compile $ pandocCompiler
+            -- >>= saveSnapshot "content"
+            -- >>= addRevisionList
+            >>= loadAndApplyTemplate "templates/post.html" (field "history" (const addRevisionList) <> contentCtx tags)
+            >>= loadAndApplyTemplate "templates/default.html" commonContext
+            >>= relativizeUrls
+    --diffs <- buildDiffsWith "articles/*" (fromCapture "diffs/*.html")
+
+    diffs <- preprocess $ do
+-- 	let ids = concat $ getMatches "articles/*"
+      ids <- getRecursiveContents (const $ return False) "articles"
+      let ids' = map (fromFilePath) ids
+      mapM buildDiffs ids'
+
+    forM_ diffs $ \diff -> 
+      create (createDiffIdentifiers diff) $ do
+	route idRoute
+	compile $ do
+	  path <- toFilePath <$> getUnderlying
+	  unsafeCompiler (putStrLn path)
+	  revisionList <- getRevisionList
+	  diff' <- unsafeCompiler (getDiff path revisionList)
+	  constructDiff (takeFileName path) diff'
+
+
     match "templates/*" $ compile templateCompiler
-   -- Index
-    match "index.html" $ route idRoute
-    create "index.html" $ constA mempty
-        >>> arr (setField "title" "Andy Irving")
-        >>> arr (setField "description" "The personal website of Andy Irving")
-        >>> arr (setField "author" "Andy Irving")
-        >>> requireA "tags" (setFieldA "tagcloud" renderTagCloud')
-        >>> requireAllA "articles/*" (id *** arr (take 3 . reverse . sortByBaseName) >>> addPostList)
-        >>> applyTemplateCompiler "templates/index.html"
-        >>> applyTemplateCompiler "templates/default.html"
-        >>> relativizeUrlsCompiler
-        -- Tags
-    _ <- ($) create "tags" $
-        requireAll "articles/*" (\_ ps -> readTags ps :: Tags String)
-
-    -- Add a tag list compiler for every tag
-    match "tags/*" $ route $ setExtension ".html"
-    metaCompile $ require_ "tags"
-        >>> arr tagsMap
-        >>> arr (map (\(t, p) -> (tagIdentifier t, makeTagList t p)))
-    where
-        tagIdentifier :: String -> Identifier (Page String)
-        tagIdentifier = fromCapture "tags/*"
-        renderTagCloud' :: Compiler (Tags String) String
-        renderTagCloud' = renderTagCloud tagIdentifier 100 120
-
+
+    create ["index.html"] $ do
+        route idRoute
+        compile $ do
+            list <- postList tags ("articles/*" .&&. hasNoVersion) $ fmap (take 5) . recentFirst
+            makeItem ""
+                >>= loadAndApplyTemplate "templates/index.html" (field "tagcloud" (\_ -> renderTagList tags) <> constField "title" "Andy Irving" <> constField "posts" list <> commonContext)
+                >>= loadAndApplyTemplate "templates/default.html" (
+                    constField "author" "Andy Irving"
+                    <> constField "title" "Andy Irving"
+                    <> constField "description" "The personal website of Andy Irving"
+                    <> commonContext)
+                >>= relativizeUrls
+
+--buildDiffs :: Identifier -> IO (Identifier,[(Revision, Revision)])
+buildDiffs id' = do
+  revs <- getRevisions $ toFilePath id'
+  --return $ (id', revs)
+  let diffMap = M.fromList [(id',revs)]
+  return diffMap
+
+createDiffIdentifiers :: M.Map Identifier [(Revision, Revision)] -> [Identifier]
+createDiffIdentifiers diffs = map fromFilePath (fp diffs) 
+  where
+    f i (a,b) = i ++ "/" ++ revId a ++ "_" ++ revId b ++ ".html"
+    fp = M.foldrWithKey (\k x ks-> ks ++  map (f ((combine "articles") $ dropExtension (toFilePath k))) x) []
+
 -- Pandoc options
-options :: WriterOptions
-options = defaultWriterOptions{ writerTableOfContents = True,
+--options :: WriterOptions
+options = def{ writerTableOfContents = True,
                                     writerTemplate = "$if(toc)$\n$toc$\n$endif$\n$body$",
                                     writerWrapText = True,
                                     writerColumns = 72,
@@ -205,11 +226,25 @@ options = defaultWriterOptions{ writerTableOfContents = True,
                                     writerReferenceLinks = False
 
 }
+commonContext :: Context String
+commonContext = mconcat
+    [ dateField "date" "%B %e, %Y"
+    , field "author" $ \item -> do
+        metadata <- getMetadataField (itemIdentifier item) "author" 
+        return $ fromMaybe "Anonymous" metadata
+    , field "description" $ \item -> do
+        metadata <- getMetadataField (itemIdentifier item) "description"
+        return $ fromMaybe "" metadata
+    , defaultContext
+    ]
+contentCtx :: Tags -> Context String
+contentCtx tags = mconcat
+    [ tagsField "tags" tags
+    , commonContext
+    ]
+
+postList tags pattern preprocess' = do
+    postItemTpl <- loadBody "templates/postitem.html"
+    posts <- preprocess' =<< loadAll pattern
+    applyTemplateList postItemTpl (contentCtx tags) posts
 
-prettyPrintDate :: String -> String
-prettyPrintDate date = fromMaybe defaultValue $ do
-        let dateString = intercalate "-" $ take 3 $ splitAll "-" date
-        time <- parseTime defaultTimeLocale "%Y-%m-%d" dateString :: Maybe UTCTime
-        return $ formatTime defaultTimeLocale format time
-    where defaultValue = "Unknown"
-          format = "%B %e, %Y"