bb9ea6f · hakyll · git.iko.soy

src/Text/Hakyll.hs+2−2

compare with master

unifiedsplit

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

15

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

17import Control.Monad (when)

18−import qualified Data.Map as M

18+import Data.Monoid (mempty)

19import System.Environment (getArgs, getProgName)

20import System.Directory (doesDirectoryExist, removeDirectoryRecursive)

21

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

48 -> HakyllConfiguration -- ^ Default config.

49defaultHakyllConfiguration absoluteUrl' = HakyllConfiguration

50 { absoluteUrl = absoluteUrl'

51− , additionalContext = M.empty

51+ , additionalContext = mempty

52 , siteDirectory = "_site"

53 , cacheDirectory = "_cache"

54 , enableIndexUrl = False

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

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

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

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

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

4+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

4module Text.Hakyll.Context

5module Text.Hakyll.Context

5− ( Context

6+ ( Context (..)

6 ) where

7 ) where

7

8

9+import Data.Monoid (Monoid)

8import Data.Map (Map)

10import Data.Map (Map)

11+import Data.Binary (Binary)

9

12

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

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

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

11−type Context = Map String String

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

21

22import Text.Hakyll.Regex (substituteRegex)

23import Text.Hakyll.HakyllAction (HakyllAction (..))

24−import Text.Hakyll.Context (Context)

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

25

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

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

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

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

31 -> HakyllAction Context Context

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

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

33 case M.lookup source context of

34 Nothing -> context

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

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

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

42createCustomPage url association = HakyllAction

43 { actionDependencies = dataDependencies

44 , actionUrl = Left $ return url

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

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

46 }

47 where

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

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

80 { actionDependencies = actionDependencies x ++ actionDependencies y

81 , actionUrl = actionUrl x

82 , actionFunction = \_ ->

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

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

84+ (unContext <$> runHakyllAction y)

84 }

85 }

85

86

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

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

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

91 -> HakyllAction () Context

92 -> HakyllAction () Context

92combineWithUrl url x y = combine'

93combineWithUrl url x y = combine'

93 { actionUrl = Left $ return url

94 { actionUrl = Left $ return url

95+ , actionFunction = \_ ->

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

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

95 }

97 }

96 where

98 where

97 combine' = combine x y

99 combine' = combine x y

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

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

28import Data.Maybe (fromMaybe)

29import qualified Data.Map as M

30

31−import Text.Hakyll.Context (Context)

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

32import Text.Hakyll.CreateContext (createListing)

33import Text.Hakyll.ContextManipulations (renderDate)

34import Text.Hakyll.HakyllMonad (Hakyll)

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

69 ] ++ updated

70

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

72− updated = let action = createHakyllAction $

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

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

73+ . M.lookup "timestamp" . unContext

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

75 in map toTuple $ take 1 renderables

76

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

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

12

13import Text.Pandoc (ParserState, WriterOptions)

14

15−import Text.Hakyll.Context (Context)

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

16

17-- | Our custom monad stack.

18type Hakyll = ReaderT HakyllConfiguration IO

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

50

51getAdditionalContext :: HakyllConfiguration -> Context

52getAdditionalContext configuration =

53+ let (Context c) = additionalContext configuration

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

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

54− (additionalContext configuration)

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

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

12

13import Text.Pandoc

14

15−import Text.Hakyll.Context (Context)

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

16import Text.Hakyll.File

17import Text.Hakyll.HakyllMonad

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

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

103 context = M.fromList $

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

105

106− return context

106+ return $ Context context

107 where

108 category = let dirs = splitDirectories $ takeDirectory path

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

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

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

7 , finalSubstitute

8 ) where

9

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

10import Data.List (isPrefixOf)

11import Data.List (isPrefixOf)

11import Data.Char (isAlphaNum)

12import Data.Char (isAlphaNum)

12import Data.Binary

13import Data.Binary

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

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

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

16import qualified Data.Map as M

17import qualified Data.Map as M

17

18

18−import Text.Hakyll.Context (Context)

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

19import Text.Hakyll.HakyllMonad (Hakyll)

20import Text.Hakyll.HakyllMonad (Hakyll)

20import Text.Hakyll.Internal.Cache

21import Text.Hakyll.Internal.Cache

21import Text.Hakyll.Internal.Page

22import Text.Hakyll.Internal.Page

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

47 if isCacheMoreRecent'

48 if isCacheMoreRecent'

48 then getFromCache fileName

49 then getFromCache fileName

49 else do

50 else do

50− page <- readPage path

51+ page <- unContext <$> readPage path

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

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

52 (M.lookup "body" page)

53 (M.lookup "body" page)

53 template = fromString body

54 template = fromString body

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

65substitute escaper (Identifier key template) context =

66substitute escaper (Identifier key template) context =

66 replacement ++ substitute escaper template context

67 replacement ++ substitute escaper template context

67 where

68 where

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

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

69substitute escaper (EscapeCharacter template) context =

70substitute escaper (EscapeCharacter template) context =

70 escaper ++ substitute escaper template context

71 escaper ++ substitute escaper template context

71substitute _ End _ = []

72substitute _ End _ = []

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

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

16import Data.Maybe (fromMaybe)

17import qualified Data.Map as M

18

19−import Text.Hakyll.Context (Context)

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

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

21import Text.Hakyll.File

22import Text.Hakyll.HakyllAction

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

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

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

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

30−pureRender template context =

30+pureRender template (Context c) =

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

32 -- final render (just before writing).

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

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

34− body = regularSubstitute template contextIgnoringRoot

34+ body = regularSubstitute template $ contextIgnoringRoot

35− in M.insert "body" body context

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

36

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

38-- template, and get back the result.

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

68

69 actionFunction' _ = do

70 contexts <- mapM runHakyllAction renders

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

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

72

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

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

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

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

113-- chains and such.

114writePage :: HakyllAction Context ()

115−writePage = createHakyllAction $ \initialContext -> do

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

116− additionalContext' <- askHakyll getAdditionalContext

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

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

118 (M.lookup "url" initialContext)

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

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

121 destination <- toDestination url

122 makeDirectories destination

123 -- 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, (>>>))

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

44import System.FilePath

45

46−import Text.Hakyll.Context (Context)

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

47import Text.Hakyll.ContextManipulations (changeValue)

48import Text.Hakyll.CreateContext (createPage)

49import Text.Hakyll.HakyllMonad (Hakyll)

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

105readTagMap = readMap getTagsFunction

106 where

107 getTagsFunction = map trim . splitRegex ","

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

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

109

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

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

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

113 -> HakyllAction () TagMap

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

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

115

116withTagMap :: HakyllAction () TagMap

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

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

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

132

133 renderTag tagMap (tag, count) =

134− finalSubstitute linkTemplate $ M.fromList

134+ finalSubstitute linkTemplate $ Context $ M.fromList

135 [ ("size", sizeTag tagMap count)

136 , ("url", urlFunction tag)

137 , ("tag", tag)

tests/Page.hs+10−6

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

35 temporaryDir <- getTemporaryDirectory

36 let temporaryFile = temporaryDir </> fileName

37 writeFile temporaryFile content

38− page <- runReaderT (readPage temporaryFile) defaultHakyllConfiguration

38+ page <- runReaderT (readPage temporaryFile)

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

39 removeFile temporaryFile

40 removeFile temporaryFile

40 return $ assertion page

41 return $ assertion page

41

42

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

48 , "---"

49 , "---"

49 , "This is a simple test."

50 , "This is a simple test."

50 ]

51 ]

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

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

52

53

53-- | readPage test case 2.

54-- | readPage test case 2.

54test_readPage_2 = test_readPage fileName content assertion @? "test_readPage_2"

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

59 , "---"

60 , "---"

60 , "This is the body."

61 , "This is the body."

61 ]

62 ]

63+ assertion page =

64+ let m = unContext page

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

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

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

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

64

67

65-- | readPage test case 3.

68-- | readPage test case 3.

66test_readPage_3 = test_readPage fileName content assertion @? "test_readPage_3"

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

68 fileName = "test_readPage_3.txt"

71 fileName = "test_readPage_3.txt"

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

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

70 ]

73 ]

74+ assertion page =

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

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

72

76

73-- | readPage test case 4.

77-- | readPage test case 4.

74test_readPage_4 = test_readPage fileName content assertion @? "test_readPage_4"

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

81 , "------"

85 , "------"

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

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

83 ]

87 ]

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

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

85 body = unlines [ "Header"

89 body = unlines [ "Header"

86 , "------"

90 , "------"

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

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

tests/Template.hs+5−3

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

5import qualified Data.Map as M

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

7import Control.Monad (replicateM)

8+import Data.Monoid (mempty)

8

9

9import Data.Binary

10import Data.Binary

10import Test.Framework (testGroup)

11import Test.Framework (testGroup)

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

13import Test.HUnit

14import Test.HUnit

14import Test.QuickCheck

15import Test.QuickCheck

15

16

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

16import Text.Hakyll.Internal.Template

18import Text.Hakyll.Internal.Template

17

19

18-- Template test group.

20-- Template test group.

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

58

60

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

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

60prop_substitute_id string =

62prop_substitute_id string =

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

63+ regularSubstitute (fromString string) mempty == string

62

64

63-- substitute test case 1.

65-- substitute test case 1.

64test_substitute_1 =

66test_substitute_1 =

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

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

66 where

68 where

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

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

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

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

69

71

70-- substitute test case 2.

72-- substitute test case 2.

71test_substitute_2 =

73test_substitute_2 =

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

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

73 where

75 where

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

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

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

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