@@ -18,9 +18,8 @@ module Language.PureScript.TypeChecker.Types (
1818 typeOf
1919) where
2020
21−import Debug.Trace
22−
2321import Data.List
22+import Data.Maybe (fromMaybe)
2423import Data.Function
2524import qualified Data.Data as D
2625import Data.Generics (everywhere, everywhereM, everything, mkT, mkM, mkQ, extM, extQ)
@@ -63,8 +62,12 @@ instance Unifiable Type where
6362 replaced ~~ ty
6463 Nothing -> error "Type synonym was not defined"
6564 ty ~~ s@(SaturatedTypeSynonym _ _) = s ~~ ty
66− ForAll idents ty1 ~~ ty2 = do
67− sk <- skolemize idents ty1
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
6871 sk ~~ ty2
6972 ty ~~ f@(ForAll _ _) = f ~~ ty
7073 Number ~~ Number = return ()
@@ -128,6 +131,7 @@ instance Unifiable Row where
128131 unifyRows row r others u'
129132 unifyRows [] REmpty [] REmpty = return ()
130133 unifyRows [] (RowVar v1) [] (RowVar v2) | v1 == v2 = return ()
134+ unifyRows [] (RSkolem s1) [] (RSkolem s2) | s1 == s2 = return ()
131135 unifyRows sd1 r1 sd2 r2 = throwError $ "Cannot unify " ++ prettyPrintRow (rowFromList (sd1, r1)) ++ " with " ++ prettyPrintRow (rowFromList (sd2, r2)) ++ "."
132136 apply s (RUnknown u) = runSubstitution s u
133137 apply s (RCons name ty r) = RCons name (apply s ty) (apply s r)
@@ -204,7 +208,7 @@ varIfUnknown ty =
204208 let
205209 (ty', m) = flip runState M.empty $ everywhereM (flip extM g $ mkM f) ty
206210 in
207− ForAll (sort $ nub $ M.elems m ++ findTypeVars ty) ty'
211+ mkForAll (sort $ nub $ M.elems m ++ findTypeVars ty) ty'
208212 where
209213 f :: Type -> State (M.Map Int String) Type
210214 f (TUnknown (Unknown n)) = do
@@ -235,6 +239,14 @@ replaceTypeVars m = everywhere (mkT replace)
235239 _ -> TypeVar v
236240 replace t = t
237241
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+
238250replaceVarsWithUnknowns :: [String] -> Type -> Subst Check Type
239251replaceVarsWithUnknowns idents = flip evalStateT M.empty . everywhereM (flip extM f $ mkM g)
240252 where
@@ -305,9 +317,8 @@ infer m (ObjectUpdate o ps) = do
305317 return obj
306318infer m (Indexer index val) = do
307319 el <- fresh
308− t1 <- infer m index
320+ check m index Number
309321 t2 <- infer m val
310− t1 ~~ Number
311322 t2 ~~ Array el
312323 return el
313324infer m (Accessor prop val) = do
@@ -323,10 +334,9 @@ infer m v@(Abs args ret) = do
323334 return $ Function ts body
324335infer m v@(App f xs) = do
325336 t1 <- infer m f
326− ts <- mapM (infer m) xs
327− me <- fresh
328− t1 ~~ Function ts me
329− return me
337+ ret <- fresh
338+ checkFunctionApplication m t1 xs ret
339+ return ret
330340infer m v@(Var var@(Qualified mp name)) = do
331341 case mp of
332342 ModulePath [] ->
@@ -351,72 +361,94 @@ infer m v@(Constructor c) = do
351361 modulePath <- checkModulePath `fmap` lift get
352362 case M.lookup (qualify modulePath c) (dataConstructors env) of
353363 Nothing -> throwError $ "Constructor " ++ show c ++ " is undefined"
354− Just (ForAll idents ty) -> replaceVarsWithUnknowns idents ty
364+ Just ty -> return ty
355365infer m (Case val binders) = do
356366 t1 <- infer m val
357367 ret <- fresh
358− cs2 <- checkBinders m t1 ret binders
368+ checkBinders m t1 ret binders
359369 return ret
360370infer m v@(IfThenElse cond th el) = do
361− t1 <- infer m cond
371+ check m cond Boolean
362372 t2 <- infer m th
363373 t3 <- infer m el
364− t1 ~~ Boolean
365374 t2 ~~ t3
366375 return t2
367376infer m v@(TypedValue val ty) = do
368377 kind <- lift $ kindOf ty
369378 guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
370379 ty' <- lift $ replaceAllTypeSynonyms ty
371− cs <- check m val ty'
380+ check m val ty'
372381 return ty'
373382
374383inferUnary :: UnaryOperator -> Type -> Subst Check Type
375−inferUnary Negate val = do
376− val ~~ Number
377− return Number
378−inferUnary Not val = do
379− val ~~ Boolean
380− return Boolean
381−inferUnary BitwiseNot val = do
382− val ~~ Number
383− return Number
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+ ]
384402
385403inferBinary :: BinaryOperator -> Type -> Type -> Subst Check Type
386−inferBinary Add = inferSymBinary Number
387−inferBinary Subtract = inferSymBinary Number
388−inferBinary Multiply = inferSymBinary Number
389−inferBinary Divide = inferSymBinary Number
390−inferBinary Modulus = inferSymBinary Number
391−inferBinary LessThan = inferAsymBinary Number Boolean
392−inferBinary LessThanOrEqualTo = inferAsymBinary Number Boolean
393−inferBinary GreaterThan = inferAsymBinary Number Boolean
394−inferBinary GreaterThanOrEqualTo = inferAsymBinary Number Boolean
395−inferBinary BitwiseAnd = inferSymBinary Number
396−inferBinary BitwiseOr = inferSymBinary Number
397−inferBinary BitwiseXor = inferSymBinary Number
398−inferBinary ShiftLeft = inferSymBinary Number
399−inferBinary ShiftRight = inferSymBinary Number
400−inferBinary ZeroFillShiftRight = inferSymBinary Number
401−inferBinary EqualTo = inferEqBinary
402−inferBinary NotEqualTo = inferEqBinary
403−inferBinary And = inferSymBinary Boolean
404−inferBinary Or = inferSymBinary Boolean
405−inferBinary Concat = inferSymBinary String
406−
407−inferEqBinary :: Type -> Type -> Subst Check Type
408−inferEqBinary left right = do
404+inferBinary op left right | isEqualityTest op = do
409405 left ~~ right
410406 return Boolean
411−
412−inferSymBinary :: Type -> Type -> Type -> Subst Check Type
413−inferSymBinary ty = inferAsymBinary ty ty
414−
415−inferAsymBinary :: Type -> Type -> Type -> Type -> Subst Check Type
416−inferAsymBinary input output left right = do
417− left ~~ input
418− right ~~ input
419− return output
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+ ]
420452
421453inferBinder :: Type -> Binder -> Subst Check (M.Map Ident Type)
422454inferBinder _ NullBinder = return M.empty
@@ -428,23 +460,18 @@ inferBinder val (NullaryBinder ctor) = do
428460 env <- lift getEnv
429461 modulePath <- checkModulePath `fmap` lift get
430462 case M.lookup (qualify modulePath ctor) (dataConstructors env) of
431− Just (ForAll args ret) -> do
432− ret' <- replaceVarsWithUnknowns args ret
433− val ~~ ret'
463+ Just ty -> do
464+ ty `subsumes` val
434465 return M.empty
435466 _ -> throwError $ "Constructor " ++ show ctor ++ " is not defined"
436467inferBinder val b@(UnaryBinder ctor binder) = do
437468 env <- lift getEnv
438469 modulePath <- checkModulePath `fmap` lift get
439470 case M.lookup (qualify modulePath ctor) (dataConstructors env) of
440− Just (ForAll idents f@(Function [_] _)) -> do
471+ Just ty -> do
441472 obj <- fresh
442− (Function [ty] ret) <- replaceVarsWithUnknowns idents f
443− m1 <- inferBinder obj binder
444− val ~~ ret
445− obj ~~ ty
446− return m1
447− Just _ -> throwError $ show ctor ++ " is not a unary constructor"
473+ ty `subsumes` (Function [obj] val)
474+ inferBinder obj binder
448475 _ -> throwError $ "Constructor " ++ show ctor ++ " is not defined"
449476inferBinder val b@(ObjectBinder props) = do
450477 row <- fresh
@@ -564,20 +591,18 @@ checkBlock m mass ret (s:ss) = do
564591 (b2, mass2) <- checkBlock m mass1 ret ss
565592 return (b2, mass2)
566593
567−skolemize :: [String] -> Type -> Subst Check Type
568−skolemize idents ty = do
569− sks <- replicateM (length idents) fresh'
570− let m = M.fromList (zip idents (map Skolem sks))
571− return $ replaceTypeVars m ty
594+skolemize :: String -> Type -> Subst Check Type
595+skolemize ident ty = do
596+ tsk <- Skolem <$> fresh'
597+ rsk <- RSkolem <$> fresh'
598+ return $ replaceRowVars (M.singleton ident rsk) $ replaceTypeVars (M.singleton ident tsk) ty
572599
573600check :: M.Map Ident Type -> Value -> Type -> Subst Check ()
574601check m (NumericLiteral _) Number = return ()
575602check m (StringLiteral _) String = return ()
576603check m (BooleanLiteral _) Boolean = return ()
577−check m (Unary Negate val) Number = check m val Number
578−check m (Unary Not val) Boolean = check m val Boolean
579−check m (Unary BitwiseNot val) Number = check m val Number
580−check m (Binary _ t1 t2) Number = check m t1 Number >> check m t2 Number
604+check m (Unary op val) ty = checkUnary m op val ty
605+check m (Binary op left right) ty = checkBinary m op left right ty
581606check m (ArrayLiteral vals) (Array ty) = forM_ vals (\val -> check m val ty)
582607check m (Indexer index vals) ty = check m index Number >> check m vals (Array ty)
583608check m (Abs args ret) (Function argTys retTy) = do
@@ -590,33 +615,112 @@ check m (App f xs) ret = do
590615check m val (ForAll idents ty) = do
591616 sk <- skolemize idents ty
592617 check m val sk
618+check m v@(Var var@(Qualified mp name)) ty = do
619+ case mp of
620+ ModulePath [] ->
621+ case M.lookup name m of
622+ Just ty1 -> ty1 `subsumes` ty
623+ Nothing -> lookupGlobal
624+ _ -> lookupGlobal
625+ where
626+ lookupGlobal = do
627+ env <- lift getEnv
628+ modulePath <- checkModulePath `fmap` lift get
629+ case M.lookup (qualify modulePath var) (names env) of
630+ Nothing -> throwError $ show var ++ " is undefined"
631+ Just (ty1, _) -> ty1 `subsumes` ty
593632check m val u@(TUnknown _) = do
594− t <- infer m val
595− t ~~ u
633+ ty <- infer m val
634+ ty ~~ u
635+ return ()
636+check m (TypedValue val ty1) ty2 = do
637+ kind <- lift $ kindOf ty1
638+ guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
639+ ty1 `subsumes` ty2
640+ check m val ty1
641+check m (Case val binders) ret = do
642+ t1 <- infer m val
643+ checkBinders m t1 ret binders
644+check m (IfThenElse cond th el) ty = do
645+ check m cond Boolean
646+ check m th ty
647+ check m el ty
648+check m (ObjectLiteral ps) (Object row) = do
649+ lift $ ensureNoDuplicateProperties ps
650+ checkProperties m ps row False
651+check m (ObjectUpdate obj ps) objTy@(Object row) = do
652+ lift $ ensureNoDuplicateProperties ps
653+ check m obj objTy
654+ checkProperties m ps row True
655+check m (Accessor prop val) ty = do
656+ rest <- fresh
657+ check m val (Object (RCons prop ty rest))
658+check m (Block ss) ret = do
659+ (allCodePathsReturn, _) <- checkBlock m M.empty ret ss
660+ guardWith "Block is missing a return statement" allCodePathsReturn
661+check m (Constructor c) ty = do
662+ env <- lift getEnv
663+ modulePath <- checkModulePath `fmap` lift get
664+ case M.lookup (qualify modulePath c) (dataConstructors env) of
665+ Nothing -> throwError $ "Constructor " ++ show c ++ " is undefined"
666+ Just ty1 -> ty1 `subsumes` ty
667+check m val (SaturatedTypeSynonym name args) = do
668+ env <- lift getEnv
669+ modulePath <- checkModulePath `fmap` lift get
670+ case M.lookup (qualify modulePath name) (typeSynonyms env) of
671+ Just (synArgs, body) -> do
672+ let replaced = replaceTypeVars (M.fromList (zip synArgs args)) body
673+ check m val replaced
674+ Nothing -> error "Type synonym was not defined"
596675check _ val ty = throwError $ prettyPrintValue val ++ " does not have type " ++ prettyPrintType ty
597676
677+checkProperties :: M.Map Ident Type -> [(String, Value)] -> Row -> Bool -> Subst Check ()
678+checkProperties m ps row lax = let (ts, r') = rowToList row in go ps ts r' where
679+ go [] [] REmpty = return ()
680+ go [] [] u@(RUnknown _) = u ~~ REmpty
681+ go [] [] (RSkolem _) | lax = return ()
682+ go [] ((p, _): _) _ | lax = return ()
683+ | otherwise = throwError $ prettyPrintValue (ObjectLiteral ps) ++ " does not have property " ++ p
684+ go ((p,_):_) [] REmpty = throwError $ "Property " ++ p ++ " is not present in closed object type " ++ prettyPrintRow row
685+ go ((p,v):ps) [] u@(RUnknown _) = do
686+ ty <- infer m v
687+ rest <- fresh
688+ u ~~ RCons p ty rest
689+ go ps [] rest
690+ go ((p,v):ps) ts r =
691+ case lookup p ts of
692+ Nothing -> do
693+ ty <- infer m v
694+ rest <- fresh
695+ r ~~ RCons p ty rest
696+ go ps ts rest
697+ Just ty -> do
698+ check m v ty
699+ go ps (delete (p, ty) ts) r
700+ go _ _ _ = throwError $ prettyPrintValue (ObjectLiteral ps) ++ " does not have type " ++ prettyPrintType (Object row)
701+
598702checkFunctionApplication :: M.Map Ident Type -> Type -> [Value] -> Type -> Subst Check ()
599703checkFunctionApplication m (Function argTys retTy) args ret = do
600704 guardWith "Incorrect number of function arguments" (length args == length argTys)
601705 zipWithM (check m) args argTys
602706 ret ~~ retTy
603−checkFunctionApplication m (ForAll idents ty) args ret = do
604− replaced <- replaceVarsWithUnknowns idents ty
707+checkFunctionApplication m (ForAll ident ty) args ret = do
708+ replaced <- replaceVarsWithUnknowns [ident] ty
605709 checkFunctionApplication m replaced args ret
710+checkFunctionApplication m u@(TUnknown _) args ret = do
711+ tyArgs <- replicateM (length args) fresh
712+ u ~~ Function tyArgs ret
606713checkFunctionApplication _ fnTy args ret = throwError $ "Cannot apply function of type "
607714 ++ prettyPrintType fnTy
608715 ++ " to arguments " ++ intercalate ", " (map prettyPrintValue args)
609716 ++ ". Expecting value of type " ++ prettyPrintType ret ++ "."
610717
611−{-
612− | Binary BinaryOperator Value Value
613− | ObjectLiteral [(String, Value)]
614− | Accessor String Value
615− | ObjectUpdate Value [(String, Value)]
616− | Var (Qualified Ident)
617− | IfThenElse Value Value Value
618− | Block [Statement]
619− | Constructor (Qualified ProperName)
620− | Case Value [(Binder, Value)]
621− | TypedValue Value PolyType
622−-}
718+subsumes :: Type -> Type -> Subst Check ()
719+subsumes (ForAll ident ty1) ty2 = do
720+ replaced <- replaceVarsWithUnknowns [ident] ty1
721+ replaced `subsumes` ty2
722+subsumes (Function args1 ret1) (Function args2 ret2) = do
723+ zipWithM subsumes args2 args1
724+ ret1 `subsumes` ret2
725+subsumes ty1 ty2 = ty1 ~~ ty2
726+