+
+
-
-
+
+
-
+
-
+
diff --git a/data/example/templates/post.html b/data/example/templates/post.html
--- a/data/example/templates/post.html
+++ b/data/example/templates/post.html
@@ -1,8 +1,11 @@
-
- Posted on $date$
- $if(author)$
- by $author$
- $endif$
-
-
-$body$
+Hello World
" :: String) +-} +constRoute :: FilePath -> Routes +constRoute = customRoute . const + + +-------------------------------------------------------------------------------- +{- | Create a "substituting" route that searches for substrings (in the +underlying identifier) that match the given pattern and transforms them +according to the given replacement function. +The identifier here is that of the underlying item being processed and is +interpreted as an destination filepath. It's normally the filepath of the +source file being processed. +See 'Hakyll.Core.Identifier.Identifier' for details. + +Hint: The name "gsub" comes from a similar function in +[R](https://www.r-project.org) and can be read as "globally substituting" +(globally in the Unix sense of repeated, not just once). + +=== __Examples__ +__Route that replaces part of the filepath__ + +> -- e.g. file on disk: 'Hello World
" :: String) +Note how you can use 'Hakyll.Core.Compiler.makeItem' to create content inline +(to be processed as a 'Hakyll.Core.Compiler.Compiler' value) as if that content +was loaded from a file (as it's the case when using 'match'). +To control where the compilation result will be written out, use routing +functions like 'Hakyll.Core.Routes.idRoute'. +-} +create :: [Identifier] -- ^ Identifiers to assign to created content in next argument + -> Rules () -- ^ Remaining processing parts that must create content + -> Rules () -- ^ Resulting rule +create ids rules = do + flush + -- TODO Maybe check if the resources exist and call tellResources on that + Rules $ local setMatches $ unRules $ rules >> flush + where + setMatches env = env {rulesMatches = ids} + + +-------------------------------------------------------------------------------- +{- | Add the given version name to the implicit identifier(s) under which the +compilation result of the given remaining 'Rules' value is saved to the +'Hakyll.Core.Store.Store'. +See 'Hakyll.Core.Identifier.Identifier' for details. + +Use this wrapper function for example when you need to compile the same source +file into two or more different results, each with a different version name. +The version is needed to distinguish between these different compilation results +in the store, otherwise they would get the same conflicting identifier in the +store. + +Warning: +__If you add a version name with this function, you need to supply the same name__ +when you 'Hakyll.Core.Compiler.load' the content from the store from +within another rule. + +=== __Examples__ +__Compile source file into differently versioned outputs and load both__ + +> -- e.g. file on disk: 'posts/hakyll.md' +> +> -- saved with implicit identifier ('posts/hakyll.md', no-version) +> match "posts/*" $ do +> route $ setExtension "html" +> compile pandocCompiler +> +> -- saved with implicit identifier ('posts/hakyll.md', version 'raw') +> match "posts/*" $ version "raw" $ do +> route idRoute +> compile getResourceBody +> +> -- use compilation results from rules above +> create ["index.html"] $ do +> route idRoute +> compile $ do +> -- load no-version version +> compiledPost <- load (fromFilePath "posts/hakyll.md") +> -- load version 'raw' +> rawPost <- load . setVersion (Just "raw") $ fromFilePath "posts/hakyll.md" +> ... +Note how a version name is needed to distinguish the unversioned and the "raw" +version when loading the Hakyll post for the @index.html@ page. +To control where the compilation result will be written out, use routing +functions like 'Hakyll.Core.Routes.idRoute' and 'Hakyll.Core.Routes.setExtension'. +-} +version :: String -- ^ Version name to add + -> Rules () -- ^ Remaining processing parts + -> Rules () -- ^ Result +version v rules = do + flush + Rules $ local setVersion' $ unRules $ rules >> flush + where + setVersion' env = env {rulesVersion = Just v} + + +-------------------------------------------------------------------------------- +{- | Add (or replace) the given compilation steps within the given +'Hakyll.Core.Compiler.Compiler' value to the current 'Rules' value. +__This functions controls HOW the content within a rule is processed__ (use one +of the 'match' functions to control WHAT content is processed). + +The compilation result is saved to the 'Hakyll.Core.Store.Store' under an +implicit identifier. +See 'Hakyll.Core.Identifier.Identifier' for details. + +If there's routing attached to the rule where this function is used, the +compilation result is also written out to a file according to that route. +See 'route' and 'Hakyll.Core.Routes.Routes' for details. + +=== __Examples__ +__Compile Markdown to HTML__ + +> -- Select all Markdown files in 'posts' directory +> match "posts/**.md" $ do +> +> route $ setExtension "html" +> +> -- use pandoc to transform Markdown to HTML in a single step +> compile pandocCompiler +Note how we set the content to be processed with +'Hakyll.Web.Pandoc.pandocCompiler'. The content comes implicitly from the +matched Markdown files on disk. We don't have to pass that content around +manually. Every file is processed the same way within this one rule. + +To control where the compilation result will be written out, use routing +functions like 'Hakyll.Core.Routes.setExtension'. +Here the compilation result of a file like @posts\/hakyll.md@ is written out +to @posts\/hakyll.html@. + +__Compile Markdown to HTML and embed it in a template__ + +> -- Select all Markdown files in 'posts' directory +> match "posts/**.md" $ do +> route $ setExtension "html" +> compile $ +> pandocCompiler >>= +> loadAndApplyTemplate "templates/post.html" defaultContext +> +> -- To Hakyll templates are just plain files that have to be processed +> -- and placed into the store like any other file (but without routing). +> -- e.g. file on disk: 'templates/post.html' +> match "templates/*" $ compile templateBodyCompiler +Note how a Markdown post that is compiled to HTML using +'Hakyll.Web.Pandoc.pandocCompiler' in a first step and then embedded into +a HTMl 'Hakyll.Web.Template.Template' in a second step by using +'Hakyll.Web.Template.loadAndApplyTemplate'. +We can use templates to control the design and layout of a webpage. +A template may look as follows: + +>$title$
+> $body$ +See "Hakyll.Web.Template" to see examples of the templating syntax. +-} +compile :: (Binary a, Typeable a, Writable a) => Compiler (Item a) -- ^ How to transform content + -> Rules () -- ^ Result +compile compiler = Rules $ modify $ \s -> + s {rulesCompiler = Just (fmap SomeItem compiler)} + + +-------------------------------------------------------------------------------- +{- | Add (or replace) routing in the current 'Rules' value. +__This functions controls IF and WHERE the compiled results are written out__ +(use one of the 'match' functions to control WHAT content is processed and +'compile' to control HOW). +See 'Hakyll.Core.Routes.Routes' and 'Hakyll.Core.Identifier.Identifier' for +details on how output filepaths are computed. + +Hint: +__If there's no route attached to a rule, the compilation result is not written out__. +However, the compilation result is saved to the 'Hakyll.Core.Store.Store' +and can be loaded and used within another rule. This behavior is needed, +for example, for templates. + +=== __Examples__ +__Rules with and without routing__ + +> -- e.g. file on disk: 'templates/post.html' +> +> -- Rule 1 (without routing) +> match "templates/*" $ do +> -- compilation result saved to store with implicit identifier, e.g. 'templates/post.html' +> compile templateCompiler +> +> -- Rule 2 (with routing) +> match "posts/**.md" $ do +> route $ setExtension "html" +> compile $ do +> -- load compiled result of other rule with explicit identifier. +> postTemplate <- loadBody "templates/post.html" +> pandocCompiler >>= applyTemplate postTemplate defaultContext +Note that we don't set a route in the first rule to avoid writing out our +compiled templates. +However, we can still 'Hakyll.Core.Compiler.load' (or +'Hakyll.Core.Compiler.loadBody') the compiled templates to apply them in a +second rule. +The content for 'Hakyll.Web.Template.templateCompiler' comes implicitly from the +matched template files on disk. We don't have to pass that content around +manually. See 'match' and 'compile' for details. + +To control where a compilation result will be written out (as done in the second +rule), use routing functions like 'Hakyll.Core.Routes.setExtension'. + +See "Hakyll.Web.Template" for examples of templates and the templating syntax. +-} +route :: Routes -- ^ Where to output compilation results + -> Rules () -- ^ Result +route route' = Rules $ modify $ \s -> s {rulesRoute = Just route'} + + +-------------------------------------------------------------------------------- +-- | Execute an 'IO' action immediately while the rules are being evaluated. +-- This should be avoided if possible, but occasionally comes in useful. +preprocess :: IO a -> Rules a +preprocess = Rules . liftIO + + +-------------------------------------------------------------------------------- +-- | Advanced usage: add extra dependencies to compilers. Basically this is +-- needed when you're doing unsafe tricky stuff in the rules monad, but you +-- still want correct builds. +-- +-- A useful utility for this purpose is 'makePatternDependency'. +rulesExtraDependencies :: [Dependency] -> Rules a -> Rules a +rulesExtraDependencies deps rules = + -- Note that we add the dependencies seemingly twice here. However, this is + -- done so that 'rulesExtraDependencies' works both if we have something + -- like: + -- + -- > match "*.css" $ rulesExtraDependencies [foo] $ ... + -- + -- and something like: + -- + -- > rulesExtraDependencies [foo] $ match "*.css" $ ... + -- + -- (1) takes care of the latter and (2) of the former. + Rules $ censor fixRuleSet $ do + x <- unRules rules + fixCompiler + return x + where + -- (1) Adds the dependencies to the compilers we are yet to create + fixCompiler = modify $ \s -> case rulesCompiler s of + Nothing -> s + Just c -> s + { rulesCompiler = Just $ compilerTellDependencies deps >> c + } + + -- (2) Adds the dependencies to the compilers that are already in the ruleset + fixRuleSet ruleSet = ruleSet + { rulesCompilers = + [ (i, compilerTellDependencies deps >> c) + | (i, c) <- rulesCompilers ruleSet + ] + } diff --git a/lib/Hakyll/Core/Rules/Internal.hs b/lib/Hakyll/Core/Rules/Internal.hs new file mode 100644 --- /dev/null +++ b/lib/Hakyll/Core/Rules/Internal.hs @@ -0,0 +1,116 @@ +-------------------------------------------------------------------------------- +{-# LANGUAGE CPP #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE Rank2Types #-} +module Hakyll.Core.Rules.Internal + ( RulesRead (..) + , RuleSet (..) + , RulesState (..) + , emptyRulesState + , Rules (..) + , runRules + ) where + + +-------------------------------------------------------------------------------- +#if !MIN_VERSION_base(4,13,0) +import Control.Monad.Fail (MonadFail) +#endif +import Control.Monad.Reader (ask) +import Control.Monad.RWS (RWST, runRWST) +import Control.Monad.Trans (liftIO) +import qualified Data.Map as M +import Data.Set (Set) + + +-------------------------------------------------------------------------------- +import Hakyll.Core.Compiler.Internal +import Hakyll.Core.Identifier +import Hakyll.Core.Identifier.Pattern +import Hakyll.Core.Item.SomeItem +import Hakyll.Core.Metadata +import Hakyll.Core.Provider +import Hakyll.Core.Routes + + +-------------------------------------------------------------------------------- +data RulesRead = RulesRead + { rulesProvider :: Provider + , rulesMatches :: [Identifier] + , rulesVersion :: Maybe String + } + + +-------------------------------------------------------------------------------- +data RuleSet = RuleSet + { -- | Accumulated routes + rulesRoutes :: Routes + , -- | Accumulated compilers + rulesCompilers :: [(Identifier, Compiler SomeItem)] + , -- | A set of the actually used files + rulesResources :: Set Identifier + , -- | A pattern we can use to check if a file *would* be used. This is + -- needed for the preview server. + rulesPattern :: Pattern + } + + +-------------------------------------------------------------------------------- +instance Semigroup RuleSet where + (<>) (RuleSet r1 c1 s1 p1) (RuleSet r2 c2 s2 p2) = + RuleSet (mappend r1 r2) (mappend c1 c2) (mappend s1 s2) (p1 .||. p2) + +instance Monoid RuleSet where + mempty = RuleSet mempty mempty mempty mempty + mappend = (<>) + + +-------------------------------------------------------------------------------- +data RulesState = RulesState + { rulesRoute :: Maybe Routes + , rulesCompiler :: Maybe (Compiler SomeItem) + } + + +-------------------------------------------------------------------------------- +emptyRulesState :: RulesState +emptyRulesState = RulesState Nothing Nothing + + +-------------------------------------------------------------------------------- +-- | The monad used to compose rules +newtype Rules a = Rules + { unRules :: RWST RulesRead RuleSet RulesState IO a + } deriving (Monad, MonadFail, Functor, Applicative) + + +-------------------------------------------------------------------------------- +instance MonadMetadata Rules where + getMetadata identifier = Rules $ do + provider <- rulesProvider <$> ask + liftIO $ resourceMetadata provider identifier + + getMatches pattern = Rules $ do + provider <- rulesProvider <$> ask + return $ filterMatches pattern $ resourceList provider + + +-------------------------------------------------------------------------------- +-- | Run a Rules monad, resulting in a 'RuleSet' +runRules :: Rules a -> Provider -> IO RuleSet +runRules rules provider = do + (_, _, ruleSet) <- runRWST (unRules rules) env emptyRulesState + + -- Ensure compiler uniqueness + let ruleSet' = ruleSet + { rulesCompilers = M.toList $ + M.fromListWith (flip const) (rulesCompilers ruleSet) + } + + return ruleSet' + where + env = RulesRead + { rulesProvider = provider + , rulesMatches = [] + , rulesVersion = Nothing + } diff --git a/lib/Hakyll/Core/Runtime.hs b/lib/Hakyll/Core/Runtime.hs new file mode 100644 --- /dev/null +++ b/lib/Hakyll/Core/Runtime.hs @@ -0,0 +1,539 @@ +-------------------------------------------------------------------------------- +{-# LANGUAGE CPP #-} +{-# LANGUAGE RecordWildCards #-} +module Hakyll.Core.Runtime + ( run + , RunMode(..) + ) where + + +-------------------------------------------------------------------------------- +import Control.Concurrent (forkIO, getNumCapabilities, + rtsSupportsBoundThreads) +import qualified Control.Concurrent.MVar as MVar +import Control.Exception (SomeException, try) +import Control.Monad (replicateM_, unless, void, when) +import Control.Monad.Reader (ReaderT, ask, runReaderT) +import Control.Monad.Trans (liftIO) +import Data.Foldable (for_, traverse_) +import qualified Data.Graph as Graph +import Data.IORef (IORef) +import qualified Data.IORef as IORef +import Data.List (intercalate) +#if !(MIN_VERSION_base(4,20,0)) +import Data.List (foldl') +#endif +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Maybe (fromMaybe) +import Data.Sequence (Seq) +import qualified Data.Sequence as Seq +import Data.Set (Set) +import qualified Data.Set as Set +import System.Exit (ExitCode (..)) +import System.FilePath (()) + + +-------------------------------------------------------------------------------- +import Hakyll.Core.Compiler.Internal +import Hakyll.Core.Compiler.Require +import Hakyll.Core.Configuration +import Hakyll.Core.Dependencies +import Hakyll.Core.Identifier +import Hakyll.Core.Item +import Hakyll.Core.Item.SomeItem +import Hakyll.Core.Logger (Logger) +import qualified Hakyll.Core.Logger as Logger +import Hakyll.Core.Provider +import Hakyll.Core.Routes +import Hakyll.Core.Rules.Internal +import Hakyll.Core.Store (Store) +import qualified Hakyll.Core.Store as Store +import Hakyll.Core.Util.File +import Hakyll.Core.Writable + + +factsKey :: [String] +factsKey = ["Hakyll.Core.Runtime.run", "facts"] + + +-------------------------------------------------------------------------------- +-- | Whether to execute a normal run (build the site) or a dry run. +data RunMode = RunModeNormal | RunModePrintOutOfDate + deriving (Show) + + +-------------------------------------------------------------------------------- +run :: RunMode -> Configuration -> Logger -> Rules a -> IO (ExitCode, RuleSet) +run mode config logger rules = do + -- Initialization + Logger.header logger "Initialising..." + Logger.message logger "Creating store..." + store <- Store.new (inMemoryCache config) $ storeDirectory config + Logger.message logger "Creating provider..." + (provider, modifiedMeta) <- newProvider store (shouldIgnoreFile config) $ + providerDirectory config + Logger.message logger "Running rules..." + ruleSet <- runRules rules provider + + -- Get old facts + mOldFacts <- Store.get store factsKey + let (oldFacts) = case mOldFacts of Store.Found f -> f + _ -> mempty + + -- Build runtime read/state + scheduler <- IORef.newIORef $ emptyScheduler {schedulerFacts = oldFacts} + let compilers = rulesCompilers ruleSet + read' = RuntimeRead + { runtimeConfiguration = config + , runtimeLogger = logger + , runtimeProvider = provider + , runtimeModifiedMeta = Set.fromList modifiedMeta + , runtimeStore = store + , runtimeRoutes = rulesRoutes ruleSet + , runtimeUniverse = Map.fromList compilers + , runtimeScheduler = scheduler + } + + -- Run the program and fetch the resulting state + runReaderT (build mode) read' + errors <- schedulerErrors <$> IORef.readIORef scheduler + if null errors then do + Logger.debug logger "Removing tmp directory..." + removeDirectory $ tmpDirectory config + + Logger.flush logger + return (ExitSuccess, ruleSet) + else do + for_ errors $ \(mbId, err) -> Logger.error logger $ case mbId of + Just identifier -> show identifier <> ": " <> err + Nothing -> err + Logger.flush logger + return (ExitFailure 1, ruleSet) + + +-------------------------------------------------------------------------------- +data RuntimeRead = RuntimeRead + { runtimeConfiguration :: Configuration + , runtimeLogger :: Logger + , runtimeProvider :: Provider + , runtimeModifiedMeta :: Set Identifier + , runtimeStore :: Store + , runtimeRoutes :: Routes + , runtimeUniverse :: Map Identifier (Compiler SomeItem) + , runtimeScheduler :: IORef Scheduler + } + + +-------------------------------------------------------------------------------- +-- | A Scheduler is a pure representation of work going on, works that needs +-- to be done, and work already done. Workers can obtain things to do +-- by interacting with the Scheduler, and execute them synchronously or +-- asynchronously. +-- +-- All operations on Scheduler look like 'Scheduler -> (Scheduler, a)' and +-- should be used with atomicModifyIORef'. +data Scheduler = Scheduler + { -- | Items to work on next. Identifiers may appear multiple times. + schedulerQueue :: !(Seq Identifier) + , -- | Items that we haven't started yet. + schedulerTodo :: !(Map Identifier (Compiler SomeItem)) + , -- | Currently processing + schedulerWorking :: !(Set Identifier) + , -- | Finished + schedulerDone :: !(Set Identifier) + , -- | Any snapshots stored. + schedulerSnapshots :: !(Set (Identifier, Snapshot)) + , -- | Any routed files and who wrote them. This is used to detect multiple + -- writes to the same file, which can yield inconsistent results. + schedulerRoutes :: !(Map FilePath Identifier) + , -- | Currently blocked compilers. + schedulerBlocked :: !(Set Identifier) + , -- | Compilers that may resume on triggers + schedulerTriggers :: !(Map Identifier (Set Identifier)) + , -- | Number of starved pops; tracking this allows us to start a new + -- number of threads again later. + schedulerStarved :: !Int + , -- | Dynamic dependency info. + schedulerFacts :: !DependencyFacts + , -- | Errors encountered. + schedulerErrors :: ![(Maybe Identifier, String)] + } + + +-------------------------------------------------------------------------------- +emptyScheduler :: Scheduler +emptyScheduler = Scheduler {..} + where + schedulerTodo = Map.empty + schedulerDone = Set.empty + schedulerQueue = Seq.empty + schedulerWorking = Set.empty + schedulerSnapshots = Set.empty + schedulerRoutes = Map.empty + schedulerBlocked = Set.empty + schedulerTriggers = Map.empty + schedulerStarved = 0 + schedulerFacts = Map.empty + schedulerErrors = [] + + +-------------------------------------------------------------------------------- +schedulerError :: Maybe Identifier -> String -> Scheduler -> (Scheduler, ()) +schedulerError i e s = (s {schedulerErrors = (i, e) : schedulerErrors s}, ()) + + +-------------------------------------------------------------------------------- +schedulerMarkOutOfDate + :: Map Identifier (Compiler SomeItem) + -> Set Identifier + -> Set Identifier + -> Scheduler + -> (Scheduler, [String]) +schedulerMarkOutOfDate universe modifiedC modifiedM scheduler@Scheduler {..} = + ( scheduler + { schedulerQueue = schedulerQueue <> Seq.fromList (Map.keys todo) + , schedulerDone = schedulerDone <> + (Map.keysSet universe `Set.difference` ood) + , schedulerTodo = schedulerTodo <> todo + , schedulerFacts = facts' + } + , msgs + ) + where + (ood, facts', msgs) = outOfDate (Map.keys universe) modifiedC modifiedM schedulerFacts + todo = Map.filterWithKey (\id' _ -> id' `Set.member` ood) universe + + +-------------------------------------------------------------------------------- +data SchedulerStep + -- | The scheduler instructs to offer some work on the given item. It + -- also returns the number of threads that can be resumed after they have + -- starved. + = SchedulerWork Identifier (Compiler SomeItem) Int + -- | There's currently no work available, but there will be after other + -- threads have finished whatever they are doing. + | SchedulerStarve + -- | We've finished all work. + | SchedulerFinish + -- | An error occurred. You can retrieve the errors from 'schedulerErrors'. + | SchedulerError + + +-------------------------------------------------------------------------------- +schedulerPop :: Scheduler -> (Scheduler, SchedulerStep) +schedulerPop scheduler@Scheduler {..} = case Seq.viewl schedulerQueue of + Seq.EmptyL + | not $ Set.null schedulerWorking -> + ( scheduler {schedulerStarved = schedulerStarved + 1} + , SchedulerStarve + ) + | not $ Set.null schedulerBlocked -> + let cycles = schedulerCycles scheduler + msg | null cycles = "Possible dependency cycle in: " <> + intercalate ", " (show <$> Set.toList schedulerBlocked) + | otherwise = "Dependency cycles: " <> + intercalate "; " + (map (intercalate " -> " . map show) cycles) in + SchedulerError <$ schedulerError Nothing msg scheduler + | otherwise -> (scheduler, SchedulerFinish) + x Seq.:< xs + | x `Set.member` schedulerDone -> + schedulerPop scheduler {schedulerQueue = xs} + | x `Set.member` schedulerWorking -> + schedulerPop scheduler {schedulerQueue = xs} + | x `Set.member` schedulerBlocked -> + schedulerPop scheduler {schedulerQueue = xs} + | otherwise -> case Map.lookup x schedulerTodo of + Nothing -> SchedulerError <$ + schedulerError (Just x) "Compiler not found" scheduler + Just c -> + ( scheduler + { schedulerQueue = xs + , schedulerWorking = Set.insert x schedulerWorking + } + , SchedulerWork x c 0 + ) + + +-------------------------------------------------------------------------------- +schedulerCycles :: Scheduler -> [[Identifier]] +schedulerCycles Scheduler {..} = + [c | Graph.CyclicSCC c <- Graph.stronglyConnComp graph] + where + graph = [(x, x, Set.toList ys) | (x, ys) <- Map.toList edges] + edges = Map.fromListWith Set.union $ do + (dep, xs) <- Map.toList $ schedulerTriggers + x <- Set.toList xs + pure (x, Set.singleton dep) + + +-------------------------------------------------------------------------------- +schedulerBlock + :: Identifier + -> [(Identifier, Snapshot)] + -> Compiler SomeItem + -> Scheduler + -> (Scheduler, SchedulerStep) +schedulerBlock identifier deps0 compiler scheduler@Scheduler {..} + | null deps1 = (scheduler, SchedulerWork identifier compiler 0) + | otherwise = schedulerPop $ scheduler + { schedulerQueue = + -- Optimization: move deps to the front and item to the back + Seq.fromList depIds <> + schedulerQueue <> + Seq.singleton identifier + , schedulerTodo = + Map.insert identifier + (Compiler $ \_ -> pure $ CompilerRequire deps0 compiler) + schedulerTodo + , schedulerWorking = Set.delete identifier schedulerWorking + , schedulerBlocked = Set.insert identifier schedulerBlocked + , schedulerTriggers = foldl' + (\acc (depId, _) -> + Map.insertWith Set.union depId (Set.singleton identifier) acc) + schedulerTriggers + deps1 + } + where + deps1 = filter (not . done) deps0 + depIds = map fst deps1 + + -- Done if we either completed the entire item (runtimeDone) or + -- if we previously saved the snapshot (runtimeSnapshots). + done (depId, depSnapshot) = + depId `Set.member` schedulerDone || + (depId, depSnapshot) `Set.member` schedulerSnapshots + + +-------------------------------------------------------------------------------- +schedulerUnblock :: Identifier -> Scheduler -> (Scheduler, Int) +schedulerUnblock identifier scheduler@Scheduler {..} = + ( scheduler + { schedulerQueue = + schedulerQueue <> Seq.fromList (Set.toList triggered) + , schedulerStarved = 0 + , schedulerBlocked = Set.delete identifier $ + schedulerBlocked `Set.difference` triggered + , schedulerTriggers = Map.delete identifier schedulerTriggers + } + , schedulerStarved + ) + where + triggered = fromMaybe Set.empty $ Map.lookup identifier schedulerTriggers + + +-------------------------------------------------------------------------------- +schedulerSnapshot + :: Identifier -> Snapshot -> Compiler SomeItem + -> Scheduler -> (Scheduler, SchedulerStep) +schedulerSnapshot identifier snapshot compiler scheduler@Scheduler {..} = + let (scheduler', resume) = schedulerUnblock identifier scheduler + { schedulerSnapshots = + Set.insert (identifier, snapshot) schedulerSnapshots + } in + (scheduler', SchedulerWork identifier compiler resume) + + +-------------------------------------------------------------------------------- +schedulerWrite + :: Identifier + -> [Dependency] + -> Scheduler + -> (Scheduler, SchedulerStep) +schedulerWrite identifier depFacts scheduler0@Scheduler {..} = + let (scheduler1, resume) = schedulerUnblock identifier scheduler0 + { schedulerWorking = Set.delete identifier schedulerWorking + , schedulerFacts = Map.insert identifier depFacts schedulerFacts + , schedulerDone = + Set.insert identifier schedulerDone + , schedulerTodo = + Map.delete identifier schedulerTodo + } + (scheduler2, step) = schedulerPop scheduler1 in + case step of + SchedulerWork i c n -> (scheduler2, SchedulerWork i c (n + resume)) + _ -> (scheduler2, step) + + +-------------------------------------------------------------------------------- +-- | Record that a specific identifier was routed to a specific filepath. +-- This is used to detect multiple (inconsistent) writes to the same file. +schedulerRoute + :: Identifier + -> FilePath + -> Scheduler + -> (Scheduler, ()) +schedulerRoute id0 path scheduler0@Scheduler {..} + | Just id1 <- Map.lookup path schedulerRoutes, id0 /= id1 = + let msg = "multiple writes for route " ++ path ++ ": " ++ + show id0 ++ " and " ++ show id1 in + schedulerError (Just id0) msg scheduler0 + | otherwise = + let routes = Map.insert path id0 schedulerRoutes in + (scheduler0 {schedulerRoutes = routes}, ()) + + +-------------------------------------------------------------------------------- +build :: RunMode -> ReaderT RuntimeRead IO () +build mode = do + logger <- runtimeLogger <$> ask + Logger.header logger "Checking for out-of-date items" + schedulerRef <- runtimeScheduler <$> ask + scheduleOutOfDate + case mode of + RunModeNormal -> do + Logger.header logger "Compiling" + if rtsSupportsBoundThreads then pickAndChaseAsync else pickAndChase + errs <- liftIO $ schedulerErrors <$> IORef.readIORef schedulerRef + when (null errs) $ Logger.header logger "Success" + facts <- liftIO $ schedulerFacts <$> IORef.readIORef schedulerRef + store <- runtimeStore <$> ask + liftIO $ Store.set store factsKey facts + RunModePrintOutOfDate -> do + Logger.header logger "Out of date items:" + todo <- liftIO $ schedulerTodo <$> IORef.readIORef schedulerRef + traverse_ (Logger.message logger . show) (Map.keys todo) + + +-------------------------------------------------------------------------------- +scheduleOutOfDate :: ReaderT RuntimeRead IO () +scheduleOutOfDate = do + logger <- runtimeLogger <$> ask + provider <- runtimeProvider <$> ask + modifiedMeta <- runtimeModifiedMeta <$> ask + universe <- runtimeUniverse <$> ask + schedulerRef <- runtimeScheduler <$> ask + let modifiedContent = Set.filter (resourceModified provider) (Map.keysSet universe) + msgs <- liftIO . IORef.atomicModifyIORef' schedulerRef $ + schedulerMarkOutOfDate universe modifiedContent modifiedMeta + + -- Print messages + mapM_ (Logger.debug logger) msgs + + +-------------------------------------------------------------------------------- +pickAndChase :: ReaderT RuntimeRead IO () +pickAndChase = do + scheduler <- runtimeScheduler <$> ask + let go SchedulerFinish = pure () + go SchedulerError = pure () + go (SchedulerWork i c _) = work i c >>= go + go SchedulerStarve = + liftIO . IORef.atomicModifyIORef' scheduler $ + schedulerError Nothing "Starved, possible dependency cycle?" + pop <- liftIO . IORef.atomicModifyIORef' scheduler $ schedulerPop + go pop + + +-------------------------------------------------------------------------------- +pickAndChaseAsync :: ReaderT RuntimeRead IO () +pickAndChaseAsync = do + runtimeRead <- ask + numThreads <- liftIO getNumCapabilities + let scheduler = runtimeScheduler runtimeRead + Logger.message (runtimeLogger runtimeRead) $ + "Using async runtime with " <> show numThreads <> " threads..." + liftIO $ do + signal <- MVar.newEmptyMVar + + let spawnN :: Int -> IO () + spawnN n = replicateM_ n $ forkIO $ + IORef.atomicModifyIORef' scheduler schedulerPop >>= go + + go :: SchedulerStep -> IO () + go step = case step of + SchedulerFinish -> void $ MVar.tryPutMVar signal () + SchedulerStarve -> pure () + SchedulerError -> void $ MVar.tryPutMVar signal () + (SchedulerWork i c n) -> do + spawnN n + step' <- runReaderT (work i c) runtimeRead + go step' + + spawnN numThreads + MVar.readMVar signal + + +-------------------------------------------------------------------------------- +work :: Identifier -> Compiler SomeItem -> ReaderT RuntimeRead IO SchedulerStep +work id' compiler = do + logger <- runtimeLogger <$> ask + provider <- runtimeProvider <$> ask + universe <- runtimeUniverse <$> ask + routes <- runtimeRoutes <$> ask + store <- runtimeStore <$> ask + config <- runtimeConfiguration <$> ask + scheduler <- runtimeScheduler <$> ask + + let cread = CompilerRead + { compilerConfig = config + , compilerUnderlying = id' + , compilerProvider = provider + , compilerUniverse = Map.keysSet universe + , compilerRoutes = routes + , compilerStore = store + , compilerLogger = logger + } + result <- liftIO $ runCompiler compiler cread + case result of + CompilerError e -> do + let msgs = case compilerErrorMessages e of + [] -> ["Compiler failed but no info given, try running with -v?"] + es -> es + for_ msgs $ \msg -> liftIO . IORef.atomicModifyIORef' scheduler $ + schedulerError (Just id') msg + return SchedulerError + + CompilerSnapshot snapshot c -> + liftIO . IORef.atomicModifyIORef' scheduler $ + schedulerSnapshot id' snapshot c + + CompilerDone (SomeItem item) cwrite -> do + -- Print some info + let facts = compilerDependencies cwrite + cacheHits + | compilerCacheHits cwrite <= 0 = "updated" + | otherwise = "cached " + Logger.message logger $ cacheHits ++ " " ++ show id' + + -- Sanity check + liftIO . unless (itemIdentifier item == id') $ + IORef.atomicModifyIORef' scheduler $ schedulerError + (Just id') $ + "The compiler yielded an Item with Identifier " ++ + show (itemIdentifier item) ++ ", but we were expecting " ++ + "an Item with Identifier " ++ show id' ++ " " ++ + "(you probably want to call makeItem to solve this problem)" + + -- Write if necessary. Note that we want another exception handler + -- around this: some compilers may successfully produce a + -- 'CompilerResult', but the thing they are supposed to 'write' can + -- have an un-evaluated 'error' them. + routeOrErr <- liftIO $ try $ do + (mroute, _) <- runRoutes routes provider id' + for_ mroute $ \route -> do + IORef.atomicModifyIORef' scheduler $ + schedulerRoute id' route + let path = destinationDirectory config route + makeDirectories path + write path item + save store item + pure mroute + + case routeOrErr of + Left e -> do + liftIO $ IORef.atomicModifyIORef' scheduler $ + schedulerError (Just id') $ + "An exception was thrown when persisting " ++ + "the compiler result: " ++ show (e :: SomeException) + pure SchedulerError + Right mroute -> do + for_ mroute $ \route -> + Logger.debug logger $ "Routed to " ++ show route + liftIO . IORef.atomicModifyIORef' scheduler $ + schedulerWrite id' facts + + CompilerRequire reqs c -> + liftIO . IORef.atomicModifyIORef' scheduler $ + schedulerBlock id' reqs c diff --git a/lib/Hakyll/Core/Store.hs b/lib/Hakyll/Core/Store.hs new file mode 100644 --- /dev/null +++ b/lib/Hakyll/Core/Store.hs @@ -0,0 +1,233 @@ +-------------------------------------------------------------------------------- +-- | A store for storing and retreiving items +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Hakyll.Core.Store + ( Store + , Result (..) + , toMaybe + , new + , set + , get + , isMember + , delete + , hash + ) where + + +-------------------------------------------------------------------------------- +import Control.Monad (when) +import Data.Binary (Binary, decode, encodeFile) +import qualified Data.ByteString.Lazy as BL +import qualified Data.Cache.LRU.IO as Lru +import qualified Data.Hashable as DH +import qualified Data.IORef as IORef +import Data.List (intercalate) +import qualified Data.Map as Map +import Data.Maybe (isJust) +import Data.Typeable (TypeRep, Typeable, cast, typeOf) +import System.Directory (createDirectoryIfMissing, doesFileExist, + removeFile) +import System.FilePath (()) +import System.IO (IOMode (..), hClose, openFile) +import System.IO.Error (catchIOError, ioeSetFileName, + ioeSetLocation, modifyIOError) + + +-------------------------------------------------------------------------------- +-- | Simple wrapper type +data Box = forall a. Typeable a => Box a + + +-------------------------------------------------------------------------------- +data Store = Store + { -- | All items are stored on the filesystem + storeDirectory :: FilePath + , -- | See 'set' + storeWriteAhead :: IORef.IORef (Map.Map String Box) + -- | Optionally, items are also kept in-memory + , storeMap :: Maybe (Lru.AtomicLRU FilePath Box) + } + + +-------------------------------------------------------------------------------- +instance Show Store where + show _ = "foo
" +-- +-- Result: +-- +-- > "foo" +-- +-- This also works for incomplete tags +-- +-- Example: +-- +-- > stripTags "foo "foo"
+stripTags :: String -> String
+stripTags [] = []
+stripTags ('<' : xs) = stripTags $ drop 1 $ dropWhile (/= '>') xs
+stripTags (x : xs) = x : stripTags xs
+
+
+--------------------------------------------------------------------------------
+-- | HTML-escape a string
+--
+-- Example:
+--
+-- > escapeHtml "Me & Dean"
+--
+-- Result:
+--
+-- > "Me & Dean"
+escapeHtml :: String -> String
+escapeHtml = renderHtml . toHtml
+
+
+--------------------------------------------------------------------------------
+data Srcset = Srcset {
+ unSrcset :: [SrcsetImageCandidate]
+ }
+
+
+--------------------------------------------------------------------------------
+instance Show Srcset where
+ show set = intercalate ", " $ map show $ unSrcset set
+
+
+--------------------------------------------------------------------------------
+data SrcsetImageCandidate = SrcsetImageCandidate {
+ srcsetImageCandidateUrl :: String
+ , srcsetImageCandidateDescriptor :: Maybe String
+ }
+
+
+--------------------------------------------------------------------------------
+instance Show SrcsetImageCandidate where
+ show candidate =
+ let url = srcsetImageCandidateUrl candidate
+ in case srcsetImageCandidateDescriptor candidate of
+ Just desc -> concat [url, " ", desc]
+ Nothing -> url
+
+
+--------------------------------------------------------------------------------
+-- HTML spec: https://html.spec.whatwg.org/#srcset-attributes
+srcsetParser :: P.Parsec String () Srcset
+srcsetParser = do
+ result <- candidate `P.sepBy1` (PC.char ',')
+ P.eof
+ return $ Srcset result
+ where
+ candidate :: P.Parsec String () SrcsetImageCandidate
+ candidate = do
+ P.skipMany ascii_whitespace
+ u <- url
+ P.skipMany ascii_whitespace
+ desc <- P.optionMaybe $ P.choice $ fmap P.try [width_descriptor, px_density_descriptor]
+ P.skipMany ascii_whitespace
+ return $ SrcsetImageCandidate {
+ srcsetImageCandidateUrl = u
+ , srcsetImageCandidateDescriptor = desc
+ }
+
+ -- This is an over-simplification, but should be good enough for our purposes
+ url :: P.Parsec String () String
+ url = P.many1 $ PC.noneOf " ,"
+
+ ascii_whitespace :: P.Parsec String () ()
+ ascii_whitespace = void $ P.oneOf "\x09\x0A\x0C\x0D\x20"
+
+ width_descriptor :: P.Parsec String () String
+ width_descriptor = do
+ number <- P.many1 PC.digit
+ void $ PC.char 'w'
+ return $ concat [number, "w"]
+
+ px_density_descriptor :: P.Parsec String () String
+ px_density_descriptor = do
+ sign <- P.optionMaybe $ PC.char '-'
+ int <- P.many1 PC.digit
+ frac <- P.optionMaybe $ do
+ void $ PC.char '.'
+ frac <- P.many1 PC.digit
+ return $ concat [".", frac]
+ expon <- P.optionMaybe $ do
+ letter <- P.oneOf "eE"
+ e_sign <- P.optionMaybe $ PC.oneOf "-+"
+ number <- P.many1 PC.digit
+ return $ concat [[letter], mb $ fmap show e_sign, number]
+ void $ PC.char 'x'
+ return $ concat [mb $ fmap show sign, int, mb frac, mb expon, "x"]
+
+ mb :: Maybe String -> String
+ mb = fromMaybe ""
diff --git a/lib/Hakyll/Web/Html/RelativizeUrls.hs b/lib/Hakyll/Web/Html/RelativizeUrls.hs
new file mode 100644
--- /dev/null
+++ b/lib/Hakyll/Web/Html/RelativizeUrls.hs
@@ -0,0 +1,52 @@
+--------------------------------------------------------------------------------
+-- | This module exposes a function which can relativize URL's on a webpage.
+--
+-- This means that one can deploy the resulting site on
+-- @http:\/\/example.com\/@, but also on @http:\/\/example.com\/some-folder\/@
+-- without having to change anything (simply copy over the files).
+--
+-- To use it, you should use absolute URL's from the site root everywhere. For
+-- example, use
+--
+-- > The page has moved to: this page
+-- > A literal $$key$$.
+-- >
+-- > I like
+-- >
+-- > fresh fruits, and
+-- >
+-- > fresh vegetables
+-- >
+-- > $partial("test.html")$
+-- >
+-- > $key$
+-- >
+-- > $for(counts)-$
+-- > $count$
+-- > $-sep$...
+-- > $-endfor$
+-- >
+-- > 3...2...1
+-- > foo foo "foo"
-stripTags :: String -> String
-stripTags [] = []
-stripTags ('<' : xs) = stripTags $ drop 1 $ dropWhile (/= '>') xs
-stripTags (x : xs) = x : stripTags xs
-
-
---------------------------------------------------------------------------------
--- | HTML-escape a string
---
--- Example:
---
--- > escapeHtml "Me & Dean"
---
--- Result:
---
--- > "Me & Dean"
-escapeHtml :: String -> String
-escapeHtml = renderHtml . toHtml
diff --git a/src/Hakyll/Web/Html/RelativizeUrls.hs b/src/Hakyll/Web/Html/RelativizeUrls.hs
deleted file mode 100644
--- a/src/Hakyll/Web/Html/RelativizeUrls.hs
+++ /dev/null
@@ -1,52 +0,0 @@
---------------------------------------------------------------------------------
--- | This module exposes a function which can relativize URL's on a webpage.
---
--- This means that one can deploy the resulting site on
--- @http:\/\/example.com\/@, but also on @http:\/\/example.com\/some-folder\/@
--- without having to change anything (simply copy over the files).
---
--- To use it, you should use absolute URL's from the site root everywhere. For
--- example, use
---
--- >
--- > A literal $$key$$.
--- >
--- > I like
--- >
--- > fresh fruits, and
--- >
--- > fresh vegetables
--- >
--- > $partial("test.html")$
--- >
--- > $key$
--- > This is an example. foo Hello, world "++) . (++" I would like to cite one of my favourite papers (Meijer, Fokkinga, and Paterson 1991) here. I would like to cite one of my favourite papers (Meijer, Fokkinga, and Paterson 1991) here. I would like to cite one of my favourite papers (Meijer, Fokkinga, and Paterson 1991) here. I would like to cite one of my favourite papers (Meijer, Fokkinga, and Paterson 1991) here. And also a book (Lipovača 2012). I would like to cite one of my favourite papers (Meijer, Fokkinga, and Paterson 1991) here. And also a book (Lipovača 2012). I would like to cite one of my favourite papers (Meijer, Fokkinga, and Paterson 1991) here. And also a book (Lipovača 2012). $body$ This is an included partial. This is a file that includes a partial. This is a file that includes a partial. This is an included partial. This is an example.
+--
+-- in a blogpost. When running this through the relativize URL's module, this
+-- will result in (suppose your blogpost is located at @\/posts\/foo.html@:
+--
+-- > 
+module Hakyll.Web.Html.RelativizeUrls
+ ( relativizeUrls
+ , relativizeUrlsWith
+ ) where
+
+
+--------------------------------------------------------------------------------
+import Data.List (isPrefixOf)
+
+
+--------------------------------------------------------------------------------
+import Hakyll.Core.Compiler
+import Hakyll.Core.Item
+import Hakyll.Web.Html
+
+
+--------------------------------------------------------------------------------
+-- | Compiler form of 'relativizeUrls' which automatically picks the right root
+-- path
+relativizeUrls :: Item String -> Compiler (Item String)
+relativizeUrls item = do
+ route <- getRoute $ itemIdentifier item
+ return $ case route of
+ Nothing -> item
+ Just r -> fmap (relativizeUrlsWith $ toSiteRoot r) item
+
+
+--------------------------------------------------------------------------------
+-- | Relativize URL's in HTML
+relativizeUrlsWith :: String -- ^ Path to the site root
+ -> String -- ^ HTML to relativize
+ -> String -- ^ Resulting HTML
+relativizeUrlsWith root = withUrls rel
+ where
+ isRel x = "/" `isPrefixOf` x && not ("//" `isPrefixOf` x)
+ rel x = if isRel x then root ++ x else x
diff --git a/lib/Hakyll/Web/Meta/JSONLD.hs b/lib/Hakyll/Web/Meta/JSONLD.hs
new file mode 100644
--- /dev/null
+++ b/lib/Hakyll/Web/Meta/JSONLD.hs
@@ -0,0 +1,115 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+{- |
+
+JSON-LD metadata, using
+-- >
+-- > My crazy homepage - $title$
+-- >
+-- > $body$
+-- >
+-- >
+-- >
+-- >
+--
+-- As you can see, the format is very simple -- @$key$@ is used to render the
+-- @$key$@ field from the page, everything else is literally copied. If you want
+-- to literally insert @\"$key$\"@ into your page (for example, when you're
+-- writing a Hakyll tutorial) you can use
+--
+-- >
---
--- in a blogpost. When running this through the relativize URL's module, this
--- will result in (suppose your blogpost is located at @\/posts\/foo.html@:
---
--- >
-module Hakyll.Web.Html.RelativizeUrls
- ( relativizeUrls
- , relativizeUrlsWith
- ) where
-
-
---------------------------------------------------------------------------------
-import Data.List (isPrefixOf)
-
-
---------------------------------------------------------------------------------
-import Hakyll.Core.Compiler
-import Hakyll.Core.Item
-import Hakyll.Web.Html
-
-
---------------------------------------------------------------------------------
--- | Compiler form of 'relativizeUrls' which automatically picks the right root
--- path
-relativizeUrls :: Item String -> Compiler (Item String)
-relativizeUrls item = do
- route <- getRoute $ itemIdentifier item
- return $ case route of
- Nothing -> item
- Just r -> fmap (relativizeUrlsWith $ toSiteRoot r) item
-
-
---------------------------------------------------------------------------------
--- | Relativize URL's in HTML
-relativizeUrlsWith :: String -- ^ Path to the site root
- -> String -- ^ HTML to relativize
- -> String -- ^ Resulting HTML
-relativizeUrlsWith root = withUrls rel
- where
- isRel x = "/" `isPrefixOf` x && not ("//" `isPrefixOf` x)
- rel x = if isRel x then root ++ x else x
diff --git a/src/Hakyll/Web/Paginate.hs b/src/Hakyll/Web/Paginate.hs
deleted file mode 100644
--- a/src/Hakyll/Web/Paginate.hs
+++ /dev/null
@@ -1,126 +0,0 @@
---------------------------------------------------------------------------------
-{-# LANGUAGE OverloadedStrings #-}
-module Hakyll.Web.Paginate
- ( PageNumber
- , Paginate (..)
- , buildPaginateWith
- , paginateEvery
- , paginateRules
- , paginateContext
- ) where
-
-
---------------------------------------------------------------------------------
-import Control.Monad (forM_)
-import qualified Data.Map as M
-import qualified Data.Set as S
-
-
---------------------------------------------------------------------------------
-import Hakyll.Core.Compiler
-import Hakyll.Core.Identifier
-import Hakyll.Core.Identifier.Pattern
-import Hakyll.Core.Item
-import Hakyll.Core.Metadata
-import Hakyll.Core.Rules
-import Hakyll.Web.Html
-import Hakyll.Web.Template.Context
-
-
---------------------------------------------------------------------------------
-type PageNumber = Int
-
-
---------------------------------------------------------------------------------
--- | Data about paginators
-data Paginate = Paginate
- { paginateMap :: M.Map PageNumber [Identifier]
- , paginateMakeId :: PageNumber -> Identifier
- , paginateDependency :: Dependency
- }
-
-
---------------------------------------------------------------------------------
-paginateNumPages :: Paginate -> Int
-paginateNumPages = M.size . paginateMap
-
-
---------------------------------------------------------------------------------
-paginateEvery :: Int -> [a] -> [[a]]
-paginateEvery n = go
- where
- go [] = []
- go xs = let (y, ys) = splitAt n xs in y : go ys
-
-
---------------------------------------------------------------------------------
-buildPaginateWith
- :: MonadMetadata m
- => ([Identifier] -> m [[Identifier]]) -- ^ Group items into pages
- -> Pattern -- ^ Select items to paginate
- -> (PageNumber -> Identifier) -- ^ Identifiers for the pages
- -> m Paginate
-buildPaginateWith grouper pattern makeId = do
- ids <- getMatches pattern
- idGroups <- grouper ids
- let idsSet = S.fromList ids
- return Paginate
- { paginateMap = M.fromList (zip [1 ..] idGroups)
- , paginateMakeId = makeId
- , paginateDependency = PatternDependency pattern idsSet
- }
-
-
---------------------------------------------------------------------------------
-paginateRules :: Paginate -> (PageNumber -> Pattern -> Rules ()) -> Rules ()
-paginateRules paginator rules =
- forM_ (M.toList $ paginateMap paginator) $ \(idx, identifiers) ->
- rulesExtraDependencies [paginateDependency paginator] $
- create [paginateMakeId paginator idx] $
- rules idx $ fromList identifiers
-
-
---------------------------------------------------------------------------------
--- | Get the identifier for a certain page by passing in the page number.
-paginatePage :: Paginate -> PageNumber -> Maybe Identifier
-paginatePage pag pageNumber
- | pageNumber < 1 = Nothing
- | pageNumber > (paginateNumPages pag) = Nothing
- | otherwise = Just $ paginateMakeId pag pageNumber
-
-
---------------------------------------------------------------------------------
--- | A default paginate context which provides the following keys:
---
---
-paginateContext :: Paginate -> PageNumber -> Context a
-paginateContext pag currentPage = mconcat
- [ field "firstPageNum" $ \_ -> otherPage 1 >>= num
- , field "firstPageUrl" $ \_ -> otherPage 1 >>= url
- , field "previousPageNum" $ \_ -> otherPage (currentPage - 1) >>= num
- , field "previousPageUrl" $ \_ -> otherPage (currentPage - 1) >>= url
- , field "nextPageNum" $ \_ -> otherPage (currentPage + 1) >>= num
- , field "nextPageUrl" $ \_ -> otherPage (currentPage + 1) >>= url
- , field "lastPageNum" $ \_ -> otherPage lastPage >>= num
- , field "lastPageUrl" $ \_ -> otherPage lastPage >>= url
- , field "currentPageNum" $ \i -> thisPage i >>= num
- , field "currentPageUrl" $ \i -> thisPage i >>= url
- , constField "numPages" $ show $ paginateNumPages pag
- ]
- where
- lastPage = paginateNumPages pag
-
- thisPage i = return (currentPage, itemIdentifier i)
- otherPage n
- | n == currentPage = fail $ "This is the current page: " ++ show n
- | otherwise = case paginatePage pag n of
- Nothing -> fail $ "No such page: " ++ show n
- Just i -> return (n, i)
-
- num :: (Int, Identifier) -> Compiler String
- num = return . show . fst
-
- url :: (Int, Identifier) -> Compiler String
- url (n, i) = getRoute i >>= \mbR -> case mbR of
- Just r -> return $ toUrl r
- Nothing -> fail $ "No URL for page: " ++ show n
diff --git a/src/Hakyll/Web/Pandoc.hs b/src/Hakyll/Web/Pandoc.hs
deleted file mode 100644
--- a/src/Hakyll/Web/Pandoc.hs
+++ /dev/null
@@ -1,164 +0,0 @@
---------------------------------------------------------------------------------
--- | Module exporting convenient pandoc bindings
-module Hakyll.Web.Pandoc
- ( -- * The basic building blocks
- readPandoc
- , readPandocWith
- , writePandoc
- , writePandocWith
- , renderPandoc
- , renderPandocWith
-
- -- * Derived compilers
- , pandocCompiler
- , pandocCompilerWith
- , pandocCompilerWithTransform
- , pandocCompilerWithTransformM
-
- -- * Default options
- , defaultHakyllReaderOptions
- , defaultHakyllWriterOptions
- ) where
-
-
---------------------------------------------------------------------------------
-import qualified Data.Set as S
-import Text.Pandoc
-import Text.Pandoc.Error (PandocError (..))
-
-
---------------------------------------------------------------------------------
-import Hakyll.Core.Compiler
-import Hakyll.Core.Item
-import Hakyll.Web.Pandoc.FileType
-
-
---------------------------------------------------------------------------------
--- | Read a string using pandoc, with the default options
-readPandoc
- :: Item String -- ^ String to read
- -> Compiler (Item Pandoc) -- ^ Resulting document
-readPandoc = readPandocWith defaultHakyllReaderOptions
-
-
---------------------------------------------------------------------------------
--- | Read a string using pandoc, with the supplied options
-readPandocWith
- :: ReaderOptions -- ^ Parser options
- -> Item String -- ^ String to read
- -> Compiler (Item Pandoc) -- ^ Resulting document
-readPandocWith ropt item =
- case traverse (reader ropt (itemFileType item)) item of
- Left (ParseFailure err) -> fail $
- "Hakyll.Web.Pandoc.readPandocWith: parse failed: " ++ err
- Left (ParsecError _ err) -> fail $
- "Hakyll.Web.Pandoc.readPandocWith: parse failed: " ++ show err
- Right item' -> return item'
- where
- reader ro t = case t of
- DocBook -> readDocBook ro
- Html -> readHtml ro
- LaTeX -> readLaTeX ro
- LiterateHaskell t' -> reader (addExt ro Ext_literate_haskell) t'
- Markdown -> readMarkdown ro
- MediaWiki -> readMediaWiki ro
- OrgMode -> readOrg ro
- Rst -> readRST ro
- Textile -> readTextile ro
- _ -> error $
- "Hakyll.Web.readPandocWith: I don't know how to read a file of " ++
- "the type " ++ show t ++ " for: " ++ show (itemIdentifier item)
-
- addExt ro e = ro {readerExtensions = S.insert e $ readerExtensions ro}
-
-
---------------------------------------------------------------------------------
--- | Write a document (as HTML) using pandoc, with the default options
-writePandoc :: Item Pandoc -- ^ Document to write
- -> Item String -- ^ Resulting HTML
-writePandoc = writePandocWith defaultHakyllWriterOptions
-
-
---------------------------------------------------------------------------------
--- | Write a document (as HTML) using pandoc, with the supplied options
-writePandocWith :: WriterOptions -- ^ Writer options for pandoc
- -> Item Pandoc -- ^ Document to write
- -> Item String -- ^ Resulting HTML
-writePandocWith wopt = fmap $ writeHtmlString wopt
-
-
---------------------------------------------------------------------------------
--- | Render the resource using pandoc
-renderPandoc :: Item String -> Compiler (Item String)
-renderPandoc =
- renderPandocWith defaultHakyllReaderOptions defaultHakyllWriterOptions
-
-
---------------------------------------------------------------------------------
--- | Render the resource using pandoc
-renderPandocWith
- :: ReaderOptions -> WriterOptions -> Item String -> Compiler (Item String)
-renderPandocWith ropt wopt item =
- writePandocWith wopt <$> readPandocWith ropt item
-
-
---------------------------------------------------------------------------------
--- | Read a page render using pandoc
-pandocCompiler :: Compiler (Item String)
-pandocCompiler =
- pandocCompilerWith defaultHakyllReaderOptions defaultHakyllWriterOptions
-
-
---------------------------------------------------------------------------------
--- | A version of 'pandocCompiler' which allows you to specify your own pandoc
--- options
-pandocCompilerWith :: ReaderOptions -> WriterOptions -> Compiler (Item String)
-pandocCompilerWith ropt wopt =
- cached "Hakyll.Web.Pandoc.pandocCompilerWith" $
- pandocCompilerWithTransform ropt wopt id
-
-
---------------------------------------------------------------------------------
--- | An extension of 'pandocCompilerWith' which allows you to specify a custom
--- pandoc transformation for the content
-pandocCompilerWithTransform :: ReaderOptions -> WriterOptions
- -> (Pandoc -> Pandoc)
- -> Compiler (Item String)
-pandocCompilerWithTransform ropt wopt f =
- pandocCompilerWithTransformM ropt wopt (return . f)
-
-
---------------------------------------------------------------------------------
--- | Similar to 'pandocCompilerWithTransform', but the transformation
--- function is monadic. This is useful when you want the pandoc
--- transformation to use the 'Compiler' information such as routes,
--- metadata, etc
-pandocCompilerWithTransformM :: ReaderOptions -> WriterOptions
- -> (Pandoc -> Compiler Pandoc)
- -> Compiler (Item String)
-pandocCompilerWithTransformM ropt wopt f =
- writePandocWith wopt <$>
- (traverse f =<< readPandocWith ropt =<< getResourceBody)
-
-
---------------------------------------------------------------------------------
--- | The default reader options for pandoc parsing in hakyll
-defaultHakyllReaderOptions :: ReaderOptions
-defaultHakyllReaderOptions = def
- { -- The following option causes pandoc to read smart typography, a nice
- -- and free bonus.
- readerSmart = True
- }
-
-
---------------------------------------------------------------------------------
--- | The default writer options for pandoc rendering in hakyll
-defaultHakyllWriterOptions :: WriterOptions
-defaultHakyllWriterOptions = def
- { -- This option causes literate haskell to be written using '>' marks in
- -- html, which I think is a good default.
- writerExtensions = S.insert Ext_literate_haskell (writerExtensions def)
- , -- We want to have hightlighting by default, to be compatible with earlier
- -- Hakyll releases
- writerHighlight = True
- }
diff --git a/src/Hakyll/Web/Pandoc/Biblio.hs b/src/Hakyll/Web/Pandoc/Biblio.hs
deleted file mode 100644
--- a/src/Hakyll/Web/Pandoc/Biblio.hs
+++ /dev/null
@@ -1,115 +0,0 @@
---------------------------------------------------------------------------------
--- | Wraps pandocs bibiliography handling
---
--- In order to add a bibliography, you will need a bibliography file (e.g.
--- @.bib@) and a CSL file (@.csl@). Both need to be compiled with their
--- respective compilers ('biblioCompiler' and 'cslCompiler'). Then, you can
--- refer to these files when you use 'readPandocBiblio'. This function also
--- takes the reader options for completeness -- you can use
--- 'defaultHakyllReaderOptions' if you're unsure.
--- 'pandocBiblioCompiler' is a convenience wrapper which works like 'pandocCompiler',
--- but also takes paths to compiled bibliography and csl files.
-{-# LANGUAGE Arrows #-}
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-module Hakyll.Web.Pandoc.Biblio
- ( CSL
- , cslCompiler
- , Biblio (..)
- , biblioCompiler
- , readPandocBiblio
- , pandocBiblioCompiler
- ) where
-
-
---------------------------------------------------------------------------------
-import Control.Monad (liftM, replicateM)
-import Data.Binary (Binary (..))
-import Data.Default (def)
-import Data.Typeable (Typeable)
-import Hakyll.Core.Compiler
-import Hakyll.Core.Identifier
-import Hakyll.Core.Item
-import Hakyll.Core.Writable
-import Hakyll.Web.Pandoc
-import Hakyll.Web.Pandoc.Binary ()
-import qualified Text.CSL as CSL
-import Text.CSL.Pandoc (processCites)
-import Text.Pandoc (Pandoc, ReaderOptions (..))
-
-
---------------------------------------------------------------------------------
-data CSL = CSL
- deriving (Show, Typeable)
-
-
---------------------------------------------------------------------------------
-instance Binary CSL where
- put CSL = return ()
- get = return CSL
-
-
---------------------------------------------------------------------------------
-instance Writable CSL where
- -- Shouldn't be written.
- write _ _ = return ()
-
-
---------------------------------------------------------------------------------
-cslCompiler :: Compiler (Item CSL)
-cslCompiler = makeItem CSL
-
-
---------------------------------------------------------------------------------
-newtype Biblio = Biblio [CSL.Reference]
- deriving (Show, Typeable)
-
-
---------------------------------------------------------------------------------
-instance Binary Biblio where
- -- Ugly.
- get = do
- len <- get
- Biblio <$> replicateM len get
- put (Biblio rs) = put (length rs) >> mapM_ put rs
-
-
---------------------------------------------------------------------------------
-instance Writable Biblio where
- -- Shouldn't be written.
- write _ _ = return ()
-
-
---------------------------------------------------------------------------------
-biblioCompiler :: Compiler (Item Biblio)
-biblioCompiler = do
- filePath <- toFilePath <$> getUnderlying
- makeItem =<< unsafeCompiler (Biblio <$> CSL.readBiblioFile filePath)
-
-
---------------------------------------------------------------------------------
-readPandocBiblio :: ReaderOptions
- -> Item CSL
- -> Item Biblio
- -> (Item String)
- -> Compiler (Item Pandoc)
-readPandocBiblio ropt csl biblio item = do
- -- Parse CSL file, if given
- style <- unsafeCompiler $ CSL.readCSLFile Nothing . toFilePath . itemIdentifier $ csl
-
- -- We need to know the citation keys, add then *before* actually parsing the
- -- actual page. If we don't do this, pandoc won't even consider them
- -- citations!
- let Biblio refs = itemBody biblio
- pandoc <- itemBody <$> readPandocWith ropt item
- let pandoc' = processCites style refs pandoc
-
- return $ fmap (const pandoc') item
-
---------------------------------------------------------------------------------
-pandocBiblioCompiler :: String -> String -> Compiler (Item String)
-pandocBiblioCompiler cslFileName bibFileName = do
- csl <- load $ fromFilePath cslFileName
- bib <- load $ fromFilePath bibFileName
- liftM writePandoc
- (getResourceBody >>= readPandocBiblio def csl bib)
diff --git a/src/Hakyll/Web/Pandoc/Binary.hs b/src/Hakyll/Web/Pandoc/Binary.hs
deleted file mode 100644
--- a/src/Hakyll/Web/Pandoc/Binary.hs
+++ /dev/null
@@ -1,31 +0,0 @@
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-{-# LANGUAGE DeriveGeneric #-}
-module Hakyll.Web.Pandoc.Binary where
-
-import Data.Binary (Binary (..))
-
-import qualified Text.CSL as CSL
-import qualified Text.CSL.Reference as REF
-import qualified Text.CSL.Style as STY
-import Text.Pandoc
-
---------------------------------------------------------------------------------
--- orphans
-
-instance Binary REF.CNum
-instance Binary REF.Literal
-instance Binary REF.RefDate
-instance Binary REF.RefType
-instance Binary STY.Agent
-instance Binary STY.Formatted
-instance Binary Inline
-instance Binary Block
-instance Binary Citation
-instance Binary MathType
-instance Binary Alignment
-instance Binary CitationMode
-instance Binary QuoteType
-instance Binary Format
-instance Binary ListNumberDelim
-instance Binary ListNumberStyle
-instance Binary CSL.Reference
diff --git a/src/Hakyll/Web/Pandoc/FileType.hs b/src/Hakyll/Web/Pandoc/FileType.hs
deleted file mode 100644
--- a/src/Hakyll/Web/Pandoc/FileType.hs
+++ /dev/null
@@ -1,74 +0,0 @@
---------------------------------------------------------------------------------
--- | A module dealing with pandoc file extensions and associated file types
-module Hakyll.Web.Pandoc.FileType
- ( FileType (..)
- , fileType
- , itemFileType
- ) where
-
-
---------------------------------------------------------------------------------
-import System.FilePath (splitExtension)
-
-
---------------------------------------------------------------------------------
-import Hakyll.Core.Identifier
-import Hakyll.Core.Item
-
-
---------------------------------------------------------------------------------
--- | Datatype to represent the different file types Hakyll can deal with by
--- default
-data FileType
- = Binary
- | Css
- | DocBook
- | Html
- | LaTeX
- | LiterateHaskell FileType
- | Markdown
- | MediaWiki
- | OrgMode
- | PlainText
- | Rst
- | Textile
- deriving (Eq, Ord, Show, Read)
-
-
---------------------------------------------------------------------------------
--- | Get the file type for a certain file. The type is determined by extension.
-fileType :: FilePath -> FileType
-fileType = uncurry fileType' . splitExtension
- where
- fileType' _ ".css" = Css
- fileType' _ ".dbk" = DocBook
- fileType' _ ".htm" = Html
- fileType' _ ".html" = Html
- fileType' f ".lhs" = LiterateHaskell $ case fileType f of
- -- If no extension is given, default to Markdown + LiterateHaskell
- Binary -> Markdown
- -- Otherwise, LaTeX + LiterateHaskell or whatever the user specified
- x -> x
- fileType' _ ".markdown" = Markdown
- fileType' _ ".mediawiki" = MediaWiki
- fileType' _ ".md" = Markdown
- fileType' _ ".mdn" = Markdown
- fileType' _ ".mdown" = Markdown
- fileType' _ ".mdwn" = Markdown
- fileType' _ ".mkd" = Markdown
- fileType' _ ".mkdwn" = Markdown
- fileType' _ ".org" = OrgMode
- fileType' _ ".page" = Markdown
- fileType' _ ".rst" = Rst
- fileType' _ ".tex" = LaTeX
- fileType' _ ".text" = PlainText
- fileType' _ ".textile" = Textile
- fileType' _ ".txt" = PlainText
- fileType' _ ".wiki" = MediaWiki
- fileType' _ _ = Binary -- Treat unknown files as binary
-
-
---------------------------------------------------------------------------------
--- | Get the file type for the current file
-itemFileType :: Item a -> FileType
-itemFileType = fileType . toFilePath . itemIdentifier
diff --git a/src/Hakyll/Web/Tags.hs b/src/Hakyll/Web/Tags.hs
deleted file mode 100644
--- a/src/Hakyll/Web/Tags.hs
+++ /dev/null
@@ -1,344 +0,0 @@
---------------------------------------------------------------------------------
--- | This module containing some specialized functions to deal with tags. It
--- assumes you follow some conventions.
---
--- We support two types of tags: tags and categories.
---
--- To use default tags, use 'buildTags'. Tags are placed in a comma-separated
--- metadata field like this:
---
--- > ---
--- > author: Philip K. Dick
--- > title: Do androids dream of electric sheep?
--- > tags: future, science fiction, humanoid
--- > ---
--- > The novel is set in a post-apocalyptic near future, where the Earth and
--- > its populations have been damaged greatly by Nuclear...
---
--- To use categories, use the 'buildCategories' function. Categories are
--- determined by the directory a page is in, for example, the post
---
--- > posts/coding/2010-01-28-hakyll-categories.markdown
---
--- will receive the @coding@ category.
---
--- Advanced users may implement custom systems using 'buildTagsWith' if desired.
---
--- In the above example, we would want to create a page which lists all pages in
--- the @coding@ category, for example, with the 'Identifier':
---
--- > tags/coding.html
---
--- This is where the first parameter of 'buildTags' and 'buildCategories' comes
--- in. In the above case, we used the function:
---
--- > fromCapture "tags/*.html" :: String -> Identifier
---
--- The 'tagsRules' function lets you generate such a page for each tag in the
--- 'Rules' monad.
-{-# LANGUAGE Arrows #-}
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE OverloadedStrings #-}
-module Hakyll.Web.Tags
- ( Tags (..)
- , getTags
- , buildTagsWith
- , buildTags
- , buildCategories
- , tagsRules
- , renderTags
- , renderTagCloud
- , renderTagCloudWith
- , tagCloudField
- , tagCloudFieldWith
- , renderTagList
- , tagsField
- , tagsFieldWith
- , categoryField
- , sortTagsBy
- , caseInsensitiveTags
- ) where
-
-
---------------------------------------------------------------------------------
-import Control.Arrow ((&&&))
-import Control.Monad (foldM, forM, forM_, mplus)
-import Data.Char (toLower)
-import Data.List (intercalate, intersperse,
- sortBy)
-import qualified Data.Map as M
-import Data.Maybe (catMaybes, fromMaybe)
-import Data.Ord (comparing)
-import qualified Data.Set as S
-import System.FilePath (takeBaseName, takeDirectory)
-import Text.Blaze.Html (toHtml, toValue, (!))
-import Text.Blaze.Html.Renderer.String (renderHtml)
-import qualified Text.Blaze.Html5 as H
-import qualified Text.Blaze.Html5.Attributes as A
-
-
---------------------------------------------------------------------------------
-import Hakyll.Core.Compiler
-import Hakyll.Core.Dependencies
-import Hakyll.Core.Identifier
-import Hakyll.Core.Identifier.Pattern
-import Hakyll.Core.Item
-import Hakyll.Core.Metadata
-import Hakyll.Core.Rules
-import Hakyll.Core.Util.String
-import Hakyll.Web.Html
-import Hakyll.Web.Template.Context
-
-
---------------------------------------------------------------------------------
--- | Data about tags
-data Tags = Tags
- { tagsMap :: [(String, [Identifier])]
- , tagsMakeId :: String -> Identifier
- , tagsDependency :: Dependency
- }
-
-
---------------------------------------------------------------------------------
--- | Obtain tags from a page in the default way: parse them from the @tags@
--- metadata field. This can either be a list or a comma-separated string.
-getTags :: MonadMetadata m => Identifier -> m [String]
-getTags identifier = do
- metadata <- getMetadata identifier
- return $ fromMaybe [] $
- (lookupStringList "tags" metadata) `mplus`
- (map trim . splitAll "," <$> lookupString "tags" metadata)
-
-
---------------------------------------------------------------------------------
--- | Obtain categories from a page.
-getCategory :: MonadMetadata m => Identifier -> m [String]
-getCategory = return . return . takeBaseName . takeDirectory . toFilePath
-
-
---------------------------------------------------------------------------------
--- | Higher-order function to read tags
-buildTagsWith :: MonadMetadata m
- => (Identifier -> m [String])
- -> Pattern
- -> (String -> Identifier)
- -> m Tags
-buildTagsWith f pattern makeId = do
- ids <- getMatches pattern
- tagMap <- foldM addTags M.empty ids
- let set' = S.fromList ids
- return $ Tags (M.toList tagMap) makeId (PatternDependency pattern set')
- where
- -- Create a tag map for one page
- addTags tagMap id' = do
- tags <- f id'
- let tagMap' = M.fromList $ zip tags $ repeat [id']
- return $ M.unionWith (++) tagMap tagMap'
-
-
---------------------------------------------------------------------------------
-buildTags :: MonadMetadata m => Pattern -> (String -> Identifier) -> m Tags
-buildTags = buildTagsWith getTags
-
-
---------------------------------------------------------------------------------
-buildCategories :: MonadMetadata m => Pattern -> (String -> Identifier)
- -> m Tags
-buildCategories = buildTagsWith getCategory
-
-
---------------------------------------------------------------------------------
-tagsRules :: Tags -> (String -> Pattern -> Rules ()) -> Rules ()
-tagsRules tags rules =
- forM_ (tagsMap tags) $ \(tag, identifiers) ->
- rulesExtraDependencies [tagsDependency tags] $
- create [tagsMakeId tags tag] $
- rules tag $ fromList identifiers
-
-
---------------------------------------------------------------------------------
--- | Render tags in HTML (the flexible higher-order function)
-renderTags :: (String -> String -> Int -> Int -> Int -> String)
- -- ^ Produce a tag item: tag, url, count, min count, max count
- -> ([String] -> String)
- -- ^ Join items
- -> Tags
- -- ^ Tag cloud renderer
- -> Compiler String
-renderTags makeHtml concatHtml tags = do
- -- In tags' we create a list: [((tag, route), count)]
- tags' <- forM (tagsMap tags) $ \(tag, ids) -> do
- route' <- getRoute $ tagsMakeId tags tag
- return ((tag, route'), length ids)
-
- -- TODO: We actually need to tell a dependency here!
-
- let -- Absolute frequencies of the pages
- freqs = map snd tags'
-
- -- The minimum and maximum count found
- (min', max')
- | null freqs = (0, 1)
- | otherwise = (minimum &&& maximum) freqs
-
- -- Create a link for one item
- makeHtml' ((tag, url), count) =
- makeHtml tag (toUrl $ fromMaybe "/" url) count min' max'
-
- -- Render and return the HTML
- return $ concatHtml $ map makeHtml' tags'
-
-
---------------------------------------------------------------------------------
--- | Render a tag cloud in HTML
-renderTagCloud :: Double
- -- ^ Smallest font size, in percent
- -> Double
- -- ^ Biggest font size, in percent
- -> Tags
- -- ^ Input tags
- -> Compiler String
- -- ^ Rendered cloud
-renderTagCloud = renderTagCloudWith makeLink (intercalate " ")
- where
- makeLink minSize maxSize tag url count min' max' =
- -- Show the relative size of one 'count' in percent
- let diff = 1 + fromIntegral max' - fromIntegral min'
- relative = (fromIntegral count - fromIntegral min') / diff
- size = floor $ minSize + relative * (maxSize - minSize) :: Int
- in renderHtml $
- H.a ! A.style (toValue $ "font-size: " ++ show size ++ "%")
- ! A.href (toValue url)
- $ toHtml tag
-
-
---------------------------------------------------------------------------------
--- | Render a tag cloud in HTML
-renderTagCloudWith :: (Double -> Double ->
- String -> String -> Int -> Int -> Int -> String)
- -- ^ Render a single tag link
- -> ([String] -> String)
- -- ^ Concatenate links
- -> Double
- -- ^ Smallest font size, in percent
- -> Double
- -- ^ Biggest font size, in percent
- -> Tags
- -- ^ Input tags
- -> Compiler String
- -- ^ Rendered cloud
-renderTagCloudWith makeLink cat minSize maxSize =
- renderTags (makeLink minSize maxSize) cat
-
-
---------------------------------------------------------------------------------
--- | Render a tag cloud in HTML as a context
-tagCloudField :: String
- -- ^ Destination key
- -> Double
- -- ^ Smallest font size, in percent
- -> Double
- -- ^ Biggest font size, in percent
- -> Tags
- -- ^ Input tags
- -> Context a
- -- ^ Context
-tagCloudField key minSize maxSize tags =
- field key $ \_ -> renderTagCloud minSize maxSize tags
-
-
---------------------------------------------------------------------------------
--- | Render a tag cloud in HTML as a context
-tagCloudFieldWith :: String
- -- ^ Destination key
- -> (Double -> Double ->
- String -> String -> Int -> Int -> Int -> String)
- -- ^ Render a single tag link
- -> ([String] -> String)
- -- ^ Concatenate links
- -> Double
- -- ^ Smallest font size, in percent
- -> Double
- -- ^ Biggest font size, in percent
- -> Tags
- -- ^ Input tags
- -> Context a
- -- ^ Context
-tagCloudFieldWith key makeLink cat minSize maxSize tags =
- field key $ \_ -> renderTagCloudWith makeLink cat minSize maxSize tags
-
-
---------------------------------------------------------------------------------
--- | Render a simple tag list in HTML, with the tag count next to the item
--- TODO: Maybe produce a Context here
-renderTagList :: Tags -> Compiler (String)
-renderTagList = renderTags makeLink (intercalate ", ")
- where
- makeLink tag url count _ _ = renderHtml $
- H.a ! A.href (toValue url) $ toHtml (tag ++ " (" ++ show count ++ ")")
-
-
---------------------------------------------------------------------------------
--- | Render tags with links with custom functions to get tags and to
--- render links
-tagsFieldWith :: (Identifier -> Compiler [String])
- -- ^ Get the tags
- -> (String -> (Maybe FilePath) -> Maybe H.Html)
- -- ^ Render link for one tag
- -> ([H.Html] -> H.Html)
- -- ^ Concatenate tag links
- -> String
- -- ^ Destination field
- -> Tags
- -- ^ Tags structure
- -> Context a
- -- ^ Resulting context
-tagsFieldWith getTags' renderLink cat key tags = field key $ \item -> do
- tags' <- getTags' $ itemIdentifier item
- links <- forM tags' $ \tag -> do
- route' <- getRoute $ tagsMakeId tags tag
- return $ renderLink tag route'
-
- return $ renderHtml $ cat $ catMaybes $ links
-
-
---------------------------------------------------------------------------------
--- | Render tags with links
-tagsField :: String -- ^ Destination key
- -> Tags -- ^ Tags
- -> Context a -- ^ Context
-tagsField =
- tagsFieldWith getTags simpleRenderLink (mconcat . intersperse ", ")
-
-
---------------------------------------------------------------------------------
--- | Render the category in a link
-categoryField :: String -- ^ Destination key
- -> Tags -- ^ Tags
- -> Context a -- ^ Context
-categoryField =
- tagsFieldWith getCategory simpleRenderLink (mconcat . intersperse ", ")
-
-
---------------------------------------------------------------------------------
--- | Render one tag link
-simpleRenderLink :: String -> (Maybe FilePath) -> Maybe H.Html
-simpleRenderLink _ Nothing = Nothing
-simpleRenderLink tag (Just filePath) =
- Just $ H.a ! A.href (toValue $ toUrl filePath) $ toHtml tag
-
-
---------------------------------------------------------------------------------
--- | Sort tags using supplied function. First element of the tuple passed to
--- the comparing function is the actual tag name.
-sortTagsBy :: ((String, [Identifier]) -> (String, [Identifier]) -> Ordering)
- -> Tags -> Tags
-sortTagsBy f t = t {tagsMap = sortBy f (tagsMap t)}
-
-
---------------------------------------------------------------------------------
--- | Sample sorting function that compares tags case insensitively.
-caseInsensitiveTags :: (String, [Identifier]) -> (String, [Identifier])
- -> Ordering
-caseInsensitiveTags = comparing $ map toLower . fst
diff --git a/src/Hakyll/Web/Template.hs b/src/Hakyll/Web/Template.hs
deleted file mode 100644
--- a/src/Hakyll/Web/Template.hs
+++ /dev/null
@@ -1,263 +0,0 @@
--- | This module provides means for reading and applying 'Template's.
---
--- Templates are tools to convert items into a string. They are perfectly suited
--- for laying out your site.
---
--- Let's look at an example template:
---
--- >
--- >
--- >
--- > My crazy homepage - $title$
--- >
--- > $body$
--- >
--- >
--- >
--- >
---
--- As you can see, the format is very simple -- @$key$@ is used to render the
--- @$key$@ field from the page, everything else is literally copied. If you want
--- to literally insert @\"$key$\"@ into your page (for example, when you're
--- writing a Hakyll tutorial) you can use
---
--- > ![](\"./image.png)
![](\"/image.png)
A h1 title
" @=?
- demoteHeaders "A h1 title
"
+ demoteHeaders "A h1 title
" -- Assert single-step demotion
+ , "A h6 title
" @=?
+ demoteHeaders "A h6 title
" -- Assert maximum demotion is h6
]
+ , fromAssertions "demoteHeadersBy"
+ [ "A h1 title
" @=?
+ demoteHeadersBy 2 "A h1 title
"
+ , "A h5 title
" @=?
+ demoteHeadersBy 2 "A h5 title
" -- Assert that h6 is the lowest possible demoted header.
+ , "A h4 title
" @=?
+ demoteHeadersBy 0 "A h4 title
" -- Assert that a demotion of @N < 1@ is a no-op.
+ ]
+
+ , fromAssertions "getUrls"
+ [ ["/image1.png", "/image2.jpeg", "https://example.com", "/game.swf", "/poster.jpeg"] @=?
+ getUrls [
+ TS.TagOpen "img" [("src", "/image1.png")]
+ , TS.TagOpen "img" [("src", "/image2.jpeg")]
+ , TS.TagOpen "a" [("href", "https://example.com")]
+ , TS.TagOpen "object" [("data", "/game.swf")]
+ , TS.TagOpen "video" [("poster", "/poster.jpeg")]
+ ]
+ , ["/image1.png", "/image2.jpeg", "/image3.bmp"] @=?
+ getUrls [ TS.TagOpen "img" [("srcset", "/image1.png 10w, /image2.jpeg, /image3.bmp 1.3x")] ]
+
+ -- Invalid srcset specification means no URLs are extracted
+ , [] @=?
+ getUrls [ TS.TagOpen "img" [("srcset", "/image1.png 10wide, /image2.jpeg, /image3.bmp 1.3px")] ]
+ ]
+
, fromAssertions "withUrls"
[ "bar" @=?
withUrls (map toUpper) "bar"
@@ -40,10 +69,21 @@
-- Test minimizing elements
, "" @=?
withUrls id ""
+
+ -- Test that URLs are extracted from img's srcset
+ , "" @=?
+ withUrls (const "foo") "
![](\"/path/to/image.png)
" @=?
+ withUrls (const "bar") "
![](\"/small.jpeg)
![](\"/image1.png)
This page cites a paper.
+
+
+
+
diff --git a/tests/data/biblio/cites-meijer-pandoc-3.0.0plus.golden b/tests/data/biblio/cites-meijer-pandoc-3.0.0plus.golden
new file mode 100644
--- /dev/null
+++ b/tests/data/biblio/cites-meijer-pandoc-3.0.0plus.golden
@@ -0,0 +1,16 @@
+
+
+
+
+
+Meijer, Erik, Maarten Fokkinga, and Ross Paterson. 1991. “Functional Programming with Bananas, Lenses, Envelopes and Barbed Wire.” In Conference on Functional Programming Languages and Computer Architecture, 124–44. Springer.
+
+This page cites a paper.
+
+
+
+
diff --git a/tests/data/biblio/cites-meijer-pandoc-3.1.8plus.golden b/tests/data/biblio/cites-meijer-pandoc-3.1.8plus.golden
new file mode 100644
--- /dev/null
+++ b/tests/data/biblio/cites-meijer-pandoc-3.1.8plus.golden
@@ -0,0 +1,16 @@
+
+
+
+
+
+Meijer, Erik, Maarten Fokkinga, and Ross Paterson. 1991. “Functional Programming with Bananas, Lenses, Envelopes and Barbed Wire.” In Conference on Functional Programming Languages and Computer Architecture, 124–44. Springer.
+
+This page cites a paper.
+
+
+
+
diff --git a/tests/data/biblio/cites-multiple-pandoc-2.0.0plus.golden b/tests/data/biblio/cites-multiple-pandoc-2.0.0plus.golden
new file mode 100644
--- /dev/null
+++ b/tests/data/biblio/cites-multiple-pandoc-2.0.0plus.golden
@@ -0,0 +1,20 @@
+
+
+
+
+
+Meijer, Erik, Maarten Fokkinga, and Ross Paterson. 1991. “Functional Programming with Bananas, Lenses, Envelopes and Barbed Wire.” In Conference on Functional Programming Languages and Computer Architecture, 124–44. Springer.
+
+This page cites a paper and a book.
+
+
+
+
diff --git a/tests/data/biblio/cites-multiple-pandoc-3.0.0plus.golden b/tests/data/biblio/cites-multiple-pandoc-3.0.0plus.golden
new file mode 100644
--- /dev/null
+++ b/tests/data/biblio/cites-multiple-pandoc-3.0.0plus.golden
@@ -0,0 +1,20 @@
+
+
+
+
+
+Lipovača, Miran. 2012. Learn You a Haskell for Great Good! A Beginner’s Guide. San Francisco, CA: No Starch Press.
+
+
+Meijer, Erik, Maarten Fokkinga, and Ross Paterson. 1991. “Functional Programming with Bananas, Lenses, Envelopes and Barbed Wire.” In Conference on Functional Programming Languages and Computer Architecture, 124–44. Springer.
+
+This page cites a paper and a book.
+
+
+
+
diff --git a/tests/data/biblio/cites-multiple-pandoc-3.1.8plus.golden b/tests/data/biblio/cites-multiple-pandoc-3.1.8plus.golden
new file mode 100644
--- /dev/null
+++ b/tests/data/biblio/cites-multiple-pandoc-3.1.8plus.golden
@@ -0,0 +1,20 @@
+
+
+
+
+
+Lipovača, Miran. 2012. Learn You a Haskell for Great Good! A Beginner’s Guide. San Francisco, CA: No Starch Press.
+
+
+Meijer, Erik, Maarten Fokkinga, and Ross Paterson. 1991. “Functional Programming with Bananas, Lenses, Envelopes and Barbed Wire.” In Conference on Functional Programming Languages and Computer Architecture, 124–44. Springer.
+
+This page cites a paper and a book.
+
+
+
+
diff --git a/tests/data/biblio/cites-multiple.markdown b/tests/data/biblio/cites-multiple.markdown
new file mode 100644
--- /dev/null
+++ b/tests/data/biblio/cites-multiple.markdown
@@ -0,0 +1,7 @@
+---
+title: This page cites a paper and a book.
+---
+
+I would like to cite one of my favourite papers [@meijer1991functional] here.
+
+And also a book [@lipovaca2012].
diff --git a/tests/data/biblio/default.html b/tests/data/biblio/default.html
new file mode 100644
--- /dev/null
+++ b/tests/data/biblio/default.html
@@ -0,0 +1,11 @@
+
+
+
+
+
+Lipovača, Miran. 2012. Learn You a Haskell for Great Good! A Beginner’s Guide. San Francisco, CA: No Starch Press.
+
+
+Meijer, Erik, Maarten Fokkinga, and Ross Paterson. 1991. “Functional Programming with Bananas, Lenses, Envelopes and Barbed Wire.” In Conference on Functional Programming Languages and Computer Architecture, 124–44. Springer.
+
+$title$
+ $body$
+
+
diff --git a/tests/data/biblio/page.markdown b/tests/data/biblio/page.markdown
new file mode 100644
--- /dev/null
+++ b/tests/data/biblio/page.markdown
@@ -0,0 +1,5 @@
+---
+title: This page cites a paper.
+---
+
+I would like to cite one of my favourite papers [@meijer1991functional] here.
diff --git a/tests/data/biblio/refs.bib b/tests/data/biblio/refs.bib
new file mode 100644
--- /dev/null
+++ b/tests/data/biblio/refs.bib
@@ -0,0 +1,8 @@
+@inproceedings{meijer1991functional,
+ title={Functional programming with bananas, lenses, envelopes and barbed wire},
+ author={Meijer, Erik and Fokkinga, Maarten and Paterson, Ross},
+ booktitle={Conference on Functional Programming Languages and Computer Architecture},
+ pages={124--144},
+ year={1991},
+ organization={Springer}
+}
diff --git a/tests/data/biblio/refs.yaml b/tests/data/biblio/refs.yaml
new file mode 100644
--- /dev/null
+++ b/tests/data/biblio/refs.yaml
@@ -0,0 +1,18 @@
+---
+references:
+- id: meijer1991functional
+ author:
+ - family: Meijer
+ given: Erik
+ - family: Fokkinga
+ given: Maarten
+ - family: Paterson
+ given: Ross
+ container-title: Conference on functional programming languages and computer architecture
+ issued:
+ - year: 1991
+ page: 124–144
+ publisher: Springer
+ title: Functional programming with bananas, lenses, envelopes and barbed wire
+ type: paper-conference
+...
diff --git a/tests/data/biblio/refs2.yaml b/tests/data/biblio/refs2.yaml
new file mode 100644
--- /dev/null
+++ b/tests/data/biblio/refs2.yaml
@@ -0,0 +1,18 @@
+---
+references:
+- id: lipovaca2012
+ author:
+ - family: Lipovača
+ given: Miran
+ call-number: QA76.73.H37 L69 2012
+ event-place: San Francisco, CA
+ ISBN: 978-1-59327-283-8
+ issued:
+ - year: 2012
+ number-of-pages: '375'
+ publisher: No Starch Press
+ publisher-place: San Francisco, CA
+ source: Library of Congress ISBN
+ title: Learn you a Haskell for great good! a beginner's guide
+ type: book
+...
diff --git a/tests/data/embed.html b/tests/data/embed.html
new file mode 100644
--- /dev/null
+++ b/tests/data/embed.html
@@ -0,0 +1,1 @@
+
+external: {$external$}
+date: {$date$}
+subblog: {$subblog$}
+intfield: {$intfield$}
+numfield: {$numfield$}
+
diff --git a/tests/data/just-meta.html.out b/tests/data/just-meta.html.out
new file mode 100644
--- /dev/null
+++ b/tests/data/just-meta.html.out
@@ -0,0 +1,7 @@
+
+external: {External data}
+date: {2012-10-22 14:35:24}
+subblog: {food}
+intfield: {42}
+numfield: {3.14}
+
diff --git a/tests/data/partial-helper.html b/tests/data/partial-helper.html
new file mode 100644
--- /dev/null
+++ b/tests/data/partial-helper.html
@@ -0,0 +1,3 @@
+
+ I'm so rich I have $$3.
+
+ $rev("foo")$
+ $-rev(rev("foo"))$
+
+ $if(body)-$
+ I have body
+ $else-$
+ or no
+ $-endif-$
+
+ $if(unbound)$
+ should not be printed
+ $endif$
+
+ $-if(body)-$
+ should be printed
+ $-endif$
+
+
+
diff --git a/tests/data/strip.html.out b/tests/data/strip.html.out
new file mode 100644
--- /dev/null
+++ b/tests/data/strip.html.out
@@ -0,0 +1,18 @@
+
+ $for(authors)-$
+
+
+ $for(authors)-$
+ $name-$
+ $sep$,
+ $-endfor$
+
+ $body$
+
+ I'm so rich I have $3.
+
+ ooffoo
+
+ I have body
+ should be printed
+
+
+
diff --git a/tests/data/template-empty.html b/tests/data/template-empty.html
new file mode 100644
--- /dev/null
+++ b/tests/data/template-empty.html
diff --git a/web/site.hs b/web/site.hs
new file mode 100644
--- /dev/null
+++ b/web/site.hs
@@ -0,0 +1,89 @@
+--------------------------------------------------------------------------------
+{-# LANGUAGE OverloadedStrings #-}
+import Control.Monad (filterM, forM_)
+import Data.List (sortBy)
+import Data.Ord (comparing)
+import Hakyll
+import System.Directory (copyFile)
+import qualified Text.Pandoc as Pandoc
+
+
+--------------------------------------------------------------------------------
+main :: IO ()
+main = hakyllWith config $ do
+ -- Copy CHANGELOG.md here.
+ preprocess $ copyFile "../CHANGELOG.md" "releases.markdown"
+
+ -- CSS
+ match "css/*" $ do
+ route idRoute
+ compile compressCssCompiler
+
+ -- Static directories
+ forM_ ["images/*", "examples/*"] $ \f -> match f $ do
+ route idRoute
+ compile copyFileCompiler
+
+ -- Pages
+ match "*.markdown" $ do
+ route $ setExtension "html"
+ compile $ pandocCompiler
+ >>= loadAndApplyTemplate "templates/default.html" defaultContext
+ >>= relativizeUrls
+
+ -- Tutorials
+ match "tutorials/*" $ do
+ route $ setExtension "html"
+ compile $ pandocCompilerWith defaultHakyllReaderOptions withToc
+ >>= loadAndApplyTemplate "templates/tutorial.html" defaultContext
+ >>= loadAndApplyTemplate "templates/default.html" defaultContext
+ >>= relativizeUrls
+
+ -- Tutorial list
+ create ["tutorials.html"] $ do
+ route idRoute
+ compile $ do
+ ctx <- tutorialsCtx <$>
+ sortBy (comparing itemIdentifier) <$> loadAll "tutorials/*"
+ makeItem ""
+ >>= loadAndApplyTemplate "templates/tutorials.html" ctx
+ >>= loadAndApplyTemplate "templates/default.html" ctx
+ >>= relativizeUrls
+
+ -- Templates
+ match "templates/*" $ compile templateCompiler
+ where
+ withToc = defaultHakyllWriterOptions
+ { Pandoc.writerTableOfContents = True
+ , Pandoc.writerTemplate = Just tocTemplate
+ }
+
+ -- When did it get so hard to compile a string to a Pandoc template?
+ tocTemplate =
+ either error id $ either (error . show) id $
+ Pandoc.runPure $ Pandoc.runWithDefaultPartials $
+ Pandoc.compileTemplate "" "$toc$\n$body$"
+
+
+--------------------------------------------------------------------------------
+config :: Configuration
+config = defaultConfiguration
+ { deployCommand =
+ "rsync --checksum -av _site/* anmitsu:jaspervdj.be/hakyll/"
+ }
+
+
+--------------------------------------------------------------------------------
+-- | Partition tutorials into tutorial series, other articles, external articles
+tutorialsCtx :: [Item String] -> Context String
+tutorialsCtx tuts =
+ constField "title" "Tutorials" <>
+ listField "main" defaultContext (ofType "main") <>
+ listField "articles" defaultContext (ofType "article") <>
+ listField "externals" defaultContext (ofType "external") <>
+ listField "robertwpearce" defaultContext (ofType "robertwpearce") <>
+ defaultContext
+ where
+ ofType ty = filterM (\item -> do
+ mbType <- getMetadataField (itemIdentifier item) "type"
+ return $ Just ty == mbType) tuts
+
+
+ Jan,Piet
+
+