git.iko.soy/hakyll
on b287c82 help sign in
hakyll/src/Hakyll/Core/Compiler/Internal.hs
232 lines 8.2 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 Data.Monoid (Monoid (..))
32import Data.Set (Set)
33import qualified Data.Set as S
36--------------------------------------------------------------------------------
37import Hakyll.Core.Configuration
38import Hakyll.Core.Dependencies
39import Hakyll.Core.Identifier
40import Hakyll.Core.Identifier.Pattern
41import Hakyll.Core.Logger
42import Hakyll.Core.Metadata
43import Hakyll.Core.Provider
44import Hakyll.Core.Routes
45import Hakyll.Core.Store
48--------------------------------------------------------------------------------
49-- | Environment in which a compiler runs
50data CompilerRead = CompilerRead
51 { -- | Main configuration
52 compilerConfig :: Configuration
53 , -- | Underlying identifier
54 compilerUnderlying :: Identifier
55 , -- | Resource provider
56 compilerProvider :: Provider
57 , -- | List of all known identifiers
58 compilerUniverse :: Set Identifier
59 , -- | Site routes
60 compilerRoutes :: Routes
61 , -- | Compiler store
62 compilerStore :: Store
63 , -- | Logger
64 compilerLogger :: Logger
65 }
68--------------------------------------------------------------------------------
69data CompilerWrite = CompilerWrite
70 { compilerDependencies :: [Dependency]
71 , compilerCacheHits :: Int
72 } deriving (Show)
75--------------------------------------------------------------------------------
76instance Monoid CompilerWrite where
77 mempty = CompilerWrite [] 0
78 mappend (CompilerWrite d1 h1) (CompilerWrite d2 h2) =
79 CompilerWrite (d1 ++ d2) (h1 + h2)
82--------------------------------------------------------------------------------
83data CompilerResult a where
84 CompilerDone :: a -> CompilerWrite -> CompilerResult a
85 CompilerError :: String -> CompilerResult a
86 CompilerRequire :: Identifier -> Compiler a -> CompilerResult a
89--------------------------------------------------------------------------------
90-- | A monad which lets you compile items and takes care of dependency tracking
91-- for you.
92newtype Compiler a = Compiler
93 { unCompiler :: CompilerRead -> IO (CompilerResult a)
94 }
97--------------------------------------------------------------------------------
98instance Functor Compiler where
99 fmap f (Compiler c) = Compiler $ \r -> do
100 res <- c r
101 return $ case res of
102 CompilerDone x w -> CompilerDone (f x) w
103 CompilerError e -> CompilerError e
104 CompilerRequire i c' -> CompilerRequire i (fmap f c')
105 {-# INLINE fmap #-}
108--------------------------------------------------------------------------------
109instance Monad Compiler where
110 return x = Compiler $ \_ -> return $ CompilerDone x mempty
111 {-# INLINE return #-}
113 Compiler c >>= f = Compiler $ \r -> do
114 res <- c r
115 case res of
116 CompilerDone x w -> do
117 res' <- unCompiler (f x) r
118 return $ case res' of
119 CompilerDone y w' -> CompilerDone y (w `mappend` w')
120 CompilerError e -> CompilerError e
121 CompilerRequire i c' -> CompilerRequire i $ do
122 compilerTell w -- Save dependencies!
123 c'
125 CompilerError e -> return $ CompilerError e
126 CompilerRequire i c' -> return $ CompilerRequire i $ c' >>= f
127 {-# INLINE (>>=) #-}
129 fail = compilerThrow
130 {-# INLINE fail #-}
133--------------------------------------------------------------------------------
134instance Applicative Compiler where
135 pure x = return x
136 {-# INLINE pure #-}
138 f <*> x = f >>= \f' -> fmap f' x
139 {-# INLINE (<*>) #-}
142--------------------------------------------------------------------------------
143instance MonadMetadata Compiler where
144 getMetadata = compilerGetMetadata
145 getMatches = compilerGetMatches
148--------------------------------------------------------------------------------
149runCompiler :: Compiler a -> CompilerRead -> IO (CompilerResult a)
150runCompiler compiler read' = handle handler $ unCompiler compiler read'
151 where
152 handler :: SomeException -> IO (CompilerResult a)
153 handler e = return $ CompilerError $ show e
156--------------------------------------------------------------------------------
157instance Alternative Compiler where
158 empty = compilerThrow "Hakyll.Core.Compiler.Internal: empty alternative"
159 x <|> y = compilerCatch x (\_ -> y)
160 {-# INLINE (<|>) #-}
163--------------------------------------------------------------------------------
164compilerAsk :: Compiler CompilerRead
165compilerAsk = Compiler $ \r -> return $ CompilerDone r mempty
166{-# INLINE compilerAsk #-}
169--------------------------------------------------------------------------------
170compilerTell :: CompilerWrite -> Compiler ()
171compilerTell deps = Compiler $ \_ -> return $ CompilerDone () deps
172{-# INLINE compilerTell #-}
175--------------------------------------------------------------------------------
176compilerThrow :: String -> Compiler a
177compilerThrow e = Compiler $ \_ -> return $ CompilerError e
178{-# INLINE compilerThrow #-}
181--------------------------------------------------------------------------------
182compilerCatch :: Compiler a -> (String -> Compiler a) -> Compiler a
183compilerCatch (Compiler x) f = Compiler $ \r -> do
184 res <- x r
185 case res of
186 CompilerError e -> unCompiler (f e) r
187 _ -> return res
188{-# INLINE compilerCatch #-}
191--------------------------------------------------------------------------------
192-- | Put the result back in a compiler
193compilerResult :: CompilerResult a -> Compiler a
194compilerResult x = Compiler $ \_ -> return x
195{-# INLINE compilerResult #-}
198--------------------------------------------------------------------------------
199compilerUnsafeIO :: IO a -> Compiler a
200compilerUnsafeIO io = Compiler $ \_ -> do
201 x <- io
202 return $ CompilerDone x mempty
203{-# INLINE compilerUnsafeIO #-}
206--------------------------------------------------------------------------------
207compilerTellDependencies :: [Dependency] -> Compiler ()
208compilerTellDependencies ds = compilerTell mempty {compilerDependencies = ds}
209{-# INLINE compilerTellDependencies #-}
212--------------------------------------------------------------------------------
213compilerTellCacheHits :: Int -> Compiler ()
214compilerTellCacheHits ch = compilerTell mempty {compilerCacheHits = ch}
215{-# INLINE compilerTellCacheHits #-}
218--------------------------------------------------------------------------------
219compilerGetMetadata :: Identifier -> Compiler Metadata
220compilerGetMetadata identifier = do
221 provider <- compilerProvider <$> compilerAsk
222 compilerTellDependencies [IdentifierDependency identifier]
223 compilerUnsafeIO $ resourceMetadata provider identifier
226--------------------------------------------------------------------------------
227compilerGetMatches :: Pattern -> Compiler [Identifier]
228compilerGetMatches pattern = do
229 universe <- compilerUniverse <$> compilerAsk
230 let matching = filterMatches pattern $ S.toList universe
231 compilerTellDependencies [PatternDependency pattern matching]
232 return matching