Experimental changes for a re-write

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