From bb9ea6f1226b55a584cfcec47efeddabc230418d Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Sun, 20 Jun 2010 10:45:17 +0200 Subject: Add newtype for Context --- src/Text/Hakyll.hs | 4 ++-- src/Text/Hakyll/Context.hs | 9 +++++++-- src/Text/Hakyll/ContextManipulations.hs | 4 ++-- src/Text/Hakyll/CreateContext.hs | 8 +++++--- src/Text/Hakyll/Feed.hs | 6 +++--- src/Text/Hakyll/HakyllMonad.hs | 6 +++--- src/Text/Hakyll/Internal/Page.hs | 4 ++-- src/Text/Hakyll/Internal/Template.hs | 7 ++++--- src/Text/Hakyll/Render.hs | 19 ++++++++++--------- src/Text/Hakyll/Tags.hs | 8 ++++---- tests/Page.hs | 16 ++++++++++------ tests/Template.hs | 8 +++++--- 12 files changed, 57 insertions(+), 42 deletions(-) diff --git a/src/Text/Hakyll.hs b/src/Text/Hakyll.hs index f7cb04e..a2ade71 100644 --- a/src/Text/Hakyll.hs +++ b/src/Text/Hakyll.hs @@ -15,7 +15,7 @@ module Text.Hakyll import Control.Monad.Reader (runReaderT, liftIO, ask) import Control.Monad (when) -import qualified Data.Map as M +import Data.Monoid (mempty) import System.Environment (getArgs, getProgName) import System.Directory (doesDirectoryExist, removeDirectoryRecursive) @@ -48,7 +48,7 @@ defaultHakyllConfiguration :: String -- ^ Absolute site URL. -> HakyllConfiguration -- ^ Default config. defaultHakyllConfiguration absoluteUrl' = HakyllConfiguration { absoluteUrl = absoluteUrl' - , additionalContext = M.empty + , additionalContext = mempty , siteDirectory = "_site" , cacheDirectory = "_cache" , enableIndexUrl = False diff --git a/src/Text/Hakyll/Context.hs b/src/Text/Hakyll/Context.hs index c5c77d4..9045a65 100644 --- a/src/Text/Hakyll/Context.hs +++ b/src/Text/Hakyll/Context.hs @@ -1,11 +1,16 @@ -- | This (quite small) module exports the datatype used for contexts. A -- @Context@ is a simple key-value mapping. You can render these @Context@s -- with templates, and manipulate them in various ways. +{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Text.Hakyll.Context - ( Context + ( Context (..) ) where +import Data.Monoid (Monoid) import Data.Map (Map) +import Data.Binary (Binary) -- | Datatype used for key-value mappings. -type Context = Map String String +newtype Context = Context { -- | Extract the context. + unContext :: Map String String + } deriving (Show, Monoid, Binary) diff --git a/src/Text/Hakyll/ContextManipulations.hs b/src/Text/Hakyll/ContextManipulations.hs index ff4d661..b2706be 100644 --- a/src/Text/Hakyll/ContextManipulations.hs +++ b/src/Text/Hakyll/ContextManipulations.hs @@ -21,7 +21,7 @@ import qualified Data.Map as M import Text.Hakyll.Regex (substituteRegex) import Text.Hakyll.HakyllAction (HakyllAction (..)) -import Text.Hakyll.Context (Context) +import Text.Hakyll.Context (Context (..)) -- | Do something with a value in a @Context@, but keep the old value as well. -- If the key given is not present in the @Context@, nothing will happen. @@ -29,7 +29,7 @@ renderValue :: 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. -> HakyllAction Context Context -renderValue source destination f = arr $ \context -> +renderValue source destination f = arr $ \(Context context) -> Context $ case M.lookup source context of Nothing -> context (Just value) -> M.insert destination (f value) context diff --git a/src/Text/Hakyll/CreateContext.hs b/src/Text/Hakyll/CreateContext.hs index 1bfd00c..a38d055 100644 --- a/src/Text/Hakyll/CreateContext.hs +++ b/src/Text/Hakyll/CreateContext.hs @@ -42,7 +42,7 @@ createCustomPage :: FilePath createCustomPage url association = HakyllAction { actionDependencies = dataDependencies , actionUrl = Left $ return url - , actionFunction = \_ -> M.fromList <$> assoc' + , actionFunction = \_ -> Context . M.fromList <$> assoc' } where mtuple (a, b) = b >>= \b' -> return (a, b') @@ -80,7 +80,8 @@ combine x y = HakyllAction { actionDependencies = actionDependencies x ++ actionDependencies y , actionUrl = actionUrl x , actionFunction = \_ -> - liftM2 M.union (runHakyllAction x) (runHakyllAction y) + Context <$> liftM2 (M.union) (unContext <$> runHakyllAction x) + (unContext <$> runHakyllAction y) } -- | Combine two @Context@s and set a custom URL. This behaves like @combine@, @@ -91,7 +92,8 @@ combineWithUrl :: FilePath -> HakyllAction () Context combineWithUrl url x y = combine' { actionUrl = Left $ return url - , actionFunction = \_ -> M.insert "url" url <$> runHakyllAction combine' + , actionFunction = \_ -> + Context . M.insert "url" url . unContext <$> runHakyllAction combine' } where combine' = combine x y diff --git a/src/Text/Hakyll/Feed.hs b/src/Text/Hakyll/Feed.hs index 40e4257..992b8da 100644 --- a/src/Text/Hakyll/Feed.hs +++ b/src/Text/Hakyll/Feed.hs @@ -28,7 +28,7 @@ import Control.Monad.Reader (liftIO) import Data.Maybe (fromMaybe) import qualified Data.Map as M -import Text.Hakyll.Context (Context) +import Text.Hakyll.Context (Context (..)) import Text.Hakyll.CreateContext (createListing) import Text.Hakyll.ContextManipulations (renderDate) import Text.Hakyll.HakyllMonad (Hakyll) @@ -69,8 +69,8 @@ createFeed configuration renderables template itemTemplate = ] ++ updated -- Take the first timestamp, which should be the most recent. - updated = let action = createHakyllAction $ - return . fromMaybe "foo" . M.lookup "timestamp" + updated = let action = createHakyllAction $ return . fromMaybe "foo" + . M.lookup "timestamp" . unContext toTuple r = ("timestamp", Right $ r >>> action) in map toTuple $ take 1 renderables diff --git a/src/Text/Hakyll/HakyllMonad.hs b/src/Text/Hakyll/HakyllMonad.hs index 372fad1..9535a66 100644 --- a/src/Text/Hakyll/HakyllMonad.hs +++ b/src/Text/Hakyll/HakyllMonad.hs @@ -12,7 +12,7 @@ import qualified Data.Map as M import Text.Pandoc (ParserState, WriterOptions) -import Text.Hakyll.Context (Context) +import Text.Hakyll.Context (Context (..)) -- | Our custom monad stack. type Hakyll = ReaderT HakyllConfiguration IO @@ -50,5 +50,5 @@ askHakyll = flip liftM ask getAdditionalContext :: HakyllConfiguration -> Context getAdditionalContext configuration = - M.insert "absolute" (absoluteUrl configuration) - (additionalContext configuration) + let (Context c) = additionalContext configuration + in Context $ M.insert "absolute" (absoluteUrl configuration) c diff --git a/src/Text/Hakyll/Internal/Page.hs b/src/Text/Hakyll/Internal/Page.hs index e2998a5..59bae65 100644 --- a/src/Text/Hakyll/Internal/Page.hs +++ b/src/Text/Hakyll/Internal/Page.hs @@ -12,7 +12,7 @@ import Control.Monad.State (State, evalState, get, put) import Text.Pandoc -import Text.Hakyll.Context (Context) +import Text.Hakyll.Context (Context (..)) import Text.Hakyll.File import Text.Hakyll.HakyllMonad import Text.Hakyll.Regex (substituteRegex, matchesRegex) @@ -103,7 +103,7 @@ readPageFromFile path = do context = M.fromList $ ("url", url) : ("path", path) : category ++ sectionsData - return context + return $ Context context where category = let dirs = splitDirectories $ takeDirectory path in [("category", last dirs) | not (null dirs)] diff --git a/src/Text/Hakyll/Internal/Template.hs b/src/Text/Hakyll/Internal/Template.hs index b7d1db0..bd8db2c 100644 --- a/src/Text/Hakyll/Internal/Template.hs +++ b/src/Text/Hakyll/Internal/Template.hs @@ -7,6 +7,7 @@ module Text.Hakyll.Internal.Template , finalSubstitute ) where +import Control.Applicative ((<$>)) import Data.List (isPrefixOf) import Data.Char (isAlphaNum) import Data.Binary @@ -15,7 +16,7 @@ import Data.Maybe (fromMaybe) import System.FilePath (()) import qualified Data.Map as M -import Text.Hakyll.Context (Context) +import Text.Hakyll.Context (Context (..)) import Text.Hakyll.HakyllMonad (Hakyll) import Text.Hakyll.Internal.Cache import Text.Hakyll.Internal.Page @@ -47,7 +48,7 @@ readTemplate path = do if isCacheMoreRecent' then getFromCache fileName else do - page <- readPage path + page <- unContext <$> readPage path let body = fromMaybe (error $ "No body in template " ++ fileName) (M.lookup "body" page) template = fromString body @@ -65,7 +66,7 @@ substitute escaper (Chunk chunk template) context = substitute escaper (Identifier key template) context = replacement ++ substitute escaper template context where - replacement = fromMaybe ('$' : key) $ M.lookup key context + replacement = fromMaybe ('$' : key) $ M.lookup key $ unContext context substitute escaper (EscapeCharacter template) context = escaper ++ substitute escaper template context substitute _ End _ = [] diff --git a/src/Text/Hakyll/Render.hs b/src/Text/Hakyll/Render.hs index a3476b6..d054f63 100644 --- a/src/Text/Hakyll/Render.hs +++ b/src/Text/Hakyll/Render.hs @@ -16,7 +16,7 @@ import System.Directory (copyFile) import Data.Maybe (fromMaybe) import qualified Data.Map as M -import Text.Hakyll.Context (Context) +import Text.Hakyll.Context (Context (..)) import Text.Hakyll.HakyllMonad (Hakyll, askHakyll, getAdditionalContext) import Text.Hakyll.File import Text.Hakyll.HakyllAction @@ -27,12 +27,12 @@ import Text.Hakyll.Internal.Template pureRender :: Template -- ^ Template to use for rendering. -> Context -- ^ Renderable object to render with given template. -> Context -- ^ The body of the result will contain the render. -pureRender template context = +pureRender template (Context c) = -- Ignore $root when substituting here. We will only replace that in the -- final render (just before writing). - let contextIgnoringRoot = M.insert "root" "$root" context - body = regularSubstitute template contextIgnoringRoot - in M.insert "body" body context + let contextIgnoringRoot = Context $ M.insert "root" "$root" c + body = regularSubstitute template $ contextIgnoringRoot + in Context $ M.insert "body" body c -- | This is the most simple render action. You render a @Context@ with a -- template, and get back the result. @@ -68,7 +68,7 @@ renderAndConcat templatePaths renderables = HakyllAction actionFunction' _ = do contexts <- mapM runHakyllAction renders - return $ concatMap (fromMaybe "" . M.lookup "body") contexts + return $ concatMap (fromMaybe "" . M.lookup "body" . unContext) contexts -- | Chain a render action for a page with a number of templates. This will -- also write the result to the site destination. This is the preferred way @@ -112,8 +112,8 @@ css source = runHakyllActionIfNeeded css' -- | Write a page to the site destination. Final action after render -- chains and such. writePage :: HakyllAction Context () -writePage = createHakyllAction $ \initialContext -> do - additionalContext' <- askHakyll getAdditionalContext +writePage = createHakyllAction $ \(Context initialContext) -> do + additionalContext' <- unContext <$> askHakyll getAdditionalContext let url = fromMaybe (error "No url defined at write time.") (M.lookup "url" initialContext) body = fromMaybe "" (M.lookup "body" initialContext) @@ -121,4 +121,5 @@ writePage = createHakyllAction $ \initialContext -> do destination <- toDestination url makeDirectories destination -- Substitute $root here, just before writing. - liftIO $ writeFile destination $ finalSubstitute (fromString body) context + liftIO $ writeFile destination $ finalSubstitute (fromString body) + (Context context) diff --git a/src/Text/Hakyll/Tags.hs b/src/Text/Hakyll/Tags.hs index 8b7d96b..1ca74a5 100644 --- a/src/Text/Hakyll/Tags.hs +++ b/src/Text/Hakyll/Tags.hs @@ -43,7 +43,7 @@ import Control.Arrow (second, (>>>)) import Control.Applicative ((<$>)) import System.FilePath -import Text.Hakyll.Context (Context) +import Text.Hakyll.Context (Context (..)) import Text.Hakyll.ContextManipulations (changeValue) import Text.Hakyll.CreateContext (createPage) import Text.Hakyll.HakyllMonad (Hakyll) @@ -105,13 +105,13 @@ readTagMap :: String -- ^ Unique identifier for the map. readTagMap = readMap getTagsFunction where getTagsFunction = map trim . splitRegex "," - . fromMaybe [] . M.lookup "tags" + . fromMaybe [] . M.lookup "tags" . unContext -- | Read a @TagMap@, using the subdirectories the pages are placed in. readCategoryMap :: String -- ^ Unique identifier for the map. -> [FilePath] -- ^ Paths to get tags from. -> HakyllAction () TagMap -readCategoryMap = readMap $ maybeToList . M.lookup "category" +readCategoryMap = readMap $ maybeToList . M.lookup "category" . unContext withTagMap :: HakyllAction () TagMap -> (String -> [HakyllAction () Context] -> Hakyll ()) @@ -131,7 +131,7 @@ renderTagCloud urlFunction minSize maxSize = createHakyllAction renderTagCloud' return $ intercalate " " $ map (renderTag tagMap) (tagCount tagMap) renderTag tagMap (tag, count) = - finalSubstitute linkTemplate $ M.fromList + finalSubstitute linkTemplate $ Context $ M.fromList [ ("size", sizeTag tagMap count) , ("url", urlFunction tag) , ("tag", tag) diff --git a/tests/Page.hs b/tests/Page.hs index 1b80578..d12638e 100644 --- a/tests/Page.hs +++ b/tests/Page.hs @@ -35,7 +35,8 @@ test_readPage fileName content assertion = do temporaryDir <- getTemporaryDirectory let temporaryFile = temporaryDir fileName writeFile temporaryFile content - page <- runReaderT (readPage temporaryFile) defaultHakyllConfiguration + page <- runReaderT (readPage temporaryFile) + (defaultHakyllConfiguration "http://examples.com") removeFile temporaryFile return $ assertion page @@ -48,7 +49,7 @@ test_readPage_1 = test_readPage fileName content assertion @? "test_readPage_1" , "---" , "This is a simple test." ] - assertion page = M.lookup "author" page == Just "Eric Cartman" + assertion page = M.lookup "author" (unContext page) == Just "Eric Cartman" -- | readPage test case 2. test_readPage_2 = test_readPage fileName content assertion @? "test_readPage_2" @@ -59,8 +60,10 @@ test_readPage_2 = test_readPage fileName content assertion @? "test_readPage_2" , "---" , "This is the body." ] - assertion page = M.lookup "someSection" page == Just "This is a section.\n" - && M.lookup "body" page == Just "This is the body.\n" + assertion page = + let m = unContext page + in M.lookup "someSection" m == Just "This is a section.\n" + && M.lookup "body" m == Just "This is the body.\n" -- | readPage test case 3. test_readPage_3 = test_readPage fileName content assertion @? "test_readPage_3" @@ -68,7 +71,8 @@ test_readPage_3 = test_readPage fileName content assertion @? "test_readPage_3" fileName = "test_readPage_3.txt" content = unlines [ "No metadata here, sorry." ] - assertion page = M.lookup "body" page == Just "No metadata here, sorry.\n" + assertion page = + M.lookup "body" (unContext page) == Just "No metadata here, sorry.\n" -- | readPage test case 4. test_readPage_4 = test_readPage fileName content assertion @? "test_readPage_4" @@ -81,7 +85,7 @@ test_readPage_4 = test_readPage fileName content assertion @? "test_readPage_4" , "------" , "The header is not a separate section." ] - assertion page = M.lookup "body" page == Just body + assertion page = M.lookup "body" (unContext page) == Just body body = unlines [ "Header" , "------" , "The header is not a separate section." diff --git a/tests/Template.hs b/tests/Template.hs index 9924efb..4024b6a 100644 --- a/tests/Template.hs +++ b/tests/Template.hs @@ -5,6 +5,7 @@ module Template import qualified Data.Map as M import Control.Applicative ((<$>)) import Control.Monad (replicateM) +import Data.Monoid (mempty) import Data.Binary import Test.Framework (testGroup) @@ -13,6 +14,7 @@ import Test.Framework.Providers.QuickCheck2 import Test.HUnit import Test.QuickCheck +import Text.Hakyll.Context (Context (..)) import Text.Hakyll.Internal.Template -- Template test group. @@ -58,18 +60,18 @@ prop_template_encode_id template = decode (encode template) == template -- Check we get the same sting with empty substitutions. prop_substitute_id string = - regularSubstitute (fromString string) M.empty == string + regularSubstitute (fromString string) mempty == string -- substitute test case 1. test_substitute_1 = finalSubstitute template context @?= "Banana costs $4." where template = fromString "$product costs $$$price." - context = M.fromList [("product", "Banana"), ("price", "4")] + context = Context $ M.fromList [("product", "Banana"), ("price", "4")] -- substitute test case 2. test_substitute_2 = regularSubstitute template context @?= "$$root is a special key." where template = fromString "$$root is a special $thing." - context = M.fromList [("root", "foo"), ("thing", "key")] + context = Context $ M.fromList [("root", "foo"), ("thing", "key")] -- cgit v1.2.3