More arrows
This commit is contained in:
parent
6268e4a4fe
commit
1c1133dfd6
4 changed files with 77 additions and 38 deletions
|
@ -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.
|
||||
--
|
||||
|
|
|
@ -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
|
||||
|
|
28
src/Hakyll/Core/Util/Arrow.hs
Normal file
28
src/Hakyll/Core/Util/Arrow.hs
Normal file
|
@ -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
|
|
@ -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
|
||||
--
|
||||
|
|
Loading…
Reference in a new issue