{-# 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 SrcLoc
import GHC.Hs.Extension
import GHC.Hs.Decls hiding (SpliceDecl)
import GHC.Hs.Expr hiding (Match)
import GHC.Hs.Lit
import FastString
import ApiAnnotation
import Outputable

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
_ SourceText
_ AnnProvenance (IdP GhcPs)
provenance Located (HsExpr GhcPs)
expr) = Located (HsExpr GhcPs) -> Maybe Classify
forall p. LHsExpr p -> Maybe Classify
f Located (HsExpr GhcPs)
expr
    where
        name :: String
name = case AnnProvenance (IdP GhcPs)
provenance of
            ValueAnnProvenance (L SrcSpan
_ IdP GhcPs
x) -> RdrName -> String
occNameStr IdP GhcPs
RdrName
x
            TypeAnnProvenance (L SrcSpan
_ IdP GhcPs
x) -> RdrName -> String
occNameStr IdP GhcPs
RdrName
x
            AnnProvenance (IdP GhcPs)
ModuleAnnProvenance -> String
""

        f :: LHsExpr p -> Maybe Classify
f (L SrcSpan
_ (HsLit XLitE p
_ (HsString XHsString p
_ (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 -> Located (HsExpr GhcPs) -> String -> Maybe Classify
forall a b. Outputable a => Located a -> String -> b
errorOn Located (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 SrcSpan
_ (HsPar XPar p
_ LHsExpr p
x)) = LHsExpr p -> Maybe Classify
f LHsExpr p
x
        f (L SrcSpan
_ (ExprWithTySig XExprWithTySig p
_ LHsExpr p
x LHsSigWcType (NoGhcTc p)
_)) = LHsExpr p -> Maybe Classify
f LHsExpr p
x
        f LHsExpr p
_ = Maybe Classify
forall a. Maybe a
Nothing
readPragma AnnDecl GhcPs
_ = Maybe Classify
forall a. Maybe a
Nothing

readComment :: Located AnnotationComment -> [Classify]
readComment :: Located AnnotationComment -> [Classify]
readComment c :: Located AnnotationComment
c@(L SrcSpan
pos AnnBlockComment{})
    | (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 = Located AnnotationComment -> String
commentText Located AnnotationComment
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 (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
things] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String]
things
        f Bool
hash String
_ = Located AnnotationComment -> String -> [Classify]
forall b. Located AnnotationComment -> String -> b
errorOnComment Located AnnotationComment
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 Located AnnotationComment
_ = []


errorOn :: Outputable a => Located a -> String -> b
errorOn :: Located a -> String -> b
errorOn (L SrcSpan
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 SrcSpan
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 :: Located AnnotationComment -> String -> b
errorOnComment :: Located AnnotationComment -> String -> b
errorOnComment c :: Located AnnotationComment
c@(L SrcSpan
s AnnotationComment
_) String
msg = String -> b
forall a. String -> a
exitMessageImpure (String -> b) -> String -> b
forall a b. (a -> b) -> a -> b
$
    let isMultiline :: Bool
isMultiline = Located AnnotationComment -> Bool
isCommentMultiline Located AnnotationComment
c in
    SrcSpan -> String
showSrcSpan SrcSpan
s 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]
++ Located AnnotationComment -> String
commentText Located AnnotationComment
c String -> String -> String
forall a. [a] -> [a] -> [a]
++ (if Bool
isMultiline then String
"-}" else String
"")