@@ -67,7 +67,6 @@ import Control.Arrow (Arrow(..))
6767
6868import qualified Data.Map as M
6969import Data.Function (on)
70−import Debug.Trace (trace)
7170
7271instance Partial Type where
7372 unknown = TUnknown
@@ -211,14 +210,16 @@ typesOf moduleName vals = do
211210 -- Make sure unification variables do not escape
212211 escapeCheck val ty
213212 return triple
214− forM tys $ \(ident, (val, ty)) -> rethrow (("Error in " ++ show ident ++ ": \n") ++) $ do
213+ forM tys $ \(ident, (val, ty)) -> do
215214 -- Replace type class dictionary placeholders with actual dictionaries
216215 val' <- replaceTypeClassDictionaries moduleName val
217216 -- Check skolem variables did not escape their scope
218217 skolemEscapeCheck val'
219− --
220− return $ (ident, (overTypes (desaturateAllTypeSynonyms . setifyAll) $ val'
221− , varIfUnknown . desaturateAllTypeSynonyms . setifyAll $ ty))
218+ -- Remove type synonyms placeholders, remove duplicate row fields, and replace
219+ -- top-level unification variables with named type variables.
220+ let val'' = overTypes (desaturateAllTypeSynonyms . setifyAll) val'
221+ ty' = varIfUnknown . desaturateAllTypeSynonyms . setifyAll $ ty
222+ return $ (ident, (val'', ty'))
222223 where
223224 -- Apply the substitution that was returned from runUnify to both types and (type-annotated) values
224225 tidyUp (ts, sub) = map (\(i, (val, ty)) -> (i, (overTypes (sub $?) val, sub $? ty))) ts
@@ -309,6 +310,9 @@ typeHeadsAreEqual _ _ t (TypeVar v) = Just [(v, t)]
309310typeHeadsAreEqual m e (TypeConstructor c1) (TypeConstructor c2) | typeConstructorsAreEqual e m c1 c2 = Just []
310311typeHeadsAreEqual m e (TypeApp h1 (TypeVar v)) (TypeApp h2 arg) = (:) (v, arg) <$> typeHeadsAreEqual m e h1 h2
311312typeHeadsAreEqual m e t1@(TypeApp _ _) t2@(TypeApp _ (TypeVar _)) = typeHeadsAreEqual m e t2 t1
313+typeHeadsAreEqual m e (SaturatedTypeSynonym name args) t2 = case expandTypeSynonym' e m name args of
314+ Left err -> Nothing
315+ Right t1 -> typeHeadsAreEqual m e t1 t2
312316typeHeadsAreEqual _ _ _ _ = Nothing
313317
314318-- |
@@ -429,12 +433,18 @@ replaceVarWithUnknown ident ty = do
429433-- Replace fully applied type synonyms with the @SaturatedTypeSynonym@ data constructor, which helps generate
430434-- better error messages during unification.
431435--
432−replaceAllTypeSynonyms :: (Functor m, MonadState CheckState m, MonadError String m) => (D.Data d) => d -> m d
436+replaceAllTypeSynonyms' :: (D.Data d) => Environment -> ModuleName -> d -> Either String d
437+replaceAllTypeSynonyms' env moduleName d =
438+ let
439+ syns = map (\((path, name), (args, _)) -> ((path, name), length args)) . M.toList $ typeSynonyms env
440+ in
441+ saturateAllTypeSynonyms env moduleName syns d
442+
443+replaceAllTypeSynonyms :: (Functor m, Monad m, MonadState CheckState m, MonadError String m) => (D.Data d) => d -> m d
433444replaceAllTypeSynonyms d = do
434445 env <- getEnv
435446 Just moduleName <- checkCurrentModule <$> get
436− let syns = map (\((path, name), (args, _)) -> ((path, name), length args)) . M.toList $ typeSynonyms env
437− either throwError return $ saturateAllTypeSynonyms env moduleName syns d
447+ either throwError return $ replaceAllTypeSynonyms' env moduleName d
438448
439449-- |
440450-- \"Desaturate\" @SaturatedTypeSynonym@s
@@ -448,13 +458,19 @@ desaturateAllTypeSynonyms = everywhere (mkT replaceSaturatedTypeSynonym)
448458-- |
449459-- Replace a type synonym and its arguments with the aliased type
450460--
451−expandTypeSynonym :: Qualified ProperName -> [Type] -> UnifyT Type Check Type
461+expandTypeSynonym' :: Environment -> ModuleName -> Qualified ProperName -> [Type] -> Either String Type
462+expandTypeSynonym' env moduleName name args =
463+ case M.lookup (canonicalizeType moduleName env name) (typeSynonyms env) of
464+ Just (synArgs, body) -> do
465+ let repl = replaceAllTypeVars (zip synArgs args) body
466+ replaceAllTypeSynonyms' env moduleName repl
467+ Nothing -> error "Type synonym was not defined"
468+
469+expandTypeSynonym :: (Functor m, Monad m, MonadState CheckState m, MonadError String m) => Qualified ProperName -> [Type] -> m Type
452470expandTypeSynonym name args = do
453471 env <- getEnv
454472 Just moduleName <- checkCurrentModule <$> get
455− case M.lookup (canonicalizeType moduleName env name) (typeSynonyms env) of
456− Just (synArgs, body) -> return $ replaceAllTypeVars (zip synArgs args) body
457− Nothing -> error "Type synonym was not defined"
473+ either throwError return $ expandTypeSynonym' env moduleName name args
458474
459475-- |
460476-- Ensure a set of property names and value does not contain duplicate labels