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