content: {-# LANGUAGE ImportQualifiedPost #-}
  {-# LANGUAGE PatternGuards, ViewPatterns, TupleSections #-}
  module Config.Haskell(
      readPragma,
      readComment
      ) where
  
  import Data.Char
  import Data.List.Extra
  import Text.Read
  import Data.Tuple.Extra
  import Data.Maybe
  import Config.Type
  import Util
  import Prelude
  
  import GHC.Util
  
  import GHC.Types.SrcLoc
  import GHC.Hs.Extension
  import GHC.Hs.Decls hiding (SpliceDecl)
  import GHC.Hs.Expr hiding (Match)
  import GHC.Hs.Lit
  import GHC.Data.FastString
  import GHC.Parser.Annotation
  import GHC.Utils.Outputable
  import GHC.Data.Strict qualified
  
  import Language.Haskell.GhclibParserEx.GHC.Utils.Outputable
  import Language.Haskell.GhclibParserEx.GHC.Types.Name.Reader
  
  -- | Read an {-# ANN #-} pragma and determine if it is intended for HLint.
  --   Return Nothing if it is not an HLint pragma, otherwise what it means.
  readPragma :: AnnDecl GhcPs -> Maybe Classify
  readPragma (HsAnnotation _ provenance expr) = f expr
      where
          name = case provenance of
              ValueAnnProvenance (L _ x) -> occNameStr x
              TypeAnnProvenance (L _ x) -> occNameStr x
              ModuleAnnProvenance -> ""
  
          f :: LocatedA (HsExpr GhcPs) -> Maybe Classify
          f (L _ (HsLit _ (HsString _ (unpackFS -> s)))) | "hlint:" `isPrefixOf` lower s =
                  case getSeverity a of
                      Nothing -> errorOn expr "bad classify pragma"
                      Just severity -> Just $ Classify severity (trimStart b) "" name
              where (a,b) = break isSpace $ trimStart $ drop 6 s
          f (L _ (HsPar _ x)) = f x
          f (L _ (ExprWithTySig _ x _)) = f x
          f _ = Nothing
  
  readComment :: LEpaComment -> [Classify]
  readComment c@(L pos (EpaComment EpaBlockComment{} _))
      | (hash, x) <- maybe (False, x) (True,) $ stripPrefix "#" x
      , x <- trim x
      , (hlint, x) <- word1 x
      , lower hlint == "hlint"
      = f hash x
      where
          x = commentText c
          f hash x
              | Just x <- if hash then stripSuffix "#" x else Just x
              , (sev, x) <- word1 x
              , Just sev <- getSeverity sev
              , (things, x) <- g x
              , Just hint <- if x == "" then Just "" else readMaybe x
              = map (Classify sev hint "") $ ["" | null things] ++ things
          f hash _ = errorOnComment c $ "bad HLINT pragma, expected:\n    {-" ++ h ++ " HLINT <severity> <identifier> \"Hint name\" " ++ h ++ "-}"
              where h = ['#' | hash]
  
          g x | (s, x) <- word1 x
              , s /= ""
              , not $ "\"" `isPrefixOf` s
              = first ((if s == "module" then "" else s):) $ g x
          g x = ([], x)
  readComment _ = []
  
  
  errorOn :: Outputable a => LocatedA a -> String -> b
  errorOn (L pos val) msg = exitMessageImpure $
      showSrcSpan (locA pos) ++
      ": Error while reading hint file, " ++ msg ++ "\n" ++
      unsafePrettyPrint val
  
  errorOnComment :: LEpaComment -> String -> b
  errorOnComment c@(L s _) msg = exitMessageImpure $
      let isMultiline = isCommentMultiline c in
      showSrcSpan (RealSrcSpan (epaLocationRealSrcSpan s) GHC.Data.Strict.Nothing) ++
      ": Error while reading hint file, " ++ msg ++ "\n" ++
      (if isMultiline then "{-" else "--") ++ commentText c ++ (if isMultiline then "-}" else "")
  