From c5764243257c685a680f51df25d33aa1339449ba Mon Sep 17 00:00:00 2001
From: Jasper Van der Jeugt <jaspervdj@gmail.com>
Date: Mon, 17 Jan 2011 16:08:37 +0100
Subject: Backport ContextManipulations → Metadata
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

---
 src/Hakyll/Web/Page/Metadata.hs | 110 ++++++++++++++++++++++++++++++++++++++++
 1 file changed, 110 insertions(+)
 create mode 100644 src/Hakyll/Web/Page/Metadata.hs

(limited to 'src/Hakyll/Web/Page/Metadata.hs')

diff --git a/src/Hakyll/Web/Page/Metadata.hs b/src/Hakyll/Web/Page/Metadata.hs
new file mode 100644
index 0000000..28be7d5
--- /dev/null
+++ b/src/Hakyll/Web/Page/Metadata.hs
@@ -0,0 +1,110 @@
+-- | Provides various functions to manipulate the metadata fields of a page
+--
+module Hakyll.Web.Page.Metadata
+    ( getField
+    , setField
+    , renderField
+    , changeField
+    , copyField
+    , renderDateField
+    , renderDateFieldWith
+    ) where
+
+import Data.List (intercalate)
+import Data.Maybe (fromMaybe)
+import Data.Time.Clock (UTCTime)
+import Data.Time.Format (parseTime, formatTime)
+import qualified Data.Map as M
+import System.FilePath (takeFileName)
+import System.Locale (TimeLocale, defaultTimeLocale)
+
+import Hakyll.Web.Page.Internal
+import Hakyll.Web.Util.String
+
+-- | Get a metadata field. If the field does not exist, the empty string is
+-- returned.
+--
+getField :: String  -- ^ Key
+         -> Page a  -- ^ Page
+         -> String  -- ^ Value
+getField key = fromMaybe "" . M.lookup key . pageMetadata
+
+-- | Add a metadata field. If the field already exists, it is not overwritten.
+--
+setField :: String  -- ^ Key
+         -> String  -- ^ Value
+         -> Page a  -- ^ Page to add it to
+         -> Page a  -- ^ Resulting page
+setField k v (Page m b) = Page (M.insertWith (flip const) k v m) b
+
+-- | Do something with a metadata value, but keep the old value as well. If the
+-- key given is not present in the metadata, nothing will happen. If the source
+-- and destination keys are the same, the value will be changed (but you should
+-- use 'changeField' for this purpose).
+--
+renderField :: String              -- ^ Key of which the value should be copied
+            -> String              -- ^ Key the value should be copied to
+            -> (String -> String)  -- ^ Function to apply on the value
+            -> Page a              -- ^ Page on which this should be applied
+            -> Page a              -- ^ Resulting page
+renderField src dst f page = case M.lookup src (pageMetadata page) of
+    Nothing      -> page
+    (Just value) -> setField dst (f value) page
+
+-- | Change a metadata value.
+--
+-- > import Data.Char (toUpper)
+-- > changeField "title" (map toUpper)
+--
+-- Will put the title in UPPERCASE.
+--
+changeField :: String              -- ^ Key to change.
+            -> (String -> String)  -- ^ Function to apply on the value.
+            -> Page a              -- ^ Page to change
+            -> Page a              -- ^ Resulting page
+changeField key = renderField key key
+
+-- | Make a copy of a metadata field (put the value belonging to a certain key
+-- under some other key as well)
+--
+copyField :: String  -- ^ Key to copy
+          -> String  -- ^ Destination to copy to
+          -> Page a  -- ^ Page on which this should be applied
+          -> Page a  -- ^ Resulting page
+copyField src dst = renderField src dst id
+
+-- | When the metadata has a field called @path@ in a
+-- @folder/yyyy-mm-dd-title.extension@ format (the convention for pages),
+-- this function can render the date.
+--
+-- > renderDate "date" "%B %e, %Y" "Date unknown"
+--
+-- Will render something like @January 32, 2010@.
+--
+renderDateField :: String  -- ^ Key in which the rendered date should be placed
+                -> String  -- ^ Format to use on the date
+                -> String  -- ^ Default value, in case the date cannot be parsed
+                -> Page a  -- ^ Page on which this should be applied
+                -> Page a  -- ^ Resulting page
+renderDateField = renderDateFieldWith defaultTimeLocale
+
+-- | This is an extended version of 'renderDateField' that allows you to
+-- specify a time locale that is used for outputting the date. For more
+-- details, see 'renderDateField'.
+--
+renderDateFieldWith :: TimeLocale  -- ^ Output time locale
+                    -> String      -- ^ Destination key
+                    -> String      -- ^ Format to use on the date
+                    -> String      -- ^ Default value
+                    -> Page a      -- ^ Target page
+                    -> Page a      -- ^ Resulting page
+renderDateFieldWith locale key format defaultValue =
+    renderField "path" key renderDate'
+  where
+    renderDate' filePath = fromMaybe defaultValue $ do
+        let dateString = intercalate "-" $ take 3
+                       $ splitAll "-" $ takeFileName filePath
+        time <- parseTime defaultTimeLocale
+                          "%Y-%m-%d"
+                          dateString :: Maybe UTCTime
+        return $ formatTime locale format time
-- 
cgit v1.2.3


From 97ce6cbfa0c2935ec1958dc005b2d57d8a839206 Mon Sep 17 00:00:00 2001
From: Jasper Van der Jeugt <jaspervdj@gmail.com>
Date: Sun, 30 Jan 2011 15:18:38 +0100
Subject: Add setFieldA function

---
 src/Hakyll/Web/Page/Metadata.hs | 17 +++++++++++++++--
 1 file changed, 15 insertions(+), 2 deletions(-)

(limited to 'src/Hakyll/Web/Page/Metadata.hs')

diff --git a/src/Hakyll/Web/Page/Metadata.hs b/src/Hakyll/Web/Page/Metadata.hs
index 28be7d5..d601a97 100644
--- a/src/Hakyll/Web/Page/Metadata.hs
+++ b/src/Hakyll/Web/Page/Metadata.hs
@@ -3,6 +3,7 @@
 module Hakyll.Web.Page.Metadata
     ( getField
     , setField
+    , setFieldA
     , renderField
     , changeField
     , copyField
@@ -10,6 +11,9 @@ module Hakyll.Web.Page.Metadata
     , renderDateFieldWith
     ) where
 
+import Prelude hiding (id)
+import Control.Category (id)
+import Control.Arrow (Arrow, (>>>), (***), arr)
 import Data.List (intercalate)
 import Data.Maybe (fromMaybe)
 import Data.Time.Clock (UTCTime)
@@ -37,6 +41,15 @@ setField :: String  -- ^ Key
          -> Page a  -- ^ Resulting page
 setField k v (Page m b) = Page (M.insertWith (flip const) k v m) b
 
+-- | Arrow-based variant of 'setField'. Because of it's type, this function is
+-- very usable together with the different 'require' functions.
+--
+setFieldA :: Arrow a
+          => String                            -- ^ Key
+          -> a x String                        -- ^ Value arrow
+          -> a (Page String, x) (Page String)  -- ^ Resulting arrow
+setFieldA k v = id *** v >>> arr (uncurry $ flip $ setField k)
+
 -- | Do something with a metadata value, but keep the old value as well. If the
 -- key given is not present in the metadata, nothing will happen. If the source
 -- and destination keys are the same, the value will be changed (but you should
@@ -48,8 +61,8 @@ renderField :: String              -- ^ Key of which the value should be copied
             -> Page a              -- ^ Page on which this should be applied
             -> Page a              -- ^ Resulting page
 renderField src dst f page = case M.lookup src (pageMetadata page) of
-    Nothing      -> page
-    (Just value) -> setField dst (f value) page
+    Nothing    -> page
+    Just value -> setField dst (f value) page
 
 -- | Change a metadata value.
 --
-- 
cgit v1.2.3


From ee320c61668b532cafce7f4fd0a80ba43b3b512a Mon Sep 17 00:00:00 2001
From: Jasper Van der Jeugt <jaspervdj@gmail.com>
Date: Wed, 9 Feb 2011 13:02:28 +0100
Subject: Finish tags module

---
 src/Hakyll/Core/Compiler.hs          |   7 ++
 src/Hakyll/Core/Compiler/Internal.hs |   8 +--
 src/Hakyll/Core/Util/Arrow.hs        |  15 +---
 src/Hakyll/Web/Page/Metadata.hs      |   6 +-
 src/Hakyll/Web/Tags.hs               | 131 +++++++++++++++++++++++++----------
 5 files changed, 108 insertions(+), 59 deletions(-)

(limited to 'src/Hakyll/Web/Page/Metadata.hs')

diff --git a/src/Hakyll/Core/Compiler.hs b/src/Hakyll/Core/Compiler.hs
index 53daa75..5249478 100644
--- a/src/Hakyll/Core/Compiler.hs
+++ b/src/Hakyll/Core/Compiler.hs
@@ -17,6 +17,7 @@ module Hakyll.Core.Compiler
     , requireAllA
     , cached
     , unsafeCompiler
+    , mapCompiler
     ) where
 
 import Prelude hiding ((.), id)
@@ -187,3 +188,9 @@ cached name (Compiler d j) = Compiler d $ const $ CompilerM $ do
 unsafeCompiler :: (a -> IO b)   -- ^ Function to lift
                -> Compiler a b  -- ^ Resulting compiler
 unsafeCompiler f = fromJob $ CompilerM . liftIO . f
+
+-- | Map over a compiler
+--
+mapCompiler :: Compiler a b
+            -> Compiler [a] [b]
+mapCompiler (Compiler d j) = Compiler d $ mapM j
diff --git a/src/Hakyll/Core/Compiler/Internal.hs b/src/Hakyll/Core/Compiler/Internal.hs
index be78412..a524a66 100644
--- a/src/Hakyll/Core/Compiler/Internal.hs
+++ b/src/Hakyll/Core/Compiler/Internal.hs
@@ -60,11 +60,11 @@ data Compiler a b = Compiler
     }
 
 instance Functor (Compiler a) where
-    fmap f (Compiler d j) = Compiler d $ fmap f . j
+    fmap f ~(Compiler d j) = Compiler d $ fmap f . j
 
 instance Applicative (Compiler a) where
     pure = Compiler (return S.empty) . const . return
-    (Compiler d1 f) <*> (Compiler d2 j) =
+    ~(Compiler d1 f) <*> ~(Compiler d2 j) =
         Compiler (liftM2 S.union d1 d2) $ \x -> f x <*> j x
 
 instance Category Compiler where
@@ -74,12 +74,12 @@ instance Category Compiler where
 
 instance Arrow Compiler where
     arr f = Compiler (return S.empty) (return . f)
-    first (Compiler d j) = Compiler d $ \(x, y) -> do
+    first ~(Compiler d j) = Compiler d $ \(x, y) -> do
         x' <- j x
         return (x', y)
 
 instance ArrowChoice Compiler where
-    left (Compiler d j) = Compiler d $ \e -> case e of
+    left ~(Compiler d j) = Compiler d $ \e -> case e of
         Left l  -> Left  <$> j l
         Right r -> Right <$> return r
 
diff --git a/src/Hakyll/Core/Util/Arrow.hs b/src/Hakyll/Core/Util/Arrow.hs
index dfcb7da..1896e11 100644
--- a/src/Hakyll/Core/Util/Arrow.hs
+++ b/src/Hakyll/Core/Util/Arrow.hs
@@ -4,14 +4,9 @@ module Hakyll.Core.Util.Arrow
     ( constA
     , sequenceA
     , unitA
-    , mapA
     ) where
 
-import Prelude hiding (id)
-import Control.Category (id)
-import Control.Arrow ( Arrow, ArrowChoice, (&&&), arr, (>>^), (|||)
-                     , (>>>), (***)
-                     )
+import Control.Arrow (Arrow, (&&&), arr, (>>^))
 
 constA :: Arrow a
        => c
@@ -28,11 +23,3 @@ sequenceA = foldl reduce $ constA []
 unitA :: Arrow a
       => a b ()
 unitA = constA ()
-
-mapA :: ArrowChoice a
-     => a b c
-     -> a [b] [c]
-mapA f = arr listEither >>> id ||| (f *** mapA f >>> arr (uncurry (:)))
-  where
-    listEither []       = Left []
-    listEither (x : xs) = Right (x, xs)
diff --git a/src/Hakyll/Web/Page/Metadata.hs b/src/Hakyll/Web/Page/Metadata.hs
index d601a97..2880ece 100644
--- a/src/Hakyll/Web/Page/Metadata.hs
+++ b/src/Hakyll/Web/Page/Metadata.hs
@@ -45,9 +45,9 @@ setField k v (Page m b) = Page (M.insertWith (flip const) k v m) b
 -- very usable together with the different 'require' functions.
 --
 setFieldA :: Arrow a
-          => String                            -- ^ Key
-          -> a x String                        -- ^ Value arrow
-          -> a (Page String, x) (Page String)  -- ^ Resulting arrow
+          => String                  -- ^ Key
+          -> a x String              -- ^ Value arrow
+          -> a (Page b, x) (Page b)  -- ^ Resulting arrow
 setFieldA k v = id *** v >>> arr (uncurry $ flip $ setField k)
 
 -- | Do something with a metadata value, but keep the old value as well. If the
diff --git a/src/Hakyll/Web/Tags.hs b/src/Hakyll/Web/Tags.hs
index 9c3d114..77dc440 100644
--- a/src/Hakyll/Web/Tags.hs
+++ b/src/Hakyll/Web/Tags.hs
@@ -19,32 +19,37 @@
 -- is to place pages in subdirectories.
 --
 -- An example, the page @posts\/coding\/2010-01-28-hakyll-categories.markdown@
--- Tags or categories are read using the @readTags@ and @readCategories@
+-- Tags or categories are read using the @readTags@ and @readCategory@
 -- functions. This module only provides functions to work with tags:
 -- categories are represented as tags. This is perfectly possible: categories
 -- only have an additional restriction that a page can only have one category
 -- (instead of multiple tags).
 --
-{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-}
+{-# LANGUAGE DeriveDataTypeable, OverloadedStrings, Arrows #-}
 module Hakyll.Web.Tags
     ( Tags (..)
     , readTagsWith
     , readTags
-    , readCategories
+    , readCategory
     , renderTagCloud
+    , renderTagsField
+    , renderCategoryField
     ) where
 
+import Prelude hiding (id)
+import Control.Category (id)
 import Control.Applicative ((<$>))
 import Data.Map (Map)
 import qualified Data.Map as M
 import Data.List (intersperse)
-import Control.Arrow (second, (&&&))
+import Control.Arrow (arr, (&&&), (>>>), (***), (<<^), returnA)
+import Data.Maybe (catMaybes, fromMaybe)
+import Data.Monoid (mconcat)
 
 import Data.Typeable (Typeable)
 import Data.Binary (Binary, get, put)
-import Data.Monoid (mconcat)
 import Text.Blaze.Renderer.String (renderHtml)
-import Text.Blaze (Html, (!), toHtml, toValue)
+import Text.Blaze ((!), toHtml, toValue)
 import qualified Text.Blaze.Html5 as H
 import qualified Text.Blaze.Html5.Attributes as A
 
@@ -52,6 +57,8 @@ import Hakyll.Web.Page
 import Hakyll.Web.Page.Metadata
 import Hakyll.Web.Util.String
 import Hakyll.Core.Writable
+import Hakyll.Core.Identifier
+import Hakyll.Core.Compiler
 
 -- | Data about tags
 --
@@ -66,6 +73,16 @@ instance Binary a => Binary (Tags a) where
 instance Writable (Tags a) where
     write _ _ = return ()
 
+-- | Obtain tags from a page
+--
+getTags :: Page a -> [String]
+getTags = map trim . splitAll "," . getField "tags"
+
+-- | Obtain categories from a page
+--
+getCategory :: Page a -> [String]
+getCategory = return . getField "category"
+
 -- | Higher-level function to read tags
 --
 readTagsWith :: (Page a -> [String])  -- ^ Function extracting tags from a page
@@ -83,42 +100,80 @@ readTagsWith f pages = Tags
 -- | Read a tagmap using the @tags@ metadata field
 --
 readTags :: [Page a] -> Tags a
-readTags = readTagsWith $ map trim . splitAll "," . getField "tags"
+readTags = readTagsWith getTags
 
 -- | Read a tagmap using the @category@ metadata field
 --
-readCategories :: [Page a] -> Tags a
-readCategories = readTagsWith $ return . getField "category"
+readCategory :: [Page a] -> Tags a
+readCategory = readTagsWith getCategory
 
 -- | Render a tag cloud in HTML
 --
-renderTagCloud :: (String -> String)  -- ^ Function to produce an url for a tag
-               -> Double              -- ^ Smallest font size, in percent
-               -> Double              -- ^ Biggest font size, in percent
-               -> Tags a              -- ^ Tags structure to render
-               -> String              -- ^ Resulting HTML
-renderTagCloud urlFunction minSize maxSize (Tags tags) = renderHtml $
-    mconcat $ intersperse " " $ map (uncurry renderTag) withCount
+renderTagCloud :: (String -> Identifier)    -- ^ Produce a link for a tag
+               -> Double                    -- ^ Smallest font size, in percent
+               -> Double                    -- ^ Biggest font size, in percent
+               -> Compiler (Tags a) String  -- ^ Tag cloud renderer
+renderTagCloud makeUrl minSize maxSize = proc (Tags tags) -> do
+    -- In tags' we create a list: [((tag, route), count)]
+    tags' <- mapCompiler ((id &&& (getRouteFor <<^ makeUrl)) *** arr length)
+                -< M.toList tags
+
+    let -- Absolute frequencies of the pages
+        freqs = map snd tags'
+
+        -- Find out the relative count of a tag: on a scale from 0 to 1
+        relative count = (fromIntegral count - min') / (1 + max' - min')
+
+        -- Show the relative size of one 'count' in percent
+        size count =
+            let size' = floor $ minSize + relative count * (maxSize - minSize)
+            in show (size' :: Int) ++ "%"
+
+        -- The minimum and maximum count found, as doubles
+        (min', max')
+            | null freqs = (0, 1)
+            | otherwise = (minimum &&& maximum) $ map fromIntegral freqs
+
+        -- Create a link for one item
+        makeLink ((tag, url), count) =
+            H.a ! A.style (toValue $ "font-size: " ++ size count)
+                ! A.href (toValue $ fromMaybe "/" url)
+                $ toHtml tag
+
+    -- Render and return the HTML
+    returnA -< renderHtml $ mconcat $ intersperse " " $ map makeLink tags'
+
+-- | Render tags with links
+--
+renderTagsFieldWith :: (Page a -> [String])        -- ^ Function to get the tags
+                    -> String                      -- ^ Destination key
+                    -> (String -> Identifier)      -- ^ Create a link for a tag
+                    -> Compiler (Page a) (Page a)  -- ^ Resulting compiler
+renderTagsFieldWith tags destination makeUrl =
+    id &&& arr tags >>> setFieldA destination renderTags
   where
-    -- Tags composed with their count
-    withCount = map (second $ fromIntegral . length) $ M.toList tags
-
-    -- Render one tag, given it's count
-    renderTag :: String -> Int -> Html
-    renderTag tag count =
-        H.a ! A.style (toValue $ "font-size: " ++ size count)
-            ! A.href (toValue $ urlFunction tag)
-            $ toHtml tag
-
-    -- Show the relative size of one 'count' in percent
-    size count =
-        let size' = floor $ minSize + relative count * (maxSize - minSize)
-        in show (size' :: Int) ++ "%"
-
-    -- Find out the relative count of a tag: on a scale from 0 to 1
-    relative count = (fromIntegral count - minCount) / (1 + maxCount - minCount)
-
-    -- The minimum and maximum count found, as doubles
-    (minCount, maxCount)
-        | null withCount = (0, 1)
-        | otherwise = (minimum &&& maximum) $ map (fromIntegral . snd) withCount
+    -- Compiler creating a comma-separated HTML string for a list of tags
+    renderTags :: Compiler [String] String
+    renderTags =   arr (map $ id &&& makeUrl)
+               >>> mapCompiler (id *** getRouteFor)
+               >>> arr (map $ uncurry renderLink)
+               >>> arr (renderHtml . mconcat . intersperse ", " . catMaybes)
+
+    -- Render one tag link
+    renderLink _   Nothing         = Nothing
+    renderLink tag (Just filePath) = Just $
+        H.a ! A.href (toValue $ toUrl filePath) $ toHtml tag
+
+-- | Render tags with links
+--
+renderTagsField :: String                      -- ^ Destination key
+                -> (String -> Identifier)      -- ^ Create a link for a tag
+                -> Compiler (Page a) (Page a)  -- ^ Resulting compiler
+renderTagsField = renderTagsFieldWith getTags
+
+-- | Render the category in a link
+--
+renderCategoryField :: String                      -- ^ Destination key
+                    -> (String -> Identifier)      -- ^ Create a category link
+                    -> Compiler (Page a) (Page a)  -- ^ Resulting compiler
+renderCategoryField = renderTagsFieldWith getCategory
-- 
cgit v1.2.3


From d00026366c78ef8578f7a9503ced4915b1d4ec28 Mon Sep 17 00:00:00 2001
From: Jasper Van der Jeugt <jaspervdj@gmail.com>
Date: Tue, 15 Feb 2011 22:15:02 +0100
Subject: defaultPageRead → defaultPageCompiler
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

---
 src/Hakyll/Web.hs               | 10 ++--------
 src/Hakyll/Web/Page.hs          | 15 +++++++++++----
 src/Hakyll/Web/Page/Metadata.hs | 10 +++++++++-
 src/Hakyll/Web/Pandoc.hs        |  2 +-
 src/Hakyll/Web/Template.hs      |  6 +++---
 5 files changed, 26 insertions(+), 17 deletions(-)

(limited to 'src/Hakyll/Web/Page/Metadata.hs')

diff --git a/src/Hakyll/Web.hs b/src/Hakyll/Web.hs
index 74c5c6c..bd9ce31 100644
--- a/src/Hakyll/Web.hs
+++ b/src/Hakyll/Web.hs
@@ -1,8 +1,7 @@
 -- | Module exporting commonly used web-related functions
 --
 module Hakyll.Web
-    ( defaultPageRead
-    , defaultTemplateRead
+    ( defaultTemplateRead
     , defaultTemplateReadWith
     , defaultRelativizeUrls
     , defaultCopyFile
@@ -11,7 +10,7 @@ module Hakyll.Web
 
 import Prelude hiding (id)
 import Control.Category (id)
-import Control.Arrow (arr, (>>>), (>>^), (&&&))
+import Control.Arrow ((>>^), (&&&))
 
 import Text.Hamlet (HamletSettings)
 
@@ -20,15 +19,10 @@ import Hakyll.Core.Writable
 import Hakyll.Core.Identifier
 import Hakyll.Core.ResourceProvider
 import Hakyll.Web.Page
-import Hakyll.Web.Pandoc
 import Hakyll.Web.Template
 import Hakyll.Web.RelativizeUrls
 import Hakyll.Web.Util.String
 
-defaultPageRead :: Compiler Resource (Page String)
-defaultPageRead = cached "Hakyll.Web.defaultPageRead" $
-    pageRead >>> addDefaultFields >>> arr applySelf >>> pageRenderPandoc
-
 defaultRelativizeUrls :: Compiler (Page String) (Page String)
 defaultRelativizeUrls = getRoute &&& id >>^ uncurry relativize
   where
diff --git a/src/Hakyll/Web/Page.hs b/src/Hakyll/Web/Page.hs
index 03995cd..30578e9 100644
--- a/src/Hakyll/Web/Page.hs
+++ b/src/Hakyll/Web/Page.hs
@@ -51,14 +51,15 @@ module Hakyll.Web.Page
     , fromBody
     , fromMap
     , toMap
-    , pageRead
+    , readPageCompiler
+    , defaultPageCompiler
     , addDefaultFields
     , sortByBaseName
     ) where
 
 import Prelude hiding (id)
 import Control.Category (id)
-import Control.Arrow ((>>^), (&&&), (>>>))
+import Control.Arrow (arr, (>>^), (&&&), (>>>))
 import System.FilePath (takeBaseName, takeDirectory)
 import Data.Monoid (Monoid, mempty)
 import Data.Map (Map)
@@ -72,6 +73,8 @@ import Hakyll.Core.ResourceProvider
 import Hakyll.Web.Page.Internal
 import Hakyll.Web.Page.Read
 import Hakyll.Web.Page.Metadata
+import Hakyll.Web.Pandoc
+import Hakyll.Web.Template
 import Hakyll.Web.Util.String
 
 -- | Create a page from a body, without metadata
@@ -91,8 +94,12 @@ toMap (Page m b) = M.insert "body" b m
 
 -- | Read a page (do not render it)
 --
-pageRead :: Compiler Resource (Page String)
-pageRead = getResourceString >>^ readPage
+readPageCompiler :: Compiler Resource (Page String)
+readPageCompiler = getResourceString >>^ readPage
+
+defaultPageCompiler :: Compiler Resource (Page String)
+defaultPageCompiler = cached "Hakyll.Web.Page.defaultPageCompiler" $
+    readPageCompiler >>> addDefaultFields >>> arr applySelf >>> pageRenderPandoc
 
 -- | Add a number of default metadata fields to a page. These fields include:
 --
diff --git a/src/Hakyll/Web/Page/Metadata.hs b/src/Hakyll/Web/Page/Metadata.hs
index 2880ece..23d98a4 100644
--- a/src/Hakyll/Web/Page/Metadata.hs
+++ b/src/Hakyll/Web/Page/Metadata.hs
@@ -2,6 +2,7 @@
 --
 module Hakyll.Web.Page.Metadata
     ( getField
+    , getFieldMaybe
     , setField
     , setFieldA
     , renderField
@@ -31,7 +32,14 @@ import Hakyll.Web.Util.String
 getField :: String  -- ^ Key
          -> Page a  -- ^ Page
          -> String  -- ^ Value
-getField key = fromMaybe "" . M.lookup key . pageMetadata
+getField key = fromMaybe "" . getFieldMaybe key
+
+-- | Get a field in a 'Maybe' wrapper
+--
+getFieldMaybe :: String        -- ^ Key
+              -> Page a        -- ^ Page
+              -> Maybe String  -- ^ Value, if found
+getFieldMaybe key = M.lookup key . pageMetadata
 
 -- | Add a metadata field. If the field already exists, it is not overwritten.
 --
diff --git a/src/Hakyll/Web/Pandoc.hs b/src/Hakyll/Web/Pandoc.hs
index 308d06b..f225997 100644
--- a/src/Hakyll/Web/Pandoc.hs
+++ b/src/Hakyll/Web/Pandoc.hs
@@ -27,7 +27,7 @@ import Text.Pandoc
 
 import Hakyll.Core.Compiler
 import Hakyll.Web.FileType
-import Hakyll.Web.Page
+import Hakyll.Web.Page.Internal
 
 -- | Read a string using pandoc, with the default options
 --
diff --git a/src/Hakyll/Web/Template.hs b/src/Hakyll/Web/Template.hs
index 78ddbba..70b689a 100644
--- a/src/Hakyll/Web/Template.hs
+++ b/src/Hakyll/Web/Template.hs
@@ -51,7 +51,6 @@ module Hakyll.Web.Template
 
 import Control.Arrow
 import Data.Maybe (fromMaybe)
-import qualified Data.Map as M
 import System.FilePath (takeExtension)
 
 import Text.Hamlet (HamletSettings, defaultHamletSettings)
@@ -61,7 +60,8 @@ import Hakyll.Core.Identifier
 import Hakyll.Core.ResourceProvider
 import Hakyll.Web.Template.Internal
 import Hakyll.Web.Template.Read
-import Hakyll.Web.Page
+import Hakyll.Web.Page.Internal
+import Hakyll.Web.Page.Metadata
 
 -- | Substitutes @$identifiers@ in the given @Template@ by values from the given
 -- "Page". When a key is not found, it is left as it is. You can specify
@@ -73,7 +73,7 @@ applyTemplate template page =
   where
     substitute (Chunk chunk) = chunk
     substitute (Key key) =
-        fromMaybe ("$" ++ key ++ "$") $ M.lookup key $ toMap page
+        fromMaybe ("$" ++ key ++ "$") $ getFieldMaybe key page
     substitute (Escaped) = "$"
 
 -- | Apply a page as it's own template. This is often very useful to fill in
-- 
cgit v1.2.3


From 49989eab5767b24cb3e917b95137ae05566e34a8 Mon Sep 17 00:00:00 2001
From: Jasper Van der Jeugt <jaspervdj@gmail.com>
Date: Mon, 28 Feb 2011 22:33:28 +0100
Subject: Web.Util.String → {Web.Util.Url, Core.Util.String}
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

---
 hakyll.cabal                     |  3 +-
 src/Hakyll.hs                    |  6 ++--
 src/Hakyll/Core/Util/String.hs   | 48 ++++++++++++++++++++++++++
 src/Hakyll/Web/CompressCss.hs    |  2 +-
 src/Hakyll/Web/Feed.hs           |  2 +-
 src/Hakyll/Web/Page.hs           |  2 +-
 src/Hakyll/Web/Page/Metadata.hs  |  2 +-
 src/Hakyll/Web/Page/Read.hs      |  2 +-
 src/Hakyll/Web/Preview/Server.hs |  2 +-
 src/Hakyll/Web/RelativizeUrls.hs |  2 +-
 src/Hakyll/Web/Tags.hs           |  3 +-
 src/Hakyll/Web/Util/String.hs    | 73 ----------------------------------------
 src/Hakyll/Web/Util/Url.hs       | 30 +++++++++++++++++
 13 files changed, 93 insertions(+), 84 deletions(-)
 create mode 100644 src/Hakyll/Core/Util/String.hs
 delete mode 100644 src/Hakyll/Web/Util/String.hs
 create mode 100644 src/Hakyll/Web/Util/Url.hs

(limited to 'src/Hakyll/Web/Page/Metadata.hs')

diff --git a/hakyll.cabal b/hakyll.cabal
index e011406..b4a533f 100644
--- a/hakyll.cabal
+++ b/hakyll.cabal
@@ -65,7 +65,7 @@ library
                       strict-concurrency >= 0.2
   exposed-modules:    Hakyll
                       Hakyll.Main
-                      Hakyll.Web.Util.String
+                      Hakyll.Web.Util.Url
                       Hakyll.Web.Preview.Server
                       Hakyll.Web.Preview.Poll
                       Hakyll.Web.CompressCss
@@ -85,6 +85,7 @@ library
                       Hakyll.Core.UnixFilter
                       Hakyll.Core.Util.Arrow
                       Hakyll.Core.Util.File
+                      Hakyll.Core.Util.String
                       Hakyll.Core.ResourceProvider
                       Hakyll.Core.CompiledItem
                       Hakyll.Core.Compiler
diff --git a/src/Hakyll.hs b/src/Hakyll.hs
index 9a17479..0261044 100644
--- a/src/Hakyll.hs
+++ b/src/Hakyll.hs
@@ -12,6 +12,7 @@ module Hakyll
     , module Hakyll.Core.UnixFilter
     , module Hakyll.Core.Util.Arrow
     , module Hakyll.Core.Util.File
+    , module Hakyll.Core.Util.String
     , module Hakyll.Core.Writable
     , module Hakyll.Main
     , module Hakyll.Web.CompressCss
@@ -24,7 +25,7 @@ module Hakyll
     , module Hakyll.Web.RelativizeUrls
     , module Hakyll.Web.Tags
     , module Hakyll.Web.Template
-    , module Hakyll.Web.Util.String
+    , module Hakyll.Web.Util.Url
     ) where
 
 import Hakyll.Core.Compiler
@@ -38,6 +39,7 @@ import Hakyll.Core.Rules
 import Hakyll.Core.UnixFilter
 import Hakyll.Core.Util.Arrow
 import Hakyll.Core.Util.File
+import Hakyll.Core.Util.String
 import Hakyll.Core.Writable
 import Hakyll.Main
 import Hakyll.Web.CompressCss
@@ -50,4 +52,4 @@ import Hakyll.Web.Pandoc
 import Hakyll.Web.RelativizeUrls
 import Hakyll.Web.Tags
 import Hakyll.Web.Template
-import Hakyll.Web.Util.String
+import Hakyll.Web.Util.Url
diff --git a/src/Hakyll/Core/Util/String.hs b/src/Hakyll/Core/Util/String.hs
new file mode 100644
index 0000000..7f75a36
--- /dev/null
+++ b/src/Hakyll/Core/Util/String.hs
@@ -0,0 +1,48 @@
+-- | Miscellaneous string manipulation functions.
+--
+module Hakyll.Core.Util.String
+    ( trim
+    , replaceAll
+    , splitAll
+    ) where
+
+import Data.Char (isSpace)
+import Data.Maybe (listToMaybe)
+
+import Text.Regex.PCRE ((=~~))
+
+-- | Trim a string (drop spaces, tabs and newlines at both sides).
+--
+trim :: String -> String
+trim = reverse . trim' . reverse . trim'
+  where
+    trim' = dropWhile isSpace
+
+-- | A simple (but inefficient) regex replace funcion
+--
+replaceAll :: String              -- ^ Pattern
+           -> (String -> String)  -- ^ Replacement (called on capture)
+           -> String              -- ^ Source string
+           -> String              -- ^ Result
+replaceAll pattern f source = replaceAll' source
+  where
+    replaceAll' src = case listToMaybe (src =~~ pattern) of
+        Nothing     -> src
+        Just (o, l) ->
+            let (before, tmp) = splitAt o src
+                (capture, after) = splitAt l tmp
+            in before ++ f capture ++ replaceAll' after
+
+-- | A simple regex split function. The resulting list will contain no empty
+-- strings.
+--
+splitAll :: String    -- ^ Pattern
+         -> String    -- ^ String to split
+         -> [String]  -- ^ Result
+splitAll pattern = filter (not . null) . splitAll'
+  where
+    splitAll' src = case listToMaybe (src =~~ pattern) of
+        Nothing     -> [src]
+        Just (o, l) ->
+            let (before, tmp) = splitAt o src
+            in before : splitAll' (drop l tmp)
diff --git a/src/Hakyll/Web/CompressCss.hs b/src/Hakyll/Web/CompressCss.hs
index 94ba9a9..2df08fd 100644
--- a/src/Hakyll/Web/CompressCss.hs
+++ b/src/Hakyll/Web/CompressCss.hs
@@ -12,7 +12,7 @@ import Control.Arrow ((>>^))
 
 import Hakyll.Core.Compiler
 import Hakyll.Core.ResourceProvider
-import Hakyll.Web.Util.String
+import Hakyll.Core.Util.String
 
 -- | Compiler form of 'compressCss'
 --
diff --git a/src/Hakyll/Web/Feed.hs b/src/Hakyll/Web/Feed.hs
index d91a60f..85674c6 100644
--- a/src/Hakyll/Web/Feed.hs
+++ b/src/Hakyll/Web/Feed.hs
@@ -33,7 +33,7 @@ import Hakyll.Web.Page
 import Hakyll.Web.Page.Metadata
 import Hakyll.Web.Template
 import Hakyll.Web.Template.Read.Hakyll (readTemplate)
-import Hakyll.Web.Util.String
+import Hakyll.Web.Util.Url
 
 import Paths_hakyll
 
diff --git a/src/Hakyll/Web/Page.hs b/src/Hakyll/Web/Page.hs
index 8a16ef8..955e1a8 100644
--- a/src/Hakyll/Web/Page.hs
+++ b/src/Hakyll/Web/Page.hs
@@ -73,7 +73,7 @@ import Hakyll.Web.Page.Read
 import Hakyll.Web.Page.Metadata
 import Hakyll.Web.Pandoc
 import Hakyll.Web.Template
-import Hakyll.Web.Util.String
+import Hakyll.Web.Util.Url
 
 -- | Create a page from a body, without metadata
 --
diff --git a/src/Hakyll/Web/Page/Metadata.hs b/src/Hakyll/Web/Page/Metadata.hs
index 23d98a4..72742e6 100644
--- a/src/Hakyll/Web/Page/Metadata.hs
+++ b/src/Hakyll/Web/Page/Metadata.hs
@@ -24,7 +24,7 @@ import System.FilePath (takeFileName)
 import System.Locale (TimeLocale, defaultTimeLocale)
 
 import Hakyll.Web.Page.Internal
-import Hakyll.Web.Util.String
+import Hakyll.Core.Util.String
 
 -- | Get a metadata field. If the field does not exist, the empty string is
 -- returned.
diff --git a/src/Hakyll/Web/Page/Read.hs b/src/Hakyll/Web/Page/Read.hs
index d72f32a..cf39ddd 100644
--- a/src/Hakyll/Web/Page/Read.hs
+++ b/src/Hakyll/Web/Page/Read.hs
@@ -12,7 +12,7 @@ import Data.Map (Map)
 import qualified Data.Map as M
 
 import Hakyll.Web.Page.Internal
-import Hakyll.Web.Util.String
+import Hakyll.Core.Util.String
 
 -- | We're using a simple state monad as parser
 --
diff --git a/src/Hakyll/Web/Preview/Server.hs b/src/Hakyll/Web/Preview/Server.hs
index 77b3cb0..c550b69 100644
--- a/src/Hakyll/Web/Preview/Server.hs
+++ b/src/Hakyll/Web/Preview/Server.hs
@@ -18,7 +18,7 @@ import Snap.Http.Server ( httpServe, setAccessLog, setErrorLog, addListen
                         , ConfigListen (..), emptyConfig
                         )
 
-import Hakyll.Web.Util.String (replaceAll)
+import Hakyll.Core.Util.String (replaceAll)
 
 -- | The first file in the list that actually exists is returned
 --
diff --git a/src/Hakyll/Web/RelativizeUrls.hs b/src/Hakyll/Web/RelativizeUrls.hs
index 1df4fea..2de4a0e 100644
--- a/src/Hakyll/Web/RelativizeUrls.hs
+++ b/src/Hakyll/Web/RelativizeUrls.hs
@@ -29,7 +29,7 @@ import Text.HTML.TagSoup
 
 import Hakyll.Core.Compiler
 import Hakyll.Web.Page
-import Hakyll.Web.Util.String
+import Hakyll.Web.Util.Url
 
 -- | Compiler form of 'compressCss' which automatically picks the right root
 -- path
diff --git a/src/Hakyll/Web/Tags.hs b/src/Hakyll/Web/Tags.hs
index 77dc440..211a06b 100644
--- a/src/Hakyll/Web/Tags.hs
+++ b/src/Hakyll/Web/Tags.hs
@@ -55,10 +55,11 @@ import qualified Text.Blaze.Html5.Attributes as A
 
 import Hakyll.Web.Page
 import Hakyll.Web.Page.Metadata
-import Hakyll.Web.Util.String
+import Hakyll.Web.Util.Url
 import Hakyll.Core.Writable
 import Hakyll.Core.Identifier
 import Hakyll.Core.Compiler
+import Hakyll.Core.Util.String
 
 -- | Data about tags
 --
diff --git a/src/Hakyll/Web/Util/String.hs b/src/Hakyll/Web/Util/String.hs
deleted file mode 100644
index 0dde74a..0000000
--- a/src/Hakyll/Web/Util/String.hs
+++ /dev/null
@@ -1,73 +0,0 @@
--- | Miscellaneous string manipulation functions.
---
-module Hakyll.Web.Util.String
-    ( trim
-    , replaceAll
-    , splitAll
-    , toUrl
-    , toSiteRoot
-    ) where
-
-import Data.Char (isSpace)
-import Data.Maybe (listToMaybe)
-
-import System.FilePath (splitPath, takeDirectory, joinPath)
-import Text.Regex.PCRE ((=~~))
-
--- | Trim a string (drop spaces, tabs and newlines at both sides).
---
-trim :: String -> String
-trim = reverse . trim' . reverse . trim'
-  where
-    trim' = dropWhile isSpace
-
--- | A simple (but inefficient) regex replace funcion
---
-replaceAll :: String              -- ^ Pattern
-           -> (String -> String)  -- ^ Replacement (called on capture)
-           -> String              -- ^ Source string
-           -> String              -- ^ Result
-replaceAll pattern f source = replaceAll' source
-  where
-    replaceAll' src = case listToMaybe (src =~~ pattern) of
-        Nothing     -> src
-        Just (o, l) ->
-            let (before, tmp) = splitAt o src
-                (capture, after) = splitAt l tmp
-            in before ++ f capture ++ replaceAll' after
-
--- | A simple regex split function. The resulting list will contain no empty
--- strings.
---
-splitAll :: String    -- ^ Pattern
-         -> String    -- ^ String to split
-         -> [String]  -- ^ Result
-splitAll pattern = filter (not . null) . splitAll'
-  where
-    splitAll' src = case listToMaybe (src =~~ pattern) of
-        Nothing     -> [src]
-        Just (o, l) ->
-            let (before, tmp) = splitAt o src
-            in before : splitAll' (drop l tmp)
-
--- | Convert a filepath to an URL starting from the site root
---
--- Example:
---
--- > toUrl "foo/bar.html"
---
--- Result:
---
--- > "/foo/bar.html"
---
-toUrl :: FilePath -> String
-toUrl = ('/' :)
-
--- | Get the relative url to the site root, for a given (absolute) url
---
-toSiteRoot :: String -> String
-toSiteRoot = emptyException . joinPath . map parent . splitPath . takeDirectory
-  where
-    parent = const ".."
-    emptyException [] = "."
-    emptyException x  = x
diff --git a/src/Hakyll/Web/Util/Url.hs b/src/Hakyll/Web/Util/Url.hs
new file mode 100644
index 0000000..54a361e
--- /dev/null
+++ b/src/Hakyll/Web/Util/Url.hs
@@ -0,0 +1,30 @@
+-- | Miscellaneous URL manipulation functions.
+--
+module Hakyll.Web.Util.Url
+    ( toUrl
+    , toSiteRoot
+    ) where
+
+import System.FilePath (splitPath, takeDirectory, joinPath)
+
+-- | Convert a filepath to an URL starting from the site root
+--
+-- Example:
+--
+-- > toUrl "foo/bar.html"
+--
+-- Result:
+--
+-- > "/foo/bar.html"
+--
+toUrl :: FilePath -> String
+toUrl = ('/' :)
+
+-- | Get the relative url to the site root, for a given (absolute) url
+--
+toSiteRoot :: String -> String
+toSiteRoot = emptyException . joinPath . map parent . splitPath . takeDirectory
+  where
+    parent = const ".."
+    emptyException [] = "."
+    emptyException x  = x
-- 
cgit v1.2.3