{-# LANGUAGE AllowAmbiguousTypes   #-}
{-# LANGUAGE ConstraintKinds       #-}
{-# LANGUAGE CPP                   #-}
{-# LANGUAGE DerivingStrategies    #-}
{-# LANGUAGE DerivingVia           #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE QuasiQuotes           #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE StandaloneDeriving    #-}
{-# LANGUAGE TemplateHaskell       #-}
{-# LANGUAGE TypeApplications      #-}
{-# LANGUAGE TypeOperators         #-}

-- | Hierarchical exceptions are a powerful and useful tool in the Haskell
-- toolbox, but they're not used anywhere near often enough. I suspect it's
-- because they're a) not very commonly understood and b) a lot of
-- boilerplate to write. This library is intended to help the latter
-- problem.
--
-- Let's look at an example. We'll define a type for all of our
-- application's exceptions:
--
-- @
-- data AppException where
--   AppException :: 'Exception' e => AppException
--
-- deriving stock instance 'Show' AppException
--
-- instance 'Exception' AppException
--
-- 'mkHierarchy' ''AppException
-- @
--
-- Now, we can 'try' to catch all of the 'Exception's that we define
-- ourselves:
--
-- @
-- tryApp :: 'IO' a -> 'IO' ('Either' AppException a)
-- tryApp = 'try'
-- @
--
-- Now let's define a problem that might happen in our domain. We're going
-- to derive 'Exception' through our subtype wrapper.
--
-- @
-- data HttpException = HttpException
--   deriving stock Show
--   deriving
--     via (HttpException <!!! AppException)
--       Exception HttpException
-- @
--
-- Now, we can throw an @HttpException@, and catch it as part of
-- @AppException@:
--
-- @
-- throwHttp :: IO x
-- throwHttp = 'throwIO' HttpException
--
-- main = do
--   eresult <- tryApp throwHttp
--   case result of
--     Left (AppException err) ->
--       putStrLn "I caught it!"
--     Right _ ->
--       putStrLn "Wait what??
-- @
--
-- For each "step" in the hierarchy, you define a GADT like @AppException@
-- above. Define an instance of 'Hierarchy' for it, either via the Template
-- Haskell helper 'mkHierarchy', or manually.
module ExceptionVia
  ( -- * Deriving Via Helpers
    type (<!!!)
  , ExceptionVia(..)
  -- * Establishing Hierarchy
  , mkHierarchy
  , Hierarchy(..)
  ) where

import           Control.Exception
import           Control.Monad
import           Data.Typeable
import           Debug.Trace
import           Language.Haskell.TH
import           Language.Haskell.TH.Quote

-- | This is the explicit word version of '(<!!!)'. You can use this if you
-- don't like @TypeOperators@.
--
-- Given a wrapper exception type like @SomeCompilerException@, you can
-- derive an instance of 'Exception' like so:
--
-- @
-- data MismatchedParentheses = MismatchedParentheses
--   deriving stock Show
--   deriving
--     via (ExceptionVia SomeCompilerException MismatchedParentheses)
--       Exception MismatchedParentheses
-- @
--
-- @since 0.1.0.0
newtype ExceptionVia big lil = ExceptionVia { forall big lil. ExceptionVia big lil -> lil
unExceptionVia :: lil }
  deriving Int -> ExceptionVia big lil -> ShowS
[ExceptionVia big lil] -> ShowS
ExceptionVia big lil -> String
(Int -> ExceptionVia big lil -> ShowS)
-> (ExceptionVia big lil -> String)
-> ([ExceptionVia big lil] -> ShowS)
-> Show (ExceptionVia big lil)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall big lil. Show lil => Int -> ExceptionVia big lil -> ShowS
forall big lil. Show lil => [ExceptionVia big lil] -> ShowS
forall big lil. Show lil => ExceptionVia big lil -> String
$cshowsPrec :: forall big lil. Show lil => Int -> ExceptionVia big lil -> ShowS
showsPrec :: Int -> ExceptionVia big lil -> ShowS
$cshow :: forall big lil. Show lil => ExceptionVia big lil -> String
show :: ExceptionVia big lil -> String
$cshowList :: forall big lil. Show lil => [ExceptionVia big lil] -> ShowS
showList :: [ExceptionVia big lil] -> ShowS
Show


instance (Hierarchy big, Exception big, Exception lil) => Exception (ExceptionVia big lil) where
  toException :: ExceptionVia big lil -> SomeException
toException (ExceptionVia lil
e) = big -> SomeException
forall e. Exception e => e -> SomeException
toException (forall big lil. (Hierarchy big, Exception lil) => lil -> big
toParent @big lil
e)
  fromException :: SomeException -> Maybe (ExceptionVia big lil)
fromException SomeException
e =
    lil -> ExceptionVia big lil
forall big lil. lil -> ExceptionVia big lil
ExceptionVia
      (lil -> ExceptionVia big lil)
-> Maybe lil -> Maybe (ExceptionVia big lil)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (big -> Maybe lil
forall lil. Exception lil => big -> Maybe lil
forall big lil. (Hierarchy big, Exception lil) => big -> Maybe lil
fromParent (big -> Maybe lil) -> Maybe big -> Maybe lil
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall e. Exception e => SomeException -> Maybe e
fromException @big SomeException
e)

-- | A concise operator alias for 'ExceptionVia'.
--
-- Given a wrapper exception type like @SomeCompilerException@, you can
-- derive an instance of 'Exception' like so:
--
-- @
-- data MismatchedParentheses = MismatchedParentheses
--   deriving stock Show
--   deriving
--     via (MismatchedParentheses <!!! SomeCompilerException)
--       Exception MismatchedParentheses
-- @
--
-- @since 0.1.0.0
type lil <!!! big = ExceptionVia big lil

-- | This class tells us how to wrap and unwrap values from our
-- hierarchical wrapper types. It is very similar to 'Exception', but
-- instead of specifying how to put some value into a 'SomeException' or
-- cast a value from a 'SomeException', we say how to put any value into
-- this @big@ type or cast any value out of the @big@ type.
--
-- Instances are very straightforward. For any type:
--
-- @
-- data ExceptionWrapper where
--   ExceptionWrapper :: Exception e => e -> ExceptionWrapper
-- @
--
-- The instance will look like this:
--
-- @
-- instance 'Hierarchy' ExceptionWrapper where
--   'toParent' = ExceptionWrapper
--   'fromParent' (ExceptionWrapper e) = 'cast' e
-- @
--
-- You can skip the boilerplate with the 'mkHierarchy' Template Haskell
-- function.
--
-- @since 0.1.0.0
class (Typeable big) => Hierarchy big where
  -- | Given any 'Exception'al value, wrap it up in the @big@ type.
  --
  -- @since 0.1.0.0
  toParent :: Exception lil => lil -> big

  -- | Given a @big@ type, 'cast' out the 'Exception' buried within. Will
  -- return 'Nothing' if the requested type is different from the actual
  -- contained value.
  --
  -- @since 0.1.0.0
  fromParent :: (Exception lil) => big -> Maybe lil

-- | Create a boilerplate 'Hierarchy' instance for a type given a name.
--
-- This code block defines an exception wrapper type and an accompanying
-- 'Hierarchy' instance.
--
-- @
-- data ExceptionWrapper where
--   ExceptionWrapper :: Exception e => e -> ExceptionWrapper
--
-- mkHierarchy ''ExceptionWrapper
-- @
--
-- @since 0.1.0.0
mkHierarchy :: Name -> DecsQ
mkHierarchy :: Name -> DecsQ
mkHierarchy Name
nm = do
  Info
info <- Name -> Q Info
reify Name
nm
  Con
con <-
    case Info
info of
      TyConI Dec
d ->
        case Dec
d of
          DataD Cxt
_ Name
_ [TyVarBndr ()]
_ Maybe Kind
_ [Con
con] [DerivClause]
_ ->
            Con -> Q Con
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Con
con
          NewtypeD Cxt
_ Name
_ [TyVarBndr ()]
_ Maybe Kind
_ Con
con [DerivClause]
_ ->
            Con -> Q Con
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Con
con
          DataInstD Cxt
_ Maybe [TyVarBndr ()]
_ Kind
_ Maybe Kind
_ [Con
con] [DerivClause]
_ ->
            Con -> Q Con
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Con
con
          NewtypeInstD Cxt
_ Maybe [TyVarBndr ()]
_ Kind
_ Maybe Kind
_ Con
con [DerivClause]
_ ->
            Con -> Q Con
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Con
con
          Dec
_ ->
            String -> Q Con
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Unsupported type constructor. Must have a single constructor."

  let
    getConName :: Con -> f Name
getConName Con
c =
      case Con
c of
        NormalC Name
n [BangType]
_ ->
          Name -> f Name
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
n
        RecC Name
n [VarBangType]
_ ->
          Name -> f Name
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
n
        ForallC [TyVarBndr Specificity]
_ Cxt
_ Con
c ->
          Con -> f Name
getConName Con
c
        GadtC [Name
n] [BangType]
_ Kind
_ ->
          Name -> f Name
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
n
        RecGadtC [Name
n] [VarBangType]
_ Kind
_ ->
          Name -> f Name
forall a. a -> f a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
n
        Con
_ ->
          String -> f Name
forall a. String -> f a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Can't use with an infix constructor. Must have a single argument."

  Name
constrName <- Con -> Q Name
forall {f :: * -> *}. MonadFail f => Con -> f Name
getConName Con
con

  [d|
    instance Hierarchy $(Name -> Q Kind
forall (m :: * -> *). Quote m => Name -> m Kind
conT Name
nm) where
      toParent = $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
constrName)
#if MIN_VERSION_template_haskell(2,18,0)
      fromParent $(Pat -> Q Pat
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pat -> Q Pat) -> Pat -> Q Pat
forall a b. (a -> b) -> a -> b
$ Name -> Cxt -> [Pat] -> Pat
ConP Name
constrName [] [Name -> Pat
VarP (String -> Name
mkName String
"e")]) = cast e
#else
      fromParent $(pure $ ConP constrName [VarP (mkName "e")]) = cast e
#endif
    |]