1{-# LANGUAGE ViewPatterns, PatternGuards, FlexibleContexts #-} 2{- 3 Find and match: 4 5<TEST> 6yes = 1:2:[] -- [1,2] 7yes = ['h','e','l','l','o'] 8yes (1:2:[]) = 1 -- [1,2] 9yes ['h','e'] = 1 10 11-- [a]++b -> a : b, but only if not in a chain of ++'s 12yes = [x] ++ xs -- x : xs 13no = "x" ++ xs 14no = [x] ++ xs ++ ys 15no = xs ++ [x] ++ ys 16yes = [if a then b else c] ++ xs -- (if a then b else c) : xs 17yes = [1] : [2] : [3] : [4] : [5] : [] -- [[1], [2], [3], [4], [5]] 18yes = if x == e then l2 ++ xs else [x] ++ check_elem xs -- x : check_elem xs 19data Yes = Yes (Maybe [Char]) -- Maybe String 20yes = y :: [Char] -> a -- String -> a 21instance C [Char] 22foo = [a b] ++ xs -- a b : xs 23foo = [myexpr | True, a] -- [myexpr | a] 24foo = [myexpr | False] -- [] 25foo = map f [x + 1 | x <- [1..10]] -- [f (x + 1) | x <- [1..10]] 26foo = [x + 1 | x <- [1..10], feature] -- [x + 1 | feature, x <- [1..10]] 27foo = [x + 1 | x <- [1..10], even x] 28foo = [x + 1 | x <- [1..10], even x, dont_reoder_guards] 29foo = [x + 1 | x <- [1..10], let y = even x, y] 30foo = [x + 1 | x <- [1..10], let q = even 1, q] -- [x + 1 | let q = even 1, q, x <- [1..10]] 31foo = [fooValue | Foo{..} <- y, fooField] 32issue619 = [pkgJobs | Pkg{pkgGpd, pkgJobs} <- pkgs, not $ null $ C.condTestSuites pkgGpd] 33{-# LANGUAGE MonadComprehensions #-}\ 34foo = [x | False, x <- [1 .. 10]] -- [] 35foo = [_ | x <- _, let _ = A{x}] 36issue1039 = foo (map f [1 | _ <- []]) -- [f 1 | _ <- []] 37{-# LANGUAGE OverloadedLists #-} \ 38issue114 = True:[] 39</TEST> 40-} 41 42module Hint.List(listHint) where 43 44import Control.Applicative 45import Data.Generics.Uniplate.DataOnly 46import Data.List.Extra 47import Data.Maybe 48import Prelude 49 50import Hint.Type(DeclHint,Idea,suggest,ignore,substVars,toRefactSrcSpan,toSS,ghcAnnotations) 51 52import Refact.Types hiding (SrcSpan) 53import qualified Refact.Types as R 54 55import GHC.Hs 56import GHC.Types.SrcLoc 57import GHC.Types.Basic 58import GHC.Types.Name.Reader 59import GHC.Data.FastString 60import GHC.Builtin.Types 61 62import GHC.Util 63import Language.Haskell.GhclibParserEx.GHC.Hs.Pat 64import Language.Haskell.GhclibParserEx.GHC.Hs.Expr 65import Language.Haskell.GhclibParserEx.GHC.Hs.Types 66import Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances 67import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable 68import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader 69 70 71listHint :: DeclHint 72listHint _ modu = listDecl overloadedListsOn 73 where 74 exts = concatMap snd (languagePragmas (pragmas (ghcAnnotations modu))) 75 overloadedListsOn = "OverloadedLists" `elem` exts 76 77listDecl :: Bool -> LHsDecl GhcPs -> [Idea] 78listDecl overloadedListsOn x = 79 concatMap (listExp overloadedListsOn False) (childrenBi x) ++ 80 stringType x ++ 81 concatMap listPat (childrenBi x) ++ 82 concatMap listComp (universeBi x) 83 84-- Refer to https://github.com/ndmitchell/hlint/issues/775 for the 85-- structure of 'listComp'. 86 87listComp :: LHsExpr GhcPs -> [Idea] 88listComp o@(L _ (HsDo _ ListComp (L _ stmts))) = 89 listCompCheckGuards o ListComp stmts 90listComp o@(L _ (HsDo _ MonadComp (L _ stmts))) = 91 listCompCheckGuards o MonadComp stmts 92 93listComp (L _ HsPar{}) = [] -- App2 "sees through" paren, which causes duplicate hints with universeBi 94listComp o@(view -> App2 mp f (L _ (HsDo _ ListComp (L _ stmts)))) = 95 listCompCheckMap o mp f ListComp stmts 96listComp o@(view -> App2 mp f (L _ (HsDo _ MonadComp (L _ stmts)))) = 97 listCompCheckMap o mp f MonadComp stmts 98listComp _ = [] 99 100listCompCheckGuards :: LHsExpr GhcPs -> HsStmtContext GhcRn -> [ExprLStmt GhcPs] -> [Idea] 101listCompCheckGuards o ctx stmts = 102 let revs = reverse stmts 103 e@(L _ LastStmt{}) = head revs -- In a ListComp, this is always last. 104 xs = reverse (tail revs) in 105 list_comp_aux e xs 106 where 107 list_comp_aux e xs 108 | "False" `elem` cons = [suggest "Short-circuited list comprehension" o o' (suggestExpr o o')] 109 | "True" `elem` cons = [suggest "Redundant True guards" o o2 (suggestExpr o o2)] 110 | not (astListEq xs ys) = [suggest "Move guards forward" o o3 (suggestExpr o o3)] 111 | otherwise = [] 112 where 113 ys = moveGuardsForward xs 114 o' = noLoc $ ExplicitList noExtField Nothing [] 115 o2 = noLoc $ HsDo noExtField ctx (noLoc (filter ((/= Just "True") . qualCon) xs ++ [e])) 116 o3 = noLoc $ HsDo noExtField ctx (noLoc $ ys ++ [e]) 117 cons = mapMaybe qualCon xs 118 qualCon :: ExprLStmt GhcPs -> Maybe String 119 qualCon (L _ (BodyStmt _ (L _ (HsVar _ (L _ x))) _ _)) = Just (occNameStr x) 120 qualCon _ = Nothing 121 122listCompCheckMap :: 123 LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsStmtContext GhcRn -> [ExprLStmt GhcPs] -> [Idea] 124listCompCheckMap o mp f ctx stmts | varToStr mp == "map" = 125 [suggest "Move map inside list comprehension" o o2 (suggestExpr o o2)] 126 where 127 revs = reverse stmts 128 L _ (LastStmt _ body b s) = head revs -- In a ListComp, this is always last. 129 last = noLoc $ LastStmt noExtField (noLoc $ HsApp noExtField (paren f) (paren body)) b s 130 o2 =noLoc $ HsDo noExtField ctx (noLoc $ reverse (tail revs) ++ [last]) 131listCompCheckMap _ _ _ _ _ = [] 132 133suggestExpr :: LHsExpr GhcPs -> LHsExpr GhcPs -> [Refactoring R.SrcSpan] 134suggestExpr o o2 = [Replace Expr (toSS o) [] (unsafePrettyPrint o2)] 135 136moveGuardsForward :: [ExprLStmt GhcPs] -> [ExprLStmt GhcPs] 137moveGuardsForward = reverse . f [] . reverse 138 where 139 f guards (x@(L _ (BindStmt _ p _)) : xs) = reverse stop ++ x : f move xs 140 where (move, stop) = 141 span (if any hasPFieldsDotDot (universeBi x) 142 || any isPFieldWildcard (universeBi x) 143 then const False 144 else \x -> 145 let pvs = pvars p in 146 -- See this code from 'RdrHsSyn.hs' (8.10.1): 147 -- plus_RDR, pun_RDR :: RdrName 148 -- plus_RDR = mkUnqual varName (fsLit "+") -- Hack 149 -- pun_RDR = mkUnqual varName (fsLit "pun-right-hand-side") 150 -- Todo (SF, 2020-03-28): Try to make this better somehow. 151 pvs `disjoint` varss x && "pun-right-hand-side" `notElem` pvs 152 ) guards 153 f guards (x@(L _ BodyStmt{}):xs) = f (x:guards) xs 154 f guards (x@(L _ LetStmt{}):xs) = f (x:guards) xs 155 f guards xs = reverse guards ++ xs 156 157listExp :: Bool -> Bool -> LHsExpr GhcPs -> [Idea] 158listExp overloadedListsOn b (fromParen -> x) = 159 if null res 160 then concatMap (listExp overloadedListsOn $ isAppend x) $ children x 161 else [head res] 162 where 163 res = [suggest name x x2 [r] 164 | (name, f) <- checks overloadedListsOn 165 , Just (x2, subts, temp) <- [f b x] 166 , let r = Replace Expr (toSS x) subts temp ] 167 168listPat :: LPat GhcPs -> [Idea] 169listPat x = if null res then concatMap listPat $ children x else [head res] 170 where res = [suggest name x x2 [r] 171 | (name, f) <- pchecks 172 , Just (x2, subts, temp) <- [f x] 173 , let r = Replace Pattern (toSS x) subts temp ] 174isAppend :: View a App2 => a -> Bool 175isAppend (view -> App2 op _ _) = varToStr op == "++" 176isAppend _ = False 177 178checks :: Bool -> [(String, Bool -> LHsExpr GhcPs -> Maybe (LHsExpr GhcPs, [(String, R.SrcSpan)], String))] 179checks overloadedListsOn = let (*) = (,) in drop1 -- see #174 180 [ "Use string literal" * useString 181 , "Use :" * useCons 182 ] 183 <> ["Use list literal" * useList | not overloadedListsOn ] -- see #114 184 185pchecks :: [(String, LPat GhcPs -> Maybe (LPat GhcPs, [(String, R.SrcSpan)], String))] 186pchecks = let (*) = (,) in drop1 -- see #174 187 [ "Use string literal pattern" * usePString 188 , "Use list literal pattern" * usePList 189 ] 190 191usePString :: LPat GhcPs -> Maybe (LPat GhcPs, [a], String) 192usePString (L _ (ListPat _ xs)) | not $ null xs, Just s <- mapM fromPChar xs = 193 let literal = noLoc $ LitPat noExtField (HsString NoSourceText (fsLit (show s))) 194 in Just (literal, [], unsafePrettyPrint literal) 195usePString _ = Nothing 196 197usePList :: LPat GhcPs -> Maybe (LPat GhcPs, [(String, R.SrcSpan)], String) 198usePList = 199 fmap ( (\(e, s) -> 200 (noLoc (ListPat noExtField e) 201 , map (fmap toRefactSrcSpan . fst) s 202 , unsafePrettyPrint (noLoc $ ListPat noExtField (map snd s) :: LPat GhcPs)) 203 ) 204 . unzip 205 ) 206 . f True substVars 207 where 208 f first _ x | patToStr x == "[]" = if first then Nothing else Just [] 209 f first (ident:cs) (view -> PApp_ ":" [a, b]) = ((a, g ident a) :) <$> f False cs b 210 f first _ _ = Nothing 211 212 g :: String -> LPat GhcPs -> ((String, SrcSpan), LPat GhcPs) 213 g s (getLoc -> loc) = ((s, loc), noLoc $ VarPat noExtField (noLoc $ mkVarUnqual (fsLit s))) 214 215useString :: p -> LHsExpr GhcPs -> Maybe (LHsExpr GhcPs, [a], String) 216useString b (L _ (ExplicitList _ _ xs)) | not $ null xs, Just s <- mapM fromChar xs = 217 let literal = noLoc (HsLit noExtField (HsString NoSourceText (fsLit (show s)))) 218 in Just (literal, [], unsafePrettyPrint literal) 219useString _ _ = Nothing 220 221useList :: p -> LHsExpr GhcPs -> Maybe (LHsExpr GhcPs, [(String, R.SrcSpan)], String) 222useList b = 223 fmap ( (\(e, s) -> 224 (noLoc (ExplicitList noExtField Nothing e) 225 , map (fmap toSS) s 226 , unsafePrettyPrint (noLoc $ ExplicitList noExtField Nothing (map snd s) :: LHsExpr GhcPs)) 227 ) 228 . unzip 229 ) 230 . f True substVars 231 where 232 f first _ x | varToStr x == "[]" = if first then Nothing else Just [] 233 f first (ident:cs) (view -> App2 c a b) | varToStr c == ":" = 234 ((a, g ident a) :) <$> f False cs b 235 f first _ _ = Nothing 236 237 g :: String -> LHsExpr GhcPs -> (String, LHsExpr GhcPs) 238 g s p = (s, L (getLoc p) (unLoc $ strToVar s)) 239 240useCons :: View a App2 => Bool -> a -> Maybe (LHsExpr GhcPs, [(String, R.SrcSpan)], String) 241useCons False (view -> App2 op x y) | varToStr op == "++" 242 , Just (newX, tplX, spanX) <- f x 243 , not $ isAppend y = 244 Just (gen newX y 245 , [("x", spanX), ("xs", toSS y)] 246 , unsafePrettyPrint $ gen tplX (strToVar "xs") 247 ) 248 where 249 f :: LHsExpr GhcPs -> Maybe (LHsExpr GhcPs, LHsExpr GhcPs, R.SrcSpan) 250 f (L _ (ExplicitList _ _ [x])) 251 | isAtom x || isApp x = Just (x, strToVar "x", toSS x) 252 | otherwise = Just (addParen x, addParen (strToVar "x"), toSS x) 253 f _ = Nothing 254 255 gen :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs 256 gen x = noLoc . OpApp noExtField x (noLoc (HsVar noExtField (noLoc consDataCon_RDR))) 257useCons _ _ = Nothing 258 259typeListChar :: LHsType GhcPs 260typeListChar = 261 noLoc $ HsListTy noExtField 262 (noLoc (HsTyVar noExtField NotPromoted (noLoc (mkVarUnqual (fsLit "Char"))))) 263 264typeString :: LHsType GhcPs 265typeString = 266 noLoc $ HsTyVar noExtField NotPromoted (noLoc (mkVarUnqual (fsLit "String"))) 267 268stringType :: LHsDecl GhcPs -> [Idea] 269stringType (L _ x) = case x of 270 InstD _ ClsInstD{ 271 cid_inst= 272 ClsInstDecl{cid_binds=x, cid_tyfam_insts=y, cid_datafam_insts=z}} -> 273 f x ++ f y ++ f z -- Pretty much everthing but the instance type. 274 _ -> f x 275 where 276 f x = concatMap g $ childrenBi x 277 278 g :: LHsType GhcPs -> [Idea] 279 g e@(fromTyParen -> x) = [ignore "Use String" x (transform f x) 280 rs | not . null $ rs] 281 where f x = if astEq x typeListChar then typeString else x 282 rs = [Replace Type (toSS t) [] (unsafePrettyPrint typeString) | t <- universe x, astEq t typeListChar] 283