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