Visitar URL original
Add attached derive clauses to data and newtype declarations (#4594) · purescript/purescript@cb3c496 · GitHub
Skip to content

Commit cb3c496

Browse files
i-am-the-slimei-am-the-slime
authored
Add attached derive clauses to data and newtype declarations (#4594)
1 parent c4a35b3 commit cb3c496

16 files changed

Lines changed: 279 additions & 40 deletions

‎ci/build.sh‎

Lines changed: 5 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -176,9 +176,11 @@ tar -xzf sdist-test/purescript-*.tar.gz -C sdist-test --strip-components=1
176176
(echo "::endgroup::"; echo "::group::Build and test PureScript") 2>/dev/null
177177

178178
pushd sdist-test
179-
# Haddock -Werror goes here to keep us honest but prevent failing on
180-
# documentation errors in dependencies
181-
$STACK build $STACK_OPTS --haddock-arguments --optghc=-Werror
179+
# --ghc-options -Werror applies only to local packages, catching our own
180+
# haddock doc-comment errors without failing on warnings in dependencies.
181+
# (--haddock-arguments --optghc=-Werror would pass -Werror to all packages
182+
# via haddock, which breaks when the dependency cache is cold.)
183+
$STACK build $STACK_OPTS --ghc-options -Werror
182184

183185
if [ "$do_prerelease" ]
184186
then

‎src/Language/PureScript/CST/Convert.hs‎

Lines changed: 37 additions & 22 deletions
Original file line numberDiff line numberDiff line change
@@ -445,7 +445,7 @@ convertBinder fileName = go
445445

446446
convertDeclaration :: String -> Declaration a -> [AST.Declaration]
447447
convertDeclaration fileName decl = case decl of
448-
DeclData _ (DataHead _ a vars) bd -> do
448+
DeclData _ (DataHead _ a vars) bd deriveClauses -> do
449449
let
450450
ctrs :: SourceToken -> DataCtor b -> [(SourceToken, DataCtor b)] -> [AST.DataConstructorDeclaration]
451451
ctrs st (DataCtor _ name fields) tl
@@ -454,15 +454,17 @@ convertDeclaration fileName decl = case decl of
454454
[] -> []
455455
(st', ctor) : tl' -> ctrs st' ctor tl'
456456
)
457-
pure $ AST.DataDeclaration ann Env.Data (nameValue a) (goTypeVar <$> vars) (maybe [] (\(st, Separated hd tl) -> ctrs st hd tl) bd)
457+
AST.DataDeclaration ann Env.Data (nameValue a) (goTypeVar <$> vars) (maybe [] (\(st, Separated hd tl) -> ctrs st hd tl) bd)
458+
: convertDeriveClauses fileName (nameValue a) deriveClauses
458459
DeclType _ (DataHead _ a vars) _ bd ->
459460
pure $ AST.TypeSynonymDeclaration ann
460461
(nameValue a)
461462
(goTypeVar <$> vars)
462463
(convertType fileName bd)
463-
DeclNewtype _ (DataHead _ a vars) st x ys -> do
464+
DeclNewtype _ (DataHead _ a vars) st x ys deriveClauses -> do
464465
let ctrs = [AST.DataConstructorDeclaration (sourceAnnCommented fileName st (snd $ declRange decl)) (nameValue x) [(headDef (internalError "No constructor name") ctrFields, convertType fileName ys)]]
465-
pure $ AST.DataDeclaration ann Env.Newtype (nameValue a) (goTypeVar <$> vars) ctrs
466+
AST.DataDeclaration ann Env.Newtype (nameValue a) (goTypeVar <$> vars) ctrs
467+
: convertDeriveClauses fileName (nameValue a) deriveClauses
466468
DeclClass _ (ClassHead _ sup name vars fdeps) bd -> do
467469
let
468470
goTyVar (TypeVarKinded (Wrapped _ (Labeled (_, a) _ _) _)) = nameValue a
@@ -553,25 +555,8 @@ convertDeclaration fileName decl = case decl of
553555

554556
mkPartialInstanceName :: Maybe (Name Ident, SourceToken) -> QualifiedName (N.ProperName 'N.ClassName) -> [Type a] -> Either Text.Text N.Ident
555557
mkPartialInstanceName nameSep cls args =
556-
maybe (Left genName) (Right . ident . nameValue . fst) nameSep
558+
maybe (Left (genInstanceName cls (foldMap argName args))) (Right . ident . nameValue . fst) nameSep
557559
where
558-
-- truncate to 25 chars to reduce verbosity
559-
-- of name and still keep it readable
560-
-- name will be used to create a GenIdent
561-
-- in desugaring process
562-
genName :: Text.Text
563-
genName = Text.take 25 (className <> typeArgs)
564-
565-
className :: Text.Text
566-
className
567-
= foldMap (uncurry Text.cons . first toLower)
568-
. Text.uncons
569-
. N.runProperName
570-
$ qualName cls
571-
572-
typeArgs :: Text.Text
573-
typeArgs = foldMap argName args
574-
575560
argName :: Type a -> Text.Text
576561
argName = \case
577562
-- These are only useful to disambiguate between overlapping instances
@@ -619,6 +604,36 @@ convertDeclaration fileName decl = case decl of
619604
else
620605
(fst $ qualRange cls, snd $ typeRange $ last args)
621606

607+
convertDeriveClauses
608+
:: String
609+
-> N.ProperName 'N.TypeName
610+
-> [DeriveClause]
611+
-> [AST.Declaration]
612+
convertDeriveClauses fileName tyName = concatMap go
613+
where
614+
go (DeriveClause _ (Wrapped _ classes _)) = map convertClass (toList classes)
615+
convertClass (DeriveClass cls) =
616+
AST.TypeInstanceDeclaration clsAnn clsAnn chainId 0 (Left genName)
617+
[]
618+
(qualified cls)
619+
[tyCon]
620+
AST.DerivedInstance
621+
where
622+
clsAnn = uncurry (sourceAnnCommented fileName) (qualRange cls)
623+
chainId = mkChainId fileName (Pos.spanStart (fst clsAnn))
624+
tyCon = T.TypeConstructor clsAnn (N.Qualified N.ByNullSourcePos tyName)
625+
genName = genInstanceName cls (N.runProperName tyName)
626+
627+
genInstanceName :: QualifiedName (N.ProperName 'N.ClassName) -> Text.Text -> Text.Text
628+
genInstanceName cls typeArgs = Text.take 25 (className <> typeArgs)
629+
where
630+
className :: Text.Text
631+
className
632+
= foldMap (uncurry Text.cons . first toLower)
633+
. Text.uncons
634+
. N.runProperName
635+
$ qualName cls
636+
622637
convertSignature :: String -> Labeled (Name Ident) (Type a) -> AST.Declaration
623638
convertSignature fileName (Labeled a _ b) = do
624639
let

‎src/Language/PureScript/CST/Flatten.hs‎

Lines changed: 15 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -205,11 +205,12 @@ flattenRole = pure . roleTok
205205

206206
flattenDeclaration :: Declaration a -> DList SourceToken
207207
flattenDeclaration = \case
208-
DeclData _ a b ->
208+
DeclData _ a b drvs ->
209209
flattenDataHead a <>
210-
foldMap (\(t, cs) -> pure t <> flattenSeparated flattenDataCtor cs) b
211-
DeclType _ a b c ->flattenDataHead a <> pure b <> flattenType c
212-
DeclNewtype _ a b c d -> flattenDataHead a <> pure b <> flattenName c <> flattenType d
210+
foldMap (\(t, ctrs) -> pure t <> flattenSeparated flattenDataCtor ctrs) b <>
211+
foldMap flattenDeriveClause drvs
212+
DeclType _ a b c -> flattenDataHead a <> pure b <> flattenType c
213+
DeclNewtype _ a b c d drvs -> flattenDataHead a <> pure b <> flattenName c <> flattenType d <> foldMap flattenDeriveClause drvs
213214
DeclClass _ a b ->
214215
flattenClassHead a <>
215216
foldMap (\(c, d) -> pure c <> foldMap (flattenLabeled flattenName flattenType) d) b
@@ -222,6 +223,16 @@ flattenDeclaration = \case
222223
DeclRole _ a b c d -> pure a <> pure b <> flattenName c <> foldMap flattenRole d
223224
DeclValue _ a -> flattenValueBindingFields a
224225

226+
where
227+
flattenDeriveClass :: DeriveClass -> DList SourceToken
228+
flattenDeriveClass (DeriveClass cls) =
229+
flattenQualifiedName cls
230+
231+
flattenDeriveClause :: DeriveClause -> DList SourceToken
232+
flattenDeriveClause (DeriveClause kw classes) =
233+
pure kw <>
234+
flattenWrapped (flattenSeparated flattenDeriveClass) classes
235+
225236
flattenQualifiedName :: QualifiedName a -> DList SourceToken
226237
flattenQualifiedName = pure . qualTok
227238

‎src/Language/PureScript/CST/Parser.y‎

Lines changed: 9 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -661,10 +661,10 @@ import :: { Import () }
661661
| 'class' properName { ImportClass () $1 (getProperName $2) }
662662

663663
decl :: { Declaration () }
664-
: dataHead { DeclData () $1 Nothing }
665-
| dataHead '=' sep(dataCtor, '|') { DeclData () $1 (Just ($2, $3)) }
664+
: dataHead manyOrEmpty(deriveClause) { DeclData () $1 Nothing $2 }
665+
| dataHead '=' sep(dataCtor, '|') manyOrEmpty(deriveClause) { DeclData () $1 (Just ($2, $3)) $4 }
666666
| typeHead '=' type {% checkNoWildcards $3 *> pure (DeclType () $1 $2 $3) }
667-
| newtypeHead '=' properName typeAtom {% checkNoWildcards $4 *> pure (DeclNewtype () $1 $2 (getProperName $3) $4) }
667+
| newtypeHead '=' properName typeAtom manyOrEmpty(deriveClause) {% checkNoWildcards $4 *> pure (DeclNewtype () $1 $2 (getProperName $3) $4 $5) }
668668
| classHead { either id (\h -> DeclClass () h Nothing) $1 }
669669
| classHead 'where' '\{' manySep(classMember, '\;') '\}' {% either (const (parseError $2)) (\h -> pure $ DeclClass () h (Just ($2, $4))) $1 }
670670
| instHead { DeclInstanceChain () (Separated (Instance $1 Nothing) []) }
@@ -681,6 +681,12 @@ decl :: { Declaration () }
681681
| 'foreign' 'import' 'data' properName '::' type { DeclForeign () $1 $2 (ForeignData $3 (Labeled (getProperName $4) $5 $6)) }
682682
| 'type' 'role' properName many(role) { DeclRole () $1 $2 (getProperName $3) $4 }
683683

684+
deriveClause :: { DeriveClause }
685+
: 'derive' '(' sep(deriveClass, ',') ')' { DeriveClause $1 (Wrapped $2 $3 $4) }
686+
687+
deriveClass :: { DeriveClass }
688+
: qualProperName { DeriveClass (getQualifiedProperName $1) }
689+
684690
dataHead :: { DataHead () }
685691
: 'data' properName manyOrEmpty(typeVarBindingPlain) { DataHead $1 (getProperName $2) $3 }
686692

‎src/Language/PureScript/CST/Positions.hs‎

Lines changed: 9 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -157,14 +157,21 @@ dataMembersRange = \case
157157
DataAll _ a -> (a, a)
158158
DataEnumerated _ (Wrapped a _ b) -> (a, b)
159159

160+
deriveClauseRange :: DeriveClause -> TokenRange
161+
deriveClauseRange (DeriveClause kw classes) = (kw, wrpClose classes)
162+
160163
declRange :: Declaration a -> TokenRange
161164
declRange = \case
162-
DeclData _ hd ctors
165+
DeclData _ hd ctors drvs
166+
| _:_ <- drvs -> (fst start, snd . deriveClauseRange $ last drvs)
163167
| Just (_, cs) <- ctors -> (fst start, snd . dataCtorRange $ sepLast cs)
164168
| otherwise -> start
165169
where start = dataHeadRange hd
166170
DeclType _ a _ b -> (fst $ dataHeadRange a, snd $ typeRange b)
167-
DeclNewtype _ a _ _ b -> (fst $ dataHeadRange a, snd $ typeRange b)
171+
DeclNewtype _ a _ _ b drvs
172+
| _:_ <- drvs -> (fst start, snd . deriveClauseRange $ last drvs)
173+
| otherwise -> start
174+
where start = (fst $ dataHeadRange a, snd $ typeRange b)
168175
DeclClass _ hd body
169176
| Just (_, ts) <- body -> (fst start, snd . typeRange . lblValue $ NE.last ts)
170177
| otherwise -> start

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

Lines changed: 11 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -194,10 +194,19 @@ data DataMembers a
194194
| DataEnumerated a (Delimited (Name (N.ProperName 'N.ConstructorName)))
195195
deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
196196

197+
data DeriveClass = DeriveClass
198+
{ dcClass :: QualifiedName (N.ProperName 'N.ClassName)
199+
} deriving (Show, Eq, Ord, Generic)
200+
201+
data DeriveClause = DeriveClause
202+
{ dclKeyword :: SourceToken
203+
, dclClasses :: Wrapped (Separated DeriveClass)
204+
} deriving (Show, Eq, Ord, Generic)
205+
197206
data Declaration a
198-
= DeclData a (DataHead a) (Maybe (SourceToken, Separated (DataCtor a)))
207+
= DeclData a (DataHead a) (Maybe (SourceToken, Separated (DataCtor a))) [DeriveClause]
199208
| DeclType a (DataHead a) SourceToken (Type a)
200-
| DeclNewtype a (DataHead a) SourceToken (Name (N.ProperName 'N.ConstructorName)) (Type a)
209+
| DeclNewtype a (DataHead a) SourceToken (Name (N.ProperName 'N.ConstructorName)) (Type a) [DeriveClause]
201210
| DeclClass a (ClassHead a) (Maybe (SourceToken, NonEmpty (Labeled (Name Ident) (Type a))))
202211
| DeclInstanceChain a (Separated (Instance a))
203212
| DeclDerive a SourceToken (Maybe SourceToken) (InstanceHead a)

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

Lines changed: 20 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -15,7 +15,7 @@ import Language.PureScript.Environment (DataDeclType(..), NameKind(..))
1515
import Language.PureScript.Errors (MultipleErrors, SimpleErrorMessage(..), errorMessage')
1616
import Language.PureScript.Names (pattern ByNullSourcePos, Ident(..), ModuleName, ProperName(..), ProperNameType(..), Qualified(..), QualifiedBy(..), freshIdent)
1717
import Language.PureScript.PSString (mkString)
18-
import Language.PureScript.Types (SourceType, Type(..), WildcardData(..), replaceAllTypeVars, srcTypeApp, srcTypeConstructor, srcTypeLevelString)
18+
import Language.PureScript.Types (SourceType, Type(..), WildcardData(..), replaceAllTypeVars, srcTypeApp, srcTypeConstructor, srcTypeLevelString, srcTypeVar)
1919
import Language.PureScript.TypeChecker (checkNewtype)
2020

2121
-- | Elaborates deriving instance declarations by code generation.
@@ -46,16 +46,32 @@ deriveInstance
4646
deriveInstance mn ds decl =
4747
case decl of
4848
TypeInstanceDeclaration sa@(ss, _) na ch idx nm deps className tys DerivedInstance -> let
49+
-- Attached `derive (Generic)` / `derive (Newtype)` produces `[T]`.
50+
-- These two classes need the fully-applied type plus a trailing
51+
-- wildcard, so pad the args before falling into the standard handler.
52+
paddedTys = case tys of
53+
[bareTy]
54+
| className == Libs.Generic || className == Libs.Newtype
55+
, Just utc <- unwrapTypeConstructor bareTy
56+
, mn == utcModuleName utc
57+
, null (utcArgs utc)
58+
, Just (DataDeclaration _ _ _ tyVars _) <- find (matchesTyName (utcTyCon utc)) ds ->
59+
let applied = foldl srcTypeApp bareTy (map (srcTypeVar . fst) tyVars)
60+
in [applied, TypeWildcard sa UnnamedWildcard]
61+
_ -> tys
62+
matchesTyName n (DataDeclaration _ _ n' _ _) = n == n'
63+
matchesTyName _ _ = False
64+
4965
binaryWildcardClass :: (Declaration -> [SourceType] -> m ([Declaration], SourceType)) -> m Declaration
50-
binaryWildcardClass f = case tys of
66+
binaryWildcardClass f = case paddedTys of
5167
[ty1, ty2] -> case unwrapTypeConstructor ty1 of
5268
Just UnwrappedTypeConstructor{..} | mn == utcModuleName -> do
5369
checkIsWildcard ss utcTyCon ty2
5470
tyConDecl <- findTypeDecl ss utcTyCon ds
5571
(members, ty2') <- f tyConDecl utcArgs
5672
pure $ TypeInstanceDeclaration sa na ch idx nm deps className [ty1, ty2'] (ExplicitInstance members)
57-
_ -> throwError . errorMessage' ss $ ExpectedTypeConstructor className tys ty1
58-
_ -> throwError . errorMessage' ss $ InvalidDerivedInstance className tys 2
73+
_ -> throwError . errorMessage' ss $ ExpectedTypeConstructor className paddedTys ty1
74+
_ -> throwError . errorMessage' ss $ InvalidDerivedInstance className paddedTys 2
5975

6076
in case className of
6177
Libs.Generic -> binaryWildcardClass (deriveGenericRep ss mn)

‎tests/purs/failing/DeriveClauseCannotDerive.out‎

Lines changed: 14 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,14 @@
1+
Error found:
2+
in module Main
3+
at tests/purs/failing/DeriveClauseCannotDerive.purs:7:11 - 7:18 (line 7, column 11 - line 7, column 18)
4+
5+
Cannot derive a type class instance for
6+
 
7+
 Main.MyClass Foo
8+
 
9+
since instances of this type class are not derivable.
10+
11+
12+
See https://github.com/purescript/documentation/blob/master/errors/CannotDerive.md for more information,
13+
or to contribute content related to this error.
14+

‎tests/purs/failing/DeriveClauseCannotDerive.purs‎

Lines changed: 7 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,7 @@
1+
-- @shouldFailWith CannotDerive
2+
module Main where
3+
4+
class MyClass a
5+
6+
data Foo a = Foo a
7+
derive (MyClass)

‎tests/purs/failing/DeriveClauseEither2.out‎

Lines changed: 24 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,24 @@
1+
Error found:
2+
in module Main
3+
at tests/purs/failing/DeriveClauseEither2.purs:7:11 - 7:13 (line 7, column 11 - line 7, column 13)
4+
5+
Could not match kind
6+
 
7+
 Type -> Type -> Type
8+
 
9+
with kind
10+
 
11+
 Type
12+
 
13+
14+
while checking that type Either2
15+
has kind Type
16+
while inferring the kind of Eq Either2
17+
in type class instance
18+
 
19+
 Data.Eq.Eq Either2
20+
 
21+
22+
See https://github.com/purescript/documentation/blob/master/errors/KindsDoNotUnify.md for more information,
23+
or to contribute content related to this error.
24+

0 commit comments

Comments
 (0)