module Stan.Observation
( Observation (..)
, Observations
, mkObservation
, mkObservationId
, ignoredObservations
, prettyShowObservation
, prettyShowIgnoredObservations
, prettyObservationSource
) where
import Colourista (blue, bold, formatWith, green, italic, reset, yellow)
import Colourista.Short (b, i)
import Data.Aeson.Micro (ToJSON (..), object, (.=))
import Data.List (partition)
import Slist (Slist)
import Stan.Category (prettyShowCategory)
import Stan.Core.Id (Id (..))
import Stan.Core.ModuleName (ModuleName (..), fromGhcModule)
import Stan.Ghc.Compat (RealSrcSpan, srcSpanEndCol, srcSpanEndLine, srcSpanFile, srcSpanStartCol,
srcSpanStartLine)
import Stan.Hie.Compat (HieFile (..))
import Stan.Inspection (Inspection (..))
import Stan.Inspection.All (getInspectionById)
import Stan.Report.Settings (OutputSettings (..), Verbosity (..), isHidden)
import Stan.Severity (prettyShowSeverity, severityColour)
import qualified Crypto.Hash.SHA1 as SHA1
import qualified Data.ByteString.Base64 as Base64
import qualified Data.ByteString.Char8 as BS
import qualified Data.HashSet as HS
import qualified Data.List.NonEmpty as NE
import qualified Data.Text as Text
import qualified Slist as S
data Observation = Observation
{ Observation -> Id Observation
observationId :: !(Id Observation)
, Observation -> Id Inspection
observationInspectionId :: !(Id Inspection)
, Observation -> RealSrcSpan
observationSrcSpan :: !RealSrcSpan
, Observation -> FilePath
observationFile :: !FilePath
, Observation -> ModuleName
observationModuleName :: !ModuleName
, Observation -> ByteString
observationFileContent :: !ByteString
} deriving stock (Int -> Observation -> ShowS
[Observation] -> ShowS
Observation -> FilePath
(Int -> Observation -> ShowS)
-> (Observation -> FilePath)
-> ([Observation] -> ShowS)
-> Show Observation
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Observation] -> ShowS
$cshowList :: [Observation] -> ShowS
show :: Observation -> FilePath
$cshow :: Observation -> FilePath
showsPrec :: Int -> Observation -> ShowS
$cshowsPrec :: Int -> Observation -> ShowS
Show, Observation -> Observation -> Bool
(Observation -> Observation -> Bool)
-> (Observation -> Observation -> Bool) -> Eq Observation
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Observation -> Observation -> Bool
$c/= :: Observation -> Observation -> Bool
== :: Observation -> Observation -> Bool
$c== :: Observation -> Observation -> Bool
Eq)
instance ToJSON Observation where
toJSON :: Observation -> Value
toJSON Observation{..} = [Pair] -> Value
object
[ "id" Text -> Id Observation -> Pair
forall v. ToJSON v => Text -> v -> Pair
.= Id Observation
observationId
, "inspectionId" Text -> Id Inspection -> Pair
forall v. ToJSON v => Text -> v -> Pair
.= Id Inspection
observationInspectionId
, "srcSpan" Text -> Text -> Pair
forall v. ToJSON v => Text -> v -> Pair
.= RealSrcSpan -> Text
showSpan RealSrcSpan
observationSrcSpan
, "startLine" Text -> Int -> Pair
forall v. ToJSON v => Text -> v -> Pair
.= RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
observationSrcSpan
, "startCol" Text -> Int -> Pair
forall v. ToJSON v => Text -> v -> Pair
.= RealSrcSpan -> Int
srcSpanStartCol RealSrcSpan
observationSrcSpan
, "endLine" Text -> Int -> Pair
forall v. ToJSON v => Text -> v -> Pair
.= RealSrcSpan -> Int
srcSpanEndLine RealSrcSpan
observationSrcSpan
, "endCol" Text -> Int -> Pair
forall v. ToJSON v => Text -> v -> Pair
.= RealSrcSpan -> Int
srcSpanEndCol RealSrcSpan
observationSrcSpan
, "file" Text -> Text -> Pair
forall v. ToJSON v => Text -> v -> Pair
.= FilePath -> Text
forall a. ToText a => a -> Text
toText FilePath
observationFile
, "moduleName" Text -> ModuleName -> Pair
forall v. ToJSON v => Text -> v -> Pair
.= ModuleName
observationModuleName
]
type Observations = Slist Observation
mkObservation
:: Id Inspection
-> HieFile
-> RealSrcSpan
-> Observation
mkObservation :: Id Inspection -> HieFile -> RealSrcSpan -> Observation
mkObservation insId :: Id Inspection
insId HieFile{..} srcSpan :: RealSrcSpan
srcSpan = $WObservation :: Id Observation
-> Id Inspection
-> RealSrcSpan
-> FilePath
-> ModuleName
-> ByteString
-> Observation
Observation
{ observationId :: Id Observation
observationId = Id Inspection -> ModuleName -> RealSrcSpan -> Id Observation
mkObservationId Id Inspection
insId ModuleName
moduleName RealSrcSpan
srcSpan
, observationInspectionId :: Id Inspection
observationInspectionId = Id Inspection
insId
, observationSrcSpan :: RealSrcSpan
observationSrcSpan = RealSrcSpan
srcSpan
, observationFile :: FilePath
observationFile = FilePath
hie_hs_file
, observationModuleName :: ModuleName
observationModuleName = ModuleName
moduleName
, observationFileContent :: ByteString
observationFileContent = ByteString
hie_hs_src
}
where
moduleName :: ModuleName
moduleName :: ModuleName
moduleName = Module -> ModuleName
fromGhcModule Module
hie_module
prettyShowObservation :: OutputSettings -> Observation -> Text
prettyShowObservation :: OutputSettings -> Observation -> Text
prettyShowObservation OutputSettings{..} o :: Observation
o@Observation{..} = case Verbosity
outputSettingsVerbosity of
NonVerbose -> Text
simpleShowObservation
Verbose -> [Text] -> Text
forall t. IsText t "unlines" => [t] -> t
unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (" ┃ " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>)
([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ [Text]
observationTable
[Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> ("" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: Bool -> Observation -> [Text]
prettyObservationSource Bool
True Observation
o)
[Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> ("" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
solution)
where
simpleShowObservation :: Text
simpleShowObservation :: Text
simpleShowObservation =
" ✦ "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall str. (IsString str, Semigroup str) => str -> str
b (Id Observation -> Text
forall a. Id a -> Text
unId Id Observation
observationId)
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>" [" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
sev Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "] "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall str. (IsString str, Semigroup str) => str -> str
i (RealSrcSpan -> Text
showSpan RealSrcSpan
observationSrcSpan)
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " — "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Inspection -> Text
inspectionName Inspection
inspection
observationTable :: [Text]
observationTable :: [Text]
observationTable =
[ Text -> Text
element "ID: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall str. (IsString str, Semigroup str) => str -> str
b (Id Observation -> Text
forall a. Id a -> Text
unId Id Observation
observationId)
, Text -> Text
element "Severity: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
sev
, Text -> Text
element "Inspection ID: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Id Inspection -> Text
forall a. Id a -> Text
unId Id Inspection
observationInspectionId
, Text -> Text
element "Name: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Inspection -> Text
inspectionName Inspection
inspection
, Text -> Text
element "Description: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Inspection -> Text
inspectionDescription Inspection
inspection
, Text -> Text
element "Category: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
categories
, Text -> Text
element "File: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
forall a. ToText a => a -> Text
toText FilePath
observationFile
]
where
element :: Text -> Text
element :: Text -> Text
element = [Text] -> Text -> Text
forall str. (IsString str, Semigroup str) => [str] -> str -> str
formatWith [Text
forall str. IsString str => str
italic] (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ("✦ " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>)
sev :: Text
sev :: Text
sev = Severity -> Text
prettyShowSeverity (Inspection -> Severity
inspectionSeverity Inspection
inspection)
inspection :: Inspection
inspection :: Inspection
inspection = Id Inspection -> Inspection
getInspectionById Id Inspection
observationInspectionId
categories :: Text
categories :: Text
categories = Text -> [Text] -> Text
Text.intercalate " "
([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Category -> Text) -> [Category] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Category -> Text
prettyShowCategory ([Category] -> [Text]) -> [Category] -> [Text]
forall a b. (a -> b) -> a -> b
$ NonEmpty Category -> [Category]
forall a. NonEmpty a -> [a]
NE.toList (NonEmpty Category -> [Category])
-> NonEmpty Category -> [Category]
forall a b. (a -> b) -> a -> b
$ Inspection -> NonEmpty Category
inspectionCategory Inspection
inspection
solution :: [Text]
solution :: [Text]
solution
| ToggleSolution -> Bool
isHidden ToggleSolution
outputSettingsSolutionVerbosity Bool -> Bool -> Bool
|| [Text] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
sols = []
| Bool
otherwise = "💡 " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text -> Text
forall str. (IsString str, Semigroup str) => [str] -> str -> str
formatWith [Text
forall str. IsString str => str
italic, Text
forall str. IsString str => str
green] "Possible solution:" Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:
(Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (" ⍟ " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) [Text]
sols
where
sols :: [Text]
sols :: [Text]
sols = Inspection -> [Text]
inspectionSolution Inspection
inspection
prettyObservationSource
:: Bool
-> Observation
-> [Text]
prettyObservationSource :: Bool -> Observation -> [Text]
prettyObservationSource isColour :: Bool
isColour Observation{..} =
Int -> Text
alignLine (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1)
Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: (Int -> Text) -> [Int] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (\x :: Int
x -> Int -> Text
alignLine Int
x Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
getSourceLine Int
x) [Int
n .. Int
endL]
[Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Int -> Text
alignLine (Int
endL Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
arrows]
where
n, endL :: Int
n :: Int
n = RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
observationSrcSpan
endL :: Int
endL = RealSrcSpan -> Int
srcSpanEndLine RealSrcSpan
observationSrcSpan
alignLine :: Int -> Text
alignLine :: Int -> Text
alignLine x :: Int
x = Int -> Char -> Text -> Text
Text.justifyRight 4 ' ' (Int -> Text
forall b a. (Show a, IsString b) => a -> b
show Int
x) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> " ┃ "
getSourceLine :: Int -> Text
getSourceLine :: Int -> Text
getSourceLine x :: Int
x = Text -> (ByteString -> Text) -> Maybe ByteString -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
"<UNAVAILABLE> Open the issue in the tool that created the HIE files for you."
ByteString -> Text
forall a b. ConvertUtf8 a b => b -> a
decodeUtf8
(ByteString -> [ByteString]
BS.lines ByteString
observationFileContent [ByteString] -> Int -> Maybe ByteString
forall a. [a] -> Int -> Maybe a
!!? (Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1))
arrows :: Text
arrows :: Text
arrows = Bool -> Text -> Text
whenColour Bool
isColour (Severity -> Text
severityColour (Severity -> Text) -> Severity -> Text
forall a b. (a -> b) -> a -> b
$ Inspection -> Severity
inspectionSeverity (Inspection -> Severity) -> Inspection -> Severity
forall a b. (a -> b) -> a -> b
$ Id Inspection -> Inspection
getInspectionById Id Inspection
observationInspectionId)
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
Text.replicate Int
start " "
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
Text.replicate Int
arrow "^"
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Bool -> Text -> Text
whenColour Bool
isColour Text
forall str. IsString str => str
reset
where
start :: Int
start = RealSrcSpan -> Int
srcSpanStartCol RealSrcSpan
observationSrcSpan Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1
arrow :: Int
arrow = RealSrcSpan -> Int
srcSpanEndCol RealSrcSpan
observationSrcSpan Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
start Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1
showSpan :: RealSrcSpan -> Text
showSpan :: RealSrcSpan -> Text
showSpan s :: RealSrcSpan
s = FastString -> Text
forall b a. (Show a, IsString b) => a -> b
show (RealSrcSpan -> FastString
srcSpanFile RealSrcSpan
s)
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "(" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall b a. (Show a, IsString b) => a -> b
show (RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
s)
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall b a. (Show a, IsString b) => a -> b
show (RealSrcSpan -> Int
srcSpanStartCol RealSrcSpan
s)
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> "-" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall b a. (Show a, IsString b) => a -> b
show (RealSrcSpan -> Int
srcSpanEndLine RealSrcSpan
s)
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall b a. (Show a, IsString b) => a -> b
show (RealSrcSpan -> Int
srcSpanEndCol RealSrcSpan
s)
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ")"
whenColour :: Bool -> Text -> Text
whenColour :: Bool -> Text -> Text
whenColour = Bool -> Text -> Text
forall m. Monoid m => Bool -> m -> m
memptyIfFalse
ignoredObservations
:: [Id Observation]
-> Observations
-> ([Id Observation], [Id Observation])
ignoredObservations :: [Id Observation]
-> Observations -> ([Id Observation], [Id Observation])
ignoredObservations ids :: [Id Observation]
ids obs :: Observations
obs = ([Id Observation]
ignoredIds, [Id Observation]
unknownIds)
where
obsIds :: HashSet (Id Observation)
obsIds :: HashSet (Id Observation)
obsIds = [Item (HashSet (Id Observation))] -> HashSet (Id Observation)
forall l. IsList l => [Item l] -> l
fromList ([Item (HashSet (Id Observation))] -> HashSet (Id Observation))
-> [Item (HashSet (Id Observation))] -> HashSet (Id Observation)
forall a b. (a -> b) -> a -> b
$ Slist (Id Observation) -> [Item (HashSet (Id Observation))]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Slist (Id Observation) -> [Item (HashSet (Id Observation))])
-> Slist (Id Observation) -> [Item (HashSet (Id Observation))]
forall a b. (a -> b) -> a -> b
$ (Observation -> Id Observation)
-> Observations -> Slist (Id Observation)
forall a b. (a -> b) -> Slist a -> Slist b
S.map Observation -> Id Observation
observationId Observations
obs
ignoredIds, unknownIds :: [Id Observation]
(ignoredIds :: [Id Observation]
ignoredIds, unknownIds :: [Id Observation]
unknownIds) = (Id Observation -> Bool)
-> [Id Observation] -> ([Id Observation], [Id Observation])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (Id Observation -> HashSet (Id Observation) -> Bool
forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
`HS.member` HashSet (Id Observation)
obsIds) [Id Observation]
ids
prettyShowIgnoredObservations :: [Id Observation] -> Observations -> Text
prettyShowIgnoredObservations :: [Id Observation] -> Observations -> Text
prettyShowIgnoredObservations [] _ = ""
prettyShowIgnoredObservations ids :: [Id Observation]
ids obs :: Observations
obs = Text
ignored Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
unknown
where
ignored :: Text
ignored :: Text
ignored =
if [Id Observation] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id Observation]
ignoredIds
then ""
else [Text] -> Text -> Text
forall str. (IsString str, Semigroup str) => [str] -> str -> str
formatWith [Text
forall str. IsString str => str
bold, Text
forall str. IsString str => str
blue] "Ignored Observation IDs:\n"
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Id Observation] -> Text
showIds [Id Observation]
ignoredIds
unknown :: Text
unknown :: Text
unknown =
if [Id Observation] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id Observation]
unknownIds
then ""
else [Text] -> Text -> Text
forall str. (IsString str, Semigroup str) => [str] -> str -> str
formatWith [Text
forall str. IsString str => str
bold, Text
forall str. IsString str => str
yellow] "Unrecognised Observation IDs:\n"
Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Id Observation] -> Text
showIds [Id Observation]
unknownIds
showIds :: [Id Observation] -> Text
showIds :: [Id Observation] -> Text
showIds = [Text] -> Text
forall t. IsText t "unlines" => [t] -> t
unlines ([Text] -> Text)
-> ([Id Observation] -> [Text]) -> [Id Observation] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Id Observation -> Text) -> [Id Observation] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
(<>) " - " (Text -> Text)
-> (Id Observation -> Text) -> Id Observation -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id Observation -> Text
forall a. Id a -> Text
unId)
ignoredIds, unknownIds :: [Id Observation]
(ignoredIds :: [Id Observation]
ignoredIds, unknownIds :: [Id Observation]
unknownIds) = [Id Observation]
-> Observations -> ([Id Observation], [Id Observation])
ignoredObservations [Id Observation]
ids Observations
obs
mkObservationId :: Id Inspection -> ModuleName -> RealSrcSpan -> Id Observation
mkObservationId :: Id Inspection -> ModuleName -> RealSrcSpan -> Id Observation
mkObservationId insId :: Id Inspection
insId moduleName :: ModuleName
moduleName srcSpan :: RealSrcSpan
srcSpan = Text -> Id Observation
forall a. Text -> Id a
Id (Text -> Id Observation) -> Text -> Id Observation
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
Text.intercalate "-"
[ "OBS"
, Id Inspection -> Text
forall a. Id a -> Text
unId Id Inspection
insId
, ModuleName -> Text
hashModuleName ModuleName
moduleName
, Int -> Text
forall b a. (Show a, IsString b) => a -> b
show (RealSrcSpan -> Int
srcSpanStartLine RealSrcSpan
srcSpan) Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall b a. (Show a, IsString b) => a -> b
show (RealSrcSpan -> Int
srcSpanStartCol RealSrcSpan
srcSpan)
]
hashModuleName :: ModuleName -> Text
hashModuleName :: ModuleName -> Text
hashModuleName =
Int -> Text -> Text
Text.take 6
(Text -> Text) -> (ModuleName -> Text) -> ModuleName -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
Base64.encodeBase64
(ByteString -> Text)
-> (ModuleName -> ByteString) -> ModuleName -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
SHA1.hash
(ByteString -> ByteString)
-> (ModuleName -> ByteString) -> ModuleName -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8
(Text -> ByteString)
-> (ModuleName -> Text) -> ModuleName -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> Text
unModuleName