github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-11-24 08:54:07 +03:00
Code Issues Projects Releases Wiki Activity

Eliminate boolean blindness with tagged flags a la olegfi.

Browse Source
This commit is contained in:
Patrick Thomson 2019-03-22 16:25:04 -04:00
parent 37f3d7635f
commit ecea375520
8 changed files with 113 additions and 60 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
semantic.cabal
View File

@ -132,6 +132,7 @@ library
, Data.Duration
, Data.Error
, Data.File
, Data.Flag
, Data.Functor.Both
, Data.Functor.Classes.Generic
, Proto3.Google.Timestamp

5
src/Analysis/TOCSummary.hs
View File

@ -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

38
src/Data/Error.hs
View File

@ -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 "<filtered>"
path = Just $ if Flag.toBool LogPrintSource includeSource then blobPath else "<filtered>"
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)))

40
src/Data/Flag.hs Normal file
View File

@ -0,0 +1,40 @@
{-# LANGUAGE RankNTypes, KindSignatures #-}
-- | -- This technique is due to Oleg Grenrus: <http://oleg.fi/gists/posts/2019-03-21-flag.html>
-- 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 #-}

63
src/Semantic/Config.hs
View File

@ -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

5
src/Semantic/REPL.hs
View File

@ -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 ""

16
src/Semantic/Task.hs
View File

@ -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 "<filtered>")
let logPrintFlag = configLogPrintSource . config $ taskSession
let blobFields = ("path", if isPublic taskSession || Flag.toBool LogPrintSource logPrintFlag then blobPath else "<filtered>")
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)

5
src/Semantic/Telemetry/Log.hs
View File

@ -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")