From fcaf1307dd9ebab4e61bba7e18551b05d6b821d0 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 18 Jul 2019 16:53:00 -0400 Subject: [PATCH 1/2] Replace FreeVariables with a function abstracted over a Foldable instance. --- semantic-core/src/Analysis/Typecheck.hs | 10 ++-------- 1 file changed, 2 insertions(+), 8 deletions(-) diff --git a/semantic-core/src/Analysis/Typecheck.hs b/semantic-core/src/Analysis/Typecheck.hs index cc7a2423b..fce5672f0 100644 --- a/semantic-core/src/Analysis/Typecheck.hs +++ b/semantic-core/src/Analysis/Typecheck.hs @@ -192,14 +192,8 @@ substAll :: Substitutable t => Substitution -> t -> t substAll s a = foldl' (flip subst) a (map (uncurry (:=)) (IntMap.toList s)) -class FreeVariables t where - mvs :: t -> IntSet.IntSet - -instance FreeVariables (Term Monotype Meta) where - mvs = foldMap IntSet.singleton - -instance FreeVariables Constraint where - mvs (t1 :===: t2) = mvs t1 <> mvs t2 +mvs :: Foldable t => t Meta -> IntSet.IntSet +mvs = foldMap IntSet.singleton class Substitutable t where subst :: Solution -> t -> t From 4ccf31d8639f6139c75e6239d699db95c4c1fca8 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Thu, 18 Jul 2019 17:01:03 -0400 Subject: [PATCH 2/2] Replace Substitutable with monadic substitution. --- semantic-core/src/Analysis/Typecheck.hs | 33 +++++-------------------- 1 file changed, 6 insertions(+), 27 deletions(-) diff --git a/semantic-core/src/Analysis/Typecheck.hs b/semantic-core/src/Analysis/Typecheck.hs index fce5672f0..4c83a933f 100644 --- a/semantic-core/src/Analysis/Typecheck.hs +++ b/semantic-core/src/Analysis/Typecheck.hs @@ -19,7 +19,7 @@ import Control.Monad (unless) import Control.Monad.Module import qualified Data.Core as Core import Data.File -import Data.Foldable (foldl', for_) +import Data.Foldable (for_) import Data.Function (fix) import Data.Functor (($>)) import qualified Data.IntMap as IntMap @@ -27,7 +27,7 @@ import qualified Data.IntSet as IntSet import Data.List.NonEmpty (nonEmpty) import Data.Loc import qualified Data.Map as Map -import Data.Maybe (fromJust) +import Data.Maybe (fromJust, fromMaybe) import Data.Name as Name import Data.Scope import qualified Data.Set as Set @@ -104,7 +104,7 @@ runFile file = traverse run file where run = (\ m -> do (subst, t) <- m - modify @(Heap Name (Term Monotype Meta)) (substAll subst) + modify @(Heap Name (Term Monotype Meta)) (fmap (Set.map (substAll subst))) pure (substAll subst <$> t)) . runState (mempty :: Substitution) . runReader (fileLoc file) @@ -182,36 +182,15 @@ solve cs = for_ cs solve case sol of Just (_ := t1) -> solve (t1 :===: t2) Nothing | m1 `IntSet.member` mvs t2 -> fail ("Occurs check failure: " <> show m1 <> " :===: " <> show t2) - | otherwise -> modify (IntMap.insert m1 t2 . subst (m1 := t2)) + | otherwise -> modify (IntMap.insert m1 t2 . fmap (substAll (IntMap.singleton m1 t2))) t1 :===: Var m2 -> solve (Var m2 :===: t1) t1 :===: t2 -> unless (t1 == t2) $ fail ("Type mismatch:\nexpected: " <> show t1 <> "\n actual: " <> show t2) solution m = fmap (m :=) <$> gets (IntMap.lookup m) -substAll :: Substitutable t => Substitution -> t -> t -substAll s a = foldl' (flip subst) a (map (uncurry (:=)) (IntMap.toList s)) - mvs :: Foldable t => t Meta -> IntSet.IntSet mvs = foldMap IntSet.singleton -class Substitutable t where - subst :: Solution -> t -> t - -instance Substitutable (Term Monotype Meta) where - subst (i' := t') t = t >>= \ i -> if i == i' then t' else Var i - -instance Substitutable Constraint where - subst s (t1 :===: t2) = subst s t1 :===: subst s t2 - -instance Substitutable Solution where - subst s (m := t) = m := subst s t - -instance Substitutable a => Substitutable (IntMap.IntMap a) where - subst s = IntMap.map (subst s) - -instance (Ord a, Substitutable a) => Substitutable (Set.Set a) where - subst s = Set.map (subst s) - -instance Substitutable v => Substitutable (Map.Map k v) where - subst s = fmap (subst s) +substAll :: Monad t => IntMap.IntMap (t Meta) -> t Meta -> t Meta +substAll s a = a >>= \ i -> fromMaybe (pure i) (IntMap.lookup i s)