packages feed

hakyllbars (empty) → 1.0.0.0

raw patch · 31 files changed

+3741/−0 lines, 31 filesdep +MissingHdep +aesondep +base

Dependencies added: MissingH, aeson, base, binary, bytestring, containers, data-default, directory, filepath, hakyll, hakyllbars, hspec, mtl, network-uri, pandoc, parsec, process, scientific, text, time, unordered-containers, vector, yaml

Files

+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Changelog++## v1.0.0.0++* First release, see [here](https://keywordsalad.github.com/hakyllbars) for documentation.
+ LICENSE view
@@ -0,0 +1,19 @@+Copyright (c) 2023 Logan McGrath++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ README.md view
@@ -0,0 +1,6 @@+# hakyllbars++hakyllbars is a templating language for [hakyll](https://jaspervdj.be/hakyll/) inspired by [handlebars](https://handlebarsjs.com/).++Please see the online docs and tutorial [here](https://keywordsalad.github.io/hakyllbars) for instructions and usage.+
+ hakyllbars.cabal view
@@ -0,0 +1,243 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.35.2.+--+-- see: https://github.com/sol/hpack++name:           hakyllbars+version:        1.0.0.0+synopsis:       A Hakyll compiler for Handlebars-like templates+description:    Hakyllbars brings a handlebars-like template syntax to Hakyll. Please see the+                README at <https://github.com/keywordsalad/hakyllbars#readme>+category:       Web+author:         Logan McGrath+maintainer:     logan.mcgrath@thisfieldwas.green+copyright:      Copyright (C) 2021-2023 Logan McGrath+license:        BSD3+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    CHANGELOG.md++source-repository head+  type: git+  location: https://github.com/keywordsalad/hakyllbars++library+  exposed-modules:+      Hakyllbars+      Hakyllbars.Ast+      Hakyllbars.Common+      Hakyllbars.Compiler+      Hakyllbars.Context+      Hakyllbars.Field+      Hakyllbars.Field.Date+      Hakyllbars.Field.Git+      Hakyllbars.Field.Html+      Hakyllbars.Pandoc+      Hakyllbars.Source+      Hakyllbars.Source.Lexer+      Hakyllbars.Source.Parser+      Hakyllbars.Source.Util+      Hakyllbars.Template+      Hakyllbars.Util+  other-modules:+      Paths_hakyllbars+  hs-source-dirs:+      src+  default-extensions:+      BangPatterns+      BinaryLiterals+      BlockArguments+      ConstraintKinds+      DataKinds+      DefaultSignatures+      DeriveDataTypeable+      DeriveFoldable+      DeriveFunctor+      DeriveGeneric+      DeriveTraversable+      DoAndIfThenElse+      EmptyDataDecls+      ExistentialQuantification+      FlexibleContexts+      FlexibleInstances+      FunctionalDependencies+      GADTs+      GeneralizedNewtypeDeriving+      ImportQualifiedPost+      InstanceSigs+      KindSignatures+      LambdaCase+      MultiParamTypeClasses+      MultiWayIf+      NamedFieldPuns+      OverloadedStrings+      PartialTypeSignatures+      PatternGuards+      PatternSynonyms+      PolyKinds+      RankNTypes+      RecordWildCards+      ScopedTypeVariables+      StandaloneDeriving+      TemplateHaskell+      TupleSections+      TypeFamilies+      TypeOperators+      TypeSynonymInstances+      UndecidableInstances+      ViewPatterns+  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+  build-depends:+      MissingH >=1.6.0 && <1.7+    , aeson >=2.1.2 && <2.2+    , base >=4.14 && <5+    , binary >=0.8.9 && <0.9+    , bytestring >=0.11.3 && <0.12+    , data-default >=0.7.1 && <0.8+    , directory >=1.3.6 && <1.4+    , filepath >=1.4.2 && <1.5+    , hakyll >=4.16.1 && <4.17+    , mtl >=2.2.2 && <2.3+    , network-uri >=2.6.4 && <2.7+    , pandoc >=3.0.1 && <3.2+    , parsec >=3.1.15 && <3.2+    , process >=1.6.16 && <1.7+    , scientific >=0.3.7 && <0.4+    , text >=2.0.2 && <2.1+    , time >=1.12.2 && <1.13+    , unordered-containers >=0.2.19 && <0.3+    , vector >=0.13.0 && <0.14+    , yaml >=0.11.11 && <0.12+  default-language: Haskell2010++executable hakyllbars-site+  main-is: Main.hs+  other-modules:+      Paths_hakyllbars+  hs-source-dirs:+      site+  default-extensions:+      BangPatterns+      BinaryLiterals+      BlockArguments+      ConstraintKinds+      DataKinds+      DefaultSignatures+      DeriveDataTypeable+      DeriveFoldable+      DeriveFunctor+      DeriveGeneric+      DeriveTraversable+      DoAndIfThenElse+      EmptyDataDecls+      ExistentialQuantification+      FlexibleContexts+      FlexibleInstances+      FunctionalDependencies+      GADTs+      GeneralizedNewtypeDeriving+      ImportQualifiedPost+      InstanceSigs+      KindSignatures+      LambdaCase+      MultiParamTypeClasses+      MultiWayIf+      NamedFieldPuns+      OverloadedStrings+      PartialTypeSignatures+      PatternGuards+      PatternSynonyms+      PolyKinds+      RankNTypes+      RecordWildCards+      ScopedTypeVariables+      StandaloneDeriving+      TemplateHaskell+      TupleSections+      TypeFamilies+      TypeOperators+      TypeSynonymInstances+      UndecidableInstances+      ViewPatterns+  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:+      MissingH >=1.6.0 && <1.7+    , base >=4.14 && <5+    , hakyll >=4.16.1 && <4.17+    , hakyllbars+    , pandoc >=3.0.1 && <3.2+    , time >=1.12.2 && <1.13+  default-language: Haskell2010++test-suite test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Hakyllbars.AstStructure+      Hakyllbars.Source.LexerSpec+      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+  default-extensions:+      BangPatterns+      BinaryLiterals+      BlockArguments+      ConstraintKinds+      DataKinds+      DefaultSignatures+      DeriveDataTypeable+      DeriveFoldable+      DeriveFunctor+      DeriveGeneric+      DeriveTraversable+      DoAndIfThenElse+      EmptyDataDecls+      ExistentialQuantification+      FlexibleContexts+      FlexibleInstances+      FunctionalDependencies+      GADTs+      GeneralizedNewtypeDeriving+      ImportQualifiedPost+      InstanceSigs+      KindSignatures+      LambdaCase+      MultiParamTypeClasses+      MultiWayIf+      NamedFieldPuns+      OverloadedStrings+      PartialTypeSignatures+      PatternGuards+      PatternSynonyms+      PolyKinds+      RankNTypes+      RecordWildCards+      ScopedTypeVariables+      StandaloneDeriving+      TemplateHaskell+      TupleSections+      TypeFamilies+      TypeOperators+      TypeSynonymInstances+      UndecidableInstances+      ViewPatterns+  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+    , parsec >=3.1.15 && <3.2+    , time >=1.12.2 && <1.13+  default-language: Haskell2010
+ site/Main.hs view
@@ -0,0 +1,121 @@+module Main where++import Data.List (isSuffixOf)+import Data.Maybe (fromMaybe)+import Data.String.Utils (join, split)+import Data.Time+import Hakyll+import Hakyllbars as HB+import System.Environment (lookupEnv)+import Text.Pandoc.Highlighting (haddock, styleToCss)++main :: IO ()+main = do+  deployEnv <- fromMaybe Prod . ((=<<) deployEnvFromStr) <$> lookupEnv "DEPLOY_ENV"+  time <- utcToZonedTime <$> getCurrentTimeZone <*> getCurrentTime+  let dateConfig = HB.defaultDateConfigWith defaultTimeLocale time+  hakyllWith config do+    css' <- css+    js' <- js+    templates' <- templates+    rulesExtraDependencies [css', js', templates'] do+      pages deployEnv dateConfig++config :: Configuration+config =+  defaultConfiguration+    { providerDirectory = "site",+      destinationDirectory = "_site"+    }++css :: Rules Dependency+css = do+  match "css/**" do+    route idRoute+    compile getResourceBody+  create ["css/code-style.css"] do+    route idRoute+    compile $ makeItem (styleToCss haddock)+  makePatternDependency "css/**"++js :: Rules Dependency+js = do+  match "js/**" do+    route idRoute+    compile getResourceBody+  makePatternDependency "js/**"++-- Precompile all templates+templates :: Rules Dependency+templates = do+  match templatePattern do+    -- Use this to compile templates+    compile $+      -- Get the content of the template+      getResourceBody+        -- Compile the template+        >>= HB.compileTemplateItem+        -- Create an item from the template+        >>= makeItem+  makePatternDependency templatePattern+  where+    templatePattern =+      "_layouts/**"+        .||. "_partials/**"+        .||. "_templates/**"+        .||. "_sections/**"++pages :: DeployEnv -> HB.DateConfig -> Rules ()+pages deployEnv dateConfig = do+  match "*.md" do+    route $ setExtension "html" `composeRoutes` indexRoute+    -- This is where Hakyllbars is applied+    compile do+      getResourceBody >>= HB.applyTemplates do+        -- Sets the root context used in the templates+        HB.applyContext (context deployEnv dateConfig)+        -- Applies the item content as a template+        HB.applyContent+        -- Applies the final template+        HB.applyTemplate "_layouts/from-context.html"++indexRoute :: Routes+indexRoute = customRoute appendIndexHtml+  where+    appendIndexHtml = join "/" . reverse . indexIt . reverse . split "/" . toFilePath+    indexIt [] = []+    indexIt a@(x : xs)+      | x == "index.html" = a+      | ".html" `isSuffixOf` x = (head (split "." x) ++ "/index.html") : xs+      | otherwise = a++-- This uses Hakyllbars' Context, not Hakyll's+context :: DeployEnv -> HB.DateConfig -> HB.Context String+context deployEnv dateConfig =+  HB.gitFields "site" "https://github.com/keywordsalad/hakyllbars/tree"+    <> HB.includeField "section" (Just "_sections") (Just ".md")+    <> HB.includeField "partial" (Just "_partials") (Just ".md")+    <> HB.dateFields dateConfig+    -- Using the default fields is very recommended+    <> HB.defaultFields host siteRoot+  where+    host = deployEnvHost deployEnv+    siteRoot = deployEnvSiteRoot deployEnv++data DeployEnv = Prod | Dev++deployEnvFromStr :: String -> Maybe DeployEnv+deployEnvFromStr = \case+  "prod" -> Just Prod+  "dev" -> Just Dev+  _ -> Nothing++deployEnvHost :: DeployEnv -> String+deployEnvHost = \case+  Prod -> "https://keywordsalad.github.io"+  Dev -> "http://localhost:8000"++deployEnvSiteRoot :: DeployEnv -> String+deployEnvSiteRoot = \case+  Prod -> "/hakyllbars"+  Dev -> ""
+ src/Hakyllbars.hs view
@@ -0,0 +1,12 @@+module Hakyllbars+  ( module Hakyllbars.Compiler,+    module Hakyllbars.Context,+    module Hakyllbars.Field,+    module Hakyllbars.Template,+  )+where++import Hakyllbars.Compiler+import Hakyllbars.Context+import Hakyllbars.Field+import Hakyllbars.Template
+ src/Hakyllbars/Ast.hs view
@@ -0,0 +1,341 @@+module Hakyllbars.Ast+  ( Template (..),+    Block (..),+    getBlockName,+    getBlockPos,+    ApplyBlock (..),+    DefaultBlock (..),+    Expression (..),+    getExpressionPos,+  )+where++import Data.Binary+import qualified Data.ByteString.Char8 as Char8+import Data.List.NonEmpty (NonEmpty)+import Data.Yaml (ToJSON (..), object, (.=))+import Data.Yaml.Pretty (defConfig, encodePretty)+import GHC.Generics (Generic)+import Hakyllbars.Common+import Text.Parsec hiding (getPosition)+import Text.Parsec.Pos++showJSON :: (ToJSON a) => a -> String+showJSON = Char8.unpack . encodePretty defConfig . toJSON++data Template = Template [Block] FilePath+  deriving (Generic)++instance Binary Template where+  get = Template <$> get <*> get++  put (Template blocks pos) = do+    put blocks+    put pos++instance Writable Template where+  write _ _ = return ()++instance ToJSON Template++instance Show Template where+  show = showJSON++data Block+  = TextBlock String SourcePos+  | ExpressionBlock Expression SourcePos+  | CommentBlock String SourcePos+  | ChromeBlock Expression [Block] SourcePos+  | AltBlock+      (NonEmpty ApplyBlock)+      (Maybe DefaultBlock)+      SourcePos+  deriving (Generic)++getBlockName :: Block -> String+getBlockName = \case+  TextBlock {} -> "TextBlock"+  ExpressionBlock {} -> "ExpressionBlock"+  CommentBlock {} -> "CommentBlock"+  ChromeBlock {} -> "ChromeBlock"+  AltBlock {} -> "AltBlock"++getBlockPos :: Block -> SourcePos+getBlockPos = \case+  TextBlock _ pos -> pos+  ExpressionBlock _ pos -> pos+  CommentBlock _ pos -> pos+  ChromeBlock _ _ pos -> pos+  AltBlock _ _ pos -> pos++getBlockTag :: Block -> Int+getBlockTag = \case+  TextBlock {} -> 1+  ExpressionBlock {} -> 2+  CommentBlock {} -> 3+  ChromeBlock {} -> 4+  AltBlock {} -> 5++instance Binary Block where+  get = do+    tag <- get :: Get Int+    f <- case tag of+      1 -> TextBlock <$> get+      2 -> ExpressionBlock <$> get+      3 -> CommentBlock <$> get+      4 -> ChromeBlock <$> get <*> get+      5 -> AltBlock <$> get <*> get+      _ -> error $ "Unrecognized block tag " ++ show tag+    binaryPos <- get :: Get BinaryPos+    return $ f (unBinaryPos binaryPos)++  put block = do+    put $ getBlockTag block+    case block of+      TextBlock text _ -> put text+      ExpressionBlock expression _ -> put expression+      CommentBlock text _ -> put text+      ChromeBlock expression blocks _ -> put expression >> put blocks+      AltBlock blocks default' _ -> put blocks >> put default'+    put $ BinaryPos (getBlockPos block)++instance ToJSON Block where+  toJSON = \case+    TextBlock text pos ->+      object+        [ "type" .= ("TextBlock" :: String),+          "text" .= text,+          "pos" .= show pos+        ]+    ExpressionBlock expression pos ->+      object+        [ "type" .= ("ExpressionBlock" :: String),+          "expression" .= expression,+          "pos" .= show pos+        ]+    CommentBlock text pos ->+      object+        [ "type" .= ("CommentBlock" :: String),+          "text" .= text,+          "pos" .= show pos+        ]+    ChromeBlock expression blocks _ ->+      object+        [ "type" .= ("ChromeBlock" :: String),+          "expression" .= expression,+          "blocks" .= blocks+        ]+    AltBlock blocks default' _ ->+      object+        [ "type" .= ("AltBlock" :: String),+          "blocks" .= blocks,+          "default" .= default'+        ]++instance Show Block where+  show = showJSON++newtype BinaryPos = BinaryPos SourcePos+  deriving (Show)++unBinaryPos :: BinaryPos -> SourcePos+unBinaryPos (BinaryPos pos) = pos++instance Binary BinaryPos where+  get = BinaryPos <$> (newPos <$> get <*> get <*> get)+  put binaryPos = do+    let pos = unBinaryPos binaryPos+    put $ sourceName pos+    put $ sourceLine pos+    put $ sourceColumn pos++data ApplyBlock = ApplyBlock Expression [Block] SourcePos+  deriving (Generic)++instance Binary ApplyBlock where+  get = do+    f <- ApplyBlock <$> get <*> get+    binaryPos <- get :: Get BinaryPos+    return $ f (unBinaryPos binaryPos)++  put (ApplyBlock expression blocks pos) = do+    put expression+    put blocks+    put $ BinaryPos pos++instance ToJSON ApplyBlock where+  toJSON (ApplyBlock expression blocks pos) =+    object+      [ "type" .= ("ApplyBlock" :: String),+        "expression" .= expression,+        "blocks" .= blocks,+        "pos" .= show pos+      ]++instance Show ApplyBlock where+  show = showJSON++data DefaultBlock = DefaultBlock [Block] SourcePos+  deriving (Generic)++instance Binary DefaultBlock where+  get = do+    f <- DefaultBlock <$> get+    binaryPos <- get :: Get BinaryPos+    return $ f (unBinaryPos binaryPos)++  put (DefaultBlock blocks pos) = do+    put blocks+    put $ BinaryPos pos++instance ToJSON DefaultBlock where+  toJSON (DefaultBlock blocks pos) =+    object+      [ "type" .= ("DefaultBlock" :: String),+        "blocks" .= blocks,+        "pos" .= show pos+      ]++instance Show DefaultBlock where+  show = showJSON++data Expression+  = NameExpression String SourcePos -- name, id+  | StringExpression String SourcePos -- "a string of text"+  | IntExpression Int SourcePos -- 123, 456, 2+  | DoubleExpression Double SourcePos -- 0.2, 1.45+  | BoolExpression Bool SourcePos -- true, false+  | ApplyExpression Expression Expression SourcePos -- fn arg+  | AccessExpression Expression Expression SourcePos -- target.field+  | FilterExpression Expression Expression SourcePos -- arg | fn+  | ContextExpression [(String, Expression)] SourcePos -- { name0: value0, name1: value1 }+  | ListExpression [Expression] SourcePos -- [a, b, c]+  deriving (Generic)++getExpressionPos :: Expression -> SourcePos+getExpressionPos = \case+  NameExpression _ pos -> pos+  StringExpression _ pos -> pos+  IntExpression _ pos -> pos+  DoubleExpression _ pos -> pos+  BoolExpression _ pos -> pos+  ApplyExpression _ _ pos -> pos+  AccessExpression _ _ pos -> pos+  FilterExpression _ _ pos -> pos+  ContextExpression _ pos -> pos+  ListExpression _ pos -> pos++getExpressionTag :: Expression -> Int+getExpressionTag = \case+  NameExpression {} -> 1+  StringExpression {} -> 2+  IntExpression {} -> 3+  DoubleExpression {} -> 4+  BoolExpression {} -> 5+  ApplyExpression {} -> 6+  AccessExpression {} -> 7+  FilterExpression {} -> 8+  ContextExpression {} -> 9+  ListExpression {} -> 10++instance Binary Expression where+  get = do+    tag <- get :: Get Int+    f <- case tag of+      1 -> NameExpression <$> get+      2 -> StringExpression <$> get+      3 -> IntExpression <$> get+      4 -> DoubleExpression <$> get+      5 -> BoolExpression <$> get+      6 -> ApplyExpression <$> get <*> get+      7 -> AccessExpression <$> get <*> get+      8 -> FilterExpression <$> get <*> get+      9 -> ContextExpression <$> get+      10 -> ListExpression <$> get+      _ -> error $ "Unrecognized expression tag " ++ show tag+    binaryPos <- get :: Get BinaryPos+    return $ f (unBinaryPos binaryPos)++  put expression = do+    put $ getExpressionTag expression+    case expression of+      NameExpression value _ -> put value+      StringExpression value _ -> put value+      IntExpression value _ -> put value+      DoubleExpression value _ -> put value+      BoolExpression value _ -> put value+      ApplyExpression fn arg _ -> put fn >> put arg+      AccessExpression target field _ -> put target >> put field+      FilterExpression arg fn _ -> put arg >> put fn+      ContextExpression pairs _ -> put pairs+      ListExpression values _ -> put values+    put $ BinaryPos (getExpressionPos expression)++instance ToJSON Expression where+  toJSON = \case+    NameExpression value pos ->+      object+        [ "type" .= ("NameExpression" :: String),+          "value" .= value,+          "pos" .= show pos+        ]+    StringExpression value pos ->+      object+        [ "type" .= ("StringExpression" :: String),+          "value" .= value,+          "pos" .= show pos+        ]+    IntExpression value pos ->+      object+        [ "type" .= ("IntExpression" :: String),+          "value" .= value,+          "pos" .= show pos+        ]+    DoubleExpression value pos ->+      object+        [ "type" .= ("DoubleExpression" :: String),+          "value" .= value,+          "pos" .= show pos+        ]+    BoolExpression value pos ->+      object+        [ "type" .= ("BoolExpression" :: String),+          "value" .= value,+          "pos" .= show pos+        ]+    ApplyExpression fn arg pos ->+      object+        [ "type" .= ("ApplyExpression" :: String),+          "fn" .= fn,+          "arg" .= arg,+          "pos" .= show pos+        ]+    AccessExpression target field pos ->+      object+        [ "type" .= ("AccessExpression" :: String),+          "target" .= target,+          "field" .= field,+          "pos" .= show pos+        ]+    FilterExpression arg fn pos ->+      object+        [ "type" .= ("FilterExpression" :: String),+          "arg" .= arg,+          "fn" .= fn,+          "pos" .= show pos+        ]+    ContextExpression pairs pos ->+      object+        [ "type" .= ("ContextExpression" :: String),+          "pairs" .= pairs,+          "pos" .= show pos+        ]+    ListExpression values pos ->+      object+        [ "type" .= ("ListExpression" :: String),+          "values" .= values,+          "pos" .= show pos+        ]++instance Show Expression where+  show = showJSON
+ src/Hakyllbars/Common.hs view
@@ -0,0 +1,98 @@+module Hakyllbars.Common+  ( module Control.Applicative,+    module Control.Exception,+    module Control.Monad,+    module Control.Monad.Except,+    module Control.Monad.Trans,+    module Data.Bifunctor,+    module Data.Bool,+    module Data.Foldable,+    module Data.Functor,+    module Data.List,+    module Data.Maybe,+    module Data.Time,+    module Data.Time.Format,+    module Hakyll,+    module System.Directory,+    module System.FilePath,+  )+where++import Control.Applicative ((<|>))+import Control.Exception (bracket)+import Control.Monad (forM, join, void, (<=<), (>=>))+import Control.Monad.Except (MonadError, catchError, throwError)+import Control.Monad.Trans (lift)+import Data.Bifunctor (bimap, first, second)+import Data.Bool (bool)+import Data.Foldable (sequenceA_)+import Data.Functor ((<&>))+import Data.List (intercalate, isPrefixOf, isSuffixOf)+import Data.Maybe (fromJust, fromMaybe, isJust, isNothing, maybe, maybeToList)+import Data.Time (ZonedTime)+import Data.Time.Format (TimeLocale, formatTime, parseTimeM)+import Hakyll+  ( -- types+    Compiler,+    Dependency,+    FeedConfiguration (..),+    Identifier (..),+    Item (..),+    Metadata,+    Pattern,+    Redirect (..),+    Routes,+    Rules,+    Snapshot,+    -- typeclasses+    Writable (..),+    -- functions+    cached,+    compile,+    composeRoutes,+    constRoute,+    copyFileCompiler,+    create,+    customRoute,+    debugCompiler,+    escapeHtml,+    fromFilePath,+    fromList,+    fromRegex,+    getMatches,+    getMetadata,+    getResourceBody,+    getResourceString,+    getRoute,+    gsubRoute,+    hasNoVersion,+    hasVersion,+    idRoute,+    itemSetBody,+    load,+    loadBody,+    loadSnapshot,+    loadSnapshotBody,+    lookupString,+    makeItem,+    makePatternDependency,+    match,+    matchRoute,+    metadataRoute,+    noResult,+    relativizeUrls,+    route,+    rulesExtraDependencies,+    saveSnapshot,+    setExtension,+    toFilePath,+    toUrl,+    unsafeCompiler,+    version,+    withErrorMessage,+    withItemBody,+    (.&&.),+    (.||.),+  )+import System.Directory (copyFile, createDirectoryIfMissing, doesFileExist)+import System.FilePath (dropExtension, splitDirectories, splitFileName, takeDirectory, takeFileName, (</>))
+ src/Hakyllbars/Compiler.hs view
@@ -0,0 +1,181 @@+module Hakyllbars.Compiler where++import Control.Applicative (liftA3)+import Control.Monad.State.Strict+import Data.Bifunctor+import Data.List.NonEmpty as NonEmpty+import Hakyll.Core.Compiler.Internal+import Hakyllbars.Ast+import Hakyllbars.Common+import Hakyllbars.Context hiding (field)+import Hakyllbars.Source.Parser (parse)++-- | Takes an item and compiles a template from it.+compileTemplateItem :: Item String -> Compiler Template+compileTemplateItem item = do+  let filePath = toFilePath $ itemIdentifier item+  either (fail . show) return $ parse filePath (itemBody item)++loadTemplate :: Identifier -> TemplateRunner a Template+loadTemplate = lift . fmap itemBody . load++applyTemplate :: Identifier -> TemplateRunner String ()+applyTemplate =+  loadTemplate+    >=> reduceTemplate+    >=> lift . makeItem+    >=> tplPushItem++applyAsTemplate :: TemplateRunner String ()+applyAsTemplate =+  tplModifyItem do+    lift . compileTemplateItem+      >=> reduceTemplate+      >=> lift . makeItem++reduceTemplate :: Template -> TemplateRunner String String+reduceTemplate (Template bs src) =+  tplWithCall ("template " ++ src) (reduceBlocks bs)++reduceBlocks :: [Block] -> TemplateRunner String String+reduceBlocks = stringify . intoValue <=< applyBlocks++applyBlocks :: [Block] -> TemplateRunner String [ContextValue String]+applyBlocks = mapM applyBlock++applyBlock :: Block -> TemplateRunner String (ContextValue String)+applyBlock = tplWithPos getBlockPos \case+  TextBlock t _ -> return $ intoValue t+  ExpressionBlock e _ -> eval e+  CommentBlock {} -> return EmptyValue+  ChromeBlock e bs pos ->+    fmap intoValue do+      bs' <- reduceBlocks bs+      eval e >>= \case+        FunctionValue f -> f (intoValue bs')+        x -> tplFail $ "invalid chrome function " ++ show x ++ " near " ++ show pos+  AltBlock (ApplyBlock e bs _ :| alts) maybeDefault _ ->+    intoValue <$> applyAltBlock e bs alts maybeDefault++applyAltBlock ::+  Expression ->+  [Block] ->+  [ApplyBlock] ->+  Maybe DefaultBlock ->+  TemplateRunner String [ContextValue String]+applyAltBlock guard' bs alts maybeDefault =+  eval guard' >>= \case+    FunctionValue f -> pure <$> f (intoValue bs)+    x ->+      isTruthy x >>= \case+        True -> applyBlocks bs+        False -> case alts of+          ApplyBlock guard'' bs' _ : alts' -> applyAltBlock guard'' bs' alts' maybeDefault+          [] -> case maybeDefault of+            Just (DefaultBlock bs' _) -> applyBlocks bs'+            Nothing -> return []++eval :: Expression -> TemplateRunner a (ContextValue a)+eval = tplWithPos getExpressionPos \case+  NameExpression name pos -> do+    (context, item, trace) <-+      liftA3 (,,) tplContext tplItem tplTrace `catchError` \e -> do+        tplFail $ "Caught error in template: " ++ show e ++ " near " ++ show pos+    s <- get+    (x, s') <-+      lift $+        runStateT (unContext context name) s `compilerCatch` \case+          CompilationFailure ne ->+            compilerThrow (NonEmpty.toList ne)+          CompilationNoResult ss ->+            -- TODO figure out how to get state changes to persist if value comes back empty+            return (UndefinedValue name item (show pos : trace) ss, s)+    put s'+    return x+  StringExpression s _ -> return $ intoValue s+  IntExpression n _ -> return $ intoValue n+  DoubleExpression x _ -> return $ intoValue x+  BoolExpression b _ -> return $ intoValue b+  ApplyExpression f x _ -> apply f x+  AccessExpression target field pos ->+    eval target >>= \case+      ContextValue target' -> do+        name <-+          eval field >>= \case+            StringValue x -> return x+            x -> tplFail $ "invalid field " ++ show x ++ " near " ++ show (getExpressionPos field)+        s <- get+        (x, s') <-+          lift $+            runStateT (unContext target' name) s `compilerCatch` \case+              CompilationFailure errors ->+                compilerThrow (NonEmpty.toList errors)+              CompilationNoResult _ ->+                -- TODO figure out how to get state changes to persist if value comes back empty+                return (EmptyValue, s)+        put s'+        return x+      EmptyValue -> return EmptyValue+      UndefinedValue {} -> return EmptyValue+      x -> tplFail $ "invalid context " ++ show x ++ " near " ++ show pos+  FilterExpression x f _ -> apply f x+  ContextExpression pairs _ -> do+    pairs' <- mapM (sequence . second eval) pairs+    return $ ContextValue (intoContext pairs')+  ListExpression xs _ -> intoValue <$> mapM eval xs+  where+    apply f x =+      eval f >>= \case+        FunctionValue f' -> f' (ThunkValue $ eval x)+        x' -> tplFail $ "invalid function " ++ show x' ++ " in " ++ show (getExpressionPos f)++stringify :: ContextValue String -> TemplateRunner String String+stringify = \case+  EmptyValue -> return ""+  UndefinedValue name item trace errors ->+    tplFail $+      "can't stringify undefined value "+        ++ show name+        ++ "\nin item context for "+        ++ itemFilePath item+        ++ "\ntrace=[\n\t"+        ++ intercalate ",\n\t" trace+        ++ "\n],\nsuppressed=[\n\t"+        ++ intercalate ",\n\t" errors+        ++ "\n]\n"+  ContextValue {} -> tplFail "can't stringify context"+  ListValue xs -> mconcat <$> mapM stringify xs+  BoolValue b -> return $ show b+  StringValue s -> return s+  DoubleValue x -> return $ show x+  IntValue n -> return $ show n+  FunctionValue {} -> tplFail "can't stringify function"+  BlockValue block -> case block of+    TextBlock t _ -> return t+    CommentBlock {} -> return ""+    ExpressionBlock e _ -> stringify =<< eval e+    _ -> stringify =<< applyBlock block+  ItemValue item -> return $ itemBody item+  ThunkValue fx -> stringify =<< force =<< fx+  PairValue (_, x) -> stringify x++isTruthy :: ContextValue a -> TemplateRunner a Bool+isTruthy = \case+  EmptyValue -> return False+  UndefinedValue {} -> return False+  ContextValue {} -> return True+  ListValue xs -> return $ not (null xs)+  BoolValue x -> return x+  StringValue x -> return $ not (null x)+  DoubleValue x -> return $ x /= 0+  IntValue x -> return $ x /= 0+  FunctionValue {} -> return True+  BlockValue {} -> return True+  ItemValue _ -> return True+  ThunkValue fx -> isTruthy =<< force =<< fx+  PairValue (_, x) -> isTruthy x++force :: ContextValue a -> TemplateRunner a (ContextValue a)+force = \case+  ThunkValue fx -> force =<< fx+  x -> return x
+ src/Hakyllbars/Context.hs view
@@ -0,0 +1,510 @@+module Hakyllbars.Context where++import Control.Monad.Except+import Control.Monad.State.Strict+import Data.Aeson+import qualified Data.Aeson.Key as Key+import qualified Data.Aeson.KeyMap as KeyMap+import Data.Bifunctor+import Data.Either+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap+import Data.Maybe+import Data.Proxy+import Data.Scientific (isInteger, toBoundedInteger, toBoundedRealFloat)+import qualified Data.Text as T+import qualified Data.Vector as Vector+import Hakyllbars.Ast+import Hakyllbars.Common+import Text.Parsec (SourcePos)+import Prelude hiding (lookup)++newtype Context a = Context {unContext :: ContextFunction a}++type ContextFunction a = String -> TemplateRunner a (ContextValue a)++getContext :: Identifier -> Compiler (Context a)+getContext id' = intoContext <$> getMetadata id'++itemFilePath :: Item a -> FilePath+itemFilePath = toFilePath . itemIdentifier++data TemplateState a = TemplateState+  { tplContextStack :: [(Context a, Context a)],+    tplItemStack :: [Item a],+    tplCallStack :: [String]+  }++type TemplateRunner a b = StateT (TemplateState a) Compiler b++tplItem :: TemplateRunner a (Item a)+tplItem =+  gets tplItemStack >>= \case+    [] -> tplFail "tplItem: no Item on stack"+    (item : _) -> return item++tplModifyItem :: (Item a -> TemplateRunner a (Item a)) -> TemplateRunner a ()+tplModifyItem f =+  tplItem+    >>= f+    >>= tplReplaceItem++tplReplaceItem :: Item a -> TemplateRunner a ()+tplReplaceItem item = do+  void tplPopItem+  tplPushItem item++tplPopItem :: TemplateRunner a (Item a)+tplPopItem =+  gets tplItemStack >>= \case+    [] -> error "tplPopItem: no Item on stack"+    current : previous -> do+      modify \s -> s {tplItemStack = previous}+      return current++tplPopBody :: TemplateRunner a a+tplPopBody = itemBody <$> tplPopItem++tplPushItem :: Item a -> TemplateRunner a ()+tplPushItem item = do+  stack <- gets tplItemStack+  modify \s -> s {tplItemStack = item : stack}++tplWithItem :: Item a -> TemplateRunner a b -> TemplateRunner a b+tplWithItem item f = do+  tplPushItem item+  x <- f+  void tplPopItem+  return x++tplContext :: TemplateRunner a (Context a)+tplContext =+  gets tplContextStack >>= \case+    [] -> tplFail "tplContext: no Context on stack"+    ((_, catted) : _) -> return catted++tplPushContext :: Context a -> TemplateRunner a ()+tplPushContext context = do+  stack <-+    gets tplContextStack <&> \case+      [] -> [(context, context)]+      stack@((_, cattedParent) : _) -> (context, context <> cattedParent) : stack+  modify \s -> s {tplContextStack = stack}++tplPopContext :: TemplateRunner a (Context a)+tplPopContext =+  gets tplContextStack >>= \case+    [] -> tplFail "tplPopContext: no Context on stack"+    ((current, _) : previous) -> do+      modify \s ->+        s+          { tplContextStack = previous+          }+      return current++-- | Place context within a given scope.+tplWithContext :: Context a -> TemplateRunner a b -> TemplateRunner a b+tplWithContext context f = do+  tplPushContext context+  x <- f+  void tplPopContext+  return x++-- | Get a value from the context by name and convert it.+tplGet :: (FromValue v a) => String -> TemplateRunner a v+tplGet name =+  tplContext+    >>= flip unContext name+    >>= fromValue++-- | Get a value from a specific item's context by name and convert it.+tplGetWithItemContext :: (FromValue v a) => Item a -> Context a -> String -> TemplateRunner a v+tplGetWithItemContext item context name =+  tplWithItem item $ tplWithContext context $ tplGet name++-- | Place context in global scope.+tplPut :: Context a -> TemplateRunner a ()+tplPut context = do+  stack <- fmap (second (context <>)) <$> gets tplContextStack+  modify' \s -> s {tplContextStack = stack}++-- | Perform an action within the scope of a call.+tplWithCall :: String -> TemplateRunner a b -> TemplateRunner a b+tplWithCall call f = do+  stack <- gets tplCallStack+  modify' \s -> s {tplCallStack = call : stack}+  x <- f+  modify' \s -> s {tplCallStack = stack}+  return x++tplWithPos :: (x -> SourcePos) -> (x -> TemplateRunner a b) -> x -> TemplateRunner a b+tplWithPos getPos f x = tplWithCall (show $ getPos x) $ f x++-- | Perform an action within the scope of a field call.+tplWithField :: String -> TemplateRunner a b -> TemplateRunner a b+tplWithField field' f = do+  file <- itemFilePath <$> tplItem+  tplWithCall ("field " ++ show field' ++ " in " ++ file) f++-- | Fail with an error message and trace.+tplFail :: String -> TemplateRunner a b+tplFail = fail <=< tplTraced++-- | Fail with a no-result message and trace.+tplTried :: String -> TemplateRunner a b+tplTried = lift . noResult <=< tplTraced++-- | Return the current call stack, with the most recent call first.+tplTrace :: TemplateRunner a [String]+tplTrace = gets tplCallStack++-- | Get a formatted trace message with the most recent call first.+tplTraced :: String -> TemplateRunner a String+tplTraced message = do+  trace <- tplTrace+  return $ message ++ ", trace from most recent:\n" ++ intercalate "\n\t" trace ++ "\n"++-- | Apply @f@ to an item if @key@ is requested.+field :: (IntoValue v a) => String -> (Item a -> TemplateRunner a v) -> Context a+field key f = Context f'+  where+    f' k =+      tplWithField key $+        if k == key+          then do+            i <- tplItem+            intoValue <$> f i+          else do+            tplTried $ "key " ++ show k ++ " did not match field " ++ show key++-- | Reports missing field.+missingField :: Context a+missingField = Context f+  where+    f key = tplTried $ "missing " ++ show key++-- | Const-valued field, returns the same @val@ per @key@.+constField :: (IntoValue v a) => String -> v -> Context a+constField key val = field key f+  where+    constResult = return val+    f _ = tplWithCall key constResult++-- | Creates a field containing a list of items.+itemsField :: String -> Context a -> [Item a] -> Context a+itemsField key context items = constField key (context, items)++-- | Mapping of function @g@ after context @f@.+mapField :: (FromValue v a, IntoValue w a) => (v -> w) -> Context a -> Context a+mapField g (Context f) = Context h+  where+    h k = tplWithCall ("mapField of " ++ show k) do+      fmap (intoValue . g) $ fromValue =<< f k++-- | Binding of function @g@ after context @f@.+bindField :: (FromValue v a, IntoValue w a) => (v -> TemplateRunner a w) -> Context a -> Context a+bindField g (Context f) = Context h+  where+    h k = do+      tplWithCall ("bindField of " ++ show k) do+        fmap intoValue $ g =<< fromValue =<< f k++-- | Alternation of context @g@ after context @f@.+composeField :: Context a -> Context a -> Context a+composeField (Context g) (Context f) = Context h+  where+    h name = f name `catchError` (\_ -> g name)++-- | Lookup of @val@ by @key@ into provided @HashMap@.+hashMapField :: (IntoValue v a) => HashMap String v -> Context a+hashMapField m = Context f+  where+    m' = intoValue <$> m+    f k = tplWithCall "hashMap" $ maybe (tried k) return (HashMap.lookup k m')+    tried k = tplTried $ "tried " ++ show k ++ " from hashmap of keys " ++ show (HashMap.keys m')++forItemField :: (IntoValue v a) => String -> [Identifier] -> (Item a -> TemplateRunner a v) -> Context a+forItemField key ids f = field key f'+  where+    f' item+      | itemIdentifier item `elem` ids = f item+      | otherwise = tplTried $ show key ++ " for items " ++ show (toFilePath <$> ids)++functionField :: (FromValue v a, IntoValue w a) => String -> (v -> TemplateRunner a w) -> Context a+functionField = constField++functionField2 :: (FromValue v a, FromValue x a, IntoValue w a) => String -> (v -> x -> TemplateRunner a w) -> Context a+functionField2 = constField++functionField3 :: (FromValue v a, FromValue x a, FromValue y a, IntoValue w a) => String -> (v -> x -> y -> TemplateRunner a w) -> Context a+functionField3 = constField++functionField4 :: (FromValue v a, FromValue x a, FromValue y a, FromValue z a, IntoValue w a) => String -> (v -> x -> y -> z -> TemplateRunner a w) -> Context a+functionField4 = constField++instance Semigroup (Context a) where+  (<>) = flip composeField++instance Monoid (Context a) where+  mempty = missingField++class IntoContext v a where+  intoContext :: v -> Context a++instance IntoContext (Context a) a where+  intoContext = id++instance (IntoValue v a) => IntoContext (HashMap String v) a where+  intoContext = hashMapField++instance (IntoValue v a) => IntoContext [(String, v)] a where+  intoContext = intoContext . HashMap.fromList++instance IntoContext Object a where+  intoContext = ic . fmap (bimap Key.toString intoValue) . KeyMap.toList+    where+      ic :: [(String, ContextValue a)] -> Context a+      ic = intoContext++-- | ContextValues can hold certain types of data within a context.+data ContextValue a+  = EmptyValue+  | UndefinedValue String (Item a) [String] [String]+  | ContextValue (Context a)+  | ListValue [ContextValue a]+  | BoolValue Bool+  | StringValue String+  | DoubleValue Double+  | IntValue Int+  | FunctionValue (ContextValue a -> TemplateRunner a (ContextValue a))+  | BlockValue Block+  | ItemValue (Item a)+  | ThunkValue (TemplateRunner a (ContextValue a))+  | PairValue (ContextValue a, ContextValue a)++type FunctionValue v w a = v -> TemplateRunner a w++type FunctionValue2 v x w a = v -> FunctionValue x w a++type FunctionValue3 v x y w a = v -> FunctionValue2 x y w a++type FunctionValue4 v x y z w a = v -> FunctionValue3 x y z w a++instance Show (ContextValue a) where+  show = \case+    EmptyValue -> "EmptyValue"+    UndefinedValue name _ _ _ -> "UndefinedValue " ++ show name+    ContextValue {} -> "ContextValue"+    ListValue values -> "ListValue " ++ show values+    BoolValue value -> "BoolValue " ++ show value+    StringValue value -> "StringValue " ++ show value+    DoubleValue value -> "DoubleValue " ++ show value+    IntValue value -> "IntValue " ++ show value+    FunctionValue {} -> "FunctionValue"+    BlockValue {} -> "BlockValue"+    ItemValue item -> "ItemValue " ++ show (itemFilePath item)+    ThunkValue {} -> "ThunkValue"+    PairValue (x, y) -> "PairValue (" ++ show x ++ ", " ++ show y ++ ")"++itemValue :: Context a -> Item a -> ContextValue a+itemValue context item = intoValue (context, [item])++class IntoValue' (flag :: Bool) v a where+  intoValue' :: Proxy flag -> v -> ContextValue a++-- "Specialize" List+type family FString a :: Bool where+  FString Char = 'True+  FString _ = 'False++-- | Inject a concrete type @v@ into a @ContextValue a@.+class IntoValue v a where+  intoValue :: v -> ContextValue a++instance (FString v ~ flag, IntoValue' flag [v] a) => IntoValue [v] a where+  intoValue = intoValue' (Proxy :: Proxy flag)++instance (IntoValue v a) => IntoValue' 'False [v] a where+  intoValue' _ = ListValue . (intoValue <$>)++instance IntoValue' 'True String a where+  intoValue' _ = StringValue++instance IntoValue Block a where+  intoValue = BlockValue++instance IntoValue (ContextValue a) a where+  intoValue = id++instance IntoValue (Context a) a where+  intoValue = ContextValue++instance IntoValue Value a where+  intoValue = \case+    Object o -> ContextValue $ intoContext o+    Array a -> ListValue $ Vector.toList $ Vector.map intoValue a+    String t -> StringValue $ T.unpack t+    Number n+      | isInteger n -> IntValue $ fromJust $ toBoundedInteger n+      | otherwise -> DoubleValue $ fromRight 0.0 $ toBoundedRealFloat n+    Bool b -> BoolValue b+    Null -> EmptyValue++instance IntoValue () a where+  intoValue () = EmptyValue++instance IntoValue Bool a where+  intoValue = BoolValue++instance IntoValue Double a where+  intoValue = DoubleValue++instance IntoValue Int a where+  intoValue = IntValue++instance (IntoValue v a) => IntoValue (Maybe v) a where+  intoValue (Just v) = intoValue v+  intoValue Nothing = EmptyValue++instance (FromValue v a, IntoValue w a) => IntoValue (FunctionValue v w a) a where+  intoValue f = FunctionValue f'+    where+      f' cv = do+        v <- fromValue cv+        intoValue <$> f v++instance (FromValue v a, FromValue x a, IntoValue w a) => IntoValue (FunctionValue2 v x w a) a where+  intoValue f = FunctionValue f'+    where+      f' cv =+        intoValue . f <$> fromValue cv++instance (FromValue v a, FromValue x a, FromValue y a, IntoValue w a) => IntoValue (FunctionValue3 v x y w a) a where+  intoValue f = FunctionValue f'+    where+      f' cv =+        intoValue . f <$> fromValue cv++instance (FromValue v a, FromValue x a, FromValue y a, FromValue z a, IntoValue w a) => IntoValue (FunctionValue4 v x y z w a) a where+  intoValue f = FunctionValue f'+    where+      f' cv =+        intoValue . f <$> fromValue cv++instance IntoValue (TemplateRunner a (ContextValue a)) a where+  intoValue = ThunkValue++instance (IntoValue v a, IntoValue x a) => IntoValue (v, x) a where+  intoValue (v, x) = PairValue (intoValue v, intoValue x)++instance IntoValue (Item a) a where+  intoValue = ItemValue++-- | Extract a concrete value of type @v@ from a @ContextValue a@.+class FromValue v a where+  fromValue :: ContextValue a -> TemplateRunner a v++class FromValue' (flag :: Bool) v a where+  fromValue' :: Proxy flag -> ContextValue a -> TemplateRunner a v++instance (FString v ~ flag, FromValue' flag [v] a) => FromValue [v] a where+  fromValue = fromValue' (Proxy :: Proxy flag)++instance (FromValue v a) => FromValue' 'False [v] a where+  fromValue' flag = \case+    ListValue xs -> sequence $ fromValue <$> xs+    ThunkValue fx -> fromValue' flag =<< fx+    x -> tplFail $ "Tried to get " ++ show x ++ " as List"++instance FromValue' 'True String a where+  fromValue' flag = \case+    StringValue x -> return x+    EmptyValue -> return ""+    ThunkValue fx -> fromValue' flag =<< fx+    x -> tplFail $ "Tried to get " ++ show x ++ " as String"++instance FromValue (Context a) a where+  fromValue = \case+    ContextValue c -> return c+    ThunkValue fx -> fromValue =<< fx+    x -> tplFail $ "Tried to get " ++ show x ++ " as Context"++instance FromValue (ContextValue a) a where+  fromValue = return++instance FromValue Bool a where+  fromValue = \case+    BoolValue x -> return x+    ThunkValue fx -> fromValue =<< fx+    x -> tplFail $ "Tried to get " ++ show x ++ " as Bool"++instance FromValue Double a where+  fromValue = \case+    DoubleValue x -> return x+    ThunkValue fx -> fromValue =<< fx+    x -> tplFail $ "Tried to get " ++ show x ++ " as Double"++instance FromValue Int a where+  fromValue = \case+    IntValue x -> return x+    ThunkValue fx -> fromValue =<< fx+    x -> tplFail $ "Tried to get " ++ show x ++ " as Int"++instance FromValue (Item a) a where+  fromValue = \case+    ItemValue item -> return item+    ThunkValue fx -> fromValue =<< fx+    x -> tplFail $ "Tried to get " ++ show x ++ " as Item"++instance FromValue Block a where+  fromValue = \case+    BlockValue block -> return block+    ThunkValue fx -> fromValue =<< fx+    x -> tplFail $ "Tried to get " ++ show x ++ " as Block"++instance (IntoValue v a, FromValue w a) => FromValue (FunctionValue v w a) a where+  fromValue cv = case cv of+    FunctionValue f -> return f'+      where+        f' v = fromValue =<< f (intoValue v)+    ThunkValue fx -> fromValue =<< fx+    x -> tplFail $ "Tried to get " ++ show x ++ " as Function"++instance (IntoValue v a, IntoValue x a, FromValue w a) => FromValue (FunctionValue2 v x w a) a where+  fromValue cv = case cv of+    FunctionValue f -> return f'+      where+        f' v x = do+          g <- fromValue =<< f (intoValue v)+          g x+    ThunkValue fx -> fromValue =<< fx+    x -> tplFail $ "Tried to get " ++ show x ++ " as Function2"++instance (IntoValue v a, IntoValue x a, IntoValue y a, FromValue w a) => FromValue (FunctionValue3 v x y w a) a where+  fromValue = \case+    FunctionValue f -> return f'+      where+        f' v x y = do+          g <- fromValue =<< f (intoValue v)+          h <- g x+          h y+    ThunkValue fx -> fromValue =<< fx+    x -> tplFail $ "Tried to get " ++ show x ++ " as Function3"++instance (IntoValue v a, IntoValue x a, IntoValue y a, IntoValue z a, FromValue w a) => FromValue (FunctionValue4 v x y z w a) a where+  fromValue = \case+    FunctionValue f -> return f'+      where+        f' v x y z = do+          g <- fromValue =<< f (intoValue v)+          h <- g x+          i <- h y+          i z+    ThunkValue fx -> fromValue =<< fx+    x -> tplFail $ "Tried to get " ++ show x ++ " as Function4"++instance (FromValue v a, FromValue x a) => FromValue (v, x) a where+  fromValue = \case+    PairValue (a, b) -> (,) <$> fromValue a <*> fromValue b+    ThunkValue fx -> fromValue =<< fx+    x -> tplFail $ "Tried to get " ++ show x ++ " as Pair"
+ src/Hakyllbars/Field.hs view
@@ -0,0 +1,310 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++module Hakyllbars.Field+  ( module Hakyllbars.Field.Date,+    module Hakyllbars.Field.Git,+    module Hakyllbars.Field.Html,+    defaultFields,+    emptyString,+    defaultKeys,+    includeField,+    layoutField,+    ifField,+    forField,+    withField,+    forEachField,+    defaultField,+    linkedTitleField,+    metadataField,+    siteUrlField,+    urlField,+    absUrlField,+    getUrlField,+    getAbsUrlField,+    titleFromFileField,+    teaserField,+    metadataPriorityField,+    namedMetadataField,+    putField,+    addField,+    putBlockField,+    addBlockField,+  )+where++import Control.Monad.Except+import Data.Aeson.Key qualified as Key+import Data.Aeson.KeyMap qualified as KeyMap+import Hakyllbars.Ast+import Hakyllbars.Common+import Hakyllbars.Compiler+import Hakyllbars.Context+import Hakyllbars.Field.Date (DateConfig, dateFields, defaultDateConfigWith)+import Hakyllbars.Field.Git (gitFields)+import Hakyllbars.Field.Html (escapeHtmlField, escapeHtmlUriField)+import Hakyllbars.Util (stripSuffix)+import System.FilePath++defaultFields :: String -> String -> Context String+defaultFields host siteRoot =+  mconcat+    [ bodyField "body",+      constField "host" host,+      constField "siteRoot" siteRoot,+      pathField "path",+      siteUrlField "siteUrl" "host" "siteRoot",+      urlField "url" "siteRoot",+      absUrlField "absUrl" "host" "url",+      getUrlField "getUrl" "siteRoot",+      getAbsUrlField "getAbsUrl" "host" "getUrl",+      linkedTitleField "linkedTitle" "title" "url",+      escapeHtmlField,+      escapeHtmlUriField,+      putField "put",+      addField "add",+      putBlockField "putBlock",+      addBlockField "addBlock",+      ifField "if",+      forField "for",+      defaultField "default",+      withField "with",+      includeField "include" Nothing Nothing,+      includeField "partial" (Just "_partials") (Just "html"),+      layoutField "applyLayout" "_layouts" (Just "html"),+      metadataPriorityField "updated" ["updated", "published", "created"],+      metadataPriorityField "published" ["published", "created"],+      metadataField,+      titleFromFileField "title",+      constField "description" ("" :: String)+    ]++emptyString :: ContextValue a+emptyString = intoValue ("" :: String)++defaultKeys :: [String] -> Context a+defaultKeys keys = intoContext $ (,"" :: String) <$> keys++withField :: String -> Context String+withField key = functionField2 key f+  where+    f (context :: Context String) (blocks :: [Block]) =+      tplWithContext context do+        reduceBlocks blocks++includeField :: String -> Maybe FilePath -> Maybe FilePath -> Context String+includeField key basePath extension = functionField key f+  where+    f (filePath :: String) = do+      basePath' <- maybe (itemFilePath <$> tplItem) return basePath+      let filePath' = basePath' </> filePath+      let filePath'' = maybe filePath' (filePath' <.>) extension+      context <- tplContext+      applyTemplate (fromFilePath filePath'')+      itemValue context <$> tplPopItem++layoutField :: String -> FilePath -> Maybe FilePath -> Context String+layoutField key basePath extension = functionField2 key f+  where+    f (filePath :: FilePath) (content :: String) = do+      let filePath' = basePath </> filePath+      let filePath'' = maybe filePath' (filePath' <.>) extension+      let layoutId = fromFilePath filePath''+      (Template bs _) <- loadTemplate layoutId+      item <- itemSetBody content <$> tplItem+      tplWithItem item do+        reduceBlocks bs++ifField :: forall a. String -> Context a+ifField key = functionField key isTruthy++forField :: String -> Context String+forField key = functionField2 key applyForLoop++applyForLoop :: ContextValue String -> [Block] -> TemplateRunner String (Maybe String)+applyForLoop items blocks =+  getAsItems items+    `catchError` (\_ -> getAsStrings items)+    `catchError` (\_ -> return (mempty, []))+    >>= uncurry go+  where+    go context items'+      | null items' = return Nothing+      | otherwise = tplWithContext context do+          Just . mconcat <$> forM items' \item ->+            tplWithItem item do+              reduceBlocks blocks++getAsItems :: ContextValue String -> TemplateRunner String (Context String, [Item String])+getAsItems = fromValue++getAsStrings :: ContextValue String -> TemplateRunner String (Context String, [Item String])+getAsStrings x = do+  bodies <- fromValue x :: TemplateRunner String [String]+  items <- forM bodies \body -> itemSetBody body <$> tplItem+  return (bodyField "item", items)++forEachField :: String -> Context String+forEachField key = functionField3 key f+  where+    f (forEachKey :: ContextValue String) (forEachItems :: ContextValue String) (blocks :: [Block]) = do+      keyId <- getKey forEachKey+      keyItemPairs <- fromValue forEachItems :: TemplateRunner String [(ContextValue String, ContextValue String)]+      keyItemPairs `forM` \(key', items) ->+        tplWithContext (constField keyId key') do+          applyForLoop items blocks+    getKey block = case block of+      UndefinedValue k _ _ _ -> return k -- allow identifier as key+      StringValue k -> return k+      _ -> tplFail "forEach: key must be a string or identifier"++defaultField :: forall a. String -> Context a+defaultField key = functionField2 key f+  where+    f (default' :: ContextValue a) (arg :: ContextValue a) =+      isTruthy arg <&> \case+        True -> arg+        False -> default'++linkedTitleField :: String -> String -> String -> Context String+linkedTitleField key titleKey urlKey = constField key f+  where+    f :: FunctionValue String String String+    f filePath = do+      tplWithItem (Item (fromFilePath filePath) "") do+        makeLink <$> getField titleKey <*> getField urlKey+      where+        getField key' = do+          context <- tplContext+          fromValue =<< unContext context key'+        makeLink title url+          | ".html" `isSuffixOf` filePath = "<a href=\"" ++ escapeHtml url ++ "\" title=\"" ++ escapeHtml title ++ "\">" ++ escapeHtml title ++ "</a>"+          | ".md" `isSuffixOf` filePath = "[" ++ title ++ "](" ++ url ++ " \"" ++ title ++ "\")"+          | otherwise = title ++ " <" ++ url ++ ">"++metadataField :: forall a. Context a+metadataField = Context f+  where+    f key = lift . getMetadataField key =<< tplItem++getMetadataField :: String -> Item a -> Compiler (ContextValue a)+getMetadataField key item = do+  m <- getMetadata (itemIdentifier item)+  maybe+    (noResult $ "tried metadata key " ++ show key)+    (return . intoValue)+    (KeyMap.lookup (Key.fromString key) m)++bodyField :: String -> Context String+bodyField key = field key $ return . itemBody++siteUrlField :: String -> String -> String -> Context a+siteUrlField key hostKey siteRootKey = field key f+  where+    f _ = do+      context <- tplContext+      host <- fromValue =<< unContext context hostKey+      siteRoot <- fromValue =<< unContext context siteRootKey+      return (host ++ siteRoot :: String)++urlField :: String -> String -> Context a+urlField key siteRootKey = field key f+  where+    f = getUri key siteRootKey . itemIdentifier++getUrlField :: String -> String -> Context a+getUrlField key siteRootKey = functionField key f+  where+    f = getUri key siteRootKey . fromFilePath++getUri :: String -> String -> Identifier -> TemplateRunner a String+getUri key siteRootKey id' = do+  siteRoot <-+    tplContext+      >>= flip unContext siteRootKey+      >>= fromValue+  maybeRoute <- lift $ getRoute id'+  definitelyRoute <-+    maybe+      (fail $ "no route by " ++ show key ++ " found for item " ++ show id')+      (return . ("/" ++))+      maybeRoute+  let uri = stripSuffix "index.html" definitelyRoute+  return if null uri then siteRoot else siteRoot ++ uri++absUrlField :: String -> String -> String -> Context a+absUrlField key hostKey urlKey = field key f+  where+    f _ = do+      context <- tplContext+      host <- fromValue =<< unContext context hostKey+      url <- fromValue =<< unContext context urlKey+      return (host ++ url :: String)++getAbsUrlField :: forall a. String -> String -> String -> Context a+getAbsUrlField key hostKey getUrlKey = functionField key f+  where+    f (filePath :: FilePath) = do+      context <- tplContext+      host <- fromValue =<< unContext context hostKey+      getUrl <- fromValue =<< unContext context getUrlKey+      url <- getUrl (intoValue filePath :: ContextValue a)+      return (host ++ url :: String)++pathField :: String -> Context a+pathField key = field key $ return . toFilePath . itemIdentifier++titleFromFileField :: String -> Context a+titleFromFileField = bindField titleFromPath . pathField+  where+    titleFromPath = return . takeBaseName++teaserField :: String -> Snapshot -> Context String+teaserField key snapshot = field key f+  where+    f item = lift do+      body <- loadSnapshotBody (itemIdentifier item) snapshot+      case takeTeaser body of+        Just teaser -> return teaser+        Nothing -> fail $ "item " ++ itemFilePath item ++ " has no teaser"+    takeTeaser = go ""+      where+        go acc xss@(x : xs)+          | "<!--more-->" `isPrefixOf` xss = Just (reverse acc)+          | otherwise = go (x : acc) xs+        go _ [] = Nothing++metadataPriorityField :: String -> [String] -> Context a+metadataPriorityField key priorityKeys = field key f+  where+    f item =+      lift $+        foldl+          (<|>)+          (noResult $ "Metadata priority key " ++ show key ++ " from set " ++ show priorityKeys)+          (flip getMetadataField item <$> priorityKeys)++namedMetadataField :: String -> Context String+namedMetadataField key = field key $ lift . getMetadataField key++putField :: String -> Context a+putField key = functionField key tplPut++addField :: forall a. String -> Context a+addField key = functionField2 key f+  where+    f (name :: String) (value :: ContextValue a) = do+      current <- tplGet name `catchError` \_ -> return []+      tplPut $ constField name (value : current)++putBlockField :: String -> Context a+putBlockField key = functionField2 key f+  where+    f (name :: String) (blocks :: [Block]) = do+      tplPut $ constField name blocks++addBlockField :: String -> Context a+addBlockField key = functionField2 key f+  where+    f (name :: String) (blocks :: [Block]) = do+      current <- tplGet name `catchError` \_ -> return []+      tplPut $ constField name (current ++ blocks)
+ src/Hakyllbars/Field/Date.hs view
@@ -0,0 +1,189 @@+module Hakyllbars.Field.Date+  ( DateConfig (..),+    defaultDateConfigWith,+    dateFields,+    dateFormatField,+    dateField,+    publishedField,+    updatedField,+    getLastModifiedDate,+    isPublishedField,+    isUpdatedField,+    dateFromMetadata,+    normalizedDateTimeFormat,+    parseTimeM',+  )+where++import Data.Aeson.Key qualified as Key+import Data.Aeson.KeyMap qualified as KeyMap+import Data.List (tails)+import Data.String.Utils+import Hakyllbars.Common+import Hakyllbars.Context+import Hakyllbars.Util++data DateConfig = DateConfig+  { dateConfigLocale :: TimeLocale,+    dateConfigCurrentTime :: ZonedTime,+    dateConfigDateLongFormat :: String,+    dateConfigDateShortFormat :: String,+    dateConfigTimeFormat :: String,+    dateConfigRobotDateFormat :: String,+    dateConfigRobotTimeFormat :: String+  }++defaultDateConfigWith :: TimeLocale -> ZonedTime -> DateConfig+defaultDateConfigWith locale currentTime =+  DateConfig+    { dateConfigLocale = locale,+      dateConfigCurrentTime = currentTime,+      dateConfigDateLongFormat = "%B %e, %Y %l:%M %P %EZ",+      dateConfigDateShortFormat = "%B %e, %Y",+      dateConfigTimeFormat = "%l:%M %p %EZ",+      dateConfigRobotDateFormat = "%Y-%m-%d",+      dateConfigRobotTimeFormat = "%Y-%m-%dT%H:%M:%S%Ez"+    }++dateFields :: DateConfig -> Context a+dateFields config =+  mconcat+    [ dateField "date" (dateConfigLocale config) (dateConfigCurrentTime config),+      publishedField "published" (dateConfigLocale config),+      updatedField "updated" (dateConfigLocale config),+      isPublishedField "isPublished",+      isUpdatedField "isUpdated",+      constField "longDate" (dateConfigDateLongFormat config),+      constField "shortDate" (dateConfigDateShortFormat config),+      constField "timeOnly" (dateConfigTimeFormat config),+      constField "robotDate" (dateConfigRobotDateFormat config),+      constField "robotTime" (dateConfigRobotTimeFormat config),+      constField "rfc822" rfc822DateFormat,+      dateFormatField "dateAs" (dateConfigLocale config)+    ]++dateFormatField :: String -> TimeLocale -> Context a+dateFormatField key timeLocale = functionField2 key f+  where+    f (dateFormat :: String) (dateString :: String) = do+      date <- deserializeTime dateString+      return $ formatTime timeLocale dateFormat date+    deserializeTime = parseTimeM' timeLocale normalizedDateTimeFormat++dateField :: String -> TimeLocale -> ZonedTime -> Context a+dateField key timeLocale currentTime = field key f+  where+    f item = do+      metadata <- lift . getMetadata $ itemIdentifier item+      tplWithCall key . lift $+        do+          let maybeDateString = dateFromMetadata timeLocale ["date", "published"] metadata+          maybe (dateFromFilePath timeLocale item) return maybeDateString+            <|> return (formatTime timeLocale "%Y-%m-%dT%H:%M:%S%Ez" currentTime)++publishedField :: String -> TimeLocale -> Context a+publishedField key timeLocale = field key f+  where+    f =+      lift+        . getMetadata+        . itemIdentifier+        >=> tplWithCall key+        . lift+        . maybe (noResult $ "Tried published field " ++ show key) return+        . dateFromMetadata timeLocale ["published", "date"]++updatedField :: String -> TimeLocale -> Context a+updatedField key timeLocale = field key f+  where+    f =+      lift+        . getMetadata+        . itemIdentifier+        >=> tplWithCall key+        . lift+        . maybe (noResult $ "Tried updated field " ++ show key) return+        . dateFromMetadata timeLocale ["updated", "published", "date"]++getLastModifiedDate :: TimeLocale -> Item a -> Compiler ZonedTime+getLastModifiedDate timeLocale item = do+  metadata <- getMetadata $ itemIdentifier item+  let maybeDateString = dateFromMetadata timeLocale ["updated", "published", "date"] metadata+  dateString <- maybe (dateFromFilePath timeLocale item) return maybeDateString+  parseTimeM' timeLocale "%Y-%m-%dT%H:%M:%S%Ez" dateString++dateFromMetadata :: TimeLocale -> [String] -> Metadata -> Maybe String+dateFromMetadata timeLocale sourceKeys metadata =+  firstAlt $ findDate <$> sourceKeys+  where+    findDate sourceKey =+      serializeTime =<< lookupString sourceKey metadata+    serializeTime dateString = do+      date <- firstAlt (parse dateString <$> metadataDateFormats)+      return $ normalizedTime timeLocale date+    parse = flip $ parseTimeM True timeLocale++dateFromFilePath :: TimeLocale -> Item a -> Compiler String+dateFromFilePath timeLocale item =+  dateFromPath+    <|> noResult ("Could not find file path date from " ++ show (toFilePath $ itemIdentifier item))+  where+    dateFromPath =+      firstAlt $+        dateFromPath' . intercalate "-"+          <$> ( [take 3 $ split "-" fnCand | fnCand <- reverse paths]+                  ++ (fmap (take 3) <$> reverse (tails paths))+              )+    paths = splitDirectories $ dropExtension $ toFilePath $ itemIdentifier item+    dateFromPath' path = do+      debugCompiler $ "Trying to parse date from path " ++ show path+      date <- parseTimeM' timeLocale "%Y-%m-%d" path+      return $ normalizedTime timeLocale date++parseTimeM' :: (MonadFail m) => TimeLocale -> String -> String -> m ZonedTime+parseTimeM' = parseTimeM True++normalizedTime :: TimeLocale -> ZonedTime -> String+normalizedTime = flip formatTime normalizedDateTimeFormat++normalizedDateTimeFormat :: String+normalizedDateTimeFormat = "%Y-%m-%dT%H:%M:%S%Ez"++rfc822DateFormat :: String+rfc822DateFormat = "%a, %d %b %Y %H:%M:%S %Z"++metadataDateFormats :: [String]+metadataDateFormats =+  [ "%Y-%m-%d",+    normalizedDateTimeFormat,+    "%Y-%m-%dT%H:%M:%S",+    "%Y-%m-%d %H:%M:%S %EZ",+    "%Y-%m-%d %H:%M:%S%Ez",+    "%Y-%m-%d %H:%M:%S",+    rfc822DateFormat,+    "%a, %d %b %Y %H:%M:%S",+    "%B %e, %Y %l:%M %p %EZ",+    "%B %e, %Y %l:%M %p",+    "%b %e, %Y %l:%M %p %EZ",+    "%b %e, %Y %l:%M %p",+    "%B %e, %Y",+    "%B %d, %Y",+    "%b %e, %Y",+    "%b %d, %Y"+  ]++isPublishedField :: String -> Context a+isPublishedField key = field key f+  where+    f item = lift do+      getMetadata (itemIdentifier item)+        <&> isJust+        . KeyMap.lookup (Key.fromString "published")++isUpdatedField :: String -> Context a+isUpdatedField key = field key f+  where+    f item = lift do+      getMetadata (itemIdentifier item)+        <&> isJust+        . KeyMap.lookup (Key.fromString "updated")
+ src/Hakyllbars/Field/Git.hs view
@@ -0,0 +1,92 @@+module Hakyllbars.Field.Git+  ( gitFields,+    gitSha1Compiler,+    gitMessageCompiler,+    gitLogField,+    gitFileField,+    gitFileCompiler,+    gitBranchCompiler,+    gitBranch,+  )+where++import Data.Binary+import GHC.Generics (Generic)+import Hakyllbars.Common+import Hakyllbars.Context+import System.Exit+import System.Process++gitFields :: String -> String -> Context a+gitFields providerDirectory gitWebUrl =+  mconcat+    [ constField "gitWebUrl" gitWebUrl,+      field "gitSha1" (gitSha1Compiler providerDirectory),+      field "gitMessage" (gitMessageCompiler providerDirectory),+      field "gitBranch" gitBranchCompiler,+      gitFileField providerDirectory "gitFilePath" gitFilePath,+      gitFileField providerDirectory "gitFileName" (takeFileName . gitFilePath),+      gitFileField providerDirectory "isFromSource" gitFileIsFromSource,+      gitFileField providerDirectory "isChanged" gitFileIsChanged+    ]++gitSha1Compiler :: String -> Item a -> TemplateRunner a String+gitSha1Compiler = gitLogField "%h"++gitMessageCompiler :: String -> Item a -> TemplateRunner a String+gitMessageCompiler = gitLogField "%s"++type LogFormat = String++gitLogField :: LogFormat -> String -> Item a -> TemplateRunner a String+gitLogField format providerDirectory item =+  lift $ unsafeCompiler do+    maybeResult <- gitLog format (Just $ providerDirectory </> toFilePath (itemIdentifier item))+    case maybeResult of+      Just result -> return result+      Nothing -> fromJust <$> gitLog format Nothing++data GitFile = GitFile+  { gitFilePath :: String,+    gitFileIsFromSource :: Bool,+    gitFileIsChanged :: Bool+  }+  deriving (Generic)++instance Binary GitFile where+  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+gitFileField providerDirectory key f = field key $ fmap f . gitFileCompiler providerDirectory++gitFileCompiler :: String -> Item a -> TemplateRunner a GitFile+gitFileCompiler providerDirectory item =+  lift $+    GitFile gitFilePath+      <$> unsafeCompiler (doesFileExist gitFilePath)+      <*> unsafeCompiler (isChanged gitFilePath)+  where+    gitFilePath = providerDirectory </> toFilePath (itemIdentifier item)+    isChanged filePath = do+      let args = ["diff", "HEAD", filePath]+      (exitCode, stdout, _stderr) <- readProcessWithExitCode "git" args ""+      return $ not (exitCode == ExitSuccess && null stdout)++gitLog :: LogFormat -> Maybe FilePath -> IO (Maybe String)+gitLog format filePath = do+  let fpArgs = bool [] [fromJust filePath] (isJust filePath)+  let args = ["log", "-1", "HEAD", "--pretty=format:" ++ format] ++ fpArgs+  (_exitCode, stdout, _stderr) <- readProcessWithExitCode "git" args ""+  return if null stdout then Nothing else Just stdout++gitBranchCompiler :: Item a -> TemplateRunner a String+gitBranchCompiler _ = lift $ unsafeCompiler gitBranch++gitBranch :: IO String+gitBranch = do+  let args = ["branch", "--show-current"]+  (exitCode, stdout, stderr) <- readProcessWithExitCode "git" args ""+  if exitCode == ExitSuccess+    then return stdout+    else fail $ "Unable to get current branch: " ++ stderr
+ src/Hakyllbars/Field/Html.hs view
@@ -0,0 +1,19 @@+module Hakyllbars.Field.Html+  ( escapeHtmlField,+    escapeHtmlUriField,+  )+where++import Hakyllbars.Common+import Hakyllbars.Context+import Network.URI (escapeURIString, isUnescapedInURI)++escapeHtmlField :: Context String+escapeHtmlField = functionField "escapeHtml" f+  where+    f = return . escapeHtml++escapeHtmlUriField :: Context String+escapeHtmlUriField = functionField "escapeHtmlUri" f+  where+    f = return . escapeHtml . escapeURIString isUnescapedInURI
+ src/Hakyllbars/Pandoc.hs view
@@ -0,0 +1,16 @@+module Hakyllbars.Pandoc where++import Hakyll hiding (pandocCompilerWith)+import System.FilePath+import Text.Pandoc++pandocCompiler :: Item String -> Compiler (Item String)+pandocCompiler = pandocCompilerWith defaultHakyllReaderOptions defaultHakyllWriterOptions++pandocCompilerWith :: ReaderOptions -> WriterOptions -> Item String -> Compiler (Item String)+pandocCompilerWith readerOpts writerOpts item@(Item id' _) = do+  let ext = takeExtension $ toFilePath id'+  go ext+  where+    go ".html" = return item+    go _ = renderPandocWith readerOpts writerOpts item
+ src/Hakyllbars/Source.hs view
@@ -0,0 +1,3 @@+module Hakyllbars.Source (module Hakyllbars.Source.Parser) where++import Hakyllbars.Source.Parser
+ src/Hakyllbars/Source/Lexer.hs view
@@ -0,0 +1,384 @@+module Hakyllbars.Source.Lexer where++import Data.Functor+import Data.Maybe+import Data.Scientific+import Data.String+import Hakyllbars.Source.Util+import Text.Parsec hiding (runParser, token, tokens, (<?>))+import Prelude hiding (lex)++type Lexer a = Parsec String ParserState a++lex :: SourceName -> String -> Either ParseError [Token]+lex = runParser $ manyTill token eof++token :: Lexer Token+token =+  getLexerMode >>= \case+    --+    BlockMode -> do+      trace "BlockMode"+      blockToken >>= \t -> case t of+        TaggedToken TurnOffToken _ -> t <$ startFenced+        TaggedToken CommentBlockToken _ -> t <$ startFenced+        TaggedToken CloseBlockToken _ -> t <$ startText+        _ -> return t+    --+    TextMode -> do+      trace "TextMode"+      tryOne+        [ do+            void . lookAhead $ tryOne [spaces *> trimmingOpen, open]+            startBlock+            token,+          textToken+        ]+    --+    FencedMode {} -> do+      trace "FencedMode"+      fencedText++startText :: (Show t, Stream s m t) => ParsecT s ParserState m ()+startText = putLexerMode TextMode <?> "starting text"++startBlock :: (Show t, Stream s m t) => ParsecT s ParserState m ()+startBlock = putLexerMode BlockMode <?> "starting block"++startFenced :: (Show t, Stream s m t) => ParsecT s ParserState m ()+startFenced = putLexerMode (FencedMode 1) <?> "starting fenced text"++illegalState :: (Show t, Stream s m t) => ParsecT s ParserState m a+illegalState = p <?> "illegal state"+  where+    p = do+      mode <- getLexerMode+      fail $ "Illegal lexer mode: " ++ show mode++blockToken :: Lexer Token+blockToken =+  tryOne+    [ symbolToken,+      numberToken,+      boolToken,+      endKeyword,+      elseKeyword,+      nameToken,+      stringToken+    ]++textToken :: Lexer Token+textToken = withPosition (TextToken <$> text) <?> "text"++fencedText :: Lexer Token+fencedText = withPosition (TextToken <$> p "")+  where+    p acc =+      tryOne+        [ downFence acc,+          upFence acc,+          fenceText acc+        ]+    -- {{+    downFence acc = do+      trace "downFence"+      x <- open+      downFenceLevel+      p (acc ++ x)+    -- }}+    upFence acc = do+      trace "upFence"+      void . lookAhead $ tryOne [trimmingClose, close]+      upFenceLevel >>= \case+        0 -> do+          startBlock+          return acc+        _ -> do+          x <- tryOne [trimmingClose, close]+          p (acc ++ x)+    -- ...abc...+    fenceText acc = do+      trace "fenceText"+      t <- text+      p (acc ++ t)+    --+    downFenceLevel = do+      n <- succ <$> fenceLevel+      putLexerMode $ FencedMode n+    upFenceLevel = do+      n <- pred <$> fenceLevel+      putLexerMode $ FencedMode n+      return n+    fenceLevel =+      getLexerMode >>= \case+        FencedMode n -> return n+        _ -> illegalState++text :: Lexer String+text = mconcat <$> manyTill p (lookAhead $ try end)+  where+    p =+      tryOne+        [ labeled "TextString" $ many1 (noneOf "-{}\\\n\t "),+          labeled "Just '{'" $ openBrace <* notFollowedBy (try openBrace),+          labeled "Just '}'" $ closeBrace <* notFollowedBy (try closeBrace),+          labeled "Just '-'" $ string "-" <* notFollowedBy (try closeBrace),+          labeled "Just '\\'" $ string "\\" <* notFollowedBy (try escapedText),+          labeled "EscapedText" $ char '\\' *> escapedText,+          labeled "SpaceString" $ many1 space <* notFollowedBy (try trimmingOpen)+        ]+    escapedText =+      tryOne+        [ openBrace,+          closeBrace,+          string "-",+          string "\\"+        ]+    end =+      labeled "text terminator" . tryOne $+        [ spaces *> trimmingOpen,+          trimmingClose,+          open,+          close,+          "" <$ eof+        ]++symbolToken :: Lexer Token+symbolToken =+  withPosition $+    tryOne+      [ spaces+          *> tryOne+            [ mkTrimmingSymbol TurnOffToken,+              mkTrimmingSymbol CommentBlockToken,+              mkTrimmingSymbol AltBlockToken <* spaces,+              mkTrimmingSymbol ChromeBlockToken <* spaces,+              mkTrimmingSymbol ExpressionBlockToken <* spaces+            ],+        mkTrimmingSymbol CloseBlockToken <* spaces,+        --+        mkSymbol TurnOffToken,+        mkSymbol CommentBlockToken,+        mkSymbol AltBlockToken <* spaces,+        mkSymbol ChromeBlockToken <* spaces,+        mkSymbol ExpressionBlockToken <* spaces,+        mkSymbol CloseBlockToken,+        --+        mkSymbol OpenBraceToken <* spaces,+        mkSymbol CloseBraceToken <* spaces,+        mkSymbol OpenParenToken <* spaces,+        mkSymbol CloseParenToken <* spaces,+        mkSymbol OpenBracketToken <* spaces,+        mkSymbol CloseBracketToken <* spaces,+        mkSymbol PipeToken <* spaces,+        mkSymbol ColonToken <* spaces,+        mkSymbol DotToken <* spaces,+        mkSymbol CommaToken <* spaces+      ]+  where+    mkSymbol t = TaggedToken t <$ string (tokenTagValue t) <?> show t+    mkTrimmingSymbol t = TaggedToken t <$ string (trimmingTokenTagValue t) <?> showTrimmingTokenTag t++boolToken :: Lexer Token+boolToken = withPosition (BoolToken <$> value) <?> "BoolToken"+  where+    value =+      True <$ tryOne [keyword "True", keyword "true"]+        <|> False <$ tryOne [keyword "False", keyword "false"]++stringToken :: Lexer Token+stringToken = labeled "StringToken" $ withPosition $ (StringToken <$> stringChars) <* spaces+  where+    stringChars =+      tryOne+        [ between squote squote $ many (noneOf "\\\'\n" <|> escapeChar),+          between dquote dquote $ many (noneOf "\\\"\n" <|> escapeChar)+        ]+    squote = char '\''+    dquote = char '"'+    escapeChar =+      labeled "EscapeChar" $+        char '\\'+          *> tryOne+            [ char '\\',+              char '\'',+              char '"',+              char 'n' $> '\n',+              char 't' $> '\t'+            ]++numberToken :: Lexer Token+numberToken = withPosition (numberToken' <* spaces)+  where+    numberToken' = do+      value <- ints <> option "" doubles+      notFollowedBy badChars+      case (read value :: Scientific) of+        n | isInteger n -> labeled "IntToken" . return . IntToken . fromJust . toBoundedInteger $ n+        n | otherwise -> labeled "DoubleToken" . return . DoubleToken . toRealFloat $ n++    ints = labeled "IntegerDigits" $ justZero <|> ((:) <$> nonZero <*> many digit)+    justZero = labeled "JustZero" $ string "0" <* notFollowedBy nonZero+    nonZero = labeled "NonZeroDigit" $ oneOf ['1' .. '9']+    doubles = labeled "DoubleDigits" $ string "." <> many1 digit+    badChars = labeled "BadNumberChar" $ oneOf "_." <|> alphaNum++nameToken :: Lexer Token+nameToken = withPosition $ (NameToken <$> name <?> "NameToken") <* spaces++endKeyword :: Lexer Token+endKeyword = withPosition do+  keyword (tokenTagValue EndToken)+  return $ TaggedToken EndToken++elseKeyword :: Lexer Token+elseKeyword = withPosition do+  keyword (tokenTagValue ElseToken)+  return $ TaggedToken ElseToken++keyword :: String -> Lexer ()+keyword s = labeled ("Keyword " ++ show s) do+  () <$ string s <* notFollowedBy nameRest <* spaces++name :: Lexer String+name = labeled "NameValue" do+  (:) <$> nameStart <*> many nameRest++nameStart :: Lexer Char+nameStart = oneOf ('_' : ['a' .. 'z'])++nameRest :: Lexer Char+nameRest = tryOne [nameStart, alphaNum]++data Token+  = TaggedToken TokenTag SourcePos+  | BoolToken Bool SourcePos+  | NameToken String SourcePos+  | StringToken String SourcePos+  | IntToken Int SourcePos+  | DoubleToken Double SourcePos+  | TextToken String SourcePos+  deriving (Eq)++instance Show Token where+  show t = case t of+    TaggedToken tt _ -> show tt+    BoolToken b _ -> "Bool " ++ show b+    NameToken s _ -> "Name " ++ show s+    StringToken s _ -> "String " ++ show s+    IntToken n _ -> "Int " ++ show n+    DoubleToken x _ -> "Double " ++ show x+    TextToken s _ -> "Text " ++ show s++getTokenPos :: Token -> SourcePos+getTokenPos = \case+  TaggedToken _ pos -> pos+  BoolToken _ pos -> pos+  NameToken _ pos -> pos+  StringToken _ pos -> pos+  IntToken _ pos -> pos+  DoubleToken _ pos -> pos+  TextToken _ pos -> pos++data TokenTag+  = ExpressionBlockToken+  | CommentBlockToken+  | AltBlockToken+  | ChromeBlockToken+  | CloseBlockToken+  | OpenParenToken+  | CloseParenToken+  | OpenBraceToken+  | CloseBraceToken+  | OpenBracketToken+  | CloseBracketToken+  | PipeToken+  | CommaToken+  | DotToken+  | ColonToken+  | EndToken+  | ElseToken+  | TurnOffToken+  deriving (Eq)++tokenTagName :: TokenTag -> String+tokenTagName = \case+  ExpressionBlockToken -> "ExpressionBlock"+  CommentBlockToken -> "CommentBlock"+  AltBlockToken -> "AltBlock"+  ChromeBlockToken -> "ChromeBlock"+  CloseBlockToken -> "CloseBlock"+  OpenParenToken -> "OpenParen"+  CloseParenToken -> "CloseParen"+  OpenBracketToken -> "OpenBracket"+  CloseBracketToken -> "CloseBracket"+  OpenBraceToken -> "OpenBrace"+  CloseBraceToken -> "CloseBrace"+  PipeToken -> "PipeToken"+  CommaToken -> "CommaToken"+  DotToken -> "DotToken"+  ColonToken -> "ColonToken"+  EndToken -> "EndToken"+  ElseToken -> "ElseToken"+  TurnOffToken -> "TurnOff"++tokenTagValue :: TokenTag -> String+tokenTagValue = \case+  ExpressionBlockToken -> "{{"+  CommentBlockToken -> "{{!"+  AltBlockToken -> "{{#"+  ChromeBlockToken -> "{{@"+  CloseBlockToken -> "}}"+  OpenParenToken -> "("+  CloseParenToken -> ")"+  OpenBraceToken -> "{"+  CloseBraceToken -> "}"+  OpenBracketToken -> "["+  CloseBracketToken -> "]"+  PipeToken -> "|"+  CommaToken -> ","+  DotToken -> "."+  ColonToken -> ":"+  EndToken -> "end"+  ElseToken -> "else"+  TurnOffToken -> "{{*"++tokenTagParser :: TokenTag -> Lexer String+tokenTagParser tag = string (tokenTagValue tag) <?> show tag++trimmingTokenTagValue :: TokenTag -> String+trimmingTokenTagValue = \case+  ExpressionBlockToken -> "{{-"+  CommentBlockToken -> "{{-!"+  AltBlockToken -> "{{-#"+  ChromeBlockToken -> "{{-@"+  CloseBlockToken -> "-}}"+  TurnOffToken -> "{{-*"+  t -> tokenTagValue t++trimmingTokenTagParser :: TokenTag -> Lexer String+trimmingTokenTagParser tag = string (trimmingTokenTagValue tag) <?> showTrimmingTokenTag tag++showTrimmingTokenTag :: TokenTag -> String+showTrimmingTokenTag t = tokenTagName t ++ " " ++ show (trimmingTokenTagValue t)++open :: Lexer String+open = tokenTagParser ExpressionBlockToken++close :: Lexer String+close = tokenTagParser CloseBlockToken++trimmingOpen :: Lexer String+trimmingOpen = trimmingTokenTagParser ExpressionBlockToken++trimmingClose :: Lexer String+trimmingClose = trimmingTokenTagParser CloseBlockToken++openBrace :: Lexer String+openBrace = tokenTagParser OpenBraceToken++closeBrace :: Lexer String+closeBrace = tokenTagParser CloseBraceToken++instance Show TokenTag where+  show t = tokenTagName t ++ " " ++ show (tokenTagValue t)
+ src/Hakyllbars/Source/Parser.hs view
@@ -0,0 +1,254 @@+module Hakyllbars.Source.Parser where++import Data.Functor+import Data.List.NonEmpty as NEL+import Data.Maybe+import Data.String+import Hakyllbars.Ast+import Hakyllbars.Source.Lexer+import Hakyllbars.Source.Util+import Text.Parsec hiding (parse, runParser, token, tokens, (<?>))+import qualified Text.Parsec as P+import Prelude hiding (lex)++type Parser a = Parsec [Token] ParserState a++parse :: SourceName -> String -> Either ParseError Template+parse origin input = do+  tokens <- lex origin input+  blocks <- runParser (many block <* eof) origin tokens+  return $ Template blocks origin++block :: Parser Block+block =+  tryOne+    [ offBlock,+      commentBlock,+      chromeBlock,+      altBlock,+      expressionBlock,+      textBlock+    ]++commentBlock :: Parser Block+commentBlock = labeled "CommentBlock" $+  withPosition do+    -- {{!+    withTag CommentBlockToken+    -- ...text...+    value <- withToken \case+      TextToken value _ -> Just value+      _ -> Nothing+    -- }}+    closeBlock+    return $ CommentBlock value++offBlock :: Parser Block+offBlock = labeled "OffBlock" $+  withPosition do+    -- {{*+    withTag TurnOffToken+    -- ...text...+    value <- withToken \case+      TextToken value _ -> Just value+      _ -> Nothing+    -- }}+    withTag CloseBlockToken+    return $ TextBlock value++expressionBlock :: Parser Block+expressionBlock = labeled "ExpressionBlock" $+  withPosition do+    -- {{+    withTag ExpressionBlockToken+    -- ...1 + 2...+    e <- expression+    -- }}+    closeBlock+    return $ ExpressionBlock e++chromeBlock :: Parser Block+chromeBlock = labeled "ChromeBlock" $+  withPosition do+    -- {{@+    withTag ChromeBlockToken+    -- ...layout "body"...+    e <- expression+    -- }}+    closeBlock+    -- {{...}}++    bs <- many block+    return $ ChromeBlock e bs++altBlock :: Parser Block+altBlock = labeled "AltBlock" $ withPosition do+  -- {{#if doThis}} <- one of these+  startAlt <- labeled "StartAlt" $ withPosition do+    e <- between altToken closeBlock expression+    bs <- manyTill block closeAlt+    return $ ApplyBlock e bs+  -- {{#else doThat}} <- zero or more of these+  elseAlts <- flip manyTill closeElses $+    labeled "ElseAlt" $ withPosition do+      e <- between (altToken *> elseToken) closeBlock expression+      bs <- manyTill block closeAlt+      return $ ApplyBlock e bs+  -- {{#else}} <- zero or one of these+  defaultAlt <- optionMaybe . try $+    labeled "DefaultAlt" $ withPosition do+      defaultBlock+      bs <- manyTill block closeDefault+      return $ DefaultBlock bs+  -- {{#end}}+  endBlock+  return $ AltBlock (startAlt :| elseAlts) defaultAlt+  where+    closeAlt = lookAhead $ tryOne [endBlock, defaultBlock, elseBlock]+    closeElses = lookAhead $ tryOne [endBlock, defaultBlock]+    closeDefault = lookAhead $ try endBlock+    --+    endBlock = altToken *> endToken *> closeBlock+    defaultBlock = altToken *> elseToken *> closeBlock+    elseBlock = altToken *> elseToken+    --+    altToken = withTag AltBlockToken+    elseToken = withTag ElseToken+    endToken = withTag EndToken++textBlock :: Parser Block+textBlock = labeled "TextBlock" $+  withToken \case+    TextToken x pos -> Just $ TextBlock x pos+    _ -> Nothing++expression :: Parser Expression+expression = filterExpression <?> "Expression"+{-# INLINE expression #-}++filterExpression :: Parser Expression+filterExpression = applyExpression `chainl1` filtered <?> "FilterExpression"+  where+    filtered = withPosition do+      withTag PipeToken+      return f+    f pos x y = FilterExpression x y pos++applyExpression :: Parser Expression+applyExpression = chain . NEL.fromList <$> many1 accessExpression <?> "ApplyExpression"+  where+    chain (fn :| args) = chain' fn args+    chain' fn (arg : rest) = chain' (ApplyExpression fn arg (getExpressionPos arg)) rest+    chain' done [] = done++accessExpression :: Parser Expression+accessExpression = simpleExpression `chainl1` try accessed <?> "AccessExpression"+  where+    accessed = withPosition do+      withTag DotToken+      return f+    f pos x (NameExpression id' pos') = f pos x (StringExpression id' pos')+    f pos x y = AccessExpression x y pos++simpleExpression :: Parser Expression+simpleExpression =+  tryOne+    [ stringExpression,+      intExpression,+      doubleExpression,+      boolExpression,+      nameExpression,+      parensExpression,+      contextExpression,+      listExpression+    ]++stringExpression :: Parser Expression+stringExpression = labeled "StringLiteral" $+  withToken \case+    StringToken value pos -> Just (StringExpression value pos)+    _ -> Nothing++intExpression :: Parser Expression+intExpression = labeled "IntLiteral" $+  withToken \case+    IntToken value pos -> Just (IntExpression value pos)+    _ -> Nothing++doubleExpression :: Parser Expression+doubleExpression = labeled "DoubleLiteral" $+  withToken \case+    DoubleToken value pos -> Just (DoubleExpression value pos)+    _ -> Nothing++boolExpression :: Parser Expression+boolExpression = labeled "BoolLiteral" $+  withToken \case+    BoolToken value pos -> Just (BoolExpression value pos)+    _ -> Nothing++nameExpression :: Parser Expression+nameExpression = labeled "Name" $ withPosition do+  n <- NameExpression <$> withName+  try . notFollowedBy $ withTag ColonToken+  return n++parensExpression :: Parser Expression+parensExpression = do+  withTag OpenParenToken+  expression' <- expression+  withTag CloseParenToken+  return expression'++contextExpression :: Parser Expression+contextExpression =+  (braced <?> "BracedContext")+    <|> (unbraced <?> "UnbracedContext")+  where+    braced = withPosition do+      withTag OpenBraceToken+      pairs <- contextKeyValue `sepEndBy` comma+      withTag CloseBraceToken+      return $ ContextExpression pairs+    unbraced = withPosition do+      pairs <- contextKeyValue `sepBy1` comma+      return $ ContextExpression pairs++contextKeyValue :: Parser (String, Expression)+contextKeyValue = labeled "ContextLiteralPair" do+  key <- withName+  withTag ColonToken+  value <- expression+  return (key, value)++listExpression :: Parser Expression+listExpression = labeled "ListLiteral" do+  withPosition do+    withTag OpenBracketToken+    values <- expression `sepEndBy` comma+    withTag CloseBracketToken+    return $ ListExpression values++comma :: Parser ()+comma =+  labeled "Comma" $+    withTag CommaToken++closeBlock :: Parser ()+closeBlock =+  labeled "CloseBlock" $+    withTag CloseBlockToken++withToken :: (Token -> Maybe a) -> Parser a+withToken = P.token show getTokenPos++withTag :: TokenTag -> Parser ()+withTag tag = P.token show getTokenPos f+  where+    f = \case+      TaggedToken t _ | t == tag -> Just ()+      _ -> Nothing++withName :: Parser String+withName = withToken \case+  NameToken n _ -> Just n+  _ -> Nothing
+ src/Hakyllbars/Source/Util.hs view
@@ -0,0 +1,79 @@+module Hakyllbars.Source.Util where++import Control.Monad.Identity+import Data.Default+import Text.Parsec hiding (label, runParser, token, (<?>))+import qualified Text.Parsec as P++data ParserState = ParserState+  { parserStateLexerMode :: LexerMode,+    parserStateIsDebugging :: Bool+  }++instance Default ParserState where+  def =+    ParserState+      { parserStateLexerMode = TextMode,+        parserStateIsDebugging = False+      }++data LexerMode+  = TextMode+  | BlockMode+  | FencedMode Int+  deriving (Show)++runParser :: (Stream s Identity t) => Parsec s ParserState a -> SourceName -> s -> Either ParseError a+runParser = runParserWith state+  where+    state = def++debugRunParser :: (Stream s Identity t) => Parsec s ParserState a -> SourceName -> s -> Either ParseError a+debugRunParser = runParserWith state+  where+    state = def {parserStateIsDebugging = True}++runParserWith :: (Stream s Identity t) => ParserState -> Parsec s ParserState a -> SourceName -> s -> Either ParseError a+runParserWith state p = P.runParser p state++labeled :: (Show t, Stream s m t) => String -> ParsecT s ParserState m a -> ParsecT s ParserState m a+labeled = flip (<?>)++(<?>) :: (Show t, Stream s m t) => ParsecT s ParserState m a -> String -> ParsecT s ParserState m a+p <?> label = traced label (p P.<?> label)++infix 0 <?>++whenDebugging :: (Stream s m t) => ParsecT s ParserState m () -> ParsecT s ParserState m ()+whenDebugging p = do+  isDebugging <- getIsDebugging+  when isDebugging p++trace :: (Show t, Stream s m t) => String -> ParsecT s ParserState m ()+trace label = whenDebugging $ parserTrace label++traced :: (Show t, Stream s m t) => String -> ParsecT s ParserState m a -> ParsecT s ParserState m a+traced label p =+  getIsDebugging >>= \case+    True -> parserTraced label p+    False -> p++tryOne :: (Stream s m t) => [ParsecT s u m a] -> ParsecT s u m a+tryOne = choice . fmap try++withPosition :: (Stream s m t) => ParsecT s u m (SourcePos -> a) -> ParsecT s u m a+withPosition p = do+  pos <- getPosition+  f <- p+  return $ f pos++getIsDebugging :: (Monad m) => ParsecT s ParserState m Bool+getIsDebugging = parserStateIsDebugging <$> getState++getLexerMode :: (Monad m) => ParsecT s ParserState m LexerMode+getLexerMode = parserStateLexerMode <$> getState++putLexerMode :: (Monad m) => LexerMode -> ParsecT s ParserState m ()+putLexerMode mode = do+  state <- getState+  putState state {parserStateLexerMode = mode}
+ src/Hakyllbars/Template.hs view
@@ -0,0 +1,48 @@+module Hakyllbars.Template+  ( applyTemplates,+    applyContent,+    applyContentWith,+    fileTemplate,+    applyCompiler,+    applyContext,+    applyTemplate,+    applyAsTemplate,+  )+where++import Control.Monad.State.Strict (evalStateT)+import Hakyll (defaultHakyllReaderOptions, defaultHakyllWriterOptions)+import Hakyllbars.Common+import Hakyllbars.Compiler (applyAsTemplate, applyTemplate)+import Hakyllbars.Context+import Hakyllbars.Pandoc (pandocCompilerWith)+import Text.Pandoc (ReaderOptions, WriterOptions)++applyTemplates :: TemplateRunner a () -> Item a -> Compiler (Item a)+applyTemplates templates item =+  evalStateT (templates >> tplItem) $+    TemplateState+      { tplContextStack = [],+        tplItemStack = [item],+        tplCallStack = ["item " ++ itemFilePath item]+      }++applyContent :: TemplateRunner String ()+applyContent = applyContentWith defaultHakyllReaderOptions defaultHakyllWriterOptions++applyContentWith :: ReaderOptions -> WriterOptions -> TemplateRunner String ()+applyContentWith readerOpts writerOpts = do+  applyAsTemplate+  tplModifyItem $ lift . pandocCompilerWith readerOpts writerOpts++fileTemplate :: FilePath -> TemplateRunner String ()+fileTemplate filePath =+  applyTemplate (fromFilePath filePath)++applyCompiler :: (Item a -> Compiler (Item a)) -> TemplateRunner a ()+applyCompiler compiler =+  tplModifyItem $ lift . compiler++applyContext :: Context a -> TemplateRunner a ()+applyContext = tplPushContext+{-# INLINE applyContext #-}
+ src/Hakyllbars/Util.hs view
@@ -0,0 +1,111 @@+module Hakyllbars.Util where++import Control.Applicative (Alternative, empty)+import Data.Char+import Data.String.Utils as S+import Hakyllbars.Common++dropIndex :: FilePath -> FilePath+dropIndex url = case splitFileName url of+  (p, "index.html") -> takeDirectory p+  _ -> url++stripSuffix :: String -> String -> String+stripSuffix suffix text =+  if drop prefixLength text == suffix+    then prefix+    else text+  where+    prefixLength = length text - length suffix+    prefix = take prefixLength text++splitAndStrip ::+  -- | The delimiter to split the input string on.+  String ->+  -- | The string to split.+  String ->+  -- | The list of strings split from the input.+  [String]+splitAndStrip d = fmap S.strip . S.split d++sequenceRules :: [Rules ()] -> Rules ()+sequenceRules = sequenceA_++splitWordsBy :: (Char -> Bool) -> String -> [String]+splitWordsBy _ [] = []+splitWordsBy f xs = takeWhile (not . f) xs : splitWordsBy f (dropWhile f xs)++splitWordsByHumps :: String -> [String]+splitWordsByHumps "" = []+splitWordsByHumps xss@(x : _)+  | isUpper x =+      let prefix = takeWhile isUpper xss+          rest = dropWhile isUpper xss+       in if null rest+            then [prefix]+            else+              let currentLength = length prefix - 1+                  currentWord = take currentLength prefix+                  restWords = splitWordsByHumps rest+                  nextWord = drop currentLength prefix ++ concat (take 1 restWords)+               in [y | y <- [currentWord, nextWord], not (null y)] ++ drop 1 restWords+  | otherwise =+      let currentWord = takeWhile (not . isUpper) xss+          rest = dropWhile (not . isUpper) xss+       in currentWord : splitWordsByHumps rest++kebabToWords :: String -> [String]+kebabToWords = splitWordsBy (== '-')++wordsToKebab :: [String] -> String+wordsToKebab = intercalate "-"++camelToWords :: String -> [String]+camelToWords = splitWordsByHumps++wordsToCamel :: [String] -> String+wordsToCamel [] = []+wordsToCamel wss = go $ fmap toLower <$> wss+  where+    go [] = []+    go (w : ws) = w ++ firstToUpper ws+    firstToUpper = concatMap \case+      (w : ws) -> toUpper w : ws+      [] -> []++snakeToWords :: String -> [String]+snakeToWords = splitWordsBy (== '_')++wordsToSnake :: [String] -> String+wordsToSnake = intercalate "_"++camelToKebab :: String -> String+camelToKebab = wordsToKebab . camelToWords++kebabToCamel :: String -> String+kebabToCamel = wordsToCamel . kebabToWords++snakeToCamel :: String -> String+snakeToCamel = wordsToCamel . snakeToWords++kebabToSnake :: String -> String+kebabToSnake = wordsToSnake . kebabToWords++snakeToKebab :: String -> String+snakeToKebab = wordsToKebab . snakeToWords++firstAlt :: (Foldable m, Alternative n) => m (n a) -> n a+firstAlt = foldl (<|>) empty++uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d+uncurry3 f (x, y, z) = f x y z++curry3 :: ((a, b, c) -> d) -> a -> b -> c -> d+curry3 f x y z = f (x, y, z)++maybeHead :: [a] -> Maybe a+maybeHead (x : _) = Just x+maybeHead _ = Nothing++commas :: [String] -> String+commas xs = "[" ++ intercalate ", " xs ++ "]"
+ test/Hakyllbars/AstStructure.hs view
@@ -0,0 +1,133 @@+module Hakyllbars.AstStructure where++import Data.Bifunctor+import qualified Data.List.NonEmpty as NEL+import Hakyllbars.Ast+import Hakyllbars.Source.Lexer++-- | Converts type @a@ into a type @b@ which is _structurally_ equivalent to+-- type @a@.+--+-- Specifically this class is used to convert from the concrete AST emitted by+-- parsers into an AST omitting meta and source information so that asserting+-- equivalence in tests against structure is much easier.+class AstStructure a b where+  intoAstStructure :: a -> b++instance (Functor f, AstStructure a b) => AstStructure (f a) (f b) where+  intoAstStructure = fmap intoAstStructure++newtype Template' = Template' [Block']+  deriving (Eq, Show)++instance AstStructure Template Template' where+  intoAstStructure (Template blocks' _) = Template' (intoAstStructure blocks')++data ApplyBlock' = ApplyBlock' Expression' [Block']+  deriving (Eq, Show)++instance AstStructure ApplyBlock ApplyBlock' where+  intoAstStructure (ApplyBlock e bs _) = ApplyBlock' (intoAstStructure e) (intoAstStructure <$> bs)++data DefaultBlock' = DefaultBlock' [Block']+  deriving (Eq, Show)++instance AstStructure DefaultBlock DefaultBlock' where+  intoAstStructure (DefaultBlock bs _) = DefaultBlock' (intoAstStructure <$> bs)++data Block'+  = TextBlock' String+  | ExpressionBlock' Expression'+  | CommentBlock' String+  | ChromeBlock' Expression' [Block']+  | AltBlock' [ApplyBlock'] (Maybe DefaultBlock')+  deriving (Eq, Show)++instance AstStructure Block Block' where+  intoAstStructure = \case+    TextBlock t _ -> TextBlock' t+    ExpressionBlock e _ -> ExpressionBlock' (intoAstStructure e)+    CommentBlock t _ -> CommentBlock' t+    ChromeBlock e bs _ -> ChromeBlock' (intoAstStructure e) (intoAstStructure <$> bs)+    AltBlock alts def _ -> AltBlock' (NEL.toList $ intoAstStructure <$> alts) (intoAstStructure <$> def)++data Expression'+  = NameExpression' String+  | StringExpression' String+  | IntExpression' Int+  | DoubleExpression' Double+  | BoolExpression' Bool+  | ApplyExpression' Expression' Expression'+  | AccessExpression' Expression' Expression'+  | FilterExpression' Expression' Expression'+  | ContextExpression' [(String, Expression')]+  | ListExpression' [Expression']+  deriving (Eq, Show)++instance AstStructure Expression Expression' where+  intoAstStructure = \case+    NameExpression x _ -> NameExpression' x+    StringExpression x _ -> StringExpression' x+    IntExpression x _ -> IntExpression' x+    DoubleExpression x _ -> DoubleExpression' x+    BoolExpression x _ -> BoolExpression' x+    ApplyExpression f x _ -> ApplyExpression' (intoAstStructure f) (intoAstStructure x)+    AccessExpression t f _ -> AccessExpression' (intoAstStructure t) (intoAstStructure f)+    FilterExpression x f _ -> FilterExpression' (intoAstStructure x) (intoAstStructure f)+    ContextExpression xs _ -> ContextExpression' (second intoAstStructure <$> xs)+    ListExpression xs _ -> ListExpression' (intoAstStructure <$> xs)++data Token'+  = ExpressionBlockToken'+  | CommentBlockToken'+  | AltBlockToken'+  | ChromeBlockToken'+  | CloseBlockToken'+  | OpenParenToken'+  | CloseParenToken'+  | OpenBracketToken'+  | CloseBracketToken'+  | OpenBraceToken'+  | CloseBraceToken'+  | PipeToken'+  | CommaToken'+  | DotToken'+  | ColonToken'+  | EndToken'+  | ElseToken'+  | TurnOffToken'+  | BoolToken' Bool+  | NameToken' String+  | StringToken' String+  | IntToken' Int+  | DoubleToken' Double+  | TextToken' String+  deriving (Eq, Show)++instance AstStructure Token Token' where+  intoAstStructure = \case+    TaggedToken t _ -> case t of+      ExpressionBlockToken -> ExpressionBlockToken'+      CommentBlockToken -> CommentBlockToken'+      AltBlockToken -> AltBlockToken'+      ChromeBlockToken -> ChromeBlockToken'+      CloseBlockToken -> CloseBlockToken'+      OpenParenToken -> OpenParenToken'+      CloseParenToken -> CloseParenToken'+      OpenBracketToken -> OpenBracketToken'+      CloseBracketToken -> CloseBracketToken'+      OpenBraceToken -> OpenBraceToken'+      CloseBraceToken -> CloseBraceToken'+      PipeToken -> PipeToken'+      CommaToken -> CommaToken'+      DotToken -> DotToken'+      ColonToken -> ColonToken'+      EndToken -> EndToken'+      ElseToken -> ElseToken'+      TurnOffToken -> TurnOffToken'+    BoolToken b _ -> BoolToken' b+    NameToken n _ -> NameToken' n+    StringToken s _ -> StringToken' s+    IntToken n _ -> IntToken' n+    DoubleToken d _ -> DoubleToken' d+    TextToken t _ -> TextToken' t
+ test/Hakyllbars/Source/LexerSpec.hs view
@@ -0,0 +1,176 @@+module Hakyllbars.Source.LexerSpec where++import Hakyllbars.AstStructure+import Hakyllbars.Source.Lexer+import Hakyllbars.Source.TestSupport+import Hakyllbars.TestSupport+import Prelude hiding (lex)++spec :: Spec+spec = do+  withParser lex do+    context "expression mode" do+      "{{a b c d"+        `produces` [ ExpressionBlockToken',+                     NameToken' "a",+                     NameToken' "b",+                     NameToken' "c",+                     NameToken' "d"+                   ]+      "{{1 2 3 4"+        `produces` [ ExpressionBlockToken',+                     IntToken' 1,+                     IntToken' 2,+                     IntToken' 3,+                     IntToken' 4+                   ]+      "{{a 1 b 2"+        `produces` [ ExpressionBlockToken',+                     NameToken' "a",+                     IntToken' 1,+                     NameToken' "b",+                     IntToken' 2+                   ]+      "{{1.1 2.2 3.3 4.4"+        `produces` [ ExpressionBlockToken',+                     DoubleToken' 1.1,+                     DoubleToken' 2.2,+                     DoubleToken' 3.3,+                     DoubleToken' 4.4+                   ]++      context "invalid numbers" do+        "{{1.a 2.2" `rejectsWith` "\"test\" (line 1, column 5):\nunexpected \"a\"\nexpecting digit"+        "{{1a 2.2" `rejectsWith` "\"test\" (line 1, column 5):\nunexpected 'a'"++      context "keywords and word literals" do+        "{{true else false end"+          `produces` [ ExpressionBlockToken',+                       BoolToken' True,+                       ElseToken',+                       BoolToken' False,+                       EndToken'+                     ]++      context "string literals" do+        "{{\"abcd\""+          `produces` [ExpressionBlockToken', StringToken' "abcd"]+        "{{\"\\\"abcd\""+          `produces` [ExpressionBlockToken', StringToken' "\"abcd"]+        "{{\"a\\'b\\nc\\td\\\\\""+          `produces` [ExpressionBlockToken', StringToken' "a\'b\nc\td\\"]+        "{{\"this string}} has these {{\""+          `produces` [ExpressionBlockToken', StringToken' "this string}} has these {{"]+        "{{'abcd'"+          `produces` [ExpressionBlockToken', StringToken' "abcd"]+        "{{'\\\"abcd'"+          `produces` [ExpressionBlockToken', StringToken' "\"abcd"]+        "{{'a\\\"b\\nc\\td\\\\\\\''"+          `produces` [ExpressionBlockToken', StringToken' "a\"b\nc\td\\'"]+        "{{'this string}} has these {{'"+          `produces` [ExpressionBlockToken', StringToken' "this string}} has these {{"]++    context "text" do+      "\\{{*" `produces` [TextToken' "{{*"]+      "\\{{!" `produces` [TextToken' "{{!"]+      "\\}}" `produces` [TextToken' "}}"]+      "\\{{" `produces` [TextToken' "{{"]+      "{a" `produces` [TextToken' "{a"]+      "}a" `produces` [TextToken' "}a"]+      "\\a" `produces` [TextToken' "\\a"]+      "\\\\" `produces` [TextToken' "\\"]++      "this contains a \\}} literal"+        `produces` [TextToken' "this contains a }} literal"]++    context "comment blocks" do+      "{{! this is a comment }}"+        `produces` [ CommentBlockToken',+                      TextToken' " this is a comment ",+                      CloseBlockToken'+                    ]++      "{{! this {{is {{! a}} nested}} comment }}"+        `produces` [ CommentBlockToken',+                      TextToken' " this {{is {{! a}} nested}} comment ",+                      CloseBlockToken'+                    ]+      "{{! this has an \\}} in it }}"+        `produces` [ CommentBlockToken',+                      TextToken' " this has an }} in it ",+                      CloseBlockToken'+                    ]++    context "mixing blocks" do+      "{{expression}} and some text"+        `produces` [ ExpressionBlockToken',+                      NameToken' "expression",+                      CloseBlockToken',+                      TextToken' " and some text"+                    ]+      "this {{expression}} and some text"+        `produces` [ TextToken' "this ",+                      ExpressionBlockToken',+                      NameToken' "expression",+                      CloseBlockToken',+                      TextToken' " and some text"+                    ]+      "here: {{! a comment {{with nesting}} }} followed by {{an | expression}}"+        `produces` [ TextToken' "here: ",+                      CommentBlockToken',+                      TextToken' " a comment {{with nesting}} ",+                      CloseBlockToken',+                      TextToken' " followed by ",+                      ExpressionBlockToken',+                      NameToken' "an",+                      PipeToken',+                      NameToken' "expression",+                      CloseBlockToken'+                    ]++    context "whitespace-trimmed blocks" do+      context "end-trimming block" do+        "{{expression-}}\n     some spaces"+          `produces` [ ExpressionBlockToken',+                        NameToken' "expression",+                        CloseBlockToken',+                        TextToken' "some spaces"+                      ]+      context "start-trimming block" do+        "some spaces\n   {{-expression}}"+          `produces` [ TextToken' "some spaces",+                        ExpressionBlockToken',+                        NameToken' "expression",+                        CloseBlockToken'+                      ]++    context "turning off blocks" do+      context "expression block" do+        "{{*{{expression}}}}"+          `produces` [ TurnOffToken',+                        TextToken' "{{expression}}",+                        CloseBlockToken'+                     ]+      context "trimming" do+        intercalate "\n" [ "{{*",+                            "{{#if layout-}}",+                            "  {{@applyLayout layout-}}",+                            "  {{body-}}",+                            "{{#else-}}",+                            "  {{body-}}",+                            "{{#end-}}",+                            "}}"+                          ]+          `produces` [ TurnOffToken',+                        TextToken' (intercalate "\n" [+                          "",+                          "{{#if layout-}}",+                          "  {{@applyLayout layout-}}",+                          "  {{body-}}",+                          "{{#else-}}",+                          "  {{body-}}",+                          "{{#end-}}",+                          ""+                        ]),+                        CloseBlockToken'+                    ]
+ test/Hakyllbars/Source/ParserSpec.hs view
@@ -0,0 +1,207 @@+module Hakyllbars.Source.ParserSpec where++import Hakyllbars.AstStructure+import Hakyllbars.Source.TestSupport+import Hakyllbars.Source+import Hakyllbars.TestSupport++spec :: Spec+spec = do+  withParser parse do+    context "expression blocks" do+      "{{a | b}}{{c d}}"+        `produces` Template'+          [ ExpressionBlock'+              ( FilterExpression'+                  (NameExpression' "a")+                  (NameExpression' "b")+              ),+            ExpressionBlock'+              ( ApplyExpression'+                  (NameExpression' "c")+                  (NameExpression' "d")+              )+          ]+      "{{thing | with { this: a, that: b } }}"+        `produces` Template'+          [ ExpressionBlock'+              ( FilterExpression'+                  (NameExpression' "thing")+                  ( ApplyExpression'+                      (NameExpression' "with")+                      ( ContextExpression'+                          [ ("this", NameExpression' "a"),+                            ("that", NameExpression' "b")+                          ]+                      )+                  )+              )+          ]+      "{{thing | with this: a, that: b}}"+        `produces` Template'+          [ ExpressionBlock'+              ( FilterExpression'+                  (NameExpression' "thing")+                  ( ApplyExpression'+                      (NameExpression' "with")+                      ( ContextExpression'+                          [ ("this", NameExpression' "a"),+                            ("that", NameExpression' "b")+                          ]+                      )+                  )+              )+          ]+      "{{(a (b | c))}}"+        `produces` Template'+          [ ExpressionBlock'+              ( ApplyExpression'+                  (NameExpression' "a")+                  ( FilterExpression'+                      (NameExpression' "b")+                      (NameExpression' "c")+                  )+              )+          ]+      "{{[1, 2, 3]}}"+        `produces` Template'+          [ ExpressionBlock'+              ( ListExpression'+                  [ IntExpression' 1,+                    IntExpression' 2,+                    IntExpression' 3+                  ]+              )+          ]+      "{{[]}}"+        `produces` Template' [ExpressionBlock' (ListExpression' [])]++    context "comment blocks" do+      "{{! this is a comment }}"+        `produces` Template' [CommentBlock' " this is a comment "]++    context "alt blocks" do+      "{{#if (this thing)}} text {{#end}}"+        `produces` Template'+          [ AltBlock'+              [ ApplyBlock'+                  ( ApplyExpression'+                      (NameExpression' "if")+                      ( ApplyExpression'+                          (NameExpression' "this")+                          (NameExpression' "thing")+                      )+                  )+                  [TextBlock' " text "]+              ]+              Nothing+          ]++      unlines+        [ "{{#if (that thing)}}",+          "text",+          "{{#end}}"+        ]+        `produces` Template'+          [ AltBlock'+              [ ApplyBlock'+                  ( ApplyExpression'+                      (NameExpression' "if")+                      ( ApplyExpression'+                          (NameExpression' "that")+                          (NameExpression' "thing")+                      )+                  )+                  [TextBlock' "\ntext\n"]+              ]+              Nothing,+            TextBlock' "\n"+          ]++      unlines+        [ "{{#if this}}",+          "that",+          "{{#else then}}",+          "the other",+          "{{#end}}"+        ]+        `produces` Template'+          [ AltBlock'+              [ ApplyBlock'+                  ( ApplyExpression'+                      (NameExpression' "if")+                      (NameExpression' "this")+                  )+                  [TextBlock' "\nthat\n"],+                ApplyBlock'+                  (NameExpression' "then")+                  [TextBlock' "\nthe other\n"]+              ]+              Nothing,+            TextBlock' "\n"+          ]++      unlines+        [ "{{#if this}}",+          "that",+          "{{#else}}",+          "the other",+          "{{#end}}"+        ]+        `produces` Template'+          [ AltBlock'+              [ ApplyBlock'+                  ( ApplyExpression'+                      (NameExpression' "if")+                      (NameExpression' "this")+                  )+                  [TextBlock' "\nthat\n"]+              ]+              (Just $ DefaultBlock' [TextBlock' "\nthe other\n"]),+            TextBlock' "\n"+          ]++      unlines+        [ "{{#if (this thing)}}",+          "then show this thing",+          "{{#else some condition}}",+          "then show this other thing",+          "{{#else}}",+          "otherwise show this thing",+          "{{#end}}"+        ]+        `produces` Template'+          [ AltBlock'+              [ ApplyBlock'+                  ( ApplyExpression'+                      (NameExpression' "if")+                      ( ApplyExpression'+                          (NameExpression' "this")+                          (NameExpression' "thing")+                      )+                  )+                  [TextBlock' "\nthen show this thing\n"],+                ApplyBlock'+                  ( ApplyExpression'+                      (NameExpression' "some")+                      (NameExpression' "condition")+                  )+                  [TextBlock' "\nthen show this other thing\n"]+              ]+              ( Just $+                  DefaultBlock'+                    [TextBlock' "\notherwise show this thing\n"]+              ),+            TextBlock' "\n"+          ]++    context "off blocks" do+      unlines+        [ "{{*",+          "{{this}} is",+          "{{!verbatim}}",+          "and {{@bananana}}",+          "-}}"+        ]+        `produces` Template'+          [TextBlock' "\n{{this}} is\n{{!verbatim}}\nand {{@bananana}}\n"]
+ test/Hakyllbars/Source/TestSupport.hs view
@@ -0,0 +1,27 @@+module Hakyllbars.Source.TestSupport where++import Control.Exception+import Data.Bifunctor+import Hakyllbars.AstStructure+import Test.Hspec+import Text.Parsec hiding (runParser, runParserT, token, tokens)++type Parse s a = s -> Either ParseError a++withParser :: (String -> Parse s a) -> SpecWith (Parse s a) -> Spec+withParser parser =+  around (bracket (return (parser "test")) (const (return ())))++produces :: (Show s, Eq b, Show b, AstStructure a b) => s -> b -> SpecWith (Parse s a)+produces input expected =+  describe (show input) do+    it ("produces " ++ show expected) \p -> do+      second intoAstStructure (p input) `shouldBe` Right expected++rejectsWith :: (Show s, Eq a, Show a) => s -> String -> SpecWith (Parse s a)+rejectsWith input expected =+  describe (show input) do+    it ("rejects tokens with " ++ show expected) \p -> do+      first show (p input) `shouldBe` Left expected++infixr 0 `produces`, `rejectsWith`
+ test/Hakyllbars/TestSupport.hs view
@@ -0,0 +1,16 @@+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
+ test/Hakyllbars/TestSupport/Compiler.hs view
@@ -0,0 +1,46 @@+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
+ test/Hakyllbars/TestSupport/Config.hs view
@@ -0,0 +1,12 @@+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"+    }
+ test/Hakyllbars/TestSupport/Resource.hs view
@@ -0,0 +1,16 @@+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)
+ test/Hakyllbars/TestSupport/TestEnv.hs view
@@ -0,0 +1,66 @@+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"
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}