improve query logging and top-level exception printing

codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs

@@ -226,7 +226,6 @@ data Error
   = DecodeError DecodeError ByteString ErrString
   deriving stock (Show)
   deriving anyclass (SqliteExceptionReason)
--- instance Exception Error -- FIXME this came from trunk
 
 newtype NeedTypeForBuiltinMetadata
   = NeedTypeForBuiltinMetadata Text

lib/unison-sqlite/src/Unison/Sqlite/Connection.hs

@@ -65,27 +65,15 @@ where
 import Data.Bifunctor (bimap)
 import qualified Database.SQLite.Simple as Sqlite
 import qualified Database.SQLite.Simple.FromField as Sqlite
-import qualified Database.SQLite3.Direct as Sqlite (Database (..))
 import Debug.RecoverRTTI (anythingToString)
-import Unison.Debug (debugLogM, debugM)
 import qualified Unison.Debug as Debug
 import Unison.Prelude
+import Unison.Sqlite.Connection.Internal (Connection (..))
 import Unison.Sqlite.Exception
 import Unison.Sqlite.Sql
 import UnliftIO (MonadUnliftIO, withRunInIO)
 import UnliftIO.Exception
 
--- | A /non-thread safe/ connection to a SQLite database.
-data Connection = Connection
-  { name :: String,
-    file :: FilePath,
-    conn :: Sqlite.Connection
-  }
-
-instance Show Connection where
-  show (Connection name file (Sqlite.Connection (Sqlite.Database conn))) =
-    "Connection " ++ show name ++ " " ++ show file ++ " " ++ show conn
-
 -- | Perform an action with a connection to a SQLite database.
 --
 -- Note: the connection is created with @PRAGMA foreign_keys = ON@ automatically, to work around the fact that SQLite
@@ -124,13 +112,33 @@ closeConnection (Connection _ _ conn) =
   --   2. Always ignore exceptions thrown by `close` (Mitchell prefers this one)
   Sqlite.close conn
 
+-- An internal type, for making prettier debug logs
+
+data Query = Query
+  { sql :: Sql,
+    params :: Maybe String,
+    result :: Maybe String
+  }
+
+instance Show Query where
+  show Query {sql, params, result} =
+    concat
+      [ "Query { sql = ",
+        show sql,
+        maybe "" (\p -> ", params = " ++ show p) params,
+        maybe "" (\r -> ", results = " ++ show r) result,
+        " }"
+      ]
+
+logQuery :: Sql -> Maybe a -> Maybe b -> IO ()
+logQuery sql params result =
+  Debug.debugM Debug.Sqlite "SQL query" (Query sql (anythingToString <$> params) (anythingToString <$> result))
+
 -- Without results, with parameters
 
 execute :: Sqlite.ToRow a => Connection -> Sql -> a -> IO ()
 execute conn@(Connection _ _ conn0) s params = do
-  debugM Debug.Sqlite "query" s
-  debugM Debug.Sqlite "params" (anythingToString params)
-  debugLogM Debug.Sqlite "----------"
+  logQuery s (Just params) Nothing
   Sqlite.execute conn0 (coerce s) params `catch` \(exception :: Sqlite.SQLError) ->
     throwSqliteQueryException
       SqliteQueryExceptionInfo
@@ -142,9 +150,7 @@ execute conn@(Connection _ _ conn0) s params = do
 
 executeMany :: Sqlite.ToRow a => Connection -> Sql -> [a] -> IO ()
 executeMany conn@(Connection _ _ conn0) s params = do
-  debugM Debug.Sqlite "query" s
-  debugM Debug.Sqlite "params" (anythingToString params)
-  debugLogM Debug.Sqlite "----------"
+  logQuery s (Just params) Nothing
   Sqlite.executeMany conn0 (coerce s) params `catch` \(exception :: Sqlite.SQLError) ->
     throwSqliteQueryException
       SqliteQueryExceptionInfo
@@ -158,8 +164,7 @@ executeMany conn@(Connection _ _ conn0) s params = do
 
 execute_ :: Connection -> Sql -> IO ()
 execute_ conn@(Connection _ _ conn0) s = do
-  debugM Debug.Sqlite "query" s
-  debugLogM Debug.Sqlite "----------"
+  logQuery s Nothing Nothing
   Sqlite.execute_ conn0 (coerce s) `catch` \(exception :: Sqlite.SQLError) ->
     throwSqliteQueryException
       SqliteQueryExceptionInfo
@@ -172,23 +177,19 @@ execute_ conn@(Connection _ _ conn0) s = do
 -- With results, with parameters, without checks
 
 queryListRow :: (Sqlite.FromRow b, Sqlite.ToRow a) => Connection -> Sql -> a -> IO [b]
-queryListRow conn@(Connection _ _ conn0) s params =
-  doQueryListRow `catch` \(exception :: Sqlite.SQLError) ->
-    throwSqliteQueryException
-      SqliteQueryExceptionInfo
-        { connection = conn,
-          exception = SomeSqliteExceptionReason exception,
-          params = Just params,
-          sql = s
-        }
-  where
-    doQueryListRow = do
-      debugM Debug.Sqlite "query" s
-      debugM Debug.Sqlite "params" (anythingToString params)
-      result <- Sqlite.query conn0 (coerce s) params
-      debugM Debug.Sqlite "result" (anythingToString result)
-      debugLogM Debug.Sqlite "----------"
-      pure result
+queryListRow conn@(Connection _ _ conn0) s params = do
+  result <-
+    Sqlite.query conn0 (coerce s) params
+      `catch` \(exception :: Sqlite.SQLError) ->
+        throwSqliteQueryException
+          SqliteQueryExceptionInfo
+            { connection = conn,
+              exception = SomeSqliteExceptionReason exception,
+              params = Just params,
+              sql = s
+            }
+  logQuery s (Just params) (Just result)
+  pure result
 
 queryListCol :: forall a b. (Sqlite.FromField b, Sqlite.ToRow a) => Connection -> Sql -> a -> IO [b]
 queryListCol conn s params =
@@ -308,22 +309,19 @@ queryOneColCheck conn s params check =
 -- With results, without parameters, without checks
 
 queryListRow_ :: Sqlite.FromRow a => Connection -> Sql -> IO [a]
-queryListRow_ conn@(Connection _ _ conn0) s =
-  doQueryListRow_ `catch` \(exception :: Sqlite.SQLError) ->
-    throwSqliteQueryException
-      SqliteQueryExceptionInfo
-        { connection = conn,
-          exception = SomeSqliteExceptionReason exception,
-          params = Nothing,
-          sql = s
-        }
-  where
-    doQueryListRow_ = do
-      debugM Debug.Sqlite "query" s
-      result <- Sqlite.query_ conn0 (coerce s)
-      debugM Debug.Sqlite "result" (anythingToString result)
-      debugLogM Debug.Sqlite "----------"
-      pure result
+queryListRow_ conn@(Connection _ _ conn0) s = do
+  result <-
+    Sqlite.query_ conn0 (coerce s)
+      `catch` \(exception :: Sqlite.SQLError) ->
+        throwSqliteQueryException
+          SqliteQueryExceptionInfo
+            { connection = conn,
+              exception = SomeSqliteExceptionReason exception,
+              params = Nothing,
+              sql = s
+            }
+  logQuery s Nothing (Just result)
+  pure result
 
 queryListCol_ :: forall a. Sqlite.FromField a => Connection -> Sql -> IO [a]
 queryListCol_ conn s =

lib/unison-sqlite/src/Unison/Sqlite/Connection/Internal.hs

@@ -0,0 +1,17 @@
+module Unison.Sqlite.Connection.Internal
+  ( Connection (..),
+  )
+where
+
+import qualified Database.SQLite.Simple as Sqlite
+
+-- | A /non-thread safe/ connection to a SQLite database.
+data Connection = Connection
+  { name :: String,
+    file :: FilePath,
+    conn :: Sqlite.Connection
+  }
+
+instance Show Connection where
+  show (Connection name file _conn) =
+    "Connection { name = " ++ show name ++ ", file = " ++ show file ++ " }"

lib/unison-sqlite/src/Unison/Sqlite/Exception.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE ImplicitParams #-}
+
 -- | Sqlite exception utils.
 module Unison.Sqlite.Exception
   ( -- * @SomeSqliteException@
@@ -24,7 +26,9 @@ import Data.Typeable (cast)
 import Data.Void (Void)
 import qualified Database.SQLite.Simple as Sqlite
 import Debug.RecoverRTTI (anythingToString)
+import GHC.Stack (currentCallStack)
 import Unison.Prelude
+import Unison.Sqlite.Connection.Internal (Connection)
 import Unison.Sqlite.Sql
 import UnliftIO.Exception
 
@@ -110,7 +114,8 @@ data SqliteQueryException = SqliteQueryException
     -- | The inner exception. It is intentionally not 'SomeException', so that calling code cannot accidentally
     -- 'throwIO' domain-specific exception types, but must instead use a @*Check@ query variant.
     exception :: SomeSqliteExceptionReason,
-    connection :: String,
+    callStack :: [String],
+    connection :: Connection,
     threadId :: ThreadId
   }
   deriving stock (Show)
@@ -128,22 +133,24 @@ isSqliteBusyException SqliteQueryException {exception = SomeSqliteExceptionReaso
     Just (Sqlite.SQLError Sqlite.ErrorBusy _ _) -> True
     _ -> False
 
-data SqliteQueryExceptionInfo params connection = SqliteQueryExceptionInfo
-  { connection :: connection,
+data SqliteQueryExceptionInfo params = SqliteQueryExceptionInfo
+  { connection :: Connection,
     sql :: Sql,
     params :: Maybe params,
     exception :: SomeSqliteExceptionReason
   }
 
-throwSqliteQueryException :: Show connection => SqliteQueryExceptionInfo params connection -> IO a
+throwSqliteQueryException :: SqliteQueryExceptionInfo params -> IO a
 throwSqliteQueryException SqliteQueryExceptionInfo {connection, exception, params, sql} = do
   threadId <- myThreadId
+  callStack <- currentCallStack
   throwIO
     SqliteQueryException
       { sql,
         params = maybe "" anythingToString params,
         exception,
-        connection = show connection,
+        callStack,
+        connection,
         threadId
       }
 

lib/unison-sqlite/unison-sqlite.cabal

@@ -19,6 +19,7 @@ library
   exposed-modules:
       Unison.Sqlite
       Unison.Sqlite.Connection
+      Unison.Sqlite.Connection.Internal
       Unison.Sqlite.DB
       Unison.Sqlite.Transaction
   other-modules:

unison-cli/package.yaml

@@ -30,6 +30,7 @@ dependencies:
   - mtl
   - transformers
   - open-browser
+  - pretty-simple
   - random >= 1.2.0
   - regex-tdfa
   - stm

unison-cli/src/Unison/Codebase/TranscriptParser.hs

@@ -19,7 +19,6 @@ module Unison.Codebase.TranscriptParser
 where
 
 import Control.Concurrent.STM (atomically)
-import Control.Error (rightMay)
 import Control.Lens (view)
 import qualified Crypto.Random as Random
 import qualified Data.Char as Char
@@ -58,9 +57,6 @@ import qualified Unison.Runtime.Interface as RTI
 import Unison.Symbol (Symbol)
 import qualified Unison.Util.Pretty as P
 import qualified Unison.Util.TQueue as Q
-import qualified Unison.Codebase.Editor.Output as Output
-import Control.Lens (view)
-import qualified Unison.Codebase.Editor.HandleInput as HandleInput
 import qualified UnliftIO
 import Prelude hiding (readFile, writeFile)
 

unison-cli/src/Unison/CommandLine/Main.hs

@@ -10,7 +10,6 @@ where
 import Compat (withInterruptHandler)
 import qualified Control.Concurrent.Async as Async
 import Control.Concurrent.STM (atomically)
-import Control.Error (rightMay)
 import Control.Exception (catch, finally)
 import Control.Lens (view)
 import qualified Crypto.Random as Random
@@ -18,9 +17,11 @@ import Data.Configurator.Types (Config)
 import Data.IORef
 import qualified Data.Map as Map
 import qualified Data.Text as Text
+import qualified Data.Text.Lazy.IO as Text.Lazy
 import qualified System.Console.Haskeline as Line
 import System.IO (hPutStrLn, stderr)
 import System.IO.Error (isDoesNotExistError)
+import Text.Pretty.Simple (pShow)
 import Unison.Codebase (Codebase)
 import qualified Unison.Codebase as Codebase
 import Unison.Codebase.Branch (Branch)
@@ -46,13 +47,6 @@ import qualified Unison.Server.CodebaseServer as Server
 import Unison.Symbol (Symbol)
 import qualified Unison.Util.Pretty as P
 import qualified Unison.Util.TQueue as Q
-import qualified Unison.CommandLine.Welcome as Welcome
-import Control.Lens (view)
-import UnliftIO (catchSyncOrAsync, throwIO, withException)
-import System.IO (hPutStrLn, stderr)
-import Unison.Codebase.Editor.Output (Output)
-import qualified Unison.Codebase.Editor.HandleInput.LoopState as LoopState
-import qualified Unison.Codebase.Editor.HandleInput as HandleInput
 import qualified UnliftIO
 
 getUserInput ::
@@ -234,7 +228,7 @@ main dir welcome initialPath (config, cancelConfig) initialInputs runtime codeba
         `finally` cleanup
   where
     printException :: SomeException -> IO ()
-    printException e = hPutStrLn stderr ("Encountered Exception: " <> show (e :: SomeException))
+    printException e = Text.Lazy.hPutStrLn stderr ("Encountered exception:\n" <> pShow e)
 
 -- | Installs a posix interrupt handler for catching SIGINT.
 -- This replaces GHC's default sigint handler which throws a UserInterrupt async exception

unison-cli/unison-cli.cabal

@@ -97,6 +97,7 @@ library
     , mtl
     , nonempty-containers
     , open-browser
+    , pretty-simple
     , random >=1.2.0
     , regex-tdfa
     , semialign
@@ -172,6 +173,7 @@ executable integration-tests
     , mtl
     , nonempty-containers
     , open-browser
+    , pretty-simple
     , process
     , random >=1.2.0
     , regex-tdfa
@@ -244,6 +246,7 @@ executable transcripts
     , mtl
     , nonempty-containers
     , open-browser
+    , pretty-simple
     , process
     , random >=1.2.0
     , regex-tdfa
@@ -319,6 +322,7 @@ executable unison
     , nonempty-containers
     , open-browser
     , optparse-applicative >=0.16.1.0
+    , pretty-simple
     , random >=1.2.0
     , regex-tdfa
     , semialign
@@ -400,6 +404,7 @@ test-suite tests
     , mtl
     , nonempty-containers
     , open-browser
+    , pretty-simple
     , random >=1.2.0
     , regex-tdfa
     , semialign