bb9ea6f · hakyll · git.iko.soy

git.iko.soy/hakyll

Add newtype for Context

commitbb9ea6f1226b55a584cfcec47efeddabc230418d authorJasper Van der Jeugt <jaspervdj@gmail.com> dateSun 20 Jun 2010, 10:45 (16 years ago) parent2282e78

12 files changed+57−42

compare with master

unifiedsplit

src/Text/Hakyll.hs+2−2 src/Text/Hakyll/Context.hs+7−2 src/Text/Hakyll/ContextManipulations.hs+2−2 src/Text/Hakyll/CreateContext.hs+5−3 src/Text/Hakyll/Feed.hs+3−3 src/Text/Hakyll/HakyllMonad.hs+3−3 src/Text/Hakyll/Internal/Page.hs+2−2 src/Text/Hakyll/Internal/Template.hs+4−3 src/Text/Hakyll/Render.hs+10−9 src/Text/Hakyll/Tags.hs+4−4 tests/Page.hs+10−6 tests/Template.hs+5−3

src/Text/Hakyll.hs+2−2

@@ -15,7 +15,7 @@ module Text.Hakyll

1515

1616import Control.Monad.Reader (runReaderT, liftIO, ask)

1717import Control.Monad (when)

18−import qualified Data.Map as M

18+import Data.Monoid (mempty)

1919import System.Environment (getArgs, getProgName)

2020import System.Directory (doesDirectoryExist, removeDirectoryRecursive)

2121

@@ -48,7 +48,7 @@ defaultHakyllConfiguration :: String -- ^ Absolute site URL.

4848 -> HakyllConfiguration -- ^ Default config.

4949defaultHakyllConfiguration absoluteUrl' = HakyllConfiguration

5050 { absoluteUrl = absoluteUrl'

51− , additionalContext = M.empty

51+ , additionalContext = mempty

5252 , siteDirectory = "_site"

5353 , cacheDirectory = "_cache"

5454 , enableIndexUrl = False

src/Text/Hakyll/Context.hs+7−2

@@ -1,11 +1,16 @@

11-- | This (quite small) module exports the datatype used for contexts. A

22-- @Context@ is a simple key-value mapping. You can render these @Context@s

33-- with templates, and manipulate them in various ways.

4+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

45module Text.Hakyll.Context

5− ( Context

6+ ( Context (..)

67 ) where

9+import Data.Monoid (Monoid)

810import Data.Map (Map)

11+import Data.Binary (Binary)

912

1013-- | Datatype used for key-value mappings.

11−type Context = Map String String

14+newtype Context = Context { -- | Extract the context.

15+ unContext :: Map String String

16+ } deriving (Show, Monoid, Binary)

src/Text/Hakyll/ContextManipulations.hs+2−2

@@ -21,7 +21,7 @@ import qualified Data.Map as M

2121

2222import Text.Hakyll.Regex (substituteRegex)

2323import Text.Hakyll.HakyllAction (HakyllAction (..))

24−import Text.Hakyll.Context (Context)

24+import Text.Hakyll.Context (Context (..))

2525

2626-- | Do something with a value in a @Context@, but keep the old value as well.

2727-- 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.

2929 -> String -- ^ Key the value should be copied to.

3030 -> (String -> String) -- ^ Function to apply on the value.

3131 -> HakyllAction Context Context

32−renderValue source destination f = arr $ \context ->

32+renderValue source destination f = arr $ \(Context context) -> Context $

3333 case M.lookup source context of

3434 Nothing -> context

3535 (Just value) -> M.insert destination (f value) context

src/Text/Hakyll/CreateContext.hs+5−3

@@ -42,7 +42,7 @@ createCustomPage :: FilePath

4242createCustomPage url association = HakyllAction

4343 { actionDependencies = dataDependencies

4444 , actionUrl = Left $ return url

45− , actionFunction = \_ -> M.fromList <$> assoc'

45+ , actionFunction = \_ -> Context . M.fromList <$> assoc'

4646 }

4747 where

4848 mtuple (a, b) = b >>= \b' -> return (a, b')

@@ -80,7 +80,8 @@ combine x y = HakyllAction

8080 { actionDependencies = actionDependencies x ++ actionDependencies y

8181 , actionUrl = actionUrl x

8282 , actionFunction = \_ ->

83− liftM2 M.union (runHakyllAction x) (runHakyllAction y)

83+ Context <$> liftM2 (M.union) (unContext <$> runHakyllAction x)

84+ (unContext <$> runHakyllAction y)

8485 }

8586

8687-- | Combine two @Context@s and set a custom URL. This behaves like @combine@,

@@ -91,7 +92,8 @@ combineWithUrl :: FilePath

9192 -> HakyllAction () Context

9293combineWithUrl url x y = combine'

9394 { actionUrl = Left $ return url

94− , actionFunction = \_ -> M.insert "url" url <$> runHakyllAction combine'

95+ , actionFunction = \_ ->

96+ Context . M.insert "url" url . unContext <$> runHakyllAction combine'

9597 }

9698 where

9799 combine' = combine x y

src/Text/Hakyll/Feed.hs+3−3

@@ -28,7 +28,7 @@ import Control.Monad.Reader (liftIO)

2828import Data.Maybe (fromMaybe)

2929import qualified Data.Map as M

3030

31−import Text.Hakyll.Context (Context)

31+import Text.Hakyll.Context (Context (..))

3232import Text.Hakyll.CreateContext (createListing)

3333import Text.Hakyll.ContextManipulations (renderDate)

3434import Text.Hakyll.HakyllMonad (Hakyll)

@@ -69,8 +69,8 @@ createFeed configuration renderables template itemTemplate =

6969 ] ++ updated

7070

7171 -- Take the first timestamp, which should be the most recent.

72− updated = let action = createHakyllAction $

73− return . fromMaybe "foo" . M.lookup "timestamp"

72+ updated = let action = createHakyllAction $ return . fromMaybe "foo"

73+ . M.lookup "timestamp" . unContext

7474 toTuple r = ("timestamp", Right $ r >>> action)

7575 in map toTuple $ take 1 renderables

7676

src/Text/Hakyll/HakyllMonad.hs+3−3

@@ -12,7 +12,7 @@ import qualified Data.Map as M

1212

1313import Text.Pandoc (ParserState, WriterOptions)

1414

15−import Text.Hakyll.Context (Context)

15+import Text.Hakyll.Context (Context (..))

1616

1717-- | Our custom monad stack.

1818type Hakyll = ReaderT HakyllConfiguration IO

@@ -50,5 +50,5 @@ askHakyll = flip liftM ask

5050

5151getAdditionalContext :: HakyllConfiguration -> Context

5252getAdditionalContext configuration =

53− M.insert "absolute" (absoluteUrl configuration)

54− (additionalContext configuration)

53+ let (Context c) = additionalContext configuration

54+ in Context $ M.insert "absolute" (absoluteUrl configuration) c

src/Text/Hakyll/Internal/Page.hs+2−2

@@ -12,7 +12,7 @@ import Control.Monad.State (State, evalState, get, put)

1212

1313import Text.Pandoc

1414

15−import Text.Hakyll.Context (Context)

15+import Text.Hakyll.Context (Context (..))

1616import Text.Hakyll.File

1717import Text.Hakyll.HakyllMonad

1818import Text.Hakyll.Regex (substituteRegex, matchesRegex)

@@ -103,7 +103,7 @@ readPageFromFile path = do

103103 context = M.fromList $

104104 ("url", url) : ("path", path) : category ++ sectionsData

105105

106− return context

106+ return $ Context context

107107 where

108108 category = let dirs = splitDirectories $ takeDirectory path

109109 in [("category", last dirs) | not (null dirs)]

src/Text/Hakyll/Internal/Template.hs+4−3

@@ -7,6 +7,7 @@ module Text.Hakyll.Internal.Template

77 , finalSubstitute

88 ) where

10+import Control.Applicative ((<$>))

1011import Data.List (isPrefixOf)

1112import Data.Char (isAlphaNum)

1213import Data.Binary

@@ -15,7 +16,7 @@ import Data.Maybe (fromMaybe)

1516import System.FilePath ((</>))

1617import qualified Data.Map as M

1718

18−import Text.Hakyll.Context (Context)

19+import Text.Hakyll.Context (Context (..))

1920import Text.Hakyll.HakyllMonad (Hakyll)

2021import Text.Hakyll.Internal.Cache

2122import Text.Hakyll.Internal.Page

@@ -47,7 +48,7 @@ readTemplate path = do

4748 if isCacheMoreRecent'

4849 then getFromCache fileName

4950 else do

50− page <- readPage path

51+ page <- unContext <$> readPage path

5152 let body = fromMaybe (error $ "No body in template " ++ fileName)

5253 (M.lookup "body" page)

5354 template = fromString body

@@ -65,7 +66,7 @@ substitute escaper (Chunk chunk template) context =

6566substitute escaper (Identifier key template) context =

6667 replacement ++ substitute escaper template context

6768 where

68− replacement = fromMaybe ('$' : key) $ M.lookup key context

69+ replacement = fromMaybe ('$' : key) $ M.lookup key $ unContext context

6970substitute escaper (EscapeCharacter template) context =

7071 escaper ++ substitute escaper template context

7172substitute _ End _ = []

src/Text/Hakyll/Render.hs+10−9

@@ -16,7 +16,7 @@ import System.Directory (copyFile)

1616import Data.Maybe (fromMaybe)

1717import qualified Data.Map as M

1818

19−import Text.Hakyll.Context (Context)

19+import Text.Hakyll.Context (Context (..))

2020import Text.Hakyll.HakyllMonad (Hakyll, askHakyll, getAdditionalContext)

2121import Text.Hakyll.File

2222import Text.Hakyll.HakyllAction

@@ -27,12 +27,12 @@ import Text.Hakyll.Internal.Template

2727pureRender :: Template -- ^ Template to use for rendering.

2828 -> Context -- ^ Renderable object to render with given template.

2929 -> Context -- ^ The body of the result will contain the render.

30−pureRender template context =

30+pureRender template (Context c) =

3131 -- Ignore $root when substituting here. We will only replace that in the

3232 -- final render (just before writing).

33− let contextIgnoringRoot = M.insert "root" "$root" context

34− body = regularSubstitute template contextIgnoringRoot

35− in M.insert "body" body context

33+ let contextIgnoringRoot = Context $ M.insert "root" "$root" c

34+ body = regularSubstitute template $ contextIgnoringRoot

35+ in Context $ M.insert "body" body c

3636

3737-- | This is the most simple render action. You render a @Context@ with a

3838-- template, and get back the result.

@@ -68,7 +68,7 @@ renderAndConcat templatePaths renderables = HakyllAction

6868

6969 actionFunction' _ = do

7070 contexts <- mapM runHakyllAction renders

71− return $ concatMap (fromMaybe "" . M.lookup "body") contexts

71+ return $ concatMap (fromMaybe "" . M.lookup "body" . unContext) contexts

7272

7373-- | Chain a render action for a page with a number of templates. This will

7474-- also write the result to the site destination. This is the preferred way

@@ -112,8 +112,8 @@ css source = runHakyllActionIfNeeded css'

112112-- | Write a page to the site destination. Final action after render

113113-- chains and such.

114114writePage :: HakyllAction Context ()

115−writePage = createHakyllAction $ \initialContext -> do

116− additionalContext' <- askHakyll getAdditionalContext

115+writePage = createHakyllAction $ \(Context initialContext) -> do

116+ additionalContext' <- unContext <$> askHakyll getAdditionalContext

117117 let url = fromMaybe (error "No url defined at write time.")

118118 (M.lookup "url" initialContext)

119119 body = fromMaybe "" (M.lookup "body" initialContext)

@@ -121,4 +121,5 @@ writePage = createHakyllAction $ \initialContext -> do

121121 destination <- toDestination url

122122 makeDirectories destination

123123 -- Substitute $root here, just before writing.

124− liftIO $ writeFile destination $ finalSubstitute (fromString body) context

124+ liftIO $ writeFile destination $ finalSubstitute (fromString body)

125+ (Context context)

src/Text/Hakyll/Tags.hs+4−4

@@ -43,7 +43,7 @@ import Control.Arrow (second, (>>>))

4343import Control.Applicative ((<$>))

4444import System.FilePath

4545

46−import Text.Hakyll.Context (Context)

46+import Text.Hakyll.Context (Context (..))

4747import Text.Hakyll.ContextManipulations (changeValue)

4848import Text.Hakyll.CreateContext (createPage)

4949import Text.Hakyll.HakyllMonad (Hakyll)

@@ -105,13 +105,13 @@ readTagMap :: String -- ^ Unique identifier for the map.

105105readTagMap = readMap getTagsFunction

106106 where

107107 getTagsFunction = map trim . splitRegex ","

108− . fromMaybe [] . M.lookup "tags"

108+ . fromMaybe [] . M.lookup "tags" . unContext

109109

110110-- | Read a @TagMap@, using the subdirectories the pages are placed in.

111111readCategoryMap :: String -- ^ Unique identifier for the map.

112112 -> [FilePath] -- ^ Paths to get tags from.

113113 -> HakyllAction () TagMap

114−readCategoryMap = readMap $ maybeToList . M.lookup "category"

114+readCategoryMap = readMap $ maybeToList . M.lookup "category" . unContext

115115

116116withTagMap :: HakyllAction () TagMap

117117 -> (String -> [HakyllAction () Context] -> Hakyll ())

@@ -131,7 +131,7 @@ renderTagCloud urlFunction minSize maxSize = createHakyllAction renderTagCloud'

131131 return $ intercalate " " $ map (renderTag tagMap) (tagCount tagMap)

132132

133133 renderTag tagMap (tag, count) =

134− finalSubstitute linkTemplate $ M.fromList

134+ finalSubstitute linkTemplate $ Context $ M.fromList

135135 [ ("size", sizeTag tagMap count)

136136 , ("url", urlFunction tag)

137137 , ("tag", tag)

tests/Page.hs+10−6

@@ -35,7 +35,8 @@ test_readPage fileName content assertion = do

3535 temporaryDir <- getTemporaryDirectory

3636 let temporaryFile = temporaryDir </> fileName

3737 writeFile temporaryFile content

38− page <- runReaderT (readPage temporaryFile) defaultHakyllConfiguration

38+ page <- runReaderT (readPage temporaryFile)

39+ (defaultHakyllConfiguration "http://examples.com")

3940 removeFile temporaryFile

4041 return $ assertion page

4142

@@ -48,7 +49,7 @@ test_readPage_1 = test_readPage fileName content assertion @? "test_readPage_1"

4849 , "---"

4950 , "This is a simple test."

5051 ]

51− assertion page = M.lookup "author" page == Just "Eric Cartman"

52+ assertion page = M.lookup "author" (unContext page) == Just "Eric Cartman"

5253

5354-- | readPage test case 2.

5455test_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"

5960 , "---"

6061 , "This is the body."

6162 ]

62− assertion page = M.lookup "someSection" page == Just "This is a section.\n"

63− && M.lookup "body" page == Just "This is the body.\n"

63+ assertion page =

64+ let m = unContext page

65+ in M.lookup "someSection" m == Just "This is a section.\n"

66+ && M.lookup "body" m == Just "This is the body.\n"

6467

6568-- | readPage test case 3.

6669test_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"

6871 fileName = "test_readPage_3.txt"

6972 content = unlines [ "No metadata here, sorry."

7073 ]

71− assertion page = M.lookup "body" page == Just "No metadata here, sorry.\n"

74+ assertion page =

75+ M.lookup "body" (unContext page) == Just "No metadata here, sorry.\n"

7276

7377-- | readPage test case 4.

7478test_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"

8185 , "------"

8286 , "The header is not a separate section."

8387 ]

84− assertion page = M.lookup "body" page == Just body

88+ assertion page = M.lookup "body" (unContext page) == Just body

8589 body = unlines [ "Header"

8690 , "------"

8791 , "The header is not a separate section."

tests/Template.hs+5−3

@@ -5,6 +5,7 @@ module Template

55import qualified Data.Map as M

66import Control.Applicative ((<$>))

77import Control.Monad (replicateM)

8+import Data.Monoid (mempty)

910import Data.Binary

1011import Test.Framework (testGroup)

@@ -13,6 +14,7 @@ import Test.Framework.Providers.QuickCheck2

1314import Test.HUnit

1415import Test.QuickCheck

1516

17+import Text.Hakyll.Context (Context (..))

1618import Text.Hakyll.Internal.Template

1719

1820-- Template test group.

@@ -58,18 +60,18 @@ prop_template_encode_id template = decode (encode template) == template

5860

5961-- Check we get the same sting with empty substitutions.

6062prop_substitute_id string =

61− regularSubstitute (fromString string) M.empty == string

63+ regularSubstitute (fromString string) mempty == string

6264

6365-- substitute test case 1.

6466test_substitute_1 =

6567 finalSubstitute template context @?= "Banana costs $4."

6668 where

6769 template = fromString "$product costs $$$price."

68− context = M.fromList [("product", "Banana"), ("price", "4")]

70+ context = Context $ M.fromList [("product", "Banana"), ("price", "4")]

6971

7072-- substitute test case 2.

7173test_substitute_2 =

7274 regularSubstitute template context @?= "$$root is a special key."

7375 where

7476 template = fromString "$$root is a special $thing."

75− context = M.fromList [("root", "foo"), ("thing", "key")]

77+ context = Context $ M.fromList [("root", "foo"), ("thing", "key")]