content: {-# LANGUAGE CPP #-}
  {-# LANGUAGE FunctionalDependencies #-}
  {-# LANGUAGE MultiParamTypeClasses #-}
  {-# LANGUAGE UndecidableInstances #-}
  {-# LANGUAGE ScopedTypeVariables #-}
  {-# LANGUAGE DeriveDataTypeable #-}
  {-# LANGUAGE FlexibleInstances #-}
  {-# LANGUAGE FlexibleContexts #-}
  {-# LANGUAGE KindSignatures #-}
  #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 707
  {-# LANGUAGE ConstraintKinds #-}
  {-# LANGUAGE PolyKinds #-}
  {-# LANGUAGE RoleAnnotations #-}
  #endif
  
  #ifndef MIN_VERSION_base
  #define MIN_VERSION_base(x,y,z) 1
  #endif
  -----------------------------------------------------------------------------
  -- |
  -- Module      :  Silica.Internal.Exception
  -- Copyright   :  (C) 2013-2016 Edward Kmett
  -- License     :  BSD-style (see the file LICENSE)
  -- Maintainer  :  Edward Kmett <ekmett@gmail.com>
  -- Stability   :  experimental
  -- Portability :  non-portable
  --
  -- This module uses dirty tricks to generate a 'Handler' from an arbitrary
  -- 'Fold'.
  ----------------------------------------------------------------------------
  module Silica.Internal.Exception
    ( Handleable(..)
    , HandlingException(..)
    ) where
  
  import Control.Exception as Exception
  import Silica.Fold
  import Silica.Getter
  import Control.Monad.Catch as Catch
  import Data.Monoid
  import Data.Proxy
  import Data.Reflection
  import Data.Typeable
  
  -- This is needed because ghc 7.8-rc2 has Typeable1 as a type alias.
  #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 707
  #define Typeable1 Typeable
  #endif
  
  ------------------------------------------------------------------------------
  -- Handlers
  ------------------------------------------------------------------------------
  
  -- | Both @exceptions@ and "Control.Exception" provide a 'Handler' type.
  --
  -- This lets us write combinators to build handlers that are agnostic about the choice of
  -- which of these they use.
  class Handleable e (m :: * -> *) (h :: * -> *) | h -> e m where
    -- | This builds a 'Handler' for just the targets of a given 'Silica.Type.Prism' (or any 'Getter', really).
    --
    -- @
    -- 'catches' ... [ 'handler' 'Control.Exception.Lens._AssertionFailed' (\s -> 'print' '$' \"Assertion Failed\\n\" '++' s)
    --             , 'handler' 'Control.Exception.Lens._ErrorCall' (\s -> 'print' '$' \"Error\\n\" '++' s)
    --             ]
    -- @
    --
    -- This works ith both the 'Exception.Handler' type provided by @Control.Exception@:
    --
    -- @
    -- 'handler' :: 'Getter'     'SomeException' a -> (a -> 'IO' r) -> 'Exception.Handler' r
    -- 'handler' :: 'Fold'       'SomeException' a -> (a -> 'IO' r) -> 'Exception.Handler' r
    -- 'handler' :: 'Silica.Prism.Prism''     'SomeException' a -> (a -> 'IO' r) -> 'Exception.Handler' r
    -- 'handler' :: 'Silica.Lens.Lens''      'SomeException' a -> (a -> 'IO' r) -> 'Exception.Handler' r
    -- 'handler' :: 'Silica.Traversal.Traversal'' 'SomeException' a -> (a -> 'IO' r) -> 'Exception.Handler' r
    -- @
    --
    -- and with the 'Catch.Handler' type provided by @Control.Monad.Catch@:
    --
    -- @
    -- 'handler' :: 'Getter'     'SomeException' a -> (a -> m r) -> 'Catch.Handler' m r
    -- 'handler' :: 'Fold'       'SomeException' a -> (a -> m r) -> 'Catch.Handler' m r
    -- 'handler' :: 'Silica.Prism.Prism''     'SomeException' a -> (a -> m r) -> 'Catch.Handler' m r
    -- 'handler' :: 'Silica.Lens.Lens''      'SomeException' a -> (a -> m r) -> 'Catch.Handler' m r
    -- 'handler' :: 'Silica.Traversal.Traversal'' 'SomeException' a -> (a -> m r) -> 'Catch.Handler' m r
    -- @
    --
    -- and with the 'Control.Monad.Error.Lens.Handler' type provided by @Control.Monad.Error.Lens@:
    --
    -- @
    -- 'handler' :: 'Getter'     e a -> (a -> m r) -> 'Control.Monad.Error.Lens.Handler' e m r
    -- 'handler' :: 'Fold'       e a -> (a -> m r) -> 'Control.Monad.Error.Lens.Handler' e m r
    -- 'handler' :: 'Silica.Prism.Prism''     e a -> (a -> m r) -> 'Control.Monad.Error.Lens.Handler' e m r
    -- 'handler' :: 'Silica.Lens.Lens''      e a -> (a -> m r) -> 'Control.Monad.Error.Lens.Handler' e m r
    -- 'handler' :: 'Silica.Traversal.Traversal'' e a -> (a -> m r) -> 'Control.Monad.Error.Lens.Handler' e m r
    -- @
    handler :: Typeable a => Getting (First a) e a -> (a -> m r) -> h r
  
    -- | This builds a 'Handler' for just the targets of a given 'Silica.Prism.Prism' (or any 'Getter', really).
    -- that ignores its input and just recovers with the stated monadic action.
    --
    -- @
    -- 'catches' ... [ 'handler_' 'Control.Exception.Lens._NonTermination' ('return' \"looped\")
    --             , 'handler_' 'Control.Exception.Lens._StackOverflow' ('return' \"overflow\")
    --             ]
    -- @
    --
    -- This works with the 'Exception.Handler' type provided by @Control.Exception@:
    --
    -- @
    -- 'handler_' :: 'Getter'     'SomeException' a -> 'IO' r -> 'Exception.Handler' r
    -- 'handler_' :: 'Fold'       'SomeException' a -> 'IO' r -> 'Exception.Handler' r
    -- 'handler_' :: 'Silica.Prism.Prism''     'SomeException' a -> 'IO' r -> 'Exception.Handler' r
    -- 'handler_' :: 'Silica.Lens.Lens''      'SomeException' a -> 'IO' r -> 'Exception.Handler' r
    -- 'handler_' :: 'Silica.Traversal.Traversal'' 'SomeException' a -> 'IO' r -> 'Exception.Handler' r
    -- @
    --
    -- and with the 'Catch.Handler' type provided by @Control.Monad.Catch@:
    --
    -- @
    -- 'handler_' :: 'Getter'     'SomeException' a -> m r -> 'Catch.Handler' m r
    -- 'handler_' :: 'Fold'       'SomeException' a -> m r -> 'Catch.Handler' m r
    -- 'handler_' :: 'Silica.Prism.Prism''     'SomeException' a -> m r -> 'Catch.Handler' m r
    -- 'handler_' :: 'Silica.Lens.Lens''      'SomeException' a -> m r -> 'Catch.Handler' m r
    -- 'handler_' :: 'Silica.Traversal.Traversal'' 'SomeException' a -> m r -> 'Catch.Handler' m r
    -- @
    --
    -- and with the 'Control.Monad.Error.Lens.Handler' type provided by @Control.Monad.Error.Lens@:
    --
    -- @
    -- 'handler_' :: 'Getter'     e a -> m r -> 'Control.Monad.Error.Lens.Handler' e m r
    -- 'handler_' :: 'Fold'       e a -> m r -> 'Control.Monad.Error.Lens.Handler' e m r
    -- 'handler_' :: 'Silica.Prism.Prism''     e a -> m r -> 'Control.Monad.Error.Lens.Handler' e m r
    -- 'handler_' :: 'Silica.Lens.Lens''      e a -> m r -> 'Control.Monad.Error.Lens.Handler' e m r
    -- 'handler_' :: 'Silica.Traversal.Traversal'' e a -> m r -> 'Control.Monad.Error.Lens.Handler' e m r
    -- @
    handler_ :: Typeable a => Getting (First a) e a -> m r -> h r
    handler_ l = handler l . const
    {-# INLINE handler_ #-}
  
  instance Handleable SomeException IO Exception.Handler where
    handler = handlerIO
  
  instance Typeable1 m => Handleable SomeException m (Catch.Handler m) where
    handler = handlerCatchIO
  
  handlerIO :: forall a r. Typeable a => Getting (First a) SomeException a -> (a -> IO r) -> Exception.Handler r
  handlerIO l f = reifyTypeable (preview l) $ \ (_ :: Proxy s) -> Exception.Handler (\(Handling a :: Handling a s IO) -> f a)
  
  handlerCatchIO :: forall m a r. (Typeable a, Typeable1 m) => Getting (First a) SomeException a -> (a -> m r) -> Catch.Handler m r
  handlerCatchIO l f = reifyTypeable (preview l) $ \ (_ :: Proxy s) -> Catch.Handler (\(Handling a :: Handling a s m) -> f a)
  
  ------------------------------------------------------------------------------
  -- Helpers
  ------------------------------------------------------------------------------
  
  -- | There was an 'Exception' caused by abusing the internals of a 'Handler'.
  data HandlingException = HandlingException deriving (Show,Typeable)
  
  instance Exception HandlingException
  
  {-
  -- | This supplies a globally unique set of IDs so we can hack around the default use of 'cast' in 'SomeException'
  -- if someone, somehow, somewhere decides to reach in and catch and rethrow a @Handling@ 'Exception' by existentially
  -- opening a 'Handler' that uses it.
  supply :: IORef Int
  supply = unsafePerformIO $ newIORef 0
  {-# NOINLINE supply #-}
  -}
  
  -- | This permits the construction of an \"impossible\" 'Control.Exception.Handler' that matches only if some function does.
  newtype Handling a s (m :: * -> *) = Handling a
  #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ >= 707
    deriving Typeable
  
  type role Handling representational nominal nominal
  #else
  -- the m parameter exists simply to break the Typeable1 pattern, so we can provide this without overlap.
  -- here we simply generate a fresh TypeRep so we'll fail to compare as equal to any other TypeRep.
  instance (Typeable a, Typeable s, Typeable1 m) => Typeable (Handling a s m) where
    typeOf _ = mkTyConApp handlingTyCon [typeOf (undefined :: a), typeOf (undefined :: s), typeOf1 (undefined :: m a)]
    {-# INLINE typeOf #-}
  
  handlingTyCon :: TyCon
  handlingTyCon = mkTyCon3 "lens" "Silica.Internal.Exception" "Handling"
  {-# NOINLINE handlingTyCon #-}
  #endif
  
  -- The @Handling@ wrapper is uninteresting, and should never be thrown, so you won't get much benefit here.
  instance Show (Handling a s m) where
    showsPrec d _ = showParen (d > 10) $ showString "Handling ..."
    {-# INLINE showsPrec #-}
  
  instance (Reifies s (SomeException -> Maybe a), Typeable (Handling a s m)) => Exception (Handling a s m) where
    toException _ = SomeException HandlingException
    {-# INLINE toException #-}
    fromException = fmap Handling . reflect (Proxy :: Proxy s)
    {-# INLINE fromException #-}
  