{-# 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 :: AnnDecl GhcPs -> Maybe Classify
readPragma (HsAnnotation XHsAnnotation GhcPs
_ AnnProvenance GhcPs
provenance XRec GhcPs (HsExpr GhcPs)
expr) = LocatedA (HsExpr GhcPs) -> Maybe Classify
f XRec GhcPs (HsExpr GhcPs)
expr
    where
        name :: String
name = case AnnProvenance GhcPs
provenance of
            ValueAnnProvenance (L SrcSpanAnnN
_ RdrName
x) -> RdrName -> String
occNameStr RdrName
x
            TypeAnnProvenance (L SrcSpanAnnN
_ RdrName
x) -> RdrName -> String
occNameStr RdrName
x
            AnnProvenance GhcPs
ModuleAnnProvenance -> String
""

        f :: LocatedA (HsExpr GhcPs) -> Maybe Classify
        f :: LocatedA (HsExpr GhcPs) -> Maybe Classify
f (L SrcSpanAnnA
_ (HsLit XLitE GhcPs
_ (HsString XHsString GhcPs
_ (FastString -> String
unpackFS -> String
s)))) | String
"hlint:" forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String -> String
lower String
s =
                case String -> Maybe Severity
getSeverity String
a of
                    Maybe Severity
Nothing -> forall a b. Outputable a => LocatedA a -> String -> b
errorOn XRec GhcPs (HsExpr GhcPs)
expr String
"bad classify pragma"
                    Just Severity
severity -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Severity -> String -> String -> String -> Classify
Classify Severity
severity (String -> String
trimStart String
b) String
"" String
name
            where (String
a,String
b) = forall a. (a -> Bool) -> [a] -> ([a], [a])
break Char -> Bool
isSpace forall a b. (a -> b) -> a -> b
$ String -> String
trimStart forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
drop Int
6 String
s
        f (L SrcSpanAnnA
_ (HsPar XPar GhcPs
_ LHsToken "(" GhcPs
_ XRec GhcPs (HsExpr GhcPs)
x LHsToken ")" GhcPs
_)) = LocatedA (HsExpr GhcPs) -> Maybe Classify
f XRec GhcPs (HsExpr GhcPs)
x
        f (L SrcSpanAnnA
_ (ExprWithTySig XExprWithTySig GhcPs
_ XRec GhcPs (HsExpr GhcPs)
x LHsSigWcType (NoGhcTc GhcPs)
_)) = LocatedA (HsExpr GhcPs) -> Maybe Classify
f XRec GhcPs (HsExpr GhcPs)
x
        f LocatedA (HsExpr GhcPs)
_ = forall a. Maybe a
Nothing

readComment :: LEpaComment -> [Classify]
readComment :: LEpaComment -> [Classify]
readComment c :: LEpaComment
c@(L Anchor
pos (EpaComment EpaBlockComment{} RealSrcSpan
_))
    | (Bool
hash, String
x) <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Bool
False, String
x) (Bool
True,) forall a b. (a -> b) -> a -> b
$ forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix String
"#" String
x
    , String
x <- String -> String
trim String
x
    , (String
hlint, String
x) <- String -> (String, String)
word1 String
x
    , String -> String
lower String
hlint forall a. Eq a => a -> a -> Bool
== String
"hlint"
    = Bool -> String -> [Classify]
f Bool
hash String
x
    where
        x :: String
x = LEpaComment -> String
commentText LEpaComment
c
        f :: Bool -> String -> [Classify]
f Bool
hash String
x
            | Just String
x <- if Bool
hash then forall a. Eq a => [a] -> [a] -> Maybe [a]
stripSuffix String
"#" String
x else forall a. a -> Maybe a
Just String
x
            , (String
sev, String
x) <- String -> (String, String)
word1 String
x
            , Just Severity
sev <- String -> Maybe Severity
getSeverity String
sev
            , ([String]
things, String
x) <- String -> ([String], String)
g String
x
            , Just String
hint <- if String
x forall a. Eq a => a -> a -> Bool
== String
"" then forall a. a -> Maybe a
Just String
"" else forall a. Read a => String -> Maybe a
readMaybe String
x
            = forall a b. (a -> b) -> [a] -> [b]
map (Severity -> String -> String -> String -> Classify
Classify Severity
sev String
hint String
"") forall a b. (a -> b) -> a -> b
$ [String
"" | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
things] forall a. [a] -> [a] -> [a]
++ [String]
things
        f Bool
hash String
_ = forall b. LEpaComment -> String -> b
errorOnComment LEpaComment
c forall a b. (a -> b) -> a -> b
$ String
"bad HLINT pragma, expected:\n    {-" forall a. [a] -> [a] -> [a]
++ String
h forall a. [a] -> [a] -> [a]
++ String
" HLINT <severity> <identifier> \"Hint name\" " forall a. [a] -> [a] -> [a]
++ String
h forall a. [a] -> [a] -> [a]
++ String
"-}"
            where h :: String
h = [Char
'#' | Bool
hash]

        g :: String -> ([String], String)
g String
x | (String
s, String
x) <- String -> (String, String)
word1 String
x
            , String
s forall a. Eq a => a -> a -> Bool
/= String
""
            , Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ String
"\"" forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
s
            = forall a a' b. (a -> a') -> (a, b) -> (a', b)
first ((if String
s forall a. Eq a => a -> a -> Bool
== String
"module" then String
"" else String
s)forall a. a -> [a] -> [a]
:) forall a b. (a -> b) -> a -> b
$ String -> ([String], String)
g String
x
        g String
x = ([], String
x)
readComment LEpaComment
_ = []


errorOn :: Outputable a => LocatedA a -> String -> b
errorOn :: forall a b. Outputable a => LocatedA a -> String -> b
errorOn (L SrcSpanAnnA
pos a
val) String
msg = forall a. String -> a
exitMessageImpure forall a b. (a -> b) -> a -> b
$
    SrcSpan -> String
showSrcSpan (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
pos) forall a. [a] -> [a] -> [a]
++
    String
": Error while reading hint file, " forall a. [a] -> [a] -> [a]
++ String
msg forall a. [a] -> [a] -> [a]
++ String
"\n" forall a. [a] -> [a] -> [a]
++
    forall a. Outputable a => a -> String
unsafePrettyPrint a
val

errorOnComment :: LEpaComment -> String -> b
errorOnComment :: forall b. LEpaComment -> String -> b
errorOnComment c :: LEpaComment
c@(L Anchor
s EpaComment
_) String
msg = forall a. String -> a
exitMessageImpure forall a b. (a -> b) -> a -> b
$
    let isMultiline :: Bool
isMultiline = LEpaComment -> Bool
isCommentMultiline LEpaComment
c in
    SrcSpan -> String
showSrcSpan (RealSrcSpan -> Maybe BufSpan -> SrcSpan
RealSrcSpan (Anchor -> RealSrcSpan
anchor Anchor
s) forall a. Maybe a
GHC.Data.Strict.Nothing) forall a. [a] -> [a] -> [a]
++
    String
": Error while reading hint file, " forall a. [a] -> [a] -> [a]
++ String
msg forall a. [a] -> [a] -> [a]
++ String
"\n" forall a. [a] -> [a] -> [a]
++
    (if Bool
isMultiline then String
"{-" else String
"--") forall a. [a] -> [a] -> [a]
++ LEpaComment -> String
commentText LEpaComment
c forall a. [a] -> [a] -> [a]
++ (if Bool
isMultiline then String
"-}" else String
"")