Merge pull request #2493 from github/smart-flags

Eliminate boolean blindness with tagged flags a la olegfi.

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

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

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 "<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 :: Flag Colourize -> [SGR] -> ShowS -> ShowS
-withSGRCode useColour code content =
+withSGRCode useColour code content
-  if useColour then
+  | Flag.toBool Colourize useColour = showString (setSGRCode code) . content . showString (setSGRCode [])
-    showString (setSGRCode code)
+  | otherwise = content
-    . content
-    . showString (setSGRCode [])
-  else
-    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)))

src/Data/Flag.hs

@@ -0,0 +1,44 @@
+{-# 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@
+-- 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 #-}

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

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")
+  { configAppName                :: String               -- ^ Application name ("semantic")
-  , configHostName               :: String       -- ^ HostName from getHostName
+  , configHostName               :: String               -- ^ HostName from getHostName
-  , configProcessID              :: ProcessID    -- ^ ProcessID from getProcessID
+  , configProcessID              :: ProcessID            -- ^ ProcessID from getProcessID
-  , configHaystackURL            :: Maybe String -- ^ URL of Haystack (with creds) from environment
+  , configHaystackURL            :: Maybe String         -- ^ URL of Haystack (with creds) from environment
-  , configStatsHost              :: Stat.Host    -- ^ Host of statsd/datadog (default: "127.0.0.1")
+  , configStatsHost              :: Stat.Host            -- ^ Host of statsd/datadog (default: "127.0.0.1")
-  , configStatsPort              :: Stat.Port    -- ^ Port of statsd/datadog (default: "28125")
+  , configStatsPort              :: Stat.Port            -- ^ Port of statsd/datadog (default: "28125")
-
+  , configTreeSitterParseTimeout :: Duration             -- ^ Timeout in milliseconds before canceling tree-sitter parsing (default: 6000).
-  , configTreeSitterParseTimeout :: Duration     -- ^ Timeout in milliseconds before canceling tree-sitter parsing (default: 6000).
+  , configAssignmentTimeout      :: Duration             -- ^ Millisecond timeout for assignment (default: 4000)
-  , configAssignmentTimeout      :: Duration     -- ^ Millisecond timeout for assignment (default: 4000)
+  , configMaxTelemetyQueueSize   :: Int                  -- ^ Max size of telemetry queues before messages are dropped (default: 1000).
-  , 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).
-  , configIsTerminal             :: Bool         -- ^ 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).
-  , configLogPrintSource         :: Bool         -- ^ Whether to print the source reference when logging errors (set automatically at runtime).
+  , configLogFormatter           :: LogFormatter         -- ^ Log formatter to use (set automatically at runtime).
-  , configLogFormatter           :: LogFormatter -- ^ Log formatter to use (set automaticaly at runtime).
+  , configSHA                    :: Maybe String         -- ^ Optional SHA to include in log messages.
-  , configSHA                    :: Maybe String -- ^ Optional SHA to include in log messages.
+  , configFailParsingForTesting  :: Flag FailTestParsing -- ^ Simulate internal parse failure for testing (default: False).
-  , configFailParsingForTesting  :: Bool         -- ^ Simulate internal parse failure for testing (default: False).
+  , configOptions                :: Options              -- ^ Options configurable via command line arguments.
-
-  , 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.
+  { optionsLogLevel         :: Maybe Level           -- ^ What level of messages to log. 'Nothing' disables logging.
-  , optionsFailOnWarning    :: Bool          -- ^ Should semantic fail fast on assignment warnings (for testing)
+  , optionsFailOnWarning    :: Flag FailOnWarning    -- ^ Should semantic fail fast on assignment warnings (for testing)
-  , optionsFailOnParseError :: Bool          -- ^ Should semantic fail fast on tree-sitter parser errors (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
+    , configIsTerminal = flag IsTerminal isTerminal
-    , configLogPrintSource = 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
+  where logOptionsContext'
-          False -> [ ("app", configAppName)
+          | toBool IsTerminal configIsTerminal = []
-                   , ("pid", show configProcessID)
+          | otherwise = [ ("app", configAppName)
-                   , ("hostname", configHostName)
+                        , ("pid", show configProcessID)
-                   , ("sha", fromMaybe "development" configSHA)
+                        , ("hostname", configHostName)
-                   ]
+                        , ("sha", fromMaybe "development" configSHA)
-          _     -> []
+                        ]
 
 
 withLoggerFromConfig :: Config -> (LogQueue -> IO c) -> IO c

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

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
+  let shouldLogSource = configLogPrintSource config
-      configIsTerminal' = configIsTerminal config
+      shouldColorize = Flag.switch IsTerminal Error.Colourize $ configIsTerminal config
-  in writeLog level (Error.formatError configLogPrintSource' configIsTerminal' blob err)
+  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 "<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
+          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))
+            Just r | not (Flag.toBool FailTestParsing shouldFailForTesting) -> pure r
-              -> pure r
             _ -> do
               writeStat (increment "assign.assign_timeouts" languageTag)
               writeLog Error "assignment timeout" (("task", "assign") : logFields)

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

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 []