{-# 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__ >= 902
#define PRE902(x)
#define POST902(x) x
#else
#define PRE902(x) x
#define POST902(x)
#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 Typeable (Driving a)
DataType
Constr
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 d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Driving a -> c (Driving a)
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c (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))
$cDriving :: Constr
$tDriving :: DataType
gmapMo :: (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 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 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 :: 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 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 :: (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 :: (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 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 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 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 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)
$cp1Data :: forall k (a :: k). (Typeable a, Typeable k) => Typeable (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 GhcPs)
hpm_module = (HsModule GhcPs -> HsModule GhcPs)
-> Located (HsModule GhcPs) -> Located (HsModule GhcPs)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap HsModule GhcPs -> HsModule GhcPs
drivingMod (HsParsedModule -> Located (HsModule GhcPs)
hpm_module HsParsedModule
m) }

#if __GLASGOW_HASKELL__ >= 900
drivingMod :: Endo HsModule
#else
drivingMod :: Endo (HsModule GhcPs)
#endif
drivingMod :: HsModule GhcPs -> HsModule GhcPs
drivingMod m :: HsModule GhcPs
m@HsModule{ hsmodDecls :: forall pass. HsModule pass -> [LHsDecl pass]
hsmodDecls = [LHsDecl GhcPs]
ds } = HsModule GhcPs
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 = PRE902(fmap) (drivingDerivs tyname conf) 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 POST902(noAnn)) (drivingStock 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 POST902(noAnn)) (drivingNewtype 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 POST902(noAnn)) (drivingAnyclass 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
noLocA (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
noLocA (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 =
  [ SrcSpanLess (LHsDerivingClause GhcPs) -> LHsDerivingClause GhcPs
forall a. HasSrcSpan a => SrcSpanLess a -> a
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
noAnn
      , deriv_clause_strategy :: Maybe (LDerivStrategy GhcPs)
deriv_clause_strategy = LDerivStrategy GhcPs -> Maybe (LDerivStrategy GhcPs)
forall a. a -> Maybe a
Just (SrcSpanLess (LDerivStrategy GhcPs) -> LDerivStrategy GhcPs
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc DerivStrategy GhcPs
SrcSpanLess (LDerivStrategy GhcPs)
strat)
      , deriv_clause_tys :: Located [LHsSigType GhcPs]
deriv_clause_tys = [LHsSigType GhcPs] -> Located [LHsSigType GhcPs]
forall e. e -> Located e
noLocA (POST902(mkDerivingClausesTys) (map hsTypeToHsSigType cls))
      })
  ]

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

mkDerivingViaClauses :: ([LHsType GhcPs], LHsType GhcPs) -> [LHsDerivingClause GhcPs]
mkDerivingViaClauses :: ([LHsType GhcPs], LHsType GhcPs) -> [LHsDerivingClause GhcPs]
mkDerivingViaClauses ([LHsType GhcPs]
cls, LHsType GhcPs
v) =
#if __GLASGOW_HASKELL__ >= 902
  let s = XViaStrategyPs noAnn (hsTypeToHsSigType v) in
#else
  let s :: LHsSigType GhcPs
s = LHsType GhcPs -> LHsSigType GhcPs
forall e. e -> HsImplicitBndrs GhcPs e
mkHsImplicitBndrs LHsType GhcPs
v in
#endif
  DerivStrategy GhcPs -> [LHsType GhcPs] -> [LHsDerivingClause GhcPs]
mkDerivingClauses (XViaStrategy GhcPs -> DerivStrategy GhcPs
forall pass. XViaStrategy pass -> DerivStrategy pass
ViaStrategy LHsSigType GhcPs
XViaStrategy GhcPs
s) [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
noAnn 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
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 = (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 = HsExpr GhcPs -> Maybe Config
addModuleAnns_ (HsExpr GhcPs -> Maybe Config)
-> (Located (HsExpr GhcPs) -> HsExpr GhcPs)
-> Located (HsExpr GhcPs)
-> Maybe Config
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Located (HsExpr GhcPs) -> HsExpr GhcPs
unPar where
  addModuleAnns_ :: HsExpr GhcPs -> Maybe Config
#if __GLASGOW_HASKELL__ >= 808
  addModuleAnns_ :: HsExpr GhcPs -> Maybe Config
addModuleAnns_ (ExprWithTySig XExprWithTySig GhcPs
_ Located (HsExpr GhcPs)
_ LHsSigWcType (NoGhcTc GhcPs)
t) =
#else
  addModuleAnns_ (ExprWithTySig t _) =
#endif
#if __GLASGOW_HASKELL__ >= 902
    let hsImplicitBody = sig_body . unLoc in
#endif
    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 GhcPs)
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 GhcPs
_ = 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 -> SrcSpanLess (LHsType GhcPs)
forall a. HasSrcSpan a => a -> SrcSpanLess a
unLoc LHsType GhcPs
e of
  HsParTy _ t -> LHsType GhcPs -> [LHsType GhcPs]
extractClasses LHsType GhcPs
t
  HsExplicitTupleTy _ 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
  SrcSpanLess (LHsType GhcPs)
_ -> [LHsType GhcPs
e]

#if __GLASGOW_HASKELL__ < 902
noLocA :: e -> Located e
noLocA :: e -> Located e
noLocA = e -> Located e
forall a. HasSrcSpan a => SrcSpanLess a -> a
noLoc

noAnn :: NoExtField
noAnn :: NoExtField
noAnn = NoExtField
NoExtField

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