{-# LANGUAGE
  CPP,
  DeriveDataTypeable,
  GADTs,
  KindSignatures,
  PolyKinds,
  ScopedTypeVariables #-}

-- | Derive instances without spelling out "deriving".
--
-- = Usage
--
-- __Step 1__: add this pragma at the top of the file to load the plugin:
--
-- @
-- {-\# OPTIONS_GHC -fplugin=Driving.Classes \#-}
-- @
--
-- __Step 2__: enable @DerivingStrategies@ and other relevant extensions as needed
-- (@DerivingVia@, @GeneralizedNewtypeDeriving@, @DeriveAnyClass@):
--
-- @
-- {-\# LANGUAGE DerivingStrategies \#-}
-- @
--
-- __Step 3__: add an @ANN@ pragma after imports to configure the classes to auto-derive:
--
-- @
-- {-\# ANN module (Driving :: Driving '[ \<LIST OF OPTIONS\> ]) \#-}
-- @
--
-- = Example
--
-- This automatically declares instances of @Eq@, @Ord@, @Show@ for @T@, @U@, @V@,
-- and disables auto-deriving for @MyEndo@.
--
-- @
-- {-\# ANN module (Driving :: Driving
--   '[ Stock '(Eq, Ord, Show)
--    , NoDriving '(Eq MyEndo, Ord MyEndo, Show MyEndo)
--    ]) \#-}
--
-- data T = C1 | C2
-- data U = D1 | D2
-- data V = E1 | E2
--
-- newtype MyEndo a = MyEndo (a -> a)
-- @
--
-- Available options:
--
-- - 'Stock'
-- - 'Anyclass'
-- - 'Newtype'
-- - 'Via'
-- - 'ViaF'
-- - 'NoDriving'
--
-- See more examples below.

#if __GLASGOW_HASKELL__ >= 904
#define noLoc noLocA
#define GHC904(x,y) x
#else
#define GHC904(x,y) y
#endif
#if __GLASGOW_HASKELL__ >= 902
#define GHC902(x,y) x
#else
#define GHC902(x,y) y
#endif

module Driving.Classes
  ( -- * Options
    Driving(..)
  , Stock
  , Newtype
  , Anyclass
  , Via
  , ViaF
  , NoDriving

    -- * Plugin
  , plugin) where

import Data.Bifunctor (first)
import Data.Data (Data)
import Data.Kind (Type)

import Data.Map (Map)
import qualified Data.Map as Map
import Data.Set (Set)
import qualified Data.Set as Set

#if __GLASGOW_HASKELL__ >= 900
import GHC.Plugins hiding (Type)
#else
import GhcPlugins hiding (Type)
#endif
#if __GLASGOW_HASKELL__ >= 810
import GHC.Hs
#else
import HsSyn
#define NoExtField NoExt
#endif

-- * User configuration

-- | Type constructor for configuring the plugin in a source annotation.
--
-- Argument: list of types using the constructors below.
--
-- === Example
--
-- @
-- {-\# ANN module (Driving :: 'Driving' '[ 'Stock' '(Eq, Ord), 'Newtype' Num ]) \#-}
-- @
data Driving :: k -> Type where
  -- | Dummy constructor
  Driving :: Driving x
  deriving Driving a -> DataType
Driving a -> Constr
forall a.
Typeable a
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall {k} {a :: k}.
(Typeable a, Typeable k) =>
Typeable (Driving a)
forall k (a :: k).
(Typeable a, Typeable k) =>
Driving a -> DataType
forall k (a :: k). (Typeable a, Typeable k) => Driving a -> Constr
forall k (a :: k).
(Typeable a, Typeable k) =>
(forall b. Data b => b -> b) -> Driving a -> Driving a
forall k (a :: k) u.
(Typeable a, Typeable k) =>
Int -> (forall d. Data d => d -> u) -> Driving a -> u
forall k (a :: k) u.
(Typeable a, Typeable k) =>
(forall d. Data d => d -> u) -> Driving a -> [u]
forall k (a :: k) r r'.
(Typeable a, Typeable k) =>
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Driving a -> r
forall k (a :: k) r r'.
(Typeable a, Typeable k) =>
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Driving a -> r
forall k (a :: k) (m :: * -> *).
(Typeable a, Typeable k, Monad m) =>
(forall d. Data d => d -> m d) -> Driving a -> m (Driving a)
forall k (a :: k) (m :: * -> *).
(Typeable a, Typeable k, MonadPlus m) =>
(forall d. Data d => d -> m d) -> Driving a -> m (Driving a)
forall k (a :: k) (c :: * -> *).
(Typeable a, Typeable k) =>
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (Driving a)
forall k (a :: k) (c :: * -> *).
(Typeable a, Typeable k) =>
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Driving a -> c (Driving a)
forall k (a :: k) (t :: * -> *) (c :: * -> *).
(Typeable a, Typeable k, Typeable t) =>
(forall d. Data d => c (t d)) -> Maybe (c (Driving a))
forall k (a :: k) (t :: * -> * -> *) (c :: * -> *).
(Typeable a, Typeable k, Typeable t) =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c (Driving a))
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (Driving a)
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Driving a -> c (Driving a)
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Driving a -> m (Driving a)
$cgmapMo :: forall k (a :: k) (m :: * -> *).
(Typeable a, Typeable k, MonadPlus m) =>
(forall d. Data d => d -> m d) -> Driving a -> m (Driving a)
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Driving a -> m (Driving a)
$cgmapMp :: forall k (a :: k) (m :: * -> *).
(Typeable a, Typeable k, MonadPlus m) =>
(forall d. Data d => d -> m d) -> Driving a -> m (Driving a)
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Driving a -> m (Driving a)
$cgmapM :: forall k (a :: k) (m :: * -> *).
(Typeable a, Typeable k, Monad m) =>
(forall d. Data d => d -> m d) -> Driving a -> m (Driving a)
gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> Driving a -> u
$cgmapQi :: forall k (a :: k) u.
(Typeable a, Typeable k) =>
Int -> (forall d. Data d => d -> u) -> Driving a -> u
gmapQ :: forall u. (forall d. Data d => d -> u) -> Driving a -> [u]
$cgmapQ :: forall k (a :: k) u.
(Typeable a, Typeable k) =>
(forall d. Data d => d -> u) -> Driving a -> [u]
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Driving a -> r
$cgmapQr :: forall k (a :: k) r r'.
(Typeable a, Typeable k) =>
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Driving a -> r
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Driving a -> r
$cgmapQl :: forall k (a :: k) r r'.
(Typeable a, Typeable k) =>
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Driving a -> r
gmapT :: (forall b. Data b => b -> b) -> Driving a -> Driving a
$cgmapT :: forall k (a :: k).
(Typeable a, Typeable k) =>
(forall b. Data b => b -> b) -> Driving a -> Driving a
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c (Driving a))
$cdataCast2 :: forall k (a :: k) (t :: * -> * -> *) (c :: * -> *).
(Typeable a, Typeable k, Typeable t) =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (c (Driving a))
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c (Driving a))
$cdataCast1 :: forall k (a :: k) (t :: * -> *) (c :: * -> *).
(Typeable a, Typeable k, Typeable t) =>
(forall d. Data d => c (t d)) -> Maybe (c (Driving a))
dataTypeOf :: Driving a -> DataType
$cdataTypeOf :: forall k (a :: k).
(Typeable a, Typeable k) =>
Driving a -> DataType
toConstr :: Driving a -> Constr
$ctoConstr :: forall k (a :: k). (Typeable a, Typeable k) => Driving a -> Constr
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (Driving a)
$cgunfold :: forall k (a :: k) (c :: * -> *).
(Typeable a, Typeable k) =>
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (Driving a)
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Driving a -> c (Driving a)
$cgfoldl :: forall k (a :: k) (c :: * -> *).
(Typeable a, Typeable k) =>
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Driving a -> c (Driving a)
Data

-- | Auto-derive classes using the @stock@ deriving strategy.
--
-- Argument: a class (of kind @k -> Constraint@ for some @k@), or a tuple of classes.
--
-- === Examples
--
-- @
-- {-\# ANN module (Driving :: 'Driving' '[ 'Stock' Show ]) \#-}
-- {-\# ANN module (Driving :: 'Driving' '[ 'Stock' '(Eq, Ord) ]) \#-}
-- @
data Stock :: k -> Type

-- | Auto-derive classes using the @newtype@ deriving strategy.
-- Enable the extension @GeneralizedNewtypeDeriving@ to use this.
--
-- Argument: a class (of kind @k -> Constraint@ for some @k@), or a tuple of classes.
--
-- === Examples
--
-- @
-- {-\# ANN module (Driving :: 'Driving' '[ 'Newtype' Num ]) \#-}
-- {-\# ANN module (Driving :: 'Driving' '[ 'Newtype' '(Semigroup, Monoid)]) \#-}
-- @
data Newtype :: k -> Type

-- | Auto-derive classes using the @anyclass@ deriving strategy.
-- Enable the extension @DeriveAnyClass@ to use this.
--
-- Argument: a class (of kind @k -> Constraint@ for some @k@), or a tuple of classes.
--
-- === Examples
--
-- @
-- {-\# ANN module (Driving :: 'Driving' '[ 'Anyclass' Binary ]) \#-}
-- {-\# ANN module (Driving :: 'Driving' '[ 'Anyclass' '(ToJSON, FromJSON) ]) \#-}
-- -- Classes from the packages binary and aeson
-- @
data Anyclass :: k -> Type

-- | Auto-derive classes using the @via@ deriving strategy, for a given via-type.
-- Enable the extension @DerivingVia@ to use this.
--
-- Arguments:
--
-- 1. a class (of kind @k -> Constraint@ for some @k@), or a tuple of classes;
-- 2. a type.
--
-- === Examples
--
-- @
-- {-\# ANN module (Driving :: 'Driving' '[ Num `'Via'` Int ]) \#-}
-- {-\# ANN module (Driving :: 'Driving' '[ '(Eq, Ord) `'Via'` Int ]) \#-}
-- @
data Via :: k -> l -> Type

-- | Auto-derive classes using the @via@ deriving strategy, where the via-type
-- is an application of a given type constructor to each newly declared type.
-- Enable the extension @DerivingVia@ to use this.
--
-- Arguments:
--
-- 1. a class (of kind @k -> Constraint@ for some @k@), or a tuple of classes;
-- 2. a type constructor.
--
-- === Examples
--
-- @
-- {-\# ANN module (Driving :: 'Driving' '[ '(Functor, Applicative) `'ViaF'` WrappedMonad ]) \#-}
-- {-\# ANN module (Driving :: 'Driving' '[ '(Semigroup, Monoid) `'ViaF'` Generically ]) \#-}
-- -- Generically from the package generic-data
-- @
data ViaF :: k -> l -> Type

-- | Cancel auto-deriving for a particular instance.
--
-- Argument: an application of a class to a type, or a tuple of those.
--
-- === Example
--
-- Derive @Show@ for all types except @MyType@:
--
-- @
-- {-\# ANN module (Driving :: 'Driving' '[ 'Stock' Show, 'NoDriving' (Show MyType) ]) \#-}
-- @
data NoDriving :: k -> Type

-- * Plugin

-- | For the compiler.
plugin :: Plugin
plugin :: Plugin
plugin = Plugin
defaultPlugin
  { parsedResultAction :: [CommandLineOption]
-> ModSummary -> HsParsedModule -> Hsc HsParsedModule
parsedResultAction = [CommandLineOption]
-> ModSummary -> HsParsedModule -> Hsc HsParsedModule
parsed
  }

-- ** Implementation

#if __GLASGOW_HASKELL__ >= 904
parsed :: [CommandLineOption] -> ModSummary -> ParsedResult -> Hsc ParsedResult
parsed _opts _modsum m = pure (m { parsedResultModule = driving (parsedResultModule m) })
#else
parsed :: [CommandLineOption] -> ModSummary -> HsParsedModule -> Hsc HsParsedModule
parsed :: [CommandLineOption]
-> ModSummary -> HsParsedModule -> Hsc HsParsedModule
parsed [CommandLineOption]
_opts ModSummary
_modsum HsParsedModule
m = forall (f :: * -> *) a. Applicative f => a -> f a
pure (Endo HsParsedModule
driving HsParsedModule
m)
#endif

type Endo a = a -> a
type DrivingPass a = Config -> a -> a

driving :: Endo HsParsedModule
driving :: Endo HsParsedModule
driving HsParsedModule
m = HsParsedModule
m { hpm_module :: Located HsModule
hpm_module = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Endo HsModule
drivingMod (HsParsedModule -> Located HsModule
hpm_module HsParsedModule
m) }

#if __GLASGOW_HASKELL__ >= 900
drivingMod :: Endo HsModule
#else
drivingMod :: Endo (HsModule GhcPs)
#endif
drivingMod :: Endo HsModule
drivingMod m :: HsModule
m@HsModule{ hsmodDecls :: HsModule -> [LHsDecl GhcPs]
hsmodDecls = [LHsDecl GhcPs]
ds } = HsModule
m { hsmodDecls :: [LHsDecl GhcPs]
hsmodDecls = DrivingPass [LHsDecl GhcPs]
drivingDecls Config
emptyConfig [LHsDecl GhcPs]
ds }

-- *** AST Traversal

-- | Traverse the source top-down, any annotation using @Driving@ overrides the
-- configuration.
drivingDecls :: DrivingPass [LHsDecl GhcPs]
drivingDecls :: DrivingPass [LHsDecl GhcPs]
drivingDecls Config
_conf [] = []
drivingDecls Config
conf (LHsDecl GhcPs
d : [LHsDecl GhcPs]
ds)
    -- Erase plugin annotations. They can't go through the renamer because they break
    -- the staging restriction by refering to types in the current module.
    -- Also some annotations are ill-kinded. Very sloppy API...
  | Just Config
newConf <- LHsDecl GhcPs -> Maybe Config
getConf LHsDecl GhcPs
d = DrivingPass [LHsDecl GhcPs]
drivingDecls Config
newConf [LHsDecl GhcPs]
ds
  | Bool
otherwise = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (DrivingPass (HsDecl GhcPs)
drivingDecl Config
conf) LHsDecl GhcPs
d forall a. a -> [a] -> [a]
: DrivingPass [LHsDecl GhcPs]
drivingDecls Config
conf [LHsDecl GhcPs]
ds

drivingDecl :: DrivingPass (HsDecl GhcPs)
drivingDecl :: DrivingPass (HsDecl GhcPs)
drivingDecl Config
conf (TyClD XTyClD GhcPs
x d :: TyClDecl GhcPs
d@DataDecl{ tcdDataDefn :: forall pass. TyClDecl pass -> HsDataDefn pass
tcdDataDefn = HsDataDefn GhcPs
dd }) =
  forall p. XTyClD p -> TyClDecl p -> HsDecl p
TyClD XTyClD GhcPs
x (TyClDecl GhcPs
d { tcdDataDefn :: HsDataDefn GhcPs
tcdDataDefn = RdrName -> DrivingPass (HsDataDefn GhcPs)
drivingDataDefn (forall (p :: Pass).
(Anno (IdGhcP p) ~ SrcSpanAnnN) =>
TyClDecl (GhcPass p) -> IdP (GhcPass p)
tcdName TyClDecl GhcPs
d) Config
conf HsDataDefn GhcPs
dd })
drivingDecl Config
_conf HsDecl GhcPs
decl = HsDecl GhcPs
decl

drivingDataDefn :: RdrName -> DrivingPass (HsDataDefn GhcPs)
drivingDataDefn :: RdrName -> DrivingPass (HsDataDefn GhcPs)
drivingDataDefn RdrName
tyname Config
conf dd :: HsDataDefn GhcPs
dd@HsDataDefn{ dd_derivs :: forall pass. HsDataDefn pass -> HsDeriving pass
dd_derivs = HsDeriving GhcPs
derivs } =
  HsDataDefn GhcPs
dd { dd_derivs :: HsDeriving GhcPs
dd_derivs = GHC902(,fmap) (drivingDerivs tyname conf) derivs }

drivingDerivs :: RdrName -> DrivingPass [LHsDerivingClause GhcPs]
drivingDerivs :: RdrName -> DrivingPass (HsDeriving GhcPs)
drivingDerivs RdrName
tyname Config
conf HsDeriving GhcPs
derivs = RdrName -> Config -> HsDeriving GhcPs
extraDerivingClauses RdrName
tyname Config
conf forall a. [a] -> [a] -> [a]
++ HsDeriving GhcPs
derivs

extraDerivingClauses :: RdrName -> Config -> [LHsDerivingClause GhcPs]
extraDerivingClauses :: RdrName -> Config -> HsDeriving GhcPs
extraDerivingClauses RdrName
tyname Config
conf = [GenLocated SrcSpan (HsDerivingClause GhcPs)]
hsClauses
  where
    clauses :: DrivingClauses
clauses =
      let clauses0 :: DrivingClauses
clauses0 = Config -> DrivingClauses
drivingClauses Config
conf in
      case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup RdrName
tyname (Config -> Map RdrName (Set RdrName)
exceptions Config
conf) of
        Maybe (Set RdrName)
Nothing -> DrivingClauses
clauses0
        Just Set RdrName
excs -> DrivingClauses
          { drivingStock :: [LHsType GhcPs]
drivingStock    = forall a. (a -> Bool) -> [a] -> [a]
filter (Set RdrName -> LHsType GhcPs -> Bool
headNoMatch Set RdrName
excs) (DrivingClauses -> [LHsType GhcPs]
drivingStock DrivingClauses
clauses0)
          , drivingNewtype :: [LHsType GhcPs]
drivingNewtype  = forall a. (a -> Bool) -> [a] -> [a]
filter (Set RdrName -> LHsType GhcPs -> Bool
headNoMatch Set RdrName
excs) (DrivingClauses -> [LHsType GhcPs]
drivingNewtype DrivingClauses
clauses0)
          , drivingAnyclass :: [LHsType GhcPs]
drivingAnyclass = forall a. (a -> Bool) -> [a] -> [a]
filter (Set RdrName -> LHsType GhcPs -> Bool
headNoMatch Set RdrName
excs) (DrivingClauses -> [LHsType GhcPs]
drivingAnyclass DrivingClauses
clauses0)
          , drivingVia :: [([LHsType GhcPs], LHsType GhcPs)]
drivingVia      = (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first) (forall a. (a -> Bool) -> [a] -> [a]
filter (Set RdrName -> LHsType GhcPs -> Bool
headNoMatch Set RdrName
excs)) (DrivingClauses -> [([LHsType GhcPs], LHsType GhcPs)]
drivingVia DrivingClauses
clauses0)
          , drivingViaF :: [([LHsType GhcPs], LHsType GhcPs)]
drivingViaF     = (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first) (forall a. (a -> Bool) -> [a] -> [a]
filter (Set RdrName -> LHsType GhcPs -> Bool
headNoMatch Set RdrName
excs)) (DrivingClauses -> [([LHsType GhcPs], LHsType GhcPs)]
drivingViaF DrivingClauses
clauses0)
          }
    hsClauses :: [GenLocated SrcSpan (HsDerivingClause GhcPs)]
hsClauses =
         DerivStrategy GhcPs -> [LHsType GhcPs] -> HsDeriving GhcPs
mkDerivingClauses (forall pass. XStockStrategy pass -> DerivStrategy pass
StockStrategy GHC902(noAnn,)) (drivingStock clauses)
      forall a. [a] -> [a] -> [a]
++ DerivStrategy GhcPs -> [LHsType GhcPs] -> HsDeriving GhcPs
mkDerivingClauses (forall pass. XNewtypeStrategy pass -> DerivStrategy pass
NewtypeStrategy GHC902(noAnn,)) (drivingNewtype clauses)
      forall a. [a] -> [a] -> [a]
++ DerivStrategy GhcPs -> [LHsType GhcPs] -> HsDeriving GhcPs
mkDerivingClauses (forall pass. XAnyClassStrategy pass -> DerivStrategy pass
AnyclassStrategy GHC902(noAnn,)) (drivingAnyclass clauses)
      forall a. [a] -> [a] -> [a]
++ (([LHsType GhcPs], LHsType GhcPs) -> HsDeriving GhcPs
mkDerivingViaClauses forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< DrivingClauses -> [([LHsType GhcPs], LHsType GhcPs)]
drivingVia DrivingClauses
clauses)
      forall a. [a] -> [a] -> [a]
++ (([LHsType GhcPs], LHsType GhcPs) -> HsDeriving GhcPs
mkDerivingViaClauses forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) LHsType GhcPs -> GenLocated SrcSpanAnnA (HsType GhcPs)
applyToTyname (DrivingClauses -> [([LHsType GhcPs], LHsType GhcPs)]
drivingViaF DrivingClauses
clauses))
    applyToTyname :: LHsType GhcPs -> GenLocated SrcSpanAnnA (HsType GhcPs)
applyToTyname LHsType GhcPs
f = forall a an. a -> LocatedAn an a
noLocA (forall pass.
XAppTy pass -> LHsType pass -> LHsType pass -> HsType pass
HsAppTy NoExtField
NoExtField LHsType GhcPs
f (forall a an. a -> LocatedAn an a
noLocA (RdrName -> HsType GhcPs
hsTyVar RdrName
tyname)))

headNoMatch :: Set RdrName -> LHsType GhcPs -> Bool
headNoMatch :: Set RdrName -> LHsType GhcPs -> Bool
headNoMatch Set RdrName
excs (L SrcSpanAnnA
_ (HsParTy XParTy GhcPs
_ LHsType GhcPs
t)) = Set RdrName -> LHsType GhcPs -> Bool
headNoMatch Set RdrName
excs LHsType GhcPs
t
headNoMatch Set RdrName
excs (L SrcSpanAnnA
_ (HsAppTy XAppTy GhcPs
_ LHsType GhcPs
t LHsType GhcPs
_)) = Set RdrName -> LHsType GhcPs -> Bool
headNoMatch Set RdrName
excs LHsType GhcPs
t
headNoMatch Set RdrName
excs (L SrcSpanAnnA
_ (HsTyVar XTyVar GhcPs
_ PromotionFlag
_ (L SrcSpanAnnN
_ RdrName
v))) = forall a. Ord a => a -> Set a -> Bool
Set.notMember RdrName
v Set RdrName
excs
headNoMatch Set RdrName
_ LHsType GhcPs
_ = Bool
True

mkDerivingClauses :: DerivStrategy GhcPs -> [LHsType GhcPs] -> [LHsDerivingClause GhcPs]
mkDerivingClauses :: DerivStrategy GhcPs -> [LHsType GhcPs] -> HsDeriving GhcPs
mkDerivingClauses DerivStrategy GhcPs
_ [] = []
mkDerivingClauses DerivStrategy GhcPs
strat [LHsType GhcPs]
cls =
  [ forall e. e -> Located e
noLoc (HsDerivingClause
      { deriv_clause_ext :: XCHsDerivingClause GhcPs
deriv_clause_ext = forall a. EpAnn a
noAnn
      , deriv_clause_strategy :: Maybe (LDerivStrategy GhcPs)
deriv_clause_strategy = forall a. a -> Maybe a
Just (forall e. e -> Located e
noLoc DerivStrategy GhcPs
strat)
      , deriv_clause_tys :: LDerivClauseTys GhcPs
deriv_clause_tys = forall a an. a -> LocatedAn an a
noLocA (GHC902(mkDerivingClausesTys,) (map hsTypeToHsSigType cls))
      })
  ]

#if __GLASGOW_HASKELL__ >= 902
-- Input: one or more
mkDerivingClausesTys :: [LHsSigType GhcPs] -> DerivClauseTys GhcPs
mkDerivingClausesTys :: [LHsSigType GhcPs] -> DerivClauseTys GhcPs
mkDerivingClausesTys [LHsSigType GhcPs
c] = forall pass.
XDctSingle pass -> LHsSigType pass -> DerivClauseTys pass
DctSingle NoExtField
NoExtField LHsSigType GhcPs
c
mkDerivingClausesTys [LHsSigType GhcPs]
cls = forall pass.
XDctMulti pass -> [LHsSigType pass] -> DerivClauseTys pass
DctMulti NoExtField
NoExtField [LHsSigType GhcPs]
cls
#endif

mkDerivingViaClauses :: ([LHsType GhcPs], LHsType GhcPs) -> [LHsDerivingClause GhcPs]
mkDerivingViaClauses :: ([LHsType GhcPs], LHsType GhcPs) -> HsDeriving GhcPs
mkDerivingViaClauses ([LHsType GhcPs]
cls, LHsType GhcPs
v) =
#if __GLASGOW_HASKELL__ >= 902
  let s :: XViaStrategyPs
s = EpAnn [AddEpAnn] -> LHsSigType GhcPs -> XViaStrategyPs
XViaStrategyPs forall a. EpAnn a
noAnn (LHsType GhcPs -> LHsSigType GhcPs
hsTypeToHsSigType LHsType GhcPs
v) in
#else
  let s = mkHsImplicitBndrs v in
#endif
  DerivStrategy GhcPs -> [LHsType GhcPs] -> HsDeriving GhcPs
mkDerivingClauses (forall pass. XViaStrategy pass -> DerivStrategy pass
ViaStrategy XViaStrategyPs
s) [LHsType GhcPs]
cls

hsTyVar :: RdrName -> HsType GhcPs
hsTyVar :: RdrName -> HsType GhcPs
hsTyVar = forall pass.
XTyVar pass -> PromotionFlag -> LIdP pass -> HsType pass
HsTyVar forall a. EpAnn a
noAnn PromotionFlag
NotPromoted forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a an. a -> LocatedAn an a
noLocA

-- *** Configuration

data Config = Config
  { Config -> DrivingClauses
drivingClauses :: DrivingClauses
  , Config -> Map RdrName (Set RdrName)
exceptions :: Map RdrName (Set RdrName)
  }

data DrivingClauses = DrivingClauses
  { DrivingClauses -> [LHsType GhcPs]
drivingStock    :: [LHsType GhcPs]
  , DrivingClauses -> [LHsType GhcPs]
drivingNewtype  :: [LHsType GhcPs]
  , DrivingClauses -> [LHsType GhcPs]
drivingAnyclass :: [LHsType GhcPs]
  , DrivingClauses -> [([LHsType GhcPs], LHsType GhcPs)]
drivingVia      :: [([LHsType GhcPs], LHsType GhcPs)]
  , DrivingClauses -> [([LHsType GhcPs], LHsType GhcPs)]
drivingViaF     :: [([LHsType GhcPs], LHsType GhcPs)]
  }

addException :: RdrName -> RdrName -> Config -> Config
addException :: RdrName -> RdrName -> Config -> Config
addException RdrName
ty RdrName
cls Config
config = Config
config { exceptions :: Map RdrName (Set RdrName)
exceptions = forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter Maybe (Set RdrName) -> Maybe (Set RdrName)
add RdrName
ty (Config -> Map RdrName (Set RdrName)
exceptions Config
config) } where
  add :: Maybe (Set RdrName) -> Maybe (Set RdrName)
add Maybe (Set RdrName)
Nothing = forall a. a -> Maybe a
Just (forall a. a -> Set a
Set.singleton RdrName
cls)
  add (Just Set RdrName
clss) = forall a. a -> Maybe a
Just (forall a. Ord a => a -> Set a -> Set a
Set.insert RdrName
cls Set RdrName
clss)

updateDrivingClauses :: (DrivingClauses -> DrivingClauses) -> Config -> Config
updateDrivingClauses :: (DrivingClauses -> DrivingClauses) -> Config -> Config
updateDrivingClauses DrivingClauses -> DrivingClauses
f Config
conf = Config
conf { drivingClauses :: DrivingClauses
drivingClauses = DrivingClauses -> DrivingClauses
f (Config -> DrivingClauses
drivingClauses Config
conf) }

addStock, addNewtype, addAnyclass :: [LHsType GhcPs] -> DrivingClauses -> DrivingClauses
addStock :: [LHsType GhcPs] -> DrivingClauses -> DrivingClauses
addStock    [LHsType GhcPs]
names DrivingClauses
dc = DrivingClauses
dc { drivingStock :: [LHsType GhcPs]
drivingStock    = [LHsType GhcPs]
names forall a. [a] -> [a] -> [a]
++ DrivingClauses -> [LHsType GhcPs]
drivingStock DrivingClauses
dc }
addNewtype :: [LHsType GhcPs] -> DrivingClauses -> DrivingClauses
addNewtype  [LHsType GhcPs]
names DrivingClauses
dc = DrivingClauses
dc { drivingNewtype :: [LHsType GhcPs]
drivingNewtype  = [LHsType GhcPs]
names forall a. [a] -> [a] -> [a]
++ DrivingClauses -> [LHsType GhcPs]
drivingNewtype DrivingClauses
dc }
addAnyclass :: [LHsType GhcPs] -> DrivingClauses -> DrivingClauses
addAnyclass [LHsType GhcPs]
names DrivingClauses
dc = DrivingClauses
dc { drivingAnyclass :: [LHsType GhcPs]
drivingAnyclass = [LHsType GhcPs]
names forall a. [a] -> [a] -> [a]
++ DrivingClauses -> [LHsType GhcPs]
drivingAnyclass DrivingClauses
dc }

addVia :: [LHsType GhcPs] -> LHsType GhcPs -> DrivingClauses -> DrivingClauses
addVia :: [LHsType GhcPs]
-> LHsType GhcPs -> DrivingClauses -> DrivingClauses
addVia [LHsType GhcPs]
names LHsType GhcPs
v DrivingClauses
dc = DrivingClauses
dc { drivingVia :: [([LHsType GhcPs], LHsType GhcPs)]
drivingVia = ([LHsType GhcPs]
names, LHsType GhcPs
v) forall a. a -> [a] -> [a]
: DrivingClauses -> [([LHsType GhcPs], LHsType GhcPs)]
drivingVia DrivingClauses
dc }

addViaF :: [LHsType GhcPs] -> LHsType GhcPs -> DrivingClauses -> DrivingClauses
addViaF :: [LHsType GhcPs]
-> LHsType GhcPs -> DrivingClauses -> DrivingClauses
addViaF [LHsType GhcPs]
names LHsType GhcPs
v DrivingClauses
dc = DrivingClauses
dc { drivingViaF :: [([LHsType GhcPs], LHsType GhcPs)]
drivingViaF = ([LHsType GhcPs]
names, LHsType GhcPs
v) forall a. a -> [a] -> [a]
: DrivingClauses -> [([LHsType GhcPs], LHsType GhcPs)]
drivingViaF DrivingClauses
dc }

emptyDrivingClauses :: DrivingClauses
emptyDrivingClauses :: DrivingClauses
emptyDrivingClauses = DrivingClauses
  { drivingStock :: [LHsType GhcPs]
drivingStock = []
  , drivingNewtype :: [LHsType GhcPs]
drivingNewtype = []
  , drivingAnyclass :: [LHsType GhcPs]
drivingAnyclass = []
  , drivingVia :: [([LHsType GhcPs], LHsType GhcPs)]
drivingVia = []
  , drivingViaF :: [([LHsType GhcPs], LHsType GhcPs)]
drivingViaF = []
  }

emptyConfig :: Config
emptyConfig :: Config
emptyConfig = Config
  { drivingClauses :: DrivingClauses
drivingClauses = DrivingClauses
emptyDrivingClauses
  , exceptions :: Map RdrName (Set RdrName)
exceptions = forall k a. Map k a
Map.empty
  }

getConf :: LHsDecl GhcPs -> Maybe Config
getConf :: LHsDecl GhcPs -> Maybe Config
getConf (L SrcSpanAnnA
_ (AnnD XAnnD GhcPs
_ (HsAnnotation XHsAnnotation GhcPs
_ SourceText
_ AnnProvenance GhcPs
prov XRec GhcPs (HsExpr GhcPs)
ann_)))
    | AnnProvenance GhcPs
ModuleAnnProvenance <- AnnProvenance GhcPs
prov = XRec GhcPs (HsExpr GhcPs) -> Maybe Config
getConfExpr XRec GhcPs (HsExpr GhcPs)
ann_
getConf LHsDecl GhcPs
_ = forall a. Maybe a
Nothing

unParTy :: LHsType GhcPs -> HsType GhcPs
unParTy :: LHsType GhcPs -> HsType GhcPs
unParTy (L SrcSpanAnnA
_ (HsParTy XParTy GhcPs
_ LHsType GhcPs
t)) = LHsType GhcPs -> HsType GhcPs
unParTy LHsType GhcPs
t
unParTy (L SrcSpanAnnA
_ HsType GhcPs
t) = HsType GhcPs
t

getConfExpr :: LHsExpr GhcPs -> Maybe Config
getConfExpr :: XRec GhcPs (HsExpr GhcPs) -> Maybe Config
getConfExpr = HsExpr GhcPs -> Maybe Config
addModuleAnns_ forall b c a. (b -> c) -> (a -> b) -> a -> c
. XRec GhcPs (HsExpr GhcPs) -> HsExpr GhcPs
unPar where
  addModuleAnns_ :: HsExpr GhcPs -> Maybe Config
#if __GLASGOW_HASKELL__ >= 808
  addModuleAnns_ :: HsExpr GhcPs -> Maybe Config
addModuleAnns_ (ExprWithTySig XExprWithTySig GhcPs
_ XRec GhcPs (HsExpr GhcPs)
_ LHsSigWcType (NoGhcTc GhcPs)
t) =
#else
  addModuleAnns_ (ExprWithTySig t _) =
#endif
#if __GLASGOW_HASKELL__ >= 902
    let hsImplicitBody :: GenLocated l (HsSigType pass) -> XRec pass (HsType pass)
hsImplicitBody = forall pass. HsSigType pass -> LHsType pass
sig_body forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall l e. GenLocated l e -> e
unLoc in
#endif
    case LHsType GhcPs -> HsType GhcPs
unParTy (forall {l} {pass}.
GenLocated l (HsSigType pass) -> XRec pass (HsType pass)
hsImplicitBody (forall pass thing. HsWildCardBndrs pass thing -> thing
hswc_body LHsSigWcType (NoGhcTc GhcPs)
t)) of
      HsAppTy XAppTy GhcPs
_ (L SrcSpanAnnA
_ (HsTyVar XTyVar GhcPs
_ PromotionFlag
_ (L SrcSpanAnnN
_ RdrName
con))) LHsType GhcPs
t'
        | RdrName
con RdrName -> CommandLineOption -> Bool
`eqTyOcc` CommandLineOption
"Driving" -> forall a. a -> Maybe a
Just (LHsType GhcPs -> Config -> Config
mkConfig LHsType GhcPs
t' Config
emptyConfig)
      HsType GhcPs
_ -> forall a. Maybe a
Nothing
  addModuleAnns_ HsExpr GhcPs
_ = forall a. Maybe a
Nothing

unPar :: LHsExpr GhcPs -> HsExpr GhcPs
unPar :: XRec GhcPs (HsExpr GhcPs) -> HsExpr GhcPs
unPar (L SrcSpanAnnA
_ (HsPar XPar GhcPs
_ GHC904(_,) e GHC904(_,))) = unPar e
unPar (L SrcSpanAnnA
_ HsExpr GhcPs
e) = HsExpr GhcPs
e

mkConfig :: LHsType GhcPs -> Config -> Config
mkConfig :: LHsType GhcPs -> Config -> Config
mkConfig = HsType GhcPs -> Config -> Config
go forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsType GhcPs -> HsType GhcPs
unParTy where
  go :: HsType GhcPs -> Config -> Config
go (HsExplicitListTy XExplicitListTy GhcPs
_ PromotionFlag
_ [LHsType GhcPs]
ts) Config
conf = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (HsType GhcPs -> Config -> Config
go forall b c a. (b -> c) -> (a -> b) -> a -> c
. LHsType GhcPs -> HsType GhcPs
unParTy) Config
conf [LHsType GhcPs]
ts
  go (HsAppTy XAppTy GhcPs
_ (L SrcSpanAnnA
_ (HsTyVar XTyVar GhcPs
_ PromotionFlag
_ (L SrcSpanAnnN
_ RdrName
con))) LHsType GhcPs
t) Config
conf
    | RdrName
con RdrName -> CommandLineOption -> Bool
`eqTyOcc` CommandLineOption
"Stock"     = (DrivingClauses -> DrivingClauses) -> Config -> Config
updateDrivingClauses ([LHsType GhcPs] -> DrivingClauses -> DrivingClauses
addStock (LHsType GhcPs -> [LHsType GhcPs]
extractClasses LHsType GhcPs
t)) Config
conf
    | RdrName
con RdrName -> CommandLineOption -> Bool
`eqTyOcc` CommandLineOption
"Newtype"   = (DrivingClauses -> DrivingClauses) -> Config -> Config
updateDrivingClauses ([LHsType GhcPs] -> DrivingClauses -> DrivingClauses
addNewtype (LHsType GhcPs -> [LHsType GhcPs]
extractClasses LHsType GhcPs
t)) Config
conf
    | RdrName
con RdrName -> CommandLineOption -> Bool
`eqTyOcc` CommandLineOption
"Anyclass"  = (DrivingClauses -> DrivingClauses) -> Config -> Config
updateDrivingClauses ([LHsType GhcPs] -> DrivingClauses -> DrivingClauses
addAnyclass (LHsType GhcPs -> [LHsType GhcPs]
extractClasses LHsType GhcPs
t)) Config
conf
    | RdrName
con RdrName -> CommandLineOption -> Bool
`eqTyOcc` CommandLineOption
"NoDriving" = LHsType GhcPs -> Config -> Config
updExceptions LHsType GhcPs
t Config
conf
  go (HsAppTy XAppTy GhcPs
_ (L SrcSpanAnnA
_ (HsAppTy XAppTy GhcPs
_ (L SrcSpanAnnA
_ (HsTyVar XTyVar GhcPs
_ PromotionFlag
_ (L SrcSpanAnnN
_ RdrName
con))) LHsType GhcPs
t)) LHsType GhcPs
t') Config
conf
    | RdrName
con RdrName -> CommandLineOption -> Bool
`eqTyOcc` CommandLineOption
"Via" = (DrivingClauses -> DrivingClauses) -> Config -> Config
updateDrivingClauses ([LHsType GhcPs]
-> LHsType GhcPs -> DrivingClauses -> DrivingClauses
addVia (LHsType GhcPs -> [LHsType GhcPs]
extractClasses LHsType GhcPs
t) LHsType GhcPs
t') Config
conf
    | RdrName
con RdrName -> CommandLineOption -> Bool
`eqTyOcc` CommandLineOption
"ViaF" = (DrivingClauses -> DrivingClauses) -> Config -> Config
updateDrivingClauses ([LHsType GhcPs]
-> LHsType GhcPs -> DrivingClauses -> DrivingClauses
addViaF (LHsType GhcPs -> [LHsType GhcPs]
extractClasses LHsType GhcPs
t) LHsType GhcPs
t') Config
conf
  go (HsOpTy XOpTy GhcPs
_ GHC904(_,) t (L _ con) t') conf
    | RdrName
con RdrName -> CommandLineOption -> Bool
`eqTyOcc` CommandLineOption
"Via" = (DrivingClauses -> DrivingClauses) -> Config -> Config
updateDrivingClauses ([LHsType GhcPs]
-> LHsType GhcPs -> DrivingClauses -> DrivingClauses
addVia (LHsType GhcPs -> [LHsType GhcPs]
extractClasses LHsType GhcPs
t) LHsType GhcPs
t') Config
conf
    | RdrName
con RdrName -> CommandLineOption -> Bool
`eqTyOcc` CommandLineOption
"ViaF" = (DrivingClauses -> DrivingClauses) -> Config -> Config
updateDrivingClauses ([LHsType GhcPs]
-> LHsType GhcPs -> DrivingClauses -> DrivingClauses
addViaF (LHsType GhcPs -> [LHsType GhcPs]
extractClasses LHsType GhcPs
t) LHsType GhcPs
t') Config
conf
  go HsType GhcPs
_ Config
_ = forall a. HasCallStack => CommandLineOption -> a
error CommandLineOption
"Unrecognized syntax"

eqTyOcc :: RdrName -> String -> Bool
eqTyOcc :: RdrName -> CommandLineOption -> Bool
eqTyOcc RdrName
con CommandLineOption
cname = RdrName -> OccName
rdrNameOcc RdrName
con forall a. Eq a => a -> a -> Bool
== CommandLineOption -> OccName
mkTcOcc CommandLineOption
cname

updExceptions :: LHsType GhcPs -> Config -> Config
updExceptions :: LHsType GhcPs -> Config -> Config
updExceptions (L SrcSpanAnnA
_ (HsParTy XParTy GhcPs
_ LHsType GhcPs
t)) Config
conf = LHsType GhcPs -> Config -> Config
updExceptions LHsType GhcPs
t Config
conf
updExceptions (L SrcSpanAnnA
_ (HsExplicitTupleTy XExplicitTupleTy GhcPs
_ [LHsType GhcPs]
ts)) Config
conf = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr LHsType GhcPs -> Config -> Config
updExceptions Config
conf [LHsType GhcPs]
ts
updExceptions (L SrcSpanAnnA
_ (HsAppTy XAppTy GhcPs
_ (L SrcSpanAnnA
_ (HsTyVar XTyVar GhcPs
_ PromotionFlag
_ (L SrcSpanAnnN
_ RdrName
cname))) (L SrcSpanAnnA
_ (HsTyVar XTyVar GhcPs
_ PromotionFlag
_ (L SrcSpanAnnN
_ RdrName
tname))))) Config
conf =
  RdrName -> RdrName -> Config -> Config
addException RdrName
tname RdrName
cname Config
conf
updExceptions LHsType GhcPs
_ Config
_ = forall a. HasCallStack => CommandLineOption -> a
error CommandLineOption
"Unrecognized syntax"

extractClasses :: LHsType GhcPs -> [LHsType GhcPs]
extractClasses :: LHsType GhcPs -> [LHsType GhcPs]
extractClasses LHsType GhcPs
e = case forall l e. GenLocated l e -> e
unLoc LHsType GhcPs
e of
  HsParTy XParTy GhcPs
_ LHsType GhcPs
t -> LHsType GhcPs -> [LHsType GhcPs]
extractClasses LHsType GhcPs
t
  HsExplicitTupleTy XExplicitTupleTy GhcPs
_ [LHsType GhcPs]
ts -> [LHsType GhcPs]
ts forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LHsType GhcPs -> [LHsType GhcPs]
extractClasses
  HsType GhcPs
_ -> [LHsType GhcPs
e]

#if __GLASGOW_HASKELL__ < 902
noLocA :: e -> Located e
noLocA = noLoc

noAnn :: NoExtField
noAnn = NoExtField

hsTypeToHsSigType :: e -> HsImplicitBndrs GhcPs e
hsTypeToHsSigType = mkHsImplicitBndrs
#endif