content: --------------------------------------------------------------------------------
  -- | Internally used compiler module
  {-# LANGUAGE CPP                        #-}
  {-# LANGUAGE DeriveFunctor              #-}
  {-# LANGUAGE FlexibleInstances          #-}
  {-# LANGUAGE GADTs                      #-}
  {-# LANGUAGE GeneralizedNewtypeDeriving #-}
  {-# LANGUAGE MultiParamTypeClasses      #-}
  module Hakyll.Core.Compiler.Internal
      ( -- * Types
        Snapshot
      , CompilerRead (..)
      , CompilerWrite (..)
      , CompilerErrors (..)
      , CompilerResult (..)
      , Compiler (..)
      , runCompiler
  
        -- * Core operations
      , compilerResult
      , compilerTell
      , compilerAsk
      , compilerUnsafeIO
  
        -- * Error operations
      , compilerThrow
      , compilerNoResult
      , compilerCatch
      , compilerTry
      , compilerErrorMessages
  
        -- * Utilities
      , compilerDebugEntries
      , compilerTellDependencies
      , compilerTellCacheHits
      ) where
  
  
  --------------------------------------------------------------------------------
  import           Control.Applicative            (Alternative (..))
  import           Control.Exception              (SomeException, handle)
  import           Control.Monad                  (forM_)
  import qualified Control.Monad.Fail             as Fail
  import           Control.Monad.Except           (MonadError (..))
  import           Data.List.NonEmpty             (NonEmpty (..))
  import qualified Data.List.NonEmpty             as NonEmpty
  import           Data.Set                       (Set)
  import qualified Data.Set                       as S
  
  
  --------------------------------------------------------------------------------
  import           Hakyll.Core.Configuration
  import           Hakyll.Core.Dependencies
  import           Hakyll.Core.Identifier
  import           Hakyll.Core.Identifier.Pattern
  import qualified Hakyll.Core.Logger             as Logger
  import           Hakyll.Core.Metadata
  import           Hakyll.Core.Provider
  import           Hakyll.Core.Routes
  import           Hakyll.Core.Store
  
  
  --------------------------------------------------------------------------------
  -- | Whilst compiling an item, it possible to save multiple snapshots of it, and
  -- not just the final result.
  type Snapshot = String
  
  
  --------------------------------------------------------------------------------
  -- | Environment in which a compiler runs
  data CompilerRead = CompilerRead
      { -- | Main configuration
        compilerConfig     :: Configuration
      , -- | Underlying identifier
        compilerUnderlying :: Identifier
      , -- | Resource provider
        compilerProvider   :: Provider
      , -- | List of all known identifiers
        compilerUniverse   :: Set Identifier
      , -- | Site routes
        compilerRoutes     :: Routes
      , -- | Compiler store
        compilerStore      :: Store
      , -- | Logger
        compilerLogger     :: Logger.Logger
      }
  
  
  --------------------------------------------------------------------------------
  data CompilerWrite = CompilerWrite
      { compilerDependencies :: [Dependency]
      , compilerCacheHits    :: Int
      } deriving (Show)
  
  
  --------------------------------------------------------------------------------
  instance Semigroup CompilerWrite where
      (<>) (CompilerWrite d1 h1) (CompilerWrite d2 h2) =
          CompilerWrite (d1 ++ d2) (h1 + h2)
  
  instance Monoid CompilerWrite where
      mempty  = CompilerWrite [] 0
      mappend = (<>)
  
  
  --------------------------------------------------------------------------------
  -- | Distinguishes reasons in a 'CompilerError'
  data CompilerErrors a
      -- | One or more exceptions occured during compilation
      = CompilationFailure (NonEmpty a)
      -- | Absence of any result, most notably in template contexts.  May still
      -- have error messages.
      | CompilationNoResult [a]
      deriving Functor
  
  
  -- | Unwrap a `CompilerErrors`
  compilerErrorMessages :: CompilerErrors a -> [a]
  compilerErrorMessages (CompilationFailure x)  = NonEmpty.toList x
  compilerErrorMessages (CompilationNoResult x) = x
  
  
  --------------------------------------------------------------------------------
  -- | An intermediate result of a compilation step
  data CompilerResult a
      = CompilerDone a CompilerWrite
      | CompilerSnapshot Snapshot (Compiler a)
      | CompilerRequire [(Identifier, Snapshot)] (Compiler a)
      | CompilerError (CompilerErrors String)
  
  
  --------------------------------------------------------------------------------
  -- | A monad which lets you compile items and takes care of dependency tracking
  -- for you.
  newtype Compiler a = Compiler
      { unCompiler :: CompilerRead -> IO (CompilerResult a)
      }
  
  
  --------------------------------------------------------------------------------
  instance Functor Compiler where
      fmap f (Compiler c) = Compiler $ \r -> do
          res <- c r
          return $ case res of
              CompilerDone x w      -> CompilerDone (f x) w
              CompilerSnapshot s c' -> CompilerSnapshot s (fmap f c')
              CompilerRequire i c'  -> CompilerRequire i (fmap f c')
              CompilerError e       -> CompilerError e
      {-# INLINE fmap #-}
  
  
  --------------------------------------------------------------------------------
  instance Monad Compiler where
      return = pure
      {-# INLINE return #-}
  
      Compiler c >>= f = Compiler $ \r -> do
          res <- c r
          case res of
              CompilerDone x w    -> do
                  res' <- unCompiler (f x) r
                  return $ case res' of
                      CompilerDone y w'     -> CompilerDone y (w `mappend` w')
                      CompilerSnapshot s c' -> CompilerSnapshot s $ do
                          compilerTell w  -- Save dependencies!
                          c'
                      CompilerRequire i c'  -> CompilerRequire i $ do
                          compilerTell w  -- Save dependencies!
                          c'
                      CompilerError e       -> CompilerError e
  
              CompilerSnapshot s c' -> return $ CompilerSnapshot s (c' >>= f)
              CompilerRequire i c'  -> return $ CompilerRequire i (c' >>= f)
              CompilerError e       -> return $ CompilerError e
      {-# INLINE (>>=) #-}
  
  #if !(MIN_VERSION_base(4,13,0))
      fail = Fail.fail
      {-# INLINE fail #-}
  #endif
  
  instance Fail.MonadFail Compiler where
      fail = compilerThrow . return
      {-# INLINE fail #-}
  
  --------------------------------------------------------------------------------
  instance Applicative Compiler where
      pure x = compilerResult $ CompilerDone x mempty
      {-# INLINE pure #-}
  
      f <*> x = f >>= \f' -> fmap f' x
      {-# INLINE (<*>) #-}
  
  
  --------------------------------------------------------------------------------
  -- | Access provided metadata from anywhere
  instance MonadMetadata Compiler where
      getMetadata = compilerGetMetadata
      getMatches  = compilerGetMatches
  
  
  --------------------------------------------------------------------------------
  -- | Compilation may fail with multiple error messages.
  -- 'catchError' handles errors from 'throwError', 'fail' and 'Hakyll.Core.Compiler.noResult'
  instance MonadError [String] Compiler where
      throwError = compilerThrow
      catchError c = compilerCatch c . (. compilerErrorMessages)
  
  
  --------------------------------------------------------------------------------
  -- | Like 'unCompiler' but treating IO exceptions as 'CompilerError's
  runCompiler :: Compiler a -> CompilerRead -> IO (CompilerResult a)
  runCompiler compiler read' = handle handler $ unCompiler compiler read'
    where
      handler :: SomeException -> IO (CompilerResult a)
      handler e = return $ CompilerError $ CompilationFailure $ show e :| []
  
  
  --------------------------------------------------------------------------------
  -- | Trying alternative compilers if the first fails, regardless whether through
  -- 'fail', 'throwError' or 'Hakyll.Core.Compiler.noResult'.
  -- Aggregates error messages if all fail.
  instance Alternative Compiler where
      empty   = compilerNoResult []
      x <|> y = x `compilerCatch` (\rx -> y `compilerCatch` (\ry ->
          case (rx, ry) of
            (CompilationFailure xs,  CompilationFailure ys)  ->
              compilerThrow $ NonEmpty.toList xs ++ NonEmpty.toList ys
            (CompilationFailure xs,  CompilationNoResult ys) ->
              debug ys >> compilerThrow (NonEmpty.toList xs)
            (CompilationNoResult xs, CompilationFailure ys)  ->
              debug xs >> compilerThrow (NonEmpty.toList ys)
            (CompilationNoResult xs, CompilationNoResult ys) -> compilerNoResult $ xs ++ ys
          ))
        where
          debug = compilerDebugEntries "Hakyll.Core.Compiler.Internal: Alternative fail suppressed"
      {-# INLINE (<|>) #-}
  
  
  --------------------------------------------------------------------------------
  -- | Put the result back in a compiler
  compilerResult :: CompilerResult a -> Compiler a
  compilerResult x = Compiler $ \_ -> return x
  {-# INLINE compilerResult #-}
  
  
  --------------------------------------------------------------------------------
  -- | Get the current environment
  compilerAsk :: Compiler CompilerRead
  compilerAsk = Compiler $ \r -> return $ CompilerDone r mempty
  {-# INLINE compilerAsk #-}
  
  
  --------------------------------------------------------------------------------
  -- | Put a 'CompilerWrite'
  compilerTell :: CompilerWrite -> Compiler ()
  compilerTell = compilerResult . CompilerDone ()
  {-# INLINE compilerTell #-}
  
  
  --------------------------------------------------------------------------------
  -- | Run an IO computation without dependencies in a Compiler
  compilerUnsafeIO :: IO a -> Compiler a
  compilerUnsafeIO io = Compiler $ \_ -> do
      x <- io
      return $ CompilerDone x mempty
  {-# INLINE compilerUnsafeIO #-}
  
  
  --------------------------------------------------------------------------------
  -- | Throw errors in the 'Compiler'.
  --
  -- If no messages are given, this is considered a 'CompilationNoResult' error.
  -- Otherwise, it is treated as a proper compilation failure.
  compilerThrow :: [String] -> Compiler a
  compilerThrow = compilerResult . CompilerError .
      maybe (CompilationNoResult []) CompilationFailure .
      NonEmpty.nonEmpty
  
  -- | Put a 'CompilerError' with  multiple messages as 'CompilationNoResult'
  compilerNoResult :: [String] -> Compiler a
  compilerNoResult = compilerResult . CompilerError . CompilationNoResult
  
  
  --------------------------------------------------------------------------------
  -- | Allows to distinguish 'CompilerError's and branch on them with 'Either'
  --
  -- prop> compilerTry = (`compilerCatch` return . Left) . fmap Right
  compilerTry :: Compiler a -> Compiler (Either (CompilerErrors String) a)
  compilerTry (Compiler x) = Compiler $ \r -> do
      res <- x r
      case res of
          CompilerDone res' w  -> return (CompilerDone (Right res') w)
          CompilerSnapshot s c -> return (CompilerSnapshot s (compilerTry c))
          CompilerRequire i c  -> return (CompilerRequire i (compilerTry c))
          CompilerError e      -> return (CompilerDone (Left e) mempty)
  {-# INLINE compilerTry #-}
  
  
  --------------------------------------------------------------------------------
  -- | Allows you to recover from 'CompilerError's.
  -- Uses the same parameter order as 'catchError' so that it can be used infix.
  --
  -- prop> c `compilerCatch` f = compilerTry c >>= either f return
  compilerCatch :: Compiler a -> (CompilerErrors String -> Compiler a) -> Compiler a
  compilerCatch (Compiler x) f = Compiler $ \r -> do
      res <- x r
      case res of
          CompilerDone res' w  -> return (CompilerDone res' w)
          CompilerSnapshot s c -> return (CompilerSnapshot s (compilerCatch c f))
          CompilerRequire i c  -> return (CompilerRequire i (compilerCatch c f))
          CompilerError e      -> unCompiler (f e) r
  {-# INLINE compilerCatch #-}
  
  
  --------------------------------------------------------------------------------
  compilerDebugLog :: [String] -> Compiler ()
  compilerDebugLog ms = do
    logger <- compilerLogger <$> compilerAsk
    compilerUnsafeIO $ forM_ ms $ Logger.debug logger
  
  --------------------------------------------------------------------------------
  -- | Pass a list of messages with a heading to the debug logger
  compilerDebugEntries :: String -> [String] -> Compiler ()
  compilerDebugEntries msg = compilerDebugLog . (msg:) . map indent
    where
      indent = unlines . map ("    "++) . lines
  
  
  --------------------------------------------------------------------------------
  compilerTellDependencies :: [Dependency] -> Compiler ()
  compilerTellDependencies ds = do
    compilerDebugLog $ map (\d ->
        "Hakyll.Core.Compiler.Internal: Adding dependency: " ++ show d) ds
    compilerTell mempty {compilerDependencies = ds}
  {-# INLINE compilerTellDependencies #-}
  
  
  --------------------------------------------------------------------------------
  compilerTellCacheHits :: Int -> Compiler ()
  compilerTellCacheHits ch = compilerTell mempty {compilerCacheHits = ch}
  {-# INLINE compilerTellCacheHits #-}
  
  
  --------------------------------------------------------------------------------
  compilerGetMetadata :: Identifier -> Compiler Metadata
  compilerGetMetadata identifier = do
      provider <- compilerProvider <$> compilerAsk
      compilerTellDependencies [IdentifierDependency identifier]
      compilerUnsafeIO $ resourceMetadata provider identifier
  
  
  --------------------------------------------------------------------------------
  compilerGetMatches :: Pattern -> Compiler [Identifier]
  compilerGetMatches pattern = do
      universe <- compilerUniverse <$> compilerAsk
      let matching = S.filter (matches pattern) universe
      compilerTellDependencies [PatternDependency pattern matching]
      pure $ S.toList matching
  