From ecea3755200f489b1018d77f66309e313a02bf49 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Fri, 22 Mar 2019 16:25:04 -0400 Subject: [PATCH 1/6] Eliminate boolean blindness with tagged flags a la olegfi. --- semantic.cabal | 1 + src/Analysis/TOCSummary.hs | 5 +-- src/Data/Error.hs | 38 ++++++++++----------- src/Data/Flag.hs | 40 ++++++++++++++++++++++ src/Semantic/Config.hs | 63 +++++++++++++++++++---------------- src/Semantic/REPL.hs | 5 +-- src/Semantic/Task.hs | 16 +++++---- src/Semantic/Telemetry/Log.hs | 5 +-- 8 files changed, 113 insertions(+), 60 deletions(-) create mode 100644 src/Data/Flag.hs 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..661d1fe3f 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..d5c8bd929 --- /dev/null +++ b/src/Data/Flag.hs @@ -0,0 +1,40 @@ +{-# 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@ +newtype Flag (t :: *) = Flag Bool + +-- | The constructor for a 'Flag'. You specify @t@ with a visible type application. +flag :: forall 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/Config.hs b/src/Semantic/Config.hs index b9c8281e0..d8a1ec0aa 100644 --- a/src/Semantic/Config.hs +++ b/src/Semantic/Config.hs @@ -13,9 +13,15 @@ module Semantic.Config , withLoggerFromConfig , withStatterFromConfig , withTelemetry + -- * Flags + , IsTerminal (..) + , LogPrintSource (..) + , FailTestParsing (..) ) where import Data.Duration +import Data.Error (LogPrintSource(..)) +import Data.Flag import Network.HostName import Network.HTTP.Client.TLS import Network.URI @@ -29,25 +35,26 @@ import System.IO (hIsTerminalDevice, stdout) import System.Posix.Process import System.Posix.Types +data IsTerminal = IsTerminal +data FailTestParsing = FailTestParsing + 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. @@ -88,11 +95,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 +115,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..4d816c49d 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..5ef42bc17 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -73,6 +73,7 @@ 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 +241,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 +254,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,7 +309,8 @@ 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 ast <- runParser blob parser `catchError` \ (SomeException err) -> do writeStat (increment "parse.parse_failures" languageTag) @@ -332,9 +334,9 @@ runParser blob@Blob{..} parser = case parser of logError taskSession Warning blob err (("task", "assign") : logFields) when (optionsFailOnWarning (configOptions (config taskSession))) $ throwError (toException err) term <$ writeStat (count "parse.nodes" (length term) languageTag) + let shouldFail = configFailParsingForTesting $ config taskSession case res of - Just r | not (configFailParsingForTesting (config taskSession)) - -> pure r + Just r | not (Flag.toBool FailTestParsing shouldFail) -> 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..34dfb5955 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") From 5dfb7fb50d3f8850c9eca7d5969f8be249c3ae6f Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Fri, 22 Mar 2019 16:27:36 -0400 Subject: [PATCH 2/6] Stray LANGUAGE pragma. --- src/Semantic/Config.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/src/Semantic/Config.hs b/src/Semantic/Config.hs index d8a1ec0aa..e15e2dfdf 100644 --- a/src/Semantic/Config.hs +++ b/src/Semantic/Config.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE LambdaCase #-} - module Semantic.Config ( Config (..) , defaultConfig From 272b5b3b64e854291223920fa231d44ac58008e6 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Fri, 22 Mar 2019 16:37:17 -0400 Subject: [PATCH 3/6] Use flags for Options. --- src/Data/Flag.hs | 4 ++++ src/Semantic/CLI.hs | 3 ++- src/Semantic/Config.hs | 20 ++++++++++++-------- src/Semantic/Task.hs | 11 +++++++---- 4 files changed, 25 insertions(+), 13 deletions(-) diff --git a/src/Data/Flag.hs b/src/Data/Flag.hs index d5c8bd929..3b555d1cb 100644 --- a/src/Data/Flag.hs +++ b/src/Data/Flag.hs @@ -14,6 +14,10 @@ import Data.Coerce -- | To declare a new flag, declare a singly-inhabited type: -- @data MyFlag = MyFlag@ +-- then use the 'flag' constructor with a @MyFlag@ type annotation 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. diff --git a/src/Semantic/CLI.hs b/src/Semantic/CLI.hs index 95ffef027..6a013306c 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 e15e2dfdf..b135e0ebd 100644 --- a/src/Semantic/Config.hs +++ b/src/Semantic/Config.hs @@ -15,6 +15,8 @@ module Semantic.Config , IsTerminal (..) , LogPrintSource (..) , FailTestParsing (..) + , FailOnWarning (..) + , FailOnParseError (..) ) where import Data.Duration @@ -33,8 +35,10 @@ import System.IO (hIsTerminalDevice, stdout) import System.Posix.Process import System.Posix.Types -data IsTerminal = IsTerminal -data FailTestParsing = FailTestParsing +data IsTerminal = IsTerminal +data FailTestParsing = FailTestParsing +data FailOnWarning = FailOnWarning +data FailOnParseError = FailOnParseError data Config = Config @@ -58,19 +62,19 @@ data Config -- 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 diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index 5ef42bc17..b68add769 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -312,6 +312,10 @@ runParser blob@Blob{..} parser = case parser of 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) @@ -328,15 +332,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) - let shouldFail = configFailParsingForTesting $ config taskSession case res of - Just r | not (Flag.toBool FailTestParsing shouldFail) -> 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) From f82146ea58d0c81e2a521f3b05d1d8c9050e4bf6 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Fri, 22 Mar 2019 16:52:07 -0400 Subject: [PATCH 4/6] No need to use type applications. --- src/Analysis/TOCSummary.hs | 4 ++-- src/Data/Flag.hs | 6 +++--- src/Semantic/CLI.hs | 2 +- src/Semantic/Config.hs | 8 ++++---- src/Semantic/REPL.hs | 2 +- src/Semantic/Telemetry/Log.hs | 4 ++-- 6 files changed, 13 insertions(+), 13 deletions(-) diff --git a/src/Analysis/TOCSummary.hs b/src/Analysis/TOCSummary.hs index 661d1fe3f..8cd658f36 100644 --- a/src/Analysis/TOCSummary.hs +++ b/src/Analysis/TOCSummary.hs @@ -10,7 +10,7 @@ import Prologue hiding (project) import Control.Arrow import Control.Rewriting import Data.Blob -import Data.Error (Error (..), Colourize, showExpectation) +import Data.Error (Error (..), Colourize (..), showExpectation) import Data.Flag import Data.Language as Language import Data.Location @@ -87,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 (flag @Colourize 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/Flag.hs b/src/Data/Flag.hs index 3b555d1cb..e74a5a00b 100644 --- a/src/Data/Flag.hs +++ b/src/Data/Flag.hs @@ -14,15 +14,15 @@ import Data.Coerce -- | To declare a new flag, declare a singly-inhabited type: -- @data MyFlag = MyFlag@ --- then use the 'flag' constructor with a @MyFlag@ type annotation to create one from a 'Bool'. +-- 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 :: forall t . Bool -> Flag t -flag = Flag +flag :: t -> Bool -> Flag t +flag _ = Flag {-# INLINE flag #-} -- | The destructor for a 'Flag'. You pass in the inhabitant of @t@ to diff --git a/src/Semantic/CLI.hs b/src/Semantic/CLI.hs index 6a013306c..e5f24ef07 100644 --- a/src/Semantic/CLI.hs +++ b/src/Semantic/CLI.hs @@ -49,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 (Flag.flag @FailOnWarning failOnWarning) (Flag.flag @FailOnParseError 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 b135e0ebd..454a55b2e 100644 --- a/src/Semantic/Config.hs +++ b/src/Semantic/Config.hs @@ -68,7 +68,7 @@ data Options } defaultOptions :: Options -defaultOptions = Options (Just Warning) (flag @FailOnWarning False) (flag @FailOnParseError False) +defaultOptions = Options (Just Warning) (flag FailOnWarning False) (flag FailOnParseError False) debugOptions :: Options debugOptions = defaultOptions { optionsLogLevel = Just Debug } @@ -97,11 +97,11 @@ defaultConfig options@Options{..} = do , configTreeSitterParseTimeout = fromMilliseconds parseTimeout , configAssignmentTimeout = fromMilliseconds assignTimeout , configMaxTelemetyQueueSize = size - , configIsTerminal = flag @IsTerminal isTerminal - , configLogPrintSource = flag @LogPrintSource isTerminal + , configIsTerminal = flag IsTerminal isTerminal + , configLogPrintSource = flag LogPrintSource isTerminal , configLogFormatter = if isTerminal then terminalFormatter else logfmtFormatter , configSHA = Nothing - , configFailParsingForTesting = flag @FailTestParsing False + , configFailParsingForTesting = flag FailTestParsing False , configOptions = options } diff --git a/src/Semantic/REPL.hs b/src/Semantic/REPL.hs index 4d816c49d..5e642565c 100644 --- a/src/Semantic/REPL.hs +++ b/src/Semantic/REPL.hs @@ -139,7 +139,7 @@ step blobs recur term = do where list = do path <- asks modulePath span <- ask - maybe (pure ()) (\ blob -> output (T.pack (showExcerpt (flag @Colourize 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/Telemetry/Log.hs b/src/Semantic/Telemetry/Log.hs index 34dfb5955..2510017da 100644 --- a/src/Semantic/Telemetry/Log.hs +++ b/src/Semantic/Telemetry/Log.hs @@ -8,7 +8,7 @@ module Semantic.Telemetry.Log , writeLogMessage ) where -import Data.Error (Colourize, withSGRCode) +import Data.Error (Colourize (..), withSGRCode) import Data.Flag as Flag import Data.List (intersperse) import qualified Data.Time.Format as Time @@ -76,7 +76,7 @@ terminalFormatter LogOptions{..} (Message level message pairs time) = . showPairs (pairs <> logOptionsContext) . showChar '\n' $ "" where - colourize = flag @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") From cf52476d3b5eb8cc33ff657d57109db31ac4dff5 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Mon, 25 Mar 2019 11:15:37 -0400 Subject: [PATCH 5/6] Fix compile errors. --- src/Semantic/CLI.hs | 2 +- src/Semantic/REPL.hs | 2 +- src/Semantic/Task.hs | 1 - 3 files changed, 2 insertions(+), 3 deletions(-) diff --git a/src/Semantic/CLI.hs b/src/Semantic/CLI.hs index e5f24ef07..52a97b8a0 100644 --- a/src/Semantic/CLI.hs +++ b/src/Semantic/CLI.hs @@ -49,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 (Flag.flag FailOnWarning failOnWarning) (Flag.flag @FailOnParseError failOnParseError) + pure $ Options logLevel (Flag.flag FailOnWarning failOnWarning) (Flag.flag FailOnParseError failOnParseError) argumentsParser :: Parser (Task.TaskEff ()) argumentsParser = do diff --git a/src/Semantic/REPL.hs b/src/Semantic/REPL.hs index 5e642565c..dc70d66f1 100644 --- a/src/Semantic/REPL.hs +++ b/src/Semantic/REPL.hs @@ -18,7 +18,7 @@ import Data.Abstract.ModuleTable as ModuleTable import Data.Abstract.Package import Data.Abstract.Value.Concrete as Concrete import Data.Blob (Blob(..)) -import Data.Error (Colourize, showExcerpt) +import Data.Error (Colourize (..), showExcerpt) import Data.File (File (..), readBlobFromFile) import Data.Flag (flag) import Data.Graph (topologicalSort) diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index b68add769..37a7bb497 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -68,7 +68,6 @@ 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 From aa7e1d140c43ec07d56647fed149dc6c4ae414b8 Mon Sep 17 00:00:00 2001 From: Patrick Thomson Date: Mon, 25 Mar 2019 11:37:19 -0400 Subject: [PATCH 6/6] Fix parse-examples. --- test/Examples.hs | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) 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 []