Skip to content

Commit ebd7c3c

Browse files
paf31paf31
authored
Newtype Deriving (purescript#2304)
* Newtype deriving * Syntax changes. Rename SuperclassDictionary to DeferredDictionary * Examples, generalize
1 parent c993ec2 commit ebd7c3c

15 files changed

Lines changed: 126 additions & 16 deletions

File tree

‎examples/failing/NewtypeInstance.purs‎

Lines changed: 8 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,8 @@
1+
-- @shouldFailWith InvalidNewtypeInstance
2+
module Main where
3+
4+
import Prelude
5+
6+
data X = X
7+
8+
derive newtype instance showX :: Show X

‎examples/failing/NewtypeInstance2.purs‎

Lines changed: 8 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,8 @@
1+
-- @shouldFailWith InvalidNewtypeInstance
2+
module Main where
3+
4+
import Prelude
5+
6+
data X a = X a a
7+
8+
derive newtype instance showX :: Show a => Show (X a)

‎examples/failing/NewtypeInstance3.purs‎

Lines changed: 8 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,8 @@
1+
-- @shouldFailWith InvalidNewtypeInstance
2+
module Main where
3+
4+
import Prelude
5+
6+
class Nullary
7+
8+
derive newtype instance nullary :: Nullary

‎examples/failing/NewtypeInstance4.purs‎

Lines changed: 8 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,8 @@
1+
-- @shouldFailWith InvalidNewtypeInstance
2+
module Main where
3+
4+
import Prelude
5+
6+
data X = X | Y
7+
8+
derive newtype instance showX :: Show X

‎examples/passing/NewtypeInstance.purs‎

Lines changed: 30 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,30 @@
1+
module Main where
2+
3+
import Prelude
4+
import Control.Monad.Eff
5+
import Control.Monad.Eff.Console
6+
7+
newtype X = X String
8+
9+
derive newtype instance showX :: Show X
10+
11+
derive newtype instance eqX :: Eq X
12+
13+
derive newtype instance ordX :: Ord X
14+
15+
newtype Y a = Y (Array a)
16+
17+
derive newtype instance showY :: Show (Y String)
18+
19+
class Singleton a b where
20+
singleton :: a -> b
21+
22+
instance singletonArray :: Singleton a (Array a) where
23+
singleton x = [x]
24+
25+
derive newtype instance singletonY :: Singleton a (Y a)
26+
27+
main = do
28+
logShow (X "test")
29+
logShow (singleton "test" :: Y String)
30+
log "Done"

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

Lines changed: 10 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -77,6 +77,7 @@ data SimpleErrorMessage
7777
| NoInstanceFound Constraint
7878
| PossiblyInfiniteInstance (Qualified (ProperName 'ClassName)) [Type]
7979
| CannotDerive (Qualified (ProperName 'ClassName)) [Type]
80+
| InvalidNewtypeInstance (Qualified (ProperName 'ClassName)) [Type]
8081
| CannotFindDerivingType (ProperName 'TypeName)
8182
| DuplicateLabel String (Maybe Expr)
8283
| DuplicateValueDeclaration Ident
@@ -374,19 +375,24 @@ pattern TypeFixityDeclaration fixity name op = FixityDeclaration (Right (TypeFix
374375

375376
-- | The members of a type class instance declaration
376377
data TypeInstanceBody
377-
-- | This is a derived instance
378378
= DerivedInstance
379-
-- | This is a regular (explicit) instance
379+
-- ^ This is a derived instance
380+
| NewtypeInstance
381+
-- ^ This is an instance derived from a newtype
382+
| NewtypeInstanceWithDictionary Expr
383+
-- ^ This is an instance derived from a newtype, desugared to include a
384+
-- dictionary for the type under the newtype.
380385
| ExplicitInstance [Declaration]
386+
-- ^ This is a regular (explicit) instance
381387
deriving (Show)
382388

383389
mapTypeInstanceBody :: ([Declaration] -> [Declaration]) -> TypeInstanceBody -> TypeInstanceBody
384390
mapTypeInstanceBody f = runIdentity . traverseTypeInstanceBody (Identity . f)
385391

386392
-- | A traversal for TypeInstanceBody
387393
traverseTypeInstanceBody :: (Applicative f) => ([Declaration] -> f [Declaration]) -> TypeInstanceBody -> f TypeInstanceBody
388-
traverseTypeInstanceBody _ DerivedInstance = pure DerivedInstance
389394
traverseTypeInstanceBody f (ExplicitInstance ds) = ExplicitInstance <$> f ds
395+
traverseTypeInstanceBody _ other = pure other
390396

391397
-- |
392398
-- Test if a declaration is a value declaration
@@ -570,7 +576,7 @@ data Expr
570576
-- |
571577
-- A placeholder for a superclass dictionary to be turned into a TypeClassDictionary during typechecking
572578
--
573-
| SuperClassDictionary (Qualified (ProperName 'ClassName)) [Type]
579+
| DeferredDictionary (Qualified (ProperName 'ClassName)) [Type]
574580
-- |
575581
-- A placeholder for an anonymous function argument
576582
--

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

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -583,6 +583,6 @@ accumTypes f = everythingOnValues mappend forDecls forValues (const mempty) (con
583583
forDecls _ = mempty
584584

585585
forValues (TypeClassDictionary c _ _) = mconcat (map f (constraintArgs c))
586-
forValues (SuperClassDictionary _ tys) = mconcat (map f tys)
586+
forValues (DeferredDictionary _ tys) = mconcat (map f tys)
587587
forValues (TypedValue _ _ ty) = f ty
588588
forValues _ = mempty

‎src/Language/PureScript/Errors.hs‎

Lines changed: 10 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -120,6 +120,7 @@ errorCode em = case unwrapErrorMessage em of
120120
NoInstanceFound{} -> "NoInstanceFound"
121121
PossiblyInfiniteInstance{} -> "PossiblyInfiniteInstance"
122122
CannotDerive{} -> "CannotDerive"
123+
InvalidNewtypeInstance{} -> "InvalidNewtypeInstance"
123124
CannotFindDerivingType{} -> "CannotFindDerivingType"
124125
DuplicateLabel{} -> "DuplicateLabel"
125126
DuplicateValueDeclaration{} -> "DuplicateValueDeclaration"
@@ -262,6 +263,7 @@ onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse
262263
gSimple (OverlappingInstances cl ts insts) = OverlappingInstances cl <$> traverse f ts <*> pure insts
263264
gSimple (PossiblyInfiniteInstance cl ts) = PossiblyInfiniteInstance cl <$> traverse f ts
264265
gSimple (CannotDerive cl ts) = CannotDerive cl <$> traverse f ts
266+
gSimple (InvalidNewtypeInstance cl ts) = InvalidNewtypeInstance cl <$> traverse f ts
265267
gSimple (ExpectedType ty k) = ExpectedType <$> f ty <*> pure k
266268
gSimple (OrphanInstance nm cl ts) = OrphanInstance nm cl <$> traverse f ts
267269
gSimple (WildcardInferredType ty ctx) = WildcardInferredType <$> f ty <*> traverse (sndM f) ctx
@@ -642,6 +644,14 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS
642644
, Box.vcat Box.left (map typeAtomAsBox ts)
643645
]
644646
]
647+
renderSimpleErrorMessage (InvalidNewtypeInstance nm ts) =
648+
paras [ line "Cannot derive newtype instance for"
649+
, markCodeBox $ indent $ Box.hsep 1 Box.left
650+
[ line (showQualified runProperName nm)
651+
, Box.vcat Box.left (map typeAtomAsBox ts)
652+
]
653+
, line "Make sure this is a newtype."
654+
]
645655
renderSimpleErrorMessage (CannotFindDerivingType nm) =
646656
line $ "Cannot derive a type class instance, because the type declaration for " ++ markCode (runProperName nm) ++ " could not be found."
647657
renderSimpleErrorMessage (DuplicateLabel l expr) =

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

Lines changed: 4 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -17,6 +17,7 @@ module Language.PureScript.Parser.Declarations
1717

1818
import Prelude hiding (lex)
1919

20+
import Data.Functor (($>))
2021
import Data.Maybe (fromMaybe)
2122

2223
import Control.Applicative
@@ -192,6 +193,7 @@ parseConstraint :: TokenParser Constraint
192193
parseConstraint = Constraint <$> parseQualified properName
193194
<*> P.many (noWildcards parseTypeAtom)
194195
<*> pure Nothing
196+
195197
parseInstanceDeclaration :: TokenParser (TypeInstanceBody -> Declaration)
196198
parseInstanceDeclaration = do
197199
reserved "instance"
@@ -216,8 +218,9 @@ parseTypeInstanceDeclaration = do
216218
parseDerivingInstanceDeclaration :: TokenParser Declaration
217219
parseDerivingInstanceDeclaration = do
218220
reserved "derive"
221+
ty <- P.option DerivedInstance (reserved "newtype" $> NewtypeInstance)
219222
instanceDecl <- parseInstanceDeclaration
220-
return $ instanceDecl DerivedInstance
223+
return $ instanceDecl ty
221224

222225
positioned :: TokenParser Declaration -> TokenParser Declaration
223226
positioned = withSourceSpan PositionedDeclaration

‎src/Language/PureScript/Pretty/Values.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -61,7 +61,7 @@ prettyPrintValue d (Let ds val) =
6161
prettyPrintValue d (Do els) =
6262
text "do " <> vcat left (map (prettyPrintDoNotationElement (d - 1)) els)
6363
prettyPrintValue _ (TypeClassDictionary (Constraint name tys _) _ _) = foldl1 beforeWithSpace $ text ("#dict " ++ runProperName (disqualify name)) : map typeAtomAsBox tys
64-
prettyPrintValue _ (SuperClassDictionary name _) = text $ "#dict " ++ runProperName (disqualify name)
64+
prettyPrintValue _ (DeferredDictionary name _) = text $ "#dict " ++ runProperName (disqualify name)
6565
prettyPrintValue _ (TypeClassDictionaryAccessor className ident) =
6666
text "#dict-accessor " <> text (runProperName (disqualify className)) <> text "." <> text (showIdent ident) <> text ">"
6767
prettyPrintValue d (TypedValue _ val _) = prettyPrintValue d val

0 commit comments

Comments
 (0)