From 0da0dd469de6f3c7439099900676deb8a667bbe6 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Mon, 13 Dec 2010 20:41:26 +0100 Subject: Experimental changes for a re-write --- src/Text/Hakyll/File.hs | 2 +- src/Text/Hakyll/HakyllAction.hs | 98 ---------------------------------- src/Text/Hakyll/HakyllMonad.hs | 99 ---------------------------------- src/Text/Hakyll/Monad.hs | 115 ++++++++++++++++++++++++++++++++++++++++ src/Text/Hakyll/Pandoc.hs | 31 +++++++++++ src/Text/Hakyll/Resource.hs | 60 +++++++++++++++++++++ src/Text/Hakyll/Transformer.hs | 97 +++++++++++++++++++++++++++++++++ 7 files changed, 304 insertions(+), 198 deletions(-) delete mode 100644 src/Text/Hakyll/HakyllAction.hs delete mode 100644 src/Text/Hakyll/HakyllMonad.hs create mode 100644 src/Text/Hakyll/Monad.hs create mode 100644 src/Text/Hakyll/Resource.hs create mode 100644 src/Text/Hakyll/Transformer.hs (limited to 'src/Text') diff --git a/src/Text/Hakyll/File.hs b/src/Text/Hakyll/File.hs index 167ece7..747608c 100644 --- a/src/Text/Hakyll/File.hs +++ b/src/Text/Hakyll/File.hs @@ -26,7 +26,7 @@ import Data.List (isPrefixOf, sortBy) import Data.Ord (comparing) import Control.Monad.Reader (liftIO) -import Text.Hakyll.HakyllMonad +import Text.Hakyll.Monad import Text.Hakyll.Internal.FileType (isRenderableFile) -- | Auxiliary function to remove pathSeparators form the start. We don't deal diff --git a/src/Text/Hakyll/HakyllAction.hs b/src/Text/Hakyll/HakyllAction.hs deleted file mode 100644 index 491f1f1..0000000 --- a/src/Text/Hakyll/HakyllAction.hs +++ /dev/null @@ -1,98 +0,0 @@ --- | This is the module which exports @HakyllAction@. -module Text.Hakyll.HakyllAction - ( HakyllAction (..) - , createHakyllAction - , createSimpleHakyllAction - , createFileHakyllAction - , chain - , runHakyllAction - , runHakyllActionIfNeeded - ) where - -import Control.Arrow -import Control.Category -import Control.Monad ((<=<), unless) -import Prelude hiding ((.), id) - -import Text.Hakyll.File (toDestination, isFileMoreRecent) -import Text.Hakyll.HakyllMonad - --- | Type used for rendering computations that carry along dependencies. -data HakyllAction a b = HakyllAction - { -- | Dependencies of the @HakyllAction@. - actionDependencies :: [FilePath] - , -- | URL pointing to the result of this @HakyllAction@. - actionUrl :: Either (Hakyll FilePath) - (Hakyll FilePath -> Hakyll FilePath) - , -- | The actual render function. - actionFunction :: a -> Hakyll b - } - --- | Create a @HakyllAction@ from a function. -createHakyllAction :: (a -> Hakyll b) -- ^ Function to execute. - -> HakyllAction a b -createHakyllAction f = id { actionFunction = f } - --- | Create a @HakyllAction@ from a simple @Hakyll@ value. -createSimpleHakyllAction :: Hakyll b -- ^ Hakyll value to pass on. - -> HakyllAction () b -createSimpleHakyllAction = createHakyllAction . const - --- | Create a @HakyllAction@ that operates on one file. -createFileHakyllAction :: FilePath -- ^ File to operate on. - -> Hakyll b -- ^ Value to pass on. - -> HakyllAction () b -- ^ The resulting action. -createFileHakyllAction path action = HakyllAction - { actionDependencies = [path] - , actionUrl = Left $ return path - , actionFunction = const action - } - --- | Run a @HakyllAction@ now. -runHakyllAction :: HakyllAction () a -- ^ Render action to run. - -> Hakyll a -- ^ Result of the action. -runHakyllAction action = actionFunction action () - --- | Run a @HakyllAction@, but only when it is out-of-date. At this point, the --- @actionUrl@ field must be set. -runHakyllActionIfNeeded :: HakyllAction () () -- ^ Action to run. - -> Hakyll () -- ^ Empty result. -runHakyllActionIfNeeded action = do - url <- case actionUrl action of - Left u -> u - Right _ -> error "No url when checking dependencies." - destination <- toDestination url - valid <- isFileMoreRecent destination $ actionDependencies action - unless valid $ do logHakyll $ "Rendering " ++ destination - runHakyllAction action - --- | Chain a number of @HakyllAction@ computations. -chain :: [HakyllAction a a] -- ^ Actions to chain. - -> HakyllAction a a -- ^ Resulting action. -chain [] = id -chain list = foldl1 (>>>) list - -instance Category HakyllAction where - id = HakyllAction - { actionDependencies = [] - , actionUrl = Right id - , actionFunction = return - } - - x . y = HakyllAction - { actionDependencies = actionDependencies x ++ actionDependencies y - , actionUrl = case actionUrl x of - Left ux -> Left ux - Right fx -> case actionUrl y of - Left uy -> Left (fx uy) - Right fy -> Right (fx . fy) - , actionFunction = actionFunction x <=< actionFunction y - } - -instance Arrow HakyllAction where - arr f = id { actionFunction = return . f } - - first x = x - { actionFunction = \(y, z) -> do y' <- actionFunction x y - return (y', z) - } diff --git a/src/Text/Hakyll/HakyllMonad.hs b/src/Text/Hakyll/HakyllMonad.hs deleted file mode 100644 index f51cf2c..0000000 --- a/src/Text/Hakyll/HakyllMonad.hs +++ /dev/null @@ -1,99 +0,0 @@ --- | Module describing the Hakyll monad stack. -module Text.Hakyll.HakyllMonad - ( HakyllConfiguration (..) - , PreviewMode (..) - , Hakyll - , askHakyll - , getAdditionalContext - , logHakyll - , forkHakyllWait - , concurrentHakyll - ) where - -import Control.Monad.Trans (liftIO) -import Control.Concurrent.MVar (MVar, putMVar, newEmptyMVar, readMVar) -import Control.Monad.Reader (ReaderT, ask, runReaderT) -import Control.Monad (liftM, forM, forM_) -import qualified Data.Map as M -import System.IO (hPutStrLn, stderr) - -import Text.Pandoc (ParserState, WriterOptions) -import Text.Hamlet (HamletSettings) - -import Text.Hakyll.Context (Context (..)) - --- | Our custom monad stack. --- -type Hakyll = ReaderT HakyllConfiguration IO - --- | Preview mode. --- -data PreviewMode = BuildOnRequest - | BuildOnInterval - deriving (Show, Eq, Ord) - --- | Hakyll global configuration type. --- -data HakyllConfiguration = HakyllConfiguration - { -- | Absolute URL of the site. - absoluteUrl :: String - , -- | An additional context to use when rendering. This additional context - -- is used globally. - additionalContext :: Context - , -- | Directory where the site is placed. - siteDirectory :: FilePath - , -- | Directory for cache files. - cacheDirectory :: FilePath - , -- | Enable index links. - enableIndexUrl :: Bool - , -- | The preview mode used - previewMode :: PreviewMode - , -- | Pandoc parsing options - pandocParserState :: ParserState - , -- | Pandoc writer options - pandocWriterOptions :: WriterOptions - , -- | Hamlet settings (if you use hamlet for templates) - hamletSettings :: HamletSettings - } - --- | Simplified @ask@ function for the Hakyll monad stack. --- --- Usage would typically be something like: --- --- > doSomething :: a -> b -> Hakyll c --- > doSomething arg1 arg2 = do --- > siteDirectory' <- askHakyll siteDirectory --- > ... --- -askHakyll :: (HakyllConfiguration -> a) -> Hakyll a -askHakyll = flip liftM ask - --- | Obtain the globally available, additional context. --- -getAdditionalContext :: HakyllConfiguration -> Context -getAdditionalContext configuration = - let (Context c) = additionalContext configuration - in Context $ M.insert "absolute" (absoluteUrl configuration) c - --- | Write some log information. --- -logHakyll :: String -> Hakyll () -logHakyll = liftIO . hPutStrLn stderr - --- | Perform a concurrent hakyll action. Returns an MVar you can wait on --- -forkHakyllWait :: Hakyll () -> Hakyll (MVar ()) -forkHakyllWait action = do - mvar <- liftIO newEmptyMVar - config <- ask - liftIO $ do - runReaderT action config - putMVar mvar () - return mvar - --- | Perform a number of concurrent hakyll actions, and waits for them to finish --- -concurrentHakyll :: [Hakyll ()] -> Hakyll () -concurrentHakyll actions = do - mvars <- forM actions forkHakyllWait - forM_ mvars (liftIO . readMVar) diff --git a/src/Text/Hakyll/Monad.hs b/src/Text/Hakyll/Monad.hs new file mode 100644 index 0000000..5de5e44 --- /dev/null +++ b/src/Text/Hakyll/Monad.hs @@ -0,0 +1,115 @@ +-- | Module describing the Hakyll monad stack. +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Text.Hakyll.Monad + ( HakyllConfiguration (..) + , PreviewMode (..) + , Hakyll + , askHakyll + , getAdditionalContext + , logHakyll + , forkHakyllWait + , concurrentHakyll + ) where + +import Control.Monad.Trans (liftIO) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Concurrent.MVar (MVar, putMVar, newEmptyMVar, readMVar) +import Control.Monad.Reader (ReaderT, ask, runReaderT) +import Control.Monad (liftM, forM, forM_) +import qualified Data.Map as M +import System.IO (hPutStrLn, stderr) + +import Text.Pandoc (ParserState, WriterOptions) +import Text.Hamlet (HamletSettings) + +import Text.Hakyll.Context (Context (..)) + +-- | Our custom monad stack. +-- +newtype Hakyll a = Hakyll (ReaderT HakyllConfiguration IO a) + deriving (Monad, Functor) + +instance MonadIO Hakyll where + liftIO = Hakyll . liftIO + +-- | Run a hakyll stack +-- +runHakyll :: Hakyll a -> HakyllConfiguration -> IO a +runHakyll (Hakyll h) = runReaderT h + +-- | Preview mode. +-- +data PreviewMode = BuildOnRequest + | BuildOnInterval + deriving (Show, Eq, Ord) + +-- | Hakyll global configuration type. +-- +data HakyllConfiguration = HakyllConfiguration + { -- | Absolute URL of the site. + absoluteUrl :: String + , -- | An additional context to use when rendering. This additional context + -- is used globally. + additionalContext :: Context + , -- | Directory where the site is placed. + siteDirectory :: FilePath + , -- | Directory for cache files. + cacheDirectory :: FilePath + , -- | Enable index links. + enableIndexUrl :: Bool + , -- | The preview mode used + previewMode :: PreviewMode + , -- | Pandoc parsing options + pandocParserState :: ParserState + , -- | Pandoc writer options + pandocWriterOptions :: WriterOptions + , -- | Hamlet settings (if you use hamlet for templates) + hamletSettings :: HamletSettings + } + +-- | Get the hakyll configuration +-- +getHakyllConfiguration :: Hakyll HakyllConfiguration +getHakyllConfiguration = Hakyll ask + +-- | Simplified @ask@ function for the Hakyll monad stack. +-- +-- Usage would typically be something like: +-- +-- > doSomething :: a -> b -> Hakyll c +-- > doSomething arg1 arg2 = do +-- > siteDirectory' <- askHakyll siteDirectory +-- > ... +-- +askHakyll :: (HakyllConfiguration -> a) -> Hakyll a +askHakyll = flip liftM getHakyllConfiguration + +-- | Obtain the globally available, additional context. +-- +getAdditionalContext :: HakyllConfiguration -> Context +getAdditionalContext configuration = + let (Context c) = additionalContext configuration + in Context $ M.insert "absolute" (absoluteUrl configuration) c + +-- | Write some log information. +-- +logHakyll :: String -> Hakyll () +logHakyll = Hakyll . liftIO . hPutStrLn stderr + +-- | Perform a concurrent hakyll action. Returns an MVar you can wait on +-- +forkHakyllWait :: Hakyll () -> Hakyll (MVar ()) +forkHakyllWait action = do + mvar <- liftIO newEmptyMVar + config <- getHakyllConfiguration + liftIO $ do + runHakyll action config + putMVar mvar () + return mvar + +-- | Perform a number of concurrent hakyll actions, and waits for them to finish +-- +concurrentHakyll :: [Hakyll ()] -> Hakyll () +concurrentHakyll actions = do + mvars <- forM actions forkHakyllWait + forM_ mvars (liftIO . readMVar) diff --git a/src/Text/Hakyll/Pandoc.hs b/src/Text/Hakyll/Pandoc.hs index c0dec77..af4be62 100644 --- a/src/Text/Hakyll/Pandoc.hs +++ b/src/Text/Hakyll/Pandoc.hs @@ -17,6 +17,30 @@ import Text.Hakyll.HakyllMonad import Text.Hakyll.HakyllAction import Text.Hakyll.Context +-- | Reader function for plain text +-- +readText :: ParserState -> String -> Pandoc +readText _ = Pandoc (Meta [] [] []) . return . Plain . return . Str + +-- | Get a read function for a given extension. +-- +readPandoc :: HakyllAction (FileType, String) Pandoc +readPandoc = createHakyllAction $ \(fileType, inp) -> do + parserState <- askHakyll pandocParserState + return $ readFunction fileType (readOptions parserState fileType) inp + where + readFunction ReStructuredText = readRST + readFunction LaTeX = readLaTeX + readFunction Markdown = readMarkdown + readFunction LiterateHaskellMarkdown = readMarkdown + readFunction Html = readHtml + readFunction Text = readText + readFunction t = error $ "Cannot render " ++ show t + + readOptions options LiterateHaskellMarkdown = options + { stateLiterateHaskell = True } + readOptions options _ = options + -- | Get a render function for a given extension. -- getRenderFunction :: HakyllAction FileType (String -> String) @@ -39,6 +63,13 @@ getRenderFunction = createHakyllAction $ \fileType -> case fileType of { stateLiterateHaskell = True } readOptions options _ = options +-- | Get a render action +-- +renderPandoc :: HakyllAction Pandoc String +renderPandoc = createHakyllAction $ \p -> do + writerOptions <- askHakyll pandocWriterOptions + return $ writeHtmlString writerOptions p + -- | An action that renders the list of page sections to a context using pandoc -- renderAction :: HakyllAction [PageSection] Context diff --git a/src/Text/Hakyll/Resource.hs b/src/Text/Hakyll/Resource.hs new file mode 100644 index 0000000..a8a77b2 --- /dev/null +++ b/src/Text/Hakyll/Resource.hs @@ -0,0 +1,60 @@ +-- | A resource represents data for a website +-- +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Text.Hakyll.Resource + ( Metadata (..) + , Resource (..) + , getData + , getMetadata + , getMetadataList + ) where + +import Data.Monoid (Monoid, mempty, mappend) +import Control.Applicative (Applicative, (<*>), pure) + +-- | Metadata for a resource +-- +newtype Metadata = Metadata {unMetadata :: [(String, String)]} + deriving (Show, Eq, Ord, Monoid) + +-- | A resource represents a data source for the website. It contains a value +-- and a number of metadata fields +-- +data Resource a = Resource + { resourceMetadata :: Metadata + , resourceData :: a + } deriving (Show, Eq, Ord) + +instance Functor Resource where + fmap f (Resource m d) = Resource m $ f d + +instance Applicative Resource where + pure d = Resource mempty d + (Resource m1 f) <*> (Resource m2 d) = Resource (mappend m2 m1) (f d) + +instance Monad Resource where + return d = Resource mempty d + (Resource m1 d) >>= f = let Resource m2 d' = f d + in Resource (mappend m2 m1) d' + +instance Monoid a => Monoid (Resource a) where + mempty = Resource mempty mempty + mappend (Resource m1 d1) (Resource m2 d2) = + Resource (mappend m1 m2) (mappend d1 d2) + +-- | Get the data from a resource +-- +getData :: Resource a -> a +getData = resourceData + +-- | Get a metadata field from a resource +-- +getMetadata :: String -> Resource a -> Maybe String +getMetadata k (Resource m _) = lookup k $ unMetadata m + +-- | Get a metadata field from a resource. If multiple fields with the same name +-- exist, they will all be returned +-- +getMetadataList :: String -> Resource a -> [String] +getMetadataList k = map snd . filter ((== k) . fst) + . unMetadata . resourceMetadata diff --git a/src/Text/Hakyll/Transformer.hs b/src/Text/Hakyll/Transformer.hs new file mode 100644 index 0000000..fff8470 --- /dev/null +++ b/src/Text/Hakyll/Transformer.hs @@ -0,0 +1,97 @@ +-- | This is the module which exports @Transformer@. +module Text.Hakyll.Transformer + ( Transformer (..) + , transformResource + , transformResourceM + , transformData + , transformDataM + , transformMetaData + , transformMetaDataM + , runTransformer + , runTransformerForced + ) where + +import Data.Monoid (mappend, mempty) +import Control.Arrow +import Control.Category +import Control.Applicative ((<$>)) +import Control.Monad ((<=<), unless) +import Prelude hiding ((.), id) + +import Text.Hakyll.Resource +import Text.Hakyll.File (toDestination, isFileMoreRecent) +import Text.Hakyll.Monad + +-- | Type used for computations that transform resources, carrying along +-- dependencies. +-- +data Transformer a b = Transformer + { -- | Dependencies of the @Transformer@. + transformerDependencies :: [FilePath] + , -- | URL pointing to the result of this @Transformer@. + transformerUrl :: FilePath -> Hakyll FilePath + , -- | The actual transforming function. + transformerFunction :: Resource a -> Hakyll (Resource b) + } + +instance Category Transformer where + id = Transformer + { transformerDependencies = [] + , transformerUrl = return + , transformerFunction = return + } + + x . y = Transformer + { transformerDependencies = + transformerDependencies x ++ transformerDependencies y + , transformerUrl = transformerUrl y <=< transformerUrl x + , transformerFunction = transformerFunction x <=< transformerFunction y + } + +instance Arrow Transformer where + arr = transformData + + first t = t + { transformerFunction = \(Resource m (x, y)) -> do + Resource m' x' <- transformerFunction t $ Resource m x + return $ Resource (mappend m' m) (x', y) + } + +transformResource :: (Resource a -> Resource b) -> Transformer a b +transformResource = transformResourceM . (return .) + +transformResourceM :: (Resource a -> Hakyll (Resource b)) -> Transformer a b +transformResourceM f = id {transformerFunction = f} + +transformData :: (a -> b) -> Transformer a b +transformData = transformResource . fmap + +transformDataM :: (a -> Hakyll b) -> Transformer a b +transformDataM f = transformResourceM $ \(Resource m x) -> + f x >>= return . Resource m + +transformMetaData :: (Metadata -> Metadata) -> Transformer a a +transformMetaData = transformMetaDataM . (return .) + +transformMetaDataM :: (Metadata -> Hakyll Metadata) -> Transformer a a +transformMetaDataM f = transformResourceM $ \(Resource m x) -> do + m' <- f m + return $ Resource m' x + +-- | Run a transformer. This might not run it when the result is up-to-date +-- +runTransformer :: Transformer () () + -> Hakyll () +runTransformer t = do + url <- transformerUrl t $ + error "runTransformer: No url when checking dependencies." + destination <- toDestination url + valid <- isFileMoreRecent destination $ transformerDependencies t + unless valid $ do logHakyll $ "Rendering " ++ destination + runTransformerForced t + +-- | Always run the transformer, even when the target is up-to-date +-- +runTransformerForced :: Transformer () () + -> Hakyll () +runTransformerForced t = getData <$> transformerFunction t mempty -- cgit v1.2.3