Alternative instance for Compiler

1 files changed, 72 insertions, 31 deletions

diff --git a/src/Hakyll/Core/Compiler/Internal.hs b/src/Hakyll/Core/Compiler/Internal.hs
index a8c0989..acdfe80 100644
--- a/src/Hakyll/Core/Compiler/Internal.hs
+++ b/src/Hakyll/Core/Compiler/Internal.hs
@@ -1,5 +1,5 @@
+--------------------------------------------------------------------------------
 -- | Internally used compiler module
---
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 module Hakyll.Core.Compiler.Internal
     ( Dependencies
@@ -15,28 +15,38 @@ module Hakyll.Core.Compiler.Internal
     , fromDependency
     ) where
 
-import Prelude hiding ((.), id)
-import Control.Applicative (Applicative, pure, (<*>), (<$>))
-import Control.Monad.Reader (ReaderT, Reader, ask, runReaderT, runReader)
-import Control.Monad.Error (ErrorT, runErrorT)
-import Control.Monad ((<=<), liftM2)
-import Data.Set (Set)
-import qualified Data.Set as S
-import Control.Category (Category, (.), id)
-import Control.Arrow (Arrow, ArrowChoice, arr, first, left)
-
-import Hakyll.Core.Identifier
-import Hakyll.Core.ResourceProvider
-import Hakyll.Core.Store
-import Hakyll.Core.Routes
-import Hakyll.Core.Logger
 
+--------------------------------------------------------------------------------
+import           Control.Applicative          (Alternative (..), Applicative,
+                                               pure, (<$>), (<*>))
+import           Control.Arrow                (Arrow, ArrowChoice, arr, first,
+                                               left)
+import           Control.Category             (Category, id, (.))
+import           Control.Monad                (liftM2, (<=<))
+import           Control.Monad.Error          (ErrorT, catchError, runErrorT,
+                                               throwError)
+import           Control.Monad.Reader         (Reader, ReaderT, ask, runReader,
+                                               runReaderT)
+import           Data.Set                     (Set)
+import qualified Data.Set                     as S
+import           Prelude                      hiding (id, (.))
+
+
+--------------------------------------------------------------------------------
+import           Hakyll.Core.Identifier
+import           Hakyll.Core.Logger
+import           Hakyll.Core.ResourceProvider
+import           Hakyll.Core.Routes
+import           Hakyll.Core.Store
+
+
+--------------------------------------------------------------------------------
 -- | A set of dependencies
---
 type Dependencies = Set (Identifier ())
 
+
+--------------------------------------------------------------------------------
 -- | Environment in which the dependency analyzer runs
---
 data DependencyEnvironment = DependencyEnvironment
     { -- | Target identifier
       dependencyIdentifier :: Identifier ()
@@ -44,8 +54,9 @@ data DependencyEnvironment = DependencyEnvironment
       dependencyUniverse   :: [Identifier ()]
     }
 
+
+--------------------------------------------------------------------------------
 -- | Environment in which a compiler runs
---
 data CompilerEnvironment = CompilerEnvironment
     { -- | Target identifier
       compilerIdentifier       :: Identifier ()
@@ -63,49 +74,72 @@ data CompilerEnvironment = CompilerEnvironment
       compilerLogger           :: Logger
     }
 
+
+--------------------------------------------------------------------------------
 -- | A calculation possibly throwing an error
---
 type Throwing a = Either String a
 
+
+--------------------------------------------------------------------------------
 -- | The compiler monad
---
 newtype CompilerM a = CompilerM
     { unCompilerM :: ErrorT String (ReaderT CompilerEnvironment IO) a
     } deriving (Monad, Functor, Applicative)
 
+
+--------------------------------------------------------------------------------
 -- | The compiler arrow
---
 data Compiler a b = Compiler
     { compilerDependencies :: Reader DependencyEnvironment Dependencies
     , compilerJob          :: a -> CompilerM b
     }
 
+
+--------------------------------------------------------------------------------
 instance Functor (Compiler a) where
     fmap f ~(Compiler d j) = Compiler d $ fmap f . j
 
+
+--------------------------------------------------------------------------------
 instance Applicative (Compiler a) where
-    pure = Compiler (return S.empty) . const . return
-    ~(Compiler d1 f) <*> ~(Compiler d2 j) =
-        Compiler (liftM2 S.union d1 d2) $ \x -> f x <*> j x
+    pure = fromJob . const . return
+    ~(Compiler d1 j1) <*> ~(Compiler d2 j2) =
+        Compiler (liftM2 S.union d1 d2) $ \x -> j1 x <*> j2 x
 
+
+--------------------------------------------------------------------------------
+instance Alternative (Compiler a) where
+    empty = fromJob $ const $ CompilerM $
+        throwError "Hakyll.Core.Compiler.Internal: empty alternative"
+    ~(Compiler d1 j1) <|> ~(Compiler d2 j2) =
+        Compiler (liftM2 S.union d1 d2) $ \x -> CompilerM $
+            catchError (unCompilerM $ j1 x) (\_ -> unCompilerM $ j2 x)
+
+
+--------------------------------------------------------------------------------
 instance Category Compiler where
     id = Compiler (return S.empty) return
     ~(Compiler d1 j1) . ~(Compiler d2 j2) =
         Compiler (liftM2 S.union d1 d2) (j1 <=< j2)
 
+
+--------------------------------------------------------------------------------
 instance Arrow Compiler where
-    arr f = Compiler (return S.empty) (return . f)
+    arr f = fromJob (return . f)
     first ~(Compiler d j) = Compiler d $ \(x, y) -> do
         x' <- j x
         return (x', y)
 
+
+--------------------------------------------------------------------------------
 instance ArrowChoice Compiler where
     left ~(Compiler d j) = Compiler d $ \e -> case e of
         Left l  -> Left  <$> j l
         Right r -> Right <$> return r
 
+
+--------------------------------------------------------------------------------
 -- | Run a compiler, yielding the resulting target
---
 runCompilerJob :: Compiler () a     -- ^ Compiler to run
                -> Identifier ()     -- ^ Target identifier
                -> ResourceProvider  -- ^ Resource provider
@@ -128,6 +162,8 @@ runCompilerJob compiler id' provider universe route store modified logger =
             , compilerLogger           = logger
             }
 
+
+--------------------------------------------------------------------------------
 runCompilerDependencies :: Compiler () a
                         -> Identifier ()
                         -> [Identifier ()]
@@ -140,17 +176,22 @@ runCompilerDependencies compiler identifier universe =
             , dependencyUniverse   = universe
             }
 
-fromJob :: (a -> CompilerM b)
-        -> Compiler a b
-fromJob = Compiler (return S.empty)
 
+--------------------------------------------------------------------------------
+fromJob :: (a -> CompilerM b) -> Compiler a b
+fromJob = Compiler $ return S.empty
+{-# INLINE fromJob #-}
+
+
+--------------------------------------------------------------------------------
 fromDependencies :: (Identifier () -> [Identifier ()] -> [Identifier ()])
                  -> Compiler b b
 fromDependencies collectDeps = flip Compiler return $ do
     DependencyEnvironment identifier universe <- ask
     return $ S.fromList $ collectDeps identifier universe
 
+
+--------------------------------------------------------------------------------
 -- | Wait until another compiler has finished before running this compiler
---
 fromDependency :: Identifier a -> Compiler b b
 fromDependency = fromDependencies . const . const . return . castIdentifier