{-# LANGUAGE NamedFieldPuns #-}
{-
    Suggest newtype instead of data for type declarations that have
    only one field. Don't suggest newtype for existentially
    quantified data types because it is not valid.

<TEST>
data Foo = Foo Int -- newtype Foo = Foo Int
data Foo = Foo Int deriving (Show, Eq) -- newtype Foo = Foo Int deriving (Show, Eq)
data Foo = Foo { field :: Int } deriving Show -- newtype Foo = Foo { field :: Int } deriving Show
data Foo a b = Foo a -- newtype Foo a b = Foo a
data Foo = Foo { field1, field2 :: Int}
data S a = forall b . Show b => S b
{-# LANGUAGE RankNTypes #-}; data Foo = Foo (forall a. a) -- newtype Foo = Foo (forall a. a)
data Color a = Red a | Green a | Blue a
data Pair a b = Pair a b
data Foo = Bar
data Foo a = Eq a => MkFoo a
data Foo a = () => Foo a -- newtype Foo a = Foo a
data X = Y {-# UNPACK #-} !Int -- newtype X = Y Int
data A = A {b :: !C} -- newtype A = A {b :: C}
data A = A Int#
{-# LANGUAGE UnboxedTuples #-}; data WithAnn x = WithAnn (# Ann, x #)
{-# LANGUAGE UnboxedTuples #-}; data WithAnn x = WithAnn {getWithAnn :: (# Ann, x #)}
data A = A () -- newtype A = A ()
newtype Foo = Foo Int deriving (Show, Eq) --
newtype Foo = Foo { getFoo :: Int } deriving (Show, Eq) --
newtype Foo = Foo Int deriving stock Show
</TEST>
-}
module Hint.NewType (newtypeHint) where

import Hint.Type (Idea, DeclHint', Note(DecreasesLaziness), ideaNote, ignoreNoSuggestion', suggestN')

import Data.List (isSuffixOf)
import HsDecls
import HsSyn
import Outputable
import SrcLoc

newtypeHint :: DeclHint'
newtypeHint :: DeclHint'
newtypeHint _ _ x :: 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 old :: 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' "Use newtype instead of data" LHsDecl GhcPs
old LHsDecl GhcPs
newDecl)
            {ideaNote :: [Note]
ideaNote = [Note
DecreasesLaziness | HsType GhcPs -> Bool
warnBang HsType GhcPs
insideType]}]
newtypeHintDecl _ = []

newTypeDerivingStrategiesHintDecl :: LHsDecl GhcPs -> [Idea]
newTypeDerivingStrategiesHintDecl :: LHsDecl GhcPs -> [Idea]
newTypeDerivingStrategiesHintDecl decl :: LHsDecl GhcPs
decl@(LL _ (TyClD _ (DataDecl _ _ _ _ dataDef))) =
    [String -> LHsDecl GhcPs -> Idea
forall a. (HasSrcSpan a, Outputable a) => String -> a -> Idea
ignoreNoSuggestion' "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 _ = []

hasAllStrategies :: HsDataDefn GhcPs -> Bool
hasAllStrategies :: HsDataDefn GhcPs -> Bool
hasAllStrategies (HsDataDefn _ NewType _ _ _ _ (LL _ xs :: SrcSpanLess (HsDeriving 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]
SrcSpanLess (HsDeriving GhcPs)
xs
hasAllStrategies _ = Bool
False

isData :: HsDataDefn GhcPs -> Bool
isData :: HsDataDefn GhcPs -> Bool
isData (HsDataDefn _ NewType _ _ _ _ _) = Bool
False
isData (HsDataDefn _ DataType _ _ _ _ _) = Bool
True
isData _ = Bool
False

hasStrategyClause :: LHsDerivingClause GhcPs -> Bool
hasStrategyClause :: LHsDerivingClause GhcPs -> Bool
hasStrategyClause (LL _ (HsDerivingClause _ (Just _) _)) = Bool
True
hasStrategyClause _ = Bool
False

data WarnNewtype = WarnNewtype
    { WarnNewtype -> LHsDecl GhcPs
newDecl :: LHsDecl GhcPs
    , WarnNewtype -> HsType GhcPs
insideType :: HsType GhcPs
    }

-- | Given a declaration, returns the suggested \"newtype\"ized declaration following these guidelines:
-- * Types ending in a \"#\" are __ignored__, because they are usually unboxed primitives - @data X = X Int#@
-- * @ExistentialQuantification@ stuff is __ignored__ - @data X = forall t. X t@
-- * Constructors with (nonempty) constraints are __ignored__ - @data X a = (Eq a) => X a@
-- * Single field constructors get newtyped - @data X = X Int@ -> @newtype X = X Int@
-- * Single record field constructors get newtyped - @data X = X {getX :: Int}@ -> @newtype X = X {getX :: Int}@
-- * All other declarations are ignored.
singleSimpleField :: LHsDecl GhcPs -> Maybe WarnNewtype
singleSimpleField :: LHsDecl GhcPs -> Maybe WarnNewtype
singleSimpleField (LL loc :: SrcSpan
loc (TyClD ext decl@(DataDecl _ _ _ _ dataDef@(HsDataDefn _ DataType _ _ _ [LL _ constructor] _))))
    | Just inType :: HsType GhcPs
inType <- ConDecl GhcPs -> Maybe (HsType GhcPs)
simpleCons SrcSpanLess (LConDecl GhcPs)
ConDecl GhcPs
constructor =
        WarnNewtype -> Maybe WarnNewtype
forall a. a -> Maybe a
Just WarnNewtype :: LHsDecl GhcPs -> HsType GhcPs -> WarnNewtype
WarnNewtype
              { newDecl :: LHsDecl GhcPs
newDecl = SrcSpan -> SrcSpanLess (LHsDecl GhcPs) -> LHsDecl GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
LL SrcSpan
loc (SrcSpanLess (LHsDecl GhcPs) -> LHsDecl GhcPs)
-> SrcSpanLess (LHsDecl 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 (\(LL consloc :: SrcSpan
consloc x :: SrcSpanLess (LConDecl GhcPs)
x) -> SrcSpan -> SrcSpanLess (LConDecl GhcPs) -> LConDecl GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
LL SrcSpan
consloc (SrcSpanLess (LConDecl GhcPs) -> LConDecl GhcPs)
-> SrcSpanLess (LConDecl GhcPs) -> LConDecl GhcPs
forall a b. (a -> b) -> a -> b
$ ConDecl GhcPs -> ConDecl GhcPs
dropConsBang SrcSpanLess (LConDecl GhcPs)
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 _ = Maybe WarnNewtype
forall a. Maybe a
Nothing

-- | Checks whether its argument is a \"simple constructor\" (see criteria in 'singleSimpleFieldNew')
-- returning the type inside the constructor if it is. This is needed for strictness analysis.
simpleCons :: ConDecl GhcPs -> Maybe (HsType GhcPs)
simpleCons :: ConDecl GhcPs -> Maybe (HsType GhcPs)
simpleCons (ConDeclH98 _ _ _ [] context :: Maybe (LHsContext GhcPs)
context (PrefixCon [LL _ inType :: SrcSpanLess (LBangType GhcPs)
inType]) _)
    | 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 SrcSpanLess (LBangType GhcPs)
HsType GhcPs
inType
    , Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ HsType GhcPs -> Bool
isHashy SrcSpanLess (LBangType GhcPs)
HsType GhcPs
inType
    = HsType GhcPs -> Maybe (HsType GhcPs)
forall a. a -> Maybe a
Just SrcSpanLess (LBangType GhcPs)
HsType GhcPs
inType
simpleCons (ConDeclH98 _ _ _ [] context :: Maybe (LHsContext GhcPs)
context (RecCon (LL _ [LL _ (ConDeclField _ [_] (LL _ inType) _)])) _)
    | 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 SrcSpanLess (LBangType GhcPs)
HsType GhcPs
inType
    , Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ HsType GhcPs -> Bool
isHashy SrcSpanLess (LBangType GhcPs)
HsType GhcPs
inType
    = HsType GhcPs -> Maybe (HsType GhcPs)
forall a. a -> Maybe a
Just SrcSpanLess (LBangType GhcPs)
HsType GhcPs
inType
simpleCons _ = Maybe (HsType GhcPs)
forall a. Maybe a
Nothing

isHashy :: HsType GhcPs -> Bool
isHashy :: HsType GhcPs -> Bool
isHashy (HsTyVar _ _ identifier :: Located (IdP GhcPs)
identifier) = "#" 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 RdrName
Located (IdP GhcPs)
identifier)
isHashy _ = Bool
False

warnBang :: HsType GhcPs -> Bool
warnBang :: HsType GhcPs -> Bool
warnBang (HsBangTy _ (HsSrcBang _ _ SrcStrict) _) = Bool
False
warnBang _ = Bool
True

emptyOrNoContext :: Maybe (LHsContext GhcPs) -> Bool
emptyOrNoContext :: Maybe (LHsContext GhcPs) -> Bool
emptyOrNoContext Nothing = Bool
True
emptyOrNoContext (Just (LL _ [])) = Bool
True
emptyOrNoContext _ = Bool
False

-- | The \"Bang\" here refers to 'HsSrcBang', which notably also includes @UNPACK@ pragmas!
dropConsBang :: ConDecl GhcPs -> ConDecl GhcPs
dropConsBang :: ConDecl GhcPs -> ConDecl GhcPs
dropConsBang decl :: ConDecl GhcPs
decl@(ConDeclH98 _ _ _ _ _ (PrefixCon fields :: [LBangType GhcPs]
fields) _) =
    ConDecl GhcPs
decl {con_args :: HsConDetails (LBangType GhcPs) (Located [LConDeclField GhcPs])
con_args = [LBangType GhcPs]
-> HsConDetails (LBangType GhcPs) (Located [LConDeclField GhcPs])
forall arg rec. [arg] -> HsConDetails arg rec
PrefixCon ([LBangType GhcPs]
 -> HsConDetails (LBangType GhcPs) (Located [LConDeclField GhcPs]))
-> [LBangType GhcPs]
-> HsConDetails (LBangType GhcPs) (Located [LConDeclField GhcPs])
forall a b. (a -> b) -> a -> b
$ (LBangType GhcPs -> LBangType GhcPs)
-> [LBangType GhcPs] -> [LBangType GhcPs]
forall a b. (a -> b) -> [a] -> [b]
map LBangType GhcPs -> LBangType GhcPs
forall a. LHsType a -> LHsType a
getBangType [LBangType GhcPs]
fields}
dropConsBang decl :: ConDecl GhcPs
decl@(ConDeclH98 _ _ _ _ _ (RecCon (LL recloc :: SrcSpan
recloc conDeclFields :: SrcSpanLess (Located [LConDeclField GhcPs])
conDeclFields)) _) =
    ConDecl GhcPs
decl {con_args :: HsConDetails (LBangType GhcPs) (Located [LConDeclField GhcPs])
con_args = Located [LConDeclField GhcPs]
-> HsConDetails (LBangType GhcPs) (Located [LConDeclField GhcPs])
forall arg rec. rec -> HsConDetails arg rec
RecCon (Located [LConDeclField GhcPs]
 -> HsConDetails (LBangType GhcPs) (Located [LConDeclField GhcPs]))
-> Located [LConDeclField GhcPs]
-> HsConDetails (LBangType 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]
SrcSpanLess (Located [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 (\(LL conDeclFieldLoc :: SrcSpan
conDeclFieldLoc x :: SrcSpanLess (LConDeclField GhcPs)
x) -> SrcSpan -> SrcSpanLess (LConDeclField GhcPs) -> LConDeclField GhcPs
forall a. HasSrcSpan a => SrcSpan -> SrcSpanLess a -> a
LL SrcSpan
conDeclFieldLoc (SrcSpanLess (LConDeclField GhcPs) -> LConDeclField GhcPs)
-> SrcSpanLess (LConDeclField GhcPs) -> LConDeclField GhcPs
forall a b. (a -> b) -> a -> b
$ ConDeclField GhcPs -> ConDeclField GhcPs
removeConDeclFieldUnpacks SrcSpanLess (LConDeclField GhcPs)
ConDeclField GhcPs
x)

        removeConDeclFieldUnpacks :: ConDeclField GhcPs -> ConDeclField GhcPs
        removeConDeclFieldUnpacks :: ConDeclField GhcPs -> ConDeclField GhcPs
removeConDeclFieldUnpacks conDeclField :: ConDeclField GhcPs
conDeclField@(ConDeclField _ _ fieldType :: LBangType GhcPs
fieldType _) =
            ConDeclField GhcPs
conDeclField {cd_fld_type :: LBangType GhcPs
cd_fld_type = LBangType GhcPs -> LBangType GhcPs
forall a. LHsType a -> LHsType a
getBangType LBangType GhcPs
fieldType}
        removeConDeclFieldUnpacks x :: ConDeclField GhcPs
x = ConDeclField GhcPs
x
dropConsBang x :: ConDecl GhcPs
x = ConDecl GhcPs
x

isUnboxedTuple :: HsType GhcPs -> Bool
isUnboxedTuple :: HsType GhcPs -> Bool
isUnboxedTuple (HsTupleTy _ HsUnboxedTuple _) = Bool
True
isUnboxedTuple _ = Bool
False