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