Merge branch 'master' into parse-jsx

.gitignore

@@ -1,33 +1,14 @@
 .DS_Store
-xcuserdata
-*.mode*
-*.pbxuser
-*.xcuserdatad
-*.xccheckout
+
 .stack-work
 profiles
 tags
 
+cabal.project.local
+dist-newstyle
+
 tmp/
 
-vendor/icu/tools
-vendor/icu/lib
-vendor/icu/layoutex
-vendor/icu/layout
-vendor/icu/i18n
-vendor/icu/test/
-vendor/icu/stubdata/
-vendor/icu/samples/
-vendor/icu/io/
-vendor/icu/icudefs.mk
-vendor/icu/extra/
-vendor/icu/data/
-vendor/icu/config/
-vendor/icu/config.status
-vendor/icu/config.log
-vendor/icu/common/
-vendor/icu/bin/
-vendor/icu/Makefile
 bin/
 
 *.hp

semantic-diff.cabal

@@ -24,6 +24,7 @@ library
                      , Data.Functor.Listable
                      , Data.Mergeable
                      , Data.Mergeable.Generic
+                     , Data.Output
                      , Data.Range
                      , Data.Record
                      , Data.Source
@@ -70,6 +71,7 @@ library
                      , Renderer.TOC
                      , RWS
                      , Semantic
+                     , Semantic.Log
                      , Semantic.Task
                      , SemanticCmdLine
                      , SES
@@ -111,6 +113,7 @@ library
                      , text >= 1.2.1.3
                      , these
                      , time
+                     , unix
                      , haskell-tree-sitter
                      , go
                      , ruby

src/Data/Output.hs

@@ -0,0 +1,9 @@
+module Data.Output where
+
+import Prologue
+
+class Monoid o => Output o where
+  toOutput :: o -> ByteString
+
+instance Output ByteString where
+  toOutput s = s

src/Data/Syntax/Assignment.hs

@@ -75,13 +75,8 @@ module Data.Syntax.Assignment
 , while
 -- Results
 , Error(..)
-, Options(..)
-, defaultOptions
-, optionsForHandle
-, printError
-, formatError
+, errorCallStack
 , formatErrorWithOptions
-, withSGRCode
 -- Running
 , assignBy
 , runAssignment
@@ -107,7 +102,6 @@ import Prologue hiding (Alt, get, Location, State, state)
 import System.Console.ANSI
 import Text.Parser.TreeSitter.Language
 import Text.Show hiding (show)
-import System.IO (hIsTerminalDevice, hPutStr)
 
 -- | Assignment from an AST with some set of 'symbol's onto some other value.
 --
@@ -181,49 +175,25 @@ data Error grammar = HasCallStack => Error { errorPos :: Info.Pos, errorExpected
 deriving instance Eq grammar => Eq (Error grammar)
 deriving instance Show grammar => Show (Error grammar)
 
-nodeError :: [grammar] -> Node grammar -> Error grammar
+errorCallStack :: Error grammar -> CallStack
+errorCallStack Error{} = callStack
+
+nodeError :: HasCallStack => [grammar] -> Node grammar -> Error grammar
 nodeError expected (Node actual _ (Info.Span spanStart _)) = Error spanStart expected (Just actual)
 
--- | Options for printing errors.
-data Options = Options
-  { optionsColour :: Bool -- ^ Whether to use colour formatting codes suitable for a terminal device.
-  , optionsIncludeSource :: Bool -- ^ Whether to include the source reference.
-  }
 
-defaultOptions :: Options
-defaultOptions = Options
-  { optionsColour = True
-  , optionsIncludeSource = True
-  }
-
-optionsForHandle :: Handle -> IO Options
-optionsForHandle handle = do
-  isTerminal <- hIsTerminalDevice handle
-  pure $ defaultOptions
-    { optionsColour = isTerminal
-    }
-
--- | Pretty-print an 'Error' to stderr, optionally with reference to the source where it occurred.
-printError :: Show grammar => Blob -> Error grammar -> IO ()
-printError blob error = do
-  options <- optionsForHandle stderr
-  hPutStr stderr $ formatErrorWithOptions options blob error
+type IncludeSource = Bool
+type Colourize = Bool
 
 -- | Format an 'Error', optionally with reference to the source where it occurred.
---
--- > formatError = formatErrorWithOptions defaultOptions
-formatError :: Show grammar => Blob -> Error grammar -> String
-formatError = formatErrorWithOptions defaultOptions
-
--- | Format an 'Error', optionally with reference to the source where it occurred.
-formatErrorWithOptions :: Show grammar => Options -> Blob -> Error grammar -> String
-formatErrorWithOptions Options{..} Blob{..} Error{..}
+formatErrorWithOptions :: Show grammar => IncludeSource -> Colourize -> Blob -> Error grammar -> String
+formatErrorWithOptions includeSource colourize Blob{..} Error{..}
   = ($ "")
-  $ withSGRCode optionsColour [SetConsoleIntensity BoldIntensity] (showPos (maybe Nothing (const (Just blobPath)) blobKind) errorPos . showString ": ")
-  . withSGRCode optionsColour [SetColor Foreground Vivid Red] (showString "error" . showString ": " . showExpectation errorExpected errorActual . showChar '\n')
-  . (if optionsIncludeSource
-    then showString (toS context) . (if isSuffixOf "\n" context then identity else showChar '\n')
-       . showString (replicate (succ (Info.posColumn errorPos + lineNumberDigits)) ' ') . withSGRCode optionsColour [SetColor Foreground Vivid Green] (showChar '^' . showChar '\n')
+  $ 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 "\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'
   where context = maybe "\n" (Source.sourceBytes . sconcat) (nonEmpty [ Source.fromBytes (toS (showLineNumber i)) <> Source.fromBytes ": " <> l | (i, l) <- zip [1..] (Source.sourceLines blobSource), inRange (Info.posLine errorPos - 2, Info.posLine errorPos) i ])
@@ -255,7 +225,7 @@ showPos :: Maybe FilePath -> Info.Pos -> ShowS
 showPos path Info.Pos{..} = maybe (showParen True (showString "interactive")) showString path . showChar ':' . shows posLine . showChar ':' . shows posColumn
 
 -- | Run an assignment over an AST exhaustively.
-assignBy :: (Symbol grammar, Enum grammar, Eq grammar, Recursive ast, Foldable (Base ast), HasCallStack)
+assignBy :: (Symbol grammar, Enum grammar, Eq grammar, Recursive ast, Foldable (Base ast))
          => (forall x. Base ast x -> Node grammar) -- ^ A function to project a 'Node' from the ast.
          -> Source.Source                          -- ^ The source for the parse tree.
          -> Assignment ast grammar a               -- ^ The 'Assignment to run.
@@ -264,7 +234,7 @@ assignBy :: (Symbol grammar, Enum grammar, Eq grammar, Recursive ast, Foldable (
 assignBy toNode source assignment = fmap fst . runAssignment toNode source assignment . makeState . pure
 
 -- | Run an assignment of nodes in a grammar onto terms in a syntax over an AST exhaustively.
-runAssignment :: forall grammar a ast. (Symbol grammar, Enum grammar, Eq grammar, Recursive ast, Foldable (Base ast), HasCallStack)
+runAssignment :: forall grammar a ast. (Symbol grammar, Enum grammar, Eq grammar, Recursive ast, Foldable (Base ast))
               => (forall x. Base ast x -> Node grammar)        -- ^ A function to project a 'Node' from the ast.
               -> Source.Source                                 -- ^ The source for the parse tree.
               -> Assignment ast grammar a                      -- ^ The 'Assignment' to run.
@@ -298,12 +268,17 @@ runAssignment toNode source = (\ assignment state -> go assignment state >>= req
                   Alt a b -> yield a state `catchError` (\ err -> yield b state { stateError = Just err })
                   Throw e -> Left e
                   Catch during handler -> (go during state `catchError` (flip go state . handler)) >>= uncurry yield
-                  _ -> Left (maybe (Error (statePos state) expectedSymbols Nothing) (nodeError expectedSymbols . toNode) node)
+                  Choose{} -> Left (makeError node)
+                  Project{} -> Left (makeError node)
+                  Children{} -> Left (makeError node)
+                  Source -> Left (makeError node)
 
                 state | _:_ <- expectedSymbols, all ((== Regular) . symbolType) expectedSymbols = dropAnonymous initialState
                       | otherwise = initialState
                 expectedSymbols | Choose choices _ <- assignment = (toEnum :: Int -> grammar) <$> IntMap.keys choices
                                 | otherwise = []
+                makeError :: HasCallStack => Maybe (Base ast ast) -> Error grammar
+                makeError node = maybe (Error (statePos state) expectedSymbols Nothing) (nodeError expectedSymbols . toNode) node
 
         runMany :: Assignment ast grammar result -> State ast grammar -> ([result], State ast grammar)
         runMany rule = loop

src/Renderer.hs

@@ -20,6 +20,7 @@ module Renderer
 
 import Data.Aeson (Value, (.=))
 import qualified Data.Map as Map
+import Data.Output
 import Data.Syntax.Algebra (RAlgebra)
 import Diff (SyntaxDiff)
 import Info (DefaultFields)
@@ -66,7 +67,7 @@ deriving instance Show (TermRenderer output)
 --
 --   This type abstracts the type indices of 'DiffRenderer' and 'TermRenderer' s.t. multiple renderers can be present in a single list, alternation, etc., while retaining the ability to render and serialize. (Without 'SomeRenderer', the different output types of individual term/diff renderers prevent them from being used in a homogeneously typed setting.)
 data SomeRenderer f where
-  SomeRenderer :: (Monoid output, StringConv output ByteString, Show (f output)) => f output -> SomeRenderer f
+  SomeRenderer :: (Output output, Show (f output)) => f output -> SomeRenderer f
 
 deriving instance Show (SomeRenderer f)
 

src/Renderer/JSON.hs

@@ -10,14 +10,16 @@ import Data.Aeson (ToJSON, toJSON, encode, object, (.=))
 import Data.Aeson as A hiding (json)
 import Data.Bifunctor.Join
 import Data.Blob
+import Data.ByteString.Lazy (toStrict)
 import Data.Functor.Both (Both)
 import qualified Data.Map as Map
+import Data.Output
 import Data.Record
 import Data.Union
 import Info
 import Language
 import Patch
-import Prologue hiding ((++))
+import Prologue hiding ((++), toStrict)
 import Syntax as S
 
 --
@@ -32,8 +34,8 @@ renderJSONDiff blobs diff = Map.fromList
   , ("paths", toJSON (blobPath <$> toList blobs))
   ]
 
-instance StringConv (Map Text Value) ByteString where
-  strConv _ = toS . (<> "\n") . encode
+instance Output (Map Text Value) where
+  toOutput = toStrict . (<> "\n") . encode
 
 instance ToJSON a => ToJSONFields (Join (,) a) where
   toJSONFields (Join (a, b)) = [ "before" .= a, "after" .= b ]
@@ -117,8 +119,8 @@ data File a = File { filePath :: FilePath, fileLanguage :: Maybe Language, fileC
 instance ToJSON a => ToJSON (File a) where
   toJSON File{..} = object [ "filePath" .= filePath, "language" .= fileLanguage, "programNode" .= fileContent ]
 
-instance StringConv [Value] ByteString where
-  strConv _ = toS . (<> "\n") . encode
+instance Output [Value] where
+  toOutput = toStrict . (<> "\n") . encode
 
 renderJSONTerm :: ToJSON a => Blob -> a -> [Value]
 renderJSONTerm Blob{..} = pure . toJSON . File blobPath blobLanguage

src/Renderer/Patch.hs

@@ -13,6 +13,7 @@ import Data.Blob
 import qualified Data.ByteString.Char8 as ByteString
 import Data.Functor.Both as Both
 import Data.List (span, unzip)
+import Data.Output
 import Data.Range
 import Data.Record
 import Data.Source
@@ -40,8 +41,8 @@ instance Monoid File where
   mempty = File mempty
   mappend (File a) (File b) = File (a <> "\n" <> b)
 
-instance StringConv File ByteString where
-  strConv _ = unFile
+instance Output File where
+  toOutput = unFile
 
 
 -- | A hunk in a patch, including the offset, changes, and context.

src/Renderer/TOC.hs

@@ -20,10 +20,12 @@ module Renderer.TOC
 import Data.Aeson
 import Data.Align (crosswalk)
 import Data.Blob
+import Data.ByteString.Lazy (toStrict)
 import Data.Functor.Both hiding (fst, snd)
 import qualified Data.Functor.Both as Both
 import Data.Functor.Listable
 import Data.List.NonEmpty (nonEmpty)
+import Data.Output
 import Data.Record
 import Data.Source as Source
 import Data.Text (toLower)
@@ -35,7 +37,7 @@ import Diff
 import Info
 import Language
 import Patch
-import Prologue
+import Prologue hiding (toStrict)
 import qualified Data.List as List
 import qualified Data.Map as Map hiding (null)
 import Syntax as S
@@ -52,8 +54,8 @@ instance Monoid Summaries where
   mempty = Summaries mempty mempty
   mappend (Summaries c1 e1) (Summaries c2 e2) = Summaries (Map.unionWith (<>) c1 c2) (Map.unionWith (<>) e1 e2)
 
-instance StringConv Summaries ByteString where
-  strConv _ = toS . (<> "\n") . encode
+instance Output Summaries where
+  toOutput = toStrict . (<> "\n") . encode
 
 instance ToJSON Summaries where
   toJSON Summaries{..} = object [ "changes" .= changes, "errors" .= errors ]

src/Semantic.hs

@@ -12,6 +12,7 @@ import Data.Align.Generic (GAlign)
 import Data.Blob
 import Data.Functor.Both as Both
 import Data.Functor.Classes (Eq1, Show1)
+import Data.Output
 import Data.Record
 import qualified Data.Syntax.Declaration as Declaration
 import Data.Union
@@ -36,8 +37,8 @@ import Term
 --   - Built in concurrency where appropriate.
 --   - Easy to consume this interface from other application (e.g a cmdline or web server app).
 
-parseBlobs :: (Monoid output, StringConv output ByteString) => TermRenderer output -> [Blob] -> Task ByteString
-parseBlobs renderer = fmap toS . distributeFoldMap (parseBlob renderer) . filter blobExists
+parseBlobs :: Output output => TermRenderer output -> [Blob] -> Task ByteString
+parseBlobs renderer = fmap toOutput . distributeFoldMap (parseBlob renderer) . filter blobExists
 
 -- | A task to parse a 'Blob' and render the resulting 'Term'.
 parseBlob :: TermRenderer output -> Blob -> Task output
@@ -61,8 +62,8 @@ parseBlob renderer blob@Blob{..} = case (renderer, blobLanguage) of
 
 
 
-diffBlobPairs :: (Monoid output, StringConv output ByteString) => DiffRenderer output -> [Both Blob] -> Task ByteString
-diffBlobPairs renderer = fmap toS . distributeFoldMap (diffBlobPair renderer) . filter (any blobExists)
+diffBlobPairs :: Output output => DiffRenderer output -> [Both Blob] -> Task ByteString
+diffBlobPairs renderer = fmap toOutput . distributeFoldMap (diffBlobPair renderer) . filter (any blobExists)
 
 -- | A task to parse a pair of 'Blob's, diff them, and render the 'Diff'.
 diffBlobPair :: DiffRenderer output -> Both Blob -> Task output
@@ -97,7 +98,13 @@ diffTermPair :: Functor f => Both Blob -> Differ f a -> Both (Term f a) -> Task
 diffTermPair blobs differ terms = case runJoin (blobExists <$> blobs) of
   (True, False) -> pure (deleting (Both.fst terms))
   (False, True) -> pure (inserting (Both.snd terms))
-  _ -> diff differ terms
+  _ -> time "diff" logInfo $ diff differ terms
+  where
+    logInfo = let (a, b) = runJoin blobs in
+            [ ("before_path", blobPath a)
+            , ("before_language", maybe "" show (blobLanguage a))
+            , ("after_path", blobPath b)
+            , ("after_language", maybe "" show (blobLanguage b)) ]
 
 
 keepCategory :: HasField fields Category => Record fields -> Record '[Category]

src/Semantic/Log.hs

@@ -0,0 +1,109 @@
+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 System.Posix.Process
+import System.Posix.Types
+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)
+      : kv "process_id" (shows optionsProcessID)
+      : kv "app" (showString "semantic")
+      : (uncurry kv . second shows <$> pairs)
+      <> [ kv "request_id" (shows x) | x <- toList optionsRequestID ] )
+  . showChar '\n' $ ""
+  where
+    kv k v = showString k . showChar '=' . v
+    showPairs = foldr (.) identity . intersperse (showChar ' ')
+    showTime = showString . Time.formatTime Time.defaultTimeLocale "%FT%XZ%z"
+
+-- | 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 && optionsEnableColour
+    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
+  { optionsEnableColour :: Bool -- ^ Whether to enable 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.
+  , optionsRequestID :: Maybe String -- ^ Optional request id for tracing across systems.
+  , optionsIsTerminal :: Bool -- ^ Whether a terminal is attached (set automaticaly at runtime).
+  , optionsPrintSource :: Bool -- ^ Whether to print the source reference when logging errors (set automatically at runtime).
+  , optionsFormatter :: Options -> Message -> String -- ^ Log formatter to use (set automaticaly at runtime).
+  , optionsProcessID :: CPid -- ^ ProcessID (set automaticaly at runtime).
+  }
+
+defaultOptions :: Options
+defaultOptions = Options
+  { optionsEnableColour = True
+  , optionsLevel = Just Warning
+  , optionsRequestID = Nothing
+  , optionsIsTerminal = False
+  , optionsPrintSource = False
+  , optionsFormatter = logfmtFormatter
+  , optionsProcessID = 0
+  }
+
+configureOptionsForHandle :: Handle -> Options -> IO Options
+configureOptionsForHandle handle options = do
+  pid <- getProcessID
+  isTerminal <- hIsTerminalDevice handle
+  pure $ options
+    { optionsIsTerminal = isTerminal
+    , optionsFormatter = if isTerminal then terminalFormatter else logfmtFormatter
+    , optionsPrintSource = isTerminal
+    , optionsProcessID = pid
+    }
+
+withSGRCode :: Bool -> [SGR] -> ShowS -> ShowS
+withSGRCode useColour code content =
+  if useColour then
+    showString (setSGRCode code)
+    . content
+    . showString (setSGRCode [])
+  else
+    content

src/Semantic/Task.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE DataKinds, GADTs, TypeOperators #-}
+{-# LANGUAGE DataKinds, GADTs, TypeOperators, BangPatterns #-}
 module Semantic.Task
 ( Task
 , Level(..)
@@ -8,6 +8,7 @@ module Semantic.Task
 , readBlobPairs
 , writeToOutput
 , writeLog
+, time
 , parse
 , decorate
 , diff
@@ -15,14 +16,16 @@ module Semantic.Task
 , distribute
 , distributeFor
 , distributeFoldMap
-, Options(..)
 , defaultOptions
 , configureOptionsForHandle
+, terminalFormatter
+, logfmtFormatter
 , runTask
 , runTaskWithOptions
 ) where
 
 import Control.Concurrent.STM.TMQueue
+import Control.Exception
 import Control.Monad.IO.Class
 import Control.Parallel.Strategies
 import qualified Control.Concurrent.Async as Async
@@ -31,14 +34,13 @@ import Data.Blob
 import qualified Data.ByteString as B
 import Data.Functor.Both as Both
 import Data.Record
-import Data.Source
 import Data.String
 import qualified Data.Syntax as Syntax
 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
 import qualified Files
@@ -46,17 +48,18 @@ 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 TreeSitter
+import Semantic.Log
 
 data TaskF output where
   ReadBlobs :: Either Handle [(FilePath, Maybe Language)] -> TaskF [Blob]
   ReadBlobPairs :: Either Handle [Both (FilePath, Maybe Language)] -> TaskF [Both Blob]
   WriteToOutput :: Either Handle FilePath -> ByteString -> TaskF ()
-  WriteLog :: Level -> String -> TaskF ()
+  WriteLog :: Level -> String -> [(String, String)] -> TaskF ()
+  Time :: String -> [(String, String)] -> Task output -> TaskF output
   Parse :: Parser term -> Blob -> TaskF term
   Decorate :: Functor f => RAlgebra (TermF f (Record fields)) (Term f (Record fields)) field -> Term f (Record fields) -> TaskF (Term f (Record (field ': fields)))
   Diff :: Differ f a -> Both (Term f a) -> TaskF (Diff f a)
@@ -67,27 +70,6 @@ data TaskF output where
 -- | A high-level task producing some result, e.g. parsing, diffing, rendering. 'Task's can also specify explicit concurrency via 'distribute', 'distributeFor', and 'distributeFoldMap'
 type Task = Freer TaskF
 
--- | A log message at a specific level.
-data Message = Message Level String Time.UTCTime
-  deriving (Eq, Show)
-
-data Level
-  = Error
-  | Warning
-  | Info
-  | Debug
-  deriving (Eq, Ord, Show)
-
--- | Format a 'Message', optionally colourized.
-formatMessage :: Bool -> Message -> String
-formatMessage colourize (Message level message time) = showTime time . showChar ' ' . showLevel level . showString ": " . showString message . showChar '\n' $ ""
-  where 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 "warning")
-        showLevel Info = Assignment.withSGRCode colourize [SetConsoleIntensity BoldIntensity] (showString "info")
-        showLevel Debug = Assignment.withSGRCode colourize [SetColor Foreground Vivid Cyan, SetConsoleIntensity BoldIntensity] (showString "debug")
-        showTime = showString . Time.formatTime Time.defaultTimeLocale (Time.iso8601DateFormat (Just "%H:%M:%S%Q"))
-
-
 -- | A function to compute the 'Diff' for a pair of 'Term's with arbitrary syntax functor & annotation types.
 type Differ f a = Both (Term f a) -> Diff f a
 
@@ -108,9 +90,12 @@ writeToOutput path contents = WriteToOutput path contents `Then` return
 
 
 -- | A 'Task' which logs a message at a specific log level to stderr.
-writeLog :: Level -> String -> Task ()
-writeLog level message = WriteLog level message `Then` return
+writeLog :: Level -> String -> [(String, String)] -> Task ()
+writeLog level message pairs = WriteLog level message pairs `Then` return
 
+-- | A 'Task' which measures and logs the timing of another 'Task'.
+time :: String -> [(String, String)] -> Task output -> Task output
+time message pairs task = Time message pairs task `Then` return
 
 -- | A 'Task' which parses a 'Blob' with the given 'Parser'.
 parse :: Parser term -> Blob -> Task term
@@ -146,28 +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))
 
--- | Options controlling 'Task' logging, error handling, &c.
-data Options = Options
-  { optionsColour :: Maybe Bool -- ^ Whether to use colour formatting for errors. 'Nothing' implies automatic selection for the stderr handle, using colour for terminal handles but not for regular files.
-  , optionsLevel :: Maybe Level -- ^ What level of messages to log. 'Nothing' disabled logging.
-  , optionsPrintSource :: Bool -- ^ Whether to print the source reference when logging errors.
-  }
-
-defaultOptions :: Options
-defaultOptions = Options
-  { optionsColour = Nothing
-  , optionsLevel = Just Warning
-  , optionsPrintSource = False
-  }
-
-configureOptionsForHandle :: Handle -> Options -> IO Options
-configureOptionsForHandle handle options = do
-  isTerminal <- hIsTerminalDevice handle
-  pure $ options
-    { optionsColour = optionsColour options <|> Just isTerminal
-    }
-
-
 -- | Execute a 'Task' with the 'defaultOptions', yielding its result value in 'IO'.
 --
 -- > runTask = runTaskWithOptions defaultOptions
@@ -181,59 +144,70 @@ runTaskWithOptions options task = do
   logQueue <- newTMQueueIO
   logging <- async (logSink options logQueue)
 
-  result <- runFreerM (\ task -> case task of
-    ReadBlobs source -> pure <$ writeLog Info "ReadBlobs" <*> either Files.readBlobsFromHandle (traverse (uncurry Files.readFile)) source
-    ReadBlobPairs source -> pure <$ writeLog Info "ReadBlobPairs" <*> either Files.readBlobPairsFromHandle (traverse (traverse (uncurry Files.readFile))) source
-    WriteToOutput destination contents -> pure <$ writeLog Info "WriteToOutput" <*> liftIO (either B.hPutStr B.writeFile destination contents)
-    WriteLog level message
-      | Just logLevel <- optionsLevel options, level <= logLevel -> pure <$> liftIO (Time.getCurrentTime >>= atomically . writeTMQueue logQueue . Message level message)
-      | otherwise -> pure (pure ())
-    Parse parser blob -> pure <$ writeLog Info "Parse" <*> runParser options parser blob
-    Decorate algebra term -> pure <$ writeLog Info "Decorate" <*> pure (decoratorWithAlgebra algebra term)
-    Diff differ terms -> pure <$ writeLog Info "Diff" <*> pure (differ terms)
-    Render renderer input -> pure <$ writeLog Info "Render" <*> pure (renderer input)
-    Distribute tasks -> pure <$ writeLog Info "Distribute" <*> liftIO (Async.mapConcurrently runTask tasks >>= pure . withStrategy (parTraversable rseq))
-    LiftIO action -> pure action)
-    task
+  result <- run options logQueue task
   atomically (closeTMQueue logQueue)
   wait logging
-  pure result
-  where logSink options queue = do
+  either die pure result
+  where logSink options@Options{..} queue = do
           message <- atomically (readTMQueue queue)
           case message of
             Just message -> do
-              hPutStr stderr (formatMessage (fromMaybe True (optionsColour options)) message)
+              hPutStr stderr (optionsFormatter options message)
               logSink options queue
             _ -> pure ()
+        run :: Options -> TMQueue Message -> Task a -> IO (Either String a)
+        run options logQueue = go
+          where go :: Task a -> IO (Either String a)
+                go = iterFreerA (\ task yield -> case task of
+                  ReadBlobs source -> (either Files.readBlobsFromHandle (traverse (uncurry Files.readFile)) source >>= yield) `catchError` (pure . Left . displayException)
+                  ReadBlobPairs source -> (either Files.readBlobPairsFromHandle (traverse (traverse (uncurry Files.readFile))) source >>= yield) `catchError` (pure . Left . displayException)
+                  WriteToOutput destination contents -> either B.hPutStr B.writeFile destination contents >>= yield
+                  WriteLog level message pairs -> queueLogMessage level message pairs >>= yield
+                  Time message pairs task -> do
+                    start <- Time.getCurrentTime
+                    !res <- go task
+                    end <- Time.getCurrentTime
+                    queueLogMessage Info message (pairs <> [("duration", show (Time.diffUTCTime end start))])
+                    either (pure . Left) yield res
+                  Parse parser blob -> go (runParser options parser blob) >>= either (pure . Left) yield . join
+                  Decorate algebra term -> pure (decoratorWithAlgebra algebra term) >>= yield
+                  Diff differ terms -> pure (differ terms) >>= yield
+                  Render renderer input -> pure (renderer input) >>= yield
+                  Distribute tasks -> Async.mapConcurrently go tasks >>= either (pure . Left) yield . sequenceA . withStrategy (parTraversable (parTraversable rseq))
+                  LiftIO action -> action >>= yield ) . fmap Right
+                queueLogMessage level message pairs
+                  | Just logLevel <- optionsLevel options, level <= logLevel = Time.getCurrentTime >>= LocalTime.utcToLocalZonedTime >>= atomically . writeTMQueue logQueue . Message level message pairs
+                  | otherwise = pure ()
 
-runParser :: Options -> Parser term -> Blob -> Task term
-runParser options parser blob@Blob{..} = case parser of
-  ASTParser language -> liftIO $ parseToAST language blob
+
+runParser :: Options -> Parser term -> Blob -> Task (Either String term)
+runParser options@Options{..} parser blob@Blob{..} = case parser of
+  ASTParser language -> do
+    logTiming "ts ast parse" $
+      liftIO $ (Right <$> parseToAST language blob) `catchError` (pure . Left. displayException)
   AssignmentParser parser by assignment -> do
-    ast <- runParser options parser blob
-    case Assignment.assignBy by blobSource assignment ast of
-      Left err -> do
-        let formatOptions = Assignment.defaultOptions
-              { Assignment.optionsColour = fromMaybe True (optionsColour options)
-              , Assignment.optionsIncludeSource = optionsPrintSource options
-              }
-        writeLog Warning (Assignment.formatErrorWithOptions formatOptions blob err)
-        pure (errorTerm blobSource)
-      Right term -> do
-        when (hasErrors term) $ writeLog Warning (blobPath <> ":" <> show blobLanguage <> " has parse errors")
-        pure term
-  TreeSitterParser tslanguage -> liftIO $ treeSitterParser tslanguage blob
-  MarkdownParser -> pure (cmarkParser blobSource)
-  LineByLineParser -> pure (lineByLineParser blobSource)
-
-errorTerm :: Syntax.Error :< fs => Source -> Term (Union fs) (Record Assignment.Location)
-errorTerm source = cofree ((totalRange source :. totalSpan source :. Nil) :< inj (Syntax.Error []))
-
-hasErrors :: (Syntax.Error :< fs, Foldable (Union fs), Functor (Union fs)) => Term (Union fs) (Record Assignment.Location) -> Bool
-hasErrors = cata $ \ (_ :< syntax) -> case syntax of
-  _ | Just err <- prj syntax -> const True (err :: Syntax.Error Bool)
-  _ -> or syntax
-
+    res <- runParser options parser blob
+    case res of
+      Left err -> writeLog Error (showBlob blob <> " failed parsing") [] >> pure (Left err)
+      Right ast -> logTiming "assign" $ case Assignment.assignBy by blobSource assignment ast of
+        Left err -> do
+          writeLog Error (Assignment.formatErrorWithOptions optionsPrintSource (optionsIsTerminal && optionsEnableColour) blob err) []
+          pure $ Left (showBlob blob <> " failed assignment")
+        Right term -> do
+          when (hasErrors term) $ writeLog Warning (showBlob blob <> " has parse errors") []
+          pure $ Right term
+  TreeSitterParser tslanguage -> logTiming "ts parse" $ liftIO (Right <$> treeSitterParser tslanguage blob)
+  MarkdownParser -> logTiming "cmark parse" $ pure (Right (cmarkParser blobSource))
+  LineByLineParser -> logTiming "line-by-line parse" $ pure (Right (lineByLineParser blobSource))
+  where
+    showBlob Blob{..} = blobPath <> ":" <> maybe "" show blobLanguage
+    hasErrors :: (Syntax.Error :< fs, Foldable (Union fs), Functor (Union fs)) => Term (Union fs) (Record Assignment.Location) -> Bool
+    hasErrors = cata $ \ (_ :< syntax) -> case syntax of
+      _ | Just err <- prj syntax -> const True (err :: Syntax.Error Bool)
+      _ -> or syntax
+    logTiming :: String -> Task a -> Task a
+    logTiming msg = time msg [ ("path", blobPath)
+                             , ("language", maybe "" show blobLanguage)]
 
 instance MonadIO Task where
   liftIO action = LiftIO action `Then` return

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 Log
 import System.IO (stdin)
 import qualified Semantic (parseBlobs, diffBlobPairs)
 
@@ -32,19 +33,23 @@ runParse (SomeRenderer parseTreeRenderer) = Semantic.parseBlobs parseTreeRendere
 -- | A parser for the application's command-line arguments.
 --
 --   Returns a 'Task' to read the input, run the requested operation, and write the output to the specified output path or stdout.
-arguments :: ParserInfo (Task.Options, Task.Task ())
+arguments :: ParserInfo (Log.Options, Task.Task ())
 arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsParser)) description
   where
     version = infoOption versionString (long "version" <> short 'v' <> help "Output the version of the program")
     versionString = "semantic version " <> showVersion Library.version <> " (" <> $(gitHash) <> ")"
     description = fullDesc <> header "semantic -- Parse and diff semantically"
 
-    optionsParser = Task.Options
-      <$> options [("yes", Just True), ("no", Just False), ("auto", Nothing)]
-            (long "colour" <> long "color" <> value Nothing <> help "Enable, disable, or decide automatically iff stderr is a terminal device, whether to use colour.")
-      <*> options [("error", Just Task.Error), ("warning", Just Task.Warning), ("info", Just Task.Info), ("debug", Just Task.Debug), ("none", Nothing)]
-            (long "log-level" <> value (Just Task.Warning) <> help "Log messages at or above this level, or disable logging entirely.")
-      <*> switch (long "print-source" <> help "Include source references in logged errors where applicable.")
+    optionsParser = Log.Options
+      <$> (not <$> switch (long "disable-colour" <> long "disable-color" <> help "Disable ANSI colors in log messages even if the terminal is a TTY."))
+      <*> options [("error", Just Log.Error), ("warning", Just Log.Warning), ("info", Just Log.Info), ("debug", Just Log.Debug), ("none", Nothing)]
+            (long "log-level" <> value (Just Log.Warning) <> help "Log messages at or above this level, or disable logging entirely.")
+      <*> optional (strOption (long "request-id" <> help "A string to use as the request identifier for any logged messages." <> metavar "id"))
+      -- The rest of the logging options are set automatically at runtime.
+      <*> pure False -- IsTerminal
+      <*> pure False -- PrintSource
+      <*> pure Log.logfmtFormatter -- Formatter
+      <*> pure 0 -- ProcessID
     argumentsParser = (. Task.writeToOutput) . (>>=)
       <$> hsubparser (diffCommand <> parseCommand)
       <*> (   Right <$> strOption (long "output" <> short 'o' <> help "Output path, defaults to stdout")

test/Data/Syntax/Assignment/Spec.hs

@@ -270,6 +270,11 @@ spec = do
       `shouldBe`
         Right (Out "magenta", Out "red")
 
+    it "produces errors with callstacks pointing at the failing assignment" $
+      first (fmap fst . getCallStack . errorCallStack) (runAssignment headF "blue" red (makeState [node Blue 0 4 []]))
+      `shouldBe`
+      Left [ "symbol", "red" ]
+
 node :: symbol -> Int -> Int -> [AST symbol] -> AST symbol
 node symbol start end children = cofree $ Node symbol (Range start end) (Info.Span (Info.Pos 1 (succ start)) (Info.Pos 1 (succ end))) :< children
 
@@ -283,14 +288,14 @@ instance Symbol Grammar where
 data Out = Out ByteString | OutError ByteString
   deriving (Eq, Show)
 
-red :: Assignment (AST Grammar) Grammar Out
+red :: HasCallStack => Assignment (AST Grammar) Grammar Out
 red = Out <$ symbol Red <*> source
 
-green :: Assignment (AST Grammar) Grammar Out
+green :: HasCallStack => Assignment (AST Grammar) Grammar Out
 green = Out <$ symbol Green <*> source
 
-blue :: Assignment (AST Grammar) Grammar Out
+blue :: HasCallStack => Assignment (AST Grammar) Grammar Out
 blue = Out <$ symbol Blue <*> source
 
-magenta :: Assignment (AST Grammar) Grammar Out
+magenta :: HasCallStack => Assignment (AST Grammar) Grammar Out
 magenta = Out <$ symbol Magenta <*> source

test/TOCSpec.hs

@@ -7,6 +7,7 @@ import Category as C
 import Data.Blob
 import Data.Functor.Both
 import Data.Functor.Listable
+import Data.Output
 import Data.Record
 import Data.Source
 import Data.Text.Listable
@@ -142,17 +143,17 @@ spec = parallel $ do
     it "produces JSON output" $ do
       blobs <- blobsForPaths (both "ruby/methods.A.rb" "ruby/methods.B.rb")
       output <- runTask (diffBlobPair ToCDiffRenderer blobs)
-      toS output `shouldBe` ("{\"changes\":{\"test/fixtures/toc/ruby/methods.A.rb -> test/fixtures/toc/ruby/methods.B.rb\":[{\"span\":{\"start\":[1,1],\"end\":[2,4]},\"category\":\"Method\",\"term\":\"self.foo\",\"changeType\":\"added\"},{\"span\":{\"start\":[4,1],\"end\":[6,4]},\"category\":\"Method\",\"term\":\"bar\",\"changeType\":\"modified\"},{\"span\":{\"start\":[4,1],\"end\":[5,4]},\"category\":\"Method\",\"term\":\"baz\",\"changeType\":\"removed\"}]},\"errors\":{}}\n" :: ByteString)
+      toOutput output `shouldBe` ("{\"changes\":{\"test/fixtures/toc/ruby/methods.A.rb -> test/fixtures/toc/ruby/methods.B.rb\":[{\"span\":{\"start\":[1,1],\"end\":[2,4]},\"category\":\"Method\",\"term\":\"self.foo\",\"changeType\":\"added\"},{\"span\":{\"start\":[4,1],\"end\":[6,4]},\"category\":\"Method\",\"term\":\"bar\",\"changeType\":\"modified\"},{\"span\":{\"start\":[4,1],\"end\":[5,4]},\"category\":\"Method\",\"term\":\"baz\",\"changeType\":\"removed\"}]},\"errors\":{}}\n" :: ByteString)
 
     it "produces JSON output if there are parse errors" $ do
       blobs <- blobsForPaths (both "ruby/methods.A.rb" "ruby/methods.X.rb")
       output <- runTask (diffBlobPair ToCDiffRenderer blobs)
-      toS output `shouldBe` ("{\"changes\":{\"test/fixtures/toc/ruby/methods.A.rb -> test/fixtures/toc/ruby/methods.X.rb\":[{\"span\":{\"start\":[4,1],\"end\":[5,4]},\"category\":\"Method\",\"term\":\"baz\",\"changeType\":\"removed\"}]},\"errors\":{\"test/fixtures/toc/ruby/methods.A.rb -> test/fixtures/toc/ruby/methods.X.rb\":[{\"span\":{\"start\":[1,1],\"end\":[3,1]},\"error\":\"def bar\\nen\\n\",\"language\":\"Ruby\"}]}}\n" :: ByteString)
+      toOutput output `shouldBe` ("{\"changes\":{\"test/fixtures/toc/ruby/methods.A.rb -> test/fixtures/toc/ruby/methods.X.rb\":[{\"span\":{\"start\":[4,1],\"end\":[5,4]},\"category\":\"Method\",\"term\":\"baz\",\"changeType\":\"removed\"}]},\"errors\":{\"test/fixtures/toc/ruby/methods.A.rb -> test/fixtures/toc/ruby/methods.X.rb\":[{\"span\":{\"start\":[1,1],\"end\":[3,1]},\"error\":\"def bar\\nen\\n\",\"language\":\"Ruby\"}]}}\n" :: ByteString)
 
     it "summarizes Markdown headings" $ do
       blobs <- blobsForPaths (both "markdown/headings.A.md" "markdown/headings.B.md")
       output <- runTask (diffBlobPair ToCDiffRenderer blobs)
-      toS output `shouldBe` ("{\"changes\":{\"test/fixtures/toc/markdown/headings.A.md -> test/fixtures/toc/markdown/headings.B.md\":[{\"span\":{\"start\":[5,1],\"end\":[5,7]},\"category\":\"Heading 2\",\"term\":\"## Two\",\"changeType\":\"added\"},{\"span\":{\"start\":[9,1],\"end\":[10,4]},\"category\":\"Heading 1\",\"term\":\"Final\",\"changeType\":\"added\"}]},\"errors\":{}}\n" :: ByteString)
+      toOutput output `shouldBe` ("{\"changes\":{\"test/fixtures/toc/markdown/headings.A.md -> test/fixtures/toc/markdown/headings.B.md\":[{\"span\":{\"start\":[5,1],\"end\":[5,7]},\"category\":\"Heading 2\",\"term\":\"## Two\",\"changeType\":\"added\"},{\"span\":{\"start\":[9,1],\"end\":[10,4]},\"category\":\"Heading 1\",\"term\":\"Final\",\"changeType\":\"added\"}]},\"errors\":{}}\n" :: ByteString)
 
 
 type Diff' = SyntaxDiff (Maybe Declaration ': DefaultFields)