{-# 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)
LocatedA (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:" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String -> String
lower String
s =
                case String -> Maybe Severity
getSeverity String
a of
                    Maybe Severity
Nothing -> LocatedA (HsExpr GhcPs) -> String -> Maybe Classify
forall a b. Outputable a => LocatedA a -> String -> b
errorOn XRec GhcPs (HsExpr GhcPs)
LocatedA (HsExpr GhcPs)
expr String
"bad classify pragma"
                    Just Severity
severity -> Classify -> Maybe Classify
forall a. a -> Maybe a
Just (Classify -> Maybe Classify) -> Classify -> Maybe Classify
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) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break Char -> Bool
isSpace (String -> (String, String)) -> String -> (String, String)
forall a b. (a -> b) -> a -> b
$ String -> String
trimStart (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Int -> String -> String
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)
LocatedA (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)
LocatedA (HsExpr GhcPs)
x
        f LocatedA (HsExpr GhcPs)
_ = Maybe Classify
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) <- (Bool, String)
-> (String -> (Bool, String)) -> Maybe String -> (Bool, String)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Bool
False, String
x) (Bool
True,) (Maybe String -> (Bool, String)) -> Maybe String -> (Bool, String)
forall a b. (a -> b) -> a -> b
$ String -> String -> Maybe String
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 String -> String -> Bool
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 String -> String -> Maybe String
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripSuffix String
"#" String
x else String -> Maybe String
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 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"" then String -> Maybe String
forall a. a -> Maybe a
Just String
"" else String -> Maybe String
forall a. Read a => String -> Maybe a
readMaybe String
x
            = (String -> Classify) -> [String] -> [Classify]
forall a b. (a -> b) -> [a] -> [b]
map (Severity -> String -> String -> String -> Classify
Classify Severity
sev String
hint String
"") ([String] -> [Classify]) -> [String] -> [Classify]
forall a b. (a -> b) -> a -> b
$ [String
"" | [String] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
things] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
things
        f Bool
hash String
_ = LEpaComment -> String -> [Classify]
forall b. LEpaComment -> String -> b
errorOnComment LEpaComment
c (String -> [Classify]) -> String -> [Classify]
forall a b. (a -> b) -> a -> b
$ String
"bad HLINT pragma, expected:\n    {-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
h String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" HLINT <severity> <identifier> \"Hint name\" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
h String -> String -> String
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 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
""
            , Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ String
"\"" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
s
            = ([String] -> [String]) -> ([String], String) -> ([String], String)
forall a a' b. (a -> a') -> (a, b) -> (a', b)
first ((if String
s String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"module" then String
"" else String
s)String -> [String] -> [String]
forall a. a -> [a] -> [a]
:) (([String], String) -> ([String], String))
-> ([String], String) -> ([String], String)
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 = String -> b
forall a. String -> a
exitMessageImpure (String -> b) -> String -> b
forall a b. (a -> b) -> a -> b
$
    SrcSpan -> String
showSrcSpan (SrcSpanAnnA -> SrcSpan
forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
pos) String -> String -> String
forall a. [a] -> [a] -> [a]
++
    String
": Error while reading hint file, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
    a -> String
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 = String -> b
forall a. String -> a
exitMessageImpure (String -> b) -> String -> b
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) Maybe BufSpan
forall a. Maybe a
GHC.Data.Strict.Nothing) String -> String -> String
forall a. [a] -> [a] -> [a]
++
    String
": Error while reading hint file, " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
    (if Bool
isMultiline then String
"{-" else String
"--") String -> String -> String
forall a. [a] -> [a] -> [a]
++ LEpaComment -> String
commentText LEpaComment
c String -> String -> String
forall a. [a] -> [a] -> [a]
++ (if Bool
isMultiline then String
"-}" else String
"")