From 7d718cd6be91e2abeb0c8623201e017240192b36 Mon Sep 17 00:00:00 2001 From: Ian Grant Jeffries Date: Mon, 11 Nov 2019 14:02:54 -0500 Subject: [PATCH] CanFailWith --- bowtie-visualize/src/Bowtie/Visualize.hs | 14 +++++---- bowtie/bowtie.cabal | 3 +- bowtie/src/Bowtie/Infer/Solve.hs | 19 ++++++------ bowtie/src/Bowtie/Lib/CanFailWith.hs | 4 +++ bowtie/src/Bowtie/Surface/Infer.hs | 38 +++++++++++++----------- 5 files changed, 43 insertions(+), 35 deletions(-) create mode 100644 bowtie/src/Bowtie/Lib/CanFailWith.hs diff --git a/bowtie-visualize/src/Bowtie/Visualize.hs b/bowtie-visualize/src/Bowtie/Visualize.hs index a597f92..b0683ec 100644 --- a/bowtie-visualize/src/Bowtie/Visualize.hs +++ b/bowtie-visualize/src/Bowtie/Visualize.hs @@ -3,9 +3,11 @@ module Bowtie.Visualize , writeConstraints ) where +import Bowtie.Infer.Assumptions (Assumptions) import Bowtie.Infer.Constraints import Bowtie.Infer.Solve -import Bowtie.Infer.Solve (next, solveConstraint) +import Bowtie.Infer.Unify +import Bowtie.Lib.CanFailWith import Bowtie.Lib.Environment import Bowtie.Lib.Prelude import Bowtie.Surface.AST (AST(astTerms, astTypes)) @@ -42,9 +44,9 @@ run libFiles appFile = do let f :: ( MonadState Int m - , CanSolveStuck m - , CanUnifyError m - , Infer.CanAssumptionsRemain m + , CanFailWith SolveStuck m + , CanFailWith UnifyError m + , CanFailWith Assumptions m ) => m [Constraints] f = do (constraints, _) <- Infer.gatherConstraints env dsg @@ -67,7 +69,7 @@ writeConstraints cs = BS.writeFile (Text.unpack (show n <> ".svg")) bts solutionSteps - :: (MonadState Int m, CanSolveStuck m, CanUnifyError m) + :: (MonadState Int m, CanFailWith SolveStuck m, CanFailWith UnifyError m) => Constraints -> m [Constraints] solutionSteps cs = do @@ -78,7 +80,7 @@ solutionSteps cs = do pure mempty else - failSolveStuck + failWith SolveStuckError Just (c, rest) -> do (_sub, rest2) <- solveConstraint c rest diff --git a/bowtie/bowtie.cabal b/bowtie/bowtie.cabal index 1ef23db..d83852d 100644 --- a/bowtie/bowtie.cabal +++ b/bowtie/bowtie.cabal @@ -4,7 +4,7 @@ cabal-version: 1.18 -- -- see: https://github.com/sol/hpack -- --- hash: 759169e0b3d720cfa7430eb1ab6d01ec5fdc06ddb6a89a10789f6bb437f0b38e +-- hash: 0b854e9d24f9bd96b6df9143a6958223d314d17aef63cf17d00ecf33561248fd name: bowtie version: 0.0.0 @@ -25,6 +25,7 @@ library Bowtie.Infer.Unify Bowtie.Interpret Bowtie.Lib.Builtin + Bowtie.Lib.CanFailWith Bowtie.Lib.Environment Bowtie.Lib.FreeVars Bowtie.Lib.OrderedMap diff --git a/bowtie/src/Bowtie/Infer/Solve.hs b/bowtie/src/Bowtie/Infer/Solve.hs index de736c9..54d5d82 100644 --- a/bowtie/src/Bowtie/Infer/Solve.hs +++ b/bowtie/src/Bowtie/Infer/Solve.hs @@ -4,6 +4,7 @@ import Bowtie.Infer.Constraints import Bowtie.Infer.Generalize (generalize, instantiate) import Bowtie.Infer.Substitution import Bowtie.Infer.Unify +import Bowtie.Lib.CanFailWith import Bowtie.Lib.Prelude import Control.Monad.State.Class @@ -11,14 +12,12 @@ import qualified Bowtie.Infer.Constraints as Constraints import qualified Data.List as List import qualified Data.Set as Set -class CanSolveStuck m where - failSolveStuck :: m a - -class CanUnifyError m where - failUnifyError :: UnifyError -> m a +data SolveStuck + = SolveStuckError + deriving (Eq, Show) solve - :: (MonadState Int m, CanSolveStuck m, CanUnifyError m) + :: (MonadState Int m, CanFailWith SolveStuck m, CanFailWith UnifyError m) => Constraints -> m Substitution solve cs = do @@ -29,14 +28,14 @@ solve cs = do pure mempty else - failSolveStuck + failWith SolveStuckError Just (c, rest) -> do (sub, rest2) <- solveConstraint c rest fmap (\a -> a <> sub) (solve rest2) solveConstraint - :: (MonadState Int m, CanUnifyError m) + :: (MonadState Int m, CanFailWith UnifyError m) => Constraint -> Constraints -> m (Substitution, Constraints) @@ -44,8 +43,8 @@ solveConstraint c rest = do case c of EqualityConstraint t1 t2 -> do sub <- case unify t1 t2 of - Left e -> - failUnifyError e + Left unifyError -> + failWith unifyError Right s -> pure s diff --git a/bowtie/src/Bowtie/Lib/CanFailWith.hs b/bowtie/src/Bowtie/Lib/CanFailWith.hs new file mode 100644 index 0000000..ebbc9fa --- /dev/null +++ b/bowtie/src/Bowtie/Lib/CanFailWith.hs @@ -0,0 +1,4 @@ +module Bowtie.Lib.CanFailWith where + +class CanFailWith e m where + failWith :: e -> m a diff --git a/bowtie/src/Bowtie/Surface/Infer.hs b/bowtie/src/Bowtie/Surface/Infer.hs index 55960e0..e14e648 100644 --- a/bowtie/src/Bowtie/Surface/Infer.hs +++ b/bowtie/src/Bowtie/Surface/Infer.hs @@ -4,9 +4,10 @@ module Bowtie.Surface.Infer where import Bowtie.Infer.Assumptions (Assumptions) import Bowtie.Infer.BottomUp import Bowtie.Infer.Constraints -import Bowtie.Infer.Unify import Bowtie.Infer.Solve import Bowtie.Infer.Substitution +import Bowtie.Infer.Unify +import Bowtie.Lib.CanFailWith import Bowtie.Lib.Environment import Bowtie.Lib.Prelude import Bowtie.Surface.AST @@ -39,7 +40,11 @@ elaborate env expr = do pure (sub, typ, substExpr sub freshExpr) inferType - :: (MonadState Int m, CanSolveStuck m, CanUnifyError m, CanAssumptionsRemain m) + :: ( MonadState Int m + , CanFailWith SolveStuck m + , CanFailWith UnifyError m + , CanFailWith Assumptions m + ) => Environment -> Expr -> m (Substitution, Type) @@ -49,11 +54,8 @@ inferType env expr = do -- Heeren paper doesn't do the substType here: pure (s, substType s typ) -class CanAssumptionsRemain m where - failAssumptionsRemain :: Assumptions -> m a - gatherConstraints - :: (MonadState Int m, CanAssumptionsRemain m) + :: (MonadState Int m, CanFailWith Assumptions m) => Environment -> Expr -> m (Constraints, Type) @@ -70,7 +72,7 @@ gatherConstraints env expr = do pure () else - failAssumptionsRemain a + failWith a pure (c <> explicitConstraintOnSet env a, t) @@ -90,14 +92,14 @@ newtype Infer a = Infer (StateT Int (Either TypeError) a) deriving newtype (Functor, Applicative, Monad, MonadError TypeError, MonadState Int) -instance CanSolveStuck Infer where - failSolveStuck :: Infer a - failSolveStuck = +instance CanFailWith SolveStuck Infer where + failWith :: SolveStuck -> Infer a + failWith SolveStuckError = throwError SolveStuck -instance CanUnifyError Infer where - failUnifyError :: UnifyError -> Infer a - failUnifyError e = +instance CanFailWith UnifyError Infer where + failWith :: UnifyError -> Infer a + failWith e = throwError (case e of TypeMismatch t1 t2 -> UnifyError t1 t2 @@ -105,11 +107,11 @@ instance CanUnifyError Infer where IdOccursInType id t -> OccursCheckFailed id t) -instance CanAssumptionsRemain Infer where - failAssumptionsRemain :: Assumptions -> Infer a - failAssumptionsRemain = +instance CanFailWith Assumptions Infer where + failWith :: Assumptions -> Infer a + failWith = throwError . AssumptionsRemain runInfer :: Infer a -> Either TypeError a -runInfer (Infer g) = - evalStateT g 0 +runInfer (Infer f) = + evalStateT f 0