Merge pull request #694 from GaloisInc/resolvesetupvalue-fail

Ensure that SAW builds on GHC 8.8
GaloisInc · Apr 28, 2020 · 93d8881 · 93d8881
2 parents e0328e9 + e01a1cc
commit 93d8881
Show file tree

Hide file tree

Showing 2 changed files with 7 additions and 4 deletions.
diff --git a/src/SAWScript/Crucible/LLVM/ResolveSetupValue.hs b/src/SAWScript/Crucible/LLVM/ResolveSetupValue.hs
@@ -27,7 +27,7 @@ module SAWScript.Crucible.LLVM.ResolveSetupValue
 
 import Control.Lens ((^.))
 import Control.Monad
-import Control.Monad.Catch (MonadThrow)
+import Control.Monad.Fail (MonadFail)
 import Control.Monad.State
 import Data.Foldable (toList)
 import Data.Maybe (fromMaybe, listToMaybe, fromJust)
@@ -125,7 +125,7 @@ resolveSetupFieldIndex cc env nameEnv v n =
     lc = ccTypeCtx cc
 
 resolveSetupFieldIndexOrFail ::
-  MonadThrow m =>
+  MonadFail m =>
   LLVMCrucibleContext arch {- ^ crucible context  -} ->
   Map AllocIndex LLVMAllocSpec {- ^ allocation types  -} ->
   Map AllocIndex Crucible.Ident   {- ^ allocation type names -} ->
@@ -148,7 +148,7 @@ resolveSetupFieldIndexOrFail cc env nameEnv v n =
             _ -> unlines [msg, "No field names were found for this struct"]
 
 typeOfSetupValue ::
-  MonadThrow m =>
+  MonadFail m =>
   LLVMCrucibleContext arch ->
   Map AllocIndex LLVMAllocSpec ->
   Map AllocIndex Crucible.Ident ->
@@ -159,7 +159,7 @@ typeOfSetupValue cc env nameEnv val =
      typeOfSetupValue' cc env nameEnv val
 
 typeOfSetupValue' :: forall m arch.
-  MonadThrow m =>
+  MonadFail m =>
   LLVMCrucibleContext arch ->
   Map AllocIndex LLVMAllocSpec ->
   Map AllocIndex Crucible.Ident ->

diff --git a/src/SAWScript/Value.hs b/src/SAWScript/Value.hs
@@ -34,6 +34,7 @@ import Prelude hiding (fail)
 import Control.Applicative (Applicative)
 #endif
 import Control.Lens
+import Control.Monad.Fail (MonadFail(..))
 import Control.Monad.Catch (MonadThrow(..))
 import Control.Monad.Except (ExceptT(..), runExceptT)
 import Control.Monad.Reader (MonadReader)
@@ -399,6 +400,8 @@ newtype TopLevel a =
 deriving instance MonadReader TopLevelRO TopLevel
 deriving instance MonadState TopLevelRW TopLevel
 instance Wrapped (TopLevel a) where
+instance MonadFail TopLevel where
+  fail = throwTopLevel
 
 runTopLevel :: TopLevel a -> TopLevelRO -> TopLevelRW -> IO (a, TopLevelRW)
 runTopLevel (TopLevel m) ro rw = runStateT (runReaderT m ro) rw