Make error reporter API generic

Instead of hard-coding the HTTP API we use for uploading errors to our internal service, let the user provide an arbitrary function (in the IO monad) for uploading them. The default config will create an error reporter that logs errors to the console, just like happened before if you didn't set the `HAYSTACK_URL` environment variable.
2024-12-23 14:54:16 +03:00 · 2019-04-03 15:12:36 -04:00 · 2019-04-03 15:12:36 -04:00 · cf803555e5
commit cf803555e5
parent b2bbda5fca
12 changed files with 308 additions and 534 deletions
--- a/script/generate-example
+++ b/script/generate-example
@ -37,20 +37,20 @@ generate_example () {

  if [ -e "$fileA" ]; then
    status $parseFileA
-    cabal new-run semantic -- parse --sexpression $fileA > $parseFileA
+    cabal new-run --verbose=0 semantic -- parse --sexpression $fileA > $parseFileA
  fi

  if [ -e "$fileB" ]; then
    status $parseFileB
-    cabal new-run semantic -- parse --sexpression $fileB > $parseFileB
+    cabal new-run --verbose=0 semantic -- parse --sexpression $fileB > $parseFileB
  fi

  if [ -e "$fileA" -a -e "$fileB" ]; then
    status $diffFileAB
-    cabal new-run semantic -- diff --sexpression $fileA $fileB > $diffFileAB
+    cabal new-run --verbose=0 semantic -- diff --sexpression $fileA $fileB > $diffFileAB

    status $diffFileBA
-    cabal new-run semantic -- diff --sexpression $fileB $fileA > $diffFileBA
+    cabal new-run --verbose=0 semantic -- diff --sexpression $fileB $fileA > $diffFileBA
  fi
 }

--- a/semantic.cabal
+++ b/semantic.cabal
@ -267,7 +267,7 @@ library
                     , Semantic.Task.Files
                     , Semantic.Telemetry
                     , Semantic.Telemetry.AsyncQueue
-                     , Semantic.Telemetry.Haystack
+                     , Semantic.Telemetry.Error
                     , Semantic.Telemetry.Log
                     , Semantic.Telemetry.Stat
                     , Semantic.Timeout
--- a/src/Semantic/Config.hs
+++ b/src/Semantic/Config.hs
@ -6,7 +6,7 @@ module Semantic.Config
  , debugOptions
  , infoOptions
  , lookupStatsAddr
-  , withHaystackFromConfig
+  , withErrorReporterFromConfig
  , logOptionsFromConfig
  , withLoggerFromConfig
  , withStatterFromConfig
@ -23,12 +23,11 @@ import           Data.Duration
 import           Data.Error (LogPrintSource(..))
 import           Data.Flag
 import           Network.HostName
-import           Network.HTTP.Client.TLS
 import           Network.URI
 import           Prologue
 import           Semantic.Env
 import           Semantic.Telemetry
-import qualified Semantic.Telemetry.Haystack as Haystack
+import qualified Semantic.Telemetry.Error as Error
 import qualified Semantic.Telemetry.Stat as Stat
 import           System.Environment
 import           System.IO (hIsTerminalDevice, stdout)
@ -45,7 +44,6 @@ data 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).
@ -81,7 +79,6 @@ defaultConfig options@Options{..} = do
  pid <- getProcessID
  hostName <- getHostName
  isTerminal <- hIsTerminalDevice stdout
-  haystackURL <- lookupEnv "HAYSTACK_URL"
  (statsHost, statsPort) <- lookupStatsAddr
  size <- envLookupNum 1000 "MAX_TELEMETRY_QUEUE_SIZE"
  parseTimeout <- envLookupNum 6000 "TREE_SITTER_PARSE_TIMEOUT"
@ -90,7 +87,6 @@ defaultConfig options@Options{..} = do
    { configAppName = "semantic"
    , configHostName = hostName
    , configProcessID = pid
-    , configHaystackURL = haystackURL
    , configStatsHost = statsHost
    , configStatsPort = statsPort

@ -109,9 +105,9 @@ defaultConfig options@Options{..} = do
 withTelemetry :: Config -> (TelemetryQueues -> IO c) -> IO c
 withTelemetry config action =
  withLoggerFromConfig config $ \logger ->
-  withHaystackFromConfig config (queueLogMessage logger Error) $ \haystack ->
+  withErrorReporterFromConfig config (queueLogMessage logger Error) $ \errorReporter ->
  withStatterFromConfig config $ \statter ->
-    action (TelemetryQueues logger statter haystack)
+    action (TelemetryQueues logger statter errorReporter)

 logOptionsFromConfig :: Config -> LogOptions
 logOptionsFromConfig Config{..} = LogOptions
@ -132,9 +128,9 @@ withLoggerFromConfig :: Config -> (LogQueue -> IO c) -> IO c
 withLoggerFromConfig config = withLogger (logOptionsFromConfig config) (configMaxTelemetyQueueSize config)


-withHaystackFromConfig :: Config -> Haystack.ErrorLogger -> (HaystackQueue -> IO c) -> IO c
-withHaystackFromConfig Config{..} errorLogger =
-  withHaystack configHaystackURL tlsManagerSettings configAppName errorLogger configMaxTelemetyQueueSize
+withErrorReporterFromConfig :: Config -> Error.ErrorLogger -> (ErrorQueue -> IO c) -> IO c
+withErrorReporterFromConfig Config{..} errorLogger =
+  withErrorReporter (nullErrorReporter errorLogger) configMaxTelemetyQueueSize

 withStatterFromConfig :: Config -> (StatQueue -> IO c) -> IO c
 withStatterFromConfig Config{..} =
--- a/src/Semantic/Telemetry.hs
+++ b/src/Semantic/Telemetry.hs
@ -3,11 +3,11 @@ module Semantic.Telemetry
 (
  -- Async telemetry interface
  withLogger
-, withHaystack
+, withErrorReporter
 , withStatter
 , LogQueue
 , StatQueue
-, HaystackQueue
+, ErrorQueue
 , TelemetryQueues(..)
 , queueLogMessage
 , queueErrorReport
@ -27,9 +27,8 @@ module Semantic.Telemetry
 , statsClient
 , StatsClient

-- Haystack client
-, haystackClient
-, HaystackClient
+-- Error reporters
+, nullErrorReporter

 -- Logging options and formatters
 , Level(..)
@ -58,21 +57,20 @@ import           Control.Exception
 import           Control.Monad.IO.Class
 import qualified Data.Time.Clock.POSIX as Time (getCurrentTime)
 import qualified Data.Time.LocalTime as LocalTime
-import           Network.HTTP.Client
 import           Semantic.Telemetry.AsyncQueue
-import           Semantic.Telemetry.Haystack
+import           Semantic.Telemetry.Error
 import           Semantic.Telemetry.Log
 import           Semantic.Telemetry.Stat as Stat

 type LogQueue = AsyncQueue Message LogOptions
 type StatQueue = AsyncQueue Stat StatsClient
-type HaystackQueue = AsyncQueue ErrorReport HaystackClient
+type ErrorQueue = AsyncQueue ErrorReport ErrorReporter

 data TelemetryQueues
  = TelemetryQueues
-  { telemetryLogger   :: LogQueue
-  , telemetryStatter  :: StatQueue
-  , telemetryHaystack :: HaystackQueue
+  { telemetryLogger        :: LogQueue
+  , telemetryStatter       :: StatQueue
+  , telemetryErrorReporter :: ErrorQueue
  }

 -- | Execute an action in IO with access to a logger (async log queue).
@ -83,10 +81,10 @@ withLogger :: LogOptions         -- ^ Log options
 withLogger options size = bracket setup closeAsyncQueue
  where setup = newAsyncQueue size writeLogMessage options

-- | Execute an action in IO with access to haystack (async error reporting queue).
-withHaystack :: Maybe String -> ManagerSettings -> String -> ErrorLogger -> Int -> (HaystackQueue -> IO c) -> IO c
-withHaystack url settings appName errorLogger size = bracket setup closeAsyncQueue
-  where setup = haystackClient url settings appName >>= newAsyncQueue size (reportError errorLogger)
+-- | Execute an action in IO with access to an error reporter (async error reporting queue).
+withErrorReporter :: IO ErrorReporter -> Int -> (ErrorQueue -> IO c) -> IO c
+withErrorReporter errorReporter size = bracket setup closeAsyncQueue
+  where setup = errorReporter >>= newAsyncQueue size ($)

 -- | Execute an action in IO with access to a statter (async stat queue).
 -- Handles the bracketed setup and teardown of the underlying 'AsyncQueue' and
@ -108,8 +106,8 @@ queueLogMessage q@AsyncQueue{..} level message pairs
  , level <= logLevel = liftIO Time.getCurrentTime >>= liftIO . LocalTime.utcToLocalZonedTime >>= liftIO . writeAsyncQueue q . Message level message pairs
  | otherwise = pure ()

-- | Queue an error to be reported to haystack.
-queueErrorReport :: MonadIO io => HaystackQueue -> SomeException -> [(String, String)] -> io ()
+-- | Queue an error to be reported.
+queueErrorReport :: MonadIO io => ErrorQueue -> SomeException -> [(String, String)] -> io ()
 queueErrorReport q@AsyncQueue{..} message = liftIO . writeAsyncQueue q . ErrorReport message

 -- | Queue a stat to be sent to statsd.
--- a/src/Semantic/Telemetry/Error.hs
+++ b/src/Semantic/Telemetry/Error.hs
@ -0,0 +1,27 @@
+module Semantic.Telemetry.Error
+  ( ErrorLogger
+  , ErrorReport (..)
+  , ErrorReporter
+  , nullErrorReporter
+  ) where
+
+import           Control.Exception
+
+data ErrorReport
+  = ErrorReport
+  { errorReportException :: SomeException
+  , errorReportContext   :: [(String, String)]
+  } deriving (Show)
+
+-- | Function to log if there are errors reporting an error.
+type ErrorLogger = String -> [(String, String)] -> IO ()
+
+type ErrorReporter = ErrorReport -> IO ()
+
+-- | Doesn't send error reports anywhere.  Useful in tests or for basic command-line usage.
+nullErrorReporter :: ErrorLogger -> IO ErrorReporter
+nullErrorReporter logger = pure reportError
+  where
+    reportError ErrorReport{..} = let
+      msg = takeWhile (/= '\n') (displayException errorReportException)
+      in logger msg errorReportContext
--- a/src/Semantic/Telemetry/Haystack.hs
+++ b/src/Semantic/Telemetry/Haystack.hs
@ -1,82 +0,0 @@
-module Semantic.Telemetry.Haystack
-  ( HaystackClient (..)
-  , ErrorReport (..)
-  , ErrorLogger
-  , haystackClient
-  , reportError
-  ) where
-
-import           Control.Exception
-import           Crypto.Hash
-import           Data.Aeson hiding (Error)
-import qualified Data.ByteString.Char8 as BC
-import           Data.List (intercalate)
-import qualified Data.Text as Text
-import qualified Data.Text.Encoding as Text
-import           GHC.Exts (currentCallStack)
-import           Network.HTTP.Client
-import           Network.HTTP.Types.Status (statusCode)
-import           Prologue hiding (hash)
-import           System.IO.Error
-
-data ErrorReport
-  = ErrorReport
-  { errorReportException :: SomeException
-  , errorReportContext   :: [(String, String)]
-  } deriving (Show)
-
-data HaystackClient
-  = HaystackClient
-  { haystackClientRequest  :: Request
-  , haystackClientManager  :: Manager
-  , haystackClientAppName  :: String
-  }                    -- ^ Standard HTTP client for Haystack
-  | NullHaystackClient -- ^ Doesn't report needles, good for testing or when the 'HAYSTACK_URL' env var isn't set.
-
-- | Function to log if there are errors reporting to haystack.
-type ErrorLogger = String -> [(String, String)] -> IO ()
-
-- Create a Haystack HTTP client.
-haystackClient :: Maybe String -> ManagerSettings -> String -> IO HaystackClient
-haystackClient maybeURL managerSettings appName
-  | Just url <- maybeURL = do
-      manager  <- newManager managerSettings
-      request' <- parseRequest url
-      let request = request'
-            { method = "POST"
-            , requestHeaders = ("Content-Type", "application/json; charset=utf-8") : requestHeaders request'
-            }
-      pure $ HaystackClient request manager appName
-  | otherwise = pure NullHaystackClient
-
-- Report an error to Haystack over HTTP (blocking).
-reportError :: ErrorLogger -> HaystackClient -> ErrorReport -> IO ()
-reportError logger NullHaystackClient ErrorReport{..} = let msg = takeWhile (/= '\n') (displayException errorReportException) in logger msg errorReportContext
-reportError logger HaystackClient{..} ErrorReport{..} = do
-  bt <- fmap (intercalate "\n") currentCallStack
-  let fullMsg = displayException errorReportException
-  let summary = takeWhile (/= '\n') fullMsg
-  logger summary errorReportContext
-  let payload = object $
-        [ "app"       .= haystackClientAppName
-        , "message"   .= fullMsg
-        , "class"     .= summary
-        , "backtrace" .= bt
-        , "rollup"    .= rollup fullMsg
-        ] <> foldr (\(k, v) acc -> Text.pack k .= v : acc) [] errorReportContext
-  let request = haystackClientRequest { requestBody = RequestBodyLBS (encode payload) }
-
-  response <- tryIOError $ httpLbs request haystackClientManager
-  case response of
-    Left e -> logger ("Failed to report error to haystack: " <> displayException e) []
-    Right response -> do
-      let status = statusCode (responseStatus response)
-      if status /= 201
-        then logger ("Failed to report error to haystack, status=" <> show status <> ".") []
-        else pure ()
-  where
-    rollup :: String -> Text
-    rollup = Text.decodeUtf8 . digestToHexByteString . md5 . BC.pack
-
-    md5 :: ByteString -> Digest MD5
-    md5 = hash
--- a/test/fixtures/haskell/corpus/function-declarations.A.hs
+++ b/test/fixtures/haskell/corpus/function-declarations.A.hs
@ -147,13 +147,8 @@ ifte :: ( IvoryStore a
          -> Ivory eff a
          -> Ivory eff a

-haystackClient maybeURL managerSettings appName
-  | Just url <- maybeURL = do
-      manager  <- newManager managerSettings
-      request' <- parseRequest url
-      let request = request'
-            { method = "POST"
-            , requestHeaders = ("Content-Type", "application/json; charset=utf-8") : requestHeaders request'
-            }
-      pure $ HaystackClient request manager appName
-  | otherwise = pure NullHaystackClient
+nullErrorReporter logger = pure reportError
+  where
+    reportError ErrorReport{..} = let
+      msg = takeWhile (/= '\n') (displayException errorReportException)
+      in logger msg errorReportContext
--- a/test/fixtures/haskell/corpus/function-declarations.B.hs
+++ b/test/fixtures/haskell/corpus/function-declarations.B.hs
@ -148,13 +148,8 @@ g :: ( IvoryStore a
       -> Ivory eff a
       -> Ivory eff a

-needlestackClient maybeURL directorSettings appName
-  | Just url <- maybeURL = do
-      director  <- newDirector directorSettings
-      request' <- parseRequest url
-      let request = request'
-            { method = "POST"
-            , requestHeaders = ("Content-Type", "application/json; charset=utf-8") : requestHeaders request'
-            }
-      pure $ NeedlestackClient request director appName
-  | otherwise = pure NullNeedlestackClient
+emptyErrorReporter logger = pure reportError
+  where
+    reportError ErrorReport{..} = let
+      msg = takeWhile (/= '\n') (displayException errorReportException)
+      in logger msg errorReportContext
--- a/test/fixtures/haskell/corpus/function-declarations.diffA-B.txt
+++ b/test/fixtures/haskell/corpus/function-declarations.diffA-B.txt
@ -655,21 +655,23 @@
  {-(Function
    {-(VariableIdentifier)-}
    {-(Statements
-      {-(App
-        {-(VariableIdentifier)-}
-        {-(TypeApp
-          {-(ConstructorIdentifier)-})-}
-        {-(TextElement)-})-})-})-}
+      {-(VariableIdentifier)-}
+      {-(TypeApp
+        {-(ConstructorPattern
+          {-(Statements
+            {-(ConstructorIdentifier)-}
+            {-(TextElement)-})-})-})-})-})-}
  {-(Function
    {-(VariableIdentifier)-}
    {-(Statements
-      {-(App
-        {-(VariableIdentifier)-}
-        {-(TypeApp
-          {-(QualifiedConstructorIdentifier
-            {-(ModuleIdentifier)-}
-            {-(ConstructorIdentifier)-})-})-}
-        {-(TextElement)-})-})-})-}
+      {-(VariableIdentifier)-}
+      {-(TypeApp
+        {-(ConstructorPattern
+          {-(Statements
+            {-(QualifiedConstructorIdentifier
+              {-(ModuleIdentifier)-}
+              {-(ConstructorIdentifier)-})-}
+            {-(TextElement)-})-})-})-})-})-}
  {-(Function
    {-(VariableIdentifier)-}
    {-(Statements
@ -1627,21 +1629,23 @@
  {+(Function
    {+(VariableIdentifier)+}
    {+(Statements
-      {+(App
-        {+(VariableIdentifier)+}
-        {+(TypeApp
-          {+(ConstructorIdentifier)+})+}
-        {+(TextElement)+})+})+})+}
+      {+(VariableIdentifier)+}
+      {+(TypeApp
+        {+(ConstructorPattern
+          {+(Statements
+            {+(ConstructorIdentifier)+}
+            {+(TextElement)+})+})+})+})+})+}
  {+(Function
    {+(VariableIdentifier)+}
    {+(Statements
-      {+(App
-        {+(VariableIdentifier)+}
-        {+(TypeApp
-          {+(QualifiedConstructorIdentifier
-            {+(ModuleIdentifier)+}
-            {+(ConstructorIdentifier)+})+})+}
-        {+(TextElement)+})+})+})+}
+      {+(VariableIdentifier)+}
+      {+(TypeApp
+        {+(ConstructorPattern
+          {+(Statements
+            {+(QualifiedConstructorIdentifier
+              {+(ModuleIdentifier)+}
+              {+(ConstructorIdentifier)+})+}
+            {+(TextElement)+})+})+})+})+})+}
  {+(Function
    {+(VariableIdentifier)+}
    {+(Statements
@ -1958,7 +1962,7 @@
    (TypeSignature
    { (VariableIdentifier)
    ->(VariableIdentifier) }
-      (Context'
+      (ContextAlt
        (TypeSignature
          (ImplicitParameterIdentifier)
          (FunctionType
@ -2021,7 +2025,7 @@
    (TypeSignature
    { (VariableIdentifier)
    ->(VariableIdentifier) }
-      (Context'
+      (ContextAlt
        (Statements
          (Class
            (TypeClassIdentifier)
@ -2067,81 +2071,42 @@
              (Empty))))))
    (Function
    { (VariableIdentifier)
-    ->(VariableIdentifier) }
-      (VariableIdentifier)
-    { (VariableIdentifier)
    ->(VariableIdentifier) }
      (VariableIdentifier)
      (Statements
-        (FunctionGuardPattern
-          (Guard
-            (PatternGuard
-              (ConstructorPattern
-                (Statements
-                  (ConstructorIdentifier)
-                  (VariableIdentifier)))
-              (VariableIdentifier)))
-          (Do
-            (BindPattern
-            { (VariableIdentifier)
-            ->(VariableIdentifier) }
-              (App
-              { (VariableIdentifier)
-              ->(VariableIdentifier) }
-                (Empty)
-              { (VariableIdentifier)
-              ->(VariableIdentifier) }))
-            (BindPattern
-              (VariableIdentifier)
-              (App
-                (VariableIdentifier)
-                (Empty)
-                (VariableIdentifier)))
-            (Let
-              (Function
-                (VariableIdentifier)
-                (Statements
-                  (LabeledUpdate
-                    (VariableIdentifier)
-                    (FieldBind
-                      (VariableIdentifier)
-                      (TextElement))
-                    (FieldBind
-                      (VariableIdentifier)
-                      (InfixOperatorApp
-                        (Tuple
-                          (TextElement)
-                          (TextElement))
+        (App
+          (VariableIdentifier)
+          (Empty)
+          (VariableIdentifier))
+        (Statements
+          (Function
+            (VariableIdentifier)
+            (LabeledPattern
+              (Statements
+                (ConstructorIdentifier)
+                (RecordWildCards)))
+            (Statements
+              (Let
+                (Function
+                  (VariableIdentifier)
+                  (Statements
+                    (App
+                      (App
+                        (VariableIdentifier)
                        (Empty)
-                        (ConstructorOperator
-                          (ConstructorSymbol))
-                        (App
-                          (VariableIdentifier)
-                          (Empty)
-                          (VariableIdentifier)))))))
-              (Empty))
-            (InfixOperatorApp
-              (VariableIdentifier)
-              (Empty)
-              (VariableOperator
-                (VariableSymbol))
-              (App
+                        (RightOperatorSection
+                          (VariableOperator
+                            (VariableSymbol))
+                          (Character)))
+                      (Empty)
+                      (App
+                        (VariableIdentifier)
+                        (Empty)
+                        (VariableIdentifier)))))
                (App
                  (App
-                  { (ConstructorIdentifier)
-                  ->(ConstructorIdentifier) }
+                    (VariableIdentifier)
                    (Empty)
                    (VariableIdentifier))
                  (Empty)
-                { (VariableIdentifier)
-                ->(VariableIdentifier) })
-                (Empty)
-                (VariableIdentifier)))))
-        (FunctionGuardPattern
-          (Guard
-            (VariableIdentifier))
-          (App
-            (VariableIdentifier)
-            (Empty)
-          { (ConstructorIdentifier)
-          ->(ConstructorIdentifier) }))))))
+                  (VariableIdentifier))))))))))
--- a/test/fixtures/haskell/corpus/function-declarations.diffB-A.txt
+++ b/test/fixtures/haskell/corpus/function-declarations.diffB-A.txt
@ -1011,21 +1011,23 @@
  {+(Function
    {+(VariableIdentifier)+}
    {+(Statements
-      {+(App
-        {+(VariableIdentifier)+}
-        {+(TypeApp
-          {+(ConstructorIdentifier)+})+}
-        {+(TextElement)+})+})+})+}
+      {+(VariableIdentifier)+}
+      {+(TypeApp
+        {+(ConstructorPattern
+          {+(Statements
+            {+(ConstructorIdentifier)+}
+            {+(TextElement)+})+})+})+})+})+}
  {+(Function
    {+(VariableIdentifier)+}
    {+(Statements
-      {+(App
-        {+(VariableIdentifier)+}
-        {+(TypeApp
-          {+(QualifiedConstructorIdentifier
-            {+(ModuleIdentifier)+}
-            {+(ConstructorIdentifier)+})+})+}
-        {+(TextElement)+})+})+})+}
+      {+(VariableIdentifier)+}
+      {+(TypeApp
+        {+(ConstructorPattern
+          {+(Statements
+            {+(QualifiedConstructorIdentifier
+              {+(ModuleIdentifier)+}
+              {+(ConstructorIdentifier)+})+}
+            {+(TextElement)+})+})+})+})+})+}
  {+(Function
    {+(VariableIdentifier)+}
    {+(Statements
@ -1500,7 +1502,7 @@
      {+(VariableIdentifier)+})+})+}
  {+(TypeSignature
    {+(VariableIdentifier)+}
-    {+(Context'
+    {+(ContextAlt
      {+(TypeSignature
        {+(ImplicitParameterIdentifier)+}
        {+(FunctionType
@ -1558,7 +1560,7 @@
      {+(VariableIdentifier)+})+})+}
  {+(TypeSignature
    {+(VariableIdentifier)+}
-    {+(Context'
+    {+(ContextAlt
      {+(Statements
        {+(Class
          {+(TypeClassIdentifier)+}
@ -1603,77 +1605,45 @@
              {+(TypeVariableIdentifier)+})+}
            {+(Empty)+})+})+})+})+})+}
  {+(Function
-    {+(VariableIdentifier)+}
-    {+(VariableIdentifier)+}
    {+(VariableIdentifier)+}
    {+(VariableIdentifier)+}
    {+(Statements
-      {+(FunctionGuardPattern
-        {+(Guard
-          {+(PatternGuard
-            {+(ConstructorPattern
-              {+(Statements
-                {+(ConstructorIdentifier)+}
-                {+(VariableIdentifier)+})+})+}
-            {+(VariableIdentifier)+})+})+}
-        {+(Do
-          {+(BindPattern
-            {+(VariableIdentifier)+}
-            {+(App
-              {+(VariableIdentifier)+}
-              {+(Empty)+}
-              {+(VariableIdentifier)+})+})+}
-          {+(BindPattern
-            {+(VariableIdentifier)+}
-            {+(App
-              {+(VariableIdentifier)+}
-              {+(Empty)+}
-              {+(VariableIdentifier)+})+})+}
-          {+(Let
-            {+(Function
-              {+(VariableIdentifier)+}
-              {+(Statements
-                {+(LabeledUpdate
-                  {+(VariableIdentifier)+}
-                  {+(FieldBind
-                    {+(VariableIdentifier)+}
-                    {+(TextElement)+})+}
-                  {+(FieldBind
-                    {+(VariableIdentifier)+}
-                    {+(InfixOperatorApp
-                      {+(Tuple
-                        {+(TextElement)+}
-                        {+(TextElement)+})+}
+      {+(App
+        {+(VariableIdentifier)+}
+        {+(Empty)+}
+        {+(VariableIdentifier)+})+}
+      {+(Statements
+        {+(Function
+          {+(VariableIdentifier)+}
+          {+(LabeledPattern
+            {+(Statements
+              {+(ConstructorIdentifier)+}
+              {+(RecordWildCards)+})+})+}
+          {+(Statements
+            {+(Let
+              {+(Function
+                {+(VariableIdentifier)+}
+                {+(Statements
+                  {+(App
+                    {+(App
+                      {+(VariableIdentifier)+}
                      {+(Empty)+}
-                      {+(ConstructorOperator
-                        {+(ConstructorSymbol)+})+}
-                      {+(App
-                        {+(VariableIdentifier)+}
-                        {+(Empty)+}
-                        {+(VariableIdentifier)+})+})+})+})+})+})+}
-            {+(Empty)+})+}
-          {+(InfixOperatorApp
-            {+(VariableIdentifier)+}
-            {+(Empty)+}
-            {+(VariableOperator
-              {+(VariableSymbol)+})+}
-            {+(App
+                      {+(RightOperatorSection
+                        {+(VariableOperator
+                          {+(VariableSymbol)+})+}
+                        {+(Character)+})+})+}
+                    {+(Empty)+}
+                    {+(App
+                      {+(VariableIdentifier)+}
+                      {+(Empty)+}
+                      {+(VariableIdentifier)+})+})+})+})+}
              {+(App
                {+(App
-                  {+(ConstructorIdentifier)+}
+                  {+(VariableIdentifier)+}
                  {+(Empty)+}
                  {+(VariableIdentifier)+})+}
                {+(Empty)+}
-                {+(VariableIdentifier)+})+}
-              {+(Empty)+}
-              {+(VariableIdentifier)+})+})+})+})+}
-      {+(FunctionGuardPattern
-        {+(Guard
-          {+(VariableIdentifier)+})+}
-        {+(App
-          {+(VariableIdentifier)+}
-          {+(Empty)+}
-          {+(ConstructorIdentifier)+})+})+})+})+}
+                {+(VariableIdentifier)+})+})+})+})+})+})+})+}
  {-(Function
    {-(VariableIdentifier)-}
    {-(VariableIdentifier)-}
@ -1796,21 +1766,23 @@
  {-(Function
    {-(VariableIdentifier)-}
    {-(Statements
-      {-(App
-        {-(VariableIdentifier)-}
-        {-(TypeApp
-          {-(ConstructorIdentifier)-})-}
-        {-(TextElement)-})-})-})-}
+      {-(VariableIdentifier)-}
+      {-(TypeApp
+        {-(ConstructorPattern
+          {-(Statements
+            {-(ConstructorIdentifier)-}
+            {-(TextElement)-})-})-})-})-})-}
  {-(Function
    {-(VariableIdentifier)-}
    {-(Statements
-      {-(App
-        {-(VariableIdentifier)-}
-        {-(TypeApp
-          {-(QualifiedConstructorIdentifier
-            {-(ModuleIdentifier)-}
-            {-(ConstructorIdentifier)-})-})-}
-        {-(TextElement)-})-})-})-}
+      {-(VariableIdentifier)-}
+      {-(TypeApp
+        {-(ConstructorPattern
+          {-(Statements
+            {-(QualifiedConstructorIdentifier
+              {-(ModuleIdentifier)-}
+              {-(ConstructorIdentifier)-})-}
+            {-(TextElement)-})-})-})-})-})-}
  {-(Function
    {-(VariableIdentifier)-}
    {-(Statements
@ -2126,7 +2098,7 @@
      {-(VariableIdentifier)-})-})-}
  {-(TypeSignature
    {-(VariableIdentifier)-}
-    {-(Context'
+    {-(ContextAlt
      {-(TypeSignature
        {-(ImplicitParameterIdentifier)-}
        {-(FunctionType
@ -2184,7 +2156,7 @@
      {-(VariableIdentifier)-})-})-}
  {-(TypeSignature
    {-(VariableIdentifier)-}
-    {-(Context'
+    {-(ContextAlt
      {-(Statements
        {-(Class
          {-(TypeClassIdentifier)-}
@ -2229,74 +2201,42 @@
              {-(TypeVariableIdentifier)-})-}
            {-(Empty)-})-})-})-})-})-}
  {-(Function
-    {-(VariableIdentifier)-}
-    {-(VariableIdentifier)-}
    {-(VariableIdentifier)-}
    {-(VariableIdentifier)-}
    {-(Statements
-      {-(FunctionGuardPattern
-        {-(Guard
-          {-(PatternGuard
-            {-(ConstructorPattern
-              {-(Statements
-                {-(ConstructorIdentifier)-}
-                {-(VariableIdentifier)-})-})-}
-            {-(VariableIdentifier)-})-})-}
-        {-(Do
-          {-(BindPattern
-            {-(VariableIdentifier)-}
-            {-(App
-              {-(VariableIdentifier)-}
-              {-(Empty)-}
-              {-(VariableIdentifier)-})-})-}
-          {-(BindPattern
-            {-(VariableIdentifier)-}
-            {-(App
-              {-(VariableIdentifier)-}
-              {-(Empty)-}
-              {-(VariableIdentifier)-})-})-}
-          {-(Let
-            {-(Function
-              {-(VariableIdentifier)-}
-              {-(Statements
-                {-(LabeledUpdate
-                  {-(VariableIdentifier)-}
-                  {-(FieldBind
-                    {-(VariableIdentifier)-}
-                    {-(TextElement)-})-}
-                  {-(FieldBind
-                    {-(VariableIdentifier)-}
-                    {-(InfixOperatorApp
-                      {-(Tuple
-                        {-(TextElement)-}
-                        {-(TextElement)-})-}
+      {-(App
+        {-(VariableIdentifier)-}
+        {-(Empty)-}
+        {-(VariableIdentifier)-})-}
+      {-(Statements
+        {-(Function
+          {-(VariableIdentifier)-}
+          {-(LabeledPattern
+            {-(Statements
+              {-(ConstructorIdentifier)-}
+              {-(RecordWildCards)-})-})-}
+          {-(Statements
+            {-(Let
+              {-(Function
+                {-(VariableIdentifier)-}
+                {-(Statements
+                  {-(App
+                    {-(App
+                      {-(VariableIdentifier)-}
                      {-(Empty)-}
-                      {-(ConstructorOperator
-                        {-(ConstructorSymbol)-})-}
-                      {-(App
-                        {-(VariableIdentifier)-}
-                        {-(Empty)-}
-                        {-(VariableIdentifier)-})-})-})-})-})-})-}
-            {-(Empty)-})-}
-          {-(InfixOperatorApp
-            {-(VariableIdentifier)-}
-            {-(Empty)-}
-            {-(VariableOperator
-              {-(VariableSymbol)-})-}
-            {-(App
+                      {-(RightOperatorSection
+                        {-(VariableOperator
+                          {-(VariableSymbol)-})-}
+                        {-(Character)-})-})-}
+                    {-(Empty)-}
+                    {-(App
+                      {-(VariableIdentifier)-}
+                      {-(Empty)-}
+                      {-(VariableIdentifier)-})-})-})-})-}
              {-(App
                {-(App
-                  {-(ConstructorIdentifier)-}
+                  {-(VariableIdentifier)-}
                  {-(Empty)-}
                  {-(VariableIdentifier)-})-}
                {-(Empty)-}
-                {-(VariableIdentifier)-})-}
-              {-(Empty)-}
-              {-(VariableIdentifier)-})-})-})-})-}
-      {-(FunctionGuardPattern
-        {-(Guard
-          {-(VariableIdentifier)-})-}
-        {-(App
-          {-(VariableIdentifier)-}
-          {-(Empty)-}
-          {-(ConstructorIdentifier)-})-})-})-})-}))
+                {-(VariableIdentifier)-})-})-})-})-})-})-})-}))
--- a/test/fixtures/haskell/corpus/function-declarations.parseA.txt
+++ b/test/fixtures/haskell/corpus/function-declarations.parseA.txt
@ -652,21 +652,23 @@
    (Function
      (VariableIdentifier)
      (Statements
-        (App
-          (VariableIdentifier)
-          (TypeApp
-            (ConstructorIdentifier))
-          (TextElement))))
+        (VariableIdentifier)
+        (TypeApp
+          (ConstructorPattern
+            (Statements
+              (ConstructorIdentifier)
+              (TextElement))))))
    (Function
      (VariableIdentifier)
      (Statements
-        (App
-          (VariableIdentifier)
-          (TypeApp
-            (QualifiedConstructorIdentifier
-              (ModuleIdentifier)
-              (ConstructorIdentifier)))
-          (TextElement))))
+        (VariableIdentifier)
+        (TypeApp
+          (ConstructorPattern
+            (Statements
+              (QualifiedConstructorIdentifier
+                (ModuleIdentifier)
+                (ConstructorIdentifier))
+              (TextElement))))))
    (Function
      (VariableIdentifier)
      (Statements
@ -982,7 +984,7 @@
        (VariableIdentifier)))
    (TypeSignature
      (VariableIdentifier)
-      (Context'
+      (ContextAlt
        (TypeSignature
          (ImplicitParameterIdentifier)
          (FunctionType
@ -1040,7 +1042,7 @@
        (VariableIdentifier)))
    (TypeSignature
      (VariableIdentifier)
-      (Context'
+      (ContextAlt
        (Statements
          (Class
            (TypeClassIdentifier)
@ -1085,74 +1087,42 @@
                (TypeVariableIdentifier))
              (Empty))))))
    (Function
-      (VariableIdentifier)
-      (VariableIdentifier)
      (VariableIdentifier)
      (VariableIdentifier)
      (Statements
-        (FunctionGuardPattern
-          (Guard
-            (PatternGuard
-              (ConstructorPattern
-                (Statements
-                  (ConstructorIdentifier)
-                  (VariableIdentifier)))
-              (VariableIdentifier)))
-          (Do
-            (BindPattern
-              (VariableIdentifier)
-              (App
-                (VariableIdentifier)
-                (Empty)
-                (VariableIdentifier)))
-            (BindPattern
-              (VariableIdentifier)
-              (App
-                (VariableIdentifier)
-                (Empty)
-                (VariableIdentifier)))
-            (Let
-              (Function
-                (VariableIdentifier)
-                (Statements
-                  (LabeledUpdate
-                    (VariableIdentifier)
-                    (FieldBind
-                      (VariableIdentifier)
-                      (TextElement))
-                    (FieldBind
-                      (VariableIdentifier)
-                      (InfixOperatorApp
-                        (Tuple
-                          (TextElement)
-                          (TextElement))
+        (App
+          (VariableIdentifier)
+          (Empty)
+          (VariableIdentifier))
+        (Statements
+          (Function
+            (VariableIdentifier)
+            (LabeledPattern
+              (Statements
+                (ConstructorIdentifier)
+                (RecordWildCards)))
+            (Statements
+              (Let
+                (Function
+                  (VariableIdentifier)
+                  (Statements
+                    (App
+                      (App
+                        (VariableIdentifier)
                        (Empty)
-                        (ConstructorOperator
-                          (ConstructorSymbol))
-                        (App
-                          (VariableIdentifier)
-                          (Empty)
-                          (VariableIdentifier)))))))
-              (Empty))
-            (InfixOperatorApp
-              (VariableIdentifier)
-              (Empty)
-              (VariableOperator
-                (VariableSymbol))
-              (App
+                        (RightOperatorSection
+                          (VariableOperator
+                            (VariableSymbol))
+                          (Character)))
+                      (Empty)
+                      (App
+                        (VariableIdentifier)
+                        (Empty)
+                        (VariableIdentifier)))))
                (App
                  (App
-                    (ConstructorIdentifier)
+                    (VariableIdentifier)
                    (Empty)
                    (VariableIdentifier))
                  (Empty)
-                  (VariableIdentifier))
-                (Empty)
-                (VariableIdentifier)))))
-        (FunctionGuardPattern
-          (Guard
-            (VariableIdentifier))
-          (App
-            (VariableIdentifier)
-            (Empty)
-            (ConstructorIdentifier)))))))
+                  (VariableIdentifier))))))))))
--- a/test/fixtures/haskell/corpus/function-declarations.parseB.txt
+++ b/test/fixtures/haskell/corpus/function-declarations.parseB.txt
@ -664,21 +664,23 @@
    (Function
      (VariableIdentifier)
      (Statements
-        (App
-          (VariableIdentifier)
-          (TypeApp
-            (ConstructorIdentifier))
-          (TextElement))))
+        (VariableIdentifier)
+        (TypeApp
+          (ConstructorPattern
+            (Statements
+              (ConstructorIdentifier)
+              (TextElement))))))
    (Function
      (VariableIdentifier)
      (Statements
-        (App
-          (VariableIdentifier)
-          (TypeApp
-            (QualifiedConstructorIdentifier
-              (ModuleIdentifier)
-              (ConstructorIdentifier)))
-          (TextElement))))
+        (VariableIdentifier)
+        (TypeApp
+          (ConstructorPattern
+            (Statements
+              (QualifiedConstructorIdentifier
+                (ModuleIdentifier)
+                (ConstructorIdentifier))
+              (TextElement))))))
    (Function
      (VariableIdentifier)
      (Statements
@ -994,7 +996,7 @@
        (VariableIdentifier)))
    (TypeSignature
      (VariableIdentifier)
-      (Context'
+      (ContextAlt
        (TypeSignature
          (ImplicitParameterIdentifier)
          (FunctionType
@ -1052,7 +1054,7 @@
        (VariableIdentifier)))
    (TypeSignature
      (VariableIdentifier)
-      (Context'
+      (ContextAlt
        (Statements
          (Class
            (TypeClassIdentifier)
@ -1097,74 +1099,42 @@
                (TypeVariableIdentifier))
              (Empty))))))
    (Function
-      (VariableIdentifier)
-      (VariableIdentifier)
      (VariableIdentifier)
      (VariableIdentifier)
      (Statements
-        (FunctionGuardPattern
-          (Guard
-            (PatternGuard
-              (ConstructorPattern
-                (Statements
-                  (ConstructorIdentifier)
-                  (VariableIdentifier)))
-              (VariableIdentifier)))
-          (Do
-            (BindPattern
-              (VariableIdentifier)
-              (App
-                (VariableIdentifier)
-                (Empty)
-                (VariableIdentifier)))
-            (BindPattern
-              (VariableIdentifier)
-              (App
-                (VariableIdentifier)
-                (Empty)
-                (VariableIdentifier)))
-            (Let
-              (Function
-                (VariableIdentifier)
-                (Statements
-                  (LabeledUpdate
-                    (VariableIdentifier)
-                    (FieldBind
-                      (VariableIdentifier)
-                      (TextElement))
-                    (FieldBind
-                      (VariableIdentifier)
-                      (InfixOperatorApp
-                        (Tuple
-                          (TextElement)
-                          (TextElement))
+        (App
+          (VariableIdentifier)
+          (Empty)
+          (VariableIdentifier))
+        (Statements
+          (Function
+            (VariableIdentifier)
+            (LabeledPattern
+              (Statements
+                (ConstructorIdentifier)
+                (RecordWildCards)))
+            (Statements
+              (Let
+                (Function
+                  (VariableIdentifier)
+                  (Statements
+                    (App
+                      (App
+                        (VariableIdentifier)
                        (Empty)
-                        (ConstructorOperator
-                          (ConstructorSymbol))
-                        (App
-                          (VariableIdentifier)
-                          (Empty)
-                          (VariableIdentifier)))))))
-              (Empty))
-            (InfixOperatorApp
-              (VariableIdentifier)
-              (Empty)
-              (VariableOperator
-                (VariableSymbol))
-              (App
+                        (RightOperatorSection
+                          (VariableOperator
+                            (VariableSymbol))
+                          (Character)))
+                      (Empty)
+                      (App
+                        (VariableIdentifier)
+                        (Empty)
+                        (VariableIdentifier)))))
                (App
                  (App
-                    (ConstructorIdentifier)
+                    (VariableIdentifier)
                    (Empty)
                    (VariableIdentifier))
                  (Empty)
-                  (VariableIdentifier))
-                (Empty)
-                (VariableIdentifier)))))
-        (FunctionGuardPattern
-          (Guard
-            (VariableIdentifier))
-          (App
-            (VariableIdentifier)
-            (Empty)
-            (ConstructorIdentifier)))))))
+                  (VariableIdentifier))))))))))