Skip to content

Commit 65df12a

Browse files
garybkritzcreek
garyb
authored and
kritzcreek
committed
Fix various typeclass-related error spans (purescript#3216)
* Ensure MissingClassMember, ExtraneousClassMember have source spans * Ensure ExpectedWildcard has source span
1 parent 80339ff commit 65df12a

5 files changed

Lines changed: 97 additions & 79 deletions

File tree

examples/failing/NonWildcardNewtypeInstance.purs renamed to examples/failing/ExpectedWildcard.purs

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,5 @@
11
-- @shouldFailWith ExpectedWildcard
2-
module NonWildcardNewtypeInstance where
2+
module ExpectedWildcard where
33

44
import Data.Newtype
55

‎examples/failing/ExtraneousClassMember.purs‎

Lines changed: 11 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,11 @@
1+
-- @shouldFailWith ExtraneousClassMember
2+
module Main where
3+
4+
import Prelude
5+
6+
class A a where
7+
a :: a -> String
8+
9+
instance aString :: A String where
10+
a s = s
11+
b x = x

examples/failing/TypeClassInstances.purs renamed to examples/failing/MissingClassMember.purs

File renamed without changes.

‎src/Language/PureScript/Sugar/TypeClasses.hs‎

Lines changed: 4 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -276,11 +276,11 @@ typeInstanceDictionaryDeclaration sa@(ss, _) name mn deps className tys decls =
276276

277277
-- Lookup the type arguments and member types for the type class
278278
TypeClassData{..} <-
279-
maybe (throwError . errorMessage . UnknownName $ fmap TyClassName className) return $
279+
maybe (throwError . errorMessage' ss . UnknownName $ fmap TyClassName className) return $
280280
M.lookup (qualify mn className) m
281281

282282
case map fst typeClassMembers \\ mapMaybe declIdent decls of
283-
member : _ -> throwError . errorMessage $ MissingClassMember member
283+
member : _ -> throwError . errorMessage' ss $ MissingClassMember member
284284
[] -> do
285285
-- Replace the type arguments with the appropriate types in the member types
286286
let memberTypes = map (second (replaceAllTypeVars (zip (map fst typeClassArguments) tys))) typeClassMembers
@@ -307,8 +307,8 @@ typeInstanceDictionaryDeclaration sa@(ss, _) name mn deps className tys decls =
307307
where
308308

309309
memberToValue :: [(Ident, Type)] -> Declaration -> Desugar m Expr
310-
memberToValue tys' (ValueDecl _ ident _ [] [MkUnguarded val]) = do
311-
_ <- maybe (throwError . errorMessage $ ExtraneousClassMember ident className) return $ lookup ident tys'
310+
memberToValue tys' (ValueDecl (ss', _) ident _ [] [MkUnguarded val]) = do
311+
_ <- maybe (throwError . errorMessage' ss' $ ExtraneousClassMember ident className) return $ lookup ident tys'
312312
return val
313313
memberToValue _ _ = internalError "Invalid declaration in type instance definition"
314314

‎src/Language/PureScript/Sugar/TypeClasses/Deriving.hs‎

Lines changed: 81 additions & 74 deletions
Original file line numberDiff line numberDiff line change
@@ -154,7 +154,7 @@ deriveInstance mn syns _ ds (TypeInstanceDeclaration sa@(ss, _) ch idx nm deps c
154154
[wrappedTy, unwrappedTy]
155155
| Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor wrappedTy
156156
, mn == fromMaybe mn mn'
157-
-> do (inst, actualUnwrappedTy) <- deriveNewtype mn syns ds tyCon args unwrappedTy
157+
-> do (inst, actualUnwrappedTy) <- deriveNewtype ss mn syns ds tyCon args unwrappedTy
158158
return $ TypeInstanceDeclaration sa ch idx nm deps className [wrappedTy, actualUnwrappedTy] (ExplicitInstance inst)
159159
| otherwise -> throwError . errorMessage' ss $ ExpectedTypeConstructor className tys wrappedTy
160160
_ -> throwError . errorMessage' ss $ InvalidDerivedInstance className tys 2
@@ -163,7 +163,7 @@ deriveInstance mn syns _ ds (TypeInstanceDeclaration sa@(ss, _) ch idx nm deps c
163163
[actualTy, repTy]
164164
| Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor actualTy
165165
, mn == fromMaybe mn mn'
166-
-> do (inst, inferredRepTy) <- deriveGenericRep mn syns ds tyCon args repTy
166+
-> do (inst, inferredRepTy) <- deriveGenericRep ss mn syns ds tyCon args repTy
167167
return $ TypeInstanceDeclaration sa ch idx nm deps className [actualTy, inferredRepTy] (ExplicitInstance inst)
168168
| otherwise -> throwError . errorMessage' ss $ ExpectedTypeConstructor className tys actualTy
169169
_ -> throwError . errorMessage' ss $ InvalidDerivedInstance className tys 2
@@ -275,38 +275,43 @@ unguarded e = [MkUnguarded e]
275275
deriveGenericRep
276276
:: forall m
277277
. (MonadError MultipleErrors m, MonadSupply m)
278-
=> ModuleName
278+
=> SourceSpan
279+
-> ModuleName
279280
-> SynonymMap
280281
-> [Declaration]
281282
-> ProperName 'TypeName
282283
-> [Type]
283284
-> Type
284285
-> m ([Declaration], Type)
285-
deriveGenericRep mn syns ds tyConNm tyConArgs repTy = do
286-
checkIsWildcard tyConNm repTy
286+
deriveGenericRep ss mn syns ds tyConNm tyConArgs repTy = do
287+
checkIsWildcard ss tyConNm repTy
287288
go =<< findTypeDecl tyConNm ds
288289
where
289290
go :: Declaration -> m ([Declaration], Type)
290-
go (DataDeclaration (ss, _) _ _ args dctors) = do
291+
go (DataDeclaration (ss', _) _ _ args dctors) = do
291292
x <- freshIdent "x"
292293
(reps, to, from) <- unzip3 <$> traverse makeInst dctors
293294
let rep = toRepTy reps
294295
inst | null reps =
295296
-- If there are no cases, spin
296-
[ ValueDecl (ss, []) (Ident "to") Public [] $ unguarded $
297-
lamCase x [ CaseAlternative [NullBinder]
298-
(unguarded (App toName (Var nullSourceSpan (Qualified Nothing x))))
299-
]
300-
, ValueDecl (ss, []) (Ident "from") Public [] $ unguarded $
301-
lamCase x [ CaseAlternative [NullBinder]
302-
(unguarded (App fromName (Var nullSourceSpan (Qualified Nothing x))))
303-
]
297+
[ ValueDecl (ss', []) (Ident "to") Public [] $ unguarded $
298+
lamCase ss' x
299+
[ CaseAlternative
300+
[NullBinder]
301+
(unguarded (App toName (Var ss' (Qualified Nothing x))))
302+
]
303+
, ValueDecl (ss', []) (Ident "from") Public [] $ unguarded $
304+
lamCase ss' x
305+
[ CaseAlternative
306+
[NullBinder]
307+
(unguarded (App fromName (Var ss' (Qualified Nothing x))))
308+
]
304309
]
305310
| otherwise =
306-
[ ValueDecl (ss, []) (Ident "to") Public [] $ unguarded $
307-
lamCase x (zipWith ($) (map underBinder (sumBinders (length dctors))) to)
308-
, ValueDecl (ss, []) (Ident "from") Public [] $ unguarded $
309-
lamCase x (zipWith ($) (map underExpr (sumExprs (length dctors))) from)
311+
[ ValueDecl (ss', []) (Ident "to") Public [] $ unguarded $
312+
lamCase ss' x (zipWith ($) (map underBinder (sumBinders (length dctors))) to)
313+
, ValueDecl (ss', []) (Ident "from") Public [] $ unguarded $
314+
lamCase ss' x (zipWith ($) (map underExpr (sumExprs (length dctors))) from)
310315
]
311316

312317
subst = zipWith ((,) . fst) args tyConArgs
@@ -319,10 +324,10 @@ deriveGenericRep mn syns ds tyConNm tyConArgs repTy = do
319324
select l r n = take (n - 1) (iterate (r .) l) ++ [compN (n - 1) r]
320325

321326
sumBinders :: Int -> [Binder -> Binder]
322-
sumBinders = select (ConstructorBinder nullSourceSpan inl . pure) (ConstructorBinder nullSourceSpan inr . pure)
327+
sumBinders = select (ConstructorBinder ss inl . pure) (ConstructorBinder ss inr . pure)
323328

324329
sumExprs :: Int -> [Expr -> Expr]
325-
sumExprs = select (App (Constructor nullSourceSpan inl)) (App (Constructor nullSourceSpan inr))
330+
sumExprs = select (App (Constructor ss inl)) (App (Constructor ss inr))
326331

327332
compN :: Int -> (a -> a) -> a -> a
328333
compN 0 _ = id
@@ -337,9 +342,9 @@ deriveGenericRep mn syns ds tyConNm tyConArgs repTy = do
337342
return ( TypeApp (TypeApp (TypeConstructor constructor)
338343
(TypeLevelString $ mkString (runProperName ctorName)))
339344
ctorTy
340-
, CaseAlternative [ ConstructorBinder nullSourceSpan constructor [matchProduct] ]
341-
(unguarded (foldl' App (Constructor nullSourceSpan (Qualified (Just mn) ctorName)) ctorArgs))
342-
, CaseAlternative [ ConstructorBinder nullSourceSpan (Qualified (Just mn) ctorName) matchCtor ]
345+
, CaseAlternative [ ConstructorBinder ss constructor [matchProduct] ]
346+
(unguarded (foldl' App (Constructor ss (Qualified (Just mn) ctorName)) ctorArgs))
347+
, CaseAlternative [ ConstructorBinder ss (Qualified (Just mn) ctorName) matchCtor ]
343348
(unguarded (constructor' mkProduct))
344349
)
345350

@@ -351,20 +356,20 @@ deriveGenericRep mn syns ds tyConNm tyConArgs repTy = do
351356
makeProduct args = do
352357
(tys, bs1, es1, bs2, es2) <- unzip5 <$> traverse makeArg args
353358
pure ( foldr1 (\f -> TypeApp (TypeApp (TypeConstructor productName) f)) tys
354-
, foldr1 (\b1 b2 -> ConstructorBinder nullSourceSpan productName [b1, b2]) bs1
359+
, foldr1 (\b1 b2 -> ConstructorBinder ss productName [b1, b2]) bs1
355360
, es1
356361
, bs2
357-
, foldr1 (\e1 -> App (App (Constructor nullSourceSpan productName) e1)) es2
362+
, foldr1 (\e1 -> App (App (Constructor ss productName) e1)) es2
358363
)
359364

360365
makeArg :: Type -> m (Type, Binder, Expr, Binder, Expr)
361366
makeArg arg = do
362367
argName <- freshIdent "arg"
363368
pure ( TypeApp (TypeConstructor argument) arg
364-
, ConstructorBinder nullSourceSpan argument [ VarBinder nullSourceSpan argName ]
365-
, Var nullSourceSpan (Qualified Nothing argName)
366-
, VarBinder nullSourceSpan argName
367-
, argument' (Var nullSourceSpan (Qualified Nothing argName))
369+
, ConstructorBinder ss argument [ VarBinder ss argName ]
370+
, Var ss (Qualified Nothing argName)
371+
, VarBinder ss argName
372+
, argument' (Var ss (Qualified Nothing argName))
368373
)
369374

370375
underBinder :: (Binder -> Binder) -> CaseAlternative -> CaseAlternative
@@ -380,10 +385,10 @@ deriveGenericRep mn syns ds tyConNm tyConArgs repTy = do
380385
toRepTy ctors = foldr1 (\f -> TypeApp (TypeApp sumCtor f)) ctors
381386

382387
toName :: Expr
383-
toName = Var nullSourceSpan (Qualified (Just dataGenericRep) (Ident "to"))
388+
toName = Var ss (Qualified (Just dataGenericRep) (Ident "to"))
384389

385390
fromName :: Expr
386-
fromName = Var nullSourceSpan (Qualified (Just dataGenericRep) (Ident "from"))
391+
fromName = Var ss (Qualified (Just dataGenericRep) (Ident "from"))
387392

388393
noCtors :: Type
389394
noCtors = TypeConstructor (Qualified (Just dataGenericRep) (ProperName "NoConstructors"))
@@ -392,7 +397,7 @@ deriveGenericRep mn syns ds tyConNm tyConArgs repTy = do
392397
noArgs = TypeConstructor (Qualified (Just dataGenericRep) (ProperName "NoArguments"))
393398

394399
noArgs' :: Expr
395-
noArgs' = Constructor nullSourceSpan (Qualified (Just dataGenericRep) (ProperName "NoArguments"))
400+
noArgs' = Constructor ss (Qualified (Just dataGenericRep) (ProperName "NoArguments"))
396401

397402
sumCtor :: Type
398403
sumCtor = TypeConstructor (Qualified (Just dataGenericRep) (ProperName "Sum"))
@@ -410,18 +415,18 @@ deriveGenericRep mn syns ds tyConNm tyConArgs repTy = do
410415
constructor = Qualified (Just dataGenericRep) (ProperName "Constructor")
411416

412417
constructor' :: Expr -> Expr
413-
constructor' = App (Constructor nullSourceSpan constructor)
418+
constructor' = App (Constructor ss constructor)
414419

415420
argument :: Qualified (ProperName ty)
416421
argument = Qualified (Just dataGenericRep) (ProperName "Argument")
417422

418423
argument' :: Expr -> Expr
419-
argument' = App (Constructor nullSourceSpan argument)
424+
argument' = App (Constructor ss argument)
420425

421-
checkIsWildcard :: MonadError MultipleErrors m => ProperName 'TypeName -> Type -> m ()
422-
checkIsWildcard _ (TypeWildcard _) = return ()
423-
checkIsWildcard tyConNm _ =
424-
throwError . errorMessage $ ExpectedWildcard tyConNm
426+
checkIsWildcard :: MonadError MultipleErrors m => SourceSpan -> ProperName 'TypeName -> Type -> m ()
427+
checkIsWildcard _ _ (TypeWildcard _) = return ()
428+
checkIsWildcard ss tyConNm _ =
429+
throwError . errorMessage' ss $ ExpectedWildcard tyConNm
425430

426431
deriveEq
427432
:: forall m
@@ -438,10 +443,10 @@ deriveEq ss mn syns ds tyConNm = do
438443
return [ ValueDecl (ss, []) (Ident C.eq) Public [] (unguarded eqFun) ]
439444
where
440445
mkEqFunction :: Declaration -> m Expr
441-
mkEqFunction (DataDeclaration _ _ _ _ args) = do
446+
mkEqFunction (DataDeclaration (ss', _) _ _ _ args) = do
442447
x <- freshIdent "x"
443448
y <- freshIdent "y"
444-
lamCase2 x y <$> (addCatch <$> mapM mkCtorClause args)
449+
lamCase2 ss' x y <$> (addCatch <$> mapM mkCtorClause args)
445450
mkEqFunction _ = internalError "mkEqFunction: expected DataDeclaration"
446451

447452
preludeConj :: Expr -> Expr -> Expr
@@ -506,10 +511,10 @@ deriveOrd ss mn syns ds tyConNm = do
506511
return [ ValueDecl (ss, []) (Ident C.compare) Public [] (unguarded compareFun) ]
507512
where
508513
mkCompareFunction :: Declaration -> m Expr
509-
mkCompareFunction (DataDeclaration _ _ _ _ args) = do
514+
mkCompareFunction (DataDeclaration (ss', _) _ _ _ args) = do
510515
x <- freshIdent "x"
511516
y <- freshIdent "y"
512-
lamCase2 x y <$> (addCatch . concat <$> mapM mkCtorClauses (splitLast args))
517+
lamCase2 ss' x y <$> (addCatch . concat <$> mapM mkCtorClauses (splitLast args))
513518
mkCompareFunction _ = internalError "mkCompareFunction: expected DataDeclaration"
514519

515520
splitLast :: [a] -> [(a, Bool)]
@@ -595,34 +600,35 @@ deriveOrd1 ss =
595600
deriveNewtype
596601
:: forall m
597602
. (MonadError MultipleErrors m, MonadSupply m)
598-
=> ModuleName
603+
=> SourceSpan
604+
-> ModuleName
599605
-> SynonymMap
600606
-> [Declaration]
601607
-> ProperName 'TypeName
602608
-> [Type]
603609
-> Type
604610
-> m ([Declaration], Type)
605-
deriveNewtype mn syns ds tyConNm tyConArgs unwrappedTy = do
606-
checkIsWildcard tyConNm unwrappedTy
611+
deriveNewtype ss mn syns ds tyConNm tyConArgs unwrappedTy = do
612+
checkIsWildcard ss tyConNm unwrappedTy
607613
go =<< findTypeDecl tyConNm ds
608614
where
609615
go :: Declaration -> m ([Declaration], Type)
610-
go (DataDeclaration (ss, _) Data name _ _) =
611-
throwError . errorMessage' ss $ CannotDeriveNewtypeForData name
612-
go (DataDeclaration (ss, _) Newtype name args dctors) = do
616+
go (DataDeclaration (ss', _) Data name _ _) =
617+
throwError . errorMessage' ss' $ CannotDeriveNewtypeForData name
618+
go (DataDeclaration (ss', _) Newtype name args dctors) = do
613619
checkNewtype name dctors
614620
wrappedIdent <- freshIdent "n"
615621
unwrappedIdent <- freshIdent "a"
616622
let (ctorName, [ty]) = head dctors
617623
ty' <- replaceAllTypeSynonymsM syns ty
618624
let inst =
619-
[ ValueDecl (ss, []) (Ident "wrap") Public [] $ unguarded $
620-
Constructor nullSourceSpan (Qualified (Just mn) ctorName)
621-
, ValueDecl (ss, []) (Ident "unwrap") Public [] $ unguarded $
622-
lamCase wrappedIdent
625+
[ ValueDecl (ss', []) (Ident "wrap") Public [] $ unguarded $
626+
Constructor ss' (Qualified (Just mn) ctorName)
627+
, ValueDecl (ss', []) (Ident "unwrap") Public [] $ unguarded $
628+
lamCase ss' wrappedIdent
623629
[ CaseAlternative
624-
[ConstructorBinder nullSourceSpan (Qualified (Just mn) ctorName) [VarBinder nullSourceSpan unwrappedIdent]]
625-
(unguarded (Var nullSourceSpan (Qualified Nothing unwrappedIdent)))
630+
[ConstructorBinder ss' (Qualified (Just mn) ctorName) [VarBinder ss' unwrappedIdent]]
631+
(unguarded (Var ss' (Qualified Nothing unwrappedIdent)))
626632
]
627633
]
628634
subst = zipWith ((,) . fst) args tyConArgs
@@ -640,20 +646,20 @@ findTypeDecl tyConNm = maybe (throwError . errorMessage $ CannotFindDerivingType
640646
isTypeDecl (DataDeclaration _ _ nm _ _) | nm == tyConNm = True
641647
isTypeDecl _ = False
642648

643-
lam :: Ident -> Expr -> Expr
644-
lam = Abs . VarBinder nullSourceSpan
649+
lam :: SourceSpan -> Ident -> Expr -> Expr
650+
lam ss = Abs . VarBinder ss
645651

646-
lamCase :: Ident -> [CaseAlternative] -> Expr
647-
lamCase s = lam s . Case [mkVar s]
652+
lamCase :: SourceSpan -> Ident -> [CaseAlternative] -> Expr
653+
lamCase ss s = lam ss s . Case [mkVar ss s]
648654

649-
lamCase2 :: Ident -> Ident -> [CaseAlternative] -> Expr
650-
lamCase2 s t = lam s . lam t . Case [mkVar s, mkVar t]
655+
lamCase2 :: SourceSpan -> Ident -> Ident -> [CaseAlternative] -> Expr
656+
lamCase2 ss s t = lam ss s . lam ss t . Case [mkVar ss s, mkVar ss t]
651657

652-
mkVarMn :: Maybe ModuleName -> Ident -> Expr
653-
mkVarMn mn = Var nullSourceSpan . Qualified mn
658+
mkVarMn :: SourceSpan -> Maybe ModuleName -> Ident -> Expr
659+
mkVarMn ss mn = Var ss . Qualified mn
654660

655-
mkVar :: Ident -> Expr
656-
mkVar = mkVarMn Nothing
661+
mkVar :: SourceSpan -> Ident -> Expr
662+
mkVar ss = mkVarMn ss Nothing
657663

658664
isAppliedVar :: Type -> Bool
659665
isAppliedVar (TypeApp (TypeVar _) _) = True
@@ -694,25 +700,25 @@ deriveFunctor ss mn syns ds tyConNm = do
694700
((iTy, _) : _) -> do
695701
f <- freshIdent "f"
696702
m <- freshIdent "m"
697-
lam f . lamCase m <$> mapM (mkCtorClause iTy f) ctors
703+
lam ss' f . lamCase ss' m <$> mapM (mkCtorClause iTy f) ctors
698704
mkMapFunction _ = internalError "mkMapFunction: expected DataDeclaration"
699705

700706
mkCtorClause :: Text -> Ident -> (ProperName 'ConstructorName, [Type]) -> m CaseAlternative
701707
mkCtorClause iTyName f (ctorName, ctorTys) = do
702708
idents <- replicateM (length ctorTys) (freshIdent "v")
703709
ctorTys' <- mapM (replaceAllTypeSynonymsM syns) ctorTys
704710
args <- zipWithM transformArg idents ctorTys'
705-
let ctor = Constructor nullSourceSpan (Qualified (Just mn) ctorName)
711+
let ctor = Constructor ss (Qualified (Just mn) ctorName)
706712
rebuilt = foldl' App ctor args
707-
caseBinder = ConstructorBinder nullSourceSpan (Qualified (Just mn) ctorName) (VarBinder nullSourceSpan <$> idents)
713+
caseBinder = ConstructorBinder ss (Qualified (Just mn) ctorName) (VarBinder ss <$> idents)
708714
return $ CaseAlternative [caseBinder] (unguarded rebuilt)
709715
where
710-
fVar = mkVar f
711-
mapVar = mkVarMn (Just dataFunctor) (Ident C.map)
716+
fVar = mkVar ss f
717+
mapVar = mkVarMn ss (Just dataFunctor) (Ident C.map)
712718

713719
-- TODO: deal with type synonyms, ala https://github.com/purescript/purescript/pull/2516
714720
transformArg :: Ident -> Type -> m Expr
715-
transformArg ident = fmap (foldr App (mkVar ident)) . goType where
721+
transformArg ident = fmap (foldr App (mkVar ss ident)) . goType where
716722

717723
goType :: Type -> m (Maybe Expr)
718724
-- argument matches the index type
@@ -730,10 +736,11 @@ deriveFunctor ss mn syns ds tyConNm = do
730736
return ((lbl,) <$> upd)
731737

732738
buildRecord :: [(Label, Expr)] -> m Expr
733-
buildRecord updates = do arg <- freshIdent "o"
734-
let argVar = mkVar arg
735-
mkAssignment ((Label l), x) = (l, App x (Accessor l argVar))
736-
return (lam arg (ObjectUpdate argVar (mkAssignment <$> updates)))
739+
buildRecord updates = do
740+
arg <- freshIdent "o"
741+
let argVar = mkVar ss arg
742+
mkAssignment ((Label l), x) = (l, App x (Accessor l argVar))
743+
return (lam ss arg (ObjectUpdate argVar (mkAssignment <$> updates)))
737744

738745
-- under a `* -> *`, just assume functor for now
739746
goType (TypeApp _ t) = fmap (App mapVar) <$> goType t

0 commit comments

Comments
 (0)