@@ -4,10 +4,23 @@ module Unify where
4import Constrain
4import Constrain
5import Control.Arrow (second)
5import Control.Arrow (second)
6import Control.Monad (liftM)
6import Control.Monad (liftM)
7+import Data.List (foldl')
7import qualified Data.Set as Set
8import qualified Data.Set as Set
8import Types
10import Types
10−import Guid
12+import Control.DeepSeq
14+force x = x `deepseq` x
16+instance NFData Constraint where
17+ rnf (t1 :=: t2) = t1 `deepseq` t2 `deepseq` ()
18+ rnf (t1 :<: t2) = t1 `deepseq` t2 `deepseq` ()
20+instance NFData Type where
21+ rnf (LambdaT t1 t2) = t1 `deepseq` t2 `deepseq` ()
22+ rnf (ADT _ ts) = foldl' (\acc x -> x `deepseq` acc) () ts
12unify hints expr = run $ do
25unify hints expr = run $ do
13 cs <- constrain hints expr
26 cs <- constrain hints expr
@@ -36,16 +49,16 @@ solver ((t1 :=: t2) : cs) subs =
37solver ((t1 :<: t2) : cs) subs = do
50solver ((t1 :<: t2) : cs) subs = do
38 let f x = do y <- guid ; return (x,VarT y)
51 let f x = do y <- guid ; return (x,VarT y)
39− t2' <- foldr (uncurry tSub) t2 `liftM` (mapM f . Set.toList $ getVars t2)
52+ t2' <- foldl' (uncurry . flip tSub) t2 `liftM` (mapM f . Set.toList $ getVars t2)
40 solver ((t1 :=: t2') : cs) subs
53 solver ((t1 :=: t2') : cs) subs
43−cSub k v (t1 :=: t2) = tSub k v t1 :=: tSub k v t2
56+cSub k v (t1 :=: t2) = force $ tSub k v t1 :=: tSub k v t2
44−cSub k v (t1 :<: t2) = tSub k v t1 :<: tSub k v t2
57+cSub k v (t1 :<: t2) = force $ tSub k v t1 :<: tSub k v t2
46−tSub k v (VarT x) = if k == x then v else (VarT x)
59+tSub k v t@(VarT x) = if k == x then v else t
47−tSub k v (LambdaT t1 t2) = LambdaT (tSub k v t1) (tSub k v t2)
60+tSub k v (LambdaT t1 t2) = force $ LambdaT (tSub k v t1) (tSub k v t2)
48−tSub k v (ADT name ts) = ADT name (map (tSub k v) ts)
61+tSub k v (ADT name ts) = ADT name (map (force . tSub k v) ts)
49tSub _ _ t = t
62tSub _ _ t = t
51getVars (VarT x) = Set.singleton x
64getVars (VarT x) = Set.singleton x