content: {-# LANGUAGE ImportQualifiedPost #-}
  {-# LANGUAGE ViewPatterns, PatternGuards, FlexibleContexts #-}
  {-
      Find and match:
  
  <TEST>
  yes = 1:2:[] -- [1,2]
  yes = ['h','e','l','l','o']
  yes (1:2:[]) = 1 -- [1,2]
  yes ['h','e'] = 1
  
  -- [a]++b -> a : b, but only if not in a chain of ++'s
  yes = [x] ++ xs -- x : xs
  no = "x" ++ xs
  no = [x] ++ xs ++ ys
  no = xs ++ [x] ++ ys
  yes = [if a then b else c] ++ xs -- (if a then b else c) : xs
  yes = [1] : [2] : [3] : [4] : [5] : [] -- [[1], [2], [3], [4], [5]]
  yes = if x == e then l2 ++ xs else [x] ++ check_elem xs -- x : check_elem xs
  data Yes = Yes (Maybe [Char]) -- Maybe String
  yes = y :: [Char] -> a -- String -> a
  instance C [Char]
  foo = [a b] ++ xs -- a b : xs
  foo = [myexpr | True, a] -- [myexpr | a]
  foo = [myexpr | False] -- []
  foo = map f [x + 1 | x <- [1..10]] -- [f (x + 1) | x <- [1..10]]
  foo = [x + 1 | x <- [1..10], feature] -- [x + 1 | feature, x <- [1..10]]
  foo = [x + 1 | x <- [1..10], even x]
  foo = [x + 1 | x <- [1..10], even x, dont_reoder_guards]
  foo = [x + 1 | x <- [1..10], let y = even x, y]
  foo = [x + 1 | x <- [1..10], let q = even 1, q] -- [x + 1 | let q = even 1, q, x <- [1..10]]
  foo = [fooValue | Foo{..} <- y, fooField]
  issue619 = [pkgJobs | Pkg{pkgGpd, pkgJobs} <- pkgs, not $ null $ C.condTestSuites pkgGpd]
  {-# LANGUAGE MonadComprehensions #-}\
  foo = [x | False, x <- [1 .. 10]] -- []
  foo = [_ | x <- _, let _ = A{x}]
  issue1039 = foo (map f [1 | _ <- []]) -- [f 1 | _ <- []]
  {-# LANGUAGE OverloadedLists #-} \
  issue114 = True:[]
  </TEST>
  -}
  
  module Hint.List(listHint) where
  
  import Control.Applicative
  import Data.Generics.Uniplate.DataOnly
  import Data.List.NonEmpty qualified as NE
  import Data.List.Extra
  import Data.Maybe
  import Prelude
  
  import Hint.Type(DeclHint,Idea,suggest,ignore,substVars,toRefactSrcSpan,toSSA,modComments,firstDeclComments)
  
  import Refact.Types hiding (SrcSpan)
  import Refact.Types qualified as R
  
  import GHC.Hs
  import GHC.Types.SrcLoc
  import GHC.Types.SourceText
  import GHC.Types.Name.Reader
  import GHC.Data.FastString
  import GHC.Builtin.Types
  
  import GHC.Util
  import Language.Haskell.GhclibParserEx.GHC.Hs.Pat
  import Language.Haskell.GhclibParserEx.GHC.Hs.Expr
  import Language.Haskell.GhclibParserEx.GHC.Hs.Type
  import Language.Haskell.GhclibParserEx.GHC.Hs.ExtendInstances
  import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable
  import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader
  
  
  listHint :: DeclHint
  listHint _ modu = listDecl overloadedListsOn
    where
      -- Comments appearing without a line-break 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 = concatMap snd (languagePragmas (pragmas (modComments modu) ++ pragmas (firstDeclComments modu)))
      overloadedListsOn = "OverloadedLists" `elem` exts
  
  listDecl :: Bool -> LHsDecl GhcPs -> [Idea]
  listDecl overloadedListsOn x =
    concatMap (listExp overloadedListsOn False) (childrenBi x) ++
    stringType x ++
    concatMap listPat (childrenBi x) ++
    concatMap listComp (universeBi x)
  
  -- Refer to https://github.com/ndmitchell/hlint/issues/775 for the
  -- structure of 'listComp'.
  
  listComp :: LHsExpr GhcPs -> [Idea]
  listComp o@(L _ (HsDo _ ListComp (L _ stmts))) =
    listCompCheckGuards o ListComp stmts
  listComp o@(L _ (HsDo _ MonadComp (L _ stmts))) =
    listCompCheckGuards o MonadComp stmts
  listComp (L _ HsPar{}) = [] -- App2 "sees through" paren, which causes duplicate hints with universeBi
  listComp o@(view -> App2 mp f (L _ (HsDo _ ListComp (L _ stmts)))) =
    listCompCheckMap o mp f ListComp stmts
  listComp o@(view -> App2 mp f (L _ (HsDo _ MonadComp (L _ stmts)))) =
    listCompCheckMap o mp f MonadComp stmts
  listComp _ = []
  
  listCompCheckGuards :: LHsExpr GhcPs -> HsDoFlavour -> [ExprLStmt GhcPs] -> [Idea]
  listCompCheckGuards o ctx stmts =
    let revs = NE.reverse $ NE.fromList stmts
        e@(L _ LastStmt{}) = NE.head revs -- In a ListComp, this is always last.
        xs = reverse (NE.tail revs) in
    list_comp_aux e xs
    where
      list_comp_aux e xs
        | "False" `elem` cons =  [suggest "Short-circuited list comprehension" (reLoc o) (reLoc o') (suggestExpr o o')]
        | "True" `elem` cons = [suggest "Redundant True guards" (reLoc o) (reLoc o2) (suggestExpr o o2)]
        | not (astListEq xs ys) = [suggest "Move guards forward" (reLoc o) (reLoc o3) (suggestExpr o o3)]
        | otherwise = []
        where
          ys = moveGuardsForward xs
          o' = noLocA $ ExplicitList noAnn []
          o2 = noLocA $ HsDo noAnn ctx (noLocA (filter ((/= Just "True") . qualCon) xs ++ [e]))
          o3 = noLocA $ HsDo noAnn ctx (noLocA $ ys ++ [e])
          cons = mapMaybe qualCon xs
          qualCon :: ExprLStmt GhcPs -> Maybe String
          qualCon (L _ (BodyStmt _ (L _ (HsVar _ (L _ x))) _ _)) = Just (occNameStr x)
          qualCon _ = Nothing
  
  listCompCheckMap ::
    LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> HsDoFlavour -> [ExprLStmt GhcPs] -> [Idea]
  listCompCheckMap o mp f ctx stmts  | varToStr mp == "map" =
      [suggest "Move map inside list comprehension" (reLoc o) (reLoc o2) (suggestExpr o o2)]
      where
        revs = NE.reverse $ NE.fromList stmts
        L _ (LastStmt _ body b s) = NE.head revs -- In a ListComp, this is always last.
        last = noLocA $ LastStmt noExtField (noLocA $ HsApp noExtField (paren f) (paren body)) b s
        o2 =noLocA $ HsDo noAnn ctx (noLocA $ reverse (NE.tail revs) ++ [last])
  
  listCompCheckMap _ _ _ _ _ = []
  
  suggestExpr :: LHsExpr GhcPs -> LHsExpr GhcPs -> [Refactoring R.SrcSpan]
  suggestExpr o o2 = [Replace Expr (toSSA o) [] (unsafePrettyPrint o2)]
  
  moveGuardsForward :: [ExprLStmt GhcPs] -> [ExprLStmt GhcPs]
  moveGuardsForward = reverse . f [] . reverse
    where
      f guards (x@(L _ (BindStmt _ p _)) : xs) = reverse stop ++ x : f move xs
        where (move, stop) =
                span (if any hasPFieldsDotDot (universeBi x)
                         || any isPFieldWildcard (universeBi x)
                        then const False
                        else \x ->
                         let pvs = pvars p in
                         -- See this code from 'RdrHsSyn.hs' (8.10.1):
                         --   plus_RDR, pun_RDR :: RdrName
                         --   plus_RDR = mkUnqual varName (fsLit "+") -- Hack
                         --   pun_RDR  = mkUnqual varName (fsLit "pun-right-hand-side")
                         -- Todo (SF, 2020-03-28): Try to make this better somehow.
                         pvs `disjoint` varss x && "pun-right-hand-side" `notElem` pvs
                     ) guards
      f guards (x@(L _ BodyStmt{}):xs) = f (x:guards) xs
      f guards (x@(L _ LetStmt{}):xs) = f (x:guards) xs
      f guards xs = reverse guards ++ xs
  
  listExp :: Bool -> Bool -> LHsExpr GhcPs -> [Idea]
  listExp overloadedListsOn b (fromParen -> x) =
    if null res
      then concatMap (listExp overloadedListsOn $ isAppend x) $ children x
      else [NE.head $ NE.fromList res]
    where
      res = [suggest name (reLoc x) (reLoc x2) [r]
            | (name, f) <- checks overloadedListsOn
            , Just (x2, subts, temp) <- [f b x]
            , let r = Replace Expr (toSSA x) subts temp ]
  
  listPat :: LPat GhcPs -> [Idea]
  listPat x = if null res then concatMap listPat $ children x else [NE.head $ NE.fromList res]
      where res = [suggest name (reLoc x) (reLoc x2) [r]
                    | (name, f) <- pchecks
                    , Just (x2, subts, temp) <- [f x]
                    , let r = Replace Pattern (toSSA x) subts temp ]
  
  isAppend :: View a App2 => a -> Bool
  isAppend (view -> App2 op _ _) = varToStr op == "++"
  isAppend _ = False
  
  checks :: Bool -> [(String, Bool -> LHsExpr GhcPs -> Maybe (LHsExpr GhcPs, [(String, R.SrcSpan)], String))]
  checks overloadedListsOn = let (*) = (,) in drop1 -- see #174
    [ "Use string literal" * useString
    , "Use :" * useCons
    ]
    <> ["Use list literal" * useList | not overloadedListsOn ] -- see #114
  
  pchecks :: [(String, LPat GhcPs -> Maybe (LPat GhcPs, [(String, R.SrcSpan)], String))]
  pchecks = let (*) = (,) in drop1 -- see #174
      [ "Use string literal pattern" * usePString
      , "Use list literal pattern" * usePList
      ]
  
  usePString :: LPat GhcPs -> Maybe (LPat GhcPs, [a], String)
  usePString (L _ (ListPat _ xs)) | not $ null xs, Just s <- mapM fromPChar xs =
    let literal = noLocA $ LitPat noExtField (HsString NoSourceText (fsLit (show s))) :: LPat GhcPs
    in Just (literal, [], unsafePrettyPrint literal)
  usePString _ = Nothing
  
  usePList :: LPat GhcPs -> Maybe (LPat GhcPs, [(String, R.SrcSpan)], String)
  usePList =
    fmap  ( (\(e, s) ->
               (noLocA (ListPat noAnn e)
               , map (fmap toRefactSrcSpan . fst) s
               , unsafePrettyPrint (noLocA $ ListPat noAnn (map snd s) :: LPat GhcPs))
            )
            . unzip
          )
    . f True substVars
    where
      f first _ x | patToStr x == "[]" = if first then Nothing else Just []
      f first (ident:cs) (view -> PApp_ ":" [a, b]) = ((a, g ident a) :) <$> f False cs b
      f first _ _ = Nothing
  
      g :: String -> LPat GhcPs -> ((String, SrcSpan), LPat GhcPs)
      g s (locA . getLoc -> loc) = ((s, loc), noLocA $ VarPat noExtField (noLocA $ mkVarUnqual (fsLit s)))
  
  useString :: p -> LHsExpr GhcPs -> Maybe (LHsExpr GhcPs, [a], String)
  useString b (L _ (ExplicitList _ xs)) | not $ null xs, Just s <- mapM fromChar xs =
    let literal = noLocA (HsLit noExtField (HsString NoSourceText (fsLit (show s)))) :: LHsExpr GhcPs
    in Just (literal, [], unsafePrettyPrint literal)
  useString _ _ = Nothing
  
  useList :: p -> LHsExpr GhcPs -> Maybe (LHsExpr GhcPs, [(String, R.SrcSpan)], String)
  useList b =
    fmap  ( (\(e, s) ->
               (noLocA (ExplicitList noAnn e)
               , map (fmap toSSA) s
               , unsafePrettyPrint (noLocA $ ExplicitList noAnn (map snd s) :: LHsExpr GhcPs))
            )
            . unzip
          )
    . f True substVars
    where
      f first _ x | varToStr x == "[]" = if first then Nothing else Just []
      f first (ident:cs) (view -> App2 c a b) | varToStr c == ":" =
            ((a, g ident a) :) <$> f False cs b
      f first _ _ = Nothing
  
      g :: String -> LHsExpr GhcPs -> (String, LHsExpr GhcPs)
      g s p = (s, L (getLoc p) (unLoc $ strToVar s))
  
  useCons :: View a App2 => Bool -> a -> Maybe (LHsExpr GhcPs, [(String, R.SrcSpan)], String)
  useCons False (view -> App2 op x y) | varToStr op == "++"
                                      , Just (newX, tplX, spanX) <- f x
                                      , not $ isAppend y =
      Just (gen newX y
           , [("x", spanX), ("xs", toSSA y)]
           , unsafePrettyPrint $ gen tplX (strToVar "xs")
           )
    where
      f :: LHsExpr GhcPs -> Maybe (LHsExpr GhcPs, LHsExpr GhcPs, R.SrcSpan)
      f (L _ (ExplicitList _ [x]))
        | isAtom x || isApp x = Just (x, strToVar "x", toSSA x)
        | otherwise = Just (addParen x, addParen (strToVar "x"), toSSA x)
      f _ = Nothing
  
      gen :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
      gen x = noLocA . OpApp noExtField x (noLocA (HsVar noExtField  (noLocA consDataCon_RDR)))
  useCons _ _ = Nothing
  
  typeListChar :: LHsType GhcPs
  typeListChar =
    noLocA $ HsListTy noAnn
      (noLocA (HsTyVar noAnn NotPromoted (noLocA (mkVarUnqual (fsLit "Char")))))
  
  typeString :: LHsType GhcPs
  typeString =
    noLocA $ HsTyVar noAnn NotPromoted (noLocA (mkVarUnqual (fsLit "String")))
  
  stringType :: LHsDecl GhcPs  -> [Idea]
  stringType (L _ x) = case x of
    InstD _ ClsInstD{
      cid_inst=
          ClsInstDecl{cid_binds=x, cid_tyfam_insts=y, cid_datafam_insts=z}} ->
      f x ++ f y ++ f z -- Pretty much everything but the instance type.
    _ -> f x
    where
      f x = concatMap g $ childrenBi x
  
      g :: LHsType GhcPs -> [Idea]
      g e@(fromTyParen -> x) = [ignore "Use String" (reLoc x) (reLoc (transform f x))
                                rs | not . null $ rs]
        where f x = if astEq x typeListChar then typeString else x
              rs = [Replace Type (toSSA t) [] (unsafePrettyPrint typeString) | t <- universe x, astEq t typeListChar]
  