diff --git a/semantic.cabal b/semantic.cabal index 6ae70d2fc..2bb1ebe4e 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -132,6 +132,7 @@ library , Data.Duration , Data.Error , Data.File + , Data.Flag , Data.Functor.Both , Data.Functor.Classes.Generic , Proto3.Google.Timestamp diff --git a/src/Analysis/TOCSummary.hs b/src/Analysis/TOCSummary.hs index 44f761085..8cd658f36 100644 --- a/src/Analysis/TOCSummary.hs +++ b/src/Analysis/TOCSummary.hs @@ -10,7 +10,8 @@ import Prologue hiding (project) import Control.Arrow import Control.Rewriting import Data.Blob -import Data.Error (Error (..), showExpectation) +import Data.Error (Error (..), Colourize (..), showExpectation) +import Data.Flag import Data.Language as Language import Data.Location import Data.Range @@ -86,7 +87,7 @@ instance CustomHasDeclaration whole Markdown.Heading where instance CustomHasDeclaration whole Syntax.Error where customToDeclaration Blob{..} ann err@Syntax.Error{} = Just $ ErrorDeclaration (T.pack (formatTOCError (Syntax.unError (locationSpan ann) err))) mempty (locationSpan ann) blobLanguage - where formatTOCError e = showExpectation False (errorExpected e) (errorActual e) "" + where formatTOCError e = showExpectation (flag Colourize False) (errorExpected e) (errorActual e) "" -- | Produce a 'FunctionDeclaration' for 'Declaration.Function' nodes so long as their identifier is non-empty (defined as having a non-empty 'Range'). instance CustomHasDeclaration whole Declaration.Function where diff --git a/src/Data/Error.hs b/src/Data/Error.hs index 30070f262..1995ef778 100644 --- a/src/Data/Error.hs +++ b/src/Data/Error.hs @@ -6,6 +6,9 @@ module Data.Error , showExpectation , showExcerpt , withSGRCode + -- * Flags affecting 'Error' values + , LogPrintSource (..) + , Colourize (..) ) where import Prologue @@ -16,9 +19,13 @@ import Data.List (intersperse, isSuffixOf) import System.Console.ANSI import Data.Blob +import Data.Flag as Flag import Data.Source import Data.Span +data LogPrintSource = LogPrintSource +data Colourize = Colourize + -- | Rather than using the Error constructor directly, you probably -- want to call 'makeError', which takes care of inserting the call -- stack for you. @@ -38,21 +45,18 @@ instance Exception (Error String) makeError :: HasCallStack => Span -> [grammar] -> Maybe grammar -> Error grammar makeError s e a = withFrozenCallStack (Error s e a callStack) -type IncludeSource = Bool -type Colourize = Bool - -- | Format an 'Error', optionally with reference to the source where it occurred. -formatError :: IncludeSource -> Colourize -> Blob -> Error String -> String +formatError :: Flag LogPrintSource -> Flag Colourize -> Blob -> Error String -> String formatError includeSource colourize blob@Blob{..} Error{..} = ($ "") $ withSGRCode colourize [SetConsoleIntensity BoldIntensity] (showSpan path errorSpan . showString ": ") . withSGRCode colourize [SetColor Foreground Vivid Red] (showString "error") . showString ": " . showExpectation colourize errorExpected errorActual . showChar '\n' - . (if includeSource then showExcerpt colourize errorSpan blob else id) + . (if Flag.toBool LogPrintSource includeSource then showExcerpt colourize errorSpan blob else id) . showCallStack colourize callStack . showChar '\n' where - path = Just $ if includeSource then blobPath else "" + path = Just $ if Flag.toBool LogPrintSource includeSource then blobPath else "" -showExcerpt :: Colourize -> Span -> Blob -> ShowS +showExcerpt :: Flag Colourize -> Span -> Blob -> ShowS showExcerpt colourize Span{..} Blob{..} = showString context . (if "\n" `isSuffixOf` context then id else showChar '\n') . showString (replicate (caretPaddingWidth + lineNumberDigits) ' ') . withSGRCode colourize [SetColor Foreground Vivid Green] (showString caret) . showChar '\n' @@ -67,23 +71,19 @@ showExcerpt colourize Span{..} Blob{..} caret | posLine spanStart == posLine spanEnd = replicate (max 1 (posColumn spanEnd - posColumn spanStart)) '^' | otherwise = "^..." -withSGRCode :: Colourize -> [SGR] -> ShowS -> ShowS -withSGRCode useColour code content = - if useColour then - showString (setSGRCode code) - . content - . showString (setSGRCode []) - else - content +withSGRCode :: Flag Colourize -> [SGR] -> ShowS -> ShowS +withSGRCode useColour code content + | Flag.toBool Colourize useColour = showString (setSGRCode code) . content . showString (setSGRCode []) + | otherwise = content -showExpectation :: Colourize -> [String] -> Maybe String -> ShowS +showExpectation :: Flag Colourize -> [String] -> Maybe String -> ShowS showExpectation colourize = go where go [] Nothing = showString "no rule to match at " . showActual "end of branch" go expected Nothing = showString "expected " . showSymbols colourize expected . showString " at " . showActual "end of branch" go expected (Just actual) = showString "expected " . showSymbols colourize expected . showString ", but got " . showActual actual showActual = withSGRCode colourize [SetColor Foreground Vivid Green] . showString -showSymbols :: Colourize -> [String] -> ShowS +showSymbols :: Flag Colourize -> [String] -> ShowS showSymbols colourize = go where go [] = showString "end of input nodes" go [symbol] = showSymbol symbol @@ -96,8 +96,8 @@ showSpan :: Maybe FilePath -> Span -> ShowS showSpan path Span{..} = maybe (showParen True (showString "interactive")) showString path . showChar ':' . (if spanStart == spanEnd then showPos spanStart else showPos spanStart . showChar '-' . showPos spanEnd) where showPos Pos{..} = shows posLine . showChar ':' . shows posColumn -showCallStack :: Colourize -> CallStack -> ShowS +showCallStack :: Flag Colourize -> CallStack -> ShowS showCallStack colourize callStack = foldr (.) id (intersperse (showChar '\n') (uncurry (showCallSite colourize) <$> getCallStack callStack)) -showCallSite :: Colourize -> String -> SrcLoc -> ShowS +showCallSite :: Flag Colourize -> String -> SrcLoc -> ShowS showCallSite colourize symbol loc@SrcLoc{..} = showString symbol . showChar ' ' . withSGRCode colourize [SetConsoleIntensity BoldIntensity] (showParen True (showSpan (Just srcLocFile) (spanFromSrcLoc loc))) diff --git a/src/Data/Flag.hs b/src/Data/Flag.hs new file mode 100644 index 000000000..e74a5a00b --- /dev/null +++ b/src/Data/Flag.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE RankNTypes, KindSignatures #-} + +-- | -- This technique is due to Oleg Grenrus: +-- The implementation is clean-room due to unclear licensing of the original post. +module Data.Flag + ( Flag + , flag + , toBool + , switch + , choose + ) where + +import Data.Coerce + +-- | To declare a new flag, declare a singly-inhabited type: +-- @data MyFlag = MyFlag@ +-- then use the @flag MyFlag@ to create one from a 'Bool'. +-- This is more verbose than using 'Bool' for everything but prevents classes of errors when +-- working with multiple flag values in flight, as the 'toBool' deconstructor provides a witness +-- that you really want the given semantic flag value from the flag datum. +newtype Flag (t :: *) = Flag Bool + +-- | The constructor for a 'Flag'. You specify @t@ with a visible type application. +flag :: t -> Bool -> Flag t +flag _ = Flag +{-# INLINE flag #-} + +-- | The destructor for a 'Flag'. You pass in the inhabitant of @t@ to +-- avoid boolean blindness. +toBool :: t -> Flag t -> Bool +toBool _ = coerce +{-# INLINE toBool #-} + +switch :: a -> b -> Flag a -> Flag b +switch _ _ = coerce + +-- | Case analysis, like 'bool'. +choose :: t -- ^ Witness + -> a -- ^ False case + -> a -- ^ True case + -> Flag t + -> a +choose _ f t flag = if coerce flag then t else f +{-# INLINE choose #-} diff --git a/src/Semantic/CLI.hs b/src/Semantic/CLI.hs index 95ffef027..52a97b8a0 100644 --- a/src/Semantic/CLI.hs +++ b/src/Semantic/CLI.hs @@ -9,6 +9,7 @@ import Data.List (intercalate, uncons) import Data.List.Split (splitWhen) import Data.Project import qualified Data.Text as T +import qualified Data.Flag as Flag import Options.Applicative hiding (style) import Prologue import Semantic.Api hiding (File) @@ -48,7 +49,7 @@ optionsParser = do (long "log-level" <> value (Just Log.Warning) <> help "Log messages at or above this level, or disable logging entirely.") failOnWarning <- switch (long "fail-on-warning" <> help "Fail on assignment warnings.") failOnParseError <- switch (long "fail-on-parse-error" <> help "Fail on tree-sitter parse errors.") - pure $ Options logLevel failOnWarning failOnParseError + pure $ Options logLevel (Flag.flag FailOnWarning failOnWarning) (Flag.flag FailOnParseError failOnParseError) argumentsParser :: Parser (Task.TaskEff ()) argumentsParser = do diff --git a/src/Semantic/Config.hs b/src/Semantic/Config.hs index b9c8281e0..454a55b2e 100644 --- a/src/Semantic/Config.hs +++ b/src/Semantic/Config.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE LambdaCase #-} - module Semantic.Config ( Config (..) , defaultConfig @@ -13,9 +11,17 @@ module Semantic.Config , withLoggerFromConfig , withStatterFromConfig , withTelemetry + -- * Flags + , IsTerminal (..) + , LogPrintSource (..) + , FailTestParsing (..) + , FailOnWarning (..) + , FailOnParseError (..) ) where import Data.Duration +import Data.Error (LogPrintSource(..)) +import Data.Flag import Network.HostName import Network.HTTP.Client.TLS import Network.URI @@ -29,43 +35,46 @@ import System.IO (hIsTerminalDevice, stdout) import System.Posix.Process import System.Posix.Types +data IsTerminal = IsTerminal +data FailTestParsing = FailTestParsing +data FailOnWarning = FailOnWarning +data FailOnParseError = FailOnParseError + data Config = Config - { configAppName :: String -- ^ Application name ("semantic") - , configHostName :: String -- ^ HostName from getHostName - , configProcessID :: ProcessID -- ^ ProcessID from getProcessID - , configHaystackURL :: Maybe String -- ^ URL of Haystack (with creds) from environment - , configStatsHost :: Stat.Host -- ^ Host of statsd/datadog (default: "127.0.0.1") - , configStatsPort :: Stat.Port -- ^ Port of statsd/datadog (default: "28125") - - , configTreeSitterParseTimeout :: Duration -- ^ Timeout in milliseconds before canceling tree-sitter parsing (default: 6000). - , configAssignmentTimeout :: Duration -- ^ Millisecond timeout for assignment (default: 4000) - , configMaxTelemetyQueueSize :: Int -- ^ Max size of telemetry queues before messages are dropped (default: 1000). - , configIsTerminal :: Bool -- ^ Whether a terminal is attached (set automaticaly at runtime). - , configLogPrintSource :: Bool -- ^ Whether to print the source reference when logging errors (set automatically at runtime). - , configLogFormatter :: LogFormatter -- ^ Log formatter to use (set automaticaly at runtime). - , configSHA :: Maybe String -- ^ Optional SHA to include in log messages. - , configFailParsingForTesting :: Bool -- ^ Simulate internal parse failure for testing (default: False). - - , configOptions :: Options -- ^ Options configurable via command line arguments. + { configAppName :: String -- ^ Application name ("semantic") + , configHostName :: String -- ^ HostName from getHostName + , configProcessID :: ProcessID -- ^ ProcessID from getProcessID + , configHaystackURL :: Maybe String -- ^ URL of Haystack (with creds) from environment + , configStatsHost :: Stat.Host -- ^ Host of statsd/datadog (default: "127.0.0.1") + , configStatsPort :: Stat.Port -- ^ Port of statsd/datadog (default: "28125") + , configTreeSitterParseTimeout :: Duration -- ^ Timeout in milliseconds before canceling tree-sitter parsing (default: 6000). + , configAssignmentTimeout :: Duration -- ^ Millisecond timeout for assignment (default: 4000) + , configMaxTelemetyQueueSize :: Int -- ^ Max size of telemetry queues before messages are dropped (default: 1000). + , configIsTerminal :: Flag IsTerminal -- ^ Whether a terminal is attached (set automaticaly at runtime). + , configLogPrintSource :: Flag LogPrintSource -- ^ Whether to print the source reference when logging errors (set automatically at runtime). + , configLogFormatter :: LogFormatter -- ^ Log formatter to use (set automatically at runtime). + , configSHA :: Maybe String -- ^ Optional SHA to include in log messages. + , configFailParsingForTesting :: Flag FailTestParsing -- ^ Simulate internal parse failure for testing (default: False). + , configOptions :: Options -- ^ Options configurable via command line arguments. } -- Options configurable via command line arguments. data Options = Options - { optionsLogLevel :: Maybe Level -- ^ What level of messages to log. 'Nothing' disables logging. - , optionsFailOnWarning :: Bool -- ^ Should semantic fail fast on assignment warnings (for testing) - , optionsFailOnParseError :: Bool -- ^ Should semantic fail fast on tree-sitter parser errors (for testing) + { optionsLogLevel :: Maybe Level -- ^ What level of messages to log. 'Nothing' disables logging. + , optionsFailOnWarning :: Flag FailOnWarning -- ^ Should semantic fail fast on assignment warnings (for testing) + , optionsFailOnParseError :: Flag FailOnParseError -- ^ Should semantic fail fast on tree-sitter parser errors (for testing) } defaultOptions :: Options -defaultOptions = Options (Just Warning) False False +defaultOptions = Options (Just Warning) (flag FailOnWarning False) (flag FailOnParseError False) debugOptions :: Options -debugOptions = Options (Just Debug) False False +debugOptions = defaultOptions { optionsLogLevel = Just Debug } infoOptions :: Options -infoOptions = Options (Just Info) False False +infoOptions = defaultOptions { optionsLogLevel = Just Info } defaultConfig :: Options -> IO Config defaultConfig options@Options{..} = do @@ -88,11 +97,11 @@ defaultConfig options@Options{..} = do , configTreeSitterParseTimeout = fromMilliseconds parseTimeout , configAssignmentTimeout = fromMilliseconds assignTimeout , configMaxTelemetyQueueSize = size - , configIsTerminal = isTerminal - , configLogPrintSource = isTerminal + , configIsTerminal = flag IsTerminal isTerminal + , configLogPrintSource = flag LogPrintSource isTerminal , configLogFormatter = if isTerminal then terminalFormatter else logfmtFormatter , configSHA = Nothing - , configFailParsingForTesting = False + , configFailParsingForTesting = flag FailTestParsing False , configOptions = options } @@ -108,15 +117,15 @@ logOptionsFromConfig :: Config -> LogOptions logOptionsFromConfig Config{..} = LogOptions { logOptionsLevel = optionsLogLevel configOptions , logOptionsFormatter = configLogFormatter - , logOptionsContext = logOptionsContext' configIsTerminal + , logOptionsContext = logOptionsContext' } - where logOptionsContext' = \case - False -> [ ("app", configAppName) - , ("pid", show configProcessID) - , ("hostname", configHostName) - , ("sha", fromMaybe "development" configSHA) - ] - _ -> [] + where logOptionsContext' + | toBool IsTerminal configIsTerminal = [] + | otherwise = [ ("app", configAppName) + , ("pid", show configProcessID) + , ("hostname", configHostName) + , ("sha", fromMaybe "development" configSHA) + ] withLoggerFromConfig :: Config -> (LogQueue -> IO c) -> IO c diff --git a/src/Semantic/REPL.hs b/src/Semantic/REPL.hs index b33e7e730..dc70d66f1 100644 --- a/src/Semantic/REPL.hs +++ b/src/Semantic/REPL.hs @@ -18,8 +18,9 @@ import Data.Abstract.ModuleTable as ModuleTable import Data.Abstract.Package import Data.Abstract.Value.Concrete as Concrete import Data.Blob (Blob(..)) -import Data.Error (showExcerpt) +import Data.Error (Colourize (..), showExcerpt) import Data.File (File (..), readBlobFromFile) +import Data.Flag (flag) import Data.Graph (topologicalSort) import Data.Language as Language import Data.List (uncons) @@ -138,7 +139,7 @@ step blobs recur term = do where list = do path <- asks modulePath span <- ask - maybe (pure ()) (\ blob -> output (T.pack (showExcerpt True span blob ""))) (Prelude.lookup path blobs) + maybe (pure ()) (\ blob -> output (T.pack (showExcerpt (flag Colourize True) span blob ""))) (Prelude.lookup path blobs) help = do output "Commands available from the prompt:" output "" diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index a08571fdd..37a7bb497 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -68,11 +68,11 @@ import Control.Effect.Trace import Control.Monad import Control.Monad.IO.Class import Data.Blob -import Data.Bool import Data.ByteString.Builder import Data.Coerce import Data.Diff import qualified Data.Error as Error +import qualified Data.Flag as Flag import Data.Location import Data.Source (Source) import Data.Sum @@ -240,7 +240,7 @@ instance (Member (Error SomeException) sig, Member (Lift IO) sig, Member (Reader Semantic.Task.Diff terms k -> k (diffTermPair terms) Render renderer input k -> k (renderer input) Serialize format input k -> do - formatStyle <- asks (bool Plain Colourful . configIsTerminal . config) + formatStyle <- asks (Flag.choose IsTerminal Plain Colourful . configIsTerminal . config) k (runSerialize formatStyle format input) @@ -253,9 +253,9 @@ logError :: (Member Telemetry sig, Carrier sig m) -> [(String, String)] -> m () logError TaskSession{..} level blob err = - let configLogPrintSource' = configLogPrintSource config - configIsTerminal' = configIsTerminal config - in writeLog level (Error.formatError configLogPrintSource' configIsTerminal' blob err) + let shouldLogSource = configLogPrintSource config + shouldColorize = Flag.switch IsTerminal Error.Colourize $ configIsTerminal config + in writeLog level (Error.formatError shouldLogSource shouldColorize blob err) data ParserCancelled = ParserTimedOut | AssignmentTimedOut deriving (Show, Typeable) @@ -308,8 +308,13 @@ runParser blob@Blob{..} parser = case parser of taskSession <- ask let requestID' = ("github_request_id", requestID taskSession) let isPublic' = ("github_is_public", show (isPublic taskSession)) - let blobFields = ("path", if isPublic taskSession || configLogPrintSource (config taskSession) then blobPath else "") + let logPrintFlag = configLogPrintSource . config $ taskSession + let blobFields = ("path", if isPublic taskSession || Flag.toBool LogPrintSource logPrintFlag then blobPath else "") let logFields = requestID' : isPublic' : blobFields : languageTag + let shouldFailForTesting = configFailParsingForTesting $ config taskSession + let shouldFailOnParsing = optionsFailOnParseError . configOptions $ config taskSession + let shouldFailOnWarning = optionsFailOnWarning . configOptions $ config taskSession + ast <- runParser blob parser `catchError` \ (SomeException err) -> do writeStat (increment "parse.parse_failures" languageTag) writeLog Error "failed parsing" (("task", "parse") : logFields) @@ -326,15 +331,14 @@ runParser blob@Blob{..} parser = case parser of Just "ParseError" -> do when (i == 0) $ writeStat (increment "parse.parse_errors" languageTag) logError taskSession Warning blob err (("task", "parse") : logFields) - when (optionsFailOnParseError (configOptions (config taskSession))) $ throwError (toException err) + when (Flag.toBool FailOnParseError shouldFailOnParsing) (throwError (toException err)) _ -> do when (i == 0) $ writeStat (increment "parse.assign_warnings" languageTag) logError taskSession Warning blob err (("task", "assign") : logFields) - when (optionsFailOnWarning (configOptions (config taskSession))) $ throwError (toException err) + when (Flag.toBool FailOnWarning shouldFailOnWarning) (throwError (toException err)) term <$ writeStat (count "parse.nodes" (length term) languageTag) case res of - Just r | not (configFailParsingForTesting (config taskSession)) - -> pure r + Just r | not (Flag.toBool FailTestParsing shouldFailForTesting) -> pure r _ -> do writeStat (increment "assign.assign_timeouts" languageTag) writeLog Error "assignment timeout" (("task", "assign") : logFields) diff --git a/src/Semantic/Telemetry/Log.hs b/src/Semantic/Telemetry/Log.hs index 9553c0a8c..2510017da 100644 --- a/src/Semantic/Telemetry/Log.hs +++ b/src/Semantic/Telemetry/Log.hs @@ -8,7 +8,8 @@ module Semantic.Telemetry.Log , writeLogMessage ) where -import Data.Error (withSGRCode) +import Data.Error (Colourize (..), withSGRCode) +import Data.Flag as Flag import Data.List (intersperse) import qualified Data.Time.Format as Time import qualified Data.Time.LocalTime as LocalTime @@ -75,7 +76,7 @@ terminalFormatter LogOptions{..} (Message level message pairs time) = . showPairs (pairs <> logOptionsContext) . showChar '\n' $ "" where - colourize = True + colourize = flag Colourize True showLevel Error = withSGRCode colourize [SetColor Foreground Vivid Red, SetConsoleIntensity BoldIntensity] (showString "ERROR") showLevel Warning = withSGRCode colourize [SetColor Foreground Vivid Yellow, SetConsoleIntensity BoldIntensity] (showString " WARN") showLevel Info = withSGRCode colourize [SetColor Foreground Vivid Cyan, SetConsoleIntensity BoldIntensity] (showString " INFO") diff --git a/test/Examples.hs b/test/Examples.hs index 0b39834cf..b8c040b92 100644 --- a/test/Examples.hs +++ b/test/Examples.hs @@ -10,6 +10,7 @@ import Data.ByteString.Builder import qualified Data.ByteString.Char8 as BC import Data.Either import Data.File (file) +import Data.Flag import Data.Foldable import Data.List import Data.Maybe @@ -18,7 +19,7 @@ import Data.Typeable (cast) import Data.Void import Parsing.Parser import Semantic.Api (TermOutputFormat (..), parseTermBuilder) -import Semantic.Config (Config (..), Options (..), defaultOptions) +import Semantic.Config (Config (..), Options (..), FailOnWarning (..), defaultOptions) import qualified Semantic.IO as IO import Semantic.Task import Semantic.Task.Files @@ -58,7 +59,7 @@ main = withOptions opts $ \ config logger statter -> hspec . parallel $ do else res `shouldSatisfy` isRight setupExampleRepos = readProcess "script/clone-example-repos" mempty mempty >>= print - opts = defaultOptions { optionsFailOnWarning = True, optionsLogLevel = Nothing } + opts = defaultOptions { optionsFailOnWarning = flag FailOnWarning True, optionsLogLevel = Nothing } knownFailuresForPath :: FilePath -> Maybe FilePath -> IO [FilePath] knownFailuresForPath _ Nothing = pure []