git.iko.soy/hakyll
on 8a8dade help sign in
hakyll/src/Hakyll/Core/Compiler/Internal.hs
226 lines 8.0 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.Dependencies
38import Hakyll.Core.Identifier
39import Hakyll.Core.Identifier.Pattern
40import Hakyll.Core.Logger
41import Hakyll.Core.Metadata
42import Hakyll.Core.Provider
43import Hakyll.Core.Routes
44import Hakyll.Core.Store
47--------------------------------------------------------------------------------
48-- | Environment in which a compiler runs
49data CompilerRead = CompilerRead
50 { -- | Underlying identifier
51 compilerUnderlying :: Identifier
52 , -- | Resource provider
53 compilerProvider :: Provider
54 , -- | List of all known identifiers
55 compilerUniverse :: Set Identifier
56 , -- | Site routes
57 compilerRoutes :: Routes
58 , -- | Compiler store
59 compilerStore :: Store
60 , -- | Logger
61 compilerLogger :: Logger
62 }
65--------------------------------------------------------------------------------
66data CompilerWrite = CompilerWrite
67 { compilerDependencies :: [Dependency]
68 , compilerCacheHits :: Int
69 } deriving (Show)
72--------------------------------------------------------------------------------
73instance Monoid CompilerWrite where
74 mempty = CompilerWrite [] 0
75 mappend (CompilerWrite d1 h1) (CompilerWrite d2 h2) =
76 CompilerWrite (d1 ++ d2) (h1 + h2)
79--------------------------------------------------------------------------------
80data CompilerResult a where
81 CompilerDone :: a -> CompilerWrite -> CompilerResult a
82 CompilerError :: String -> CompilerResult a
83 CompilerRequire :: Identifier -> Compiler a -> CompilerResult a
86--------------------------------------------------------------------------------
87-- | A monad which lets you compile items and takes care of dependency tracking
88-- for you.
89newtype Compiler a = Compiler
90 { unCompiler :: CompilerRead -> IO (CompilerResult a)
91 }
94--------------------------------------------------------------------------------
95instance Functor Compiler where
96 fmap f (Compiler c) = Compiler $ \r -> do
97 res <- c r
98 return $ case res of
99 CompilerDone x w -> CompilerDone (f x) w
100 CompilerError e -> CompilerError e
101 CompilerRequire i c' -> CompilerRequire i (fmap f c')
102 {-# INLINE fmap #-}
105--------------------------------------------------------------------------------
106instance Monad Compiler where
107 return x = Compiler $ \_ -> return $ CompilerDone x mempty
108 {-# INLINE return #-}
110 Compiler c >>= f = Compiler $ \r -> do
111 res <- c r
112 case res of
113 CompilerDone x w -> do
114 res' <- unCompiler (f x) r
115 return $ case res' of
116 CompilerDone y w' -> CompilerDone y (w `mappend` w')
117 CompilerError e -> CompilerError e
118 CompilerRequire i c' -> CompilerRequire i $ do
119 compilerTell w -- Save dependencies!
120 c'
122 CompilerError e -> return $ CompilerError e
123 CompilerRequire i c' -> return $ CompilerRequire i $ c' >>= f
124 {-# INLINE (>>=) #-}
127--------------------------------------------------------------------------------
128instance Applicative Compiler where
129 pure x = return x
130 {-# INLINE pure #-}
132 f <*> x = f >>= \f' -> fmap f' x
133 {-# INLINE (<*>) #-}
136--------------------------------------------------------------------------------
137instance MonadMetadata Compiler where
138 getMetadata = compilerGetMetadata
139 getMatches = compilerGetMatches
142--------------------------------------------------------------------------------
143runCompiler :: Compiler a -> CompilerRead -> IO (CompilerResult a)
144runCompiler compiler read' = handle handler $ unCompiler compiler read'
145 where
146 handler :: SomeException -> IO (CompilerResult a)
147 handler e = return $ CompilerError $ show e
150--------------------------------------------------------------------------------
151instance Alternative Compiler where
152 empty = compilerThrow "Hakyll.Core.Compiler.Internal: empty alternative"
153 x <|> y = compilerCatch x (\_ -> y)
154 {-# INLINE (<|>) #-}
157--------------------------------------------------------------------------------
158compilerAsk :: Compiler CompilerRead
159compilerAsk = Compiler $ \r -> return $ CompilerDone r mempty
160{-# INLINE compilerAsk #-}
163--------------------------------------------------------------------------------
164compilerTell :: CompilerWrite -> Compiler ()
165compilerTell deps = Compiler $ \_ -> return $ CompilerDone () deps
166{-# INLINE compilerTell #-}
169--------------------------------------------------------------------------------
170compilerThrow :: String -> Compiler a
171compilerThrow e = Compiler $ \_ -> return $ CompilerError e
172{-# INLINE compilerThrow #-}
175--------------------------------------------------------------------------------
176compilerCatch :: Compiler a -> (String -> Compiler a) -> Compiler a
177compilerCatch (Compiler x) f = Compiler $ \r -> do
178 res <- x r
179 case res of
180 CompilerError e -> unCompiler (f e) r
181 _ -> return res
182{-# INLINE compilerCatch #-}
185--------------------------------------------------------------------------------
186-- | Put the result back in a compiler
187compilerResult :: CompilerResult a -> Compiler a
188compilerResult x = Compiler $ \_ -> return x
189{-# INLINE compilerResult #-}
192--------------------------------------------------------------------------------
193compilerUnsafeIO :: IO a -> Compiler a
194compilerUnsafeIO io = Compiler $ \_ -> do
195 x <- io
196 return $ CompilerDone x mempty
197{-# INLINE compilerUnsafeIO #-}
200--------------------------------------------------------------------------------
201compilerTellDependencies :: [Dependency] -> Compiler ()
202compilerTellDependencies ds = compilerTell mempty {compilerDependencies = ds}
203{-# INLINE compilerTellDependencies #-}
206--------------------------------------------------------------------------------
207compilerTellCacheHits :: Int -> Compiler ()
208compilerTellCacheHits ch = compilerTell mempty {compilerCacheHits = ch}
209{-# INLINE compilerTellCacheHits #-}
212--------------------------------------------------------------------------------
213compilerGetMetadata :: Identifier -> Compiler Metadata
214compilerGetMetadata identifier = do
215 provider <- compilerProvider <$> compilerAsk
216 compilerTellDependencies [IdentifierDependency identifier]
217 compilerUnsafeIO $ resourceMetadata provider identifier
220--------------------------------------------------------------------------------
221compilerGetMatches :: Pattern -> Compiler [Identifier]
222compilerGetMatches pattern = do
223 universe <- compilerUniverse <$> compilerAsk
224 let matching = filterMatches pattern $ S.toList universe
225 compilerTellDependencies [PatternDependency pattern matching]
226 return matching