diff --git a/hakyllbars.cabal b/hakyllbars.cabal --- a/hakyllbars.cabal +++ b/hakyllbars.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: hakyllbars -version: 1.0.0.0 +version: 1.0.0.1 synopsis: A Hakyll compiler for Handlebars-like templates description: Hakyllbars brings a handlebars-like template syntax to Hakyll. Please see the README at @@ -100,7 +100,7 @@ , directory >=1.3.6 && <1.4 , filepath >=1.4.2 && <1.5 , hakyll >=4.16.1 && <4.17 - , mtl >=2.2.2 && <2.3 + , mtl >=2.2.2 && <3 , network-uri >=2.6.4 && <2.7 , pandoc >=3.0.1 && <3.2 , parsec >=3.1.15 && <3.2 @@ -181,10 +181,6 @@ Hakyllbars.Source.ParserSpec Hakyllbars.Source.TestSupport Hakyllbars.TestSupport - Hakyllbars.TestSupport.Compiler - Hakyllbars.TestSupport.Config - Hakyllbars.TestSupport.Resource - Hakyllbars.TestSupport.TestEnv Paths_hakyllbars hs-source-dirs: test @@ -234,10 +230,7 @@ ghc-options: -fprint-potential-instances -Wall -Wcompat -Widentities -Wincomplete-patterns -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-home-modules -Wname-shadowing -Wpartial-fields -Wredundant-constraints -Wunused-packages -Wunused-type-patterns -threaded -rtsopts -with-rtsopts=-N build-depends: base >=4.14 && <5 - , containers >=0.6.7 && <0.7 - , hakyll >=4.16.1 && <4.17 , hakyllbars - , hspec >=2.10.10 && <2.11 + , hspec >=2.10.10 && <3 , parsec >=3.1.15 && <3.2 - , time >=1.12.2 && <1.13 default-language: Haskell2010 diff --git a/src/Hakyllbars/Field.hs b/src/Hakyllbars/Field.hs --- a/src/Hakyllbars/Field.hs +++ b/src/Hakyllbars/Field.hs @@ -45,6 +45,7 @@ import Hakyllbars.Util (stripSuffix) import System.FilePath +-- | The default recommended fields to use for your website templates. defaultFields :: String -> String -> Context String defaultFields host siteRoot = mconcat @@ -78,12 +79,15 @@ constField "description" ("" :: String) ] +-- | An empty string context value. emptyString :: ContextValue a emptyString = intoValue ("" :: String) +-- | A context with the given keys and empty string values. defaultKeys :: [String] -> Context a defaultKeys keys = intoContext $ (,"" :: String) <$> keys +-- | Sets a scope in which the given fields are active in the context. withField :: String -> Context String withField key = functionField2 key f where @@ -91,6 +95,7 @@ tplWithContext context do reduceBlocks blocks +-- | Includes the given file in the template. includeField :: String -> Maybe FilePath -> Maybe FilePath -> Context String includeField key basePath extension = functionField key f where @@ -102,6 +107,7 @@ applyTemplate (fromFilePath filePath'') itemValue context <$> tplPopItem +-- | Sets a layout to interpolate the template into. layoutField :: String -> FilePath -> Maybe FilePath -> Context String layoutField key basePath extension = functionField2 key f where @@ -114,12 +120,15 @@ tplWithItem item do reduceBlocks bs +-- | Conditionally renders a block. ifField :: forall a. String -> Context a ifField key = functionField key isTruthy +-- | Context field for iterating over a list of items. forField :: String -> Context String forField key = functionField2 key applyForLoop +-- | Iterates over a list of items, applying their context to the given block. applyForLoop :: ContextValue String -> [Block] -> TemplateRunner String (Maybe String) applyForLoop items blocks = getAsItems items @@ -134,9 +143,11 @@ tplWithItem item do reduceBlocks blocks +-- | Gets a context value as a list of items. getAsItems :: ContextValue String -> TemplateRunner String (Context String, [Item String]) getAsItems = fromValue +-- | Gets a context value as a list of strings. getAsStrings :: ContextValue String -> TemplateRunner String (Context String, [Item String]) getAsStrings x = do bodies <- fromValue x :: TemplateRunner String [String] @@ -157,6 +168,7 @@ StringValue k -> return k _ -> tplFail "forEach: key must be a string or identifier" +-- | Gets a default context value if none is provided. defaultField :: forall a. String -> Context a defaultField key = functionField2 key f where @@ -165,6 +177,7 @@ True -> arg False -> default' +-- | Creates a link with the title to the given item. linkedTitleField :: String -> String -> String -> Context String linkedTitleField key titleKey urlKey = constField key f where @@ -194,9 +207,11 @@ (return . intoValue) (KeyMap.lookup (Key.fromString key) m) +-- | The body of the current item. bodyField :: String -> Context String bodyField key = field key $ return . itemBody +-- | The absolute url to the site root. siteUrlField :: String -> String -> String -> Context a siteUrlField key hostKey siteRootKey = field key f where @@ -206,16 +221,19 @@ siteRoot <- fromValue =<< unContext context siteRootKey return (host ++ siteRoot :: String) +-- | The url path to the given item. urlField :: String -> String -> Context a urlField key siteRootKey = field key f where f = getUri key siteRootKey . itemIdentifier +-- | Gets the url path to the given item file path. getUrlField :: String -> String -> Context a getUrlField key siteRootKey = functionField key f where f = getUri key siteRootKey . fromFilePath +-- | Gets the uri to the given item identifier. getUri :: String -> String -> Identifier -> TemplateRunner a String getUri key siteRootKey id' = do siteRoot <- @@ -231,6 +249,7 @@ let uri = stripSuffix "index.html" definitelyRoute return if null uri then siteRoot else siteRoot ++ uri +-- | Gets the absolute url to the current item. absUrlField :: String -> String -> String -> Context a absUrlField key hostKey urlKey = field key f where @@ -240,6 +259,7 @@ url <- fromValue =<< unContext context urlKey return (host ++ url :: String) +-- | Gets the absolute url to the given item file path. getAbsUrlField :: forall a. String -> String -> String -> Context a getAbsUrlField key hostKey getUrlKey = functionField key f where @@ -250,14 +270,20 @@ url <- getUrl (intoValue filePath :: ContextValue a) return (host ++ url :: String) +-- | Gets the destination path to the current item. pathField :: String -> Context a pathField key = field key $ return . toFilePath . itemIdentifier +-- | Gets the title of the current item from the file name. titleFromFileField :: String -> Context a titleFromFileField = bindField titleFromPath . pathField where titleFromPath = return . takeBaseName +-- | Extracts the teaser from the current item. +-- +-- The teaser is noted in the item body with the HTML comment ``. All +-- content preceding this comment is considered the teaser. teaserField :: String -> Snapshot -> Context String teaserField key snapshot = field key f where @@ -273,7 +299,13 @@ | otherwise = go (x : acc) xs go _ [] = Nothing -metadataPriorityField :: String -> [String] -> Context a +-- | Gets the value of the first metadata key that exists. +metadataPriorityField :: + -- | The context key. + String -> + -- | The list of metadata keys to try in order of priority. + [String] -> + Context a metadataPriorityField key priorityKeys = field key f where f item = @@ -296,12 +328,14 @@ current <- tplGet name `catchError` \_ -> return [] tplPut $ constField name (value : current) +-- | Puts a block of content into the context by a given name. putBlockField :: String -> Context a putBlockField key = functionField2 key f where f (name :: String) (blocks :: [Block]) = do tplPut $ constField name blocks +-- | Adds a block of content to the given context collection identified by a name. addBlockField :: String -> Context a addBlockField key = functionField2 key f where diff --git a/src/Hakyllbars/Field/Date.hs b/src/Hakyllbars/Field/Date.hs --- a/src/Hakyllbars/Field/Date.hs +++ b/src/Hakyllbars/Field/Date.hs @@ -24,15 +24,23 @@ import Hakyllbars.Util data DateConfig = DateConfig - { dateConfigLocale :: TimeLocale, + { -- | The locale to use for date formatting. + dateConfigLocale :: TimeLocale, + -- | The current time (or time at which the site generator is running). dateConfigCurrentTime :: ZonedTime, + -- | The format to use for long dates (i.e. date with time). dateConfigDateLongFormat :: String, + -- | The format to use for short dates (i.e. date without time). dateConfigDateShortFormat :: String, + -- | The format to use for time only. dateConfigTimeFormat :: String, + -- | The format to use for machine-readable dates. dateConfigRobotDateFormat :: String, + -- | The format to use for machine-readable times. dateConfigRobotTimeFormat :: String } +-- | Creates a default date configuration with the given locale and current time. defaultDateConfigWith :: TimeLocale -> ZonedTime -> DateConfig defaultDateConfigWith locale currentTime = DateConfig @@ -45,6 +53,7 @@ dateConfigRobotTimeFormat = "%Y-%m-%dT%H:%M:%S%Ez" } +-- | Creates a default date fields configuration with the given date config. dateFields :: DateConfig -> Context a dateFields config = mconcat @@ -62,6 +71,7 @@ dateFormatField "dateAs" (dateConfigLocale config) ] +-- | Gets a date formatted with the given format. dateFormatField :: String -> TimeLocale -> Context a dateFormatField key timeLocale = functionField2 key f where @@ -70,6 +80,7 @@ return $ formatTime timeLocale dateFormat date deserializeTime = parseTimeM' timeLocale normalizedDateTimeFormat +-- | Gets the date relative to the configured time locale and current time from the "date" or "published" fields. dateField :: String -> TimeLocale -> ZonedTime -> Context a dateField key timeLocale currentTime = field key f where @@ -81,6 +92,7 @@ maybe (dateFromFilePath timeLocale item) return maybeDateString <|> return (formatTime timeLocale "%Y-%m-%dT%H:%M:%S%Ez" currentTime) +-- | Gets the published date of an item from the metadata fields "published" or "date". publishedField :: String -> TimeLocale -> Context a publishedField key timeLocale = field key f where @@ -93,6 +105,7 @@ . maybe (noResult $ "Tried published field " ++ show key) return . dateFromMetadata timeLocale ["published", "date"] +-- | Gets the updated date of an item from the metadata fields "updated", "published", or "date". updatedField :: String -> TimeLocale -> Context a updatedField key timeLocale = field key f where @@ -105,6 +118,8 @@ . maybe (noResult $ "Tried updated field " ++ show key) return . dateFromMetadata timeLocale ["updated", "published", "date"] +-- | Gets the last modified date of an item from the metadata fields "updated", "published", or "date", or the file path +-- if it contains a date. getLastModifiedDate :: TimeLocale -> Item a -> Compiler ZonedTime getLastModifiedDate timeLocale item = do metadata <- getMetadata $ itemIdentifier item @@ -112,7 +127,14 @@ dateString <- maybe (dateFromFilePath timeLocale item) return maybeDateString parseTimeM' timeLocale "%Y-%m-%dT%H:%M:%S%Ez" dateString -dateFromMetadata :: TimeLocale -> [String] -> Metadata -> Maybe String +-- | Gets a date from the given metadata fields. +dateFromMetadata :: + -- | The time locale to use. + TimeLocale -> + -- | The list of metadata keys to search for. + [String] -> + Metadata -> + Maybe String dateFromMetadata timeLocale sourceKeys metadata = firstAlt $ findDate <$> sourceKeys where @@ -123,6 +145,7 @@ return $ normalizedTime timeLocale date parse = flip $ parseTimeM True timeLocale +-- | Gets a date from the item's file path. dateFromFilePath :: TimeLocale -> Item a -> Compiler String dateFromFilePath timeLocale item = dateFromPath @@ -152,6 +175,7 @@ rfc822DateFormat :: String rfc822DateFormat = "%a, %d %b %Y %H:%M:%S %Z" +-- | Supported date formats to read from metadata. metadataDateFormats :: [String] metadataDateFormats = [ "%Y-%m-%d", @@ -172,6 +196,7 @@ "%b %d, %Y" ] +-- | Gets whether the item is published. isPublishedField :: String -> Context a isPublishedField key = field key f where @@ -180,6 +205,7 @@ <&> isJust . KeyMap.lookup (Key.fromString "published") +-- | Gets whether the item has been updated. isUpdatedField :: String -> Context a isUpdatedField key = field key f where diff --git a/src/Hakyllbars/Field/Git.hs b/src/Hakyllbars/Field/Git.hs --- a/src/Hakyllbars/Field/Git.hs +++ b/src/Hakyllbars/Field/Git.hs @@ -17,7 +17,13 @@ import System.Exit import System.Process -gitFields :: String -> String -> Context a +-- | The Git fields configuration. +gitFields :: + -- | The configured hakyll provider directory. + String -> + -- | The base url to the online git repository for browsing. + String -> + Context a gitFields providerDirectory gitWebUrl = mconcat [ constField "gitWebUrl" gitWebUrl, @@ -30,14 +36,17 @@ gitFileField providerDirectory "isChanged" gitFileIsChanged ] +-- | Gets the git-sha1 hash of the current item. gitSha1Compiler :: String -> Item a -> TemplateRunner a String gitSha1Compiler = gitLogField "%h" +-- | Gets the git commit message of the current item. gitMessageCompiler :: String -> Item a -> TemplateRunner a String gitMessageCompiler = gitLogField "%s" type LogFormat = String +-- | Extracts a latest git log field from the current item. gitLogField :: LogFormat -> String -> Item a -> TemplateRunner a String gitLogField format providerDirectory item = lift $ unsafeCompiler do @@ -57,10 +66,25 @@ get = GitFile <$> get <*> get <*> get put (GitFile x y z) = put x >> put y >> put z -gitFileField :: (IntoValue v a) => String -> String -> (GitFile -> v) -> Context a +-- | gets a given field from the git file. +gitFileField :: + (IntoValue v a) => + -- | The hakyll provider directory. + String -> + -- | The field name. + String -> + -- | The getter for the git file field. + (GitFile -> v) -> + Context a gitFileField providerDirectory key f = field key $ fmap f . gitFileCompiler providerDirectory -gitFileCompiler :: String -> Item a -> TemplateRunner a GitFile +-- | Compiles the git file for the given item. +gitFileCompiler :: + -- | The hakyll provider directory. + String -> + -- | The item to compile. + Item a -> + TemplateRunner a GitFile gitFileCompiler providerDirectory item = lift $ GitFile gitFilePath diff --git a/src/Hakyllbars/Field/Html.hs b/src/Hakyllbars/Field/Html.hs --- a/src/Hakyllbars/Field/Html.hs +++ b/src/Hakyllbars/Field/Html.hs @@ -8,11 +8,13 @@ import Hakyllbars.Context import Network.URI (escapeURIString, isUnescapedInURI) +-- | Escapes HTML before interpolating in a template. escapeHtmlField :: Context String escapeHtmlField = functionField "escapeHtml" f where f = return . escapeHtml +-- | Escapes HTML URI before interpolating in a template. escapeHtmlUriField :: Context String escapeHtmlUriField = functionField "escapeHtmlUri" f where diff --git a/src/Hakyllbars/Pandoc.hs b/src/Hakyllbars/Pandoc.hs --- a/src/Hakyllbars/Pandoc.hs +++ b/src/Hakyllbars/Pandoc.hs @@ -4,9 +4,11 @@ import System.FilePath import Text.Pandoc +-- | Compiles an item using the pandoc renderer with the default options if it isn't already HTML. pandocCompiler :: Item String -> Compiler (Item String) pandocCompiler = pandocCompilerWith defaultHakyllReaderOptions defaultHakyllWriterOptions +-- | Compiles an item using the pandoc renderer with the given options if it isn't already HTML. pandocCompilerWith :: ReaderOptions -> WriterOptions -> Item String -> Compiler (Item String) pandocCompilerWith readerOpts writerOpts item@(Item id' _) = do let ext = takeExtension $ toFilePath id' diff --git a/test/Hakyllbars/TestSupport.hs b/test/Hakyllbars/TestSupport.hs --- a/test/Hakyllbars/TestSupport.hs +++ b/test/Hakyllbars/TestSupport.hs @@ -1,16 +1,8 @@ module Hakyllbars.TestSupport ( module Hakyllbars.Common, - module Hakyllbars.TestSupport.Compiler, - module Hakyllbars.TestSupport.Config, - module Hakyllbars.TestSupport.Resource, - module Hakyllbars.TestSupport.TestEnv, module Test.Hspec, ) where import Hakyllbars.Common -import Hakyllbars.TestSupport.Compiler -import Hakyllbars.TestSupport.Config -import Hakyllbars.TestSupport.Resource -import Hakyllbars.TestSupport.TestEnv import Test.Hspec diff --git a/test/Hakyllbars/TestSupport/Compiler.hs b/test/Hakyllbars/TestSupport/Compiler.hs deleted file mode 100644 --- a/test/Hakyllbars/TestSupport/Compiler.hs +++ /dev/null @@ -1,46 +0,0 @@ -module Hakyllbars.TestSupport.Compiler where - -import Data.Set as S -import Hakyll as H -import Hakyll.Core.Compiler.Internal -import qualified Hakyll.Core.Logger as Logger -import Hakyllbars.TestSupport.TestEnv -import Test.Hspec - -type RunCompiler a = Compiler a -> Identifier -> IO (CompilerResult a) - -runCompilerSpec :: TestEnv -> (RunCompiler a -> IO b) -> IO b -runCompilerSpec testEnv f = do - let run compiler identifier = do - logger <- Logger.new Logger.Debug - let compilerRead = - CompilerRead - { compilerConfig = testHakyllConfig testEnv, - compilerUnderlying = identifier, - compilerProvider = testProvider testEnv, - compilerUniverse = S.empty, - compilerRoutes = mempty, - compilerStore = testStore testEnv, - compilerLogger = logger - } - result <- runCompiler compiler compilerRead - Logger.flush logger - return result - f run - -shouldProduce :: (Eq a, Show a) => CompilerResult (Item a) -> a -> Expectation -shouldProduce (CompilerDone item _) expected = - itemBody item `shouldBe` expected -shouldProduce (CompilerSnapshot snapshot _) _ = - expectationFailure $ "Compiler did not complete, received snapshot " ++ snapshot -shouldProduce (CompilerRequire dependencies _) _ = - expectationFailure $ "Compiler did not complete, produced dependencies on " ++ show dependencies -shouldProduce (CompilerError errors) _ = expectationFailure message - where - message = case errors of - CompilationFailure exceptions -> "Compiler failed with exceptions: " ++ show exceptions - CompilationNoResult [] -> "Compiler produced no result" - CompilationNoResult exceptions -> "Compiler produced no result with exceptions: " ++ show exceptions - -compileBody :: (Item String -> Compiler (Item String)) -> Compiler (Item String) -compileBody compiler = getResourceBody >>= compiler diff --git a/test/Hakyllbars/TestSupport/Config.hs b/test/Hakyllbars/TestSupport/Config.hs deleted file mode 100644 --- a/test/Hakyllbars/TestSupport/Config.hs +++ /dev/null @@ -1,12 +0,0 @@ -module Hakyllbars.TestSupport.Config where - -import Hakyll (Configuration (..), defaultConfiguration) - -defaultHakyllConfig :: Configuration -defaultHakyllConfig = - defaultConfiguration - { destinationDirectory = "_test/site", - storeDirectory = "_test/store", - tmpDirectory = "_test/tmp", - providerDirectory = "test/data" - } diff --git a/test/Hakyllbars/TestSupport/Resource.hs b/test/Hakyllbars/TestSupport/Resource.hs deleted file mode 100644 --- a/test/Hakyllbars/TestSupport/Resource.hs +++ /dev/null @@ -1,16 +0,0 @@ -module Hakyllbars.TestSupport.Resource where - --- | Creates a spec resource dependent on a bracketed resource and runs the spec with it --- --- Example Usage: --- >>> around (withBracketedResource `providing` thisComponent) do --- >>> describe "this thing" do -providing :: - -- | The factory providing the bracketed resource - ((a -> m c) -> m c) -> - -- | The factory providing the spec resource dependent on the bracketed resource - (a -> (b -> m c) -> m c) -> - -- | The spec requiring the dependent resource - (b -> m c) -> - m c -providing withResource thingForSpec theSpec = withResource (`thingForSpec` theSpec) diff --git a/test/Hakyllbars/TestSupport/TestEnv.hs b/test/Hakyllbars/TestSupport/TestEnv.hs deleted file mode 100644 --- a/test/Hakyllbars/TestSupport/TestEnv.hs +++ /dev/null @@ -1,66 +0,0 @@ -module Hakyllbars.TestSupport.TestEnv where - -import Data.Foldable -import Data.Time -import Hakyll (Configuration (..), removeDirectory) -import qualified Hakyll.Core.Provider as HP -import qualified Hakyll.Core.Store as HS -import Hakyllbars.Common -import Hakyllbars.Field.Date -import Hakyllbars.TestSupport.Config - -data TestEnv = TestEnv - { testTime :: ZonedTime, - testHakyllConfig :: Configuration, - testStore :: HS.Store, - testProvider :: HP.Provider, - testDateConfig :: DateConfig - } - -newStoreAndProvider :: Configuration -> IO (HS.Store, HP.Provider) -newStoreAndProvider hakyllConfig = do - store <- newStore - provider <- newProvider store - return (store, provider) - where - newStore = HS.new True (storeDirectory hakyllConfig) - newProvider store = HP.newProvider store (const (return False)) (providerDirectory hakyllConfig) - -createTestEnv :: Configuration -> IO TestEnv -createTestEnv hakyllConfig = do - time <- defaultTestTime - (store, provider) <- newStoreAndProvider hakyllConfig - return - TestEnv - { testTime = time, - testHakyllConfig = hakyllConfig, - testStore = store, - testProvider = provider, - testDateConfig = defaultDateConfigWith defaultTimeLocale time - } - -cleanTestEnv :: TestEnv -> IO () -cleanTestEnv testEnv = - let hakyllConfig = testHakyllConfig testEnv - in traverse_ (removeDirectory . ($ hakyllConfig)) cleanDirectories - where - cleanDirectories = - [ destinationDirectory, - storeDirectory, - tmpDirectory - ] - -withTestEnv :: Configuration -> (TestEnv -> IO a) -> IO a -withTestEnv hakyllConfig = bracket (createTestEnv hakyllConfig) cleanTestEnv - -withDefaultTestEnv :: (TestEnv -> IO a) -> IO a -withDefaultTestEnv = withTestEnv defaultHakyllConfig - -defaultTestTimeString :: String -defaultTestTimeString = "2023-06-16T21:12:00-07:00" - -defaultTestTime :: (MonadFail m) => m ZonedTime -defaultTestTime = timeFromString defaultTestTimeString - -timeFromString :: (MonadFail m) => String -> m ZonedTime -timeFromString = parseTimeM True defaultTimeLocale "%FT%T%EZ"