git.iko.soy/hakyll
on 877cb21 help sign in
hakyll/src/Hakyll/Core/Compiler/Internal.hs
197 lines 6.8 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 (..))
34--------------------------------------------------------------------------------
35import Hakyll.Core.Dependencies
36import Hakyll.Core.Identifier
37import Hakyll.Core.Logger
38import Hakyll.Core.Provider
39import Hakyll.Core.Routes
40import Hakyll.Core.Store
43--------------------------------------------------------------------------------
44-- | Environment in which a compiler runs
45data CompilerRead = CompilerRead
46 { -- | Underlying identifier
47 compilerUnderlying :: Identifier
48 , -- | Resource provider
49 compilerProvider :: Provider
50 , -- | List of all known identifiers
51 compilerUniverse :: [Identifier]
52 , -- | Site routes
53 compilerRoutes :: Routes
54 , -- | Compiler store
55 compilerStore :: Store
56 , -- | Logger
57 compilerLogger :: Logger
58 }
61--------------------------------------------------------------------------------
62data CompilerWrite = CompilerWrite
63 { compilerDependencies :: [Dependency]
64 , compilerCacheHits :: Int
65 } deriving (Show)
68--------------------------------------------------------------------------------
69instance Monoid CompilerWrite where
70 mempty = CompilerWrite [] 0
71 mappend (CompilerWrite d1 h1) (CompilerWrite d2 h2) =
72 CompilerWrite (d1 ++ d2) (h1 + h2)
75--------------------------------------------------------------------------------
76data CompilerResult a where
77 CompilerDone :: a -> CompilerWrite -> CompilerResult a
78 CompilerError :: String -> CompilerResult a
79 CompilerRequire :: Identifier -> Compiler a -> CompilerResult a
82--------------------------------------------------------------------------------
83newtype Compiler a = Compiler
84 { unCompiler :: CompilerRead -> IO (CompilerResult a)
85 }
88--------------------------------------------------------------------------------
89instance Functor Compiler where
90 fmap f (Compiler c) = Compiler $ \r -> do
91 res <- c r
92 return $ case res of
93 CompilerDone x w -> CompilerDone (f x) w
94 CompilerError e -> CompilerError e
95 CompilerRequire i c' -> CompilerRequire i (fmap f c')
96 {-# INLINE fmap #-}
99--------------------------------------------------------------------------------
100instance Monad Compiler where
101 return x = Compiler $ \_ -> return $ CompilerDone x mempty
102 {-# INLINE return #-}
104 Compiler c >>= f = Compiler $ \r -> do
105 res <- c r
106 case res of
107 CompilerDone x w -> do
108 res' <- unCompiler (f x) r
109 return $ case res' of
110 CompilerDone y w' -> CompilerDone y (w `mappend` w')
111 CompilerError e -> CompilerError e
112 CompilerRequire i c' -> CompilerRequire i $ do
113 compilerTell w -- Save dependencies!
114 c'
116 CompilerError e -> return $ CompilerError e
117 CompilerRequire i c' -> return $ CompilerRequire i $ c' >>= f
118 {-# INLINE (>>=) #-}
121--------------------------------------------------------------------------------
122instance Applicative Compiler where
123 pure x = return x
124 {-# INLINE pure #-}
126 f <*> x = f >>= \f' -> fmap f' x
127 {-# INLINE (<*>) #-}
130--------------------------------------------------------------------------------
131runCompiler :: Compiler a -> CompilerRead -> IO (CompilerResult a)
132runCompiler compiler read' = handle handler $ unCompiler compiler read'
133 where
134 handler :: SomeException -> IO (CompilerResult a)
135 handler e = return $ CompilerError $ show e
138--------------------------------------------------------------------------------
139instance Alternative Compiler where
140 empty = compilerThrow "Hakyll.Core.Compiler.Internal: empty alternative"
141 x <|> y = compilerCatch x (\_ -> y)
142 {-# INLINE (<|>) #-}
145--------------------------------------------------------------------------------
146compilerAsk :: Compiler CompilerRead
147compilerAsk = Compiler $ \r -> return $ CompilerDone r mempty
148{-# INLINE compilerAsk #-}
151--------------------------------------------------------------------------------
152compilerTell :: CompilerWrite -> Compiler ()
153compilerTell deps = Compiler $ \_ -> return $ CompilerDone () deps
154{-# INLINE compilerTell #-}
157--------------------------------------------------------------------------------
158compilerThrow :: String -> Compiler a
159compilerThrow e = Compiler $ \_ -> return $ CompilerError e
160{-# INLINE compilerThrow #-}
163--------------------------------------------------------------------------------
164compilerCatch :: Compiler a -> (String -> Compiler a) -> Compiler a
165compilerCatch (Compiler x) f = Compiler $ \r -> do
166 res <- x r
167 case res of
168 CompilerError e -> unCompiler (f e) r
169 _ -> return res
170{-# INLINE compilerCatch #-}
173--------------------------------------------------------------------------------
174-- | Put the result back in a compiler
175compilerResult :: CompilerResult a -> Compiler a
176compilerResult x = Compiler $ \_ -> return x
177{-# INLINE compilerResult #-}
180--------------------------------------------------------------------------------
181compilerUnsafeIO :: IO a -> Compiler a
182compilerUnsafeIO io = Compiler $ \_ -> do
183 x <- io
184 return $ CompilerDone x mempty
185{-# INLINE compilerUnsafeIO #-}
188--------------------------------------------------------------------------------
189compilerTellDependencies :: [Dependency] -> Compiler ()
190compilerTellDependencies ds = compilerTell mempty {compilerDependencies = ds}
191{-# INLINE compilerTellDependencies #-}
194--------------------------------------------------------------------------------
195compilerTellCacheHits :: Int -> Compiler ()
196compilerTellCacheHits ch = compilerTell mempty {compilerCacheHits = ch}
197{-# INLINE compilerTellCacheHits #-}