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