content: {-# LANGUAGE DeriveDataTypeable, PatternGuards, RecordWildCards, ConstraintKinds #-}
  
  -- | Errors seen by the user
  module Development.Shake.Internal.Errors(
      ShakeException(..),
      throwM, throwImpure,
      errorInternal,
      errorStructured,
      errorNoRuleToBuildType, errorRuleDefinedMultipleTimes,
      errorMultipleRulesMatch, errorRuleRecursion, errorComplexRecursion, errorNoApply,
      errorDirectoryNotFile, errorNoHash
      ) where
  
  import Data.Tuple.Extra
  import Control.Exception.Extra
  import Control.Monad.IO.Class
  import General.Extra
  import Data.Typeable
  import Data.List.Extra
  import Data.Maybe
  
  
  throwM :: MonadIO m => SomeException -> m a
  throwM = liftIO . throwIO
  
  throwImpure :: SomeException -> a
  throwImpure = throw
  
  
  errorInternal :: Partial => String -> SomeException
  errorInternal msg = toException $ ErrorCall $ unlines $
      ("Development.Shake: Internal error, please report to Neil Mitchell (" ++ msg ++ ")") : callStackFull
  
  alternatives = let (*) = (,) in
      ["_rule_" * "oracle"
      ,"_Rule_" * "Oracle"
      ,"_key_" * "question"
      ,"_Key_" * "Question"
      ,"_result_" * "answer"
      ,"_Result_" * "Answer"
      ,"_addBuiltinRule_" * "addOracle"
      ,"_apply_" * "askOracle"]
  
  
  errorStructured :: String -> [(String, Maybe String)] -> String -> SomeException
  errorStructured msg args hint = toException $ ErrorCall $ unlines $
          [msg ++ (if null args then "." else ":")] ++
          ["  " ++ a ++ [':' | a /= ""] ++ replicate (as - length a + 2) ' ' ++ b | (a,b) <- args2] ++
          [hint | hint /= ""]
      where
          as = maximum $ 0 : map (length . fst) args2
          args2 = [(a,b) | (a,Just b) <- args]
  
  
  
  structured :: Bool -> String -> [(String, Maybe String)] -> String -> SomeException
  structured alt msg args hint = errorStructured (f msg) (map (first f) args) (f hint)
      where
          f = filter (/= '_') . (if alt then g else id)
          g xs | res:_ <- [to ++ g rest | (from, to) <- alternatives, Just rest <- [stripPrefix from xs]] = res
          g (x:xs) = x : g xs
          g [] = []
  
  
  errorDirectoryNotFile :: FilePath -> SomeException
  errorDirectoryNotFile dir = errorStructured
      "Build system error - expected a file, got a directory"
      [("Directory", Just dir)]
      "Probably due to calling 'need' on a directory. Shake only permits 'need' on files."
  
  errorNoRuleToBuildType :: TypeRep -> Maybe String -> Maybe TypeRep -> SomeException
  errorNoRuleToBuildType tk k tv = structured (specialIsOracleKey tk)
      "Build system error - no _rule_ matches the _key_ type"
      [("_Key_ type", Just $ show tk)
      ,("_Key_ value", k)
      ,("_Result_ type", fmap show tv)]
      "You are missing a call to _addBuiltinRule_, or your call to _apply_ has the wrong _key_ type"
  
  errorRuleDefinedMultipleTimes :: TypeRep -> [String] -> SomeException
  errorRuleDefinedMultipleTimes tk locations = structured (specialIsOracleKey tk)
      "Build system error - _rule_ defined twice at one _key_ type"
      (("_Key_ type", Just $ show tk) :
       [("Location " ++ show i, Just x) | (i, x) <- zipFrom 1 locations])
      "You have called _addBuiltinRule_ more than once on the same key type"
  
  errorMultipleRulesMatch :: TypeRep -> String -> [Maybe String] -> SomeException
  errorMultipleRulesMatch tk k names = errorStructured
      ("Build system error - key matches " ++ (if null names then "no" else "multiple") ++ " rules")
      ([("Key type",Just $ show tk)
      ,("Key value",Just k)
      ,("Rules matched",Just $ show $ length names)] ++
      [("Rule " ++ show i, x) | any isJust names, (i, x) <- zipFrom 1 names])
      (if null names then "Either add a rule that produces the above key, or stop requiring the above key"
      else "Modify your rules so only one can produce the above key")
  
  errorNoHash :: SomeException
  errorNoHash = errorStructured "Cannot use shakeChange=ChangeModTime with shakeShare" [] ""
  
  errorRuleRecursion :: TypeRep -> String -> SomeException
  -- may involve both rules and oracle, so report as only rules
  errorRuleRecursion tk k = errorStructured
      "Build system error - recursion detected"
      [("Key type",Just $ show tk)
      ,("Key value",Just k)]
      "Rules may not be recursive"
  
  errorComplexRecursion :: [String] -> SomeException
  errorComplexRecursion ks = errorStructured
      "Build system error - indirect recursion detected"
      [("Key value " ++ show i, Just k) | (i, k) <- zipFrom 1 ks]
      "Rules may not be recursive"
  
  errorNoApply :: TypeRep -> Maybe String -> String -> SomeException
  errorNoApply tk k msg = errorStructured
      "Build system error - cannot currently introduce a dependency (e.g. calling 'apply')"
      [("Reason", Just msg)
      ,("Key type", Just $ show tk)
      ,("Key value", k)]
      "Move the call earlier/later"
  
  
  -- Should be in Special, but then we get an import cycle
  specialIsOracleKey :: TypeRep -> Bool
  specialIsOracleKey t = con == "OracleQ"
      where con = show $ fst $ splitTyConApp t
  
  
  -- | Error representing all expected exceptions thrown by Shake.
  --   Problems when executing rules will be raising using this exception type.
  data ShakeException = ShakeException
      {shakeExceptionTarget :: String -- ^ The target that was being built when the exception occurred.
      ,shakeExceptionStack :: [String]  -- ^ A description of the call stack, one entry per line.
      ,shakeExceptionInner :: SomeException -- ^ The underlying exception that was raised.
      }
      deriving Typeable
  
  instance Exception ShakeException
  
  instance Show ShakeException where
      show ShakeException{..} = unlines $
          "Error when running Shake build system:" :
          shakeExceptionStack ++
          [displayException shakeExceptionInner]
  