{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
-- |
--
-- Utility for formatting @'Idea'@ data in accordance with the Code Climate
-- spec: <https://github.com/codeclimate/spec>
--
module CC
    ( printIssue
    , fromIdea
    ) where

import Data.Aeson (ToJSON(..), (.=), encode, object)
import Data.Char (toUpper)
import Data.Text (Text)

import Data.Text qualified as T
import Data.ByteString.Lazy.Char8 qualified as C8

import Idea (Idea(..), Severity(..))

import GHC.Types.SrcLoc qualified as GHC
import GHC.Util qualified as GHC

data Issue = Issue
    { Issue -> Text
issueType :: Text
    , Issue -> Text
issueCheckName :: Text
    , Issue -> Text
issueDescription :: Text
    , Issue -> Text
issueContent :: Text
    , Issue -> [Text]
issueCategories :: [Text]
    , Issue -> Location
issueLocation :: Location
    , Issue -> Int
issueRemediationPoints :: Int
    }

data Location = Location FilePath Position Position
data Position = Position Int Int

instance ToJSON Issue where
    toJSON :: Issue -> Value
toJSON Issue{Int
[Text]
Text
Location
issueType :: Issue -> Text
issueCheckName :: Issue -> Text
issueDescription :: Issue -> Text
issueContent :: Issue -> Text
issueCategories :: Issue -> [Text]
issueLocation :: Issue -> Location
issueRemediationPoints :: Issue -> Int
issueType :: Text
issueCheckName :: Text
issueDescription :: Text
issueContent :: Text
issueCategories :: [Text]
issueLocation :: Location
issueRemediationPoints :: Int
..} = [Pair] -> Value
object
        [ Key
"type" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
issueType
        , Key
"check_name" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
issueCheckName
        , Key
"description" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
issueDescription
        , Key
"content" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object
            [ Key
"body" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Text
issueContent
            ]
        , Key
"categories" Key -> [Text] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Text]
issueCategories
        , Key
"location" Key -> Location -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Location
issueLocation
        , Key
"remediation_points" Key -> Int -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Int
issueRemediationPoints
        ]

instance ToJSON Location where
    toJSON :: Location -> Value
toJSON (Location String
path Position
begin Position
end) = [Pair] -> Value
object
        [ Key
"path" Key -> String -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= String
path
        , Key
"positions" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object
            [ Key
"begin" Key -> Position -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Position
begin
            , Key
"end" Key -> Position -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Position
end
            ]
        ]

instance ToJSON Position where
    toJSON :: Position -> Value
toJSON (Position Int
line Int
column) = [Pair] -> Value
object
        [ Key
"line" Key -> Int -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Int
line
        , Key
"column" Key -> Int -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Int
column
        ]

-- | Print an @'Issue'@ with trailing null-terminator and newline
--
-- The trailing newline will be ignored, but makes the output more readable
--
printIssue :: Issue -> IO ()
printIssue :: Issue -> IO ()
printIssue = ByteString -> IO ()
C8.putStrLn (ByteString -> IO ()) -> (Issue -> ByteString) -> Issue -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"\0") (ByteString -> ByteString)
-> (Issue -> ByteString) -> Issue -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Issue -> ByteString
forall a. ToJSON a => a -> ByteString
encode

-- | Convert an hlint @'Idea'@ to a datatype more easily serialized for CC
fromIdea :: Idea -> Issue
fromIdea :: Idea -> Issue
fromIdea Idea{String
[String]
[Refactoring SrcSpan]
[Note]
Maybe String
SrcSpan
Severity
ideaModule :: [String]
ideaDecl :: [String]
ideaSeverity :: Severity
ideaHint :: String
ideaSpan :: SrcSpan
ideaFrom :: String
ideaTo :: Maybe String
ideaNote :: [Note]
ideaRefactoring :: [Refactoring SrcSpan]
ideaDecl :: Idea -> [String]
ideaFrom :: Idea -> String
ideaHint :: Idea -> String
ideaModule :: Idea -> [String]
ideaNote :: Idea -> [Note]
ideaRefactoring :: Idea -> [Refactoring SrcSpan]
ideaSeverity :: Idea -> Severity
ideaSpan :: Idea -> SrcSpan
ideaTo :: Idea -> Maybe String
..} = Issue
    { issueType :: Text
issueType = Text
"issue"
    , issueCheckName :: Text
issueCheckName = Text
"HLint/" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (String -> String
camelize String
ideaHint)
    , issueDescription :: Text
issueDescription = String -> Text
T.pack String
ideaHint
    , issueContent :: Text
issueContent = String -> Maybe String -> Text
content String
ideaFrom Maybe String
ideaTo Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Note] -> Text
forall {a}. Show a => [a] -> Text
listNotes [Note]
ideaNote
    , issueCategories :: [Text]
issueCategories = String -> [Text]
forall {a} {p}. IsString a => p -> [a]
categories String
ideaHint
    , issueLocation :: Location
issueLocation = SrcSpan -> Location
fromSrcSpan SrcSpan
ideaSpan
    , issueRemediationPoints :: Int
issueRemediationPoints = Severity -> Int
points Severity
ideaSeverity
    }

  where
    content :: String -> Maybe String -> Text
content String
from Maybe String
Nothing = [Text] -> Text
T.unlines
        [ Text
"Found"
        , Text
""
        , Text
"```"
        , String -> Text
T.pack String
from
        , Text
"```"
        , Text
""
        , Text
"remove it."
        ]

    content String
from (Just String
to) = [Text] -> Text
T.unlines
        [ Text
"Found"
        , Text
""
        , Text
"```"
        , String -> Text
T.pack String
from
        , Text
"```"
        , Text
""
        , Text
"Perhaps"
        , Text
""
        , Text
"```"
        , String -> Text
T.pack String
to
        , Text
"```"
        ]

    listNotes :: [a] -> Text
listNotes [] = Text
""
    listNotes [a]
notes = [Text] -> Text
T.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
        [ Text
""
        , Text
"Applying this change:"
        , Text
""
        ] [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ (a -> Text) -> [a] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map ((Text
"* " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) (Text -> Text) -> (a -> Text) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text) -> (a -> String) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Show a => a -> String
show) [a]
notes

    categories :: p -> [a]
categories p
_ = [a
"Style"]

    points :: Severity -> Int
points Severity
Ignore = Int
0
    points Severity
Suggestion = Int
basePoints
    points Severity
Warning = Int
5 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
basePoints
    points Severity
Error = Int
10 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
basePoints

fromSrcSpan :: GHC.SrcSpan -> Location
fromSrcSpan :: SrcSpan -> Location
fromSrcSpan GHC.SrcSpan{Int
String
srcSpanFilename :: String
srcSpanStartLine' :: Int
srcSpanStartColumn :: Int
srcSpanEndLine' :: Int
srcSpanEndColumn :: Int
srcSpanEndColumn :: SrcSpan -> Int
srcSpanEndLine' :: SrcSpan -> Int
srcSpanFilename :: SrcSpan -> String
srcSpanStartColumn :: SrcSpan -> Int
srcSpanStartLine' :: SrcSpan -> Int
..} = String -> Position -> Position -> Location
Location
    (String -> String
locationFileName String
srcSpanFilename)
    (Int -> Int -> Position
Position Int
srcSpanStartLine' Int
srcSpanStartColumn)
    (Int -> Int -> Position
Position Int
srcSpanEndLine' Int
srcSpanEndColumn)
  where
    locationFileName :: String -> String
locationFileName (Char
'.':Char
'/':String
x) = String
x
    locationFileName String
x = String
x

camelize :: String -> String
camelize :: String -> String
camelize = (String -> String) -> [String] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap String -> String
capitalize ([String] -> String) -> (String -> [String]) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
words

capitalize :: String -> String
capitalize :: String -> String
capitalize [] = []
capitalize (Char
c:String
rest) = Char -> Char
toUpper Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: String
rest

-- "The baseline remediation points value is 50,000, which is the time it takes
-- to fix a trivial code style issue like a missing semicolon on a single line,
-- including the time for the developer to open the code, make the change, and
-- confidently commit the fix. All other remediation points values are expressed
-- in multiples of that Basic Remediation Point Value."
basePoints :: Int
basePoints :: Int
basePoints = Int
50000