@@ -149,7 +149,7 @@ typeForBindingGroupElement (ident, val) dict untypedDict = do
149149-- |
150150-- Check if a value contains a type annotation
151151--
152−isTyped :: (Ident, Expr) -> (Either (Ident, Expr) (Ident, (Expr, Type, Bool)))
152+isTyped :: (Ident, Expr) -> Either (Ident, Expr) (Ident, (Expr, Type, Bool))
153153isTyped (name, TypedValue checkType value ty) = Right (name, (value, ty, checkType))
154154isTyped (name, value) = Left (name, value)
155155
@@ -177,6 +177,14 @@ replaceTypeClassDictionaries mn =
177177 entails env mn dicts constraint trySuperclasses
178178 go other = return other
179179
180+-- |
181+-- Check the kind of a type, failing if it is not of kind *.
182+--
183+checkTypeKind :: ModuleName -> Type -> UnifyT t Check ()
184+checkTypeKind moduleName ty = do
185+ kind <- liftCheck $ kindOf moduleName ty
186+ guardWith (strMsg $ "Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
187+
180188-- |
181189-- Remove any ForAlls and ConstrainedType constructors in a type by introducing new unknowns
182190-- or TypeClassDictionary values.
@@ -282,8 +290,7 @@ infer' (SuperClassDictionary className tys) = do
282290 return $ TypeClassDictionary False (className, tys) dicts
283291infer' (TypedValue checkType val ty) = do
284292 Just moduleName <- checkCurrentModule <$> get
285− kind <- liftCheck $ kindOf moduleName ty
286− guardWith (strMsg $ "Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
293+ checkTypeKind moduleName ty
287294 ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty
288295 val' <- if checkType then check val ty' else return val
289296 return $ TypedValue True val' ty'
@@ -294,8 +301,7 @@ inferLetBinding :: [Declaration] -> [Declaration] -> Expr -> (Expr -> UnifyT Typ
294301inferLetBinding seen [] ret j = (,) seen <$> makeBindingGroupVisible (j ret)
295302inferLetBinding seen (ValueDeclaration ident nameKind [] (Right (tv@(TypedValue checkType val ty))) : rest) ret j = do
296303 Just moduleName <- checkCurrentModule <$> get
297− kind <- liftCheck $ kindOf moduleName ty
298− guardWith (strMsg $ "Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
304+ checkTypeKind moduleName ty
299305 let dict = M.singleton (moduleName, ident) (ty, nameKind, Undefined)
300306 ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty
301307 TypedValue _ val' ty'' <- if checkType then bindNames dict (check val ty') else return tv
@@ -315,7 +321,7 @@ inferLetBinding seen (BindingGroupDeclaration ds : rest) ret j = do
315321 let ds' = [(ident, LocalVariable, val') | (ident, (val', _)) <- ds1' ++ ds2']
316322 makeBindingGroupVisible $ bindNames dict $ inferLetBinding (seen ++ [BindingGroupDeclaration ds']) rest ret j
317323inferLetBinding seen (PositionedDeclaration pos d : ds) ret j = rethrowWithPosition pos $ do
318− ((d' : ds'), val') <- inferLetBinding seen (d : ds) ret j
324+ (d' : ds', val') <- inferLetBinding seen (d : ds) ret j
319325 return (PositionedDeclaration pos d' : ds', val')
320326inferLetBinding _ _ _ _ = error "Invalid argument to inferLetBinding"
321327
@@ -497,8 +503,7 @@ check' (SuperClassDictionary className tys) _ = do
497503 return $ TypeClassDictionary False (className, tys) dicts
498504check' (TypedValue checkType val ty1) ty2 = do
499505 Just moduleName <- checkCurrentModule <$> get
500− kind <- liftCheck $ kindOf moduleName ty1
501− guardWith (strMsg $ "Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
506+ checkTypeKind moduleName ty1
502507 ty1' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1
503508 ty2' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty2
504509 val' <- subsumes (Just val) ty1' ty2'
@@ -547,7 +552,7 @@ check' (Constructor c) ty = do
547552 _ <- subsumes Nothing repl ty
548553 return $ TypedValue True (Constructor c) ty
549554check' (Let ds val) ty = do
550− (ds', val') <- inferLetBinding [] ds val (flip check ty)
555+ (ds', val') <- inferLetBinding [] ds val (`check` ty)
551556 return $ TypedValue True (Let ds' val') ty
552557check' val ty | containsTypeSynonyms ty = do
553558 ty' <- introduceSkolemScope <=< expandAllTypeSynonyms $ ty
@@ -575,7 +580,7 @@ checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where
575580 go [] [] REmpty = return []
576581 go [] [] u@(TUnknown _) = do u =?= REmpty
577582 return []
578− go [] [] (Skolem _ _ _) | lax = return []
583+ go [] [] Skolem{} | lax = return []
579584 go [] ((p, _): _) _ | lax = return []
580585 | otherwise = throwError $ mkErrorStack ("Object does not have property " ++ p) (Just (ExprError (ObjectLiteral ps)))
581586 go ((p,_):_) [] REmpty = throwError $ mkErrorStack ("Property " ++ p ++ " is not present in closed object type " ++ prettyPrintRow row) (Just (ExprError (ObjectLiteral ps)))
@@ -638,12 +643,12 @@ checkFunctionApplication' fn u@(TUnknown _) arg ret = do
638643checkFunctionApplication' fn (SaturatedTypeSynonym name tyArgs) arg ret = do
639644 ty <- introduceSkolemScope <=< expandTypeSynonym name $ tyArgs
640645 checkFunctionApplication fn ty arg ret
641−checkFunctionApplication' fn (KindedType ty _) arg ret = do
646+checkFunctionApplication' fn (KindedType ty _) arg ret =
642647 checkFunctionApplication fn ty arg ret
643648checkFunctionApplication' fn (ConstrainedType constraints fnTy) arg ret = do
644649 dicts <- getTypeClassDictionaries
645650 checkFunctionApplication' (foldl App fn (map (flip (TypeClassDictionary True) dicts) constraints)) fnTy arg ret
646−checkFunctionApplication' fn fnTy dict@(TypeClassDictionary _ _ _) _ =
651+checkFunctionApplication' fn fnTy dict@TypeClassDictionary{} _ =
647652 return (fnTy, App fn dict)
648653checkFunctionApplication' _ fnTy arg _ = throwError . strMsg $ "Cannot apply a function of type "
649654 ++ prettyPrintType fnTy