@@ -12,7 +12,7 @@
1212--
1313-----------------------------------------------------------------------------
1414
15−{-# LANGUAGE DeriveDataTypeable #-}
15+{-# LANGUAGE DeriveDataTypeable, FlexibleContexts #-}
1616
1717module Language.PureScript.TypeChecker.Types (
1818 typeOf
@@ -82,7 +82,7 @@ instance Unifiable Row where
8282 forM_ int (uncurry (~~))
8383 unifyRows sd1 r1' sd2 r2'
8484 where
85− unifyRows :: [(String, Type)] -> Row -> [(String, Type)] -> Row -> Subst Check ()
85+ unifyRows :: [(String, Type)] -> Row -> [(String, Type)] -> Row -> Subst ()
8686 unifyRows [] (RUnknown u) sd r = replace u (rowFromList (sd, r))
8787 unifyRows sd r [] (RUnknown u) = replace u (rowFromList (sd, r))
8888 unifyRows ns@((name, ty):row) r others u@(RUnknown un) = do
@@ -102,7 +102,7 @@ instance Unifiable Row where
102102 unknowns (RCons _ ty r) = unknowns ty ++ unknowns r
103103 unknowns _ = []
104104
105−unifyTypes :: Type -> Type -> Subst Check ()
105+unifyTypes :: Type -> Type -> Subst ()
106106unifyTypes t1 t2 = rethrow (\e -> "Error unifying type " ++ prettyPrintType t1 ++ " with type " ++ prettyPrintType t2 ++ ":\n" ++ e) $ do
107107 unifyTypes' t1 t2
108108 where
@@ -134,7 +134,7 @@ unifyTypes t1 t2 = rethrow (\e -> "Error unifying type " ++ prettyPrintType t1 +
134134 ret1 `unifyTypes` ret2
135135 unifyTypes' (TypeVar v1) (TypeVar v2) | v1 == v2 = return ()
136136 unifyTypes' (TypeConstructor c1) (TypeConstructor c2) = do
137− modulePath <- checkModulePath `fmap` lift get
137+ modulePath <- checkModulePath `fmap` get
138138 guardWith ("Cannot unify " ++ show c1 ++ " with " ++ show c2 ++ ".") (qualify modulePath c1 == qualify modulePath c2)
139139 unifyTypes' (TypeApp t1 t2) (TypeApp t3 t4) = do
140140 t1 `unifyTypes` t3
@@ -153,17 +153,19 @@ typeOf name val = do
153153 Just ident | isFunction val ->
154154 case val of
155155 TypedValue val ty -> do
156− kind <- lift $ kindOf ty
156+ kind <- liftCheck $ kindOf ty
157157 guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
158− ty' <- lift $ replaceAllTypeSynonyms ty
159− check (M.singleton ident ty) val ty'
158+ ty' <- replaceAllTypeSynonyms ty
159+ modulePath <- checkModulePath <$> get
160+ bindNames (M.singleton (modulePath, ident) (ty, LocalVariable)) $ check val ty'
160161 return ty'
161162 _ -> do
162163 me <- fresh
163− ty <- infer (M.singleton ident me) val
164+ modulePath <- checkModulePath <$> get
165+ ty <- bindNames (M.singleton (modulePath, ident) (me, LocalVariable)) $ infer val
164166 ty ~~ me
165167 return ty
166− _ -> infer M.empty val
168+ _ -> infer val
167169 escapeCheck checks ty sub
168170 skolemEscapeCheck ty
169171 return $ varIfUnknown $ desaturateAllTypeSynonyms $ setifyAll ty
@@ -225,17 +227,17 @@ replaceRowVars name r = everywhere (mkT replace)
225227 replace (RowVar v) | v == name = r
226228 replace t = t
227229
228−replaceAllVarsWithUnknowns :: Type -> Subst Check Type
230+replaceAllVarsWithUnknowns :: Type -> Subst Type
229231replaceAllVarsWithUnknowns (ForAll ident ty) = replaceVarWithUnknown ident ty >>= replaceAllVarsWithUnknowns
230232replaceAllVarsWithUnknowns ty = return ty
231233
232−replaceVarWithUnknown :: String -> Type -> Subst Check Type
234+replaceVarWithUnknown :: String -> Type -> Subst Type
233235replaceVarWithUnknown ident ty = do
234236 tu <- fresh
235237 ru <- fresh
236238 return $ replaceRowVars ident ru . replaceTypeVars ident tu $ ty
237239
238−replaceAllTypeSynonyms :: (D.Data d) => d -> Check d
240+replaceAllTypeSynonyms :: (Functor m, MonadState CheckState m, MonadError String m) => (D.Data d) => d -> m d
239241replaceAllTypeSynonyms d = do
240242 env <- getEnv
241243 let syns = map (\((path, name), (args, _)) -> (Qualified path name, length args)) . M.toList $ typeSynonyms env
@@ -247,61 +249,62 @@ desaturateAllTypeSynonyms = everywhere (mkT replace)
247249 replace (SaturatedTypeSynonym name args) = foldl TypeApp (TypeConstructor name) args
248250 replace t = t
249251
250−expandAllTypeSynonyms :: Type -> Subst Check Type
252+expandAllTypeSynonyms :: Type -> Subst Type
251253expandAllTypeSynonyms (SaturatedTypeSynonym name args) = expandTypeSynonym name args >>= expandAllTypeSynonyms
252254expandAllTypeSynonyms ty = return ty
253255
254−expandTypeSynonym :: Qualified ProperName -> [Type] -> Subst Check Type
256+expandTypeSynonym :: Qualified ProperName -> [Type] -> Subst Type
255257expandTypeSynonym name args = do
256− env <- lift getEnv
257− modulePath <- checkModulePath `fmap` lift get
258+ env <- getEnv
259+ modulePath <- checkModulePath `fmap` get
258260 case M.lookup (qualify modulePath name) (typeSynonyms env) of
259261 Just (synArgs, body) -> return $ replaceAllTypeVars (zip synArgs args) body
260262 Nothing -> error "Type synonym was not defined"
261263
262−ensureNoDuplicateProperties :: [(String, Value)] -> Check ()
264+ensureNoDuplicateProperties :: (MonadError String m) => [(String, Value)] -> m ()
263265ensureNoDuplicateProperties ps = guardWith "Duplicate property names" $ length (nub . map fst $ ps) == length ps
264266
265−infer :: M.Map Ident Type -> Value -> Subst Check Type
266−infer m val = rethrow (\e -> "Error inferring type of term " ++ prettyPrintValue val ++ ":\n" ++ e) $ do
267− ty <- infer' m val
267+infer :: Value -> Subst Type
268+infer val = rethrow (\e -> "Error inferring type of term " ++ prettyPrintValue val ++ ":\n" ++ e) $ do
269+ ty <- infer' val
268270 escapeCheckLater ty
269271 return ty
270272
271−infer' _ (NumericLiteral _) = return Number
272−infer' _ (StringLiteral _) = return String
273−infer' _ (BooleanLiteral _) = return Boolean
274−infer' m (ArrayLiteral vals) = do
275− ts <- mapM (infer m) vals
273+infer' :: Value -> Subst Type
274+infer' (NumericLiteral _) = return Number
275+infer' (StringLiteral _) = return String
276+infer' (BooleanLiteral _) = return Boolean
277+infer' (ArrayLiteral vals) = do
278+ ts <- mapM (infer) vals
276279 arr <- fresh
277280 forM_ ts $ \t -> arr ~~ Array t
278281 return arr
279−infer' m (Unary op val) = do
280− t <- infer m val
282+infer' (Unary op val) = do
283+ t <- infer val
281284 inferUnary op t
282−infer' m (Binary op left right) = do
283− t1 <- infer m left
284− t2 <- infer m right
285+infer' (Binary op left right) = do
286+ t1 <- infer left
287+ t2 <- infer right
285288 inferBinary op t1 t2
286−infer' m (ObjectLiteral ps) = do
287− lift $ ensureNoDuplicateProperties ps
288− ts <- mapM (infer m . snd) ps
289+infer' (ObjectLiteral ps) = do
290+ ensureNoDuplicateProperties ps
291+ ts <- mapM (infer . snd) ps
289292 let fields = zipWith (\(name, _) t -> (name, t)) ps ts
290293 return $ Object $ rowFromList (fields, REmpty)
291−infer' m (ObjectUpdate o ps) = do
292− lift $ ensureNoDuplicateProperties ps
294+infer' (ObjectUpdate o ps) = do
295+ ensureNoDuplicateProperties ps
293296 row <- fresh
294− newTys <- zipWith (\(name, _) t -> (name, t)) ps <$> mapM (infer m . snd) ps
297+ newTys <- zipWith (\(name, _) t -> (name, t)) ps <$> mapM (infer . snd) ps
295298 oldTys <- zip (map fst ps) <$> replicateM (length ps) fresh
296− check m o $ Object $ rowFromList (oldTys, row)
299+ check o $ Object $ rowFromList (oldTys, row)
297300 return $ Object $ rowFromList (newTys, row)
298−infer' m (Indexer index val) = do
301+infer' (Indexer index val) = do
299302 el <- fresh
300− check m index Number
301− check m val (Array el)
303+ check index Number
304+ check val (Array el)
302305 return el
303−infer' m (Accessor prop val) = do
304− obj <- infer m val
306+infer' (Accessor prop val) = do
307+ obj <- infer val
305308 propTy <- inferProperty obj prop
306309 case propTy of
307310 Nothing -> do
@@ -310,61 +313,53 @@ infer' m (Accessor prop val) = do
310313 obj `subsumes` Object (RCons prop field rest)
311314 return field
312315 Just ty -> return ty
313−infer' m (Abs args ret) = do
316+infer' (Abs args ret) = do
314317 ts <- replicateM (length args) fresh
315− let m' = m `M.union` M.fromList (zip args ts)
316− body <- infer m' ret
317− return $ Function ts body
318−infer' m app@(App _ _) = do
318+ bindLocalVariables (zip args ts) $ do
319+ body <- infer' ret
320+ return $ Function ts body
321+infer' app@(App _ _) = do
319322 let (f, argss) = unfoldApplication app
320− ft <- infer m f
323+ ft <- infer f
321324 ret <- fresh
322− checkFunctionApplications m ft argss ret
325+ checkFunctionApplications ft argss ret
323326 return ret
324−infer' m (Var var@(Qualified mp name)) = do
325− case mp of
326− ModulePath [] ->
327− case M.lookup name m of
328− Just ty -> lift $ replaceAllTypeSynonyms ty
329− Nothing -> lookupGlobal
330− _ -> lookupGlobal
331− where
332− lookupGlobal = do
333− env <- lift getEnv
334− modulePath <- checkModulePath `fmap` lift get
335− case M.lookup (qualify modulePath var) (names env) of
336− Nothing -> throwError $ show var ++ " is undefined"
337− Just (ty, _) -> lift $ replaceAllTypeSynonyms ty
338−infer' m (Block ss) = do
327+infer' (Var var@(Qualified mp name)) = do
328+ env <- getEnv
329+ modulePath <- checkModulePath `fmap` get
330+ case M.lookup (qualify modulePath var) (names env) of
331+ Nothing -> throwError $ show var ++ " is undefined"
332+ Just (ty, _) -> replaceAllTypeSynonyms ty
333+infer' (Block ss) = do
339334 ret <- fresh
340− (allCodePathsReturn, _) <- checkBlock m M.empty ret ss
335+ (allCodePathsReturn, _) <- checkBlock M.empty ret ss
341336 guardWith "Block is missing a return statement" allCodePathsReturn
342337 return ret
343−infer' m (Constructor c) = do
344− env <- lift getEnv
345− modulePath <- checkModulePath `fmap` lift get
338+infer' (Constructor c) = do
339+ env <- getEnv
340+ modulePath <- checkModulePath `fmap` get
346341 case M.lookup (qualify modulePath c) (dataConstructors env) of
347342 Nothing -> throwError $ "Constructor " ++ show c ++ " is undefined"
348− Just ty -> lift $ replaceAllTypeSynonyms ty
349−infer' m (Case val binders) = do
350− t1 <- infer m val
343+ Just ty -> replaceAllTypeSynonyms ty
344+infer' (Case val binders) = do
345+ t1 <- infer val
351346 ret <- fresh
352− checkBinders m t1 ret binders
347+ checkBinders t1 ret binders
353348 return ret
354−infer' m (IfThenElse cond th el) = do
355− check m cond Boolean
356− t2 <- infer m th
357− t3 <- infer m el
349+infer' (IfThenElse cond th el) = do
350+ check cond Boolean
351+ t2 <- infer th
352+ t3 <- infer el
358353 t2 ~~ t3
359354 return t2
360−infer' m (TypedValue val ty) = do
361− kind <- lift $ kindOf ty
355+infer' (TypedValue val ty) = do
356+ kind <- liftCheck $ kindOf ty
362357 guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
363− ty' <- lift $ replaceAllTypeSynonyms ty
364− check m val ty'
358+ ty' <- replaceAllTypeSynonyms ty
359+ check val ty'
365360 return ty'
366361
367−inferProperty :: Type -> String -> Subst Check (Maybe Type)
362+inferProperty :: Type -> String -> Subst (Maybe Type)
368363inferProperty (Object row) prop = do
369364 let (props, _) = rowToList row
370365 return $ lookup prop props
@@ -376,19 +371,19 @@ inferProperty (ForAll ident ty) prop = do
376371 inferProperty replaced prop
377372inferProperty _ prop = return Nothing
378373
379−inferUnary :: UnaryOperator -> Type -> Subst Check Type
374+inferUnary :: UnaryOperator -> Type -> Subst Type
380375inferUnary op val =
381376 case fromMaybe (error "Invalid operator") $ lookup op unaryOps of
382377 (valTy, resTy) -> do
383378 val ~~ valTy
384379 return resTy
385380
386−checkUnary :: M.Map Ident Type -> UnaryOperator -> Value -> Type -> Subst Check ()
387−checkUnary m op val res =
381+checkUnary :: UnaryOperator -> Value -> Type -> Subst ()
382+checkUnary op val res =
388383 case fromMaybe (error "Invalid operator") $ lookup op unaryOps of
389384 (valTy, resTy) -> do
390385 res ~~ resTy
391− check m val valTy
386+ check val valTy
392387
393388unaryOps :: [(UnaryOperator, (Type, Type))]
394389unaryOps = [ (Negate, (Number, Number))
@@ -396,7 +391,7 @@ unaryOps = [ (Negate, (Number, Number))
396391 , (BitwiseNot, (Number, Number))
397392 ]
398393
399−inferBinary :: BinaryOperator -> Type -> Type -> Subst Check Type
394+inferBinary :: BinaryOperator -> Type -> Type -> Subst Type
400395inferBinary op left right | isEqualityTest op = do
401396 left ~~ right
402397 return Boolean
@@ -407,18 +402,18 @@ inferBinary op left right =
407402 right ~~ valTy
408403 return resTy
409404
410−checkBinary :: M.Map Ident Type -> BinaryOperator -> Value -> Value -> Type -> Subst Check ()
411−checkBinary m op left right res | isEqualityTest op = do
405+checkBinary :: BinaryOperator -> Value -> Value -> Type -> Subst ()
406+checkBinary op left right res | isEqualityTest op = do
412407 res ~~ Boolean
413− t1 <- infer m left
414− t2 <- infer m right
408+ t1 <- infer left
409+ t2 <- infer right
415410 t1 ~~ t2
416−checkBinary m op left right res =
411+checkBinary op left right res =
417412 case fromMaybe (error "Invalid operator") $ lookup op binaryOps of
418413 (valTy, resTy) -> do
419414 res ~~ resTy
420− check m left valTy
421− check m right valTy
415+ check left valTy
416+ check right valTy
422417
423418isEqualityTest :: BinaryOperator -> Bool
424419isEqualityTest EqualTo = True
@@ -446,23 +441,23 @@ binaryOps = [ (Add, (Number, Number))
446441 , (GreaterThanOrEqualTo, (Number, Boolean))
447442 ]
448443
449−inferBinder :: Type -> Binder -> Subst Check (M.Map Ident Type)
444+inferBinder :: Type -> Binder -> Subst (M.Map Ident Type)
450445inferBinder _ NullBinder = return M.empty
451446inferBinder val (StringBinder _) = val ~~ String >> return M.empty
452447inferBinder val (NumberBinder _) = val ~~ Number >> return M.empty
453448inferBinder val (BooleanBinder _) = val ~~ Boolean >> return M.empty
454449inferBinder val (VarBinder name) = return $ M.singleton name val
455450inferBinder val (NullaryBinder ctor) = do
456− env <- lift getEnv
457− modulePath <- checkModulePath `fmap` lift get
451+ env <- getEnv
452+ modulePath <- checkModulePath <$> get
458453 case M.lookup (qualify modulePath ctor) (dataConstructors env) of
459454 Just ty -> do
460455 ty `subsumes` val
461456 return M.empty
462457 _ -> throwError $ "Constructor " ++ show ctor ++ " is not defined"
463458inferBinder val (UnaryBinder ctor binder) = do
464− env <- lift getEnv
465− modulePath <- checkModulePath `fmap` lift get
459+ env <- getEnv
460+ modulePath <- checkModulePath <$> get
466461 case M.lookup (qualify modulePath ctor) (dataConstructors env) of
467462 Just ty -> do
468463 Function [obj] ret <- replaceAllVarsWithUnknowns ty
@@ -476,7 +471,7 @@ inferBinder val (ObjectBinder props) = do
476471 val ~~ Object row
477472 return m1
478473 where
479− inferRowProperties :: Row -> Row -> [(String, Binder)] -> Subst Check (M.Map Ident Type)
474+ inferRowProperties :: Row -> Row -> [(String, Binder)] -> Subst (M.Map Ident Type)
480475 inferRowProperties nrow row [] = nrow ~~ row >> return M.empty
481476 inferRowProperties nrow row ((name, binder):binders) = do
482477 propTy <- fresh
@@ -496,97 +491,95 @@ inferBinder val (NamedBinder name binder) = do
496491 m <- inferBinder val binder
497492 return $ M.insert name val m
498493
499−inferGuardedBinder :: M.Map Ident Type -> Type -> Binder -> Subst Check (M.Map Ident Type)
500−inferGuardedBinder m val (GuardedBinder cond binder) = do
494+inferGuardedBinder :: Type -> Binder -> Subst (M.Map Ident Type)
495+inferGuardedBinder val (GuardedBinder cond binder) = do
501496 m1 <- inferBinder val binder
502− check (m1 `M.union` m) cond Boolean
497+ bindLocalVariables (M.toList m1) $ check cond Boolean
503498 return m1
504−inferGuardedBinder m val b = inferBinder val b
505−
506−checkBinders :: M.Map Ident Type -> Type -> Type -> [(Binder, Value)] -> Subst Check ()
507−checkBinders _ _ _ [] = return ()
508−checkBinders m nval ret ((binder, val):bs) = do
509− m1 <- inferGuardedBinder m nval binder
510− check (m1 `M.union` m) val ret
511− checkBinders m nval ret bs
512−
513−assignVariable :: Ident -> M.Map Ident Type -> Subst Check ()
514−assignVariable name m =
515− case M.lookup name m of
516− Nothing -> return ()
517− Just _ -> throwError $ "Variable with name " ++ show name ++ " already exists."
518−
519−checkStatement :: M.Map Ident Type -> M.Map Ident Type -> Type -> Statement -> Subst Check (Bool, M.Map Ident Type)
520−checkStatement m mass ret (VariableIntroduction name val) = do
521− assignVariable name (m `M.union` mass)
522− t <- infer m val
499+inferGuardedBinder val b = inferBinder val b
500+
501+checkBinders :: Type -> Type -> [(Binder, Value)] -> Subst ()
502+checkBinders _ _ [] = return ()
503+checkBinders nval ret ((binder, val):bs) = do
504+ m1 <- inferGuardedBinder nval binder
505+ bindLocalVariables (M.toList m1) $ check val ret
506+ checkBinders nval ret bs
507+
508+assignVariable :: Ident -> Subst ()
509+assignVariable name = do
510+ env <- checkEnv <$> get
511+ modulePath <- checkModulePath <$> get
512+ case M.lookup (modulePath, name) (names env) of
513+ Just (_, LocalVariable) -> throwError $ "Variable with name " ++ show name ++ " already exists."
514+ _ -> return ()
515+
516+checkStatement :: M.Map Ident Type -> Type -> Statement -> Subst (Bool, M.Map Ident Type)
517+checkStatement mass ret (VariableIntroduction name val) = do
518+ assignVariable name
519+ t <- infer val
523520 return (False, M.insert name t mass)
524−checkStatement m mass ret (Assignment ident val) = do
525− t <- infer m val
521+checkStatement mass ret (Assignment ident val) = do
522+ t <- infer val
526523 case M.lookup ident mass of
527524 Nothing -> throwError $ "No local variable with name " ++ show ident
528525 Just ty -> do t ~~ ty
529526 return (False, mass)
530−checkStatement m mass ret (While val inner) = do
531− check m val Boolean
532− (allCodePathsReturn, _) <- checkBlock m mass ret inner
527+checkStatement mass ret (While val inner) = do
528+ check val Boolean
529+ (allCodePathsReturn, _) <- checkBlock mass ret inner
533530 return (allCodePathsReturn, mass)
534−checkStatement m mass ret (If ifst) = do
535− allCodePathsReturn <- checkIfStatement m mass ret ifst
531+checkStatement mass ret (If ifst) = do
532+ allCodePathsReturn <- checkIfStatement mass ret ifst
536533 return (allCodePathsReturn, mass)
537−checkStatement m mass ret (For ident start end inner) = do
538− assignVariable ident (m `M.union` mass)
539− check (m `M.union` mass) start Number
540− check (m `M.union` mass) end Number
541− let mass1 = M.insert ident Number mass
542− (allCodePathsReturn, _) <- checkBlock (m `M.union` mass1) mass1 ret inner
534+checkStatement mass ret (For ident start end inner) = do
535+ assignVariable ident
536+ check start Number
537+ check end Number
538+ (allCodePathsReturn, _) <- bindLocalVariables [(ident, Number)] $ checkBlock mass ret inner
543539 return (allCodePathsReturn, mass)
544−checkStatement m mass ret (ForEach ident vals inner) = do
545− assignVariable ident (m `M.union` mass)
540+checkStatement mass ret (ForEach ident vals inner) = do
541+ assignVariable ident
546542 val <- fresh
547− check (m `M.union` mass) vals (Array val)
548− let mass1 = M.insert ident val mass
549− (allCodePathsReturn, _) <- checkBlock (m `M.union` mass1) mass1 ret inner
543+ check vals (Array val)
544+ (allCodePathsReturn, _) <- bindLocalVariables [(ident, val)] $ checkBlock mass ret inner
550545 guardWith "Cannot return from within a foreach block" $ not allCodePathsReturn
551546 return (False, mass)
552−checkStatement m mass ret (Return val) = do
553− check (m `M.union` mass) val ret
547+checkStatement mass ret (Return val) = do
548+ check val ret
554549 return (True, mass)
555550
556−checkIfStatement :: M.Map Ident Type -> M.Map Ident Type -> Type -> IfStatement -> Subst Check Bool
557−checkIfStatement m mass ret (IfStatement val thens Nothing) = do
558− check m val Boolean
559− _ <- checkBlock m mass ret thens
551+checkIfStatement :: M.Map Ident Type -> Type -> IfStatement -> Subst Bool
552+checkIfStatement mass ret (IfStatement val thens Nothing) = do
553+ check val Boolean
554+ _ <- checkBlock mass ret thens
560555 return False
561−checkIfStatement m mass ret (IfStatement val thens (Just elses)) = do
562− check m val Boolean
563− (allCodePathsReturn1, _) <- checkBlock m mass ret thens
564− allCodePathsReturn2 <- checkElseStatement m mass ret elses
556+checkIfStatement mass ret (IfStatement val thens (Just elses)) = do
557+ check val Boolean
558+ (allCodePathsReturn1, _) <- checkBlock mass ret thens
559+ allCodePathsReturn2 <- checkElseStatement mass ret elses
565560 return $ allCodePathsReturn1 && allCodePathsReturn2
566561
567−checkElseStatement :: M.Map Ident Type -> M.Map Ident Type -> Type -> ElseStatement -> Subst Check Bool
568−checkElseStatement m mass ret (Else elses) = fst <$> checkBlock m mass ret elses
569−checkElseStatement m mass ret (ElseIf ifst) = checkIfStatement m mass ret ifst
562+checkElseStatement :: M.Map Ident Type -> Type -> ElseStatement -> Subst Bool
563+checkElseStatement mass ret (Else elses) = fst <$> checkBlock mass ret elses
564+checkElseStatement mass ret (ElseIf ifst) = checkIfStatement mass ret ifst
570565
571−checkBlock :: M.Map Ident Type -> M.Map Ident Type -> Type -> [Statement] -> Subst Check (Bool, M.Map Ident Type)
572−checkBlock _ mass _ [] = return (False, mass)
573−checkBlock m mass ret (s:ss) = do
574− (b1, mass1) <- checkStatement (m `M.union` mass) mass ret s
575− case (b1, ss) of
566+checkBlock :: M.Map Ident Type -> Type -> [Statement] -> Subst (Bool, M.Map Ident Type)
567+checkBlock mass _ [] = return (False, mass)
568+checkBlock mass ret (s:ss) = do
569+ (b1, mass1) <- checkStatement mass ret s
570+ bindLocalVariables (M.toList mass1) $ case (b1, ss) of
576571 (True, []) -> return (True, mass1)
577572 (True, _) -> throwError "Unreachable code"
578− (False, ss) -> do
579− (b2, mass2) <- checkBlock m mass1 ret ss
580− return (b2, mass2)
573+ (False, ss) -> checkBlock mass1 ret ss
581574
582−skolemize :: String -> Type -> Subst Check Type
575+skolemize :: String -> Type -> Subst Type
583576skolemize ident ty = do
584577 tsk <- Skolem <$> fresh'
585578 rsk <- RSkolem <$> fresh'
586579 return $ replaceRowVars ident rsk $ replaceTypeVars ident tsk ty
587580
588−check :: M.Map Ident Type -> Value -> Type -> Subst Check ()
589−check m val ty = rethrow errorMessage $ check' m val ty
581+check :: Value -> Type -> Subst ()
582+check val ty = rethrow errorMessage $ check' val ty
590583 where
591584 errorMessage msg =
592585 "Error checking type of term " ++
@@ -596,92 +589,81 @@ check m val ty = rethrow errorMessage $ check' m val ty
596589 ":\n" ++
597590 msg
598591
599−check' :: M.Map Ident Type -> Value -> Type -> Subst Check ()
600−check' m val (ForAll idents ty) = do
592+check' :: Value -> Type -> Subst ()
593+check' val (ForAll idents ty) = do
601594 sk <- skolemize idents ty
602− check m val sk
603−check' m val u@(TUnknown _) = do
604− ty <- infer m val
595+ check val sk
596+check' val u@(TUnknown _) = do
597+ ty <- infer val
605598 -- Don't unify an unknown with an inferred polytype
606599 ty' <- replaceAllVarsWithUnknowns ty
607600 ty' ~~ u
608−check' m (NumericLiteral _) Number = return ()
609−check' m (StringLiteral _) String = return ()
610−check' m (BooleanLiteral _) Boolean = return ()
611−check' m (Unary op val) ty = checkUnary m op val ty
612−check' m (Binary op left right) ty = checkBinary m op left right ty
613−check' m (ArrayLiteral vals) (Array ty) = forM_ vals (\val -> check m val ty)
614−check' m (Indexer index vals) ty = check m index Number >> check m vals (Array ty)
615−check' m (Abs args ret) (Function argTys retTy) = do
601+check' (NumericLiteral _) Number = return ()
602+check' (StringLiteral _) String = return ()
603+check' (BooleanLiteral _) Boolean = return ()
604+check' (Unary op val) ty = checkUnary op val ty
605+check' (Binary op left right) ty = checkBinary op left right ty
606+check' (ArrayLiteral vals) (Array ty) = forM_ vals (\val -> check val ty)
607+check' (Indexer index vals) ty = check index Number >> check vals (Array ty)
608+check' (Abs args ret) (Function argTys retTy) = do
616609 guardWith "Incorrect number of function arguments" (length args == length argTys)
617− let bindings = M.fromList (zip args argTys)
618− check (bindings `M.union` m) ret retTy
619−check' m app@(App _ _) ret = do
610+ bindLocalVariables (zip args argTys) $ check ret retTy
611+check' app@(App _ _) ret = do
620612 let (f, argss) = unfoldApplication app
621− ft <- infer m f
622− checkFunctionApplications m ft argss ret
623−check' m v@(Var var@(Qualified mp name)) ty = do
624− case mp of
625− ModulePath [] ->
626− case M.lookup name m of
627− Just ty1 -> do
628− repl <- lift $ replaceAllTypeSynonyms ty1
629− repl `subsumes` ty
630− Nothing -> lookupGlobal
631− _ -> lookupGlobal
632− where
633− lookupGlobal = do
634− env <- lift getEnv
635− modulePath <- checkModulePath `fmap` lift get
636− case M.lookup (qualify modulePath var) (names env) of
637− Nothing -> throwError $ show var ++ " is undefined"
638− Just (ty1, _) -> do
639− repl <- lift $ replaceAllTypeSynonyms ty1
640− repl `subsumes` ty
641−check' m (TypedValue val ty1) ty2 = do
642− kind <- lift $ kindOf ty1
613+ ft <- infer f
614+ checkFunctionApplications ft argss ret
615+check' v@(Var var@(Qualified mp name)) ty = do
616+ env <- getEnv
617+ modulePath <- checkModulePath <$> get
618+ case M.lookup (qualify modulePath var) (names env) of
619+ Nothing -> throwError $ show var ++ " is undefined"
620+ Just (ty1, _) -> do
621+ repl <- replaceAllTypeSynonyms ty1
622+ repl `subsumes` ty
623+check' (TypedValue val ty1) ty2 = do
624+ kind <- liftCheck $ kindOf ty1
643625 guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
644626 ty1 `subsumes` ty2
645− check m val ty1
646−check' m (Case val binders) ret = do
647− t1 <- infer m val
648− checkBinders m t1 ret binders
649−check' m (IfThenElse cond th el) ty = do
650− check m cond Boolean
651− check m th ty
652− check m el ty
653−check' m (ObjectLiteral ps) (Object row) = do
654− lift $ ensureNoDuplicateProperties ps
655− checkProperties m ps row False
656−check' m (ObjectUpdate obj ps) (Object row) = do
657− lift $ ensureNoDuplicateProperties ps
627+ check val ty1
628+check' (Case val binders) ret = do
629+ t1 <- infer val
630+ checkBinders t1 ret binders
631+check' (IfThenElse cond th el) ty = do
632+ check cond Boolean
633+ check th ty
634+ check el ty
635+check' (ObjectLiteral ps) (Object row) = do
636+ ensureNoDuplicateProperties ps
637+ checkProperties ps row False
638+check' (ObjectUpdate obj ps) (Object row) = do
639+ ensureNoDuplicateProperties ps
658640 us <- zip (map fst ps) <$> replicateM (length ps) fresh
659641 let (propsToCheck, rest) = rowToList row
660642 propsToRemove = map fst ps
661643 remainingProps = filter (\(p, _) -> p `notElem` propsToRemove) propsToCheck
662− check m obj (Object (rowFromList (us ++ remainingProps, rest)))
663− checkProperties m ps row True
664−check' m (Accessor prop val) ty = do
644+ check obj (Object (rowFromList (us ++ remainingProps, rest)))
645+ checkProperties ps row True
646+check' (Accessor prop val) ty = do
665647 rest <- fresh
666− check m val (Object (RCons prop ty rest))
667−check' m (Block ss) ret = do
668− (allCodePathsReturn, _) <- checkBlock m M.empty ret ss
648+ check val (Object (RCons prop ty rest))
649+check' (Block ss) ret = do
650+ (allCodePathsReturn, _) <- checkBlock M.empty ret ss
669651 guardWith "Block is missing a return statement" allCodePathsReturn
670−check' m (Constructor c) ty = do
671− env <- lift getEnv
672− modulePath <- checkModulePath `fmap` lift get
652+check' (Constructor c) ty = do
653+ env <- getEnv
654+ modulePath <- checkModulePath <$> get
673655 case M.lookup (qualify modulePath c) (dataConstructors env) of
674656 Nothing -> throwError $ "Constructor " ++ show c ++ " is undefined"
675657 Just ty1 -> do
676− repl <- lift $ replaceAllTypeSynonyms ty1
658+ repl <- replaceAllTypeSynonyms ty1
677659 repl `subsumes` ty
678−check' m val (SaturatedTypeSynonym name args) = do
660+check' val (SaturatedTypeSynonym name args) = do
679661 ty <- expandTypeSynonym name args
680− check m val ty
681−check' _ val ty = throwError $ prettyPrintValue val ++ " does not have type " ++ prettyPrintType ty
662+ check val ty
663+check' val ty = throwError $ prettyPrintValue val ++ " does not have type " ++ prettyPrintType ty
682664
683−checkProperties :: M.Map Ident Type -> [(String, Value)] -> Row -> Bool -> Subst Check ()
684−checkProperties m ps row lax = let (ts, r') = rowToList row in go ps ts r' where
665+checkProperties :: [(String, Value)] -> Row -> Bool -> Subst ()
666+checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where
685667 go [] [] REmpty = return ()
686668 go [] [] u@(RUnknown _) = u ~~ REmpty
687669 go [] [] (RSkolem _) | lax = return ()
@@ -689,19 +671,19 @@ checkProperties m ps row lax = let (ts, r') = rowToList row in go ps ts r' where
689671 | otherwise = throwError $ prettyPrintValue (ObjectLiteral ps) ++ " does not have property " ++ p
690672 go ((p,_):_) [] REmpty = throwError $ "Property " ++ p ++ " is not present in closed object type " ++ prettyPrintRow row
691673 go ((p,v):ps) [] u@(RUnknown _) = do
692− ty <- infer m v
674+ ty <- infer v
693675 rest <- fresh
694676 u ~~ RCons p ty rest
695677 go ps [] rest
696678 go ((p,v):ps) ts r =
697679 case lookup p ts of
698680 Nothing -> do
699− ty <- infer m v
681+ ty <- infer v
700682 rest <- fresh
701683 r ~~ RCons p ty rest
702684 go ps ts rest
703685 Just ty -> do
704− check m v ty
686+ check v ty
705687 go ps (delete (p, ty) ts) r
706688 go _ _ _ = throwError $ prettyPrintValue (ObjectLiteral ps) ++ " does not have type " ++ prettyPrintType (Object row)
707689
@@ -711,16 +693,16 @@ unfoldApplication = go []
711693 go argss (App f args) = go (args:argss) f
712694 go argss f = (f, argss)
713695
714−checkFunctionApplications :: M.Map Ident Type -> Type -> [[Value]] -> Type -> Subst Check ()
715−checkFunctionApplications _ _ [] _ = error "Nullary function application"
716−checkFunctionApplications m fnTy [args] ret = checkFunctionApplication m fnTy args ret
717−checkFunctionApplications m fnTy (args:argss) ret = do
718− argTys <- mapM (infer m) args
719− f <- inferFunctionApplication m fnTy argTys
720− checkFunctionApplications m f argss ret
696+checkFunctionApplications :: Type -> [[Value]] -> Type -> Subst ()
697+checkFunctionApplications _ [] _ = error "Nullary function application"
698+checkFunctionApplications fnTy [args] ret = checkFunctionApplication fnTy args ret
699+checkFunctionApplications fnTy (args:argss) ret = do
700+ argTys <- mapM (infer) args
701+ f <- inferFunctionApplication fnTy argTys
702+ checkFunctionApplications f argss ret
721703
722−checkFunctionApplication :: M.Map Ident Type -> Type -> [Value] -> Type -> Subst Check ()
723−checkFunctionApplication m fnTy args ret = rethrow errorMessage $ checkFunctionApplication' m fnTy args ret
704+checkFunctionApplication :: Type -> [Value] -> Type -> Subst ()
705+checkFunctionApplication fnTy args ret = rethrow errorMessage $ checkFunctionApplication' fnTy args ret
724706 where
725707 errorMessage msg = "Error applying function of type "
726708 ++ prettyPrintType fnTy
@@ -728,46 +710,46 @@ checkFunctionApplication m fnTy args ret = rethrow errorMessage $ checkFunctionA
728710 ++ ", expecting value of type "
729711 ++ prettyPrintType ret ++ ":\n" ++ msg
730712
731−inferFunctionApplication :: M.Map Ident Type -> Type -> [Type] -> Subst Check Type
732−inferFunctionApplication m (Function argTys retTy) args = do
713+inferFunctionApplication :: Type -> [Type] -> Subst Type
714+inferFunctionApplication (Function argTys retTy) args = do
733715 guardWith "Incorrect number of function arguments" (length args == length argTys)
734716 zipWithM subsumes args argTys
735717 return retTy
736−inferFunctionApplication m (ForAll ident ty) args = do
718+inferFunctionApplication (ForAll ident ty) args = do
737719 replaced <- replaceVarWithUnknown ident ty
738− inferFunctionApplication m replaced args
739−inferFunctionApplication m u@(TUnknown _) args = do
720+ inferFunctionApplication replaced args
721+inferFunctionApplication u@(TUnknown _) args = do
740722 ret <- fresh
741723 args' <- mapM replaceAllVarsWithUnknowns args
742724 u ~~ Function args' ret
743725 return ret
744−inferFunctionApplication m (SaturatedTypeSynonym name tyArgs) args = do
726+inferFunctionApplication (SaturatedTypeSynonym name tyArgs) args = do
745727 ty <- expandTypeSynonym name tyArgs
746− inferFunctionApplication m ty args
747−inferFunctionApplication _ fnTy args = throwError $ "Cannot apply function of type "
728+ inferFunctionApplication ty args
729+inferFunctionApplication fnTy args = throwError $ "Cannot apply function of type "
748730 ++ prettyPrintType fnTy
749731 ++ " to argument(s) of type(s) " ++ intercalate ", " (map prettyPrintType args)
750732
751−checkFunctionApplication' :: M.Map Ident Type -> Type -> [Value] -> Type -> Subst Check ()
752−checkFunctionApplication' m (Function argTys retTy) args ret = do
733+checkFunctionApplication' :: Type -> [Value] -> Type -> Subst ()
734+checkFunctionApplication' (Function argTys retTy) args ret = do
753735 guardWith "Incorrect number of function arguments" (length args == length argTys)
754− zipWithM (check m) args argTys
736+ zipWithM (check) args argTys
755737 retTy `subsumes` ret
756−checkFunctionApplication' m (ForAll ident ty) args ret = do
738+checkFunctionApplication' (ForAll ident ty) args ret = do
757739 replaced <- replaceVarWithUnknown ident ty
758− checkFunctionApplication m replaced args ret
759−checkFunctionApplication' m u@(TUnknown _) args ret = do
760− tyArgs <- mapM (\arg -> infer m arg >>= replaceAllVarsWithUnknowns) args
740+ checkFunctionApplication replaced args ret
741+checkFunctionApplication' u@(TUnknown _) args ret = do
742+ tyArgs <- mapM (\arg -> infer arg >>= replaceAllVarsWithUnknowns) args
761743 u ~~ Function tyArgs ret
762−checkFunctionApplication' m (SaturatedTypeSynonym name tyArgs) args ret = do
744+checkFunctionApplication' (SaturatedTypeSynonym name tyArgs) args ret = do
763745 ty <- expandTypeSynonym name tyArgs
764− checkFunctionApplication' m ty args ret
765−checkFunctionApplication' _ fnTy args ret = throwError $ "Applying a function of type "
746+ checkFunctionApplication' ty args ret
747+checkFunctionApplication' fnTy args ret = throwError $ "Applying a function of type "
766748 ++ prettyPrintType fnTy
767749 ++ " to argument(s) " ++ intercalate ", " (map prettyPrintValue args)
768750 ++ " does not yield a value of type " ++ prettyPrintType ret ++ "."
769751
770−subsumes :: Type -> Type -> Subst Check ()
752+subsumes :: Type -> Type -> Subst ()
771753subsumes (ForAll ident ty1) ty2 = do
772754 replaced <- replaceVarWithUnknown ident ty1
773755 replaced `subsumes` ty2