diff --git a/semantic-diff.cabal b/semantic-diff.cabal index 9a291d1ec..a11fb5193 100644 --- a/semantic-diff.cabal +++ b/semantic-diff.cabal @@ -71,6 +71,7 @@ library , Renderer.TOC , RWS , Semantic + , Semantic.Log , Semantic.Task , SemanticCmdLine , SES diff --git a/src/Data/Syntax/Assignment.hs b/src/Data/Syntax/Assignment.hs index b99ae1b5e..0eb31c572 100644 --- a/src/Data/Syntax/Assignment.hs +++ b/src/Data/Syntax/Assignment.hs @@ -75,9 +75,7 @@ module Data.Syntax.Assignment , while -- Results , Error(..) -, formatError , formatErrorWithOptions -, withSGRCode -- Running , assignBy , runAssignment @@ -183,12 +181,6 @@ nodeError expected (Node actual _ (Info.Span spanStart _)) = Error spanStart exp type IncludeSource = Bool type Colourize = Bool --- | Format an 'Error' with reference to the source where it occurred. --- --- > formatError = formatErrorWithOptions True True -formatError :: Show grammar => Blob -> Error grammar -> String -formatError = formatErrorWithOptions True True - -- | Format an 'Error', optionally with reference to the source where it occurred. formatErrorWithOptions :: Show grammar => IncludeSource -> Colourize -> Blob -> Error grammar -> String formatErrorWithOptions includeSource colourize Blob{..} Error{..} @@ -196,7 +188,7 @@ formatErrorWithOptions includeSource colourize Blob{..} Error{..} $ withSGRCode colourize [SetConsoleIntensity BoldIntensity] (showPos (maybe Nothing (const (Just blobPath)) blobKind) errorPos . showString ": ") . withSGRCode colourize [SetColor Foreground Vivid Red] (showString "error" . showString ": " . showExpectation errorExpected errorActual . showChar '\n') . (if includeSource - then showString (toS context) . (if isSuffixOf "\n" context then identity else showChar '\n') + then showString (toS context) . (if "\n" `isSuffixOf` context then identity else showChar '\n') . showString (replicate (succ (Info.posColumn errorPos + lineNumberDigits)) ' ') . withSGRCode colourize [SetColor Foreground Vivid Green] (showChar '^' . showChar '\n') else identity) . showString (prettyCallStack callStack) . showChar '\n' diff --git a/src/Semantic/Log.hs b/src/Semantic/Log.hs new file mode 100644 index 000000000..31c25b602 --- /dev/null +++ b/src/Semantic/Log.hs @@ -0,0 +1,99 @@ +module Semantic.Log where + +import Data.String +import Prologue hiding (Location, show) +import qualified Data.Time.Format as Time +import qualified Data.Time.LocalTime as LocalTime +import System.Console.ANSI +import System.IO (hIsTerminalDevice) +import Text.Show +import Text.Printf + +-- | A log message at a specific level. +data Message = Message Level String [(String, String)] LocalTime.ZonedTime + deriving (Show) + +data Level + = Error + | Warning + | Info + | Debug + deriving (Eq, Ord, Show) + +-- | Format log messaging using "logfmt". +-- +-- Logfmt is a loosely defined logging format (see https://brandur.org/logfmt) +-- for structured data, which plays very well with indexing tools like Splunk. +-- +-- Example: +-- time=2006-01-02T15:04:05Z07:00 msg="this is a message" key=val int=42 key2="val with word" float=33.33 +logfmtFormatter :: Options -> Message -> String +logfmtFormatter Options{..} (Message level message pairs time) = + showPairs [ + kv "time" (showTime time) + , kv "msg" (shows message) + , kv "level" (shows level) + ] + . showChar ' ' + . showPairs ((\(k, v) -> kv k (shows v)) <$> pairs) + . showChar '\n' $ "" + where + kv k v = showString k . showChar '=' . v + showTime = showString . Time.formatTime Time.defaultTimeLocale "%FT%XZ%z" + showPairs = foldr (.) identity . intersperse (showChar ' ') + +-- | Format log messages to a terminal. Suitable for local development. +-- +-- Example: +-- [16:52:41] INFO this is a message key=val language=Ruby time=0.000098s +terminalFormatter :: Options -> Message -> String +terminalFormatter Options{..} (Message level message pairs time) = + showChar '[' . showTime time . showString "] " + . showLevel level . showChar ' ' + . showString (printf "%-20s" message) + . showPairs pairs + . showChar '\n' $ "" + where + colourize = optionsIsTerminal && not optionsDisableColour + 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") + showLevel Debug = withSGRCode colourize [SetColor Foreground Vivid White, SetConsoleIntensity BoldIntensity] (showString "DEBUG") + showPairs pairs = foldr (.) identity $ intersperse (showChar ' ') (showPair <$> pairs) + showPair (k, v) = showString k . showChar '=' . withSGRCode colourize [SetConsoleIntensity BoldIntensity] (showString v) + showTime = showString . Time.formatTime Time.defaultTimeLocale "%X" + +-- | Options controlling logging, error handling, &c. +data Options = Options + { optionsDisableColour :: Bool -- ^ Whether to disable colour formatting for logging (Only works when logging to a terminal that supports ANSI colors). + , optionsLevel :: Maybe Level -- ^ What level of messages to log. 'Nothing' disabled logging. + , optionsPrintSource :: Bool -- ^ Whether to print the source reference when logging errors. + , optionsIsTerminal :: Bool -- ^ Whether a terminal is attached. + , optionsFormatter :: Options -> Message -> String -- ^ Log formatter to use. + } + +defaultOptions :: Options +defaultOptions = Options + { optionsDisableColour = False + , optionsLevel = Just Warning + , optionsPrintSource = False + , optionsIsTerminal = False + , optionsFormatter = logfmtFormatter + } + +configureOptionsForHandle :: Handle -> Options -> IO Options +configureOptionsForHandle handle options = do + isTerminal <- hIsTerminalDevice handle + pure $ options + { optionsIsTerminal = isTerminal + , optionsFormatter = if isTerminal then terminalFormatter else logfmtFormatter + } + +withSGRCode :: Bool -> [SGR] -> ShowS -> ShowS +withSGRCode useColour code content = + if useColour then + showString (setSGRCode code) + . content + . showString (setSGRCode []) + else + content diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index 3c826fbec..291d742b4 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -16,7 +16,6 @@ module Semantic.Task , distribute , distributeFor , distributeFoldMap -, Options(..) , defaultOptions , configureOptionsForHandle , terminalFormatter @@ -41,7 +40,6 @@ import Data.Syntax.Algebra (RAlgebra, decoratorWithAlgebra) import qualified Data.Syntax.Assignment as Assignment import qualified Data.Time.Clock as Time import qualified Data.Time.Clock.POSIX as Time (getCurrentTime) -import qualified Data.Time.Format as Time import qualified Data.Time.LocalTime as LocalTime import Data.Union import Diff @@ -50,12 +48,11 @@ import Language import Language.Markdown import Parser import Prologue hiding (Location, show) -import System.Console.ANSI -import System.IO (hIsTerminalDevice, hPutStr) +import System.IO (hPutStr) import Term import Text.Show -import Text.Printf import TreeSitter +import Semantic.Log data TaskF output where ReadBlobs :: Either Handle [(FilePath, Maybe Language)] -> TaskF [Blob] @@ -134,86 +131,6 @@ distributeFor inputs toTask = distribute (fmap toTask inputs) distributeFoldMap :: (Traversable t, Monoid output) => (a -> Task output) -> t a -> Task output distributeFoldMap toTask inputs = fmap fold (distribute (fmap toTask inputs)) - --- | A log message at a specific level. -data Message = Message Level String [(String, String)] LocalTime.ZonedTime - deriving (Show) - -data Level - = Error - | Warning - | Info - | Debug - deriving (Eq, Ord, Show) - --- | Format log messaging using "logfmt". --- --- Logfmt is a loosely defined logging format (see https://brandur.org/logfmt) --- for structured data, which plays very well with indexing tools like Splunk. --- --- Example: --- time=2006-01-02T15:04:05Z07:00 msg="this is a message" key=val int=42 key2="val with word" float=33.33 -logfmtFormatter :: Options -> Message -> String -logfmtFormatter Options{..} (Message level message pairs time) = - showPairs [ - kv "time" (showTime time) - , kv "msg" (shows message) - , kv "level" (shows level) - ] - . showChar ' ' - . showPairs ((\(k, v) -> kv k (shows v)) <$> pairs) - . showChar '\n' $ "" - where - kv k v = showString k . showChar '=' . v - showTime = showString . Time.formatTime Time.defaultTimeLocale "%FT%XZ%z" - showPairs = foldr (.) identity . intersperse (showChar ' ') - --- | Format log messages to a terminal. Suitable for local development. --- -terminalFormatter :: Options -> Message -> String -terminalFormatter Options{..} (Message level message pairs time) = - showChar '[' . showTime time . showString "] " - . showLevel level . showChar ' ' - . showString (printf "%-20s" message) - . showPairs pairs - . showChar '\n' $ "" - where - colourize = optionsIsTerminal && not optionsDisableColour - showLevel Error = Assignment.withSGRCode colourize [SetColor Foreground Vivid Red, SetConsoleIntensity BoldIntensity] (showString "ERROR") - showLevel Warning = Assignment.withSGRCode colourize [SetColor Foreground Vivid Yellow, SetConsoleIntensity BoldIntensity] (showString " WARN") - showLevel Info = Assignment.withSGRCode colourize [SetColor Foreground Vivid Cyan, SetConsoleIntensity BoldIntensity] (showString " INFO") - showLevel Debug = Assignment.withSGRCode colourize [SetColor Foreground Vivid White, SetConsoleIntensity BoldIntensity] (showString "DEBUG") - showPairs pairs = foldr (.) identity $ intersperse (showChar ' ') (showPair <$> pairs) - showPair (k, v) = showString k . showChar '=' . Assignment.withSGRCode colourize [SetConsoleIntensity BoldIntensity] (showString v) - showTime = showString . Time.formatTime Time.defaultTimeLocale "%X" - --- | Options controlling 'Task' logging, error handling, &c. -data Options = Options - { optionsDisableColour :: Bool -- ^ Whether to disable colour formatting for logging (Only works when logging to a terminal that supports ANSI colors). - , optionsLevel :: Maybe Level -- ^ What level of messages to log. 'Nothing' disabled logging. - , optionsPrintSource :: Bool -- ^ Whether to print the source reference when logging errors. - , optionsIsTerminal :: Bool -- ^ Whether a terminal is attached. - , optionsFormatter :: Options -> Message -> String -- ^ Log formatter to use. - } - -defaultOptions :: Options -defaultOptions = Options - { optionsDisableColour = False - , optionsLevel = Just Warning - , optionsPrintSource = False - , optionsIsTerminal = False - , optionsFormatter = logfmtFormatter - } - -configureOptionsForHandle :: Handle -> Options -> IO Options -configureOptionsForHandle handle options = do - isTerminal <- hIsTerminalDevice handle - pure $ options - { optionsIsTerminal = isTerminal - , optionsFormatter = if isTerminal then terminalFormatter else logfmtFormatter - } - - -- | Execute a 'Task' with the 'defaultOptions', yielding its result value in 'IO'. -- -- > runTask = runTaskWithOptions defaultOptions diff --git a/src/SemanticCmdLine.hs b/src/SemanticCmdLine.hs index 901f60637..66c712d37 100644 --- a/src/SemanticCmdLine.hs +++ b/src/SemanticCmdLine.hs @@ -17,6 +17,7 @@ import Prologue hiding (concurrently, readFile) import Renderer import qualified Paths_semantic_diff as Library (version) import qualified Semantic.Task as Task +import qualified Semantic.Log as Task import System.IO (stdin) import qualified Semantic (parseBlobs, diffBlobPairs)