summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJasper Van der Jeugt <jaspervdj@gmail.com>2010-12-13 20:41:26 +0100
committerJasper Van der Jeugt <jaspervdj@gmail.com>2010-12-13 20:41:26 +0100
commit0da0dd469de6f3c7439099900676deb8a667bbe6 (patch)
tree4f9ccb9ec621ac70591d0bed62176df4d35a54b9
parent18ec821d02e007dd1a1db983daf504407e70732e (diff)
downloadhakyll-0da0dd469de6f3c7439099900676deb8a667bbe6.tar.gz
Experimental changes for a re-write
-rw-r--r--src/Text/Hakyll/File.hs2
-rw-r--r--src/Text/Hakyll/HakyllAction.hs98
-rw-r--r--src/Text/Hakyll/Monad.hs (renamed from src/Text/Hakyll/HakyllMonad.hs)28
-rw-r--r--src/Text/Hakyll/Pandoc.hs31
-rw-r--r--src/Text/Hakyll/Resource.hs60
-rw-r--r--src/Text/Hakyll/Transformer.hs97
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