From 0da0dd469de6f3c7439099900676deb8a667bbe6 Mon Sep 17 00:00:00 2001
From: Jasper Van der Jeugt <jaspervdj@gmail.com>
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

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