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