Pattern.hs

{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE ViewPatterns, PatternGuards, TypeFamilies #-}

{-
    Improve the structure of code

<TEST>
yes x y = if a then b else if c then d else e -- yes x y ; | a = b ; | c = d ; | otherwise = e
x `yes` y = if a then b else if c then d else e -- x `yes` y ; | a = b ; | c = d ; | otherwise = e
no x y = if a then b else c
-- foo b | c <- f b = c -- foo (f -> c) = c
-- foo x y b z | c:cs <- f g b = c -- foo x y (f g -> c:cs) z = c
foo b | c <- f b = c + b
foo b | c <- f b = c where f = here
foo b | c <- f b = c where foo = b
foo b | c <- f b = c \
      | c <- f b = c
foo x = yes x x where yes x y = if a then b else if c then d else e -- yes x y ; | a = b ; | c = d ; | otherwise = e
foo x | otherwise = y -- foo x = y
foo x = x + x where --
foo x | a = b | True = d -- foo x | a = b ; | otherwise = d
foo (Bar _ _ _ _) = x -- Bar{}
foo (Bar _ x _ _) = x
foo (Bar _ _) = x
foo = case f v of _ -> x -- x
foo = case v of v -> x -- x
foo = case v of z -> z
foo = case v of _ | False -> x
foo x | x < -2 * 3 = 4
foo = case v of !True -> x -- True
{-# LANGUAGE BangPatterns #-}; foo = case v of !True -> x -- True
{-# LANGUAGE BangPatterns #-}; foo = case v of !(Just x) -> x -- (Just x)
{-# LANGUAGE BangPatterns #-}; foo = case v of !(x : xs) -> x -- (x:xs)
{-# LANGUAGE BangPatterns #-}; foo = case v of !1 -> x -- 1
{-# LANGUAGE BangPatterns #-}; foo = case v of !x -> x
{-# LANGUAGE BangPatterns #-}; foo = case v of !(I# x) -> y -- (I# x)
foo = let ~x = 1 in y -- x
foo = let ~(x:xs) = y in z
{-# LANGUAGE BangPatterns #-}; foo = let !x = undefined in y
{-# LANGUAGE BangPatterns #-}; foo = let !(I# x) = 4 in x
{-# LANGUAGE BangPatterns #-}; foo = let !(Just x) = Nothing in 3
{-# LANGUAGE BangPatterns #-}; foo = 1 where f !False = 2 -- False
{-# LANGUAGE BangPatterns #-}; foo = 1 where !False = True
{-# LANGUAGE BangPatterns #-}; foo = 1 where g (Just !True) = Nothing -- True
{-# LANGUAGE BangPatterns #-}; foo = 1 where Just !True = Nothing
foo otherwise = 1 -- _
foo ~x = y -- x
{-# LANGUAGE Strict #-} foo ~x = y
{-# LANGUAGE BangPatterns #-}; foo !(x, y) = x -- (x, y)
{-# LANGUAGE BangPatterns #-}; foo ![x] = x -- [x]
foo !Bar { bar = x } = x -- Bar { bar = x }
{-# LANGUAGE BangPatterns #-}; l !(() :: ()) = x -- (() :: ())
foo x@_ = x -- x
foo x@Foo = x
otherwise = True
</TEST>
-}


module Hint.Pattern(patternHint) where

import Hint.Type(DeclHint,Idea,modComments,firstDeclComments,ideaTo,toSSA,toRefactSrcSpan,suggest,suggestRemove,warn)
import Data.Generics.Uniplate.DataOnly
import Data.Function
import Data.List.Extra
import Data.Tuple
import Data.Maybe
import Data.Either
import Refact.Types hiding (RType(Pattern, Match), SrcSpan)
import Refact.Types qualified as R (RType(Pattern, Match), SrcSpan)

import GHC.Hs hiding(asPattern)
import GHC.Types.SrcLoc
import GHC.Types.Name.Reader
import GHC.Types.Name.Occurrence
import GHC.Types.Basic hiding (Pattern)
import GHC.Data.Strict qualified

import GHC.Util
import Language.Haskell.GhclibParserEx.GHC.Hs.Pat
import Language.Haskell.GhclibParserEx.GHC.Hs.Expr
import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable
import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader

patternHint :: DeclHint
patternHint _scope modu x =
    concatMap (uncurry hints . swap) (asPattern x) ++
    -- PatBind (used in 'let' and 'where') contains lazy-by-default
    -- patterns, everything else is strict.
    concatMap (patHint strict False) [p | PatBind _ p _ _ <- universeBi x :: [HsBind GhcPs]] ++
    concatMap (patHint strict True) (universeBi $ transformBi noPatBind x) ++
    concatMap expHint (universeBi x)
  where
    -- Comments appearing without an empty line before the first
    -- declaration in a module are now associated with the declaration
    -- not the module so to be safe, look also at `firstDeclComments
    -- modu`
    -- (https://gitlab.haskell.org/ghc/ghc/-/merge_requests/9517).
    exts = nubOrd $ concatMap snd (languagePragmas (pragmas (modComments modu) ++ pragmas (firstDeclComments modu))) -- language extensions enabled at source
    strict = "Strict" `elem` exts

    noPatBind :: LHsBind GhcPs -> LHsBind GhcPs
    noPatBind (L loc a@PatBind{}) = L loc a{pat_lhs=noLocA (WildPat noExtField)}
    noPatBind x = x

{-
-- Do not suggest view patterns, they aren't something everyone likes sufficiently
hints gen (Pattern pats (GuardedRhss _ [GuardedRhs _ [Generator _ pat (App _ op (view -> Var_ p))] bod]) bind)
    | Just i <- findIndex (=~= (toNamed p :: Pat_)) pats
    , p `notElem` (vars bod ++ vars bind)
    , vars op `disjoint` decsBind, pvars pats `disjoint` vars op, pvars pat `disjoint` pvars pats
    = [gen "Use view patterns" $
       Pattern (take i pats ++ [PParen an $ PViewPat an op pat] ++ drop (i+1) pats) (UnGuardedRhs an bod) bind]
    where
        decsBind = nub $ concatMap declBind $ childrenBi bind
-}

hints :: (String -> Pattern -> [Refactoring R.SrcSpan] -> Idea) -> Pattern -> [Idea]
hints gen (Pattern l rtype pat (GRHSs _ [L _ (GRHS _ [] bod)] bind))
  | length guards > 2 = [gen "Use guards" (Pattern l rtype pat (GRHSs emptyComments guards bind)) [refactoring]]
  where
    rawGuards :: [(LHsExpr GhcPs, LHsExpr GhcPs)]
    rawGuards = asGuards bod

    mkGuard :: LHsExpr GhcPs -> (LHsExpr GhcPs -> GRHS GhcPs (LHsExpr GhcPs))
    mkGuard a = GRHS noAnn [noLocA $ BodyStmt noExtField a noSyntaxExpr noSyntaxExpr]

    guards :: [LGRHS GhcPs (LHsExpr GhcPs)]
    guards = map (noLocA . uncurry mkGuard) rawGuards

    (lhs, rhs) = unzip rawGuards

    mkTemplate c ps =
      -- Check if the expression has been injected or is natural.
      zipWith checkLoc ps ['1' .. '9']
      where
        checkLoc p@(L l _) v = if locA l == noSrcSpan then Left p else Right (c ++ [v], toSSA p)

    patSubts =
      case pat of
        [p] -> [Left p] -- Substitution doesn't work properly for PatBinds.
                        -- This will probably produce unexpected results if the pattern contains any template variables.
        ps  -> mkTemplate "p100" ps
    guardSubts = mkTemplate "g100" lhs
    exprSubts  = mkTemplate "e100" rhs
    templateGuards = map noLocA (zipWith (mkGuard `on` toString) guardSubts exprSubts)

    toString (Left e) = e
    toString (Right (v, _)) = strToVar v
    toString' (Left e) = e
    toString' (Right (v, _)) = strToPat v

    template = fromMaybe "" $ ideaTo (gen "" (Pattern l rtype (map toString' patSubts) (GRHSs emptyComments templateGuards bind)) [])

    f :: [Either a (String, R.SrcSpan)] -> [(String, R.SrcSpan)]
    f = rights
    refactoring = Replace rtype (toRefactSrcSpan l) (f patSubts ++ f guardSubts ++ f exprSubts) template
hints gen (Pattern l t pats o@(GRHSs _ [L _ (GRHS _ [test] bod)] bind))
  | unsafePrettyPrint test `elem` ["otherwise", "True"]
  = [gen "Redundant guard" (Pattern l t pats o{grhssGRHSs=[noLocA (GRHS noAnn [] bod)]}) [Delete Stmt (toSSA test)]]
hints _ (Pattern l t pats bod@(GRHSs _ _ binds)) | f binds
  = [suggestRemove "Redundant where" whereSpan "where" [ {- TODO refactoring for redundant where -} ]]
  where
    f :: HsLocalBinds GhcPs -> Bool
    f (HsValBinds _ (ValBinds _ l _)) = null l
    f (HsIPBinds _ (IPBinds _ l)) = null l
    f _ = False
    whereSpan = case l of
      UnhelpfulSpan s -> UnhelpfulSpan s
      RealSrcSpan s _ ->
        let end = realSrcSpanEnd s
            start = mkRealSrcLoc (srcSpanFile s) (srcLocLine end) (srcLocCol end - 5)
         in RealSrcSpan (mkRealSrcSpan start end) GHC.Data.Strict.Nothing
hints gen (Pattern l t pats o@(GRHSs _ (unsnoc -> Just (gs, L _ (GRHS _ [test] bod))) binds))
  | unsafePrettyPrint test == "True"
  = let otherwise_ = noLocA $ BodyStmt noExtField (strToVar "otherwise") noSyntaxExpr noSyntaxExpr in
      [gen "Use otherwise" (Pattern l t pats o{grhssGRHSs = gs ++ [noLocA (GRHS noAnn [otherwise_] bod)]}) [Replace Expr (toSSA test) [] "otherwise"]]
hints _ _ = []

asGuards :: LHsExpr GhcPs -> [(LHsExpr GhcPs, LHsExpr GhcPs)]
asGuards (L _ (HsPar _ x)) = asGuards x
asGuards (L _ (HsIf _ a b c)) = (a, b) : asGuards c
asGuards x = [(strToVar "otherwise", x)]

data Pattern = Pattern SrcSpan R.RType [LPat GhcPs] (GRHSs GhcPs (LHsExpr GhcPs))

-- Invariant: Number of patterns may not change
asPattern :: LHsDecl GhcPs  -> [(Pattern, String -> Pattern -> [Refactoring R.SrcSpan] -> Idea)]
asPattern (L loc x) = concatMap decl (universeBi x)
  where
    decl :: HsBind GhcPs -> [(Pattern, String -> Pattern -> [Refactoring R.SrcSpan] -> Idea)]
    decl o@(PatBind _ pat mult rhs) = [(Pattern (locA loc) Bind [pat] rhs, \msg (Pattern _ _ [pat] rhs) rs -> suggest msg (noLoc o :: Located (HsBind GhcPs)) (noLoc (PatBind noExtField pat mult rhs) :: Located (HsBind GhcPs)) rs)]
    decl (FunBind _ _ (MG _ (L _ xs))) = map match xs
    decl _ = []

    match :: LMatch GhcPs (LHsExpr GhcPs) -> (Pattern, String -> Pattern -> [Refactoring R.SrcSpan] -> Idea)
    match o@(L loc (Match _ ctx (L lpats pats) grhss)) = (Pattern (locA loc) R.Match pats grhss, \msg (Pattern _ _ pats grhss) rs -> suggest msg (reLoc o) (noLoc (Match noExtField ctx  (L lpats pats) grhss) :: Located (Match GhcPs (LHsExpr GhcPs))) rs)

-- First Bool is if 'Strict' is a language extension. Second Bool is
-- if this pattern in this context is going to be evaluated strictly.
patHint :: Bool -> Bool -> LPat GhcPs -> [Idea]
patHint _ _ o@(L _ (ConPat _ name (PrefixCon _ args)))
  | length args >= 3 && all isPWildcard args =
  let rec_fields = HsRecFields noExtField [] Nothing :: HsRecFields GhcPs (LPat GhcPs)
      new        = noLocA $ ConPat noAnn name (RecCon rec_fields) :: LPat GhcPs
  in
  [suggest "Use record patterns" (reLoc o) (reLoc new) [Replace R.Pattern (toSSA o) [] (unsafePrettyPrint new)]]
patHint _ _ o@(L _ (VarPat _ (L _ name)))
  | occNameString (rdrNameOcc name) == "otherwise" =
    [warn "Used otherwise as a pattern" (reLoc o) (noLoc (WildPat noExtField) :: Located (Pat GhcPs)) []]
patHint lang strict o@(L _ (BangPat _ pat@(L _ x)))
  | strict, f x = [warn "Redundant bang pattern" (reLoc o) (noLoc x :: Located (Pat GhcPs)) [r]]
  where
    f :: Pat GhcPs -> Bool
    f (ParPat _ (L _ x)) = f x
    f (AsPat _ _ (L _ x)) = f x
    f LitPat {} = True
    f NPat {} = True
    f ConPat {} = True
    f TuplePat {} = True
    f ListPat {} = True
    f (SigPat _ (L _ p) _) = f p
    f _ = False
    r = Replace R.Pattern (toSSA o) [("x", toSSA pat)] "x"
patHint False _ o@(L _ (LazyPat _ pat@(L _ x)))
  | f x = [warn "Redundant irrefutable pattern" (reLoc o) (noLoc x :: Located (Pat GhcPs)) [r]]
  where
    f :: Pat GhcPs -> Bool
    f (ParPat _ (L _ x)) = f x
    f (AsPat _ _ (L _ x)) = f x
    f WildPat{} = True
    f VarPat{} = True
    f _ = False
    r = Replace R.Pattern (toSSA o) [("x", toSSA pat)] "x"
patHint _ _ o@(L _ (AsPat _ v (L _ (WildPat _)))) =
  [warn "Redundant as-pattern" (reLoc o) (reLoc v) [Replace R.Pattern (toSSA o) [] (rdrNameStr v)]]
patHint _ _ _ = []

expHint :: LHsExpr GhcPs -> [Idea]
 -- Note the 'FromSource' in these equations (don't warn on generated match groups).
expHint o@(L _ (HsCase _ _ (MG FromSource (L _ [L _ (Match _ CaseAlt (L _ [L _ (WildPat _)]) (GRHSs _ [L _ (GRHS _ [] e)] (EmptyLocalBinds _))) ])))) =
  [suggest "Redundant case" (reLoc o) (reLoc e) [r]]
  where
    r = Replace Expr (toSSA o) [("x", toSSA e)] "x"
expHint o@(L _ (HsCase _ (L _ (HsVar _ (L _ x))) (MG FromSource (L _ [L _ (Match _ CaseAlt (L _ [L _ (VarPat _ (L _ y))]) (GRHSs _ [L _ (GRHS _ [] e)] (EmptyLocalBinds _))) ]))))
  | occNameStr x == occNameStr y =
      [suggest "Redundant case" (reLoc o) (reLoc e) [r]]
  where
    r = Replace Expr (toSSA o) [("x", toSSA e)] "x"
expHint _ = []