@@ -1,748 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.TypeChecker.Types
4−-- Copyright : (c) Phil Freeman 2013
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- |
12−--
13−-----------------------------------------------------------------------------
14−
15−{-# LANGUAGE DeriveDataTypeable, FlexibleContexts #-}
16−
17−module Language.PureScript.TypeChecker.Types (
18− typeOf
19−) where
20−
21−import Data.List
22−import Data.Maybe (fromMaybe)
23−import qualified Data.Data as D
24−import Data.Generics
25− (mkT, something, everywhere, everywhereBut, mkQ, extQ)
26−
27−import Language.PureScript.Values
28−import Language.PureScript.Types
29−import Language.PureScript.Kinds
30−import Language.PureScript.Names
31−import Language.PureScript.TypeChecker.Monad
32−import Language.PureScript.TypeChecker.Kinds
33−import Language.PureScript.TypeChecker.Synonyms
34−import Language.PureScript.Pretty
35−import Language.PureScript.Unknown
36−
37−import Control.Monad.State
38−import Control.Monad.Error
39−
40−import Control.Applicative
41−import Control.Arrow (Arrow(..))
42−
43−import qualified Data.Map as M
44−
45−instance Unifiable Type where
46− unknown = TUnknown
47− isUnknown (TUnknown u) = Just u
48− isUnknown _ = Nothing
49− (~~) = unifyTypes
50− apply s (TUnknown u) = runSubstitution s u
51− apply s (SaturatedTypeSynonym name tys) = SaturatedTypeSynonym name $ map (apply s) tys
52− apply s (ForAll idents ty) = ForAll idents $ apply s ty
53− apply s (Array t) = Array (apply s t)
54− apply s (Object r) = Object (apply s r)
55− apply s (Function args ret) = Function (map (apply s) args) (apply s ret)
56− apply s (TypeApp t1 t2) = TypeApp (apply s t1) (apply s t2)
57− apply _ t = t
58− unknowns (TUnknown (Unknown u)) = [u]
59− unknowns (SaturatedTypeSynonym _ tys) = concatMap unknowns tys
60− unknowns (ForAll _ ty) = unknowns ty
61− unknowns (Array t) = unknowns t
62− unknowns (Object r) = unknowns r
63− unknowns (Function args ret) = concatMap unknowns args ++ unknowns ret
64− unknowns (TypeApp t1 t2) = unknowns t1 ++ unknowns t2
65− unknowns _ = []
66−
67−instance Unifiable Row where
68− unknown = RUnknown
69− isUnknown (RUnknown u) = Just u
70− isUnknown _ = Nothing
71− r1 ~~ r2 =
72− let
73− (s1, r1') = rowToList r1
74− (s2, r2') = rowToList r2
75− int = [ (t1, t2) | (name, t1) <- s1, (name', t2) <- s2, name == name' ]
76− sd1 = [ (name, t1) | (name, t1) <- s1, name `notElem` map fst s2 ]
77− sd2 = [ (name, t2) | (name, t2) <- s2, name `notElem` map fst s1 ]
78− in do
79− forM_ int (uncurry (~~))
80− unifyRows sd1 r1' sd2 r2'
81− where
82− unifyRows :: [(String, Type)] -> Row -> [(String, Type)] -> Row -> Subst ()
83− unifyRows [] (RUnknown u) sd r = replace u (rowFromList (sd, r))
84− unifyRows sd r [] (RUnknown u) = replace u (rowFromList (sd, r))
85− unifyRows ((name, ty):row) r others u@(RUnknown un) = do
86− occursCheck un ty
87− forM row $ \(_, t) -> occursCheck un t
88− u' <- fresh
89− u ~~ RCons name ty u'
90− unifyRows row r others u'
91− unifyRows [] REmpty [] REmpty = return ()
92− unifyRows [] (RowVar v1) [] (RowVar v2) | v1 == v2 = return ()
93− unifyRows [] (RSkolem s1) [] (RSkolem s2) | s1 == s2 = return ()
94− unifyRows sd3 r3 sd4 r4 = throwError $ "Cannot unify " ++ prettyPrintRow (rowFromList (sd3, r3)) ++ " with " ++ prettyPrintRow (rowFromList (sd4, r4)) ++ "."
95− apply s (RUnknown u) = runSubstitution s u
96− apply s (RCons name ty r) = RCons name (apply s ty) (apply s r)
97− apply _ r = r
98− unknowns (RUnknown (Unknown u)) = [u]
99− unknowns (RCons _ ty r) = unknowns ty ++ unknowns r
100− unknowns _ = []
101−
102−unifyTypes :: Type -> Type -> Subst ()
103−unifyTypes t1 t2 = rethrow (\e -> "Error unifying type " ++ prettyPrintType t1 ++ " with type " ++ prettyPrintType t2 ++ ":\n" ++ e) $ do
104− unifyTypes' t1 t2
105− where
106− unifyTypes' (TUnknown u1) (TUnknown u2) | u1 == u2 = return ()
107− unifyTypes' (TUnknown u) t = replace u t
108− unifyTypes' t (TUnknown u) = replace u t
109− unifyTypes' (SaturatedTypeSynonym name1 args1) (SaturatedTypeSynonym name2 args2)
110− | name1 == name2 = zipWithM_ unifyTypes args1 args2
111− unifyTypes' (SaturatedTypeSynonym name args) ty = do
112− ty1 <- expandTypeSynonym name args
113− ty1 `unifyTypes` ty
114− unifyTypes' ty s@(SaturatedTypeSynonym _ _) = s `unifyTypes` ty
115− unifyTypes' (ForAll ident1 ty1) (ForAll ident2 ty2) = do
116− sk <- skolemize ident1 ty1
117− replaced <- replaceVarWithUnknown ident2 ty2
118− sk `unifyTypes` replaced
119− unifyTypes' (ForAll ident ty1) ty2 = do
120− sk <- skolemize ident ty1
121− sk `unifyTypes` ty2
122− unifyTypes' ty f@(ForAll _ _) = f `unifyTypes` ty
123− unifyTypes' Number Number = return ()
124− unifyTypes' String String = return ()
125− unifyTypes' Boolean Boolean = return ()
126− unifyTypes' (Array s) (Array t) = s `unifyTypes` t
127− unifyTypes' (Object row1) (Object row2) = row1 ~~ row2
128− unifyTypes' (Function args1 ret1) (Function args2 ret2) = do
129− guardWith "Function applied to incorrect number of args" $ length args1 == length args2
130− zipWithM_ unifyTypes args1 args2
131− ret1 `unifyTypes` ret2
132− unifyTypes' (TypeVar v1) (TypeVar v2) | v1 == v2 = return ()
133− unifyTypes' (TypeConstructor c1) (TypeConstructor c2) = do
134− modulePath <- checkModulePath `fmap` get
135− guardWith ("Cannot unify " ++ show c1 ++ " with " ++ show c2 ++ ".") (qualify modulePath c1 == qualify modulePath c2)
136− unifyTypes' (TypeApp t3 t4) (TypeApp t5 t6) = do
137− t3 `unifyTypes` t5
138− t4 `unifyTypes` t6
139− unifyTypes' (Skolem s1) (Skolem s2) | s1 == s2 = return ()
140− unifyTypes' t3 t4 = throwError $ "Cannot unify " ++ prettyPrintType t3 ++ " with " ++ prettyPrintType t4 ++ "."
141−
142−isFunction :: Value -> Bool
143−isFunction (Abs _ _) = True
144−isFunction (TypedValue untyped _) = isFunction untyped
145−isFunction _ = False
146−
147−typeOf :: Maybe Ident -> Value -> Check Type
148−typeOf name val = do
149− (ty, sub, checks) <- runSubst $ case name of
150− Just ident | isFunction val ->
151− case val of
152− TypedValue value ty -> do
153− kind <- liftCheck $ kindOf ty
154− guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
155− ty' <- replaceAllTypeSynonyms ty
156− modulePath <- checkModulePath <$> get
157− bindNames (M.singleton (modulePath, ident) (ty, LocalVariable)) $ check value ty'
158− return ty'
159− _ -> do
160− me <- fresh
161− modulePath <- checkModulePath <$> get
162− ty <- bindNames (M.singleton (modulePath, ident) (me, LocalVariable)) $ infer val
163− ty ~~ me
164− return ty
165− _ -> infer val
166− escapeCheck checks ty sub
167− skolemEscapeCheck ty
168− return $ varIfUnknown $ desaturateAllTypeSynonyms $ setifyAll ty
169−
170−escapeCheck :: [AnyUnifiable] -> Type -> Substitution -> Check ()
171−escapeCheck checks ty sub =
172− let
173− visibleUnknowns = nub $ unknowns ty
174− in
175− forM_ checks $ \c -> case c of
176− AnyUnifiable t -> do
177− let unsolvedUnknowns = nub . unknowns $ apply sub t
178− guardWith "Escape check fails" $ null $ unsolvedUnknowns \\ visibleUnknowns
179−
180−skolemEscapeCheck :: Type -> Check ()
181−skolemEscapeCheck ty =
182− case something (extQ (mkQ Nothing findSkolems) findRSkolems) ty of
183− Nothing -> return ()
184− Just _ -> throwError "Skolem variables cannot escape. Consider adding a type signature."
185− where
186− findSkolems (Skolem _) = return ()
187− findSkolems _ = mzero
188− findRSkolems (RSkolem _) = return ()
189− findRSkolems _ = mzero
190−
191−setify :: Row -> Row
192−setify = rowFromList . first (M.toList . M.fromList) . rowToList
193−
194−setifyAll :: (D.Data d) => d -> d
195−setifyAll = everywhere (mkT setify)
196−
197−varIfUnknown :: Type -> Type
198−varIfUnknown ty =
199− let unks = nub $ unknowns ty
200− toName = (:) 't' . show
201− ty' = everywhere (mkT rowToVar) . everywhere (mkT typeToVar) $ ty
202− typeToVar :: Type -> Type
203− typeToVar (TUnknown (Unknown u)) = TypeVar (toName u)
204− typeToVar t = t
205− rowToVar :: Row -> Row
206− rowToVar (RUnknown (Unknown u)) = RowVar (toName u)
207− rowToVar t = t
208− in mkForAll (sort . map toName $ unks) ty'
209−
210−replaceAllTypeVars :: (D.Data d) => [(String, Type)] -> d -> d
211−replaceAllTypeVars = foldl' (\f (name, ty) -> replaceTypeVars name ty . f) id
212−
213−replaceTypeVars :: (D.Data d) => String -> Type -> d -> d
214−replaceTypeVars name t = everywhereBut (mkQ False isShadowed) (mkT replaceTypeVar)
215− where
216− replaceTypeVar (TypeVar v) | v == name = t
217− replaceTypeVar other = other
218− isShadowed (ForAll v _) | v == name = True
219− isShadowed _ = False
220−
221−replaceRowVars :: (D.Data d) => String -> Row -> d -> d
222−replaceRowVars name r = everywhere (mkT replaceRowVar)
223− where
224− replaceRowVar (RowVar v) | v == name = r
225− replaceRowVar other = other
226−
227−replaceAllVarsWithUnknowns :: Type -> Subst Type
228−replaceAllVarsWithUnknowns (ForAll ident ty) = replaceVarWithUnknown ident ty >>= replaceAllVarsWithUnknowns
229−replaceAllVarsWithUnknowns ty = return ty
230−
231−replaceVarWithUnknown :: String -> Type -> Subst Type
232−replaceVarWithUnknown ident ty = do
233− tu <- fresh
234− ru <- fresh
235− return $ replaceRowVars ident ru . replaceTypeVars ident tu $ ty
236−
237−replaceAllTypeSynonyms :: (Functor m, MonadState CheckState m, MonadError String m) => (D.Data d) => d -> m d
238−replaceAllTypeSynonyms d = do
239− env <- getEnv
240− let syns = map (\((path, name), (args, _)) -> (Qualified path name, length args)) . M.toList $ typeSynonyms env
241− either throwError return $ saturateAllTypeSynonyms syns d
242−
243−desaturateAllTypeSynonyms :: (D.Data d) => d -> d
244−desaturateAllTypeSynonyms = everywhere (mkT replaceSaturatedTypeSynonym)
245− where
246− replaceSaturatedTypeSynonym (SaturatedTypeSynonym name args) = foldl TypeApp (TypeConstructor name) args
247− replaceSaturatedTypeSynonym t = t
248−
249−expandTypeSynonym :: Qualified ProperName -> [Type] -> Subst Type
250−expandTypeSynonym name args = do
251− env <- getEnv
252− modulePath <- checkModulePath `fmap` get
253− case M.lookup (qualify modulePath name) (typeSynonyms env) of
254− Just (synArgs, body) -> return $ replaceAllTypeVars (zip synArgs args) body
255− Nothing -> error "Type synonym was not defined"
256−
257−ensureNoDuplicateProperties :: (MonadError String m) => [(String, Value)] -> m ()
258−ensureNoDuplicateProperties ps = guardWith "Duplicate property names" $ length (nub . map fst $ ps) == length ps
259−
260−infer :: Value -> Subst Type
261−infer val = rethrow (\e -> "Error inferring type of term " ++ prettyPrintValue val ++ ":\n" ++ e) $ do
262− ty <- infer' val
263− escapeCheckLater ty
264− return ty
265−
266−infer' :: Value -> Subst Type
267−infer' (NumericLiteral _) = return Number
268−infer' (StringLiteral _) = return String
269−infer' (BooleanLiteral _) = return Boolean
270−infer' (ArrayLiteral vals) = do
271− ts <- mapM (infer) vals
272− els <- fresh
273− forM_ ts $ \t -> els ~~ Array t
274− return els
275−infer' (Unary op val) = do
276− t <- infer val
277− inferUnary op t
278−infer' (Binary op left right) = do
279− t1 <- infer left
280− t2 <- infer right
281− inferBinary op t1 t2
282−infer' (ObjectLiteral ps) = do
283− ensureNoDuplicateProperties ps
284− ts <- mapM (infer . snd) ps
285− let fields = zipWith (\(name, _) t -> (name, t)) ps ts
286− return $ Object $ rowFromList (fields, REmpty)
287−infer' (ObjectUpdate o ps) = do
288− ensureNoDuplicateProperties ps
289− row <- fresh
290− newTys <- zipWith (\(name, _) t -> (name, t)) ps <$> mapM (infer . snd) ps
291− oldTys <- zip (map fst ps) <$> replicateM (length ps) fresh
292− check o $ Object $ rowFromList (oldTys, row)
293− return $ Object $ rowFromList (newTys, row)
294−infer' (Indexer index val) = do
295− el <- fresh
296− check index Number
297− check val (Array el)
298− return el
299−infer' (Accessor prop val) = do
300− obj <- infer val
301− propTy <- inferProperty obj prop
302− case propTy of
303− Nothing -> do
304− field <- fresh
305− rest <- fresh
306− obj `subsumes` Object (RCons prop field rest)
307− return field
308− Just ty -> return ty
309−infer' (Abs args ret) = do
310− ts <- replicateM (length args) fresh
311− bindLocalVariables (zip args ts) $ do
312− body <- infer' ret
313− return $ Function ts body
314−infer' app@(App _ _) = do
315− let (f, argss) = unfoldApplication app
316− ft <- infer f
317− ret <- fresh
318− checkFunctionApplications ft argss ret
319− return ret
320−infer' (Var var) = do
321− ty <- lookupVariable var
322− replaceAllTypeSynonyms ty
323−infer' (Block ss) = do
324− ret <- fresh
325− (allCodePathsReturn, _) <- checkBlock M.empty ret ss
326− guardWith "Block is missing a return statement" allCodePathsReturn
327− return ret
328−infer' (Constructor c) = do
329− env <- getEnv
330− modulePath <- checkModulePath `fmap` get
331− case M.lookup (qualify modulePath c) (dataConstructors env) of
332− Nothing -> throwError $ "Constructor " ++ show c ++ " is undefined"
333− Just ty -> replaceAllTypeSynonyms ty
334−infer' (Case val binders) = do
335− t1 <- infer val
336− ret <- fresh
337− checkBinders t1 ret binders
338− return ret
339−infer' (IfThenElse cond th el) = do
340− check cond Boolean
341− t2 <- infer th
342− t3 <- infer el
343− t2 ~~ t3
344− return t2
345−infer' (TypedValue val ty) = do
346− kind <- liftCheck $ kindOf ty
347− guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
348− ty' <- replaceAllTypeSynonyms ty
349− check val ty'
350− return ty'
351−infer' _ = error "Invalid argument to infer"
352−
353−inferProperty :: Type -> String -> Subst (Maybe Type)
354−inferProperty (Object row) prop = do
355− let (props, _) = rowToList row
356− return $ lookup prop props
357−inferProperty (SaturatedTypeSynonym name args) prop = do
358− replaced <- expandTypeSynonym name args
359− inferProperty replaced prop
360−inferProperty (ForAll ident ty) prop = do
361− replaced <- replaceVarWithUnknown ident ty
362− inferProperty replaced prop
363−inferProperty _ _ = return Nothing
364−
365−inferUnary :: UnaryOperator -> Type -> Subst Type
366−inferUnary op val =
367− case fromMaybe (error "Invalid operator") $ lookup op unaryOps of
368− (valTy, resTy) -> do
369− val ~~ valTy
370− return resTy
371−
372−checkUnary :: UnaryOperator -> Value -> Type -> Subst ()
373−checkUnary op val res =
374− case fromMaybe (error "Invalid operator") $ lookup op unaryOps of
375− (valTy, resTy) -> do
376− res ~~ resTy
377− check val valTy
378−
379−unaryOps :: [(UnaryOperator, (Type, Type))]
380−unaryOps = [ (Negate, (Number, Number))
381− , (Not, (Boolean, Boolean))
382− , (BitwiseNot, (Number, Number))
383− ]
384−
385−inferBinary :: BinaryOperator -> Type -> Type -> Subst Type
386−inferBinary op left right | isEqualityTest op = do
387− left ~~ right
388− return Boolean
389−inferBinary op left right =
390− case fromMaybe (error "Invalid operator") $ lookup op binaryOps of
391− (valTy, resTy) -> do
392− left ~~ valTy
393− right ~~ valTy
394− return resTy
395−
396−checkBinary :: BinaryOperator -> Value -> Value -> Type -> Subst ()
397−checkBinary op left right res | isEqualityTest op = do
398− res ~~ Boolean
399− t1 <- infer left
400− t2 <- infer right
401− t1 ~~ t2
402−checkBinary op left right res =
403− case fromMaybe (error "Invalid operator") $ lookup op binaryOps of
404− (valTy, resTy) -> do
405− res ~~ resTy
406− check left valTy
407− check right valTy
408−
409−isEqualityTest :: BinaryOperator -> Bool
410−isEqualityTest EqualTo = True
411−isEqualityTest NotEqualTo = True
412−isEqualityTest _ = False
413−
414−binaryOps :: [(BinaryOperator, (Type, Type))]
415−binaryOps = [ (Add, (Number, Number))
416− , (Subtract, (Number, Number))
417− , (Multiply, (Number, Number))
418− , (Divide, (Number, Number))
419− , (Modulus, (Number, Number))
420− , (BitwiseAnd, (Number, Number))
421− , (BitwiseOr, (Number, Number))
422− , (BitwiseXor, (Number, Number))
423− , (ShiftRight, (Number, Number))
424− , (ZeroFillShiftRight, (Number, Number))
425− , (And, (Boolean, Boolean))
426− , (Or, (Boolean, Boolean))
427− , (Concat, (String, String))
428− , (Modulus, (Number, Number))
429− , (LessThan, (Number, Boolean))
430− , (LessThanOrEqualTo, (Number, Boolean))
431− , (GreaterThan, (Number, Boolean))
432− , (GreaterThanOrEqualTo, (Number, Boolean))
433− ]
434−
435−inferBinder :: Type -> Binder -> Subst (M.Map Ident Type)
436−inferBinder _ NullBinder = return M.empty
437−inferBinder val (StringBinder _) = val ~~ String >> return M.empty
438−inferBinder val (NumberBinder _) = val ~~ Number >> return M.empty
439−inferBinder val (BooleanBinder _) = val ~~ Boolean >> return M.empty
440−inferBinder val (VarBinder name) = return $ M.singleton name val
441−inferBinder val (NullaryBinder ctor) = do
442− env <- getEnv
443− modulePath <- checkModulePath <$> get
444− case M.lookup (qualify modulePath ctor) (dataConstructors env) of
445− Just ty -> do
446− ty `subsumes` val
447− return M.empty
448− _ -> throwError $ "Constructor " ++ show ctor ++ " is not defined"
449−inferBinder val (UnaryBinder ctor binder) = do
450− env <- getEnv
451− modulePath <- checkModulePath <$> get
452− case M.lookup (qualify modulePath ctor) (dataConstructors env) of
453− Just ty -> do
454− Function [obj] ret <- replaceAllVarsWithUnknowns ty
455− val `subsumes` ret
456− inferBinder obj binder
457− _ -> throwError $ "Constructor " ++ show ctor ++ " is not defined"
458−inferBinder val (ObjectBinder props) = do
459− row <- fresh
460− rest <- fresh
461− m1 <- inferRowProperties row rest props
462− val ~~ Object row
463− return m1
464− where
465− inferRowProperties :: Row -> Row -> [(String, Binder)] -> Subst (M.Map Ident Type)
466− inferRowProperties nrow row [] = nrow ~~ row >> return M.empty
467− inferRowProperties nrow row ((name, binder):binders) = do
468− propTy <- fresh
469− m1 <- inferBinder propTy binder
470− m2 <- inferRowProperties nrow (RCons name propTy row) binders
471− return $ m1 `M.union` m2
472−inferBinder val (ArrayBinder binders rest) = do
473− el <- fresh
474− m1 <- M.unions <$> mapM (inferBinder el) binders
475− val ~~ Array el
476− case rest of
477− Nothing -> return m1
478− Just binder -> do
479− m2 <- inferBinder val binder
480− return $ m1 `M.union` m2
481−inferBinder val (NamedBinder name binder) = do
482− m <- inferBinder val binder
483− return $ M.insert name val m
484−inferBinder _ _ = error "Invalid argument to inferBinder"
485−
486−inferGuardedBinder :: Type -> Binder -> Subst (M.Map Ident Type)
487−inferGuardedBinder val (GuardedBinder cond binder) = do
488− m1 <- inferBinder val binder
489− bindLocalVariables (M.toList m1) $ check cond Boolean
490− return m1
491−inferGuardedBinder val b = inferBinder val b
492−
493−checkBinders :: Type -> Type -> [(Binder, Value)] -> Subst ()
494−checkBinders _ _ [] = return ()
495−checkBinders nval ret ((binder, val):bs) = do
496− m1 <- inferGuardedBinder nval binder
497− bindLocalVariables (M.toList m1) $ check val ret
498− checkBinders nval ret bs
499−
500−assignVariable :: Ident -> Subst ()
501−assignVariable name = do
502− env <- checkEnv <$> get
503− modulePath <- checkModulePath <$> get
504− case M.lookup (modulePath, name) (names env) of
505− Just (_, LocalVariable) -> throwError $ "Variable with name " ++ show name ++ " already exists."
506− _ -> return ()
507−
508−checkStatement :: M.Map Ident Type -> Type -> Statement -> Subst (Bool, M.Map Ident Type)
509−checkStatement mass _ (VariableIntroduction name val) = do
510− assignVariable name
511− t <- infer val
512− return (False, M.insert name t mass)
513−checkStatement mass _ (Assignment ident val) = do
514− t <- infer val
515− case M.lookup ident mass of
516− Nothing -> throwError $ "No local variable with name " ++ show ident
517− Just ty -> do t ~~ ty
518− return (False, mass)
519−checkStatement mass ret (While val inner) = do
520− check val Boolean
521− (allCodePathsReturn, _) <- checkBlock mass ret inner
522− return (allCodePathsReturn, mass)
523−checkStatement mass ret (If ifst) = do
524− allCodePathsReturn <- checkIfStatement mass ret ifst
525− return (allCodePathsReturn, mass)
526−checkStatement mass ret (For ident start end inner) = do
527− assignVariable ident
528− check start Number
529− check end Number
530− (allCodePathsReturn, _) <- bindLocalVariables [(ident, Number)] $ checkBlock mass ret inner
531− return (allCodePathsReturn, mass)
532−checkStatement mass ret (ForEach ident vals inner) = do
533− assignVariable ident
534− val <- fresh
535− check vals (Array val)
536− (allCodePathsReturn, _) <- bindLocalVariables [(ident, val)] $ checkBlock mass ret inner
537− guardWith "Cannot return from within a foreach block" $ not allCodePathsReturn
538− return (False, mass)
539−checkStatement mass ret (Return val) = do
540− check val ret
541− return (True, mass)
542−
543−checkIfStatement :: M.Map Ident Type -> Type -> IfStatement -> Subst Bool
544−checkIfStatement mass ret (IfStatement val thens Nothing) = do
545− check val Boolean
546− _ <- checkBlock mass ret thens
547− return False
548−checkIfStatement mass ret (IfStatement val thens (Just elses)) = do
549− check val Boolean
550− (allCodePathsReturn1, _) <- checkBlock mass ret thens
551− allCodePathsReturn2 <- checkElseStatement mass ret elses
552− return $ allCodePathsReturn1 && allCodePathsReturn2
553−
554−checkElseStatement :: M.Map Ident Type -> Type -> ElseStatement -> Subst Bool
555−checkElseStatement mass ret (Else elses) = fst <$> checkBlock mass ret elses
556−checkElseStatement mass ret (ElseIf ifst) = checkIfStatement mass ret ifst
557−
558−checkBlock :: M.Map Ident Type -> Type -> [Statement] -> Subst (Bool, M.Map Ident Type)
559−checkBlock mass _ [] = return (False, mass)
560−checkBlock mass ret (s:ss) = do
561− (b1, mass1) <- checkStatement mass ret s
562− bindLocalVariables (M.toList mass1) $ case (b1, ss) of
563− (True, []) -> return (True, mass1)
564− (True, _) -> throwError "Unreachable code"
565− (False, ss') -> checkBlock mass1 ret ss'
566−
567−skolemize :: String -> Type -> Subst Type
568−skolemize ident ty = do
569− tsk <- Skolem <$> fresh'
570− rsk <- RSkolem <$> fresh'
571− return $ replaceRowVars ident rsk $ replaceTypeVars ident tsk ty
572−
573−check :: Value -> Type -> Subst ()
574−check val ty = rethrow errorMessage $ check' val ty
575− where
576− errorMessage msg =
577− "Error checking type of term " ++
578− prettyPrintValue val ++
579− " against type " ++
580− prettyPrintType ty ++
581− ":\n" ++
582− msg
583−
584−check' :: Value -> Type -> Subst ()
585−check' val (ForAll idents ty) = do
586− sk <- skolemize idents ty
587− check val sk
588−check' val u@(TUnknown _) = do
589− ty <- infer val
590− -- Don't unify an unknown with an inferred polytype
591− ty' <- replaceAllVarsWithUnknowns ty
592− ty' ~~ u
593−check' (NumericLiteral _) Number = return ()
594−check' (StringLiteral _) String = return ()
595−check' (BooleanLiteral _) Boolean = return ()
596−check' (Unary op val) ty = checkUnary op val ty
597−check' (Binary op left right) ty = checkBinary op left right ty
598−check' (ArrayLiteral vals) (Array ty) = forM_ vals (\val -> check val ty)
599−check' (Indexer index vals) ty = check index Number >> check vals (Array ty)
600−check' (Abs args ret) (Function argTys retTy) = do
601− guardWith "Incorrect number of function arguments" (length args == length argTys)
602− bindLocalVariables (zip args argTys) $ check ret retTy
603−check' app@(App _ _) ret = do
604− let (f, argss) = unfoldApplication app
605− ft <- infer f
606− checkFunctionApplications ft argss ret
607−check' (Var var) ty = do
608− ty1 <- lookupVariable var
609− repl <- replaceAllTypeSynonyms ty1
610− repl `subsumes` ty
611−check' (TypedValue val ty1) ty2 = do
612− kind <- liftCheck $ kindOf ty1
613− guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
614− ty1 `subsumes` ty2
615− check val ty1
616−check' (Case val binders) ret = do
617− t1 <- infer val
618− checkBinders t1 ret binders
619−check' (IfThenElse cond th el) ty = do
620− check cond Boolean
621− check th ty
622− check el ty
623−check' (ObjectLiteral ps) (Object row) = do
624− ensureNoDuplicateProperties ps
625− checkProperties ps row False
626−check' (ObjectUpdate obj ps) (Object row) = do
627− ensureNoDuplicateProperties ps
628− us <- zip (map fst ps) <$> replicateM (length ps) fresh
629− let (propsToCheck, rest) = rowToList row
630− propsToRemove = map fst ps
631− remainingProps = filter (\(p, _) -> p `notElem` propsToRemove) propsToCheck
632− check obj (Object (rowFromList (us ++ remainingProps, rest)))
633− checkProperties ps row True
634−check' (Accessor prop val) ty = do
635− rest <- fresh
636− check val (Object (RCons prop ty rest))
637−check' (Block ss) ret = do
638− (allCodePathsReturn, _) <- checkBlock M.empty ret ss
639− guardWith "Block is missing a return statement" allCodePathsReturn
640−check' (Constructor c) ty = do
641− env <- getEnv
642− modulePath <- checkModulePath <$> get
643− case M.lookup (qualify modulePath c) (dataConstructors env) of
644− Nothing -> throwError $ "Constructor " ++ show c ++ " is undefined"
645− Just ty1 -> do
646− repl <- replaceAllTypeSynonyms ty1
647− repl `subsumes` ty
648−check' val (SaturatedTypeSynonym name args) = do
649− ty <- expandTypeSynonym name args
650− check val ty
651−check' val ty = throwError $ prettyPrintValue val ++ " does not have type " ++ prettyPrintType ty
652−
653−checkProperties :: [(String, Value)] -> Row -> Bool -> Subst ()
654−checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where
655− go [] [] REmpty = return ()
656− go [] [] u@(RUnknown _) = u ~~ REmpty
657− go [] [] (RSkolem _) | lax = return ()
658− go [] ((p, _): _) _ | lax = return ()
659− | otherwise = throwError $ prettyPrintValue (ObjectLiteral ps) ++ " does not have property " ++ p
660− go ((p,_):_) [] REmpty = throwError $ "Property " ++ p ++ " is not present in closed object type " ++ prettyPrintRow row
661− go ((p,v):ps') [] u@(RUnknown _) = do
662− ty <- infer v
663− rest <- fresh
664− u ~~ RCons p ty rest
665− go ps' [] rest
666− go ((p,v):ps') ts r =
667− case lookup p ts of
668− Nothing -> do
669− ty <- infer v
670− rest <- fresh
671− r ~~ RCons p ty rest
672− go ps' ts rest
673− Just ty -> do
674− check v ty
675− go ps' (delete (p, ty) ts) r
676− go _ _ _ = throwError $ prettyPrintValue (ObjectLiteral ps) ++ " does not have type " ++ prettyPrintType (Object row)
677−
678−unfoldApplication :: Value -> (Value, [[Value]])
679−unfoldApplication = go []
680− where
681− go argss (App f args) = go (args:argss) f
682− go argss f = (f, argss)
683−
684−checkFunctionApplications :: Type -> [[Value]] -> Type -> Subst ()
685−checkFunctionApplications _ [] _ = error "Nullary function application"
686−checkFunctionApplications fnTy [args] ret = checkFunctionApplication fnTy args ret
687−checkFunctionApplications fnTy (args:argss) ret = do
688− argTys <- mapM (infer) args
689− f <- inferFunctionApplication fnTy argTys
690− checkFunctionApplications f argss ret
691−
692−checkFunctionApplication :: Type -> [Value] -> Type -> Subst ()
693−checkFunctionApplication fnTy args ret = rethrow errorMessage $ checkFunctionApplication' fnTy args ret
694− where
695− errorMessage msg = "Error applying function of type "
696− ++ prettyPrintType fnTy
697− ++ " to arguments " ++ intercalate ", " (map prettyPrintValue args)
698− ++ ", expecting value of type "
699− ++ prettyPrintType ret ++ ":\n" ++ msg
700−
701−inferFunctionApplication :: Type -> [Type] -> Subst Type
702−inferFunctionApplication (Function argTys retTy) args = do
703− guardWith "Incorrect number of function arguments" (length args == length argTys)
704− zipWithM subsumes args argTys
705− return retTy
706−inferFunctionApplication (ForAll ident ty) args = do
707− replaced <- replaceVarWithUnknown ident ty
708− inferFunctionApplication replaced args
709−inferFunctionApplication u@(TUnknown _) args = do
710− ret <- fresh
711− args' <- mapM replaceAllVarsWithUnknowns args
712− u ~~ Function args' ret
713− return ret
714−inferFunctionApplication (SaturatedTypeSynonym name tyArgs) args = do
715− ty <- expandTypeSynonym name tyArgs
716− inferFunctionApplication ty args
717−inferFunctionApplication fnTy args = throwError $ "Cannot apply function of type "
718− ++ prettyPrintType fnTy
719− ++ " to argument(s) of type(s) " ++ intercalate ", " (map prettyPrintType args)
720−
721−checkFunctionApplication' :: Type -> [Value] -> Type -> Subst ()
722−checkFunctionApplication' (Function argTys retTy) args ret = do
723− guardWith "Incorrect number of function arguments" (length args == length argTys)
724− zipWithM (check) args argTys
725− retTy `subsumes` ret
726−checkFunctionApplication' (ForAll ident ty) args ret = do
727− replaced <- replaceVarWithUnknown ident ty
728− checkFunctionApplication replaced args ret
729−checkFunctionApplication' u@(TUnknown _) args ret = do
730− tyArgs <- mapM (\arg -> infer arg >>= replaceAllVarsWithUnknowns) args
731− u ~~ Function tyArgs ret
732−checkFunctionApplication' (SaturatedTypeSynonym name tyArgs) args ret = do
733− ty <- expandTypeSynonym name tyArgs
734− checkFunctionApplication' ty args ret
735−checkFunctionApplication' fnTy args ret = throwError $ "Applying a function of type "
736− ++ prettyPrintType fnTy
737− ++ " to argument(s) " ++ intercalate ", " (map prettyPrintValue args)
738− ++ " does not yield a value of type " ++ prettyPrintType ret ++ "."
739−
740−subsumes :: Type -> Type -> Subst ()
741−subsumes (ForAll ident ty1) ty2 = do
742− replaced <- replaceVarWithUnknown ident ty1
743− replaced `subsumes` ty2
744−subsumes (Function args1 ret1) (Function args2 ret2) = do
745− zipWithM subsumes args2 args1
746− ret1 `subsumes` ret2
747−subsumes ty1 ty2 = ty1 ~~ ty2
748−