{-# LANGUAGE
  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.

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

import GHC.Plugins hiding (Type)
import GHC.Hs

-- * 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 Typeable (Driving a)
Typeable (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))
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c (Driving a))
-> (Driving a -> Constr)
-> (Driving a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c (Driving a)))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e))
    -> Maybe (c (Driving a)))
-> ((forall b. Data b => b -> b) -> Driving a -> Driving a)
-> (forall r r'.
    (r -> r' -> r)
    -> r -> (forall d. Data d => d -> r') -> Driving a -> r)
-> (forall r r'.
    (r' -> r -> r)
    -> r -> (forall d. Data d => d -> r') -> Driving a -> r)
-> (forall u. (forall d. Data d => d -> u) -> Driving a -> [u])
-> (forall u.
    Int -> (forall d. Data d => d -> u) -> Driving a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> Driving a -> m (Driving a))
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> Driving a -> m (Driving a))
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> Driving a -> m (Driving a))
-> Data (Driving a)
Driving a -> DataType
Driving a -> Constr
(forall b. Data b => b -> b) -> Driving a -> Driving a
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 u. Int -> (forall d. Data d => d -> u) -> Driving a -> u
forall u. (forall d. Data d => d -> u) -> Driving a -> [u]
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 r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Driving a -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Driving a -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Driving a -> m (Driving a)
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Driving a -> m (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)
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c (Driving a))
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e))
-> Maybe (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

parsed :: [CommandLineOption] -> ModSummary -> HsParsedModule -> Hsc HsParsedModule
parsed :: [CommandLineOption]
-> ModSummary -> HsParsedModule -> Hsc HsParsedModule
parsed [CommandLineOption]
_opts ModSummary
_modsum HsParsedModule
m = HsParsedModule -> Hsc HsParsedModule
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Endo HsParsedModule
driving HsParsedModule
m)

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 = (HsModule -> HsModule) -> Located HsModule -> Located HsModule
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HsModule -> HsModule
drivingMod (HsParsedModule -> Located HsModule
hpm_module HsParsedModule
m) }

drivingMod :: Endo HsModule
drivingMod :: HsModule -> 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 = (HsDecl GhcPs -> HsDecl GhcPs) -> LHsDecl GhcPs -> LHsDecl GhcPs
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (DrivingPass (HsDecl GhcPs)
drivingDecl Config
conf) LHsDecl GhcPs
d LHsDecl GhcPs -> [LHsDecl GhcPs] -> [LHsDecl GhcPs]
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 }) =
  XTyClD GhcPs -> TyClDecl GhcPs -> HsDecl GhcPs
forall p. XTyClD p -> TyClDecl p -> HsDecl p
TyClD XTyClD GhcPs
x (TyClDecl GhcPs
d { tcdDataDefn :: HsDataDefn GhcPs
tcdDataDefn = RdrName -> DrivingPass (HsDataDefn GhcPs)
drivingDataDefn (TyClDecl GhcPs -> IdP GhcPs
forall (p :: Pass). 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 = ([LHsDerivingClause GhcPs] -> [LHsDerivingClause GhcPs])
-> HsDeriving GhcPs -> HsDeriving GhcPs
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (RdrName -> DrivingPass [LHsDerivingClause GhcPs]
drivingDerivs RdrName
tyname Config
conf) HsDeriving GhcPs
derivs }

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

extraDerivingClauses :: RdrName -> Config -> [LHsDerivingClause GhcPs]
extraDerivingClauses :: RdrName -> Config -> [LHsDerivingClause GhcPs]
extraDerivingClauses RdrName
tyname Config
conf = [LHsDerivingClause GhcPs]
hsClauses
  where
    clauses :: DrivingClauses
clauses =
      let clauses0 :: DrivingClauses
clauses0 = Config -> DrivingClauses
drivingClauses Config
conf in
      case RdrName -> Map RdrName (Set RdrName) -> Maybe (Set RdrName)
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 :: [LHsType GhcPs]
-> [LHsType GhcPs]
-> [LHsType GhcPs]
-> [([LHsType GhcPs], LHsType GhcPs)]
-> [([LHsType GhcPs], LHsType GhcPs)]
-> DrivingClauses
DrivingClauses
          { drivingStock :: [LHsType GhcPs]
drivingStock    = (LHsType GhcPs -> Bool) -> [LHsType GhcPs] -> [LHsType GhcPs]
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  = (LHsType GhcPs -> Bool) -> [LHsType GhcPs] -> [LHsType GhcPs]
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 = (LHsType GhcPs -> Bool) -> [LHsType GhcPs] -> [LHsType GhcPs]
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      = ((([LHsType GhcPs], LHsType GhcPs)
 -> ([LHsType GhcPs], LHsType GhcPs))
-> [([LHsType GhcPs], LHsType GhcPs)]
-> [([LHsType GhcPs], LHsType GhcPs)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((([LHsType GhcPs], LHsType GhcPs)
  -> ([LHsType GhcPs], LHsType GhcPs))
 -> [([LHsType GhcPs], LHsType GhcPs)]
 -> [([LHsType GhcPs], LHsType GhcPs)])
-> (([LHsType GhcPs] -> [LHsType GhcPs])
    -> ([LHsType GhcPs], LHsType GhcPs)
    -> ([LHsType GhcPs], LHsType GhcPs))
-> ([LHsType GhcPs] -> [LHsType GhcPs])
-> [([LHsType GhcPs], LHsType GhcPs)]
-> [([LHsType GhcPs], LHsType GhcPs)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([LHsType GhcPs] -> [LHsType GhcPs])
-> ([LHsType GhcPs], LHsType GhcPs)
-> ([LHsType GhcPs], LHsType GhcPs)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first) ((LHsType GhcPs -> Bool) -> [LHsType GhcPs] -> [LHsType GhcPs]
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     = ((([LHsType GhcPs], LHsType GhcPs)
 -> ([LHsType GhcPs], LHsType GhcPs))
-> [([LHsType GhcPs], LHsType GhcPs)]
-> [([LHsType GhcPs], LHsType GhcPs)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((([LHsType GhcPs], LHsType GhcPs)
  -> ([LHsType GhcPs], LHsType GhcPs))
 -> [([LHsType GhcPs], LHsType GhcPs)]
 -> [([LHsType GhcPs], LHsType GhcPs)])
-> (([LHsType GhcPs] -> [LHsType GhcPs])
    -> ([LHsType GhcPs], LHsType GhcPs)
    -> ([LHsType GhcPs], LHsType GhcPs))
-> ([LHsType GhcPs] -> [LHsType GhcPs])
-> [([LHsType GhcPs], LHsType GhcPs)]
-> [([LHsType GhcPs], LHsType GhcPs)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([LHsType GhcPs] -> [LHsType GhcPs])
-> ([LHsType GhcPs], LHsType GhcPs)
-> ([LHsType GhcPs], LHsType GhcPs)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first) ((LHsType GhcPs -> Bool) -> [LHsType GhcPs] -> [LHsType GhcPs]
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 :: [LHsDerivingClause GhcPs]
hsClauses =
         DerivStrategy GhcPs -> [LHsType GhcPs] -> [LHsDerivingClause GhcPs]
mkDerivingClauses DerivStrategy GhcPs
forall pass. DerivStrategy pass
StockStrategy (DrivingClauses -> [LHsType GhcPs]
drivingStock DrivingClauses
clauses)
      [LHsDerivingClause GhcPs]
-> [LHsDerivingClause GhcPs] -> [LHsDerivingClause GhcPs]
forall a. [a] -> [a] -> [a]
++ DerivStrategy GhcPs -> [LHsType GhcPs] -> [LHsDerivingClause GhcPs]
mkDerivingClauses DerivStrategy GhcPs
forall pass. DerivStrategy pass
NewtypeStrategy (DrivingClauses -> [LHsType GhcPs]
drivingNewtype DrivingClauses
clauses)
      [LHsDerivingClause GhcPs]
-> [LHsDerivingClause GhcPs] -> [LHsDerivingClause GhcPs]
forall a. [a] -> [a] -> [a]
++ DerivStrategy GhcPs -> [LHsType GhcPs] -> [LHsDerivingClause GhcPs]
mkDerivingClauses DerivStrategy GhcPs
forall pass. DerivStrategy pass
AnyclassStrategy (DrivingClauses -> [LHsType GhcPs]
drivingAnyclass DrivingClauses
clauses)
      [LHsDerivingClause GhcPs]
-> [LHsDerivingClause GhcPs] -> [LHsDerivingClause GhcPs]
forall a. [a] -> [a] -> [a]
++ (([LHsType GhcPs], LHsType GhcPs) -> [LHsDerivingClause GhcPs]
mkDerivingViaClauses (([LHsType GhcPs], LHsType GhcPs) -> [LHsDerivingClause GhcPs])
-> [([LHsType GhcPs], LHsType GhcPs)] -> [LHsDerivingClause GhcPs]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< DrivingClauses -> [([LHsType GhcPs], LHsType GhcPs)]
drivingVia DrivingClauses
clauses)
      [LHsDerivingClause GhcPs]
-> [LHsDerivingClause GhcPs] -> [LHsDerivingClause GhcPs]
forall a. [a] -> [a] -> [a]
++ (([LHsType GhcPs], LHsType GhcPs) -> [LHsDerivingClause GhcPs]
mkDerivingViaClauses (([LHsType GhcPs], LHsType GhcPs) -> [LHsDerivingClause GhcPs])
-> [([LHsType GhcPs], LHsType GhcPs)] -> [LHsDerivingClause GhcPs]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ((([LHsType GhcPs], LHsType GhcPs)
 -> ([LHsType GhcPs], LHsType GhcPs))
-> [([LHsType GhcPs], LHsType GhcPs)]
-> [([LHsType GhcPs], LHsType GhcPs)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((([LHsType GhcPs], LHsType GhcPs)
  -> ([LHsType GhcPs], LHsType GhcPs))
 -> [([LHsType GhcPs], LHsType GhcPs)]
 -> [([LHsType GhcPs], LHsType GhcPs)])
-> ((LHsType GhcPs -> LHsType GhcPs)
    -> ([LHsType GhcPs], LHsType GhcPs)
    -> ([LHsType GhcPs], LHsType GhcPs))
-> (LHsType GhcPs -> LHsType GhcPs)
-> [([LHsType GhcPs], LHsType GhcPs)]
-> [([LHsType GhcPs], LHsType GhcPs)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LHsType GhcPs -> LHsType GhcPs)
-> ([LHsType GhcPs], LHsType GhcPs)
-> ([LHsType GhcPs], LHsType GhcPs)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) LHsType GhcPs -> LHsType GhcPs
applyToTyname (DrivingClauses -> [([LHsType GhcPs], LHsType GhcPs)]
drivingViaF DrivingClauses
clauses))
    applyToTyname :: LHsType GhcPs -> LHsType GhcPs
applyToTyname LHsType GhcPs
f = HsType GhcPs -> LHsType GhcPs
forall e. e -> Located e
noLoc (XAppTy GhcPs -> LHsType GhcPs -> LHsType GhcPs -> HsType GhcPs
forall pass.
XAppTy pass -> LHsType pass -> LHsType pass -> HsType pass
HsAppTy NoExtField
XAppTy GhcPs
NoExtField LHsType GhcPs
f (HsType GhcPs -> LHsType GhcPs
forall e. e -> Located e
noLoc (RdrName -> HsType GhcPs
hsTyVar RdrName
tyname)))

headNoMatch :: Set RdrName -> LHsType GhcPs -> Bool
headNoMatch :: Set RdrName -> LHsType GhcPs -> Bool
headNoMatch Set RdrName
excs (L SrcSpan
_ (HsParTy XParTy GhcPs
_ LHsType GhcPs
t)) = Set RdrName -> LHsType GhcPs -> Bool
headNoMatch Set RdrName
excs LHsType GhcPs
t
headNoMatch Set RdrName
excs (L SrcSpan
_ (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 SrcSpan
_ (HsTyVar XTyVar GhcPs
_ PromotionFlag
_ (L SrcSpan
_ IdP GhcPs
v))) = RdrName -> Set RdrName -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.notMember IdP GhcPs
RdrName
v Set RdrName
excs
headNoMatch Set RdrName
_ LHsType GhcPs
_ = Bool
True

mkDerivingClauses :: DerivStrategy GhcPs -> [LHsType GhcPs] -> [LHsDerivingClause GhcPs]
mkDerivingClauses :: DerivStrategy GhcPs -> [LHsType GhcPs] -> [LHsDerivingClause GhcPs]
mkDerivingClauses DerivStrategy GhcPs
_ [] = []
mkDerivingClauses DerivStrategy GhcPs
strat [LHsType GhcPs]
cls =
  [ HsDerivingClause GhcPs -> LHsDerivingClause GhcPs
forall e. e -> Located e
noLoc (HsDerivingClause :: forall pass.
XCHsDerivingClause pass
-> Maybe (LDerivStrategy pass)
-> Located [LHsSigType pass]
-> HsDerivingClause pass
HsDerivingClause
      { deriv_clause_ext :: XCHsDerivingClause GhcPs
deriv_clause_ext = NoExtField
XCHsDerivingClause GhcPs
NoExtField
      , deriv_clause_strategy :: Maybe (LDerivStrategy GhcPs)
deriv_clause_strategy = LDerivStrategy GhcPs -> Maybe (LDerivStrategy GhcPs)
forall a. a -> Maybe a
Just (DerivStrategy GhcPs -> LDerivStrategy GhcPs
forall e. e -> Located e
noLoc DerivStrategy GhcPs
strat)
      , deriv_clause_tys :: Located [LHsSigType GhcPs]
deriv_clause_tys = [LHsSigType GhcPs] -> Located [LHsSigType GhcPs]
forall e. e -> Located e
noLoc ((LHsType GhcPs -> LHsSigType GhcPs)
-> [LHsType GhcPs] -> [LHsSigType GhcPs]
forall a b. (a -> b) -> [a] -> [b]
map LHsType GhcPs -> LHsSigType GhcPs
forall thing. thing -> HsImplicitBndrs GhcPs thing
mkHsImplicitBndrs [LHsType GhcPs]
cls)
      })
  ]

mkDerivingViaClauses :: ([LHsType GhcPs], LHsType GhcPs) -> [LHsDerivingClause GhcPs]
mkDerivingViaClauses :: ([LHsType GhcPs], LHsType GhcPs) -> [LHsDerivingClause GhcPs]
mkDerivingViaClauses ([LHsType GhcPs]
cls, LHsType GhcPs
v) = DerivStrategy GhcPs -> [LHsType GhcPs] -> [LHsDerivingClause GhcPs]
mkDerivingClauses (XViaStrategy GhcPs -> DerivStrategy GhcPs
forall pass. XViaStrategy pass -> DerivStrategy pass
ViaStrategy (LHsType GhcPs -> LHsSigType GhcPs
forall thing. thing -> HsImplicitBndrs GhcPs thing
mkHsImplicitBndrs LHsType GhcPs
v)) [LHsType GhcPs]
cls

hsTyVar :: RdrName -> HsType GhcPs
hsTyVar :: RdrName -> HsType GhcPs
hsTyVar = XTyVar GhcPs
-> PromotionFlag -> GenLocated SrcSpan (IdP GhcPs) -> HsType GhcPs
forall pass.
XTyVar pass -> PromotionFlag -> Located (IdP pass) -> HsType pass
HsTyVar NoExtField
XTyVar GhcPs
NoExtField PromotionFlag
NotPromoted (GenLocated SrcSpan RdrName -> HsType GhcPs)
-> (RdrName -> GenLocated SrcSpan RdrName)
-> RdrName
-> HsType GhcPs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RdrName -> GenLocated SrcSpan RdrName
forall e. e -> Located e
noLoc

-- *** 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 = (Maybe (Set RdrName) -> Maybe (Set RdrName))
-> RdrName
-> Map RdrName (Set RdrName)
-> Map RdrName (Set RdrName)
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 = Set RdrName -> Maybe (Set RdrName)
forall a. a -> Maybe a
Just (RdrName -> Set RdrName
forall a. a -> Set a
Set.singleton RdrName
cls)
  add (Just Set RdrName
clss) = Set RdrName -> Maybe (Set RdrName)
forall a. a -> Maybe a
Just (RdrName -> Set RdrName -> Set RdrName
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 [LHsType GhcPs] -> [LHsType GhcPs] -> [LHsType GhcPs]
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 [LHsType GhcPs] -> [LHsType GhcPs] -> [LHsType GhcPs]
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 [LHsType GhcPs] -> [LHsType GhcPs] -> [LHsType GhcPs]
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) ([LHsType GhcPs], LHsType GhcPs)
-> [([LHsType GhcPs], LHsType GhcPs)]
-> [([LHsType GhcPs], LHsType GhcPs)]
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) ([LHsType GhcPs], LHsType GhcPs)
-> [([LHsType GhcPs], LHsType GhcPs)]
-> [([LHsType GhcPs], LHsType GhcPs)]
forall a. a -> [a] -> [a]
: DrivingClauses -> [([LHsType GhcPs], LHsType GhcPs)]
drivingViaF DrivingClauses
dc }

emptyDrivingClauses :: DrivingClauses
emptyDrivingClauses :: DrivingClauses
emptyDrivingClauses = DrivingClauses :: [LHsType GhcPs]
-> [LHsType GhcPs]
-> [LHsType GhcPs]
-> [([LHsType GhcPs], LHsType GhcPs)]
-> [([LHsType GhcPs], LHsType GhcPs)]
-> DrivingClauses
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 -> Map RdrName (Set RdrName) -> Config
Config
  { drivingClauses :: DrivingClauses
drivingClauses = DrivingClauses
emptyDrivingClauses
  , exceptions :: Map RdrName (Set RdrName)
exceptions = Map RdrName (Set RdrName)
forall k a. Map k a
Map.empty
  }

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

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

getConfExpr :: LHsExpr GhcPs -> Maybe Config
getConfExpr :: Located (HsExpr GhcPs) -> Maybe Config
getConfExpr Located (HsExpr GhcPs)
e = HsExpr GhcPs -> Maybe Config
forall {p}. (NoGhcTc p ~ GhcPs) => HsExpr p -> Maybe Config
addModuleAnns_ (Located (HsExpr GhcPs) -> HsExpr GhcPs
unPar Located (HsExpr GhcPs)
e) where
  addModuleAnns_ :: HsExpr p -> Maybe Config
addModuleAnns_ (ExprWithTySig XExprWithTySig p
_ LHsExpr p
_ LHsSigWcType (NoGhcTc p)
t) =
    case LHsType GhcPs -> HsType GhcPs
unParTy (LHsSigType GhcPs -> LHsType GhcPs
forall (p :: Pass) thing.
HsImplicitBndrs (GhcPass p) thing -> thing
hsImplicitBody (HsWildCardBndrs GhcPs (LHsSigType GhcPs) -> LHsSigType GhcPs
forall pass thing. HsWildCardBndrs pass thing -> thing
hswc_body HsWildCardBndrs GhcPs (LHsSigType GhcPs)
LHsSigWcType (NoGhcTc p)
t)) of
      HsAppTy XAppTy GhcPs
_ (L SrcSpan
_ (HsTyVar XTyVar GhcPs
_ PromotionFlag
_ (L SrcSpan
_ IdP GhcPs
con))) LHsType GhcPs
t'
        | IdP GhcPs
RdrName
con RdrName -> CommandLineOption -> Bool
`eqTyOcc` CommandLineOption
"Driving" -> Config -> Maybe Config
forall a. a -> Maybe a
Just (LHsType GhcPs -> Config -> Config
mkConfig LHsType GhcPs
t' Config
emptyConfig)
      HsType GhcPs
_ -> Maybe Config
forall a. Maybe a
Nothing
  addModuleAnns_ HsExpr p
_ = Maybe Config
forall a. Maybe a
Nothing

unPar :: LHsExpr GhcPs -> HsExpr GhcPs
unPar :: Located (HsExpr GhcPs) -> HsExpr GhcPs
unPar (L SrcSpan
_ (HsPar XPar GhcPs
_ Located (HsExpr GhcPs)
e)) = Located (HsExpr GhcPs) -> HsExpr GhcPs
unPar Located (HsExpr GhcPs)
e
unPar (L SrcSpan
_ HsExpr GhcPs
e) = HsExpr GhcPs
e

mkConfig :: LHsType GhcPs -> Config -> Config
mkConfig :: LHsType GhcPs -> Config -> Config
mkConfig = HsType GhcPs -> Config -> Config
go (HsType GhcPs -> Config -> Config)
-> (LHsType GhcPs -> HsType GhcPs)
-> LHsType GhcPs
-> Config
-> Config
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 = (LHsType GhcPs -> Config -> Config)
-> Config -> [LHsType GhcPs] -> Config
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (HsType GhcPs -> Config -> Config
go (HsType GhcPs -> Config -> Config)
-> (LHsType GhcPs -> HsType GhcPs)
-> LHsType GhcPs
-> Config
-> Config
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 SrcSpan
_ (HsTyVar XTyVar GhcPs
_ PromotionFlag
_ (L SrcSpan
_ IdP GhcPs
con))) LHsType GhcPs
t) Config
conf
    | IdP GhcPs
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
    | IdP GhcPs
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
    | IdP GhcPs
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
    | IdP GhcPs
RdrName
con RdrName -> CommandLineOption -> Bool
`eqTyOcc` CommandLineOption
"NoDriving" = LHsType GhcPs -> Config -> Config
updExceptions LHsType GhcPs
t Config
conf
  go (HsAppTy XAppTy GhcPs
_ (L SrcSpan
_ (HsAppTy XAppTy GhcPs
_ (L SrcSpan
_ (HsTyVar XTyVar GhcPs
_ PromotionFlag
_ (L SrcSpan
_ IdP GhcPs
con))) LHsType GhcPs
t)) LHsType GhcPs
t') Config
conf
    | IdP GhcPs
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
    | IdP GhcPs
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
_ LHsType GhcPs
t (L SrcSpan
_ IdP GhcPs
con) LHsType GhcPs
t') Config
conf
    | IdP GhcPs
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
    | IdP GhcPs
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
_ = CommandLineOption -> 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 OccName -> OccName -> Bool
forall a. Eq a => a -> a -> Bool
== CommandLineOption -> OccName
mkTcOcc CommandLineOption
cname

updExceptions :: LHsType GhcPs -> Config -> Config
updExceptions :: LHsType GhcPs -> Config -> Config
updExceptions (L SrcSpan
_ (HsParTy XParTy GhcPs
_ LHsType GhcPs
t)) Config
conf = LHsType GhcPs -> Config -> Config
updExceptions LHsType GhcPs
t Config
conf
updExceptions (L SrcSpan
_ (HsExplicitTupleTy XExplicitTupleTy GhcPs
_ [LHsType GhcPs]
ts)) Config
conf = (LHsType GhcPs -> Config -> Config)
-> Config -> [LHsType GhcPs] -> Config
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 SrcSpan
_ (HsAppTy XAppTy GhcPs
_ (L SrcSpan
_ (HsTyVar XTyVar GhcPs
_ PromotionFlag
_ (L SrcSpan
_ IdP GhcPs
cname))) (L SrcSpan
_ (HsTyVar XTyVar GhcPs
_ PromotionFlag
_ (L SrcSpan
_ IdP GhcPs
tname))))) Config
conf =
  RdrName -> RdrName -> Config -> Config
addException IdP GhcPs
RdrName
tname IdP GhcPs
RdrName
cname Config
conf
updExceptions LHsType GhcPs
_ Config
_ = CommandLineOption -> 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 LHsType GhcPs -> HsType GhcPs
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 [LHsType GhcPs]
-> (LHsType GhcPs -> [LHsType GhcPs]) -> [LHsType GhcPs]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= LHsType GhcPs -> [LHsType GhcPs]
extractClasses
  HsType GhcPs
_ -> [LHsType GhcPs
e]