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