Skip to content

Commit da9b49f

Browse files
garybgaryb
authored
Merge pull request purescript#2326 from garyb/derive-newtype
Add deriving for Data.Newtype
2 parents a84f7f3 + 07e2e9c commit da9b49f

File tree

12 files changed

+126
-15
lines changed

12 files changed

+126
-15
lines changed

‎examples/failing/CannotDeriveNewtypeForData.purs‎

Lines changed: 8 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,8 @@
1+
-- @shouldFailWith CannotDeriveNewtypeForData
2+
module CannotDeriveNewtypeForData where
3+
4+
import Data.Newtype
5+
6+
data Test = Test String
7+
8+
derive instance newtypeTest :: Newtype Test _

‎examples/failing/NonWildcardNewtypeInstance.purs‎

Lines changed: 8 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,8 @@
1+
-- @shouldFailWith NonWildcardNewtypeInstance
2+
module NonWildcardNewtypeInstance where
3+
4+
import Data.Newtype
5+
6+
data Test = Test String
7+
8+
derive instance newtypeTest :: Newtype Test String

‎examples/failing/TypeWildcards3.purs‎

Lines changed: 1 addition & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,4 @@
1-
-- @shouldFailWith ErrorParsingModule
1+
-- @shouldFailWith InvalidInstanceHead
22
module TypeWildcards where
33

44
import Prelude
@@ -7,4 +7,3 @@ data Foo a = Foo
77

88
instance showFoo :: Show (Foo _) where
99
show Foo = "Foo"
10-

‎examples/passing/DeriveNewtype.purs‎

Lines changed: 17 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,17 @@
1+
module Main where
2+
3+
import Control.Monad.Eff.Console (log)
4+
5+
import Data.Newtype
6+
7+
newtype Test = Test String
8+
9+
derive instance newtypeTest :: Newtype Test _
10+
11+
t :: Test
12+
t = wrap "hello"
13+
14+
a :: String
15+
a = unwrap t
16+
17+
main = log "Done"

‎examples/passing/NumberLiterals.purs‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -19,8 +19,8 @@ main = do
1919
test "32.96176575630599" 32.96176575630599
2020
test "38.47735512322269" 38.47735512322269
2121

22-
test "10000000000" 1e10
23-
test "10000000000" 1.0e10
22+
test "10000000000.0" 1e10
23+
test "10000000000.0" 1.0e10
2424
test "0.00001" 1e-5
2525
test "0.00001" 1.0e-5
2626
test "1.5339794352098402e-118" 1.5339794352098402e-118

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

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -123,6 +123,8 @@ data SimpleErrorMessage
123123
| InvalidOperatorInBinder (Qualified (OpName 'ValueOpName)) (Qualified Ident)
124124
| DeprecatedRequirePath
125125
| CannotGeneralizeRecursiveFunction Ident Type
126+
| CannotDeriveNewtypeForData (ProperName 'TypeName)
127+
| NonWildcardNewtypeInstance (ProperName 'TypeName)
126128
deriving (Show)
127129

128130
-- | Error message hints, providing more detailed information about failure.

‎src/Language/PureScript/Errors.hs‎

Lines changed: 10 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -166,6 +166,8 @@ errorCode em = case unwrapErrorMessage em of
166166
InvalidOperatorInBinder{} -> "InvalidOperatorInBinder"
167167
DeprecatedRequirePath{} -> "DeprecatedRequirePath"
168168
CannotGeneralizeRecursiveFunction{} -> "CannotGeneralizeRecursiveFunction"
169+
CannotDeriveNewtypeForData{} -> "CannotDeriveNewtypeForData"
170+
NonWildcardNewtypeInstance{} -> "NonWildcardNewtypeInstance"
169171

170172
-- |
171173
-- A stack trace for an error
@@ -831,6 +833,14 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS
831833
, line "Try adding a type signature."
832834
]
833835

836+
renderSimpleErrorMessage (CannotDeriveNewtypeForData tyName) =
837+
paras [ line $ "Cannot derive an instance of the " ++ markCode "Newtype" ++ " class for non-newtype " ++ markCode (runProperName tyName) ++ "."
838+
]
839+
840+
renderSimpleErrorMessage (NonWildcardNewtypeInstance tyName) =
841+
paras [ line $ "A type wildcard (_) should be used for the inner type when deriving the " ++ markCode "Newtype" ++ " instance for " ++ markCode (runProperName tyName) ++ "."
842+
]
843+
834844
renderHint :: ErrorMessageHint -> Box.Box -> Box.Box
835845
renderHint (ErrorUnifyingTypes t1 t2) detail =
836846
paras [ detail

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

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -209,7 +209,7 @@ parseInstanceDeclaration = do
209209
rfatArrow
210210
return deps
211211
className <- indented *> parseQualified properName
212-
ty <- P.many (indented *> noWildcards parseTypeAtom)
212+
ty <- P.many (indented *> parseTypeAtom)
213213
return $ TypeInstanceDeclaration name (fromMaybe [] deps) className ty
214214

215215
parseTypeInstanceDeclaration :: TokenParser Declaration

‎src/Language/PureScript/Sugar/TypeClasses/Deriving.hs‎

Lines changed: 62 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -22,6 +22,7 @@ import Language.PureScript.Environment
2222
import Language.PureScript.Errors
2323
import Language.PureScript.Names
2424
import Language.PureScript.Types
25+
import Language.PureScript.TypeChecker (checkNewtype)
2526
import qualified Language.PureScript.Constants as C
2627

2728
-- | Elaborates deriving instance declarations by code generation.
@@ -44,14 +45,21 @@ deriveInstance mn ds (TypeInstanceDeclaration nm deps className tys@[ty] Derived
4445
, Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor ty
4546
, mn == fromMaybe mn mn'
4647
= TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveGeneric mn ds tyCon args
47-
| className == Qualified (Just (ModuleName [ ProperName "Data", ProperName "Eq" ])) (ProperName "Eq")
48+
| className == Qualified (Just dataEq) (ProperName "Eq")
4849
, Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor ty
4950
, mn == fromMaybe mn mn'
5051
= TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveEq mn ds tyCon
51-
| className == Qualified (Just (ModuleName [ ProperName "Data", ProperName "Ord" ])) (ProperName "Ord")
52+
| className == Qualified (Just dataOrd) (ProperName "Ord")
5253
, Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor ty
5354
, mn == fromMaybe mn mn'
5455
= TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveOrd mn ds tyCon
56+
deriveInstance mn ds (TypeInstanceDeclaration nm deps className [wrappedTy, unwrappedTy] DerivedInstance)
57+
| className == Qualified (Just dataNewtype) (ProperName "Newtype")
58+
, Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor wrappedTy
59+
, mn == fromMaybe mn mn'
60+
= do
61+
(inst, actualUnwrappedTy) <- deriveNewtype mn ds tyCon unwrappedTy
62+
return $ TypeInstanceDeclaration nm deps className [wrappedTy, actualUnwrappedTy] (ExplicitInstance inst)
5563
deriveInstance _ _ (TypeInstanceDeclaration _ _ className tys DerivedInstance)
5664
= throwError . errorMessage $ CannotDerive className tys
5765
deriveInstance mn ds (TypeInstanceDeclaration nm deps className tys@(_ : _) NewtypeInstance)
@@ -100,6 +108,15 @@ dataMaybe = ModuleName [ ProperName "Data", ProperName "Maybe" ]
100108
typesProxy :: ModuleName
101109
typesProxy = ModuleName [ ProperName "Type", ProperName "Proxy" ]
102110

111+
dataEq :: ModuleName
112+
dataEq = ModuleName [ ProperName "Data", ProperName "Eq" ]
113+
114+
dataOrd :: ModuleName
115+
dataOrd = ModuleName [ ProperName "Data", ProperName "Ord" ]
116+
117+
dataNewtype :: ModuleName
118+
dataNewtype = ModuleName [ ProperName "Data", ProperName "Newtype" ]
119+
103120
deriveGeneric
104121
:: forall m. (MonadError MultipleErrors m, MonadSupply m)
105122
=> ModuleName
@@ -290,7 +307,7 @@ deriveEq mn ds tyConNm = do
290307
preludeConj = App . App (Var (Qualified (Just (ModuleName [ProperName "Data", ProperName "HeytingAlgebra"])) (Ident C.conj)))
291308

292309
preludeEq :: Expr -> Expr -> Expr
293-
preludeEq = App . App (Var (Qualified (Just (ModuleName [ProperName "Data", ProperName "Eq"])) (Ident C.eq)))
310+
preludeEq = App . App (Var (Qualified (Just dataEq) (Ident C.eq)))
294311

295312
addCatch :: [CaseAlternative] -> [CaseAlternative]
296313
addCatch xs
@@ -360,7 +377,7 @@ deriveOrd mn ds tyConNm = do
360377
orderingBinder name = ConstructorBinder (orderingName name) []
361378

362379
ordCompare :: Expr -> Expr -> Expr
363-
ordCompare = App . App (Var (Qualified (Just (ModuleName [ProperName "Data", ProperName "Ord"])) (Ident C.compare)))
380+
ordCompare = App . App (Var (Qualified (Just dataOrd) (Ident C.compare)))
364381

365382
mkCtorClauses :: ((ProperName 'ConstructorName, [Type]), Bool) -> m [CaseAlternative]
366383
mkCtorClauses ((ctorName, tys), isLast) = do
@@ -404,6 +421,47 @@ deriveOrd mn ds tyConNm = do
404421
$ decomposeRec rec
405422
toOrdering l r _ = ordCompare l r
406423

424+
deriveNewtype
425+
:: forall m
426+
. (MonadError MultipleErrors m, MonadSupply m)
427+
=> ModuleName
428+
-> [Declaration]
429+
-> ProperName 'TypeName
430+
-> Type
431+
-> m ([Declaration], Type)
432+
deriveNewtype mn ds tyConNm unwrappedTy = do
433+
checkIsWildcard unwrappedTy
434+
go =<< findTypeDecl tyConNm ds
435+
where
436+
437+
go :: Declaration -> m ([Declaration], Type)
438+
go (DataDeclaration Data name _ _) =
439+
throwError . errorMessage $ CannotDeriveNewtypeForData name
440+
go (DataDeclaration Newtype name _ dctors) = do
441+
checkNewtype name dctors
442+
let (ctorName, [ty]) = head dctors
443+
wrappedIdent <- freshIdent "n"
444+
unwrappedIdent <- freshIdent "a"
445+
let inst =
446+
[ ValueDeclaration (Ident "wrap") Public [] $ Right $
447+
Constructor (Qualified (Just mn) ctorName)
448+
, ValueDeclaration (Ident "unwrap") Public [] $ Right $
449+
lamCase wrappedIdent
450+
[ CaseAlternative
451+
[ConstructorBinder (Qualified (Just mn) ctorName) [VarBinder unwrappedIdent]]
452+
(Right (Var (Qualified Nothing unwrappedIdent)))
453+
]
454+
]
455+
return (inst, ty)
456+
go (PositionedDeclaration _ _ d) = go d
457+
go _ = internalError "deriveNewtype go: expected DataDeclaration"
458+
459+
checkIsWildcard :: Type -> m ()
460+
checkIsWildcard (TypeWildcard _) =
461+
return ()
462+
checkIsWildcard _ =
463+
throwError . errorMessage $ NonWildcardNewtypeInstance tyConNm
464+
407465
findTypeDecl
408466
:: (MonadError MultipleErrors m)
409467
=> ProperName 'TypeName

‎src/Language/PureScript/TypeChecker.hs‎

Lines changed: 10 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -6,6 +6,7 @@
66
module Language.PureScript.TypeChecker
77
( module T
88
, typeCheckModule
9+
, checkNewtype
910
) where
1011

1112
import Prelude.Compat
@@ -318,10 +319,6 @@ typeCheckAll moduleName _ = traverse go
318319
checkType _ = internalError "Invalid type in instance in checkOrphanInstance"
319320
checkOrphanInstance _ _ _ = internalError "Unqualified class name in checkOrphanInstance"
320321

321-
checkNewtype :: ProperName 'TypeName -> [(ProperName 'ConstructorName, [Type])] -> m ()
322-
checkNewtype _ [(_, [_])] = return ()
323-
checkNewtype name _ = throwError . errorMessage $ InvalidNewtype name
324-
325322
-- |
326323
-- This function adds the argument kinds for a type constructor so that they may appear in the externs file,
327324
-- extracted from the kind of the type constructor itself.
@@ -332,6 +329,15 @@ typeCheckAll moduleName _ = traverse go
332329
withKinds ( (s, Nothing):ss) (FunKind k1 k2) = (s, Just k1) : withKinds ss k2
333330
withKinds _ _ = internalError "Invalid arguments to peelKinds"
334331

332+
checkNewtype
333+
:: forall m
334+
. MonadError MultipleErrors m
335+
=> ProperName 'TypeName
336+
-> [(ProperName 'ConstructorName, [Type])]
337+
-> m ()
338+
checkNewtype _ [(_, [_])] = return ()
339+
checkNewtype name _ = throwError . errorMessage $ InvalidNewtype name
340+
335341
-- |
336342
-- Type check an entire module and ensure all types and classes defined within the module that are
337343
-- required by exported members are also exported.

0 commit comments

Comments
 (0)