content: {-# LANGUAGE ImportQualifiedPost #-}
  {-# LANGUAGE ViewPatterns #-}
  {-# LANGUAGE FlexibleContexts #-}
  
  {-
      Suggest better pragmas
      OPTIONS_GHC -cpp => LANGUAGE CPP
      OPTIONS_GHC -fglasgow-exts => LANGUAGE ... (in HSE)
      OPTIONS_GHC -XFoo => LANGUAGE Foo
      LANGUAGE A, A => LANGUAGE A
      -- do not do LANGUAGE A, LANGUAGE B to combine
  
  <TEST>
  {-# OPTIONS_GHC -cpp #-} -- {-# LANGUAGE CPP #-}
  {-# OPTIONS     -cpp #-} -- {-# LANGUAGE CPP #-}
  {-# OPTIONS_YHC -cpp #-}
  {-# OPTIONS_GHC -XFoo #-} -- {-# LANGUAGE Foo #-}
  {-# OPTIONS_GHC -fglasgow-exts #-} -- ??? @NoRefactor: refactor output has one LANGUAGE pragma per extension, while hlint suggestion has a single LANGUAGE pragma
  {-# LANGUAGE RebindableSyntax, EmptyCase, RebindableSyntax #-} -- {-# LANGUAGE RebindableSyntax, EmptyCase #-}
  {-# LANGUAGE RebindableSyntax, EmptyCase, DuplicateRecordFields, RebindableSyntax #-} -- {-# LANGUAGE RebindableSyntax, EmptyCase, DuplicateRecordFields #-}
  {-# LANGUAGE RebindableSyntax #-}
  {-# OPTIONS_GHC -cpp -foo #-} -- {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -foo #-} @NoRefactor -foo is not a valid flag
  {-# OPTIONS_GHC -cpp -w #-} -- {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -w #-}
  {-# OPTIONS_GHC -cpp #-} \
  {-# LANGUAGE CPP, Text #-} --
  {-# LANGUAGE RebindableSyntax #-} \
  {-# LANGUAGE DuplicateRecordFields #-}
  {-# LANGUAGE RebindableSyntax #-} \
  {-# LANGUAGE EmptyCase, RebindableSyntax #-} -- {-# LANGUAGE EmptyCase, RebindableSyntax #-}
  </TEST>
  -}
  
  
  module Hint.Pragma(pragmaHint) where
  
  import Hint.Type(ModuHint,Idea(..),Severity(..),toSSAnc,rawIdea,modComments,firstDeclComments)
  import Data.List.Extra
  import Data.List.NonEmpty qualified as NE
  import Data.Maybe
  import Refact.Types
  import Refact.Types qualified as R
  
  import GHC.Hs
  import GHC.Types.SrcLoc
  import GHC.Data.FastString
  
  import GHC.Util
  import GHC.Driver.Session
  
  pragmaHint :: ModuHint
  pragmaHint _ modu =
    -- 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).
    let ps = pragmas (modComments modu) ++ pragmas (firstDeclComments modu)
        opts = flags ps
        lang = languagePragmas ps in
      languageDupes lang ++ optToPragma opts lang
  
  optToPragma :: [(LEpaComment, [String])]
               -> [(LEpaComment, [String])]
               -> [Idea]
  optToPragma flags languagePragmas =
    [pragmaIdea (OptionsToComment (fst <$> old2) ys rs) | Just old2 <- [NE.nonEmpty old]]
    where
        (old, new, ns, rs) =
          unzip4 [(old, new, ns, r)
                 | old <- flags, Just (new, ns) <- [optToLanguage old ls]
                 , let r = mkRefact old new ns]
  
        ls = concatMap snd languagePragmas
        ns2 = nubOrd (concat ns) \\ ls
  
        dummyLoc = mkRealSrcLoc (fsLit "dummy") 1 1
        dummySpan = mkRealSrcSpan dummyLoc dummyLoc
        dummyAnchor = realSpanAsAnchor dummySpan
  
        ys = [mkLanguagePragmas dummyAnchor ns2 | ns2 /= []] ++ catMaybes new
        mkRefact :: (LEpaComment, [String])
                 -> Maybe LEpaComment
                 -> [String]
                 -> Refactoring R.SrcSpan
        mkRefact old (maybe "" comment_ -> new) ns =
          let ns' = map (\n -> comment_ (mkLanguagePragmas dummyAnchor [n])) ns
          in ModifyComment (toSSAnc (fst old)) (intercalate "\n" (filter (not . null) (ns' `snoc` new)))
  
  data PragmaIdea = SingleComment LEpaComment LEpaComment
                   | MultiComment LEpaComment LEpaComment LEpaComment
                   | OptionsToComment (NE.NonEmpty LEpaComment) [LEpaComment] [Refactoring R.SrcSpan]
  
  pragmaIdea :: PragmaIdea -> Idea
  pragmaIdea pidea =
    case pidea of
      SingleComment old new ->
        mkFewer (getAncLoc old) (comment_ old) (Just $ comment_ new) []
        [ModifyComment (toSSAnc old) (comment_ new)]
      MultiComment repl delete new ->
        mkFewer (getAncLoc repl)
          (f [repl, delete]) (Just $ comment_ new) []
          [ ModifyComment (toSSAnc repl) (comment_ new)
          , ModifyComment (toSSAnc delete) ""]
      OptionsToComment old new r ->
        mkLanguage (getAncLoc . NE.head $ old)
          (f $ NE.toList old) (Just $ f new) []
          r
      where
            f = unlines . map comment_
            mkFewer = rawIdea Hint.Type.Warning "Use fewer LANGUAGE pragmas"
            mkLanguage = rawIdea Hint.Type.Warning "Use LANGUAGE pragmas"
  
  languageDupes :: [(LEpaComment, [String])] -> [Idea]
  languageDupes ( (a@(L l _), les) : cs ) =
    (if nubOrd les /= les
         then [pragmaIdea (SingleComment a (mkLanguagePragmas l $ nubOrd les))]
         else [pragmaIdea (MultiComment a b (mkLanguagePragmas l (nubOrd $ les ++ les'))) | ( b@(L _ _), les' ) <- cs, not $ disjoint les les']
    ) ++ languageDupes cs
  languageDupes _ = []
  
  -- Given a pragma, can you extract some language features out?
  strToLanguage :: String -> Maybe [String]
  strToLanguage "-cpp" = Just ["CPP"]
  strToLanguage x | "-X" `isPrefixOf` x = Just [drop 2 x]
  strToLanguage "-fglasgow-exts" = Just $ map show glasgowExtsFlags
  strToLanguage _ = Nothing
  
  -- In 'optToLanguage p langexts', 'p' is an 'OPTIONS_GHC' pragma,
  -- 'langexts' a list of all language extensions in the module enabled
  -- by 'LANGUAGE' pragmas.
  --
  --  If ALL of the flags in the pragma enable language extensions,
  -- 'return Nothing'.
  --
  -- If some (or all) of the flags enable options that are not language
  -- extensions, compute a new options pragma with only non-language
  -- extension enabling flags. Return that together with a list of any
  -- language extensions enabled by this pragma that are not otherwise
  -- enabled by LANGUAGE pragmas in the module.
  optToLanguage :: (LEpaComment, [String])
                 -> [String]
                 -> Maybe (Maybe LEpaComment, [String])
  optToLanguage (L loc _, flags) languagePragmas
    | any isJust vs =
        -- 'ls' is a list of language features enabled by this
        -- OPTIONS_GHC pragma that are not enabled by LANGUAGE pragmas
        -- in this module.
        let ls = concatMap (filter (`notElem` languagePragmas)) $ catMaybes vs in
        Just (res, ls)
    where
      -- Try reinterpreting each flag as a list of language features
      -- (e.g. via '-X'..., '-fglasgow-exts').
      vs = map strToLanguage flags -- e.g. '[Nothing, Just ["ScopedTypeVariables"], Nothing, ...]'
      -- Keep any flag that does not enable language extensions.
      keep = concat $ zipWith (\v f -> [f | isNothing v]) vs flags
      -- If there are flags to keep, 'res' is a new pragma setting just those flags.
      res = if null keep then Nothing else Just (mkFlags loc keep)
  optToLanguage _ _ = Nothing
  