git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
Fix #2332, allow newtype deriving when newtype is not fully applied
ed39cb5Phil Freeman
examples/failing/NewtypeInstance5.pursnew file+8
compare with golang
unifiedsplit
@@ -0,0 +1,8 @@
1+-- @shouldFailWith InvalidNewtypeInstance
2+module Main where
3+
4+import Prelude
5+
6+newtype X a = X a
7+
8+derive newtype instance functorX :: Functor X
examples/failing/NewtypeInstance6.pursnew file+8
@@ -0,0 +1,8 @@
1+-- @shouldFailWith InvalidNewtypeInstance
2+module Main where
3+
4+import Prelude
5+
6+newtype X a b = X (Array b)
7+
8+derive newtype instance functorX :: Functor X
examples/passing/NewtypeInstance.purs+11
@@ -24,7 +24,18 @@ instance singletonArray :: Singleton a (Array a) where
24
24
25derive newtype instance singletonY :: Singleton a (Y a)
25derive newtype instance singletonY :: Singleton a (Y a)
26
26
27+newtype MyArray a = MyArray (Array a)
28+
29+derive newtype instance showMyArray :: Show a => Show (MyArray a)
30+
31+derive newtype instance functorMyArray :: Functor MyArray
32+
33+newtype ProxyArray x a = ProxyArray (Array a)
34+
35+derive newtype instance functorProxyArray :: Functor (ProxyArray x)
36+
27main = do
37main = do
28 logShow (X "test")
38 logShow (X "test")
29 logShow (singleton "test" :: Y String)
39 logShow (singleton "test" :: Y String)
40+ logShow (map show (MyArray [1, 2, 3]))
30 log "Done"
41 log "Done"
src/Language/PureScript/Sugar/TypeClasses/Deriving.hs+23−3
@@ -1,4 +1,5 @@
1{-# LANGUAGE OverloadedStrings #-}
1{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE PatternGuards #-}
2
3
3-- |
4-- |
4-- This module implements the generic deriving elaboration that takes place during desugaring.
5-- This module implements the generic deriving elaboration that takes place during desugaring.
@@ -93,12 +94,31 @@ deriveNewtypeInstance className ds tys tyConNm dargs = do
93 tyCon <- findTypeDecl tyConNm ds
94 tyCon <- findTypeDecl tyConNm ds
94 go tyCon
95 go tyCon
95 where
96 where
96− go (DataDeclaration Newtype _ tyArgNames [(_, [wrapped])]) = do
97+ go (DataDeclaration Newtype _ tyArgNames [(_, [wrapped])])
98+ -- The newtype might not be applied to all type arguments.
99+ -- This is okay as long as the newtype wraps something which ends with
100+ -- sufficiently many type applications to variables.
101+ -- For example, we can derive Functor for
102+ --
103+ -- newtype MyArray a = MyArray (Array a)
104+ --
105+ -- since Array a is a type application which uses the last
106+ -- type argument
107+ | Just wrapped' <- stripRight (takeReverse (length tyArgNames - length dargs) tyArgNames) wrapped =
97− let subst = zipWith (\(name, _) t -> (name, t)) tyArgNames dargs
108+ do let subst = zipWith (\(name, _) t -> (name, t)) tyArgNames dargs
98− return (DeferredDictionary className (init tys ++ [replaceAllTypeVars subst wrapped]))
109+ return (DeferredDictionary className (init tys ++ [replaceAllTypeVars subst wrapped']))
99 go (PositionedDeclaration _ _ d) = go d
110 go (PositionedDeclaration _ _ d) = go d
100 go _ = throwError . errorMessage $ InvalidNewtypeInstance className tys
111 go _ = throwError . errorMessage $ InvalidNewtypeInstance className tys
101
112
113+ takeReverse :: Int -> [a] -> [a]
114+ takeReverse n = take n . reverse
115+
116+ stripRight :: [(String, Maybe kind)] -> Type -> Maybe Type
117+ stripRight [] ty = Just ty
118+ stripRight ((arg, _) : args) (TypeApp t (TypeVar arg'))
119+ | arg == arg' = stripRight args t
120+ stripRight _ _ = Nothing
121+
102dataGeneric :: ModuleName
122dataGeneric :: ModuleName
103dataGeneric = ModuleName [ ProperName "Data", ProperName "Generic" ]
123dataGeneric = ModuleName [ ProperName "Data", ProperName "Generic" ]
104
124