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