{-# LANGUAGE
CPP,
DeriveDataTypeable,
GADTs,
KindSignatures,
PolyKinds,
ScopedTypeVariables #-}
#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
(
Driving(..)
, Stock
, Newtype
, Anyclass
, Via
, ViaF
, NoDriving
, 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
data Driving :: k -> Type where
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
data Stock :: k -> Type
data Newtype :: k -> Type
data Anyclass :: k -> Type
data Via :: k -> l -> Type
data ViaF :: k -> l -> Type
data NoDriving :: k -> Type
plugin :: Plugin
plugin :: Plugin
plugin = Plugin
defaultPlugin
{ parsedResultAction :: [CommandLineOption]
-> ModSummary -> HsParsedModule -> Hsc HsParsedModule
parsedResultAction = [CommandLineOption]
-> ModSummary -> HsParsedModule -> Hsc HsParsedModule
parsed
}
#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 }
drivingDecls :: DrivingPass [LHsDecl GhcPs]
drivingDecls :: DrivingPass [LHsDecl GhcPs]
drivingDecls Config
_conf [] = []
drivingDecls Config
conf (LHsDecl GhcPs
d : [LHsDecl GhcPs]
ds)
| 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]
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
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
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]
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