Skip to content

Don't implement Newtype methods when deriving #3975

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Merged
hdgarrood merged 4 commits into from
Dec 27, 2020
Merged

Don't implement Newtype methods when deriving #3975

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
4 commits
Select commit Hold shift + click to select a range
f7d0245
Don't implement Newtype methods when deriving
fsoikin Dec 27, 2020
748de8e
Debug cruft
fsoikin Dec 27, 2020
d1ad12e
Hash
fsoikin Dec 27, 2020
afd1465
Return type
fsoikin Dec 27, 2020
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
31 changes: 9 additions & 22 deletions src/Language/PureScript/Sugar/TypeClasses/Deriving.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -146,8 +146,8 @@ deriveInstance mn syns kinds _ ds (TypeInstanceDeclaration sa@(ss, _) ch idx nm
[wrappedTy, unwrappedTy]
| Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor wrappedTy
, mn == fromMaybe mn mn'
-> do (inst, actualUnwrappedTy) <- deriveNewtype ss mn syns kinds ds tyCon args unwrappedTy
return $ TypeInstanceDeclaration sa ch idx nm deps className [wrappedTy, actualUnwrappedTy] (ExplicitInstance inst)
-> do actualUnwrappedTy <- deriveNewtype ss syns kinds ds tyCon args unwrappedTy
return $ TypeInstanceDeclaration sa ch idx nm deps className [wrappedTy, actualUnwrappedTy] (ExplicitInstance [])
| otherwise -> throwError . errorMessage' ss $ ExpectedTypeConstructor className tys wrappedTy
_ -> throwError . errorMessage' ss $ InvalidDerivedInstance className tys 2
| className == DataGenericRep.Generic
Expand Down Expand Up @@ -558,39 +558,26 @@ deriveNewtype
:: forall m
. (MonadError MultipleErrors m, MonadSupply m)
=> SourceSpan
-> ModuleName
-> SynonymMap
-> KindMap
-> [Declaration]
-> ProperName 'TypeName
-> [SourceType]
-> SourceType
-> m ([Declaration], SourceType)
deriveNewtype ss mn syns kinds ds tyConNm tyConArgs unwrappedTy = do
-> m SourceType
deriveNewtype ss syns kinds ds tyConNm tyConArgs unwrappedTy = do
checkIsWildcard ss tyConNm unwrappedTy
go =<< findTypeDecl ss tyConNm ds
where
go :: Declaration -> m ([Declaration], SourceType)
go :: Declaration -> m SourceType
go (DataDeclaration (ss', _) Data name _ _) =
throwError . errorMessage' ss' $ CannotDeriveNewtypeForData name
go (DataDeclaration (ss', _) Newtype name args dctors) = do
go (DataDeclaration _ Newtype name args dctors) = do
checkNewtype name dctors
wrappedIdent <- freshIdent "n"
unwrappedIdent <- freshIdent "a"
let (DataConstructorDeclaration _ ctorName [(_, ty)]) = head dctors
let (DataConstructorDeclaration _ _ [(_, ty)]) = head dctors
ty' <- replaceAllTypeSynonymsM syns kinds ty
let inst =
[ ValueDecl (ss', []) (Ident "wrap") Public [] $ unguarded $
Constructor ss' (Qualified (Just mn) ctorName)
, ValueDecl (ss', []) (Ident "unwrap") Public [] $ unguarded $
lamCase ss' wrappedIdent
[ CaseAlternative
[ConstructorBinder ss' (Qualified (Just mn) ctorName) [VarBinder ss' unwrappedIdent]]
(unguarded (Var ss' (Qualified Nothing unwrappedIdent)))
]
]
subst = zipWith ((,) . fst) args tyConArgs
return (inst, replaceAllTypeVars subst ty')
let subst = zipWith ((,) . fst) args tyConArgs
return $ replaceAllTypeVars subst ty'
go _ = internalError "deriveNewtype go: expected DataDeclaration"

findTypeDecl
Expand Down
7 changes: 4 additions & 3 deletions tests/purs/docs/bower_components/purescript-newtype/src/Data/Newtype.purs
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,5 +1,6 @@
module Data.Newtype where

class Newtype t a | t -> a where
wrap :: a -> t
unwrap :: t -> a
import Prim.Coerce (class Coercible)

class Newtype :: Type -> Type -> Constraint
class Coercible t a <= Newtype t a | t -> a
2 changes: 1 addition & 1 deletion tests/purs/passing/GenericsRep.purs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -4,7 +4,7 @@ import Prelude
import Effect (Effect)
import Effect.Console (log, logShow)
import Data.Generic.Rep (class Generic)
import Data.Generic.Rep.Eq (genericEq)
import Data.Eq.Generic (genericEq)

data X a = X a

Expand Down
18 changes: 11 additions & 7 deletions tests/purs/passing/NewtypeClass.purs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -3,16 +3,20 @@ module Main where
import Prelude
import Effect
import Effect.Console
import Safe.Coerce (class Coercible, coerce)

class Newtype t a | t -> a where
wrap :: a -> t
unwrap :: t -> a
class Newtype :: Type -> Type -> Constraint
class Coercible t a <= Newtype t a | t -> a

instance newtypeMultiplicative :: Newtype (Multiplicative a) a where
wrap = Multiplicative
unwrap (Multiplicative a) = a
wrap :: forall t a. Newtype t a => a -> t
wrap = coerce

data Multiplicative a = Multiplicative a
unwrap :: forall t a. Newtype t a => t -> a
unwrap = coerce

instance newtypeMultiplicative :: Newtype (Multiplicative a) a

newtype Multiplicative a = Multiplicative a

instance semiringMultiplicative :: Semiring a => Semigroup (Multiplicative a) where
append (Multiplicative a) (Multiplicative b) = Multiplicative (a * b)
Expand Down
7 changes: 5 additions & 2 deletions tests/purs/passing/RowsInInstanceContext.purs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -3,7 +3,6 @@ module Main where
import Prelude
import Effect (Effect)
import Effect.Console (log)
import Data.Newtype (class Newtype, unwrap)

class TypeEquals a b | a -> b, b -> a where
coerce :: a -> b
Expand All @@ -15,9 +14,13 @@ instance refl :: TypeEquals a a where

newtype RecordNewtype = RecordNewtype { x :: String }

class OldStyleNewtype t a where
wrap :: a -> t
unwrap :: t -> a

instance newtypeRecordNewtype ::
TypeEquals inner { x :: String }
=> Newtype RecordNewtype inner where
=> OldStyleNewtype RecordNewtype inner where
Comment on lines +17 to +23
Copy link
Copy Markdown
Contributor Author

@fsoikin fsoikin Dec 27, 2020 •
edited
Loading

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I'm not sure what this test was testing exactly, but it seems that the Newtype class was used only incidentally, as an example of whatever it is that's being tested. So instead of migrating this to the new Newtype class, I created another one,

Copy link
Copy Markdown
Member

@garyb garyb Dec 27, 2020

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Yeah, I think it is unrelated - it's testing that rows in an instance context are allowed / work correctly.

wrap = RecordNewtype <<< coerce
unwrap (RecordNewtype rec) = coerceBack rec

Expand Down
28 changes: 14 additions & 14 deletions tests/purs/passing/SolvingAppendSymbol.purs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -3,31 +3,31 @@ module Main where
import Prelude
import Effect.Console (log)
import Prim.Symbol (class Append)
import Type.Data.Symbol (SProxy(..), reflectSymbol)
import Type.Data.Symbol (append) as Symbol
import Type.Proxy (Proxy(..))
import Type.Data.Symbol (append, reflectSymbol) as Symbol

sym :: SProxy ""
sym = SProxy
sym :: Proxy ""
sym = Proxy

symA :: SProxy "A"
symA = SProxy
symA :: Proxy "A"
symA = Proxy

symB :: SProxy "B"
symB = SProxy
symB :: Proxy "B"
symB = Proxy

egAB :: SProxy "AB"
egAB :: Proxy "AB"
egAB = Symbol.append symA symB

egBA :: SProxy "BA"
egBA :: Proxy "BA"
egBA = Symbol.append symB symA

egA' :: SProxy "A"
egA' :: Proxy "A"
egA' = Symbol.append sym (Symbol.append symA sym)

main = do
let gotAB = reflectSymbol egAB == "AB"
gotBA = reflectSymbol egBA == "BA"
gotA' = reflectSymbol egA' == "A"
let gotAB = Symbol.reflectSymbol egAB == "AB"
gotBA = Symbol.reflectSymbol egBA == "BA"
gotA' = Symbol.reflectSymbol egA' == "A"
when (not gotAB) $ log "Did not get AB"
when (not gotBA) $ log "Did not get BA"
when (not gotA') $ log "Did not get A"
Expand Down
18 changes: 9 additions & 9 deletions tests/purs/passing/SolvingCompareSymbol.purs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -4,23 +4,23 @@ import Prelude
import Effect.Console (log)
import Prim.Symbol (class Compare)
import Prim.Ordering (kind Ordering, LT, EQ, GT)
import Type.Data.Symbol (SProxy(..))
import Type.Proxy (Proxy(..))
import Type.Data.Symbol (compare) as Symbol
import Type.Data.Ordering (OProxy(..), reflectOrdering)
import Type.Data.Ordering (reflectOrdering)

symA :: SProxy "A"
symA = SProxy
symA :: Proxy "A"
symA = Proxy

symB :: SProxy "B"
symB = SProxy
symB :: Proxy "B"
symB = Proxy

egLT :: OProxy LT
egLT :: Proxy LT
egLT = Symbol.compare symA symB

egEQ :: OProxy EQ
egEQ :: Proxy EQ
egEQ = Symbol.compare symA symA

egGT :: OProxy GT
egGT :: Proxy GT
egGT = Symbol.compare symB symA

main = do
Expand Down
6 changes: 6 additions & 0 deletions tests/purs/publish/basic-example/resolutions.json
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -13,5 +13,11 @@
},
"purescript-newtype": {
"path": "../../../support/bower_components/purescript-newtype"
},
"purescript-safe-coerce": {
"path": "../../../support/bower_components/purescript-safe-coerce"
},
"purescript-unsafe-coerce": {
"path": "../../../support/bower_components/purescript-unsafe-coerce"
}
}
22 changes: 12 additions & 10 deletions tests/support/bower.json
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -12,7 +12,6 @@
"purescript-foldable-traversable": "4.0.0",
"purescript-functions": "4.0.0",
"purescript-gen": "2.0.0",
"purescript-generics-rep": "6.0.0",
"purescript-globals": "4.0.0",
"purescript-identity": "4.0.0",
"purescript-integers": "4.0.0",
Expand All @@ -21,25 +20,28 @@
"purescript-lists": "5.0.0",
"purescript-math": "2.1.1",
"purescript-maybe": "4.0.0",
"purescript-newtype": "3.0.0",
"purescript-newtype": "#debb7bdf5d712fb568eee16fae896fd2bc6087d0",
"purescript-nonempty": "5.0.0",
"purescript-partial": "2.0.0",
"purescript-prelude": "#c932361d008379958f14ca8cc2fe32e06cc2647d",
"purescript-proxy": "3.0.0",
"purescript-prelude": "#d3cdad16a1479403a3f14f94190868ba5e25c657",
"purescript-psci-support": "4.0.0",
"purescript-refs": "4.1.0",
"purescript-safe-coerce": "0.0.2",
"purescript-safe-coerce": "#46b3171f71ca5052de6411e383bef6abe80b3f86",
"purescript-st": "4.0.0",
"purescript-strings": "4.0.0",
"purescript-tailrec": "4.0.0",
"purescript-tuples": "5.0.0",
"purescript-type-equality": "3.0.0",
"purescript-typelevel-prelude": "#52ac4bcf9a38941606b3d928127089bd363ee946",
"purescript-type-equality": "#8be8f46e70074dd3ace313bd15227f26166e9675",
"purescript-typelevel-prelude": "#e1b1c9a73f5407c2b1b197d4776d8939129a2444",
"purescript-unfoldable": "4.0.0",
"purescript-unsafe-coerce": "4.0.0"
"purescript-unsafe-coerce": "#76f1d3494a571b97a07f893a1e766f01f86f46f1"
},
"resolutions": {
"purescript-prelude": "c932361d008379958f14ca8cc2fe32e06cc2647d",
"purescript-typelevel-prelude": "52ac4bcf9a38941606b3d928127089bd363ee946"
"purescript-newtype": "debb7bdf5d712fb568eee16fae896fd2bc6087d0",
"purescript-prelude": "d3cdad16a1479403a3f14f94190868ba5e25c657",
"purescript-safe-coerce": "46b3171f71ca5052de6411e383bef6abe80b3f86",
"purescript-type-equality": "8be8f46e70074dd3ace313bd15227f26166e9675",
"purescript-typelevel-prelude": "e1b1c9a73f5407c2b1b197d4776d8939129a2444",
"purescript-unsafe-coerce": "76f1d3494a571b97a07f893a1e766f01f86f46f1"
}
}