From 3c0b2d81ff9a3b04af5382e9740d18b06df955fa Mon Sep 17 00:00:00 2001
From: Michael Walker <mike@barrucadu.co.uk>
Date: Sat, 28 Oct 2017 12:15:52 +0100
Subject: [PATCH] Give better errors from failing partial functions

They still shouldn't fail, but this will make tracking down issues
like #141 in the future easier
---
 dejafu/Test/DejaFu/Common.hs                  | 61 ++++++++++++++++---
 dejafu/Test/DejaFu/Conc/Internal.hs           | 11 ++--
 dejafu/Test/DejaFu/Conc/Internal/Memory.hs    |  6 +-
 dejafu/Test/DejaFu/Conc/Internal/Threading.hs |  2 +-
 dejafu/Test/DejaFu/SCT/Internal.hs            | 22 +++----
 dejafu/Test/DejaFu/Schedule.hs                |  2 +-
 6 files changed, 71 insertions(+), 33 deletions(-)

diff --git a/dejafu/Test/DejaFu/Common.hs b/dejafu/Test/DejaFu/Common.hs
index 10761ed..f4bd1bf 100644
--- a/dejafu/Test/DejaFu/Common.hs
+++ b/dejafu/Test/DejaFu/Common.hs
@@ -66,17 +66,24 @@ module Test.DejaFu.Common
   -- * Miscellaneous
   , MonadFailException(..)
   , runRefCont
+  , ehead
+  , etail
+  , eidx
+  , efromJust
+  , efromList
+  , fatal
   ) where
 
-import           Control.DeepSeq   (NFData(..))
-import           Control.Exception (Exception(..), MaskingState(..),
-                                    SomeException, displayException)
-import           Control.Monad.Ref (MonadRef(..))
-import           Data.Function     (on)
-import           Data.List         (intercalate)
-import           Data.Maybe        (fromMaybe, mapMaybe)
-import           Data.Set          (Set)
-import qualified Data.Set          as S
+import           Control.DeepSeq    (NFData(..))
+import           Control.Exception  (Exception(..), MaskingState(..),
+                                     SomeException, displayException)
+import           Control.Monad.Ref  (MonadRef(..))
+import           Data.Function      (on)
+import           Data.List          (intercalate)
+import           Data.List.NonEmpty (NonEmpty(..))
+import           Data.Maybe         (fromMaybe, mapMaybe)
+import           Data.Set           (Set)
+import qualified Data.Set           as S
 
 -------------------------------------------------------------------------------
 -- Identifiers
@@ -983,6 +990,42 @@ runRefCont act f k = do
   let c = k (act . writeRef ref . f)
   pure (c, ref)
 
+-- | 'head' but with a better error message if it fails.  Use this
+-- only where it shouldn't fail!
+ehead :: String -> [a] -> a
+ehead _ (x:_) = x
+ehead src _ = fatal src "head: empty list"
+
+-- | 'tail' but with a better error message if it fails.  Use this
+-- only where it shouldn't fail!
+etail :: String -> [a] -> [a]
+etail _ (_:xs) = xs
+etail src _ = fatal src "tail: empty list"
+
+-- | '(!!)' but with a better error message if it fails.  Use this
+-- only where it shouldn't fail!
+eidx :: String -> [a] -> Int -> a
+eidx src xs i
+  | i < length xs = xs !! i
+  | otherwise = fatal src "(!!): index too large"
+
+-- | 'fromJust' but with a better error message if it fails.  Use this
+-- only where it shouldn't fail!
+efromJust :: String -> Maybe a -> a
+efromJust _ (Just x) = x
+efromJust src _ = fatal src "fromJust: Nothing"
+
+-- | 'fromList' but with a better error message if it fails.  Use this
+-- only where it shouldn't fail!
+efromList :: String -> [a] -> NonEmpty a
+efromList _ (x:xs) = x:|xs
+efromList src _ = fatal src "fromList: empty list"
+
+-- | 'error' but saying where it came from
+fatal :: String -> String -> a
+fatal src msg = error ("(dejafu: " ++ src ++ ") " ++ msg)
+
+
 -------------------------------------------------------------------------------
 -- Utilities
 
diff --git a/dejafu/Test/DejaFu/Conc/Internal.hs b/dejafu/Test/DejaFu/Conc/Internal.hs
index 3260ee5..947a5f2 100755
--- a/dejafu/Test/DejaFu/Conc/Internal.hs
+++ b/dejafu/Test/DejaFu/Conc/Internal.hs
@@ -21,9 +21,8 @@ import           Control.Monad.Ref                   (MonadRef, newRef, readRef,
                                                       writeRef)
 import           Data.Functor                        (void)
 import           Data.List                           (sortOn)
-import           Data.List.NonEmpty                  (fromList)
 import qualified Data.Map.Strict                     as M
-import           Data.Maybe                          (fromJust, isJust)
+import           Data.Maybe                          (isJust)
 import           Data.Monoid                         ((<>))
 import           Data.Sequence                       (Seq, (<|))
 import qualified Data.Sequence                       as Seq
@@ -64,7 +63,7 @@ runConcurrency sched memtype g idsrc caps ma = do
                     }
   (finalCtx, trace, finalAction) <- runThreads sched memtype ref ctx
   out <- readRef ref
-  pure (fromJust out, finalCtx, trace, finalAction)
+  pure (efromJust "runConcurrency" out, finalCtx, trace, finalAction)
 
 -- | The context a collection of threads are running in.
 data Context n r g = Context
@@ -97,7 +96,7 @@ runThreads sched memtype ref = go Seq.empty Nothing where
              Nothing -> die sofar prior InternalError ctx'
            Nothing -> die sofar prior Abort ctx'
     where
-      (choice, g')  = scheduleThread sched prior (fromList runnable') (cSchedState ctx)
+      (choice, g')  = scheduleThread sched prior (efromList "runThreads" runnable') (cSchedState ctx)
       runnable'     = [(t, lookahead (_continuation a)) | (t, a) <- sortOn fst $ M.assocs runnable]
       runnable      = M.filter (not . isBlocked) threadsc
       threadsc      = addCommitThreads (cWriteBuf ctx) threads
@@ -290,7 +289,7 @@ stepThread sched memtype tid action ctx = case action of
       wb' <- case memtype of
         -- shouldn't ever get here
         SequentialConsistency ->
-          error "Attempting to commit under SequentialConsistency"
+          fatal "stepThread.ACommit" "Attempting to commit under SequentialConsistency"
         -- commit using the thread id.
         TotalStoreOrder -> commitWrite (cWriteBuf ctx) (t, Nothing)
         -- commit using the cref id.
@@ -351,7 +350,7 @@ stepThread sched memtype tid action ctx = case action of
     -- a function to run a computation with the current masking state.
     AMasking m ma c ->
       let a = runCont (ma umask) (AResetMask False False m' . c)
-          m' = _masking . fromJust $ M.lookup tid (cThreads ctx)
+          m' = _masking . efromJust "stepThread.AMasking" $ M.lookup tid (cThreads ctx)
           umask mb = resetMask True m' >> mb >>= \b -> resetMask False m >> pure b
           resetMask typ ms = cont $ \k -> AResetMask typ True ms $ k ()
           threads' = goto a tid (mask m tid (cThreads ctx))
diff --git a/dejafu/Test/DejaFu/Conc/Internal/Memory.hs b/dejafu/Test/DejaFu/Conc/Internal/Memory.hs
index 0bfdd4f..d1328e4 100755
--- a/dejafu/Test/DejaFu/Conc/Internal/Memory.hs
+++ b/dejafu/Test/DejaFu/Conc/Internal/Memory.hs
@@ -26,7 +26,7 @@ module Test.DejaFu.Conc.Internal.Memory where
 import           Control.Monad.Ref                   (MonadRef, readRef,
                                                       writeRef)
 import           Data.Map.Strict                     (Map)
-import           Data.Maybe                          (fromJust, maybeToList)
+import           Data.Maybe                          (maybeToList)
 import           Data.Monoid                         ((<>))
 import           Data.Sequence                       (Seq, ViewL(..), singleton,
                                                       viewl, (><))
@@ -160,7 +160,7 @@ tryPutIntoMVar = mutMVar NonBlocking
 -- | Read from a @MVar@, blocking if empty.
 readFromMVar :: MonadRef r n => MVar r a -> (a -> Action n r)
             -> ThreadId -> Threads n r -> n (Bool, Threads n r, [ThreadId])
-readFromMVar cvar c = seeMVar NonEmptying Blocking cvar (c . fromJust)
+readFromMVar cvar c = seeMVar NonEmptying Blocking cvar (c . efromJust "readFromMVar")
 
 -- | Try to read from a @MVar@, not blocking if empty.
 tryReadFromMVar :: MonadRef r n => MVar r a -> (Maybe a -> Action n r)
@@ -170,7 +170,7 @@ tryReadFromMVar = seeMVar NonEmptying NonBlocking
 -- | Take from a @MVar@, blocking if empty.
 takeFromMVar :: MonadRef r n => MVar r a -> (a -> Action n r)
              -> ThreadId -> Threads n r -> n (Bool, Threads n r, [ThreadId])
-takeFromMVar cvar c = seeMVar Emptying Blocking cvar (c . fromJust)
+takeFromMVar cvar c = seeMVar Emptying Blocking cvar (c . efromJust "takeFromMVar")
 
 -- | Try to take from a @MVar@, not blocking if empty.
 tryTakeFromMVar :: MonadRef r n => MVar r a -> (Maybe a -> Action n r)
diff --git a/dejafu/Test/DejaFu/Conc/Internal/Threading.hs b/dejafu/Test/DejaFu/Conc/Internal/Threading.hs
index 2154789..52feced 100644
--- a/dejafu/Test/DejaFu/Conc/Internal/Threading.hs
+++ b/dejafu/Test/DejaFu/Conc/Internal/Threading.hs
@@ -92,7 +92,7 @@ catching h = M.adjust $ \thread ->
 
 -- | Remove the most recent exception handler.
 uncatching :: ThreadId -> Threads n r -> Threads n r
-uncatching = M.adjust $ \thread -> thread { _handlers = tail $ _handlers thread }
+uncatching = M.adjust $ \thread -> thread { _handlers = etail "uncatching" (_handlers thread) }
 
 -- | Raise an exception in a thread.
 except :: (MaskingState -> Action n r) -> [Handler n r] -> ThreadId -> Threads n r -> Threads n r
diff --git a/dejafu/Test/DejaFu/SCT/Internal.hs b/dejafu/Test/DejaFu/SCT/Internal.hs
index 01cf917..8c9d87d 100644
--- a/dejafu/Test/DejaFu/SCT/Internal.hs
+++ b/dejafu/Test/DejaFu/SCT/Internal.hs
@@ -22,7 +22,7 @@ import           Data.List            (nubBy, partition, sortOn)
 import           Data.List.NonEmpty   (toList)
 import           Data.Map.Strict      (Map)
 import qualified Data.Map.Strict      as M
-import           Data.Maybe           (fromJust, fromMaybe, isJust, isNothing,
+import           Data.Maybe           (fromMaybe, isJust, isNothing,
                                        listToMaybe)
 import           Data.Sequence        (Seq, (|>))
 import qualified Data.Sequence        as Sq
@@ -157,7 +157,7 @@ incorporateTrace memtype conservative trace dpor0 = grow initialDepState (initia
     in case dporNext dpor of
          Just (t, child)
            | t == tid'      -> dpor { dporNext = Just (tid', grow state' tid' rest child) }
-           | hasTodos child -> err "incorporateTrace" "replacing child with todos!"
+           | hasTodos child -> fatal "incorporateTrace" "replacing child with todos!"
          _ ->
            let taken = M.insert tid' a (dporTaken dpor)
                sleep = dporSleep dpor `M.union` dporTaken dpor
@@ -166,7 +166,7 @@ incorporateTrace memtype conservative trace dpor0 = grow initialDepState (initia
                    , dporNext  = Just (tid', subtree state' tid' sleep trc)
                    , dporDone  = S.insert tid' (dporDone dpor)
                    }
-  grow _ _ [] _ = err "incorporateTrace" "trace exhausted without reading a to-do point!"
+  grow _ _ [] _ = fatal "incorporateTrace" "trace exhausted without reading a to-do point!"
 
   -- check if there are to-do points in a tree
   hasTodos dpor = not (M.null (dporTodo dpor)) || (case dporNext dpor of Just (_, dpor') -> hasTodos dpor'; _ -> False)
@@ -193,7 +193,7 @@ incorporateTrace memtype conservative trace dpor0 = grow initialDepState (initia
           ((d', _, a'):_) -> M.singleton (tidOf tid d') a'
           [] -> M.empty
         }
-  subtree _ _ _ [] = err "incorporateTrace" "subtree suffix empty!"
+  subtree _ _ _ [] = fatal "incorporateTrace" "subtree suffix empty!"
 
 -- | Produce a list of new backtracking points from an execution
 -- trace. These are then used to inform new \"to-do\" points in the
@@ -251,7 +251,7 @@ findBacktrackSteps memtype backtrack boundKill = go initialDepState S.empty init
   -- backtracking points.
   doBacktrack killsEarly allThreads enabledThreads bs =
     let tagged = reverse $ zip [0..] bs
-        idxs   = [ (head is, False, u)
+        idxs   = [ (ehead "doBacktrack.idxs" is, False, u)
                  | (u, n) <- enabledThreads
                  , v <- S.toList allThreads
                  , u /= v
@@ -301,9 +301,9 @@ incorporateBacktrackSteps (b:bs) dpor = dpor' where
 
   child = case dporNext dpor of
     Just (t, d)
-      | t /= tid -> err "incorporateBacktrackSteps" "incorporating wrong trace!"
+      | t /= tid -> fatal "incorporateBacktrackSteps" "incorporating wrong trace!"
       | otherwise -> incorporateBacktrackSteps bs d
-    Nothing -> err "incorporateBacktrackSteps" "child is missing!"
+    Nothing -> fatal "incorporateBacktrackSteps" "child is missing!"
 incorporateBacktrackSteps [] dpor = dpor
 
 -------------------------------------------------------------------------------
@@ -416,7 +416,7 @@ backtrackAt toAll bs0 = backtrackAt' . nubBy ((==) `on` fst') . sortOn fst' wher
         ((i',c',t'):is') -> go i' bs (i'-i0-1) c' t' is'
         [] -> bs
   go i0 (b:bs) i c tid is = b : go i0 bs (i-1) c tid is
-  go _ [] _ _ _ _ = err "backtrackAt" "ran out of schedule whilst backtracking!"
+  go _ [] _ _ _ _ = fatal "backtrackAt" "ran out of schedule whilst backtracking!"
 
   -- Backtrack to a single thread
   backtrackTo tid c = M.insert tid c . bcktBacktracks
@@ -495,7 +495,7 @@ dporSched memtype boundf = Scheduler $ \prior threads s ->
     decision = decisionOf (fst <$> prior) (S.fromList tids)
 
     -- Get the action of a thread
-    action t = fromJust $ lookup t threads'
+    action t = efromJust "dporSched.action" (lookup t threads')
 
     -- The runnable thread IDs
     tids = map fst threads'
@@ -812,7 +812,3 @@ willYield _ = False
 killsDaemons :: ThreadId -> Lookahead -> Bool
 killsDaemons t WillStop = t == initialThread
 killsDaemons _ _ = False
-
--- | Internal errors.
-err :: String -> String -> a
-err func msg = error (func ++ ": (internal error) " ++ msg)
diff --git a/dejafu/Test/DejaFu/Schedule.hs b/dejafu/Test/DejaFu/Schedule.hs
index f193dfd..473c338 100644
--- a/dejafu/Test/DejaFu/Schedule.hs
+++ b/dejafu/Test/DejaFu/Schedule.hs
@@ -98,7 +98,7 @@ randomSched = Scheduler go where
   go _ threads g =
     let threads' = map fst (toList threads)
         (choice, g') = randomR (0, length threads' - 1) g
-    in (Just $ threads' !! choice, g')
+    in (Just $ eidx "randomSched" threads' choice, g')
 
 -- | A round-robin scheduler which, at every step, schedules the
 -- thread with the next 'ThreadId'.