Skip to content

Navigation Menu

Sign in
Appearance settings

Search code, repositories, users, issues, pull requests...

Provide feedback

We read every piece of feedback, and take your input very seriously.

Saved searches

Use saved searches to filter your results more quickly
Appearance settings

Commit cb3c496

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

16 files changed

+279-40Lines changed: 279 additions & 40 deletions
Expand file treeCollapse file tree
Open diff view settings
Collapse file

‎ci/build.sh‎

Copy file name to clipboardExpand all lines: ci/build.sh
+5-3Lines 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
Collapse file

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

Copy file name to clipboardExpand all lines: src/Language/PureScript/CST/Convert.hs
+37-22Lines 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
Collapse file

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

Copy file name to clipboardExpand all lines: src/Language/PureScript/CST/Flatten.hs
+15-4Lines 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

Collapse file

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

Copy file name to clipboardExpand all lines: src/Language/PureScript/CST/Parser.y
+9-3Lines 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

Collapse file

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

Copy file name to clipboardExpand all lines: src/Language/PureScript/CST/Positions.hs
+9-2Lines 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
Collapse file

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

Copy file name to clipboardExpand all lines: src/Language/PureScript/CST/Types.hs
+11-2Lines 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)
Collapse file

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

Copy file name to clipboardExpand all lines: src/Language/PureScript/Sugar/TypeClasses/Deriving.hs
+20-4Lines 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)
Collapse file

‎tests/purs/failing/DeriveClauseCannotDerive.out‎

Copy file name to clipboard
+14Lines 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+
Collapse file

‎tests/purs/failing/DeriveClauseCannotDerive.purs‎

Copy file name to clipboard
+7Lines 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)
Collapse file

‎tests/purs/failing/DeriveClauseEither2.out‎

Copy file name to clipboard
+24Lines 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 (0)
Morty Proxy This is a proxified and sanitized view of the page, visit original site.