ebd7c3c · rowtype-yoga/purescript-native

git.iko.soy/rowtype-yoga/purescript-native

Newtype Deriving (#2304)

* Newtype deriving * Syntax changes. Rename SuperclassDictionary to DeferredDictionary * Examples, generalize

commitebd7c3cfb2b7ad1133c05bf5b1fd5a3f266413b4 authorPhil Freeman <paf31@cantab.net> dateThu 15 Sep 2016, 17:42 (10 years ago) parentc993ec2

15 files changed+126−16

compare with golang

unifiedsplit

examples/failing/NewtypeInstance.pursnew file+8

@@ -0,0 +1,8 @@

1+-- @shouldFailWith InvalidNewtypeInstance

2+module Main where

4+import Prelude

6+data X = X

8+derive newtype instance showX :: Show X

examples/failing/NewtypeInstance2.pursnew file+8

@@ -0,0 +1,8 @@

1+-- @shouldFailWith InvalidNewtypeInstance

2+module Main where

4+import Prelude

6+data X a = X a a

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

4+import Prelude

6+class Nullary

8+derive newtype instance nullary :: Nullary

examples/failing/NewtypeInstance4.pursnew file+8

@@ -0,0 +1,8 @@

1+-- @shouldFailWith InvalidNewtypeInstance

2+module Main where

4+import Prelude

6+data X = X | Y

8+derive newtype instance showX :: Show X

examples/passing/NewtypeInstance.pursnew file+30

@@ -0,0 +1,30 @@

1+module Main where

3+import Prelude

4+import Control.Monad.Eff

5+import Control.Monad.Eff.Console

7+newtype X = X String

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

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,10 +375,15 @@ pattern TypeFixityDeclaration fixity name op = FixityDeclaration (Right (TypeFix

374375

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

376377data 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

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

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

385391

386392-- | A traversal for TypeInstanceBody

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

388−traverseTypeInstanceBody _ DerivedInstance = pure DerivedInstance

389394traverseTypeInstanceBody 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+1−1

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

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

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

1717

1818import Prelude hiding (lex)

1919

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

2021import Data.Maybe (fromMaybe)

2122

2223import Control.Applicative

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

192193parseConstraint = Constraint <$> parseQualified properName

193194 <*> P.many (noWildcards parseTypeAtom)

194195 <*> pure Nothing

196+

195197parseInstanceDeclaration :: TokenParser (TypeInstanceBody -> Declaration)

196198parseInstanceDeclaration = do

197199 reserved "instance"

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

216218parseDerivingInstanceDeclaration :: TokenParser Declaration

217219parseDerivingInstanceDeclaration = do

218220 reserved "derive"

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

219222 instanceDecl <- parseInstanceDeclaration

220− return $ instanceDecl DerivedInstance

223+ return $ instanceDecl ty

221224

222225positioned :: TokenParser Declaration -> TokenParser Declaration

223226positioned = withSourceSpan PositionedDeclaration

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

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

6161prettyPrintValue d (Do els) =

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

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

6565prettyPrintValue _ (TypeClassDictionaryAccessor className ident) =

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

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

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

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

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

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

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

335− goExpr pos (SuperClassDictionary cls tys) = do

335+ goExpr pos (DeferredDictionary cls tys) = do

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

337− return (pos, SuperClassDictionary cls tys')

337+ return (pos, DeferredDictionary cls tys')

338338 goExpr pos (TypedValue check v ty) = do

339339 ty' <- goType' pos ty

340340 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

129129--

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

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

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

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

133133-- }

134134--

135135-- and finally as the generated javascript:

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

181181 desugared <- desugarCases members

182182 dictDecl <- typeInstanceDictionaryDeclaration name mn deps className tys desugared

183183 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))])

184188 go (PositionedDeclaration pos com d) = do

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

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

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

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

288292 -- The dictionary itself is a record literal.

289293 let superclasses = superClassDictionaryNames implies `zip`

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

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

291295 | (Constraint superclass suTyArgs _) <- implies

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

293297 ]

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

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

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

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

5656 = 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

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

5864deriveInstance _ _ e = return e

5965

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

6672 return (tyCon, arg : args)

6773 go _ = Nothing

6874

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+

6994dataGeneric :: ModuleName

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

7196

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

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

6161

6262-- |

6363-- 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

6565-- only example of scoped type variables.

6666--

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

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

7171 in runIdentity . f

7272 where

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

74− onExpr sco (SuperClassDictionary c ts)

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

74+ onExpr sco (DeferredDictionary c ts)

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

7676 onExpr sco (TypedValue check val ty)

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

7878 onExpr sco other = return (sco, other)

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

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

311311infer' (Let ds val) = do

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

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

314−infer' (SuperClassDictionary className tys) = do

314+infer' (DeferredDictionary className tys) = do

315315 dicts <- getTypeClassDictionaries

316316 hints <- gets checkHints

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

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

583583 case v' of

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

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

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

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

587587 {-

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

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