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