{-# LANGUAGE NamedFieldPuns #-}
module Hint.NewType (newtypeHint) where
import Hint.Type (Idea, DeclHint, Note(DecreasesLaziness), ideaNote, ignoreNoSuggestion, suggestN)
import Data.List (isSuffixOf)
import GHC.Hs.Decls
import GHC.Hs
import Outputable
import SrcLoc
newtypeHint :: DeclHint
newtypeHint :: DeclHint
newtypeHint Scope
_ ModuleEx
_ LHsDecl GhcPs
x = LHsDecl GhcPs -> [Idea]
newtypeHintDecl LHsDecl GhcPs
x [Idea] -> [Idea] -> [Idea]
forall a. [a] -> [a] -> [a]
++ LHsDecl GhcPs -> [Idea]
newTypeDerivingStrategiesHintDecl LHsDecl GhcPs
x
newtypeHintDecl :: LHsDecl GhcPs -> [Idea]
newtypeHintDecl :: LHsDecl GhcPs -> [Idea]
newtypeHintDecl LHsDecl GhcPs
old
| Just WarnNewtype{LHsDecl GhcPs
newDecl :: WarnNewtype -> LHsDecl GhcPs
newDecl :: LHsDecl GhcPs
newDecl, HsType GhcPs
insideType :: WarnNewtype -> HsType GhcPs
insideType :: HsType GhcPs
insideType} <- LHsDecl GhcPs -> Maybe WarnNewtype
singleSimpleField LHsDecl GhcPs
old
= [(String -> LHsDecl GhcPs -> LHsDecl GhcPs -> Idea
forall a. (HasSrcSpan a, Outputable a) => String -> a -> a -> Idea
suggestN String
"Use newtype instead of data" LHsDecl GhcPs
old LHsDecl GhcPs
newDecl)
{ideaNote :: [Note]
ideaNote = [Note
DecreasesLaziness | HsType GhcPs -> Bool
warnBang HsType GhcPs
insideType]}]
newtypeHintDecl LHsDecl GhcPs
_ = []
newTypeDerivingStrategiesHintDecl :: LHsDecl GhcPs -> [Idea]
newTypeDerivingStrategiesHintDecl :: LHsDecl GhcPs -> [Idea]
newTypeDerivingStrategiesHintDecl decl :: LHsDecl GhcPs
decl@(L SrcSpan
_ (TyClD XTyClD GhcPs
_ (DataDecl XDataDecl GhcPs
_ Located (IdP GhcPs)
_ LHsQTyVars GhcPs
_ LexicalFixity
_ HsDataDefn GhcPs
dataDef))) =
[String -> LHsDecl GhcPs -> Idea
forall a. (HasSrcSpan a, Outputable a) => String -> a -> Idea
ignoreNoSuggestion String
"Use DerivingStrategies" LHsDecl GhcPs
decl | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ HsDataDefn GhcPs -> Bool
isData HsDataDefn GhcPs
dataDef, Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ HsDataDefn GhcPs -> Bool
hasAllStrategies HsDataDefn GhcPs
dataDef]
newTypeDerivingStrategiesHintDecl LHsDecl GhcPs
_ = []
hasAllStrategies :: HsDataDefn GhcPs -> Bool
hasAllStrategies :: HsDataDefn GhcPs -> Bool
hasAllStrategies (HsDataDefn XCHsDataDefn GhcPs
_ NewOrData
NewType LHsContext GhcPs
_ Maybe (Located CType)
_ Maybe (LHsKind GhcPs)
_ [LConDecl GhcPs]
_ (L SrcSpan
_ [LHsDerivingClause GhcPs]
xs)) = (LHsDerivingClause GhcPs -> Bool)
-> [LHsDerivingClause GhcPs] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all LHsDerivingClause GhcPs -> Bool
hasStrategyClause [LHsDerivingClause GhcPs]
xs
hasAllStrategies HsDataDefn GhcPs
_ = Bool
False
isData :: HsDataDefn GhcPs -> Bool
isData :: HsDataDefn GhcPs -> Bool
isData (HsDataDefn XCHsDataDefn GhcPs
_ NewOrData
NewType LHsContext GhcPs
_ Maybe (Located CType)
_ Maybe (LHsKind GhcPs)
_ [LConDecl GhcPs]
_ GenLocated SrcSpan [LHsDerivingClause GhcPs]
_) = Bool
False
isData (HsDataDefn XCHsDataDefn GhcPs
_ NewOrData
DataType LHsContext GhcPs
_ Maybe (Located CType)
_ Maybe (LHsKind GhcPs)
_ [LConDecl GhcPs]
_ GenLocated SrcSpan [LHsDerivingClause GhcPs]
_) = Bool
True
isData HsDataDefn GhcPs
_ = Bool
False
hasStrategyClause :: LHsDerivingClause GhcPs -> Bool
hasStrategyClause :: LHsDerivingClause GhcPs -> Bool
hasStrategyClause (L SrcSpan
_ (HsDerivingClause XCHsDerivingClause GhcPs
_ (Just LDerivStrategy GhcPs
_) Located [LHsSigType GhcPs]
_)) = Bool
True
hasStrategyClause LHsDerivingClause GhcPs
_ = Bool
False
data WarnNewtype = WarnNewtype
{ WarnNewtype -> LHsDecl GhcPs
newDecl :: LHsDecl GhcPs
, WarnNewtype -> HsType GhcPs
insideType :: HsType GhcPs
}
singleSimpleField :: LHsDecl GhcPs -> Maybe WarnNewtype
singleSimpleField :: LHsDecl GhcPs -> Maybe WarnNewtype
singleSimpleField (L SrcSpan
loc (TyClD XTyClD GhcPs
ext decl :: TyClDecl GhcPs
decl@(DataDecl XDataDecl GhcPs
_ Located (IdP GhcPs)
_ LHsQTyVars GhcPs
_ LexicalFixity
_ dataDef :: HsDataDefn GhcPs
dataDef@(HsDataDefn XCHsDataDefn GhcPs
_ NewOrData
DataType LHsContext GhcPs
_ Maybe (Located CType)
_ Maybe (LHsKind GhcPs)
_ [L SrcSpan
_ ConDecl GhcPs
constructor] GenLocated SrcSpan [LHsDerivingClause GhcPs]
_))))
| Just HsType GhcPs
inType <- ConDecl GhcPs -> Maybe (HsType GhcPs)
simpleCons ConDecl GhcPs
constructor =
WarnNewtype -> Maybe WarnNewtype
forall a. a -> Maybe a
Just WarnNewtype :: LHsDecl GhcPs -> HsType GhcPs -> WarnNewtype
WarnNewtype
{ newDecl :: LHsDecl GhcPs
newDecl = SrcSpan -> HsDecl GhcPs -> LHsDecl GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
loc (HsDecl GhcPs -> LHsDecl GhcPs) -> HsDecl GhcPs -> LHsDecl GhcPs
forall a b. (a -> b) -> a -> b
$ XTyClD GhcPs -> TyClDecl GhcPs -> HsDecl GhcPs
forall p. XTyClD p -> TyClDecl p -> HsDecl p
TyClD XTyClD GhcPs
ext TyClDecl GhcPs
decl {tcdDataDefn :: HsDataDefn GhcPs
tcdDataDefn = HsDataDefn GhcPs
dataDef
{ dd_ND :: NewOrData
dd_ND = NewOrData
NewType
, dd_cons :: [LConDecl GhcPs]
dd_cons = (LConDecl GhcPs -> LConDecl GhcPs)
-> [LConDecl GhcPs] -> [LConDecl GhcPs]
forall a b. (a -> b) -> [a] -> [b]
map (\(L SrcSpan
consloc ConDecl GhcPs
x) -> SrcSpan -> ConDecl GhcPs -> LConDecl GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
consloc (ConDecl GhcPs -> LConDecl GhcPs)
-> ConDecl GhcPs -> LConDecl GhcPs
forall a b. (a -> b) -> a -> b
$ ConDecl GhcPs -> ConDecl GhcPs
dropConsBang ConDecl GhcPs
x) ([LConDecl GhcPs] -> [LConDecl GhcPs])
-> [LConDecl GhcPs] -> [LConDecl GhcPs]
forall a b. (a -> b) -> a -> b
$ HsDataDefn GhcPs -> [LConDecl GhcPs]
forall pass. HsDataDefn pass -> [LConDecl pass]
dd_cons HsDataDefn GhcPs
dataDef
}}
, insideType :: HsType GhcPs
insideType = HsType GhcPs
inType
}
singleSimpleField LHsDecl GhcPs
_ = Maybe WarnNewtype
forall a. Maybe a
Nothing
simpleCons :: ConDecl GhcPs -> Maybe (HsType GhcPs)
simpleCons :: ConDecl GhcPs -> Maybe (HsType GhcPs)
simpleCons (ConDeclH98 XConDeclH98 GhcPs
_ Located (IdP GhcPs)
_ Located Bool
_ [] Maybe (LHsContext GhcPs)
context (PrefixCon [L SrcSpan
_ HsType GhcPs
inType]) Maybe LHsDocString
_)
| Maybe (LHsContext GhcPs) -> Bool
emptyOrNoContext Maybe (LHsContext GhcPs)
context
, Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ HsType GhcPs -> Bool
isUnboxedTuple HsType GhcPs
inType
, Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ HsType GhcPs -> Bool
isHashy HsType GhcPs
inType
= HsType GhcPs -> Maybe (HsType GhcPs)
forall a. a -> Maybe a
Just HsType GhcPs
inType
simpleCons (ConDeclH98 XConDeclH98 GhcPs
_ Located (IdP GhcPs)
_ Located Bool
_ [] Maybe (LHsContext GhcPs)
context (RecCon (L SrcSpan
_ [L SrcSpan
_ (ConDeclField XConDeclField GhcPs
_ [LFieldOcc GhcPs
_] (L SrcSpan
_ HsType GhcPs
inType) Maybe LHsDocString
_)])) Maybe LHsDocString
_)
| Maybe (LHsContext GhcPs) -> Bool
emptyOrNoContext Maybe (LHsContext GhcPs)
context
, Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ HsType GhcPs -> Bool
isUnboxedTuple HsType GhcPs
inType
, Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ HsType GhcPs -> Bool
isHashy HsType GhcPs
inType
= HsType GhcPs -> Maybe (HsType GhcPs)
forall a. a -> Maybe a
Just HsType GhcPs
inType
simpleCons ConDecl GhcPs
_ = Maybe (HsType GhcPs)
forall a. Maybe a
Nothing
isHashy :: HsType GhcPs -> Bool
isHashy :: HsType GhcPs -> Bool
isHashy (HsTyVar XTyVar GhcPs
_ PromotionFlag
_ Located (IdP GhcPs)
identifier) = String
"#" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isSuffixOf` SDoc -> String
showSDocUnsafe (Located RdrName -> SDoc
forall a. Outputable a => a -> SDoc
ppr Located (IdP GhcPs)
Located RdrName
identifier)
isHashy HsType GhcPs
_ = Bool
False
warnBang :: HsType GhcPs -> Bool
warnBang :: HsType GhcPs -> Bool
warnBang (HsBangTy XBangTy GhcPs
_ (HsSrcBang SourceText
_ SrcUnpackedness
_ SrcStrictness
SrcStrict) LHsKind GhcPs
_) = Bool
False
warnBang HsType GhcPs
_ = Bool
True
emptyOrNoContext :: Maybe (LHsContext GhcPs) -> Bool
emptyOrNoContext :: Maybe (LHsContext GhcPs) -> Bool
emptyOrNoContext Maybe (LHsContext GhcPs)
Nothing = Bool
True
emptyOrNoContext (Just (L SrcSpan
_ [])) = Bool
True
emptyOrNoContext Maybe (LHsContext GhcPs)
_ = Bool
False
dropConsBang :: ConDecl GhcPs -> ConDecl GhcPs
dropConsBang :: ConDecl GhcPs -> ConDecl GhcPs
dropConsBang decl :: ConDecl GhcPs
decl@(ConDeclH98 XConDeclH98 GhcPs
_ Located (IdP GhcPs)
_ Located Bool
_ [LHsTyVarBndr GhcPs]
_ Maybe (LHsContext GhcPs)
_ (PrefixCon [LHsKind GhcPs]
fields) Maybe LHsDocString
_) =
ConDecl GhcPs
decl {con_args :: HsConDetails (LHsKind GhcPs) (Located [LConDeclField GhcPs])
con_args = [LHsKind GhcPs]
-> HsConDetails (LHsKind GhcPs) (Located [LConDeclField GhcPs])
forall arg rec. [arg] -> HsConDetails arg rec
PrefixCon ([LHsKind GhcPs]
-> HsConDetails (LHsKind GhcPs) (Located [LConDeclField GhcPs]))
-> [LHsKind GhcPs]
-> HsConDetails (LHsKind GhcPs) (Located [LConDeclField GhcPs])
forall a b. (a -> b) -> a -> b
$ (LHsKind GhcPs -> LHsKind GhcPs)
-> [LHsKind GhcPs] -> [LHsKind GhcPs]
forall a b. (a -> b) -> [a] -> [b]
map LHsKind GhcPs -> LHsKind GhcPs
forall a. LHsType a -> LHsType a
getBangType [LHsKind GhcPs]
fields}
dropConsBang decl :: ConDecl GhcPs
decl@(ConDeclH98 XConDeclH98 GhcPs
_ Located (IdP GhcPs)
_ Located Bool
_ [LHsTyVarBndr GhcPs]
_ Maybe (LHsContext GhcPs)
_ (RecCon (L SrcSpan
recloc [LConDeclField GhcPs]
conDeclFields)) Maybe LHsDocString
_) =
ConDecl GhcPs
decl {con_args :: HsConDetails (LHsKind GhcPs) (Located [LConDeclField GhcPs])
con_args = Located [LConDeclField GhcPs]
-> HsConDetails (LHsKind GhcPs) (Located [LConDeclField GhcPs])
forall arg rec. rec -> HsConDetails arg rec
RecCon (Located [LConDeclField GhcPs]
-> HsConDetails (LHsKind GhcPs) (Located [LConDeclField GhcPs]))
-> Located [LConDeclField GhcPs]
-> HsConDetails (LHsKind GhcPs) (Located [LConDeclField GhcPs])
forall a b. (a -> b) -> a -> b
$ SrcSpan
-> SrcSpanLess (Located [LConDeclField GhcPs])
-> Located [LConDeclField GhcPs]
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
cL SrcSpan
recloc (SrcSpanLess (Located [LConDeclField GhcPs])
-> Located [LConDeclField GhcPs])
-> SrcSpanLess (Located [LConDeclField GhcPs])
-> Located [LConDeclField GhcPs]
forall a b. (a -> b) -> a -> b
$ [LConDeclField GhcPs] -> [LConDeclField GhcPs]
removeUnpacksRecords [LConDeclField GhcPs]
conDeclFields}
where
removeUnpacksRecords :: [LConDeclField GhcPs] -> [LConDeclField GhcPs]
removeUnpacksRecords :: [LConDeclField GhcPs] -> [LConDeclField GhcPs]
removeUnpacksRecords = (LConDeclField GhcPs -> LConDeclField GhcPs)
-> [LConDeclField GhcPs] -> [LConDeclField GhcPs]
forall a b. (a -> b) -> [a] -> [b]
map (\(L SrcSpan
conDeclFieldLoc ConDeclField GhcPs
x) -> SrcSpan -> ConDeclField GhcPs -> LConDeclField GhcPs
forall l e. l -> e -> GenLocated l e
L SrcSpan
conDeclFieldLoc (ConDeclField GhcPs -> LConDeclField GhcPs)
-> ConDeclField GhcPs -> LConDeclField GhcPs
forall a b. (a -> b) -> a -> b
$ ConDeclField GhcPs -> ConDeclField GhcPs
removeConDeclFieldUnpacks ConDeclField GhcPs
x)
removeConDeclFieldUnpacks :: ConDeclField GhcPs -> ConDeclField GhcPs
removeConDeclFieldUnpacks :: ConDeclField GhcPs -> ConDeclField GhcPs
removeConDeclFieldUnpacks conDeclField :: ConDeclField GhcPs
conDeclField@(ConDeclField XConDeclField GhcPs
_ [LFieldOcc GhcPs]
_ LHsKind GhcPs
fieldType Maybe LHsDocString
_) =
ConDeclField GhcPs
conDeclField {cd_fld_type :: LHsKind GhcPs
cd_fld_type = LHsKind GhcPs -> LHsKind GhcPs
forall a. LHsType a -> LHsType a
getBangType LHsKind GhcPs
fieldType}
removeConDeclFieldUnpacks ConDeclField GhcPs
x = ConDeclField GhcPs
x
dropConsBang ConDecl GhcPs
x = ConDecl GhcPs
x
isUnboxedTuple :: HsType GhcPs -> Bool
isUnboxedTuple :: HsType GhcPs -> Bool
isUnboxedTuple (HsTupleTy XTupleTy GhcPs
_ HsTupleSort
HsUnboxedTuple [LHsKind GhcPs]
_) = Bool
True
isUnboxedTuple HsType GhcPs
_ = Bool
False