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