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