@@ -1,767 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.TypeChecker.Types
4−-- Copyright : (c) Phil Freeman 2013
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- |
12−--
13−-----------------------------------------------------------------------------
14−
15−{-# LANGUAGE DeriveDataTypeable, FlexibleContexts #-}
16−
17−module Language.PureScript.TypeChecker.Types (
18− typesOf
19−) where
20−
21−import Data.List
22−import Data.Maybe (fromMaybe)
23−import Data.Either (lefts, rights)
24−import qualified Data.Data as D
25−import Data.Generics
26− (mkT, something, everywhere, everywhereBut, mkQ, extQ)
27−
28−import Language.PureScript.Values
29−import Language.PureScript.Types
30−import Language.PureScript.Kinds
31−import Language.PureScript.Names
32−import Language.PureScript.TypeChecker.Monad
33−import Language.PureScript.TypeChecker.Kinds
34−import Language.PureScript.TypeChecker.Synonyms
35−import Language.PureScript.Pretty
36−import Language.PureScript.Unknown
37−
38−import Control.Monad.State
39−import Control.Monad.Error
40−import Control.Monad.Reader
41−
42−import Control.Applicative
43−import Control.Arrow (Arrow(..))
44−
45−import qualified Data.Map as M
46−
47−instance Unifiable Type where
48− unknown = TUnknown
49− isUnknown (TUnknown u) = Just u
50− isUnknown _ = Nothing
51− (~~) = unifyTypes
52− apply s (TUnknown u) = runSubstitution s u
53− apply s (SaturatedTypeSynonym name tys) = SaturatedTypeSynonym name $ map (apply s) tys
54− apply s (ForAll idents ty) = ForAll idents $ apply s ty
55− apply s (Array t) = Array (apply s t)
56− apply s (Object r) = Object (apply s r)
57− apply s (Function args ret) = Function (map (apply s) args) (apply s ret)
58− apply s (TypeApp t1 t2) = TypeApp (apply s t1) (apply s t2)
59− apply _ t = t
60− unknowns (TUnknown (Unknown u)) = [u]
61− unknowns (SaturatedTypeSynonym _ tys) = concatMap unknowns tys
62− unknowns (ForAll _ ty) = unknowns ty
63− unknowns (Array t) = unknowns t
64− unknowns (Object r) = unknowns r
65− unknowns (Function args ret) = concatMap unknowns args ++ unknowns ret
66− unknowns (TypeApp t1 t2) = unknowns t1 ++ unknowns t2
67− unknowns _ = []
68−
69−instance Unifiable Row where
70− unknown = RUnknown
71− isUnknown (RUnknown u) = Just u
72− isUnknown _ = Nothing
73− r1 ~~ r2 =
74− let
75− (s1, r1') = rowToList r1
76− (s2, r2') = rowToList r2
77− int = [ (t1, t2) | (name, t1) <- s1, (name', t2) <- s2, name == name' ]
78− sd1 = [ (name, t1) | (name, t1) <- s1, name `notElem` map fst s2 ]
79− sd2 = [ (name, t2) | (name, t2) <- s2, name `notElem` map fst s1 ]
80− in do
81− forM_ int (uncurry (~~))
82− unifyRows sd1 r1' sd2 r2'
83− where
84− unifyRows :: [(String, Type)] -> Row -> [(String, Type)] -> Row -> Subst ()
85− unifyRows [] (RUnknown u) sd r = replace u (rowFromList (sd, r))
86− unifyRows sd r [] (RUnknown u) = replace u (rowFromList (sd, r))
87− unifyRows ((name, ty):row) r others u@(RUnknown un) = do
88− occursCheck un ty
89− forM row $ \(_, t) -> occursCheck un t
90− u' <- fresh
91− u ~~ RCons name ty u'
92− unifyRows row r others u'
93− unifyRows [] REmpty [] REmpty = return ()
94− unifyRows [] (RowVar v1) [] (RowVar v2) | v1 == v2 = return ()
95− unifyRows [] (RSkolem s1) [] (RSkolem s2) | s1 == s2 = return ()
96− unifyRows sd3 r3 sd4 r4 = throwError $ "Cannot unify " ++ prettyPrintRow (rowFromList (sd3, r3)) ++ " with " ++ prettyPrintRow (rowFromList (sd4, r4)) ++ "."
97− apply s (RUnknown u) = runSubstitution s u
98− apply s (RCons name ty r) = RCons name (apply s ty) (apply s r)
99− apply _ r = r
100− unknowns (RUnknown (Unknown u)) = [u]
101− unknowns (RCons _ ty r) = unknowns ty ++ unknowns r
102− unknowns _ = []
103−
104−unifyTypes :: Type -> Type -> Subst ()
105−unifyTypes t1 t2 = rethrow (\e -> "Error unifying type " ++ prettyPrintType t1 ++ " with type " ++ prettyPrintType t2 ++ ":\n" ++ e) $ do
106− unifyTypes' t1 t2
107− where
108− unifyTypes' (TUnknown u1) (TUnknown u2) | u1 == u2 = return ()
109− unifyTypes' (TUnknown u) t = replace u t
110− unifyTypes' t (TUnknown u) = replace u t
111− unifyTypes' (SaturatedTypeSynonym name1 args1) (SaturatedTypeSynonym name2 args2)
112− | name1 == name2 = zipWithM_ unifyTypes args1 args2
113− unifyTypes' (SaturatedTypeSynonym name args) ty = do
114− ty1 <- expandTypeSynonym name args
115− ty1 `unifyTypes` ty
116− unifyTypes' ty s@(SaturatedTypeSynonym _ _) = s `unifyTypes` ty
117− unifyTypes' (ForAll ident1 ty1) (ForAll ident2 ty2) = do
118− sk <- skolemize ident1 ty1
119− replaced <- replaceVarWithUnknown ident2 ty2
120− sk `unifyTypes` replaced
121− unifyTypes' (ForAll ident ty1) ty2 = do
122− sk <- skolemize ident ty1
123− sk `unifyTypes` ty2
124− unifyTypes' ty f@(ForAll _ _) = f `unifyTypes` ty
125− unifyTypes' Number Number = return ()
126− unifyTypes' String String = return ()
127− unifyTypes' Boolean Boolean = return ()
128− unifyTypes' (Array s) (Array t) = s `unifyTypes` t
129− unifyTypes' (Object row1) (Object row2) = row1 ~~ row2
130− unifyTypes' (Function args1 ret1) (Function args2 ret2) = do
131− guardWith "Function applied to incorrect number of args" $ length args1 == length args2
132− zipWithM_ unifyTypes args1 args2
133− ret1 `unifyTypes` ret2
134− unifyTypes' (TypeVar v1) (TypeVar v2) | v1 == v2 = return ()
135− unifyTypes' (TypeConstructor c1) (TypeConstructor c2) = do
136− moduleName <- substCurrentModule `fmap` ask
137− guardWith ("Cannot unify " ++ show c1 ++ " with " ++ show c2 ++ ".") (qualify moduleName c1 == qualify moduleName c2)
138− unifyTypes' (TypeApp t3 t4) (TypeApp t5 t6) = do
139− t3 `unifyTypes` t5
140− t4 `unifyTypes` t6
141− unifyTypes' (Skolem s1) (Skolem s2) | s1 == s2 = return ()
142− unifyTypes' t3 t4 = throwError $ "Cannot unify " ++ prettyPrintType t3 ++ " with " ++ prettyPrintType t4 ++ "."
143−
144−typesOf :: ModuleName -> [(Ident, Value)] -> Check [Type]
145−typesOf moduleName vals = do
146− (tys, sub, checks) <- runSubst (SubstContext moduleName) $ do
147− let es = map isTyped vals
148− typed = lefts es
149− untyped = rights es
150− typedDict = map (\(ident, ty, _) -> (ident, ty)) typed
151− untypedNames <- replicateM (length untyped) fresh
152− let untypedDict = zip (map fst untyped) untypedNames
153− dict = M.fromList (map (\(ident, ty) -> ((moduleName, ident), (ty, LocalVariable))) $ typedDict ++ untypedDict)
154− tys <- forM es $ \e -> case e of
155− Left (_, ty, val) -> do
156− kind <- liftCheck $ kindOf moduleName ty
157− guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
158− ty' <- replaceAllTypeSynonyms ty
159− bindNames dict $ check val ty'
160− return ty'
161− Right (ident, val) -> do
162− ty <- bindNames dict $ infer val
163− ty ~~ fromMaybe (error "name not found in dictionary") (lookup ident untypedDict)
164− return ty
165− return tys
166− forM tys $ flip (escapeCheck checks) sub
167− forM tys $ skolemEscapeCheck
168− return $ map (varIfUnknown . desaturateAllTypeSynonyms . setifyAll) tys
169−
170−isTyped :: (Ident, Value) -> Either (Ident, Type, Value) (Ident, Value)
171−isTyped (name, TypedValue value ty) = Left (name, ty, value)
172−isTyped (name, value) = Right (name, value)
173−
174−escapeCheck :: [AnyUnifiable] -> Type -> Substitution -> Check ()
175−escapeCheck checks ty sub =
176− let
177− visibleUnknowns = nub $ unknowns ty
178− in
179− forM_ checks $ \c -> case c of
180− AnyUnifiable t -> do
181− let unsolvedUnknowns = nub . unknowns $ apply sub t
182− guardWith "Escape check fails" $ null $ unsolvedUnknowns \\ visibleUnknowns
183−
184−skolemEscapeCheck :: Type -> Check ()
185−skolemEscapeCheck ty =
186− case something (extQ (mkQ Nothing findSkolems) findRSkolems) ty of
187− Nothing -> return ()
188− Just _ -> throwError "Skolem variables cannot escape. Consider adding a type signature."
189− where
190− findSkolems (Skolem _) = return ()
191− findSkolems _ = mzero
192− findRSkolems (RSkolem _) = return ()
193− findRSkolems _ = mzero
194−
195−setify :: Row -> Row
196−setify = rowFromList . first (M.toList . M.fromList) . rowToList
197−
198−setifyAll :: (D.Data d) => d -> d
199−setifyAll = everywhere (mkT setify)
200−
201−varIfUnknown :: Type -> Type
202−varIfUnknown ty =
203− let unks = nub $ unknowns ty
204− toName = (:) 't' . show
205− ty' = everywhere (mkT rowToVar) . everywhere (mkT typeToVar) $ ty
206− typeToVar :: Type -> Type
207− typeToVar (TUnknown (Unknown u)) = TypeVar (toName u)
208− typeToVar t = t
209− rowToVar :: Row -> Row
210− rowToVar (RUnknown (Unknown u)) = RowVar (toName u)
211− rowToVar t = t
212− in mkForAll (sort . map toName $ unks) ty'
213−
214−replaceAllTypeVars :: (D.Data d) => [(String, Type)] -> d -> d
215−replaceAllTypeVars = foldl' (\f (name, ty) -> replaceTypeVars name ty . f) id
216−
217−replaceTypeVars :: (D.Data d) => String -> Type -> d -> d
218−replaceTypeVars name t = everywhereBut (mkQ False isShadowed) (mkT replaceTypeVar)
219− where
220− replaceTypeVar (TypeVar v) | v == name = t
221− replaceTypeVar other = other
222− isShadowed (ForAll v _) | v == name = True
223− isShadowed _ = False
224−
225−replaceRowVars :: (D.Data d) => String -> Row -> d -> d
226−replaceRowVars name r = everywhere (mkT replaceRowVar)
227− where
228− replaceRowVar (RowVar v) | v == name = r
229− replaceRowVar other = other
230−
231−replaceAllVarsWithUnknowns :: Type -> Subst Type
232−replaceAllVarsWithUnknowns (ForAll ident ty) = replaceVarWithUnknown ident ty >>= replaceAllVarsWithUnknowns
233−replaceAllVarsWithUnknowns ty = return ty
234−
235−replaceVarWithUnknown :: String -> Type -> Subst Type
236−replaceVarWithUnknown ident ty = do
237− tu <- fresh
238− ru <- fresh
239− return $ replaceRowVars ident ru . replaceTypeVars ident tu $ ty
240−
241−replaceAllTypeSynonyms :: (Functor m, MonadState CheckState m, MonadError String m) => (D.Data d) => d -> m d
242−replaceAllTypeSynonyms d = do
243− env <- getEnv
244− let syns = map (\((path, name), (args, _)) -> (Qualified (Just path) name, length args)) . M.toList $ typeSynonyms env
245− either throwError return $ saturateAllTypeSynonyms syns d
246−
247−desaturateAllTypeSynonyms :: (D.Data d) => d -> d
248−desaturateAllTypeSynonyms = everywhere (mkT replaceSaturatedTypeSynonym)
249− where
250− replaceSaturatedTypeSynonym (SaturatedTypeSynonym name args) = foldl TypeApp (TypeConstructor name) args
251− replaceSaturatedTypeSynonym t = t
252−
253−expandTypeSynonym :: Qualified ProperName -> [Type] -> Subst Type
254−expandTypeSynonym name args = do
255− env <- getEnv
256− moduleName <- substCurrentModule `fmap` ask
257− case M.lookup (qualify moduleName name) (typeSynonyms env) of
258− Just (synArgs, body) -> return $ replaceAllTypeVars (zip synArgs args) body
259− Nothing -> error "Type synonym was not defined"
260−
261−ensureNoDuplicateProperties :: (MonadError String m) => [(String, Value)] -> m ()
262−ensureNoDuplicateProperties ps = guardWith "Duplicate property names" $ length (nub . map fst $ ps) == length ps
263−
264−infer :: Value -> Subst Type
265−infer val = rethrow (\e -> "Error inferring type of term " ++ prettyPrintValue val ++ ":\n" ++ e) $ do
266− ty <- infer' val
267− escapeCheckLater ty
268− return ty
269−
270−infer' :: Value -> Subst Type
271−infer' (NumericLiteral _) = return Number
272−infer' (StringLiteral _) = return String
273−infer' (BooleanLiteral _) = return Boolean
274−infer' (ArrayLiteral vals) = do
275− ts <- mapM (infer) vals
276− els <- fresh
277− forM_ ts $ \t -> els ~~ Array t
278− return els
279−infer' (Unary op val) = do
280− t <- infer val
281− inferUnary op t
282−infer' (Binary op left right) = do
283− t1 <- infer left
284− t2 <- infer right
285− inferBinary op t1 t2
286−infer' (ObjectLiteral ps) = do
287− ensureNoDuplicateProperties ps
288− ts <- mapM (infer . snd) ps
289− let fields = zipWith (\(name, _) t -> (name, t)) ps ts
290− return $ Object $ rowFromList (fields, REmpty)
291−infer' (ObjectUpdate o ps) = do
292− ensureNoDuplicateProperties ps
293− row <- fresh
294− newTys <- zipWith (\(name, _) t -> (name, t)) ps <$> mapM (infer . snd) ps
295− oldTys <- zip (map fst ps) <$> replicateM (length ps) fresh
296− check o $ Object $ rowFromList (oldTys, row)
297− return $ Object $ rowFromList (newTys, row)
298−infer' (Indexer index val) = do
299− el <- fresh
300− check index Number
301− check val (Array el)
302− return el
303−infer' (Accessor prop val) = do
304− obj <- infer 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' (Abs args ret) = do
314− ts <- replicateM (length args) fresh
315− moduleName <- substCurrentModule <$> ask
316− bindLocalVariables moduleName (zip args ts) $ do
317− body <- infer' ret
318− return $ Function ts body
319−infer' app@(App _ _) = do
320− let (f, argss) = unfoldApplication app
321− ft <- infer f
322− ret <- fresh
323− checkFunctionApplications ft argss ret
324− return ret
325−infer' (Var var) = do
326− moduleName <- substCurrentModule <$> ask
327− ty <- lookupVariable moduleName var
328− replaceAllTypeSynonyms ty
329−infer' (Block ss) = do
330− ret <- fresh
331− (allCodePathsReturn, _) <- checkBlock M.empty ret ss
332− guardWith "Block is missing a return statement" allCodePathsReturn
333− return ret
334−infer' (Constructor c) = do
335− env <- getEnv
336− moduleName <- substCurrentModule `fmap` ask
337− case M.lookup (qualify moduleName c) (dataConstructors env) of
338− Nothing -> throwError $ "Constructor " ++ show c ++ " is undefined"
339− Just ty -> replaceAllTypeSynonyms ty
340−infer' (Case vals binders) = do
341− ts <- mapM infer vals
342− ret <- fresh
343− checkBinders ts ret binders
344− return ret
345−infer' (IfThenElse cond th el) = do
346− check cond Boolean
347− t2 <- infer th
348− t3 <- infer el
349− t2 ~~ t3
350− return t2
351−infer' (TypedValue val ty) = do
352− moduleName <- substCurrentModule <$> ask
353− kind <- liftCheck $ kindOf moduleName ty
354− guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
355− ty' <- replaceAllTypeSynonyms ty
356− check val ty'
357− return ty'
358−infer' _ = error "Invalid argument to infer"
359−
360−inferProperty :: Type -> String -> Subst (Maybe Type)
361−inferProperty (Object row) prop = do
362− let (props, _) = rowToList row
363− return $ lookup prop props
364−inferProperty (SaturatedTypeSynonym name args) prop = do
365− replaced <- expandTypeSynonym name args
366− inferProperty replaced prop
367−inferProperty (ForAll ident ty) prop = do
368− replaced <- replaceVarWithUnknown ident ty
369− inferProperty replaced prop
370−inferProperty _ _ = return Nothing
371−
372−inferUnary :: UnaryOperator -> Type -> Subst Type
373−inferUnary op val =
374− case fromMaybe (error "Invalid operator") $ lookup op unaryOps of
375− (valTy, resTy) -> do
376− val ~~ valTy
377− return resTy
378−
379−checkUnary :: UnaryOperator -> Value -> Type -> Subst ()
380−checkUnary op val res =
381− case fromMaybe (error "Invalid operator") $ lookup op unaryOps of
382− (valTy, resTy) -> do
383− res ~~ resTy
384− check val valTy
385−
386−unaryOps :: [(UnaryOperator, (Type, Type))]
387−unaryOps = [ (Negate, (Number, Number))
388− , (Not, (Boolean, Boolean))
389− , (BitwiseNot, (Number, Number))
390− ]
391−
392−inferBinary :: BinaryOperator -> Type -> Type -> Subst Type
393−inferBinary op left right | isEqualityTest op = do
394− left ~~ right
395− return Boolean
396−inferBinary op left right =
397− case fromMaybe (error "Invalid operator") $ lookup op binaryOps of
398− (valTy, resTy) -> do
399− left ~~ valTy
400− right ~~ valTy
401− return resTy
402−
403−checkBinary :: BinaryOperator -> Value -> Value -> Type -> Subst ()
404−checkBinary op left right res | isEqualityTest op = do
405− res ~~ Boolean
406− t1 <- infer left
407− t2 <- infer right
408− t1 ~~ t2
409−checkBinary op left right res =
410− case fromMaybe (error "Invalid operator") $ lookup op binaryOps of
411− (valTy, resTy) -> do
412− res ~~ resTy
413− check left valTy
414− check right valTy
415−
416−isEqualityTest :: BinaryOperator -> Bool
417−isEqualityTest EqualTo = True
418−isEqualityTest NotEqualTo = True
419−isEqualityTest _ = False
420−
421−binaryOps :: [(BinaryOperator, (Type, Type))]
422−binaryOps = [ (Add, (Number, Number))
423− , (Subtract, (Number, Number))
424− , (Multiply, (Number, Number))
425− , (Divide, (Number, Number))
426− , (Modulus, (Number, Number))
427− , (BitwiseAnd, (Number, Number))
428− , (BitwiseOr, (Number, Number))
429− , (BitwiseXor, (Number, Number))
430− , (ShiftRight, (Number, Number))
431− , (ZeroFillShiftRight, (Number, Number))
432− , (And, (Boolean, Boolean))
433− , (Or, (Boolean, Boolean))
434− , (Concat, (String, String))
435− , (Modulus, (Number, Number))
436− , (LessThan, (Number, Boolean))
437− , (LessThanOrEqualTo, (Number, Boolean))
438− , (GreaterThan, (Number, Boolean))
439− , (GreaterThanOrEqualTo, (Number, Boolean))
440− ]
441−
442−inferBinder :: Type -> Binder -> Subst (M.Map Ident Type)
443−inferBinder _ NullBinder = return M.empty
444−inferBinder val (StringBinder _) = val ~~ String >> return M.empty
445−inferBinder val (NumberBinder _) = val ~~ Number >> return M.empty
446−inferBinder val (BooleanBinder _) = val ~~ Boolean >> return M.empty
447−inferBinder val (VarBinder name) = return $ M.singleton name val
448−inferBinder val (NullaryBinder ctor) = do
449− env <- getEnv
450− moduleName <- substCurrentModule <$> ask
451− case M.lookup (qualify moduleName ctor) (dataConstructors env) of
452− Just ty -> do
453− ty `subsumes` val
454− return M.empty
455− _ -> throwError $ "Constructor " ++ show ctor ++ " is not defined"
456−inferBinder val (UnaryBinder ctor binder) = do
457− env <- getEnv
458− moduleName <- substCurrentModule <$> ask
459− case M.lookup (qualify moduleName ctor) (dataConstructors env) of
460− Just ty -> do
461− fn <- replaceAllVarsWithUnknowns ty
462− case fn of
463− Function [obj] ret -> do
464− val `subsumes` ret
465− inferBinder obj binder
466− _ -> throwError $ "Constructor " ++ show ctor ++ " is not a unary constructor"
467− _ -> throwError $ "Constructor " ++ show ctor ++ " is not defined"
468−inferBinder val (ObjectBinder props) = do
469− row <- fresh
470− rest <- fresh
471− m1 <- inferRowProperties row rest props
472− val ~~ Object row
473− return m1
474− where
475− inferRowProperties :: Row -> Row -> [(String, Binder)] -> Subst (M.Map Ident Type)
476− inferRowProperties nrow row [] = nrow ~~ row >> return M.empty
477− inferRowProperties nrow row ((name, binder):binders) = do
478− propTy <- fresh
479− m1 <- inferBinder propTy binder
480− m2 <- inferRowProperties nrow (RCons name propTy row) binders
481− return $ m1 `M.union` m2
482−inferBinder val (ArrayBinder binders) = do
483− el <- fresh
484− m1 <- M.unions <$> mapM (inferBinder el) binders
485− val ~~ Array el
486− return m1
487−inferBinder val (ConsBinder headBinder tailBinder) = do
488− el <- fresh
489− m1 <- inferBinder el headBinder
490− m2 <- inferBinder val tailBinder
491− val ~~ Array el
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−checkBinders :: [Type] -> Type -> [([Binder], Maybe Guard, Value)] -> Subst ()
498−checkBinders _ _ [] = return ()
499−checkBinders nvals ret ((binders, grd, val):bs) = do
500− moduleName <- substCurrentModule <$> ask
501− m1 <- M.unions <$> zipWithM inferBinder nvals binders
502− bindLocalVariables moduleName (M.toList m1) $ do
503− check val ret
504− case grd of
505− Nothing -> return ()
506− Just g -> check g Boolean
507− checkBinders nvals ret bs
508−
509−assignVariable :: Ident -> Subst ()
510−assignVariable name = do
511− env <- checkEnv <$> get
512− moduleName <- substCurrentModule <$> ask
513− case M.lookup (moduleName, name) (names env) of
514− Just (_, LocalVariable) -> throwError $ "Variable with name " ++ show name ++ " already exists."
515− _ -> return ()
516−
517−checkStatement :: M.Map Ident Type -> Type -> Statement -> Subst (Bool, M.Map Ident Type)
518−checkStatement mass _ (VariableIntroduction name val) = do
519− assignVariable name
520− t <- infer val
521− return (False, M.insert name t mass)
522−checkStatement mass _ (Assignment ident val) = do
523− t <- infer 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 mass ret (While val inner) = do
529− check val Boolean
530− (allCodePathsReturn, _) <- checkBlock mass ret inner
531− return (allCodePathsReturn, mass)
532−checkStatement mass ret (If ifst) = do
533− allCodePathsReturn <- checkIfStatement mass ret ifst
534− return (allCodePathsReturn, mass)
535−checkStatement mass ret (For ident start end inner) = do
536− moduleName <- substCurrentModule <$> ask
537− assignVariable ident
538− check start Number
539− check end Number
540− (allCodePathsReturn, _) <- bindLocalVariables moduleName [(ident, Number)] $ checkBlock mass ret inner
541− return (allCodePathsReturn, mass)
542−checkStatement mass ret (ForEach ident vals inner) = do
543− moduleName <- substCurrentModule <$> ask
544− assignVariable ident
545− val <- fresh
546− check vals (Array val)
547− (allCodePathsReturn, _) <- bindLocalVariables moduleName [(ident, val)] $ checkBlock mass ret inner
548− guardWith "Cannot return from within a foreach block" $ not allCodePathsReturn
549− return (False, mass)
550−checkStatement mass _ (ValueStatement val) = do
551− check val unit
552− return (False, mass)
553−checkStatement mass ret (Return val) = do
554− check val ret
555− return (True, mass)
556−
557−checkIfStatement :: M.Map Ident Type -> Type -> IfStatement -> Subst Bool
558−checkIfStatement mass ret (IfStatement val thens Nothing) = do
559− check val Boolean
560− _ <- checkBlock mass ret thens
561− return False
562−checkIfStatement mass ret (IfStatement val thens (Just elses)) = do
563− check val Boolean
564− (allCodePathsReturn1, _) <- checkBlock mass ret thens
565− allCodePathsReturn2 <- checkElseStatement mass ret elses
566− return $ allCodePathsReturn1 && allCodePathsReturn2
567−
568−checkElseStatement :: M.Map Ident Type -> Type -> ElseStatement -> Subst Bool
569−checkElseStatement mass ret (Else elses) = fst <$> checkBlock mass ret elses
570−checkElseStatement mass ret (ElseIf ifst) = checkIfStatement mass ret ifst
571−
572−checkBlock :: M.Map Ident Type -> Type -> [Statement] -> Subst (Bool, M.Map Ident Type)
573−checkBlock mass _ [] = return (False, mass)
574−checkBlock mass ret (s:ss) = do
575− moduleName <- substCurrentModule <$> ask
576− (b1, mass1) <- checkStatement mass ret s
577− bindLocalVariables moduleName (M.toList mass1) $ case (b1, ss) of
578− (True, []) -> return (True, mass1)
579− (True, _) -> throwError "Unreachable code"
580− (False, ss') -> checkBlock mass1 ret ss'
581−
582−skolemize :: String -> Type -> Subst 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 :: Value -> Type -> Subst ()
589−check val ty = rethrow errorMessage $ check' 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' :: Value -> Type -> Subst ()
600−check' val (ForAll idents ty) = do
601− sk <- skolemize idents ty
602− check val sk
603−check' val u@(TUnknown _) = do
604− ty <- infer val
605− -- Don't unify an unknown with an inferred polytype
606− ty' <- replaceAllVarsWithUnknowns ty
607− ty' ~~ u
608−check' (NumericLiteral _) Number = return ()
609−check' (StringLiteral _) String = return ()
610−check' (BooleanLiteral _) Boolean = return ()
611−check' (Unary op val) ty = checkUnary op val ty
612−check' (Binary op left right) ty = checkBinary op left right ty
613−check' (ArrayLiteral vals) (Array ty) = forM_ vals (\val -> check val ty)
614−check' (Indexer index vals) ty = check index Number >> check vals (Array ty)
615−check' (Abs args ret) (Function argTys retTy) = do
616− moduleName <- substCurrentModule <$> ask
617− guardWith "Incorrect number of function arguments" (length args == length argTys)
618− bindLocalVariables moduleName (zip args argTys) $ check ret retTy
619−check' app@(App _ _) ret = do
620− let (f, argss) = unfoldApplication app
621− ft <- infer f
622− checkFunctionApplications ft argss ret
623−check' (Var var) ty = do
624− moduleName <- substCurrentModule <$> ask
625− ty1 <- lookupVariable moduleName var
626− repl <- replaceAllTypeSynonyms ty1
627− repl `subsumes` ty
628−check' (TypedValue val ty1) ty2 = do
629− moduleName <- substCurrentModule <$> ask
630− kind <- liftCheck $ kindOf moduleName ty1
631− guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
632− ty1 `subsumes` ty2
633− check val ty1
634−check' (Case vals binders) ret = do
635− ts <- mapM infer vals
636− checkBinders ts ret binders
637−check' (IfThenElse cond th el) ty = do
638− check cond Boolean
639− check th ty
640− check el ty
641−check' (ObjectLiteral ps) (Object row) = do
642− ensureNoDuplicateProperties ps
643− checkProperties ps row False
644−check' (ObjectUpdate obj ps) (Object row) = do
645− ensureNoDuplicateProperties ps
646− us <- zip (map fst ps) <$> replicateM (length ps) fresh
647− let (propsToCheck, rest) = rowToList row
648− propsToRemove = map fst ps
649− remainingProps = filter (\(p, _) -> p `notElem` propsToRemove) propsToCheck
650− check obj (Object (rowFromList (us ++ remainingProps, rest)))
651− checkProperties ps row True
652−check' (Accessor prop val) ty = do
653− rest <- fresh
654− check val (Object (RCons prop ty rest))
655−check' (Block ss) ret = do
656− (allCodePathsReturn, _) <- checkBlock M.empty ret ss
657− guardWith "Block is missing a return statement" allCodePathsReturn
658−check' (Constructor c) ty = do
659− env <- getEnv
660− moduleName <- substCurrentModule <$> ask
661− case M.lookup (qualify moduleName c) (dataConstructors env) of
662− Nothing -> throwError $ "Constructor " ++ show c ++ " is undefined"
663− Just ty1 -> do
664− repl <- replaceAllTypeSynonyms ty1
665− repl `subsumes` ty
666−check' val (SaturatedTypeSynonym name args) = do
667− ty <- expandTypeSynonym name args
668− check val ty
669−check' val ty = throwError $ prettyPrintValue val ++ " does not have type " ++ prettyPrintType ty
670−
671−checkProperties :: [(String, Value)] -> Row -> Bool -> Subst ()
672−checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where
673− go [] [] REmpty = return ()
674− go [] [] u@(RUnknown _) = u ~~ REmpty
675− go [] [] (RSkolem _) | lax = return ()
676− go [] ((p, _): _) _ | lax = return ()
677− | otherwise = throwError $ prettyPrintValue (ObjectLiteral ps) ++ " does not have property " ++ p
678− go ((p,_):_) [] REmpty = throwError $ "Property " ++ p ++ " is not present in closed object type " ++ prettyPrintRow row
679− go ((p,v):ps') [] u@(RUnknown _) = do
680− ty <- infer v
681− rest <- fresh
682− u ~~ RCons p ty rest
683− go ps' [] rest
684− go ((p,v):ps') ts r =
685− case lookup p ts of
686− Nothing -> do
687− ty <- infer v
688− rest <- fresh
689− r ~~ RCons p ty rest
690− go ps' ts rest
691− Just ty -> do
692− check v ty
693− go ps' (delete (p, ty) ts) r
694− go _ _ _ = throwError $ prettyPrintValue (ObjectLiteral ps) ++ " does not have type " ++ prettyPrintType (Object row)
695−
696−unfoldApplication :: Value -> (Value, [[Value]])
697−unfoldApplication = go []
698− where
699− go argss (App f args) = go (args:argss) f
700− go argss f = (f, argss)
701−
702−checkFunctionApplications :: Type -> [[Value]] -> Type -> Subst ()
703−checkFunctionApplications _ [] _ = error "Nullary function application"
704−checkFunctionApplications fnTy [args] ret = checkFunctionApplication fnTy args ret
705−checkFunctionApplications fnTy (args:argss) ret = do
706− argTys <- mapM (infer) args
707− f <- inferFunctionApplication fnTy argTys
708− checkFunctionApplications f argss ret
709−
710−checkFunctionApplication :: Type -> [Value] -> Type -> Subst ()
711−checkFunctionApplication fnTy args ret = rethrow errorMessage $ checkFunctionApplication' fnTy args ret
712− where
713− errorMessage msg = "Error applying function of type "
714− ++ prettyPrintType fnTy
715− ++ " to arguments " ++ intercalate ", " (map prettyPrintValue args)
716− ++ ", expecting value of type "
717− ++ prettyPrintType ret ++ ":\n" ++ msg
718−
719−inferFunctionApplication :: Type -> [Type] -> Subst Type
720−inferFunctionApplication (Function argTys retTy) args = do
721− guardWith "Incorrect number of function arguments" (length args == length argTys)
722− zipWithM subsumes args argTys
723− return retTy
724−inferFunctionApplication (ForAll ident ty) args = do
725− replaced <- replaceVarWithUnknown ident ty
726− inferFunctionApplication replaced args
727−inferFunctionApplication u@(TUnknown _) args = do
728−
729− ret <- fresh
730− args' <- mapM replaceAllVarsWithUnknowns args
731− u ~~ Function args' ret
732− return ret
733−inferFunctionApplication (SaturatedTypeSynonym name tyArgs) args = do
734− ty <- expandTypeSynonym name tyArgs
735− inferFunctionApplication ty args
736−inferFunctionApplication fnTy args = throwError $ "Cannot apply function of type "
737− ++ prettyPrintType fnTy
738− ++ " to argument(s) of type(s) " ++ intercalate ", " (map prettyPrintType args)
739−
740−checkFunctionApplication' :: Type -> [Value] -> Type -> Subst ()
741−checkFunctionApplication' (Function argTys retTy) args ret = do
742− guardWith "Incorrect number of function arguments" (length args == length argTys)
743− zipWithM (check) args argTys
744− retTy `subsumes` ret
745−checkFunctionApplication' (ForAll ident ty) args ret = do
746− replaced <- replaceVarWithUnknown ident ty
747− checkFunctionApplication replaced args ret
748−checkFunctionApplication' u@(TUnknown _) args ret = do
749− tyArgs <- mapM (\arg -> infer arg >>= replaceAllVarsWithUnknowns) args
750− u ~~ Function tyArgs ret
751−checkFunctionApplication' (SaturatedTypeSynonym name tyArgs) args ret = do
752− ty <- expandTypeSynonym name tyArgs
753− checkFunctionApplication' ty args ret
754−checkFunctionApplication' fnTy args ret = throwError $ "Applying a function of type "
755− ++ prettyPrintType fnTy
756− ++ " to argument(s) " ++ intercalate ", " (map prettyPrintValue args)
757− ++ " does not yield a value of type " ++ prettyPrintType ret ++ "."
758−
759−subsumes :: Type -> Type -> Subst ()
760−subsumes (ForAll ident ty1) ty2 = do
761− replaced <- replaceVarWithUnknown ident ty1
762− replaced `subsumes` ty2
763−subsumes (Function args1 ret1) (Function args2 ret2) = do
764− zipWithM subsumes args2 args1
765− ret1 `subsumes` ret2
766−subsumes ty1 ty2 = ty1 ~~ ty2
767−