@@ -1,725 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.TypeChecker.Types
4−-- Copyright : (c) Phil Freeman 2013
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- |
12−--
13−-----------------------------------------------------------------------------
14−
15−{-# LANGUAGE DeriveDataTypeable #-}
16−
17−module Language.PureScript.TypeChecker.Types (
18− typeOf
19−) where
20−
21−import Data.List
22−import Data.Maybe (fromMaybe)
23−import Data.Function
24−import qualified Data.Data as D
25−import Data.Generics (everywhere, everywhereM, everything, mkT, mkM, mkQ, extM, extQ)
26−
27−import Language.PureScript.Values
28−import Language.PureScript.Types
29−import Language.PureScript.Kinds
30−import Language.PureScript.Names
31−import Language.PureScript.TypeChecker.Monad
32−import Language.PureScript.TypeChecker.Kinds
33−import Language.PureScript.TypeChecker.Synonyms
34−import Language.PureScript.Pretty
35−import Language.PureScript.Unknown
36−
37−import Control.Monad.State
38−import Control.Monad.Error
39−
40−import Control.Applicative
41−import Control.Arrow (Arrow(..), Kleisli(..), (***), (&&&), second)
42−import qualified Control.Category as C
43−
44−import qualified Data.Map as M
45−
46−instance Unifiable Type where
47− unknown = TUnknown
48− isUnknown (TUnknown u) = Just u
49− isUnknown _ = Nothing
50− TUnknown u1 ~~ TUnknown u2 | u1 == u2 = return ()
51− TUnknown u ~~ t = replace u t
52− t ~~ TUnknown u = replace u t
53− SaturatedTypeSynonym name1 args1 ~~ SaturatedTypeSynonym name2 args2 | name1 == name2 =
54− zipWithM_ (~~) args1 args2
55− SaturatedTypeSynonym name args ~~ ty = do
56− env <- lift getEnv
57− modulePath <- checkModulePath `fmap` lift get
58− case M.lookup (qualify modulePath name) (typeSynonyms env) of
59− Just (synArgs, body) -> do
60− let m = M.fromList $ zip synArgs args
61− let replaced = replaceTypeVars m body
62− replaced ~~ ty
63− Nothing -> error "Type synonym was not defined"
64− ty ~~ s@(SaturatedTypeSynonym _ _) = s ~~ ty
65− ForAll ident1 ty1 ~~ ForAll ident2 ty2 = do
66− sk <- skolemize ident1 ty1
67− replaced <- replaceVarsWithUnknowns [ident2] ty2
68− sk ~~ replaced
69− ForAll ident ty1 ~~ ty2 = do
70− sk <- skolemize ident ty1
71− sk ~~ ty2
72− ty ~~ f@(ForAll _ _) = f ~~ ty
73− Number ~~ Number = return ()
74− String ~~ String = return ()
75− Boolean ~~ Boolean = return ()
76− Array s ~~ Array t = s ~~ t
77− Object row1 ~~ Object row2 = row1 ~~ row2
78− Function args1 ret1 ~~ Function args2 ret2 = do
79− guardWith "Function applied to incorrect number of args" $ length args1 == length args2
80− zipWithM_ (~~) args1 args2
81− ret1 ~~ ret2
82− TypeVar v1 ~~ TypeVar v2 | v1 == v2 = return ()
83− TypeConstructor c1 ~~ TypeConstructor c2 = do
84− modulePath <- checkModulePath `fmap` lift get
85− guardWith ("Cannot unify " ++ show c1 ++ " with " ++ show c2 ++ ".") (qualify modulePath c1 == qualify modulePath c2)
86− TypeApp t1 t2 ~~ TypeApp t3 t4 = do
87− t1 ~~ t3
88− t2 ~~ t4
89− Skolem s1 ~~ Skolem s2 | s1 == s2 = return ()
90− t1 ~~ t2 = throwError $ "Cannot unify " ++ prettyPrintType t1 ++ " with " ++ prettyPrintType t2 ++ "."
91− apply s (TUnknown u) = runSubstitution s u
92− apply s (SaturatedTypeSynonym name tys) = SaturatedTypeSynonym name $ map (apply s) tys
93− apply s (ForAll idents ty) = ForAll idents $ apply s ty
94− apply s (Array t) = Array (apply s t)
95− apply s (Object r) = Object (apply s r)
96− apply s (Function args ret) = Function (map (apply s) args) (apply s ret)
97− apply s (TypeApp t1 t2) = TypeApp (apply s t1) (apply s t2)
98− apply _ t = t
99− unknowns (TUnknown (Unknown u)) = [u]
100− unknowns (SaturatedTypeSynonym _ tys) = concatMap unknowns tys
101− unknowns (ForAll idents ty) = unknowns ty
102− unknowns (Array t) = unknowns t
103− unknowns (Object r) = unknowns r
104− unknowns (Function args ret) = concatMap unknowns args ++ unknowns ret
105− unknowns (TypeApp t1 t2) = unknowns t1 ++ unknowns t2
106− unknowns _ = []
107−
108−instance Unifiable Row where
109− unknown = RUnknown
110− isUnknown (RUnknown u) = Just u
111− isUnknown _ = Nothing
112− r1 ~~ r2 =
113− let
114− (s1, r1') = rowToList r1
115− (s2, r2') = rowToList r2
116− int = [ (t1, t2) | (name, t1) <- s1, (name', t2) <- s2, name == name' ]
117− sd1 = [ (name, t1) | (name, t1) <- s1, name `notElem` map fst s2 ]
118− sd2 = [ (name, t2) | (name, t2) <- s2, name `notElem` map fst s1 ]
119− in do
120− forM_ int (uncurry (~~))
121− unifyRows sd1 r1' sd2 r2'
122− where
123− unifyRows :: [(String, Type)] -> Row -> [(String, Type)] -> Row -> Subst Check ()
124− unifyRows [] (RUnknown u) sd r = replace u (rowFromList (sd, r))
125− unifyRows sd r [] (RUnknown u) = replace u (rowFromList (sd, r))
126− unifyRows ns@((name, ty):row) r others u@(RUnknown un) = do
127− occursCheck un ty
128− forM row $ \(_, ty) -> occursCheck un ty
129− u' <- fresh
130− u ~~ RCons name ty u'
131− unifyRows row r others u'
132− unifyRows [] REmpty [] REmpty = return ()
133− unifyRows [] (RowVar v1) [] (RowVar v2) | v1 == v2 = return ()
134− unifyRows [] (RSkolem s1) [] (RSkolem s2) | s1 == s2 = return ()
135− unifyRows sd1 r1 sd2 r2 = throwError $ "Cannot unify " ++ prettyPrintRow (rowFromList (sd1, r1)) ++ " with " ++ prettyPrintRow (rowFromList (sd2, r2)) ++ "."
136− apply s (RUnknown u) = runSubstitution s u
137− apply s (RCons name ty r) = RCons name (apply s ty) (apply s r)
138− apply _ r = r
139− unknowns (RUnknown (Unknown u)) = [u]
140− unknowns (RCons _ ty r) = unknowns ty ++ unknowns r
141− unknowns _ = []
142−
143−isFunction :: Value -> Bool
144−isFunction (Abs _ _) = True
145−isFunction (TypedValue untyped _) = isFunction untyped
146−isFunction _ = False
147−
148−typeOf :: Maybe Ident -> Value -> Check Type
149−typeOf name val = do
150− ty <- runSubst $ case name of
151− Just ident -> do me <- fresh
152− ty <- infer (M.singleton ident me) val
153− me ~~ ty
154− return ty
155− Nothing -> infer M.empty val
156− --desugared <- replaceAllTypeSynonyms cs
157− --TODO: allUnknownsBecameQuantified desugared solution ty
158− return $ varIfUnknown $ desaturateAllTypeSynonyms $ setifyAll ty
159−
160−{-
161−allUnknownsBecameQuantified :: [TypeConstraint] -> TypeSolution -> Type -> Check ()
162−allUnknownsBecameQuantified cs solution ty = do
163− let
164− typesMentioned = findUnknownTypes ty
165− unknownTypes = nub $ flip concatMap cs $ \c -> case c of
166− TypeConstraint u t _ -> u : findUnknownTypes t
167− RowConstraint _ r _ -> findUnknownTypes r
168− unsolvedTypes = filter (\n -> TUnknown n == fst (runTypeSolution solution) n) unknownTypes
169− guardWith "Unsolved type variable" $ null $ unsolvedTypes \\ typesMentioned
170− let
171− rowsMentioned = findUnknownRows ty
172− unknownRows = nub $ flip concatMap cs $ \c -> case c of
173− TypeConstraint _ t _ -> findUnknownRows t
174− RowConstraint u r _ -> u : findUnknownRows r
175− unsolvedRows = filter (\n -> RUnknown n == snd (runTypeSolution solution) n) unknownRows
176− guardWith "Unsolved row variable" $ null $ unsolvedRows \\ rowsMentioned
177−
178−findUnknownTypes :: (D.Data d) => d -> [Unknown Type]
179−findUnknownTypes = everything (++) (mkQ [] f)
180− where
181− f :: Type -> [Unknown Type]
182− f (TUnknown n) = [n]
183− f _ = []
184−
185−findUnknownRows :: (D.Data d) => d -> [Unknown Row]
186−findUnknownRows = everything (++) (mkQ [] f)
187− where
188− f :: Row -> [Unknown Row]
189− f (RUnknown n) = [n]
190− f _ = []
191−-}
192−
193−setify :: Row -> Row
194−setify = rowFromList . first (M.toList . M.fromList) . rowToList
195−
196−setifyAll :: (D.Data d) => d -> d
197−setifyAll = everywhere (mkT setify)
198−
199−findTypeVars :: (D.Data d) => d -> [String]
200−findTypeVars = everything (++) (mkQ [] f)
201− where
202− f :: Type -> [String]
203− f (TypeVar v) = [v]
204− f _ = []
205−
206−varIfUnknown :: Type -> Type
207−varIfUnknown ty =
208− let
209− (ty', m) = flip runState M.empty $ everywhereM (flip extM g $ mkM f) ty
210− in
211− mkForAll (sort $ nub $ M.elems m ++ findTypeVars ty) ty'
212− where
213− f :: Type -> State (M.Map Int String) Type
214− f (TUnknown (Unknown n)) = do
215− m <- get
216− case M.lookup n m of
217− Nothing -> do
218− let name = 't' : show (M.size m)
219− put $ M.insert n name m
220− return $ TypeVar name
221− Just name -> return $ TypeVar name
222− f t = return t
223− g :: Row -> State (M.Map Int String) Row
224− g (RUnknown (Unknown n)) = do
225− m <- get
226− case M.lookup n m of
227− Nothing -> do
228− let name = 'r' : show (M.size m)
229− put $ M.insert n name m
230− return $ RowVar name
231− Just name -> return $ RowVar name
232− g r = return r
233−
234−replaceTypeVars :: M.Map String Type -> Type -> Type
235−replaceTypeVars m = everywhere (mkT replace)
236− where
237− replace (TypeVar v) = case M.lookup v m of
238− Just ty -> ty
239− _ -> TypeVar v
240− replace t = t
241−
242−replaceRowVars :: M.Map String Row -> Type -> Type
243−replaceRowVars m = everywhere (mkT replace)
244− where
245− replace (RowVar v) = case M.lookup v m of
246− Just r -> r
247− _ -> RowVar v
248− replace t = t
249−
250−replaceVarsWithUnknowns :: [String] -> Type -> Subst Check Type
251−replaceVarsWithUnknowns idents = flip evalStateT M.empty . everywhereM (flip extM f $ mkM g)
252− where
253− f :: Type -> StateT (M.Map String Int) (Subst Check) Type
254− f (TypeVar var) | var `elem` idents = do
255− m <- get
256− n <- lift fresh'
257− case M.lookup var m of
258− Nothing -> do
259− put (M.insert var n m)
260− return $ TUnknown (Unknown n)
261− Just u -> return $ TUnknown (Unknown u)
262− f t = return t
263− g :: Row -> StateT (M.Map String Int) (Subst Check) Row
264− g (RowVar var) | var `elem` idents = do
265− m <- get
266− n <- lift fresh'
267− case M.lookup var m of
268− Nothing -> do
269− put (M.insert var n m)
270− return $ RUnknown (Unknown n)
271− Just u -> return $ RUnknown (Unknown u)
272− g r = return r
273−
274−replaceAllTypeSynonyms :: (D.Data d) => d -> Check d
275−replaceAllTypeSynonyms d = do
276− env <- getEnv
277− let syns = map (\((path, name), (args, _)) -> (Qualified path name, length args)) . M.toList $ typeSynonyms env
278− either throwError return $ saturateAllTypeSynonyms syns d
279−
280−desaturateAllTypeSynonyms :: (D.Data d) => d -> d
281−desaturateAllTypeSynonyms = everywhere (mkT replace)
282− where
283− replace (SaturatedTypeSynonym name args) = foldl TypeApp (TypeConstructor name) args
284− replace t = t
285−
286−ensureNoDuplicateProperties :: [(String, Value)] -> Check ()
287−ensureNoDuplicateProperties ps = guardWith "Duplicate property names" $ length (nub . map fst $ ps) == length ps
288−
289−infer :: M.Map Ident Type -> Value -> Subst Check Type
290−infer m val = rethrow (\e -> "Error inferring type of term " ++ prettyPrintValue val ++ ":\n" ++ e) $ infer' m val
291−
292−infer' _ (NumericLiteral _) = return Number
293−infer' _ (StringLiteral _) = return String
294−infer' _ (BooleanLiteral _) = return Boolean
295−infer' m (ArrayLiteral vals) = do
296− ts <- mapM (infer m) vals
297− arr <- fresh
298− forM_ ts $ \t -> arr ~~ Array t
299− return arr
300−infer' m (Unary op val) = do
301− t <- infer m val
302− inferUnary op t
303−infer' m (Binary op left right) = do
304− t1 <- infer m left
305− t2 <- infer m right
306− inferBinary op t1 t2
307−infer' m (ObjectLiteral ps) = do
308− lift $ ensureNoDuplicateProperties ps
309− ts <- mapM (infer m . snd) ps
310− let fields = zipWith (\(name, _) t -> (name, t)) ps ts
311− return $ Object $ typesToRow fields
312−infer' m (ObjectUpdate o ps) = do
313− lift $ ensureNoDuplicateProperties ps
314− obj <- infer m o
315− row <- fresh
316− ts <- mapM (infer m . snd) ps
317− let tys = zipWith (\(name, _) t -> (name, t)) ps ts
318− obj ~~ Object (rowFromList (tys, row))
319− return obj
320−infer' m (Indexer index val) = do
321− el <- fresh
322− check m index Number
323− check m val (Array el)
324− return el
325−infer' m (Accessor prop val) = do
326− field <- fresh
327− rest <- fresh
328− check m val (Object (RCons prop field rest))
329− return field
330−infer' m v@(Abs args ret) = do
331− ts <- replicateM (length args) fresh
332− let m' = m `M.union` M.fromList (zip args ts)
333− body <- infer m' ret
334− return $ Function ts body
335−infer' m v@(App f xs) = do
336− t1 <- infer m f
337− ret <- fresh
338− checkFunctionApplication m t1 xs ret
339− return ret
340−infer' m v@(Var var@(Qualified mp name)) = do
341− case mp of
342− ModulePath [] ->
343− case M.lookup name m of
344− Just ty -> lift $ replaceAllTypeSynonyms ty
345− Nothing -> lookupGlobal
346− _ -> lookupGlobal
347− where
348− lookupGlobal = do
349− env <- lift getEnv
350− modulePath <- checkModulePath `fmap` lift get
351− case M.lookup (qualify modulePath var) (names env) of
352− Nothing -> throwError $ show var ++ " is undefined"
353− Just (ty, _) -> lift $ replaceAllTypeSynonyms ty
354−infer' m (Block ss) = do
355− ret <- fresh
356− (allCodePathsReturn, _) <- checkBlock m M.empty ret ss
357− guardWith "Block is missing a return statement" allCodePathsReturn
358− return ret
359−infer' m v@(Constructor c) = do
360− env <- lift getEnv
361− modulePath <- checkModulePath `fmap` lift get
362− case M.lookup (qualify modulePath c) (dataConstructors env) of
363− Nothing -> throwError $ "Constructor " ++ show c ++ " is undefined"
364− Just ty -> lift $ replaceAllTypeSynonyms ty
365−infer' m (Case val binders) = do
366− t1 <- infer m val
367− ret <- fresh
368− checkBinders m t1 ret binders
369− return ret
370−infer' m v@(IfThenElse cond th el) = do
371− check m cond Boolean
372− t2 <- infer m th
373− t3 <- infer m el
374− t2 ~~ t3
375− return t2
376−infer' m v@(TypedValue val ty) = do
377− kind <- lift $ kindOf ty
378− guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
379− ty' <- lift $ replaceAllTypeSynonyms ty
380− check m val ty'
381− return ty'
382−
383−inferUnary :: UnaryOperator -> Type -> Subst Check Type
384−inferUnary op val =
385− case fromMaybe (error "Invalid operator") $ lookup op unaryOps of
386− (valTy, resTy) -> do
387− val ~~ valTy
388− return resTy
389−
390−checkUnary :: M.Map Ident Type -> UnaryOperator -> Value -> Type -> Subst Check ()
391−checkUnary m op val res =
392− case fromMaybe (error "Invalid operator") $ lookup op unaryOps of
393− (valTy, resTy) -> do
394− res ~~ resTy
395− check m val valTy
396−
397−unaryOps :: [(UnaryOperator, (Type, Type))]
398−unaryOps = [ (Negate, (Number, Number))
399− , (Not, (Boolean, Boolean))
400− , (BitwiseNot, (Number, Number))
401− ]
402−
403−inferBinary :: BinaryOperator -> Type -> Type -> Subst Check Type
404−inferBinary op left right | isEqualityTest op = do
405− left ~~ right
406− return Boolean
407−inferBinary op left right =
408− case fromMaybe (error "Invalid operator") $ lookup op binaryOps of
409− (valTy, resTy) -> do
410− left ~~ valTy
411− right ~~ valTy
412− return resTy
413−
414−checkBinary :: M.Map Ident Type -> BinaryOperator -> Value -> Value -> Type -> Subst Check ()
415−checkBinary m op left right res | isEqualityTest op = do
416− res ~~ Boolean
417− t1 <- infer m left
418− t2 <- infer m right
419− t1 ~~ t2
420−checkBinary m op left right res =
421− case fromMaybe (error "Invalid operator") $ lookup op binaryOps of
422− (valTy, resTy) -> do
423− res ~~ resTy
424− check m left valTy
425− check m right valTy
426−
427−isEqualityTest :: BinaryOperator -> Bool
428−isEqualityTest EqualTo = True
429−isEqualityTest NotEqualTo = True
430−isEqualityTest _ = False
431−
432−binaryOps :: [(BinaryOperator, (Type, Type))]
433−binaryOps = [ (Add, (Number, Number))
434− , (Subtract, (Number, Number))
435− , (Multiply, (Number, Number))
436− , (Divide, (Number, Number))
437− , (Modulus, (Number, Number))
438− , (BitwiseAnd, (Number, Number))
439− , (BitwiseOr, (Number, Number))
440− , (BitwiseXor, (Number, Number))
441− , (ShiftRight, (Number, Number))
442− , (ZeroFillShiftRight, (Number, Number))
443− , (And, (Boolean, Boolean))
444− , (Or, (Boolean, Boolean))
445− , (Concat, (String, String))
446− , (Modulus, (Number, Number))
447− , (LessThan, (Number, Boolean))
448− , (LessThanOrEqualTo, (Number, Boolean))
449− , (GreaterThan, (Number, Boolean))
450− , (GreaterThanOrEqualTo, (Number, Boolean))
451− ]
452−
453−inferBinder :: Type -> Binder -> Subst Check (M.Map Ident Type)
454−inferBinder _ NullBinder = return M.empty
455−inferBinder val (StringBinder _) = val ~~ String >> return M.empty
456−inferBinder val (NumberBinder _) = val ~~ Number >> return M.empty
457−inferBinder val (BooleanBinder _) = val ~~ Boolean >> return M.empty
458−inferBinder val (VarBinder name) = return $ M.singleton name val
459−inferBinder val (NullaryBinder ctor) = do
460− env <- lift getEnv
461− modulePath <- checkModulePath `fmap` lift get
462− case M.lookup (qualify modulePath ctor) (dataConstructors env) of
463− Just ty -> do
464− ty `subsumes` val
465− return M.empty
466− _ -> throwError $ "Constructor " ++ show ctor ++ " is not defined"
467−inferBinder val b@(UnaryBinder ctor binder) = do
468− env <- lift getEnv
469− modulePath <- checkModulePath `fmap` lift get
470− case M.lookup (qualify modulePath ctor) (dataConstructors env) of
471− Just ty -> do
472− obj <- fresh
473− ty `subsumes` (Function [obj] val)
474− inferBinder obj binder
475− _ -> throwError $ "Constructor " ++ show ctor ++ " is not defined"
476−inferBinder val b@(ObjectBinder props) = do
477− row <- fresh
478− rest <- fresh
479− m1 <- inferRowProperties row rest props
480− val ~~ Object row
481− return m1
482− where
483− inferRowProperties :: Row -> Row -> [(String, Binder)] -> Subst Check (M.Map Ident Type)
484− inferRowProperties nrow row [] = nrow ~~ row >> return M.empty
485− inferRowProperties nrow row ((name, binder):binders) = do
486− propTy <- fresh
487− m1 <- inferBinder propTy binder
488− m2 <- inferRowProperties nrow (RCons name propTy row) binders
489− return $ m1 `M.union` m2
490−inferBinder val (ArrayBinder binders rest) = do
491− el <- fresh
492− m1 <- M.unions <$> mapM (inferBinder el) binders
493− val ~~ Array el
494− case rest of
495− Nothing -> return m1
496− Just binder -> do
497− m2 <- inferBinder val binder
498− return $ m1 `M.union` m2
499−inferBinder val (NamedBinder name binder) = do
500− m <- inferBinder val binder
501− return $ M.insert name val m
502−
503−inferGuardedBinder :: M.Map Ident Type -> Type -> Binder -> Subst Check (M.Map Ident Type)
504−inferGuardedBinder m val b@(GuardedBinder cond binder) = do
505− m1 <- inferBinder val binder
506− ty <- infer (m `M.union` m1) cond
507− ty ~~ Boolean
508− return m1
509−inferGuardedBinder m val b = inferBinder val b >>= return
510−
511−checkBinders :: M.Map Ident Type -> Type -> Type -> [(Binder, Value)] -> Subst Check ()
512−checkBinders _ _ _ [] = return ()
513−checkBinders m nval ret ((binder, val):bs) = do
514− m1 <- inferGuardedBinder m nval binder
515− check (m `M.union` m1) val ret
516− checkBinders m nval ret bs
517−
518−assignVariable :: Ident -> M.Map Ident Type -> Subst Check ()
519−assignVariable name m =
520− case M.lookup name m of
521− Nothing -> return ()
522− Just _ -> throwError $ "Variable with name " ++ show name ++ " already exists."
523−
524−checkStatement :: M.Map Ident Type -> M.Map Ident Type -> Type -> Statement -> Subst Check (Bool, M.Map Ident Type)
525−checkStatement m mass ret (VariableIntroduction name val) = do
526− assignVariable name (m `M.union` mass)
527− t <- infer m val
528− return (False, M.insert name t mass)
529−checkStatement m mass ret (Assignment ident val) = do
530− t <- infer m val
531− case M.lookup ident mass of
532− Nothing -> throwError $ "No local variable with name " ++ show ident
533− Just ty -> do t ~~ ty
534− return (False, mass)
535−checkStatement m mass ret (While val inner) = do
536− check m val Boolean
537− (allCodePathsReturn, _) <- checkBlock m mass ret inner
538− return (allCodePathsReturn, mass)
539−checkStatement m mass ret (If ifst) = do
540− allCodePathsReturn <- checkIfStatement m mass ret ifst
541− return (allCodePathsReturn, mass)
542−checkStatement m mass ret (For ident start end inner) = do
543− assignVariable ident (m `M.union` mass)
544− check (m `M.union` mass) start Number
545− check (m `M.union` mass) end Number
546− let mass1 = M.insert ident Number mass
547− (allCodePathsReturn, _) <- checkBlock (m `M.union` mass1) mass1 ret inner
548− return (allCodePathsReturn, mass)
549−checkStatement m mass ret (ForEach ident vals inner) = do
550− assignVariable ident (m `M.union` mass)
551− val <- fresh
552− check (m `M.union` mass) vals (Array val)
553− let mass1 = M.insert ident val mass
554− (allCodePathsReturn, _) <- checkBlock (m `M.union` mass1) mass1 ret inner
555− guardWith "Cannot return from within a foreach block" $ not allCodePathsReturn
556− return (False, mass)
557−checkStatement m mass ret (Return val) = do
558− check (m `M.union` mass) val ret
559− return (True, mass)
560−
561−checkIfStatement :: M.Map Ident Type -> M.Map Ident Type -> Type -> IfStatement -> Subst Check Bool
562−checkIfStatement m mass ret (IfStatement val thens Nothing) = do
563− check m val Boolean
564− _ <- checkBlock m mass ret thens
565− return False
566−checkIfStatement m mass ret (IfStatement val thens (Just elses)) = do
567− check m val Boolean
568− (allCodePathsReturn1, _) <- checkBlock m mass ret thens
569− allCodePathsReturn2 <- checkElseStatement m mass ret elses
570− return $ allCodePathsReturn1 && allCodePathsReturn2
571−
572−checkElseStatement :: M.Map Ident Type -> M.Map Ident Type -> Type -> ElseStatement -> Subst Check Bool
573−checkElseStatement m mass ret (Else elses) = fst <$> checkBlock m mass ret elses
574−checkElseStatement m mass ret (ElseIf ifst) = checkIfStatement m mass ret ifst
575−
576−checkBlock :: M.Map Ident Type -> M.Map Ident Type -> Type -> [Statement] -> Subst Check (Bool, M.Map Ident Type)
577−checkBlock _ mass _ [] = return (False, mass)
578−checkBlock m mass ret (s:ss) = do
579− (b1, mass1) <- checkStatement (m `M.union` mass) mass ret s
580− case (b1, ss) of
581− (True, []) -> return (True, mass1)
582− (True, _) -> throwError "Unreachable code"
583− (False, ss) -> do
584− (b2, mass2) <- checkBlock m mass1 ret ss
585− return (b2, mass2)
586−
587−skolemize :: String -> Type -> Subst Check Type
588−skolemize ident ty = do
589− tsk <- Skolem <$> fresh'
590− rsk <- RSkolem <$> fresh'
591− return $ replaceRowVars (M.singleton ident rsk) $ replaceTypeVars (M.singleton ident tsk) ty
592−
593−check :: M.Map Ident Type -> Value -> Type -> Subst Check ()
594−check m (NumericLiteral _) Number = return ()
595−check m (StringLiteral _) String = return ()
596−check m (BooleanLiteral _) Boolean = return ()
597−check m (Unary op val) ty = checkUnary m op val ty
598−check m (Binary op left right) ty = checkBinary m op left right ty
599−check m (ArrayLiteral vals) (Array ty) = forM_ vals (\val -> check m val ty)
600−check m (Indexer index vals) ty = check m index Number >> check m vals (Array ty)
601−check m (Abs args ret) (Function argTys retTy) = do
602− guardWith "Incorrect number of function arguments" (length args == length argTys)
603− let bindings = M.fromList (zip args argTys)
604− check (bindings `M.union` m) ret retTy
605−check m (App f xs) ret = do
606− ft <- infer m f
607− checkFunctionApplication m ft xs ret
608−check m val (ForAll idents ty) = do
609− sk <- skolemize idents ty
610− check m val sk
611−check m v@(Var var@(Qualified mp name)) ty = do
612− case mp of
613− ModulePath [] ->
614− case M.lookup name m of
615− Just ty1 -> do
616− repl <- lift $ replaceAllTypeSynonyms ty1
617− repl `subsumes` ty
618− Nothing -> lookupGlobal
619− _ -> lookupGlobal
620− where
621− lookupGlobal = do
622− env <- lift getEnv
623− modulePath <- checkModulePath `fmap` lift get
624− case M.lookup (qualify modulePath var) (names env) of
625− Nothing -> throwError $ show var ++ " is undefined"
626− Just (ty1, _) -> do
627− repl <- lift $ replaceAllTypeSynonyms ty1
628− repl `subsumes` ty
629−check m val u@(TUnknown _) = do
630− ty <- infer m val
631− ty ~~ u
632− return ()
633−check m (TypedValue val ty1) ty2 = do
634− kind <- lift $ kindOf ty1
635− guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
636− ty1 `subsumes` ty2
637− check m val ty1
638−check m (Case val binders) ret = do
639− t1 <- infer m val
640− checkBinders m t1 ret binders
641−check m (IfThenElse cond th el) ty = do
642− check m cond Boolean
643− check m th ty
644− check m el ty
645−check m (ObjectLiteral ps) (Object row) = do
646− lift $ ensureNoDuplicateProperties ps
647− checkProperties m ps row False
648−check m (ObjectUpdate obj ps) objTy@(Object row) = do
649− lift $ ensureNoDuplicateProperties ps
650− check m obj objTy
651− checkProperties m ps row True
652−check m (Accessor prop val) ty = do
653− rest <- fresh
654− check m val (Object (RCons prop ty rest))
655−check m (Block ss) ret = do
656− (allCodePathsReturn, _) <- checkBlock m M.empty ret ss
657− guardWith "Block is missing a return statement" allCodePathsReturn
658−check m (Constructor c) ty = do
659− env <- lift getEnv
660− modulePath <- checkModulePath `fmap` lift get
661− case M.lookup (qualify modulePath c) (dataConstructors env) of
662− Nothing -> throwError $ "Constructor " ++ show c ++ " is undefined"
663− Just ty1 -> do
664− repl <- lift $ replaceAllTypeSynonyms ty1
665− repl `subsumes` ty
666−check m val (SaturatedTypeSynonym name args) = do
667− env <- lift getEnv
668− modulePath <- checkModulePath `fmap` lift get
669− case M.lookup (qualify modulePath name) (typeSynonyms env) of
670− Just (synArgs, body) -> do
671− let replaced = replaceTypeVars (M.fromList (zip synArgs args)) body
672− check m val replaced
673− Nothing -> error "Type synonym was not defined"
674−check _ val ty = throwError $ prettyPrintValue val ++ " does not have type " ++ prettyPrintType ty
675−
676−checkProperties :: M.Map Ident Type -> [(String, Value)] -> Row -> Bool -> Subst Check ()
677−checkProperties m ps row lax = let (ts, r') = rowToList row in go ps ts r' where
678− go [] [] REmpty = return ()
679− go [] [] u@(RUnknown _) = u ~~ REmpty
680− go [] [] (RSkolem _) | lax = return ()
681− go [] ((p, _): _) _ | lax = return ()
682− | otherwise = throwError $ prettyPrintValue (ObjectLiteral ps) ++ " does not have property " ++ p
683− go ((p,_):_) [] REmpty = throwError $ "Property " ++ p ++ " is not present in closed object type " ++ prettyPrintRow row
684− go ((p,v):ps) [] u@(RUnknown _) = do
685− ty <- infer m v
686− rest <- fresh
687− u ~~ RCons p ty rest
688− go ps [] rest
689− go ((p,v):ps) ts r =
690− case lookup p ts of
691− Nothing -> do
692− ty <- infer m v
693− rest <- fresh
694− r ~~ RCons p ty rest
695− go ps ts rest
696− Just ty -> do
697− check m v ty
698− go ps (delete (p, ty) ts) r
699− go _ _ _ = throwError $ prettyPrintValue (ObjectLiteral ps) ++ " does not have type " ++ prettyPrintType (Object row)
700−
701−checkFunctionApplication :: M.Map Ident Type -> Type -> [Value] -> Type -> Subst Check ()
702−checkFunctionApplication m (Function argTys retTy) args ret = do
703− guardWith "Incorrect number of function arguments" (length args == length argTys)
704− zipWithM (check m) args argTys
705− ret ~~ retTy
706−checkFunctionApplication m (ForAll ident ty) args ret = do
707− replaced <- replaceVarsWithUnknowns [ident] ty
708− checkFunctionApplication m replaced args ret
709−checkFunctionApplication m u@(TUnknown _) args ret = do
710− tyArgs <- replicateM (length args) fresh
711− u ~~ Function tyArgs ret
712−checkFunctionApplication _ fnTy args ret = throwError $ "Cannot apply function of type "
713− ++ prettyPrintType fnTy
714− ++ " to arguments " ++ intercalate ", " (map prettyPrintValue args)
715− ++ ". Expecting value of type " ++ prettyPrintType ret ++ "."
716−
717−subsumes :: Type -> Type -> Subst Check ()
718−subsumes (ForAll ident ty1) ty2 = do
719− replaced <- replaceVarsWithUnknowns [ident] ty1
720− replaced `subsumes` ty2
721−subsumes (Function args1 ret1) (Function args2 ret2) = do
722− zipWithM subsumes args2 args1
723− ret1 `subsumes` ret2
724−subsumes ty1 ty2 = ty1 ~~ ty2
725−