@@ -2,7 +2,7 @@
22{-# LANGUAGE OverloadedStrings #-}
33module Type.Unify (unify) where
44
5−import Control.Monad (zipWithM_)
5+import Control.Monad (liftM2, when, zipWithM_)
66import Control.Monad.Except (ExceptT, lift, liftIO, throwError, runExceptT)
77import qualified Data.Map as Map
88import qualified Data.Maybe as Maybe
@@ -91,7 +91,10 @@ data Problem
9191
9292mismatch :: Context -> Maybe Error.Reason -> Unify a
9393mismatch context@(Context orientation var1 _ var2 _) maybeReason =
94− do args1 <- liftIO $ collectArgs var1
94+ do anyInfinite <- liftIO $ liftM2 (||) (Occurs.occurs var1) (Occurs.occurs var2)
95+ when anyInfinite $ throwError Infinite
96+
97+ args1 <- liftIO $ collectArgs var1
9598 args2 <- liftIO $ collectArgs var2
9699
97100 let numArgs1 = length args1
@@ -99,27 +102,26 @@ mismatch context@(Context orientation var1 _ var2 _) maybeReason =
99102
100103 if numArgs1 == numArgs2
101104 then
102− mismatchHelp orientation maybeReason
105+ throwError $ reasonToProblem orientation maybeReason
103106 else
104− do zipWithM_ (\arg1 arg2 -> lift $ runExceptT $ subUnify context arg1 arg2) args1 args2
105− mismatchHelp orientation $ Just $ Error.MissingArgs $ abs (numArgs2 - numArgs1)
107+ do lift $ zipWithM_ (\a1 a2 -> runExceptT $ subUnify context a1 a2) args1 args2
108+ throwError $ reasonToProblem orientation $ Just $
109+ Error.MissingArgs $ abs (numArgs2 - numArgs1)
106110
107111
108−mismatchHelp :: Orientation -> Maybe Error.Reason -> Unify a
109−mismatchHelp orientation maybeReason =
110− throwError $
111− case maybeReason of
112− Nothing ->
113− Typical
112+reasonToProblem :: Orientation -> Maybe Error.Reason -> Problem
113+reasonToProblem orientation maybeReason =
114+ case maybeReason of
115+ Nothing ->
116+ Typical
114117
115− Just reason ->
116− Special $
117− case orientation of
118− ExpectedActual ->
119− reason
118+ Just reason ->
119+ case orientation of
120+ ExpectedActual ->
121+ Special reason
120122
121− ActualExpected ->
122− Error.flipReason reason
123+ ActualExpected ->
124+ Special (Error.flipReason reason)
123125
124126
125127badRigid :: Maybe Text -> Error.Reason