Merge pull request #43 from bitemyapp/FintanH/errors

Cleaning up Esqueleto errors

src/Database/Esqueleto/Internal/Sql.hs

@@ -52,7 +52,7 @@ module Database.Esqueleto.Internal.Sql
   ) where
 
 import Control.Arrow ((***), first)
-import Control.Exception (throw, throwIO)
+import Control.Exception (Exception, throw, throwIO)
 import Control.Monad (ap, MonadPlus(..), void)
 import Control.Monad.IO.Class (MonadIO(..))
 import Control.Monad.Trans.Class (lift)
@@ -76,6 +76,46 @@ import qualified Data.Text.Lazy.Builder as TLB
 
 import Database.Esqueleto.Internal.Language
 
+-- | Exception data type for @esqueleto@ internal errors
+data EsqueletoError =
+    CompositeKeyErr CompositeKeyError
+  | UnexpectedCaseErr UnexpectedCaseError
+  | SqlBinOpCompositeErr SqlBinOpCompositeError
+  deriving (Show)
+
+instance Exception EsqueletoError
+
+data CompositeKeyError =
+    NotError
+  | ToInsertionError
+  | CombineInsertionError
+  | FoldHelpError
+  | SqlCaseError
+  | SqlBinOpError
+  | MakeOnClauseError
+  | MakeExcError
+  | MakeSetError
+  | MakeWhereError
+  | MakeHavingError
+  deriving (Show)
+
+data UnexpectedCaseError =
+    EmptySqlExprValueList
+  | MakeFromError
+  | UnsupportedSqlInsertIntoType
+  | InsertionFinalError
+  | NewIdentForError
+  | UnsafeSqlCaseError
+  deriving (Show)
+
+data SqlBinOpCompositeError =
+    MismatchingLengthsError
+  | NullPlaceholdersError
+  | DeconstructionError
+  deriving (Show)
+
+
+
 -- | SQL backend for @esqueleto@ using 'SqlPersistT'.
 newtype SqlQuery a =
   Q { unQ :: W.WriterT SideData (S.State IdentState) a }
@@ -238,7 +278,7 @@ newIdentFor = Q . lift . try . unDBName
       s <- S.get
       let go (t:ts) | t `HS.member` inUse s = go ts
                     | otherwise             = use t
-          go [] = error "Esqueleto/Sql/newIdentFor: never here"
+          go [] = throw (UnexpectedCaseErr NewIdentForError)
       go (possibilities orig)
 
     possibilities t = t : map addNum [2..]
@@ -448,7 +488,7 @@ instance Esqueleto SqlQuery SqlExpr SqlBackend where
 
   not_ (ERaw p f) = ERaw Never $ \info -> let (b, vals) = f info
                                           in ("NOT " <> parensM p b, vals)
-  not_ (ECompositeKey _) = unexpectedCompositeKeyError "not_"
+  not_ (ECompositeKey _) = throw (CompositeKeyErr NotError)
 
   (==.) = unsafeSqlBinOpComposite " = " " AND "
   (!=.) = unsafeSqlBinOpComposite " != " " OR "
@@ -514,13 +554,13 @@ instance Esqueleto SqlQuery SqlExpr SqlBackend where
   field /=. expr = setAux field (\ent -> ent ^. field /. expr)
 
   (<#) _ (ERaw _ f)        = EInsert Proxy f
-  (<#) _ (ECompositeKey _) = unexpectedCompositeKeyError "(<#)"
+  (<#) _ (ECompositeKey _) = throw (CompositeKeyErr ToInsertionError)
 
   (EInsert _ f) <&> (ERaw _ g) = EInsert Proxy $ \x ->
     let (fb, fv) = f x
         (gb, gv) = g x
     in (fb <> ", " <> gb, fv ++ gv)
-  (EInsert _ _) <&> (ECompositeKey _) = unexpectedCompositeKeyError "(<&>)"
+  (EInsert _ _) <&> (ECompositeKey _) = throw (CompositeKeyErr CombineInsertionError)
 
   case_ = unsafeSqlCase
   toBaseId = veryUnsafeCoerceSqlExprValue
@@ -578,7 +618,7 @@ unsafeSqlCase when (ERaw p1 f1) = ERaw Never buildCase
         in ( "CASE" <> b2 <> " ELSE " <> parensM p1 b1 <> " END", vals2 <> vals1)
 
     mapWhen :: [(SqlExpr (Value Bool), SqlExpr (Value a))] -> IdentInfo -> (TLB.Builder, [PersistValue])
-    mapWhen []    _    = error "unsafeSqlCase: empty when list."
+    mapWhen []    _    = throw (UnexpectedCaseErr UnsafeSqlCaseError)
     mapWhen when' info = foldl (foldHelp info) (mempty, mempty) when'
 
     foldHelp :: IdentInfo -> (TLB.Builder, [PersistValue]) -> (SqlExpr (Value Bool), SqlExpr (Value a)) -> (TLB.Builder, [PersistValue])
@@ -586,8 +626,8 @@ unsafeSqlCase when (ERaw p1 f1) = ERaw Never buildCase
         let (b1, vals1) = f1' info
             (b2, vals2) = f2 info
         in ( b0 <> " WHEN " <> parensM p1' b1 <> " THEN " <> parensM p2 b2, vals0 <> vals1 <> vals2 )
-    foldHelp _ _ _ = unexpectedCompositeKeyError "unsafeSqlCase/foldHelp"
+    foldHelp _ _ _ = throw (CompositeKeyErr FoldHelpError)
-unsafeSqlCase _ (ECompositeKey _) = unexpectedCompositeKeyError "unsafeSqlCase"
+unsafeSqlCase _ (ECompositeKey _) = throw (CompositeKeyErr SqlCaseError)
 
 
 -- | (Internal) Create a custom binary operator.  You /should/
@@ -609,7 +649,7 @@ unsafeSqlBinOp op (ERaw p1 f1) (ERaw p2 f2) = ERaw Parens f
                  (b2, vals2) = f2 info
              in ( parensM p1 b1 <> op <> parensM p2 b2
                 , vals1 <> vals2 )
-unsafeSqlBinOp _ _ _ = unexpectedCompositeKeyError "unsafeSqlBinOp"
+unsafeSqlBinOp _ _ _ = throw (CompositeKeyErr SqlBinOpError)
 {-# INLINE unsafeSqlBinOp #-}
 
 
@@ -647,20 +687,17 @@ unsafeSqlBinOpComposite op sep a b = ERaw Parens $ compose (listify a) (listify
     deconstruct :: (TLB.Builder, [PersistValue]) -> ([TLB.Builder], [PersistValue])
     deconstruct ("?", [PersistList vals]) = (replicate (length vals) "?", vals)
     deconstruct (b', []) = (TLB.fromLazyText <$> TL.splitOn "," (TLB.toLazyText b'), [])
-    deconstruct x = err $ "cannot deconstruct " ++ show x ++ "."
+    deconstruct _ = throw (SqlBinOpCompositeErr DeconstructionError)
 
     compose f1 f2 info
-      | not (null v1 || null v2) = err' "one side needs to have null placeholders"
+      | not (null v1 || null v2) = throw (SqlBinOpCompositeErr NullPlaceholdersError)
-      | length b1 /= length b2   = err' "mismatching lengths"
+      | length b1 /= length b2   = throw (SqlBinOpCompositeErr MismatchingLengthsError)
       | otherwise                = (bc, vc)
       where
         (b1, v1) = f1 info
         (b2, v2) = f2 info
         bc = intersperseB sep [x <> op <> y | (x, y) <- zip b1 b2]
         vc = v1 <> v2
-        err' = err . (++ (", " ++ show ((b1, v1), (b2, v2))))
-
-    err = error . ("unsafeSqlBinOpComposite: " ++)
 
 -- | (Internal) A raw SQL value.  The same warning from
 -- 'unsafeSqlBinOp' applies to this function as well.
@@ -739,8 +776,7 @@ veryUnsafeCoerceSqlExprValue (ECompositeKey f) = ECompositeKey f
 -- a)' to 'SqlExpr (Value a)'.  Does not work with empty lists.
 veryUnsafeCoerceSqlExprValueList :: SqlExpr (ValueList a) -> SqlExpr (Value a)
 veryUnsafeCoerceSqlExprValueList (EList v)  = v
-veryUnsafeCoerceSqlExprValueList EEmptyList =
+veryUnsafeCoerceSqlExprValueList EEmptyList = throw (UnexpectedCaseErr EmptySqlExprValueList)
-  error "veryUnsafeCoerceSqlExprValueList: empty list."
 
 
 ----------------------------------------------------------------------
@@ -1055,7 +1091,7 @@ makeFrom info mode fs = ret
               , mk Parens rhs
               , maybe mempty makeOnClause monClause
               ]
-    mk _ (OnClause _) = error "Esqueleto/Sql/makeFrom: never here (is collectOnClauses working?)"
+    mk _ (OnClause _) = throw (UnexpectedCaseErr MakeFromError)
 
     base ident@(I identText) def =
       let db@(DBName dbText) = entityDB def
@@ -1071,29 +1107,25 @@ makeFrom info mode fs = ret
     fromKind FullOuterJoinKind  = " FULL OUTER JOIN "
 
     makeOnClause (ERaw _ f)        = first (" ON " <>) (f info)
-    makeOnClause (ECompositeKey _) = unexpectedCompositeKeyError "makeFrom/makeOnClause"
+    makeOnClause (ECompositeKey _) = throw (CompositeKeyErr MakeOnClauseError)
 
     mkExc :: SqlExpr (Value Bool) -> OnClauseWithoutMatchingJoinException
     mkExc (ERaw _ f) =
       OnClauseWithoutMatchingJoinException $
       TL.unpack $ TLB.toLazyText $ fst (f info)
-    mkExc (ECompositeKey _) = unexpectedCompositeKeyError "makeFrom/mkExc"
+    mkExc (ECompositeKey _) = throw (CompositeKeyErr MakeExcError)
-
-unexpectedCompositeKeyError :: String -> a
-unexpectedCompositeKeyError w = error $ w ++ ": non-id/composite keys not expected here"
-
 
 makeSet :: IdentInfo -> [SetClause] -> (TLB.Builder, [PersistValue])
 makeSet _    [] = mempty
 makeSet info os = first ("\nSET " <>) . uncommas' $ concatMap mk os
   where
     mk (SetClause (ERaw _ f))        = [f info]
-    mk (SetClause (ECompositeKey _)) = unexpectedCompositeKeyError "makeSet" -- FIXME
+    mk (SetClause (ECompositeKey _)) = throw (CompositeKeyErr MakeSetError) -- FIXME
 
 makeWhere :: IdentInfo -> WhereClause -> (TLB.Builder, [PersistValue])
 makeWhere _    NoWhere                   = mempty
 makeWhere info (Where (ERaw _ f))        = first ("\nWHERE " <>) (f info)
-makeWhere _    (Where (ECompositeKey _)) = unexpectedCompositeKeyError "makeWhere"
+makeWhere _    (Where (ECompositeKey _)) = throw (CompositeKeyErr MakeWhereError)
 
 
 makeGroupBy :: IdentInfo -> GroupByClause -> (TLB.Builder, [PersistValue])
@@ -1110,7 +1142,7 @@ makeGroupBy info (GroupBy fields) = first ("\nGROUP BY " <>) build
 makeHaving :: IdentInfo -> WhereClause -> (TLB.Builder, [PersistValue])
 makeHaving _    NoWhere                    = mempty
 makeHaving info (Where (ERaw _ f))         = first ("\nHAVING " <>) (f info)
-makeHaving _    (Where (ECompositeKey _)) = unexpectedCompositeKeyError "makeHaving"
+makeHaving _    (Where (ECompositeKey _)) = throw (CompositeKeyErr MakeHavingError)
 
 -- makeHaving, makeWhere and makeOrderBy
 makeOrderBy :: IdentInfo -> [OrderByClause] -> (TLB.Builder, [PersistValue])
@@ -1172,7 +1204,7 @@ class SqlSelect a r | a -> r, r -> a where
 
   -- | Create @INSERT INTO@ clause instead.
   sqlInsertInto :: IdentInfo -> a -> (TLB.Builder, [PersistValue])
-  sqlInsertInto = error "Type does not support sqlInsertInto."
+  sqlInsertInto = throw (UnexpectedCaseErr UnsupportedSqlInsertIntoType)
 
 
 -- | @INSERT INTO@ hack.
@@ -1186,9 +1218,8 @@ instance SqlSelect (SqlExpr InsertFinal) InsertFinal where
     in ("INSERT INTO " <> table <> parens fields <> "\n", [])
   sqlSelectCols info (EInsertFinal (EInsert _ f)) = f info
   sqlSelectColCount   = const 0
-  sqlSelectProcessRow = const (Right (error msg))
+  sqlSelectProcessRow =
-    where
+    const (Right (throw (UnexpectedCaseErr InsertionFinalError)))
-      msg = "sqlSelectProcessRow/SqlSelect/InsertionFinal: never here"
 
 
 -- | Not useful for 'select', but used for 'update' and 'delete'.