Skip to content

Commit ccdbcc6

Browse files
paf31paf31
committed
Misc. work on purescript#2567 and the skolem escape check
1 parent 5ff1286 commit ccdbcc6

File tree

5 files changed

+115
-99
lines changed

5 files changed

+115
-99
lines changed

‎examples/failing/2567.purs‎

Lines changed: 5 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,5 @@
1+
-- @shouldFailWith NoInstanceFound
2+
module Main where
3+
4+
foo :: Int
5+
foo = (0 :: Fail "This constraint should be checked" => Int)

‎src/Language/PureScript/AST/Declarations.hs‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -45,7 +45,7 @@ data TypeSearch
4545

4646
-- | A type of error messages
4747
data SimpleErrorMessage
48-
= ModuleNotFound ModuleName
48+
= ModuleNotFound ModuleName
4949
| ErrorParsingFFIModule FilePath (Maybe Bundle.ErrorMessage)
5050
| ErrorParsingModule P.ParseError
5151
| MissingFFIModule ModuleName
@@ -83,7 +83,7 @@ data SimpleErrorMessage
8383
| NameIsUndefined Ident
8484
| UndefinedTypeVariable (ProperName 'TypeName)
8585
| PartiallyAppliedSynonym (Qualified (ProperName 'TypeName))
86-
| EscapedSkolem (Maybe Expr)
86+
| EscapedSkolem Text (Maybe SourceSpan) Type
8787
| TypesDoNotUnify Type Type
8888
| KindsDoNotUnify Kind Kind
8989
| ConstrainedTypeUnified Type Type

‎src/Language/PureScript/Errors.hs‎

Lines changed: 10 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -544,11 +544,16 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalS
544544
paras [ line $ "Type synonym " <> markCode (showQualified runProperName name) <> " is partially applied."
545545
, line "Type synonyms must be applied to all of their type arguments."
546546
]
547-
renderSimpleErrorMessage (EscapedSkolem binding) =
548-
paras $ [ line "A type variable has escaped its scope." ]
549-
<> foldMap (\expr -> [ line "Relevant expression: "
550-
, markCodeBox $ indent $ prettyPrintValue valueDepth expr
551-
]) binding
547+
renderSimpleErrorMessage (EscapedSkolem name Nothing ty) =
548+
paras [ line $ "The type variable " <> markCode name <> " has escaped its scope, appearing in the type"
549+
, markCodeBox $ indent $ typeAsBox ty
550+
]
551+
renderSimpleErrorMessage (EscapedSkolem name (Just srcSpan) ty) =
552+
paras [ line $ "The type variable " <> markCode name <> ", bound at"
553+
, indent $ line $ displaySourceSpan srcSpan
554+
, line "has escaped its scope, appearing in the type"
555+
, markCodeBox $ indent $ typeAsBox ty
556+
]
552557
renderSimpleErrorMessage (TypesDoNotUnify u1 u2)
553558
= let (sorted1, sorted2) = sortRows u1 u2
554559

‎src/Language/PureScript/TypeChecker/Skolems.hs‎

Lines changed: 82 additions & 80 deletions
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,4 @@
1-
-- |
2-
-- Functions relating to skolemization used during typechecking
3-
--
1+
-- | Functions relating to skolemization used during typechecking
42
module Language.PureScript.TypeChecker.Skolems
53
( newSkolemConstant
64
, introduceSkolemScope
@@ -14,115 +12,119 @@ import Prelude.Compat
1412

1513
import Control.Monad.Error.Class (MonadError(..))
1614
import Control.Monad.State.Class (MonadState(..), gets, modify)
17-
15+
import Data.Foldable (traverse_)
1816
import Data.Functor.Identity (Identity(), runIdentity)
19-
import Data.List (nub, (\\))
2017
import Data.Monoid
18+
import Data.Set (Set, fromList, notMember)
2119
import Data.Text (Text)
22-
2320
import Language.PureScript.AST
2421
import Language.PureScript.Crash
2522
import Language.PureScript.Errors
2623
import Language.PureScript.Traversals (defS)
2724
import Language.PureScript.TypeChecker.Monad
2825
import Language.PureScript.Types
2926

30-
-- |
31-
-- Generate a new skolem constant
32-
--
33-
newSkolemConstant :: (MonadState CheckState m) => m Int
27+
-- | Generate a new skolem constant
28+
newSkolemConstant :: MonadState CheckState m => m Int
3429
newSkolemConstant = do
3530
s <- gets checkNextSkolem
3631
modify $ \st -> st { checkNextSkolem = s + 1 }
3732
return s
3833

39-
-- |
40-
-- Introduce skolem scope at every occurence of a ForAll
41-
--
42-
introduceSkolemScope :: (MonadState CheckState m) => Type -> m Type
34+
-- | Introduce skolem scope at every occurence of a ForAll
35+
introduceSkolemScope :: MonadState CheckState m => Type -> m Type
4336
introduceSkolemScope = everywhereOnTypesM go
4437
where
4538
go (ForAll ident ty Nothing) = ForAll ident ty <$> (Just <$> newSkolemScope)
4639
go other = return other
4740

48-
-- |
49-
-- Generate a new skolem scope
50-
--
51-
newSkolemScope :: (MonadState CheckState m) => m SkolemScope
41+
-- | Generate a new skolem scope
42+
newSkolemScope :: MonadState CheckState m => m SkolemScope
5243
newSkolemScope = do
5344
s <- gets checkNextSkolemScope
5445
modify $ \st -> st { checkNextSkolemScope = s + 1 }
5546
return $ SkolemScope s
5647

57-
-- |
58-
-- Skolemize a type variable by replacing its instances with fresh skolem constants
59-
--
48+
-- | Skolemize a type variable by replacing its instances with fresh skolem constants
6049
skolemize :: Text -> Int -> SkolemScope -> Maybe SourceSpan -> Type -> Type
6150
skolemize ident sko scope ss = replaceTypeVars ident (Skolem ident sko scope ss)
6251

63-
-- |
64-
-- This function has one purpose - to skolemize type variables appearing in a
65-
-- DeferredDictionary placeholder. These type variables are somewhat unique since they are the
66-
-- only example of scoped type variables.
67-
--
52+
-- | This function skolemizes type variables appearing in any type signatures or
53+
-- 'DeferredDictionary' placeholders. These type variables are the only places
54+
-- where scoped type variables can appear in expressions.
6855
skolemizeTypesInValue :: Text -> Int -> SkolemScope -> Maybe SourceSpan -> Expr -> Expr
6956
skolemizeTypesInValue ident sko scope ss =
70-
let
71-
(_, f, _, _, _) = everywhereWithContextOnValuesM [] defS onExpr onBinder defS defS
72-
in runIdentity . f
57+
runIdentity . onExpr'
7358
where
74-
onExpr :: [Text] -> Expr -> Identity ([Text], Expr)
75-
onExpr sco (DeferredDictionary c ts)
76-
| ident `notElem` sco = return (sco, DeferredDictionary c (map (skolemize ident sko scope ss) ts))
77-
onExpr sco (TypedValue check val ty)
78-
| ident `notElem` sco = return (sco ++ peelTypeVars ty, TypedValue check val (skolemize ident sko scope ss ty))
79-
onExpr sco other = return (sco, other)
80-
81-
onBinder :: [Text] -> Binder -> Identity ([Text], Binder)
82-
onBinder sco (TypedBinder ty b)
83-
| ident `notElem` sco = return (sco ++ peelTypeVars ty, TypedBinder (skolemize ident sko scope ss ty) b)
84-
onBinder sco other = return (sco, other)
85-
86-
peelTypeVars :: Type -> [Text]
87-
peelTypeVars (ForAll i ty _) = i : peelTypeVars ty
88-
peelTypeVars _ = []
89-
90-
-- |
91-
-- Ensure skolem variables do not escape their scope
59+
onExpr' :: Expr -> Identity Expr
60+
(_, onExpr', _, _, _) = everywhereWithContextOnValuesM [] defS onExpr onBinder defS defS
61+
62+
onExpr :: [Text] -> Expr -> Identity ([Text], Expr)
63+
onExpr sco (DeferredDictionary c ts)
64+
| ident `notElem` sco = return (sco, DeferredDictionary c (map (skolemize ident sko scope ss) ts))
65+
onExpr sco (TypedValue check val ty)
66+
| ident `notElem` sco = return (sco ++ peelTypeVars ty, TypedValue check val (skolemize ident sko scope ss ty))
67+
onExpr sco other = return (sco, other)
68+
69+
onBinder :: [Text] -> Binder -> Identity ([Text], Binder)
70+
onBinder sco (TypedBinder ty b)
71+
| ident `notElem` sco = return (sco ++ peelTypeVars ty, TypedBinder (skolemize ident sko scope ss ty) b)
72+
onBinder sco other = return (sco, other)
73+
74+
peelTypeVars :: Type -> [Text]
75+
peelTypeVars (ForAll i ty _) = i : peelTypeVars ty
76+
peelTypeVars _ = []
77+
78+
-- | Ensure skolem variables do not escape their scope
9279
--
93-
skolemEscapeCheck :: (MonadError MultipleErrors m) => Expr -> m ()
80+
-- Every skolem variable is created when a 'ForAll' type is skolemized.
81+
-- This determines the scope of that skolem variable, which is copied from
82+
-- the 'SkolemScope' field of the 'ForAll' constructor.
83+
--
84+
-- This function traverses the tree top-down, and collects any 'SkolemScope's
85+
-- introduced by 'ForAll's. If a 'Skolem' is encountered whose 'SkolemScope' is
86+
-- not in the current list, then we have found an escaped skolem variable.
87+
skolemEscapeCheck :: MonadError MultipleErrors m => Expr -> m ()
9488
skolemEscapeCheck (TypedValue False _ _) = return ()
95-
skolemEscapeCheck root@TypedValue{} =
96-
-- Every skolem variable is created when a ForAll type is skolemized.
97-
-- This determines the scope of that skolem variable, which is copied from the SkolemScope
98-
-- field of the ForAll constructor.
99-
-- We traverse the tree top-down, and collect any SkolemScopes introduced by ForAlls.
100-
-- If a Skolem is encountered whose SkolemScope is not in the current list, we have found
101-
-- an escaped skolem variable.
102-
let (_, f, _, _, _) = everythingWithContextOnValues [] [] (++) def go def def def
103-
in case f root of
104-
[] -> return ()
105-
((binding, val) : _) -> throwError . singleError $ ErrorMessage [ ErrorInExpression val ] $ EscapedSkolem binding
89+
skolemEscapeCheck expr@TypedValue{} =
90+
traverse_ (throwError . singleError) (toSkolemErrors expr)
10691
where
107-
def s _ = (s, [])
108-
109-
go :: [(SkolemScope, Expr)] -> Expr -> ([(SkolemScope, Expr)], [(Maybe Expr, Expr)])
110-
go scos val@(TypedValue _ _ (ForAll _ _ (Just sco))) = ((sco, val) : scos, [])
111-
go scos val@(TypedValue _ _ ty) = case collectSkolems ty \\ map fst scos of
112-
(sco : _) -> (scos, [(findBindingScope sco, val)])
113-
_ -> (scos, [])
114-
where
115-
collectSkolems :: Type -> [SkolemScope]
116-
collectSkolems = nub . everythingOnTypes (++) collect
92+
toSkolemErrors :: Expr -> [ErrorMessage]
93+
(_, toSkolemErrors, _, _, _) = everythingWithContextOnValues (mempty, Nothing) [] (<>) def go def def def
94+
95+
def s _ = (s, [])
96+
97+
go :: (Set SkolemScope, Maybe SourceSpan)
98+
-> Expr
99+
-> ((Set SkolemScope, Maybe SourceSpan), [ErrorMessage])
100+
go (scopes, _) (PositionedValue ss _ _) = ((scopes, Just ss), [])
101+
go (scopes, ssUsed) val@(TypedValue _ _ ty) =
102+
( (allScopes, ssUsed)
103+
, [ ErrorMessage (maybe id ((:) . PositionedError) ssUsed [ ErrorInExpression val ]) $
104+
EscapedSkolem name ssBound ty
105+
| (name, scope, ssBound) <- collectSkolems ty
106+
, notMember scope allScopes
107+
]
108+
)
117109
where
118-
collect (Skolem _ _ scope _) = [scope]
119-
collect _ = []
120-
go scos _ = (scos, [])
121-
findBindingScope :: SkolemScope -> Maybe Expr
122-
findBindingScope sco =
123-
let (_, f, _, _, _) = everythingOnValues mappend (const mempty) go' (const mempty) (const mempty) (const mempty)
124-
in getFirst $ f root
125-
where
126-
go' val@(TypedValue _ _ (ForAll _ _ (Just sco'))) | sco == sco' = First (Just val)
127-
go' _ = mempty
128-
skolemEscapeCheck _ = internalError "Untyped value passed to skolemEscapeCheck"
110+
-- Any new skolem scopes introduced by universal quantifiers
111+
newScopes :: [SkolemScope]
112+
newScopes = collectScopes ty
113+
114+
-- All scopes, including new scopes
115+
allScopes :: Set SkolemScope
116+
allScopes = fromList newScopes <> scopes
117+
118+
-- Collect any scopes appearing in quantifiers at the top level
119+
collectScopes :: Type -> [SkolemScope]
120+
collectScopes (ForAll _ t (Just sco)) = sco : collectScopes t
121+
collectScopes ForAll{} = internalError "skolemEscapeCheck: No skolem scope"
122+
collectScopes _ = []
123+
124+
-- Collect any skolem variables appearing in a type
125+
collectSkolems :: Type -> [(Text, SkolemScope, Maybe SourceSpan)]
126+
collectSkolems = everythingOnTypes (++) collect where
127+
collect (Skolem name _ scope srcSpan) = [(name, scope, srcSpan)]
128+
collect _ = []
129+
go scos _ = (scos, [])
130+
skolemEscapeCheck _ = internalError "skolemEscapeCheck: untyped value"

‎src/Language/PureScript/TypeChecker/Types.hs‎

Lines changed: 16 additions & 12 deletions
Original file line numberDiff line numberDiff line change
@@ -241,7 +241,7 @@ checkTypedBindingGroupElement mn (ident, (val, ty, checkType)) dict = do
241241
ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty
242242
-- Check the type with the new names in scope
243243
val' <- if checkType
244-
then withScopedTypeVars mn args $ bindNames dict $ TypedValue True <$> check val ty' <*> pure ty'
244+
then withScopedTypeVars mn args $ bindNames dict $ check val ty'
245245
else return (TypedValue False val ty')
246246
return (ident, (val', ty'))
247247

@@ -377,7 +377,9 @@ infer' (Let ds val) = do
377377
infer' (DeferredDictionary className tys) = do
378378
dicts <- getTypeClassDictionaries
379379
hints <- gets checkHints
380-
return $ TypeClassDictionary (Constraint className tys Nothing) dicts hints
380+
return $ TypedValue False
381+
(TypeClassDictionary (Constraint className tys Nothing) dicts hints)
382+
(foldl TypeApp (TypeConstructor (fmap coerceProperName className)) tys)
381383
infer' (TypedValue checkType val ty) = do
382384
Just moduleName <- checkCurrentModule <$> get
383385
(kind, args) <- kindOfWithScopedVars ty
@@ -627,7 +629,7 @@ check' v@(Var var) ty = do
627629
ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty
628630
elaborate <- subsumes repl ty'
629631
return $ TypedValue True (elaborate v) ty'
630-
check' (DeferredDictionary className tys) _ = do
632+
check' (DeferredDictionary className tys) ty = do
631633
{-
632634
-- Here, we replace a placeholder for a superclass dictionary with a regular
633635
-- TypeClassDictionary placeholder. The reason we do this is that it is necessary to have the
@@ -636,18 +638,19 @@ check' (DeferredDictionary className tys) _ = do
636638
-}
637639
dicts <- getTypeClassDictionaries
638640
hints <- gets checkHints
639-
return $ TypeClassDictionary (Constraint className tys Nothing) dicts hints
641+
return $ TypedValue False
642+
(TypeClassDictionary (Constraint className tys Nothing) dicts hints)
643+
ty
640644
check' (TypedValue checkType val ty1) ty2 = do
641-
Just moduleName <- checkCurrentModule <$> get
642-
(kind, args) <- kindOfWithScopedVars ty1
645+
kind <- kindOf ty1
643646
checkTypeKind ty1 kind
644647
ty1' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty1
645648
ty2' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty2
646-
_ <- subsumes ty1' ty2'
649+
elaborate <- subsumes ty1' ty2'
647650
val' <- if checkType
648-
then withScopedTypeVars moduleName args (check val ty2')
649-
else return val
650-
return $ TypedValue checkType val' ty2'
651+
then check val ty1'
652+
else pure val
653+
return $ TypedValue True (TypedValue checkType (elaborate val') ty1') ty2'
651654
check' (Case vals binders) ret = do
652655
(vals', ts) <- instantiateForBinders vals binders
653656
binders' <- checkBinders ts ret binders
@@ -684,8 +687,9 @@ check' v@(Constructor c) ty = do
684687
Nothing -> throwError . errorMessage . UnknownName . fmap DctorName $ c
685688
Just (_, _, ty1, _) -> do
686689
repl <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1
687-
elaborate <- subsumes repl ty
688-
return $ TypedValue True (elaborate v) ty
690+
ty' <- introduceSkolemScope ty
691+
elaborate <- subsumes repl ty'
692+
return $ TypedValue True (elaborate v) ty'
689693
check' (Let ds val) ty = do
690694
(ds', val') <- inferLetBinding [] ds val (`check` ty)
691695
return $ TypedValue True (Let ds' val') ty

0 commit comments

Comments
 (0)