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