NewType.hs

{-# 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 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#
data A = A (MutableByteArray# s)
{-# 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
data instance Foo Int = Bar Bool -- newtype instance Foo Int = Bar Bool
data instance Foo Int = Bar {field :: Bool} -- newtype instance Foo Int = Bar {field :: Bool}
data instance Foo Int = Bar {field :: Int#}
data instance Foo Int = Bar
data instance Foo Int = Bar {field1 :: Bool, field2 :: ()}
newtype instance Foo Int = Bar Bool deriving (Show, Eq) --
newtype instance Foo Int = Bar {field :: Bool} deriving Show --
newtype instance Foo Int = Bar {field :: Bool} deriving stock Show
{-# LANGUAGE RankNTypes #-}; data instance Foo Int = forall a. Show a => Foo a
</TEST>
-}
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 GHC.Types.SrcLoc
import Data.Generics.Uniplate.Data
import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable

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" (reLoc old) (reLoc newDecl))
            {ideaNote = [DecreasesLaziness | warnBang insideType]}]
newtypeHintDecl _ = []

newTypeDerivingStrategiesHintDecl :: LHsDecl GhcPs -> [Idea]
newTypeDerivingStrategiesHintDecl decl@(L _ (TyClD _ (DataDecl _ _ _ _ dataDef))) =
    [ignoreNoSuggestion "Use DerivingStrategies" (reLoc decl) | shouldSuggestStrategies dataDef]
newTypeDerivingStrategiesHintDecl decl@(L _ (InstD _ (DataFamInstD _ (DataFamInstDecl ((FamEqn _ _ _ _ _ dataDef)))))) =
    [ignoreNoSuggestion "Use DerivingStrategies" (reLoc decl) | shouldSuggestStrategies dataDef]
newTypeDerivingStrategiesHintDecl _ = []

-- | Determine if the given data definition should use deriving strategies.
shouldSuggestStrategies :: HsDataDefn GhcPs -> Bool
shouldSuggestStrategies dataDef = not (isData dataDef) && not (hasAllStrategies dataDef)

hasAllStrategies :: HsDataDefn GhcPs -> Bool
hasAllStrategies (HsDataDefn _ _ _ _ _  xs) = all hasStrategyClause xs

isData :: HsDataDefn GhcPs -> Bool
isData (HsDataDefn _ _ _ _ (NewTypeCon _) _) = False
isData (HsDataDefn _ _ _ _ (DataTypeCons _ _) _) = True

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

data WarnNewtype = WarnNewtype
    { newDecl :: LHsDecl 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 (L loc (TyClD ext decl@(DataDecl _ _ _ _ dataDef)))
    | Just inType <- simpleHsDataDefn dataDef =
        case dropBangs dataDef of
          DataTypeCons False [con] ->
            Just WarnNewtype
              { newDecl = L loc $ TyClD ext decl {tcdDataDefn = dataDef
                  { dd_cons = NewTypeCon con }}
              , insideType = inType
              }
          DataTypeCons True [_] -> Nothing -- Extension "TypeData": `type data T x = ...`
          _ -> Nothing
singleSimpleField (L loc (InstD ext (DataFamInstD instExt (DataFamInstDecl famEqn@(FamEqn _ _ _ _ _ dataDef)))))
    | Just inType <- simpleHsDataDefn dataDef =
        case dropBangs dataDef of
          DataTypeCons False [con] ->
            Just WarnNewtype
              { newDecl = L loc $ InstD ext $ DataFamInstD instExt $ DataFamInstDecl $ famEqn {feqn_rhs = dataDef
                      { dd_cons = NewTypeCon con }}
              , insideType = inType
              }
          DataTypeCons True [_] -> Nothing --  -- Extension "TypeData": `type data T x = ...`
          _ -> Nothing
singleSimpleField _ = Nothing

dropBangs :: HsDataDefn GhcPs -> DataDefnCons (LConDecl GhcPs)
dropBangs def =
  case dd_cons def of
    NewTypeCon a -> NewTypeCon (dropConsBang <$> a)
    DataTypeCons isTypeData as -> DataTypeCons isTypeData (map (dropConsBang <$>) as)

-- | Checks whether its argument is a \"simple\" data definition (see
-- 'singleSimpleField') returning the single thing under its
-- constructor if it is.
simpleHsDataDefn :: HsDataDefn GhcPs -> Maybe (HsType GhcPs)
simpleHsDataDefn (HsDataDefn _ _ _ _ (DataTypeCons _ [L _ constructor]) _) = simpleCons constructor
simpleHsDataDefn _ = Nothing

-- | Checks whether its argument is a \"simple\" constructor (see criteria in 'singleSimpleField')
-- returning the type inside the constructor if it is. This is needed for strictness analysis.
simpleCons :: ConDecl GhcPs -> Maybe (HsType GhcPs)
simpleCons (ConDeclH98 _ _ _ [] context (PrefixCon [] [HsScaled _ (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 x = or ["#" `isSuffixOf` unsafePrettyPrint v | v@HsTyVar{} <- universe x]

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

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

-- | The \"Bang\" here refers to 'HsSrcBang', which notably also includes @UNPACK@ pragmas!
dropConsBang :: ConDecl GhcPs -> ConDecl GhcPs
-- fields [HsScaled GhcPs (LBangType GhcPs)]
dropConsBang decl@(ConDeclH98 _ _ _ _ _ (PrefixCon [] fields) _) =
    -- decl {con_args = PrefixCon $ map getBangType fields}
    let fs' = map (\(HsScaled s lt) -> HsScaled s (getBangType lt)) fields  :: [HsScaled GhcPs (LBangType GhcPs)]
    in decl {con_args = PrefixCon [] fs'}
dropConsBang decl@(ConDeclH98 _ _ _ _ _ (RecCon (L recloc conDeclFields)) _) =
    decl {con_args = RecCon $ L 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}
dropConsBang x = x

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