git.iko.soy/hakyll
on d88ba8a help sign in
hakyll/src/Hakyll/Core/Compiler/Internal.hs
239 lines 8.6 kB history raw
1--------------------------------------------------------------------------------
2-- | Internally used compiler module
3{-# LANGUAGE GADTs #-}
4{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5module Hakyll.Core.Compiler.Internal
6 ( -- * Types
7 CompilerRead (..)
8 , CompilerWrite (..)
9 , CompilerResult (..)
10 , Compiler (..)
11 , runCompiler
13 -- * Core operations
14 , compilerTell
15 , compilerAsk
16 , compilerThrow
17 , compilerCatch
18 , compilerResult
19 , compilerUnsafeIO
21 -- * Utilities
22 , compilerTellDependencies
23 , compilerTellCacheHits
24 ) where
27--------------------------------------------------------------------------------
28import Control.Applicative (Alternative (..),
29 Applicative (..), (<$>))
30import Control.Exception (SomeException, handle)
31import Control.Monad (forM_)
32import Data.Monoid (Monoid (..))
33import Data.Set (Set)
34import qualified Data.Set as S
37--------------------------------------------------------------------------------
38import Hakyll.Core.Configuration
39import Hakyll.Core.Dependencies
40import Hakyll.Core.Identifier
41import Hakyll.Core.Identifier.Pattern
42import Hakyll.Core.Logger (Logger)
43import qualified Hakyll.Core.Logger as Logger
44import Hakyll.Core.Metadata
45import Hakyll.Core.Provider
46import Hakyll.Core.Routes
47import Hakyll.Core.Store
50--------------------------------------------------------------------------------
51-- | Environment in which a compiler runs
52data CompilerRead = CompilerRead
53 { -- | Main configuration
54 compilerConfig :: Configuration
55 , -- | Underlying identifier
56 compilerUnderlying :: Identifier
57 , -- | Resource provider
58 compilerProvider :: Provider
59 , -- | List of all known identifiers
60 compilerUniverse :: Set Identifier
61 , -- | Site routes
62 compilerRoutes :: Routes
63 , -- | Compiler store
64 compilerStore :: Store
65 , -- | Logger
66 compilerLogger :: Logger
67 }
70--------------------------------------------------------------------------------
71data CompilerWrite = CompilerWrite
72 { compilerDependencies :: [Dependency]
73 , compilerCacheHits :: Int
74 } deriving (Show)
77--------------------------------------------------------------------------------
78instance Monoid CompilerWrite where
79 mempty = CompilerWrite [] 0
80 mappend (CompilerWrite d1 h1) (CompilerWrite d2 h2) =
81 CompilerWrite (d1 ++ d2) (h1 + h2)
84--------------------------------------------------------------------------------
85data CompilerResult a where
86 CompilerDone :: a -> CompilerWrite -> CompilerResult a
87 CompilerError :: [String] -> CompilerResult a
88 CompilerRequire :: Identifier -> Compiler a -> CompilerResult a
91--------------------------------------------------------------------------------
92-- | A monad which lets you compile items and takes care of dependency tracking
93-- for you.
94newtype Compiler a = Compiler
95 { unCompiler :: CompilerRead -> IO (CompilerResult a)
96 }
99--------------------------------------------------------------------------------
100instance Functor Compiler where
101 fmap f (Compiler c) = Compiler $ \r -> do
102 res <- c r
103 return $ case res of
104 CompilerDone x w -> CompilerDone (f x) w
105 CompilerError e -> CompilerError e
106 CompilerRequire i c' -> CompilerRequire i (fmap f c')
107 {-# INLINE fmap #-}
110--------------------------------------------------------------------------------
111instance Monad Compiler where
112 return x = Compiler $ \_ -> return $ CompilerDone x mempty
113 {-# INLINE return #-}
115 Compiler c >>= f = Compiler $ \r -> do
116 res <- c r
117 case res of
118 CompilerDone x w -> do
119 res' <- unCompiler (f x) r
120 return $ case res' of
121 CompilerDone y w' -> CompilerDone y (w `mappend` w')
122 CompilerError e -> CompilerError e
123 CompilerRequire i c' -> CompilerRequire i $ do
124 compilerTell w -- Save dependencies!
125 c'
127 CompilerError e -> return $ CompilerError e
128 CompilerRequire i c' -> return $ CompilerRequire i $ c' >>= f
129 {-# INLINE (>>=) #-}
131 fail = compilerThrow . return
132 {-# INLINE fail #-}
135--------------------------------------------------------------------------------
136instance Applicative Compiler where
137 pure x = return x
138 {-# INLINE pure #-}
140 f <*> x = f >>= \f' -> fmap f' x
141 {-# INLINE (<*>) #-}
144--------------------------------------------------------------------------------
145instance MonadMetadata Compiler where
146 getMetadata = compilerGetMetadata
147 getMatches = compilerGetMatches
150--------------------------------------------------------------------------------
151runCompiler :: Compiler a -> CompilerRead -> IO (CompilerResult a)
152runCompiler compiler read' = handle handler $ unCompiler compiler read'
153 where
154 handler :: SomeException -> IO (CompilerResult a)
155 handler e = return $ CompilerError [show e]
158--------------------------------------------------------------------------------
159instance Alternative Compiler where
160 empty = compilerThrow []
161 x <|> y = compilerCatch x $ \es -> do
162 logger <- compilerLogger <$> compilerAsk
163 forM_ es $ \e -> compilerUnsafeIO $ Logger.debug logger $
164 "Hakyll.Core.Compiler.Internal: Alternative failed: " ++ e
165 y
166 {-# INLINE (<|>) #-}
169--------------------------------------------------------------------------------
170compilerAsk :: Compiler CompilerRead
171compilerAsk = Compiler $ \r -> return $ CompilerDone r mempty
172{-# INLINE compilerAsk #-}
175--------------------------------------------------------------------------------
176compilerTell :: CompilerWrite -> Compiler ()
177compilerTell deps = Compiler $ \_ -> return $ CompilerDone () deps
178{-# INLINE compilerTell #-}
181--------------------------------------------------------------------------------
182compilerThrow :: [String] -> Compiler a
183compilerThrow es = Compiler $ \_ -> return $ CompilerError es
184{-# INLINE compilerThrow #-}
187--------------------------------------------------------------------------------
188compilerCatch :: Compiler a -> ([String] -> Compiler a) -> Compiler a
189compilerCatch (Compiler x) f = Compiler $ \r -> do
190 res <- x r
191 case res of
192 CompilerDone res' w -> return (CompilerDone res' w)
193 CompilerError e -> unCompiler (f e) r
194 CompilerRequire i c -> return (CompilerRequire i (compilerCatch c f))
195{-# INLINE compilerCatch #-}
198--------------------------------------------------------------------------------
199-- | Put the result back in a compiler
200compilerResult :: CompilerResult a -> Compiler a
201compilerResult x = Compiler $ \_ -> return x
202{-# INLINE compilerResult #-}
205--------------------------------------------------------------------------------
206compilerUnsafeIO :: IO a -> Compiler a
207compilerUnsafeIO io = Compiler $ \_ -> do
208 x <- io
209 return $ CompilerDone x mempty
210{-# INLINE compilerUnsafeIO #-}
213--------------------------------------------------------------------------------
214compilerTellDependencies :: [Dependency] -> Compiler ()
215compilerTellDependencies ds = compilerTell mempty {compilerDependencies = ds}
216{-# INLINE compilerTellDependencies #-}
219--------------------------------------------------------------------------------
220compilerTellCacheHits :: Int -> Compiler ()
221compilerTellCacheHits ch = compilerTell mempty {compilerCacheHits = ch}
222{-# INLINE compilerTellCacheHits #-}
225--------------------------------------------------------------------------------
226compilerGetMetadata :: Identifier -> Compiler Metadata
227compilerGetMetadata identifier = do
228 provider <- compilerProvider <$> compilerAsk
229 compilerTellDependencies [IdentifierDependency identifier]
230 compilerUnsafeIO $ resourceMetadata provider identifier
233--------------------------------------------------------------------------------
234compilerGetMatches :: Pattern -> Compiler [Identifier]
235compilerGetMatches pattern = do
236 universe <- compilerUniverse <$> compilerAsk
237 let matching = filterMatches pattern $ S.toList universe
238 compilerTellDependencies [PatternDependency pattern matching]
239 return matching