ebd7c3c · rowtype-yoga/purescript-native

examples/failing/NewtypeInstance.pursnew file+8

compare with golang

unifiedsplit

@@ -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.pursnew file+8

@@ -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.pursnew file+8

@@ -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.pursnew file+8

@@ -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.pursnew file+30

@@ -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+10−4

@@ -77,6 +77,7 @@ data SimpleErrorMessage

77 | NoInstanceFound Constraint

78 | PossiblyInfiniteInstance (Qualified (ProperName 'ClassName)) [Type]

79 | CannotDerive (Qualified (ProperName 'ClassName)) [Type]

80+ | InvalidNewtypeInstance (Qualified (ProperName 'ClassName)) [Type]

80 | CannotFindDerivingType (ProperName 'TypeName)

81 | CannotFindDerivingType (ProperName 'TypeName)

81 | DuplicateLabel String (Maybe Expr)

82 | DuplicateLabel String (Maybe Expr)

82 | DuplicateValueDeclaration Ident

83 | DuplicateValueDeclaration Ident

@@ -374,10 +375,15 @@ pattern TypeFixityDeclaration fixity name op = FixityDeclaration (Right (TypeFix

374

375

375-- | The members of a type class instance declaration

376-- | The members of a type class instance declaration

376data TypeInstanceBody

377data TypeInstanceBody

377− -- | This is a derived instance

378 = 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.

380 | ExplicitInstance [Declaration]

385 | ExplicitInstance [Declaration]

386+ -- ^ This is a regular (explicit) instance

381 deriving (Show)

387 deriving (Show)

382

388

383mapTypeInstanceBody :: ([Declaration] -> [Declaration]) -> TypeInstanceBody -> TypeInstanceBody

389mapTypeInstanceBody :: ([Declaration] -> [Declaration]) -> TypeInstanceBody -> TypeInstanceBody

@@ -385,8 +391,8 @@ mapTypeInstanceBody f = runIdentity . traverseTypeInstanceBody (Identity . f)

385

391

386-- | A traversal for TypeInstanceBody

392-- | A traversal for TypeInstanceBody

387traverseTypeInstanceBody :: (Applicative f) => ([Declaration] -> f [Declaration]) -> TypeInstanceBody -> f TypeInstanceBody

393traverseTypeInstanceBody :: (Applicative f) => ([Declaration] -> f [Declaration]) -> TypeInstanceBody -> f TypeInstanceBody

388−traverseTypeInstanceBody _ DerivedInstance = pure DerivedInstance

389traverseTypeInstanceBody f (ExplicitInstance ds) = ExplicitInstance <$> f ds

394traverseTypeInstanceBody f (ExplicitInstance ds) = ExplicitInstance <$> f ds

395+traverseTypeInstanceBody _ other = pure other

390

396

391-- |

397-- |

392-- Test if a declaration is a value declaration

398-- Test if a declaration is a value declaration

@@ -570,7 +576,7 @@ data Expr

570 -- |

576 -- |

571 -- A placeholder for a superclass dictionary to be turned into a TypeClassDictionary during typechecking

577 -- A placeholder for a superclass dictionary to be turned into a TypeClassDictionary during typechecking

572 --

578 --

573− | SuperClassDictionary (Qualified (ProperName 'ClassName)) [Type]

579+ | DeferredDictionary (Qualified (ProperName 'ClassName)) [Type]

574 -- |

580 -- |

575 -- A placeholder for an anonymous function argument

581 -- A placeholder for an anonymous function argument

576 --

582 --

src/Language/PureScript/AST/Traversals.hs+1−1

@@ -583,6 +583,6 @@ accumTypes f = everythingOnValues mappend forDecls forValues (const mempty) (con

583 forDecls _ = mempty

584

585 forValues (TypeClassDictionary c _ _) = mconcat (map f (constraintArgs c))

586− forValues (SuperClassDictionary _ tys) = mconcat (map f tys)

586+ forValues (DeferredDictionary _ tys) = mconcat (map f tys)

587 forValues (TypedValue _ _ ty) = f ty

588 forValues _ = mempty

src/Language/PureScript/Errors.hs+10

@@ -120,6 +120,7 @@ errorCode em = case unwrapErrorMessage em of

120 NoInstanceFound{} -> "NoInstanceFound"

121 PossiblyInfiniteInstance{} -> "PossiblyInfiniteInstance"

122 CannotDerive{} -> "CannotDerive"

123+ InvalidNewtypeInstance{} -> "InvalidNewtypeInstance"

123 CannotFindDerivingType{} -> "CannotFindDerivingType"

124 CannotFindDerivingType{} -> "CannotFindDerivingType"

124 DuplicateLabel{} -> "DuplicateLabel"

125 DuplicateLabel{} -> "DuplicateLabel"

125 DuplicateValueDeclaration{} -> "DuplicateValueDeclaration"

126 DuplicateValueDeclaration{} -> "DuplicateValueDeclaration"

@@ -262,6 +263,7 @@ onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse

262 gSimple (OverlappingInstances cl ts insts) = OverlappingInstances cl <$> traverse f ts <*> pure insts

263 gSimple (OverlappingInstances cl ts insts) = OverlappingInstances cl <$> traverse f ts <*> pure insts

263 gSimple (PossiblyInfiniteInstance cl ts) = PossiblyInfiniteInstance cl <$> traverse f ts

264 gSimple (PossiblyInfiniteInstance cl ts) = PossiblyInfiniteInstance cl <$> traverse f ts

264 gSimple (CannotDerive cl ts) = CannotDerive cl <$> traverse f ts

265 gSimple (CannotDerive cl ts) = CannotDerive cl <$> traverse f ts

266+ gSimple (InvalidNewtypeInstance cl ts) = InvalidNewtypeInstance cl <$> traverse f ts

265 gSimple (ExpectedType ty k) = ExpectedType <$> f ty <*> pure k

267 gSimple (ExpectedType ty k) = ExpectedType <$> f ty <*> pure k

266 gSimple (OrphanInstance nm cl ts) = OrphanInstance nm cl <$> traverse f ts

268 gSimple (OrphanInstance nm cl ts) = OrphanInstance nm cl <$> traverse f ts

267 gSimple (WildcardInferredType ty ctx) = WildcardInferredType <$> f ty <*> traverse (sndM f) ctx

269 gSimple (WildcardInferredType ty ctx) = WildcardInferredType <$> f ty <*> traverse (sndM f) ctx

@@ -642,6 +644,14 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS

642 , Box.vcat Box.left (map typeAtomAsBox ts)

644 , Box.vcat Box.left (map typeAtomAsBox ts)

643 ]

645 ]

644 ]

646 ]

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+ ]

645 renderSimpleErrorMessage (CannotFindDerivingType nm) =

655 renderSimpleErrorMessage (CannotFindDerivingType nm) =

646 line $ "Cannot derive a type class instance, because the type declaration for " ++ markCode (runProperName nm) ++ " could not be found."

656 line $ "Cannot derive a type class instance, because the type declaration for " ++ markCode (runProperName nm) ++ " could not be found."

647 renderSimpleErrorMessage (DuplicateLabel l expr) =

657 renderSimpleErrorMessage (DuplicateLabel l expr) =

src/Language/PureScript/Parser/Declarations.hs+4−1

@@ -17,6 +17,7 @@ module Language.PureScript.Parser.Declarations

17

18import Prelude hiding (lex)

19

20+import Data.Functor (($>))

20import Data.Maybe (fromMaybe)

21import Data.Maybe (fromMaybe)

21

22

22import Control.Applicative

23import Control.Applicative

@@ -192,6 +193,7 @@ parseConstraint :: TokenParser Constraint

192parseConstraint = Constraint <$> parseQualified properName

193parseConstraint = Constraint <$> parseQualified properName

193 <*> P.many (noWildcards parseTypeAtom)

194 <*> P.many (noWildcards parseTypeAtom)

194 <*> pure Nothing

195 <*> pure Nothing

196+

195parseInstanceDeclaration :: TokenParser (TypeInstanceBody -> Declaration)

197parseInstanceDeclaration :: TokenParser (TypeInstanceBody -> Declaration)

196parseInstanceDeclaration = do

198parseInstanceDeclaration = do

197 reserved "instance"

199 reserved "instance"

@@ -216,8 +218,9 @@ parseTypeInstanceDeclaration = do

216parseDerivingInstanceDeclaration :: TokenParser Declaration

218parseDerivingInstanceDeclaration :: TokenParser Declaration

217parseDerivingInstanceDeclaration = do

219parseDerivingInstanceDeclaration = do

218 reserved "derive"

220 reserved "derive"

221+ ty <- P.option DerivedInstance (reserved "newtype" $> NewtypeInstance)

219 instanceDecl <- parseInstanceDeclaration

222 instanceDecl <- parseInstanceDeclaration

220− return $ instanceDecl DerivedInstance

223+ return $ instanceDecl ty

221

224

222positioned :: TokenParser Declaration -> TokenParser Declaration

225positioned :: TokenParser Declaration -> TokenParser Declaration

223positioned = withSourceSpan PositionedDeclaration

226positioned = withSourceSpan PositionedDeclaration

src/Language/PureScript/Pretty/Values.hs+1−1

@@ -61,7 +61,7 @@ prettyPrintValue d (Let ds val) =

61prettyPrintValue d (Do els) =

62 text "do " <> vcat left (map (prettyPrintDoNotationElement (d - 1)) els)

63prettyPrintValue _ (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)

65prettyPrintValue _ (TypeClassDictionaryAccessor className ident) =

66 text "#dict-accessor " <> text (runProperName (disqualify className)) <> text "." <> text (showIdent ident) <> text ">"

67prettyPrintValue d (TypedValue _ val _) = prettyPrintValue d val

src/Language/PureScript/Sugar/Operators.hs+2−2

@@ -332,9 +332,9 @@ updateTypes goType = (goDecl, goExpr, goBinder)

332 goExpr pos (TypeClassDictionary (Constraint name tys info) dicts hints) = do

333 tys' <- traverse (goType' pos) tys

334 return (pos, TypeClassDictionary (Constraint name tys' info) dicts hints)

335− goExpr pos (SuperClassDictionary cls tys) = do

335+ goExpr pos (DeferredDictionary cls tys) = do

336 tys' <- traverse (goType' pos) tys

337− return (pos, SuperClassDictionary cls tys')

337+ return (pos, DeferredDictionary cls tys')

338 goExpr pos (TypedValue check v ty) = do

339 ty' <- goType' pos ty

340 return (pos, TypedValue check v ty')

src/Language/PureScript/Sugar/TypeClasses.hs+6−2

@@ -129,7 +129,7 @@ desugarModule _ = internalError "Exports should have been elaborated in name des

129--

130-- subString :: {} -> Sub String

131-- subString _ = { sub: "",

132−-- , "__superclass_Foo_0": \_ -> <SuperClassDictionary Foo String>

132+-- , "__superclass_Foo_0": \_ -> <DeferredDictionary Foo String>

133-- }

134--

135-- and finally as the generated javascript:

@@ -181,6 +181,10 @@ desugarDecl mn exps = go

181 desugared <- desugarCases members

182 dictDecl <- typeInstanceDictionaryDeclaration name mn deps className tys desugared

183 return (expRef name className tys, [d, dictDecl])

184+ go d@(TypeInstanceDeclaration name deps className tys (NewtypeInstanceWithDictionary dict)) = do

185+ let dictTy = foldl TypeApp (TypeConstructor (fmap coerceProperName className)) tys

186+ constrainedTy = quantify (if null deps then dictTy else ConstrainedType deps dictTy)

187+ return (expRef name className tys, [d, ValueDeclaration name Private [] (Right (TypedValue True dict constrainedTy))])

184 go (PositionedDeclaration pos com d) = do

188 go (PositionedDeclaration pos com d) = do

185 (dr, ds) <- rethrowWithPosition pos $ desugarDecl mn exps d

189 (dr, ds) <- rethrowWithPosition pos $ desugarDecl mn exps d

186 return (dr, map (PositionedDeclaration pos com) ds)

190 return (dr, map (PositionedDeclaration pos com) ds)

@@ -287,7 +291,7 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls =

287 -- The type is a record type, but depending on type instance dependencies, may be constrained.

291 -- The type is a record type, but depending on type instance dependencies, may be constrained.

288 -- The dictionary itself is a record literal.

292 -- The dictionary itself is a record literal.

289 let superclasses = superClassDictionaryNames implies `zip`

293 let superclasses = superClassDictionaryNames implies `zip`

290− [ Abs (Left (Ident C.__unused)) (SuperClassDictionary superclass tyArgs)

294+ [ Abs (Left (Ident C.__unused)) (DeferredDictionary superclass tyArgs)

291 | (Constraint superclass suTyArgs _) <- implies

295 | (Constraint superclass suTyArgs _) <- implies

292 , let tyArgs = map (replaceAllTypeVars (zip (map fst args) tys)) suTyArgs

296 , let tyArgs = map (replaceAllTypeVars (zip (map fst args) tys)) suTyArgs

293 ]

297 ]

src/Language/PureScript/Sugar/TypeClasses/Deriving.hs+25

@@ -54,6 +54,12 @@ deriveInstance mn ds (TypeInstanceDeclaration nm deps className tys@[ty] Derived

54 = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveOrd mn ds tyCon

55deriveInstance _ _ (TypeInstanceDeclaration _ _ className tys DerivedInstance)

56 = throwError . errorMessage $ CannotDerive className tys

57+deriveInstance mn ds (TypeInstanceDeclaration nm deps className tys@(_ : _) NewtypeInstance)

58+ | Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor (last tys)

59+ , mn == fromMaybe mn mn'

60+ = TypeInstanceDeclaration nm deps className tys . NewtypeInstanceWithDictionary <$> deriveNewtypeInstance className ds tys tyCon args

61+deriveInstance _ _ (TypeInstanceDeclaration _ _ className tys NewtypeInstance)

62+ = throwError . errorMessage $ InvalidNewtypeInstance className tys

57deriveInstance mn ds (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> deriveInstance mn ds d

63deriveInstance mn ds (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> deriveInstance mn ds d

58deriveInstance _ _ e = return e

64deriveInstance _ _ e = return e

59

65

@@ -66,6 +72,25 @@ unwrapTypeConstructor = fmap (second reverse) . go

66 return (tyCon, arg : args)

72 return (tyCon, arg : args)

67 go _ = Nothing

73 go _ = Nothing

68

74

75+deriveNewtypeInstance

76+ :: forall m

77+ . MonadError MultipleErrors m

78+ => Qualified (ProperName 'ClassName)

79+ -> [Declaration]

80+ -> [Type]

81+ -> ProperName 'TypeName

82+ -> [Type]

83+ -> m Expr

84+deriveNewtypeInstance className ds tys tyConNm dargs = do

85+ tyCon <- findTypeDecl tyConNm ds

86+ go tyCon

87+ where

88+ go (DataDeclaration Newtype _ tyArgNames [(_, [wrapped])]) = do

89+ let subst = zipWith (\(name, _) t -> (name, t)) tyArgNames dargs

90+ return (DeferredDictionary className (init tys ++ [replaceAllTypeVars subst wrapped]))

91+ go (PositionedDeclaration _ _ d) = go d

92+ go _ = throwError . errorMessage $ InvalidNewtypeInstance className tys

93+

69dataGeneric :: ModuleName

94dataGeneric :: ModuleName

70dataGeneric = ModuleName [ ProperName "Data", ProperName "Generic" ]

95dataGeneric = ModuleName [ ProperName "Data", ProperName "Generic" ]

71

96

src/Language/PureScript/TypeChecker/Skolems.hs+3−3

@@ -61,7 +61,7 @@ skolemize ident sko scope ss = replaceTypeVars ident (Skolem ident sko scope ss)

61

62-- |

63-- This function has one purpose - to skolemize type variables appearing in a

64−-- SuperClassDictionary placeholder. These type variables are somewhat unique since they are the

64+-- DeferredDictionary placeholder. These type variables are somewhat unique since they are the

65-- only example of scoped type variables.

66--

67skolemizeTypesInValue :: String -> Int -> SkolemScope -> Maybe SourceSpan -> Expr -> Expr

@@ -71,8 +71,8 @@ skolemizeTypesInValue ident sko scope ss =

71 in runIdentity . f

72 where

73 onExpr :: [String] -> Expr -> Identity ([String], Expr)

74− onExpr sco (SuperClassDictionary c ts)

74+ onExpr sco (DeferredDictionary c ts)

75− | ident `notElem` sco = return (sco, SuperClassDictionary c (map (skolemize ident sko scope ss) ts))

75+ | ident `notElem` sco = return (sco, DeferredDictionary c (map (skolemize ident sko scope ss) ts))

76 onExpr sco (TypedValue check val ty)

77 | ident `notElem` sco = return (sco ++ peelTypeVars ty, TypedValue check val (skolemize ident sko scope ss ty))

78 onExpr sco other = return (sco, other)

src/Language/PureScript/TypeChecker/Types.hs+2−2

@@ -311,7 +311,7 @@ infer' (IfThenElse cond th el) = do

311infer' (Let ds val) = do

312 (ds', val'@(TypedValue _ _ valTy)) <- inferLetBinding [] ds val infer

313 return $ TypedValue True (Let ds' val') valTy

314−infer' (SuperClassDictionary className tys) = do

314+infer' (DeferredDictionary className tys) = do

315 dicts <- getTypeClassDictionaries

316 hints <- gets checkHints

317 return $ TypeClassDictionary (Constraint className tys Nothing) dicts hints

@@ -583,7 +583,7 @@ check' v@(Var var) ty = do

583 case v' of

584 Nothing -> internalError "check: unable to check the subsumes relation."

585 Just v'' -> return $ TypedValue True v'' ty'

586−check' (SuperClassDictionary className tys) _ = do

586+check' (DeferredDictionary className tys) _ = do

587 {-

588 -- Here, we replace a placeholder for a superclass dictionary with a regular

589 -- TypeClassDictionary placeholder. The reason we do this is that it is necessary to have the