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