diff --git a/src/Hakyll/Core/Compiler.hs b/src/Hakyll/Core/Compiler.hs index c4a7b06..a2875ba 100644 --- a/src/Hakyll/Core/Compiler.hs +++ b/src/Hakyll/Core/Compiler.hs @@ -6,10 +6,11 @@ module Hakyll.Core.Compiler , CompilerM , Compiler (..) , runCompiler + , getDependencies , getIdentifier , getResourceString , require - -- , requireAll + , requireAll -- , compileFromString ) where @@ -17,9 +18,9 @@ import Prelude hiding ((.), id) import Control.Arrow (second, (>>>)) import Control.Applicative (Applicative, (<$>)) import Control.Monad.State (State, modify, runState) -import Control.Monad.Reader (ReaderT, ask, runReaderT) +import Control.Monad.Reader (ReaderT, Reader, ask, runReaderT, runReader) import Control.Monad.Trans (liftIO) -import Control.Monad ((<=<)) +import Control.Monad ((<=<), liftM2) import Data.Set (Set) import qualified Data.Set as S import Control.Category (Category, (.), id) @@ -59,18 +60,17 @@ newtype CompilerM a = CompilerM -- | The compiler arrow -- data Compiler a b = Compiler - { -- TODO: Reader ResourceProvider Dependencies - compilerDependencies :: Dependencies + { compilerDependencies :: Reader ResourceProvider Dependencies , compilerJob :: a -> CompilerM b } instance Category Compiler where - id = Compiler S.empty return + id = Compiler (return S.empty) return (Compiler d1 j1) . (Compiler d2 j2) = - Compiler (d1 `S.union` d2) (j1 <=< j2) + Compiler (liftM2 S.union d1 d2) (j1 <=< j2) instance Arrow Compiler where - arr f = Compiler S.empty (return . f) + arr f = Compiler (return S.empty) (return . f) first (Compiler d j) = Compiler d $ \(x, y) -> do x' <- j x return (x', y) @@ -91,13 +91,19 @@ runCompiler compiler identifier provider lookup' = , compilerDependencyLookup = lookup' } -addDependency :: Identifier - -> Compiler b b -addDependency id' = Compiler (S.singleton id') return +getDependencies :: Compiler () a + -> ResourceProvider + -> Dependencies +getDependencies compiler provider = + runReader (compilerDependencies compiler) provider + +addDependencies :: (ResourceProvider -> [Identifier]) + -> Compiler b b +addDependencies deps = Compiler (S.fromList . deps <$> ask) return fromCompilerM :: (a -> CompilerM b) -> Compiler a b -fromCompilerM = Compiler S.empty +fromCompilerM = Compiler (return S.empty) getIdentifier :: Compiler () Identifier getIdentifier = fromCompilerM $ const $ CompilerM $ @@ -115,26 +121,32 @@ getResourceString = getIdentifier >>> getResourceString' -- require :: (Binary a, Typeable a, Writable a) => Identifier - -> (a -> b -> c) + -> (b -> a -> c) -> Compiler b c -require identifier f = addDependency identifier >>> fromCompilerM require' +require identifier f = + addDependencies (const [identifier]) >>> fromCompilerM require' where require' x = CompilerM $ do lookup' <- compilerDependencyLookup <$> ask - return $ f (unCompiledItem $ lookup' identifier) x + return $ f x $ unCompiledItem $ lookup' identifier -{- -- | Require a number of targets. Using this function ensures automatic handling -- of dependencies -- requireAll :: (Binary a, Typeable a, Writable a) => Pattern - -> Compiler [a] -requireAll pattern = CompilerM $ do - provider <- compilerResourceProvider <$> ask - r <- unCompilerM $ mapM require $ matches pattern $ resourceList provider - return $ sequence r + -> (b -> [a] -> c) + -> Compiler b c +requireAll pattern f = + addDependencies getDeps >>> fromCompilerM requireAll' + where + getDeps = matches pattern . resourceList + requireAll' x = CompilerM $ do + deps <- getDeps . compilerResourceProvider <$> ask + lookup' <- compilerDependencyLookup <$> ask + return $ f x $ map (unCompiledItem . lookup') deps +{- -- | Construct a target from a string, this string being the content of the -- resource. -- diff --git a/src/Hakyll/Core/Run.hs b/src/Hakyll/Core/Run.hs index 3bd1e6b..911e2f9 100644 --- a/src/Hakyll/Core/Run.hs +++ b/src/Hakyll/Core/Run.hs @@ -40,7 +40,7 @@ hakyllWith rules provider store = do -- Get all dependencies dependencies = flip map compilers $ \(id', compiler) -> - let deps = compilerDependencies compiler + let deps = getDependencies compiler provider in (id', deps) -- Create a compiler map diff --git a/src/Hakyll/Core/Util/Arrow.hs b/src/Hakyll/Core/Util/Arrow.hs new file mode 100644 index 0000000..d25bc28 --- /dev/null +++ b/src/Hakyll/Core/Util/Arrow.hs @@ -0,0 +1,28 @@ +-- | Various arrow utility functions +-- +module Hakyll.Core.Util.Arrow + ( sequenceArr + , unitArr + , withUnitArr + ) where + +import Prelude hiding (id) +import Control.Arrow (Arrow, (&&&), (>>>), arr, (***)) +import Control.Category (id) + +sequenceArr :: Arrow a + => [a b c] + -> a b [c] +sequenceArr = foldl reduce $ arr $ const [] + where + reduce la xa = xa &&& la >>> arr (uncurry (:)) + +unitArr :: Arrow a + => a b () +unitArr = arr (const ()) + +withUnitArr :: Arrow a + => a b c + -> a () d + -> a b (c, d) +withUnitArr a1 a2 = a1 &&& unitArr >>> id *** a2 diff --git a/src/Hakyll/Web/Pandoc.hs b/src/Hakyll/Web/Pandoc.hs index 653c711..c03c6ca 100644 --- a/src/Hakyll/Web/Pandoc.hs +++ b/src/Hakyll/Web/Pandoc.hs @@ -7,25 +7,27 @@ module Hakyll.Web.Pandoc , writePandoc , writePandocWith - -- * Functions working on pages/targets - {- + -- * Functions working on pages/compilers , pageReadPandoc , pageReadPandocWith , pageRenderPandoc , pageRenderPandocWith - -} -- * Default options , defaultParserState , defaultWriterOptions ) where +import Prelude hiding (id) import Control.Applicative ((<$>)) +import Control.Arrow ((>>>), arr) +import Control.Category (id) import Text.Pandoc (Pandoc) import qualified Text.Pandoc as P import Hakyll.Core.Compiler +import Hakyll.Core.Util.Arrow import Hakyll.Web.FileType import Hakyll.Web.Page @@ -64,34 +66,31 @@ writePandocWith :: P.WriterOptions -- ^ Writer options for pandoc -> String -- ^ Resulting HTML writePandocWith = P.writeHtmlString -{- -- | Read the resource using pandoc -- -pageReadPandoc :: Page String -> TargetM (Page Pandoc) +pageReadPandoc :: Compiler (Page String) (Page Pandoc) pageReadPandoc = pageReadPandocWith defaultParserState -- | Read the resource using pandoc -- -pageReadPandocWith :: P.ParserState -> Page String -> TargetM (Page Pandoc) -pageReadPandocWith state page = do - fileType' <- getFileType - return $ readPandocWith state fileType' <$> page +pageReadPandocWith :: P.ParserState -> Compiler (Page String) (Page Pandoc) +pageReadPandocWith state = + withUnitArr id getFileType >>> arr pageReadPandocWith' + where + pageReadPandocWith' (p, t) = readPandocWith state t <$> p -- | Render the resource using pandoc -- -pageRenderPandoc :: Page String -> TargetM (Page String) +pageRenderPandoc :: Compiler (Page String) (Page String) pageRenderPandoc = pageRenderPandocWith defaultParserState defaultWriterOptions -- | Render the resource using pandoc -- pageRenderPandocWith :: P.ParserState -> P.WriterOptions - -> Page String - -> TargetM (Page String) -pageRenderPandocWith state options page = do - pandoc <- pageReadPandocWith state page - return $ writePandocWith options <$> pandoc --} + -> Compiler (Page String) (Page String) +pageRenderPandocWith state options = + pageReadPandocWith state >>> arr (fmap $ writePandocWith options) -- | The default reader options for pandoc parsing in hakyll --