git.iko.soy/hakyll
on master help sign in
More arrows
1c1133dJasper Van der Jeugt
src/Hakyll/Core/Compiler.hs+33−21
compare with master
unifiedsplit
@@ -6,10 +6,11 @@ module Hakyll.Core.Compiler
6 , CompilerM
6 , CompilerM
7 , Compiler (..)
7 , Compiler (..)
8 , runCompiler
8 , runCompiler
9+ , getDependencies
9 , getIdentifier
10 , getIdentifier
10 , getResourceString
11 , getResourceString
11 , require
12 , require
12− -- , requireAll
13+ , requireAll
13 -- , compileFromString
14 -- , compileFromString
14 ) where
15 ) where
15
16
@@ -17,9 +18,9 @@ import Prelude hiding ((.), id)
17import Control.Arrow (second, (>>>))
18import Control.Arrow (second, (>>>))
18import Control.Applicative (Applicative, (<$>))
19import Control.Applicative (Applicative, (<$>))
19import Control.Monad.State (State, modify, runState)
20import Control.Monad.State (State, modify, runState)
20−import Control.Monad.Reader (ReaderT, ask, runReaderT)
21+import Control.Monad.Reader (ReaderT, Reader, ask, runReaderT, runReader)
21import Control.Monad.Trans (liftIO)
22import Control.Monad.Trans (liftIO)
22−import Control.Monad ((<=<))
23+import Control.Monad ((<=<), liftM2)
23import Data.Set (Set)
24import Data.Set (Set)
24import qualified Data.Set as S
25import qualified Data.Set as S
25import Control.Category (Category, (.), id)
26import Control.Category (Category, (.), id)
@@ -59,18 +60,17 @@ newtype CompilerM a = CompilerM
59-- | The compiler arrow
60-- | The compiler arrow
60--
61--
61data Compiler a b = Compiler
62data Compiler a b = Compiler
62− { -- TODO: Reader ResourceProvider Dependencies
63+ { compilerDependencies :: Reader ResourceProvider Dependencies
63− compilerDependencies :: Dependencies
64 , compilerJob :: a -> CompilerM b
64 , compilerJob :: a -> CompilerM b
65 }
65 }
66
66
67instance Category Compiler where
67instance Category Compiler where
68− id = Compiler S.empty return
68+ id = Compiler (return S.empty) return
69 (Compiler d1 j1) . (Compiler d2 j2) =
69 (Compiler d1 j1) . (Compiler d2 j2) =
70− Compiler (d1 `S.union` d2) (j1 <=< j2)
70+ Compiler (liftM2 S.union d1 d2) (j1 <=< j2)
71
71
72instance Arrow Compiler where
72instance Arrow Compiler where
73− arr f = Compiler S.empty (return . f)
73+ arr f = Compiler (return S.empty) (return . f)
74 first (Compiler d j) = Compiler d $ \(x, y) -> do
74 first (Compiler d j) = Compiler d $ \(x, y) -> do
75 x' <- j x
75 x' <- j x
76 return (x', y)
76 return (x', y)
@@ -91,13 +91,19 @@ runCompiler compiler identifier provider lookup' =
91 , compilerDependencyLookup = lookup'
91 , compilerDependencyLookup = lookup'
92 }
92 }
93
93
94−addDependency :: Identifier
94+getDependencies :: Compiler () a
95+ -> ResourceProvider
96+ -> Dependencies
97+getDependencies compiler provider =
98+ runReader (compilerDependencies compiler) provider
99+
100+addDependencies :: (ResourceProvider -> [Identifier])
95− -> Compiler b b
101+ -> Compiler b b
96−addDependency id' = Compiler (S.singleton id') return
102+addDependencies deps = Compiler (S.fromList . deps <$> ask) return
97
103
98fromCompilerM :: (a -> CompilerM b)
104fromCompilerM :: (a -> CompilerM b)
99 -> Compiler a b
105 -> Compiler a b
100−fromCompilerM = Compiler S.empty
106+fromCompilerM = Compiler (return S.empty)
101
107
102getIdentifier :: Compiler () Identifier
108getIdentifier :: Compiler () Identifier
103getIdentifier = fromCompilerM $ const $ CompilerM $
109getIdentifier = fromCompilerM $ const $ CompilerM $
@@ -115,26 +121,32 @@ getResourceString = getIdentifier >>> getResourceString'
115--
121--
116require :: (Binary a, Typeable a, Writable a)
122require :: (Binary a, Typeable a, Writable a)
117 => Identifier
123 => Identifier
118− -> (a -> b -> c)
124+ -> (b -> a -> c)
119 -> Compiler b c
125 -> Compiler b c
126+require identifier f =
120−require identifier f = addDependency identifier >>> fromCompilerM require'
127+ addDependencies (const [identifier]) >>> fromCompilerM require'
121 where
128 where
122 require' x = CompilerM $ do
129 require' x = CompilerM $ do
123 lookup' <- compilerDependencyLookup <$> ask
130 lookup' <- compilerDependencyLookup <$> ask
124− return $ f (unCompiledItem $ lookup' identifier) x
131+ return $ f x $ unCompiledItem $ lookup' identifier
125
132
126−{-
127-- | Require a number of targets. Using this function ensures automatic handling
133-- | Require a number of targets. Using this function ensures automatic handling
128-- of dependencies
134-- of dependencies
129--
135--
130requireAll :: (Binary a, Typeable a, Writable a)
136requireAll :: (Binary a, Typeable a, Writable a)
131 => Pattern
137 => Pattern
132− -> Compiler [a]
138+ -> (b -> [a] -> c)
139+ -> Compiler b c
133−requireAll pattern = CompilerM $ do
140+requireAll pattern f =
141+ addDependencies getDeps >>> fromCompilerM requireAll'
142+ where
143+ getDeps = matches pattern . resourceList
144+ requireAll' x = CompilerM $ do
134− provider <- compilerResourceProvider <$> ask
145+ deps <- getDeps . compilerResourceProvider <$> ask
135− r <- unCompilerM $ mapM require $ matches pattern $ resourceList provider
146+ lookup' <- compilerDependencyLookup <$> ask
136− return $ sequence r
147+ return $ f x $ map (unCompiledItem . lookup') deps
137
148
149+{-
138-- | Construct a target from a string, this string being the content of the
150-- | Construct a target from a string, this string being the content of the
139-- resource.
151-- resource.
140--
152--
src/Hakyll/Core/Run.hs+1−1
@@ -40,7 +40,7 @@ hakyllWith rules provider store = do
40
40
41 -- Get all dependencies
41 -- Get all dependencies
42 dependencies = flip map compilers $ \(id', compiler) ->
42 dependencies = flip map compilers $ \(id', compiler) ->
43− let deps = compilerDependencies compiler
43+ let deps = getDependencies compiler provider
44 in (id', deps)
44 in (id', deps)
45
45
46 -- Create a compiler map
46 -- Create a compiler map
src/Hakyll/Core/Util/Arrow.hsnew file+28
@@ -0,0 +1,28 @@
1+-- | Various arrow utility functions
2+--
3+module Hakyll.Core.Util.Arrow
4+ ( sequenceArr
5+ , unitArr
6+ , withUnitArr
7+ ) where
8+
9+import Prelude hiding (id)
10+import Control.Arrow (Arrow, (&&&), (>>>), arr, (***))
11+import Control.Category (id)
12+
13+sequenceArr :: Arrow a
14+ => [a b c]
15+ -> a b [c]
16+sequenceArr = foldl reduce $ arr $ const []
17+ where
18+ reduce la xa = xa &&& la >>> arr (uncurry (:))
19+
20+unitArr :: Arrow a
21+ => a b ()
22+unitArr = arr (const ())
23+
24+withUnitArr :: Arrow a
25+ => a b c
26+ -> a () d
27+ -> a b (c, d)
28+withUnitArr a1 a2 = a1 &&& unitArr >>> id *** a2
src/Hakyll/Web/Pandoc.hs+15−16
@@ -7,25 +7,27 @@ module Hakyll.Web.Pandoc
7 , writePandoc
7 , writePandoc
8 , writePandocWith
8 , writePandocWith
9
9
10− -- * Functions working on pages/targets
10+ -- * Functions working on pages/compilers
11− {-
12 , pageReadPandoc
11 , pageReadPandoc
13 , pageReadPandocWith
12 , pageReadPandocWith
14 , pageRenderPandoc
13 , pageRenderPandoc
15 , pageRenderPandocWith
14 , pageRenderPandocWith
16− -}
17
15
18 -- * Default options
16 -- * Default options
19 , defaultParserState
17 , defaultParserState
20 , defaultWriterOptions
18 , defaultWriterOptions
21 ) where
19 ) where
22
20
21+import Prelude hiding (id)
23import Control.Applicative ((<$>))
22import Control.Applicative ((<$>))
23+import Control.Arrow ((>>>), arr)
24+import Control.Category (id)
24
25
25import Text.Pandoc (Pandoc)
26import Text.Pandoc (Pandoc)
26import qualified Text.Pandoc as P
27import qualified Text.Pandoc as P
27
28
28import Hakyll.Core.Compiler
29import Hakyll.Core.Compiler
30+import Hakyll.Core.Util.Arrow
29import Hakyll.Web.FileType
31import Hakyll.Web.FileType
30import Hakyll.Web.Page
32import Hakyll.Web.Page
31
33
@@ -64,34 +66,31 @@ writePandocWith :: P.WriterOptions -- ^ Writer options for pandoc
64 -> String -- ^ Resulting HTML
66 -> String -- ^ Resulting HTML
65writePandocWith = P.writeHtmlString
67writePandocWith = P.writeHtmlString
66
68
67−{-
68-- | Read the resource using pandoc
69-- | Read the resource using pandoc
69--
70--
70−pageReadPandoc :: Page String -> TargetM (Page Pandoc)
71+pageReadPandoc :: Compiler (Page String) (Page Pandoc)
71pageReadPandoc = pageReadPandocWith defaultParserState
72pageReadPandoc = pageReadPandocWith defaultParserState
72
73
73-- | Read the resource using pandoc
74-- | Read the resource using pandoc
74--
75--
75−pageReadPandocWith :: P.ParserState -> Page String -> TargetM (Page Pandoc)
76+pageReadPandocWith :: P.ParserState -> Compiler (Page String) (Page Pandoc)
76−pageReadPandocWith state page = do
77+pageReadPandocWith state =
77− fileType' <- getFileType
78+ withUnitArr id getFileType >>> arr pageReadPandocWith'
79+ where
78− return $ readPandocWith state fileType' <$> page
80+ pageReadPandocWith' (p, t) = readPandocWith state t <$> p
79
81
80-- | Render the resource using pandoc
82-- | Render the resource using pandoc
81--
83--
82−pageRenderPandoc :: Page String -> TargetM (Page String)
84+pageRenderPandoc :: Compiler (Page String) (Page String)
83pageRenderPandoc = pageRenderPandocWith defaultParserState defaultWriterOptions
85pageRenderPandoc = pageRenderPandocWith defaultParserState defaultWriterOptions
84
86
85-- | Render the resource using pandoc
87-- | Render the resource using pandoc
86--
88--
87pageRenderPandocWith :: P.ParserState
89pageRenderPandocWith :: P.ParserState
88 -> P.WriterOptions
90 -> P.WriterOptions
89− -> Page String
91+ -> Compiler (Page String) (Page String)
90− -> TargetM (Page String)
91−pageRenderPandocWith state options page = do
92+pageRenderPandocWith state options =
92− pandoc <- pageReadPandocWith state page
93+ pageReadPandocWith state >>> arr (fmap $ writePandocWith options)
93− return $ writePandocWith options <$> pandoc
94−-}
95
94
96-- | The default reader options for pandoc parsing in hakyll
95-- | The default reader options for pandoc parsing in hakyll
97--
96--