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