git.iko.soy/elk
on master help sign in
Detect infinite types before unrolling functions upon mismatch
572f3c2Evan Czaplicki
src/Type/Unify.hs+20−18
compare with master
unifiedsplit
@@ -2,7 +2,7 @@
2{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Type.Unify (unify) where
3module Type.Unify (unify) where
4
4
5−import Control.Monad (zipWithM_)
5+import Control.Monad (liftM2, when, zipWithM_)
6import Control.Monad.Except (ExceptT, lift, liftIO, throwError, runExceptT)
6import Control.Monad.Except (ExceptT, lift, liftIO, throwError, runExceptT)
7import qualified Data.Map as Map
7import qualified Data.Map as Map
8import qualified Data.Maybe as Maybe
8import qualified Data.Maybe as Maybe
@@ -91,7 +91,10 @@ data Problem
91
91
92mismatch :: Context -> Maybe Error.Reason -> Unify a
92mismatch :: Context -> Maybe Error.Reason -> Unify a
93mismatch context@(Context orientation var1 _ var2 _) maybeReason =
93mismatch context@(Context orientation var1 _ var2 _) maybeReason =
94+ do anyInfinite <- liftIO $ liftM2 (||) (Occurs.occurs var1) (Occurs.occurs var2)
95+ when anyInfinite $ throwError Infinite
96+
94− do args1 <- liftIO $ collectArgs var1
97+ args1 <- liftIO $ collectArgs var1
95 args2 <- liftIO $ collectArgs var2
98 args2 <- liftIO $ collectArgs var2
96
99
97 let numArgs1 = length args1
100 let numArgs1 = length args1
@@ -99,27 +102,26 @@ mismatch context@(Context orientation var1 _ var2 _) maybeReason =
99
102
100 if numArgs1 == numArgs2
103 if numArgs1 == numArgs2
101 then
104 then
102− mismatchHelp orientation maybeReason
105+ throwError $ reasonToProblem orientation maybeReason
103 else
106 else
104− do zipWithM_ (\arg1 arg2 -> lift $ runExceptT $ subUnify context arg1 arg2) args1 args2
107+ do lift $ zipWithM_ (\a1 a2 -> runExceptT $ subUnify context a1 a2) args1 args2
108+ throwError $ reasonToProblem orientation $ Just $
105− mismatchHelp orientation $ Just $ Error.MissingArgs $ abs (numArgs2 - numArgs1)
109+ Error.MissingArgs $ abs (numArgs2 - numArgs1)
106
110
107
111
108−mismatchHelp :: Orientation -> Maybe Error.Reason -> Unify a
112+reasonToProblem :: Orientation -> Maybe Error.Reason -> Problem
109−mismatchHelp orientation maybeReason =
113+reasonToProblem orientation maybeReason =
110− throwError $
111− case maybeReason of
114+ case maybeReason of
112− Nothing ->
115+ Nothing ->
113− Typical
116+ Typical
114
117
115− Just reason ->
118+ Just reason ->
116− Special $
117− case orientation of
119+ case orientation of
118− ExpectedActual ->
120+ ExpectedActual ->
119− reason
121+ Special reason
120
122
121− ActualExpected ->
123+ ActualExpected ->
122− Error.flipReason reason
124+ Special (Error.flipReason reason)
123
125
124
126
125badRigid :: Maybe Text -> Error.Reason
127badRigid :: Maybe Text -> Error.Reason