diff options
Diffstat (limited to 'src')
-rw-r--r-- | src/Text/Hakyll/File.hs | 2 | ||||
-rw-r--r-- | src/Text/Hakyll/HakyllAction.hs | 98 | ||||
-rw-r--r-- | src/Text/Hakyll/Monad.hs (renamed from src/Text/Hakyll/HakyllMonad.hs) | 28 | ||||
-rw-r--r-- | src/Text/Hakyll/Pandoc.hs | 31 | ||||
-rw-r--r-- | src/Text/Hakyll/Resource.hs | 60 | ||||
-rw-r--r-- | src/Text/Hakyll/Transformer.hs | 97 |
6 files changed, 211 insertions, 105 deletions
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/Monad.hs index f51cf2c..5de5e44 100644 --- a/src/Text/Hakyll/HakyllMonad.hs +++ b/src/Text/Hakyll/Monad.hs @@ -1,5 +1,6 @@ -- | Module describing the Hakyll monad stack. -module Text.Hakyll.HakyllMonad +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Text.Hakyll.Monad ( HakyllConfiguration (..) , PreviewMode (..) , Hakyll @@ -11,6 +12,7 @@ module Text.Hakyll.HakyllMonad ) 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_) @@ -24,7 +26,16 @@ import Text.Hakyll.Context (Context (..)) -- | Our custom monad stack. -- -type Hakyll = ReaderT HakyllConfiguration IO +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. -- @@ -56,6 +67,11 @@ data HakyllConfiguration = HakyllConfiguration 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: @@ -66,7 +82,7 @@ data HakyllConfiguration = HakyllConfiguration -- > ... -- askHakyll :: (HakyllConfiguration -> a) -> Hakyll a -askHakyll = flip liftM ask +askHakyll = flip liftM getHakyllConfiguration -- | Obtain the globally available, additional context. -- @@ -78,16 +94,16 @@ getAdditionalContext configuration = -- | Write some log information. -- logHakyll :: String -> Hakyll () -logHakyll = liftIO . hPutStrLn stderr +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 <- ask + config <- getHakyllConfiguration liftIO $ do - runReaderT action config + runHakyll action config putMVar mvar () return mvar 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 |