@@ -26,7 +26,6 @@ module Language.PureScript.TypeChecker.Types
2626
2727import Prelude.Compat
2828
29−import Control.Arrow (second)
3029import Control.Monad
3130import Control.Monad.Error.Class (MonadError(..))
3231import Control.Monad.State.Class (MonadState(..), gets)
@@ -71,7 +70,7 @@ typesOf ::
7170 m [(Ident, (Expr, Type))]
7271typesOf bindingGroupType moduleName vals = do
7372 tys <- fmap tidyUp . escalateWarningWhen isHoleError . liftUnifyWarnings replace $ do
74− (untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup moduleName vals
73+ (untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup (Just moduleName) vals
7574 ds1 <- parU typed $ \e -> checkTypedBindingGroupElement moduleName e dict
7675 ds2 <- forM untyped $ \e -> typeForBindingGroupElement e dict untypedDict
7776 return (map (\x -> (False, x)) ds1 ++ map (\x -> (True, x)) ds2)
@@ -117,26 +116,21 @@ typesOf bindingGroupType moduleName vals = do
117116 tidyUp (ts, sub) = map (\(b, (i, (val, ty))) -> (b, (i, (overTypes (substituteType sub) val, substituteType sub ty)))) ts
118117
119118 -- Replace all the wildcards types with their inferred types
120− replace sub (ErrorMessage hints (WildcardInferredType ty)) =
121− ErrorMessage hints . WildcardInferredType $ substituteType sub ty
122− replace sub (ErrorMessage hints (HoleInferredType name ty env)) =
123− ErrorMessage hints $ HoleInferredType name (substituteType sub ty)
124− (map (second (substituteType sub)) env)
125− replace _ em = em
119+ replace sub = onTypesInErrorMessage (substituteType sub)
126120
127121 isHoleError :: ErrorMessage -> Bool
128122 isHoleError (ErrorMessage _ HoleInferredType{}) = True
129123 isHoleError _ = False
130124
131−type TypeData = M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility)
125+type TypeData = M.Map (Qualified Ident) (Type, NameKind, NameVisibility)
132126
133127type UntypedData = [(Ident, Type)]
134128
135−typeDictionaryForBindingGroup ::
136− (MonadState CheckState m) =>
137− ModuleName ->
138− [(Ident, Expr)] ->
139− m ([(Ident, Expr)], [(Ident, (Expr, Type, Bool))], TypeData, UntypedData)
129+typeDictionaryForBindingGroup
130+ :: (MonadState CheckState m)
131+ => Maybe ModuleName
132+ -> [(Ident, Expr)]
133+ -> m ([(Ident, Expr)], [(Ident, (Expr, Type, Bool))], TypeData, UntypedData)
140134typeDictionaryForBindingGroup moduleName vals = do
141135 let
142136 -- Map each declaration to a name/value pair, with an optional type, if the declaration is typed
@@ -154,15 +148,15 @@ typeDictionaryForBindingGroup moduleName vals = do
154148 -- Make a map of names to the unification variables of untyped declarations
155149 untypedDict = zip (map fst untyped) untypedNames
156150 -- Create the dictionary of all name/type pairs, which will be added to the environment during type checking
157− dict = M.fromList (map (\(ident, ty) -> ((moduleName, ident), (ty, Private, Undefined))) $ typedDict ++ untypedDict)
151+ dict = M.fromList (map (\(ident, ty) -> ((Qualified moduleName ident), (ty, Private, Undefined))) $ typedDict ++ untypedDict)
158152 return (untyped, typed, dict, untypedDict)
159153
160−checkTypedBindingGroupElement ::
161− (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
162− ModuleName ->
163− (Ident, (Expr, Type, Bool)) ->
164− TypeData ->
165− m (Ident, (Expr, Type))
154+checkTypedBindingGroupElement
155+ :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
156+ => ModuleName
157+ -> (Ident, (Expr, Type, Bool))
158+ -> TypeData
159+ -> m (Ident, (Expr, Type))
166160checkTypedBindingGroupElement mn (ident, (val', ty, checkType)) dict = do
167161 -- Replace type wildcards
168162 ty' <- replaceTypeWildcards ty
@@ -176,12 +170,12 @@ checkTypedBindingGroupElement mn (ident, (val', ty, checkType)) dict = do
176170 else return (TypedValue False val' ty'')
177171 return (ident, (val'', ty''))
178172
179−typeForBindingGroupElement ::
180− (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
181− (Ident, Expr) ->
182− TypeData ->
183− UntypedData ->
184− m (Ident, (Expr, Type))
173+typeForBindingGroupElement
174+ :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
175+ => (Ident, Expr)
176+ -> TypeData
177+ -> UntypedData
178+ -> m (Ident, (Expr, Type))
185179typeForBindingGroupElement (ident, val) dict untypedDict = do
186180 -- Infer the type with the new names in scope
187181 TypedValue _ val' ty <- bindNames dict $ infer val
@@ -201,7 +195,7 @@ overTypes f = let (_, f', _) = everywhereOnValues id g id in f'
201195 where
202196 g :: Expr -> Expr
203197 g (TypedValue checkTy val t) = TypedValue checkTy val (f t)
204− g (TypeClassDictionary c sco) = TypeClassDictionary (mapConstraintArgs (map f) c) sco
198+ g (TypeClassDictionary c sco hints) = TypeClassDictionary (mapConstraintArgs (map f) c) sco hints
205199 g other = other
206200
207201-- | Check the kind of a type, failing if it is not of kind *.
@@ -227,7 +221,8 @@ instantiatePolyTypeWithUnknowns val (ForAll ident ty _) = do
227221 instantiatePolyTypeWithUnknowns val ty'
228222instantiatePolyTypeWithUnknowns val (ConstrainedType constraints ty) = do
229223 dicts <- getTypeClassDictionaries
230− instantiatePolyTypeWithUnknowns (foldl App val (map (flip TypeClassDictionary dicts) constraints)) ty
224+ hints <- gets checkHints
225+ instantiatePolyTypeWithUnknowns (foldl App val (map (\cs -> TypeClassDictionary cs dicts hints) constraints)) ty
231226instantiatePolyTypeWithUnknowns val ty = return (val, ty)
232227
233228-- | Infer a type for a value, rethrowing any error to provide a more useful error message
@@ -235,7 +230,7 @@ infer ::
235230 (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) =>
236231 Expr ->
237232 m Expr
238−infer val = rethrow (addHint (ErrorInferringType val)) $ infer' val
233+infer val = withErrorMessageHint (ErrorInferringType val) $ infer' val
239234
240235-- | Infer a type for a value
241236infer' ::
@@ -250,8 +245,11 @@ infer' v@(Literal (BooleanLiteral _)) = return $ TypedValue True v tyBoolean
250245infer' (Literal (ArrayLiteral vals)) = do
251246 ts <- traverse infer vals
252247 els <- freshType
253− forM_ ts $ \(TypedValue _ _ t) -> unifyTypes els t
254− return $ TypedValue True (Literal (ArrayLiteral ts)) (TypeApp tyArray els)
248+ ts' <- forM ts $ \(TypedValue ch val t) -> do
249+ (val', t') <- instantiatePolyTypeWithUnknowns val t
250+ unifyTypes els t'
251+ return (TypedValue ch val' t')
252+ return $ TypedValue True (Literal (ArrayLiteral ts')) (TypeApp tyArray els)
255253infer' (Literal (ObjectLiteral ps)) = do
256254 ensureNoDuplicateProperties ps
257255 ts <- traverse (infer . snd) ps
@@ -267,15 +265,14 @@ infer' (ObjectUpdate o ps) = do
267265 let oldTy = TypeApp tyRecord $ rowFromList (oldTys, row)
268266 o' <- TypedValue True <$> check o oldTy <*> pure oldTy
269267 return $ TypedValue True (ObjectUpdate o' newVals) $ TypeApp tyRecord $ rowFromList (newTys, row)
270−infer' (Accessor prop val) = rethrow (addHint (ErrorCheckingAccessor val prop)) $ do
268+infer' (Accessor prop val) = withErrorMessageHint (ErrorCheckingAccessor val prop) $ do
271269 field <- freshType
272270 rest <- freshType
273271 typed <- check val (TypeApp tyRecord (RCons prop field rest))
274272 return $ TypedValue True (Accessor prop typed) field
275273infer' (Abs (Left arg) ret) = do
276274 ty <- freshType
277− Just moduleName <- checkCurrentModule <$> get
278− withBindingGroupVisible $ bindLocalVariables moduleName [(arg, ty, Defined)] $ do
275+ withBindingGroupVisible $ bindLocalVariables [(arg, ty, Defined)] $ do
279276 body@(TypedValue _ _ bodyTy) <- infer' ret
280277 return $ TypedValue True (Abs (Left arg) body) $ function ty bodyTy
281278infer' (Abs (Right _) _) = internalError "Binder was not desugared"
@@ -284,13 +281,13 @@ infer' (App f arg) = do
284281 (ret, app) <- checkFunctionApplication f' ft arg Nothing
285282 return $ TypedValue True app ret
286283infer' (Var var) = do
287− Just moduleName <- checkCurrentModule <$> get
288− checkVisibility moduleName var
289− ty <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards <=< lookupVariable moduleName $ var
284+ checkVisibility var
285+ ty <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards <=< lookupVariable $ var
290286 case ty of
291287 ConstrainedType constraints ty' -> do
292288 dicts <- getTypeClassDictionaries
293− return $ TypedValue True (foldl App (Var var) (map (flip TypeClassDictionary dicts) constraints)) ty'
289+ hints <- gets checkHints
290+ return $ TypedValue True (foldl App (Var var) (map (\cs -> TypeClassDictionary cs dicts hints) constraints)) ty'
294291 _ -> return $ TypedValue True (Var var) ty
295292infer' v@(Constructor c) = do
296293 env <- getEnv
@@ -316,7 +313,8 @@ infer' (Let ds val) = do
316313 return $ TypedValue True (Let ds' val') valTy
317314infer' (SuperClassDictionary className tys) = do
318315 dicts <- getTypeClassDictionaries
319− return $ TypeClassDictionary (Constraint className tys Nothing) dicts
316+ hints <- gets checkHints
317+ return $ TypeClassDictionary (Constraint className tys Nothing) dicts hints
320318infer' (TypedValue checkType val ty) = do
321319 Just moduleName <- checkCurrentModule <$> get
322320 (kind, args) <- kindOfWithScopedVars ty
@@ -326,12 +324,10 @@ infer' (TypedValue checkType val ty) = do
326324 return $ TypedValue True val' ty'
327325infer' (Hole name) = do
328326 ty <- freshType
329− env <- M.toList . names <$> getEnv
330− Just moduleName <- checkCurrentModule <$> get
331− let ctx = [ (ident, ty') | ((mn, ident@Ident{}), (ty', _, Defined)) <- env, mn == moduleName ]
327+ ctx <- getLocalContext
332328 tell . errorMessage $ HoleInferredType name ty ctx
333329 return $ TypedValue True (Hole name) ty
334−infer' (PositionedValue pos c val) = warnAndRethrowWithPosition pos $ do
330+infer' (PositionedValue pos c val) = warnAndRethrowWithPositionTC pos $ do
335331 TypedValue t v ty <- infer' val
336332 return $ TypedValue t (PositionedValue pos c v) ty
337333infer' v = internalError $ "Invalid argument to infer: " ++ show v
@@ -348,27 +344,26 @@ inferLetBinding seen (ValueDeclaration ident nameKind [] (Right (tv@(TypedValue
348344 Just moduleName <- checkCurrentModule <$> get
349345 (kind, args) <- kindOfWithScopedVars ty
350346 checkTypeKind ty kind
351− let dict = M.singleton (moduleName, ident) (ty, nameKind, Undefined)
347+ let dict = M.singleton (Qualified Nothing ident) (ty, nameKind, Undefined)
352348 ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty
353349 TypedValue _ val' ty'' <- if checkType then withScopedTypeVars moduleName args (bindNames dict (check val ty')) else return tv
354− bindNames (M.singleton (moduleName, ident) (ty'', nameKind, Defined)) $ inferLetBinding (seen ++ [ValueDeclaration ident nameKind [] (Right (TypedValue checkType val' ty''))]) rest ret j
350+ bindNames (M.singleton (Qualified Nothing ident) (ty'', nameKind, Defined)) $ inferLetBinding (seen ++ [ValueDeclaration ident nameKind [] (Right (TypedValue checkType val' ty''))]) rest ret j
355351inferLetBinding seen (ValueDeclaration ident nameKind [] (Right val) : rest) ret j = do
356352 valTy <- freshType
357− Just moduleName <- checkCurrentModule <$> get
358− let dict = M.singleton (moduleName, ident) (valTy, nameKind, Undefined)
353+ let dict = M.singleton (Qualified Nothing ident) (valTy, nameKind, Undefined)
359354 TypedValue _ val' valTy' <- bindNames dict $ infer val
360355 unifyTypes valTy valTy'
361− bindNames (M.singleton (moduleName, ident) (valTy', nameKind, Defined)) $ inferLetBinding (seen ++ [ValueDeclaration ident nameKind [] (Right val')]) rest ret j
356+ bindNames (M.singleton (Qualified Nothing ident) (valTy', nameKind, Defined)) $ inferLetBinding (seen ++ [ValueDeclaration ident nameKind [] (Right val')]) rest ret j
362357inferLetBinding seen (BindingGroupDeclaration ds : rest) ret j = do
363358 Just moduleName <- checkCurrentModule <$> get
364− (untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup moduleName (map (\(i, _, v) -> (i, v)) ds)
359+ (untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup Nothing (map (\(i, _, v) -> (i, v)) ds)
365360 ds1' <- parU typed $ \e -> checkTypedBindingGroupElement moduleName e dict
366361 ds2' <- forM untyped $ \e -> typeForBindingGroupElement e dict untypedDict
367362 let ds' = [(ident, Private, val') | (ident, (val', _)) <- ds1' ++ ds2']
368363 bindNames dict $ do
369364 makeBindingGroupVisible
370365 inferLetBinding (seen ++ [BindingGroupDeclaration ds']) rest ret j
371−inferLetBinding seen (PositionedDeclaration pos com d : ds) ret j = warnAndRethrowWithPosition pos $ do
366+inferLetBinding seen (PositionedDeclaration pos com d : ds) ret j = warnAndRethrowWithPositionTC pos $ do
372367 (d' : ds', val') <- inferLetBinding seen (d : ds) ret j
373368 return (PositionedDeclaration pos com d' : ds', val')
374369inferLetBinding _ _ _ _ = internalError "Invalid argument to inferLetBinding"
@@ -426,7 +421,7 @@ inferBinder val (NamedBinder name binder) = do
426421 m <- inferBinder val binder
427422 return $ M.insert name val m
428423inferBinder val (PositionedBinder pos _ binder) =
429− warnAndRethrowWithPosition pos $ inferBinder val binder
424+ warnAndRethrowWithPositionTC pos $ inferBinder val binder
430425-- TODO: When adding support for polymorphic types, check subsumption here,
431426-- change the definition of `binderRequiresMonotype`,
432427-- and use `kindOfWithScopedVars`.
@@ -480,14 +475,13 @@ checkBinders _ _ [] = return []
480475checkBinders nvals ret (CaseAlternative binders result : bs) = do
481476 guardWith (errorMessage $ OverlappingArgNames Nothing) $
482477 let ns = concatMap binderNames binders in length (nub ns) == length ns
483− Just moduleName <- checkCurrentModule <$> get
484478 m1 <- M.unions <$> zipWithM inferBinder nvals binders
485− r <- bindLocalVariables moduleName [ (name, ty, Defined) | (name, ty) <- M.toList m1 ] $
479+ r <- bindLocalVariables [ (name, ty, Defined) | (name, ty) <- M.toList m1 ] $
486480 CaseAlternative binders <$>
487481 case result of
488482 Left gs -> do
489483 gs' <- forM gs $ \(grd, val) -> do
490− grd' <- rethrow (addHint ErrorCheckingGuard) $ check grd tyBoolean
484+ grd' <- withErrorMessageHint ErrorCheckingGuard $ check grd tyBoolean
491485 val' <- TypedValue True <$> check val ret <*> pure ret
492486 return (grd', val')
493487 return $ Left gs'
@@ -505,7 +499,7 @@ check ::
505499 Expr ->
506500 Type ->
507501 m Expr
508−check val ty = rethrow (addHint (ErrorCheckingType val ty)) $ check' val ty
502+check val ty = withErrorMessageHint (ErrorCheckingType val ty) $ check' val ty
509503
510504-- |
511505-- Check the type of a value
@@ -574,8 +568,7 @@ check' (Literal (ArrayLiteral vals)) t@(TypeApp a ty) = do
574568 return $ TypedValue True array t
575569check' (Abs (Left arg) ret) ty@(TypeApp (TypeApp t argTy) retTy) = do
576570 unifyTypes t tyFunction
577− Just moduleName <- checkCurrentModule <$> get
578− ret' <- withBindingGroupVisible $ bindLocalVariables moduleName [(arg, argTy, Defined)] $ check ret retTy
571+ ret' <- withBindingGroupVisible $ bindLocalVariables [(arg, argTy, Defined)] $ check ret retTy
579572 return $ TypedValue True (Abs (Left arg) ret') ty
580573check' (Abs (Right _) _) _ = internalError "Binder was not desugared"
581574check' (App f arg) ret = do
@@ -583,9 +576,8 @@ check' (App f arg) ret = do
583576 (_, app) <- checkFunctionApplication f' ft arg (Just ret)
584577 return $ TypedValue True app ret
585578check' v@(Var var) ty = do
586− Just moduleName <- checkCurrentModule <$> get
587− checkVisibility moduleName var
588− repl <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< lookupVariable moduleName $ var
579+ checkVisibility var
580+ repl <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< lookupVariable $ var
589581 ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty
590582 v' <- subsumes (Just v) repl ty'
591583 case v' of
@@ -599,7 +591,8 @@ check' (SuperClassDictionary className tys) _ = do
599591 -- declaration gets desugared.
600592 -}
601593 dicts <- getTypeClassDictionaries
602− return $ TypeClassDictionary (Constraint className tys Nothing) dicts
594+ hints <- gets checkHints
595+ return $ TypeClassDictionary (Constraint className tys Nothing) dicts hints
603596check' (TypedValue checkType val ty1) ty2 = do
604597 Just moduleName <- checkCurrentModule <$> get
605598 (kind, args) <- kindOfWithScopedVars ty1
@@ -638,7 +631,7 @@ check' e@(ObjectUpdate obj ps) t@(TypeApp o row) | o == tyRecord = do
638631 obj' <- check obj (TypeApp tyRecord (rowFromList (us ++ remainingProps, rest)))
639632 ps' <- checkProperties e ps row True
640633 return $ TypedValue True (ObjectUpdate obj' ps') t
641−check' (Accessor prop val) ty = rethrow (addHint (ErrorCheckingAccessor val prop)) $ do
634+check' (Accessor prop val) ty = withErrorMessageHint (ErrorCheckingAccessor val prop) $ do
642635 rest <- freshType
643636 val' <- check val (TypeApp tyRecord (RCons prop ty rest))
644637 return $ TypedValue True (Accessor prop val') ty
@@ -659,7 +652,7 @@ check' val kt@(KindedType ty kind) = do
659652 checkTypeKind ty kind
660653 val' <- check' val ty
661654 return $ TypedValue True val' kt
662−check' (PositionedValue pos c val) ty = warnAndRethrowWithPosition pos $ do
655+check' (PositionedValue pos c val) ty = warnAndRethrowWithPositionTC pos $ do
663656 TypedValue t v ty' <- check' val ty
664657 return $ TypedValue t (PositionedValue pos c v) ty'
665658check' val ty = do
@@ -713,7 +706,7 @@ checkFunctionApplication ::
713706 Expr ->
714707 Maybe Type ->
715708 m (Type, Expr)
716−checkFunctionApplication fn fnTy arg ret = rethrow (addHint (ErrorInApplication fn fnTy arg)) $ do
709+checkFunctionApplication fn fnTy arg ret = withErrorMessageHint (ErrorInApplication fn fnTy arg) $ do
717710 subst <- gets checkSubstitution
718711 checkFunctionApplication' fn (substituteType subst fnTy) arg (substituteType subst <$> ret)
719712
@@ -749,7 +742,8 @@ checkFunctionApplication' fn (KindedType ty _) arg ret =
749742 checkFunctionApplication fn ty arg ret
750743checkFunctionApplication' fn (ConstrainedType constraints fnTy) arg ret = do
751744 dicts <- getTypeClassDictionaries
752− checkFunctionApplication' (foldl App fn (map (flip TypeClassDictionary dicts) constraints)) fnTy arg ret
745+ hints <- gets checkHints
746+ checkFunctionApplication' (foldl App fn (map (\cs -> TypeClassDictionary cs dicts hints) constraints)) fnTy arg ret
753747checkFunctionApplication' fn fnTy dict@TypeClassDictionary{} _ =
754748 return (fnTy, App fn dict)
755749checkFunctionApplication' _ fnTy arg _ = throwError . errorMessage $ CannotApplyFunction fnTy arg