{-# 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 _ _ x = newtypeHintDecl x ++ newTypeDerivingStrategiesHintDecl x
newtypeHintDecl :: LHsDecl GhcPs -> [Idea]
newtypeHintDecl old
| Just WarnNewtype{newDecl, insideType} <- singleSimpleField old
= [(suggestN' "Use newtype instead of data" old newDecl)
{ideaNote = [DecreasesLaziness | warnBang insideType]}]
newtypeHintDecl _ = []
newTypeDerivingStrategiesHintDecl :: LHsDecl GhcPs -> [Idea]
newTypeDerivingStrategiesHintDecl decl@(L _ (TyClD _ (DataDecl _ _ _ _ dataDef))) =
[ignoreNoSuggestion' "Use DerivingStrategies" decl | not $ isData dataDef, not $ hasAllStrategies dataDef]
newTypeDerivingStrategiesHintDecl _ = []
hasAllStrategies :: HsDataDefn GhcPs -> Bool
hasAllStrategies (HsDataDefn _ NewType _ _ _ _ (L _ xs)) = all hasStrategyClause xs
hasAllStrategies _ = False
isData :: HsDataDefn GhcPs -> Bool
isData (HsDataDefn _ NewType _ _ _ _ _) = False
isData (HsDataDefn _ DataType _ _ _ _ _) = True
isData _ = False
hasStrategyClause :: LHsDerivingClause GhcPs -> Bool
hasStrategyClause (L _ (HsDerivingClause _ (Just _) _)) = True
hasStrategyClause _ = False
data WarnNewtype = WarnNewtype
{ newDecl :: LHsDecl GhcPs
, insideType :: HsType GhcPs
}
singleSimpleField :: LHsDecl GhcPs -> Maybe WarnNewtype
singleSimpleField (L loc (TyClD ext decl@(DataDecl _ _ _ _ dataDef@(HsDataDefn _ DataType _ _ _ [L _ constructor] _))))
| Just inType <- simpleCons constructor =
Just WarnNewtype
{ newDecl = L loc $ TyClD ext decl {tcdDataDefn = dataDef
{ dd_ND = NewType
, dd_cons = map (\(L consloc x) -> L consloc $ dropConsBang x) $ dd_cons dataDef
}}
, insideType = inType
}
singleSimpleField _ = Nothing
simpleCons :: ConDecl GhcPs -> Maybe (HsType GhcPs)
simpleCons (ConDeclH98 _ _ _ [] context (PrefixCon [L _ inType]) _)
| emptyOrNoContext context
, not $ isUnboxedTuple inType
, not $ isHashy inType
= Just inType
simpleCons (ConDeclH98 _ _ _ [] context (RecCon (L _ [L _ (ConDeclField _ [_] (L _ inType) _)])) _)
| emptyOrNoContext context
, not $ isUnboxedTuple inType
, not $ isHashy inType
= Just inType
simpleCons _ = Nothing
isHashy :: HsType GhcPs -> Bool
isHashy (HsTyVar _ _ identifier) = "#" `isSuffixOf` showSDocUnsafe (ppr identifier)
isHashy _ = False
warnBang :: HsType GhcPs -> Bool
warnBang (HsBangTy _ (HsSrcBang _ _ SrcStrict) _) = False
warnBang _ = True
emptyOrNoContext :: Maybe (LHsContext GhcPs) -> Bool
emptyOrNoContext Nothing = True
emptyOrNoContext (Just (L _ [])) = True
emptyOrNoContext _ = False
dropConsBang :: ConDecl GhcPs -> ConDecl GhcPs
dropConsBang decl@(ConDeclH98 _ _ _ _ _ (PrefixCon fields) _) =
decl {con_args = PrefixCon $ map getBangType fields}
dropConsBang decl@(ConDeclH98 _ _ _ _ _ (RecCon (L recloc conDeclFields)) _) =
decl {con_args = RecCon $ cL recloc $ removeUnpacksRecords conDeclFields}
where
removeUnpacksRecords :: [LConDeclField GhcPs] -> [LConDeclField GhcPs]
removeUnpacksRecords = map (\(L conDeclFieldLoc x) -> L conDeclFieldLoc $ removeConDeclFieldUnpacks x)
removeConDeclFieldUnpacks :: ConDeclField GhcPs -> ConDeclField GhcPs
removeConDeclFieldUnpacks conDeclField@(ConDeclField _ _ fieldType _) =
conDeclField {cd_fld_type = getBangType fieldType}
removeConDeclFieldUnpacks x = x
dropConsBang x = x
isUnboxedTuple :: HsType GhcPs -> Bool
isUnboxedTuple (HsTupleTy _ HsUnboxedTuple _) = True
isUnboxedTuple _ = False