git.iko.soy/hakyll
on 2ef7fee help sign in
hakyll/src/Hakyll/Core/Compiler/Internal.hs
252 lines 9.1 kB history raw
1--------------------------------------------------------------------------------
2-- | Internally used compiler module
3{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE GADTs #-}
5{-# LANGUAGE GeneralizedNewtypeDeriving #-}
6{-# LANGUAGE MultiParamTypeClasses #-}
7module Hakyll.Core.Compiler.Internal
8 ( -- * Types
9 CompilerRead (..)
10 , CompilerWrite (..)
11 , CompilerResult (..)
12 , Compiler (..)
13 , runCompiler
15 -- * Core operations
16 , compilerTell
17 , compilerAsk
18 , compilerThrow
19 , compilerCatch
20 , compilerResult
21 , compilerUnsafeIO
23 -- * Utilities
24 , compilerTellDependencies
25 , compilerTellCacheHits
26 ) where
29--------------------------------------------------------------------------------
30import Control.Applicative (Alternative (..),
31 Applicative (..), (<$>))
32import Control.Exception (SomeException, handle)
33import Control.Monad (forM_)
34import Control.Monad.Error (MonadError (..))
35import Data.Monoid (Monoid (..))
36import Data.Set (Set)
37import qualified Data.Set as S
40--------------------------------------------------------------------------------
41import Hakyll.Core.Configuration
42import Hakyll.Core.Dependencies
43import Hakyll.Core.Identifier
44import Hakyll.Core.Identifier.Pattern
45import Hakyll.Core.Logger (Logger)
46import qualified Hakyll.Core.Logger as Logger
47import Hakyll.Core.Metadata
48import Hakyll.Core.Provider
49import Hakyll.Core.Routes
50import Hakyll.Core.Store
53--------------------------------------------------------------------------------
54-- | Environment in which a compiler runs
55data CompilerRead = CompilerRead
56 { -- | Main configuration
57 compilerConfig :: Configuration
58 , -- | Underlying identifier
59 compilerUnderlying :: Identifier
60 , -- | Resource provider
61 compilerProvider :: Provider
62 , -- | List of all known identifiers
63 compilerUniverse :: Set Identifier
64 , -- | Site routes
65 compilerRoutes :: Routes
66 , -- | Compiler store
67 compilerStore :: Store
68 , -- | Logger
69 compilerLogger :: Logger
70 }
73--------------------------------------------------------------------------------
74data CompilerWrite = CompilerWrite
75 { compilerDependencies :: [Dependency]
76 , compilerCacheHits :: Int
77 } deriving (Show)
80--------------------------------------------------------------------------------
81instance Monoid CompilerWrite where
82 mempty = CompilerWrite [] 0
83 mappend (CompilerWrite d1 h1) (CompilerWrite d2 h2) =
84 CompilerWrite (d1 ++ d2) (h1 + h2)
87--------------------------------------------------------------------------------
88data CompilerResult a where
89 CompilerDone :: a -> CompilerWrite -> CompilerResult a
90 CompilerError :: [String] -> CompilerResult a
91 CompilerRequire :: Identifier -> Compiler a -> CompilerResult a
94--------------------------------------------------------------------------------
95-- | A monad which lets you compile items and takes care of dependency tracking
96-- for you.
97newtype Compiler a = Compiler
98 { unCompiler :: CompilerRead -> IO (CompilerResult a)
99 }
102--------------------------------------------------------------------------------
103instance Functor Compiler where
104 fmap f (Compiler c) = Compiler $ \r -> do
105 res <- c r
106 return $ case res of
107 CompilerDone x w -> CompilerDone (f x) w
108 CompilerError e -> CompilerError e
109 CompilerRequire i c' -> CompilerRequire i (fmap f c')
110 {-# INLINE fmap #-}
113--------------------------------------------------------------------------------
114instance Monad Compiler where
115 return x = Compiler $ \_ -> return $ CompilerDone x mempty
116 {-# INLINE return #-}
118 Compiler c >>= f = Compiler $ \r -> do
119 res <- c r
120 case res of
121 CompilerDone x w -> do
122 res' <- unCompiler (f x) r
123 return $ case res' of
124 CompilerDone y w' -> CompilerDone y (w `mappend` w')
125 CompilerError e -> CompilerError e
126 CompilerRequire i c' -> CompilerRequire i $ do
127 compilerTell w -- Save dependencies!
128 c'
130 CompilerError e -> return $ CompilerError e
131 CompilerRequire i c' -> return $ CompilerRequire i $ c' >>= f
132 {-# INLINE (>>=) #-}
134 fail = compilerThrow . return
135 {-# INLINE fail #-}
138--------------------------------------------------------------------------------
139instance Applicative Compiler where
140 pure x = return x
141 {-# INLINE pure #-}
143 f <*> x = f >>= \f' -> fmap f' x
144 {-# INLINE (<*>) #-}
147--------------------------------------------------------------------------------
148instance MonadMetadata Compiler where
149 getMetadata = compilerGetMetadata
150 getMatches = compilerGetMatches
153--------------------------------------------------------------------------------
154instance MonadError [String] Compiler where
155 throwError = compilerThrow
156 catchError = compilerCatch
159--------------------------------------------------------------------------------
160runCompiler :: Compiler a -> CompilerRead -> IO (CompilerResult a)
161runCompiler compiler read' = handle handler $ unCompiler compiler read'
162 where
163 handler :: SomeException -> IO (CompilerResult a)
164 handler e = return $ CompilerError [show e]
167--------------------------------------------------------------------------------
168instance Alternative Compiler where
169 empty = compilerThrow []
170 x <|> y = compilerCatch x $ \es -> do
171 logger <- compilerLogger <$> compilerAsk
172 forM_ es $ \e -> compilerUnsafeIO $ Logger.debug logger $
173 "Hakyll.Core.Compiler.Internal: Alternative failed: " ++ e
174 y
175 {-# INLINE (<|>) #-}
178--------------------------------------------------------------------------------
179compilerAsk :: Compiler CompilerRead
180compilerAsk = Compiler $ \r -> return $ CompilerDone r mempty
181{-# INLINE compilerAsk #-}
184--------------------------------------------------------------------------------
185compilerTell :: CompilerWrite -> Compiler ()
186compilerTell deps = Compiler $ \_ -> return $ CompilerDone () deps
187{-# INLINE compilerTell #-}
190--------------------------------------------------------------------------------
191compilerThrow :: [String] -> Compiler a
192compilerThrow es = Compiler $ \_ -> return $ CompilerError es
193{-# INLINE compilerThrow #-}
196--------------------------------------------------------------------------------
197compilerCatch :: Compiler a -> ([String] -> Compiler a) -> Compiler a
198compilerCatch (Compiler x) f = Compiler $ \r -> do
199 res <- x r
200 case res of
201 CompilerDone res' w -> return (CompilerDone res' w)
202 CompilerError e -> unCompiler (f e) r
203 CompilerRequire i c -> return (CompilerRequire i (compilerCatch c f))
204{-# INLINE compilerCatch #-}
207--------------------------------------------------------------------------------
208-- | Put the result back in a compiler
209compilerResult :: CompilerResult a -> Compiler a
210compilerResult x = Compiler $ \_ -> return x
211{-# INLINE compilerResult #-}
214--------------------------------------------------------------------------------
215compilerUnsafeIO :: IO a -> Compiler a
216compilerUnsafeIO io = Compiler $ \_ -> do
217 x <- io
218 return $ CompilerDone x mempty
219{-# INLINE compilerUnsafeIO #-}
222--------------------------------------------------------------------------------
223compilerTellDependencies :: [Dependency] -> Compiler ()
224compilerTellDependencies ds = do
225 logger <- compilerLogger <$> compilerAsk
226 forM_ ds $ \d -> compilerUnsafeIO $ Logger.debug logger $
227 "Hakyll.Core.Compiler.Internal: Adding dependency: " ++ show d
228 compilerTell mempty {compilerDependencies = ds}
229{-# INLINE compilerTellDependencies #-}
232--------------------------------------------------------------------------------
233compilerTellCacheHits :: Int -> Compiler ()
234compilerTellCacheHits ch = compilerTell mempty {compilerCacheHits = ch}
235{-# INLINE compilerTellCacheHits #-}
238--------------------------------------------------------------------------------
239compilerGetMetadata :: Identifier -> Compiler Metadata
240compilerGetMetadata identifier = do
241 provider <- compilerProvider <$> compilerAsk
242 compilerTellDependencies [IdentifierDependency identifier]
243 compilerUnsafeIO $ resourceMetadata provider identifier
246--------------------------------------------------------------------------------
247compilerGetMatches :: Pattern -> Compiler [Identifier]
248compilerGetMatches pattern = do
249 universe <- compilerUniverse <$> compilerAsk
250 let matching = filterMatches pattern $ S.toList universe
251 compilerTellDependencies [PatternDependency pattern matching]
252 return matching