Skip to content

Commit 4b23171

Browse files
garybgaryb
authored
Eq1 / Ord1 deriving again (purescript#3207)
* Allow `Eq1` to be used when deriving `Eq` * Derive `Eq1` (as `eq1 = eq`) * Allow `Ord1` to be used when deriving `Ord` * Derive `Ord1` (as `compare1 = compare`) * Remove unnecessary constraints * Update DerivingFunctor test for Eq1 deriving
1 parent 683f6da commit 4b23171

7 files changed

Lines changed: 115 additions & 14 deletions

File tree

‎examples/passing/DerivingFunctor.purs‎

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,7 @@
11
module Main where
22

33
import Prelude
4+
import Data.Eq (class Eq1)
45
import Control.Monad.Eff.Console (log)
56
import Test.Assert
67

@@ -13,7 +14,7 @@ data M f a
1314
| M3 { foo :: Int, bar :: a, baz :: f a }
1415
| M4 (MyRecord a)
1516

16-
derive instance eqM :: (Eq (f a), Eq a) => Eq (M f a)
17+
derive instance eqM :: (Eq1 f, Eq a) => Eq (M f a)
1718

1819
derive instance functorM :: Functor f => Functor (M f)
1920

@@ -24,5 +25,5 @@ main = do
2425
assert $ map show (M1 0 :: MA Int) == M1 0
2526
assert $ map show (M2 [0, 1] :: MA Int) == M2 ["0", "1"]
2627
assert $ map show (M3 {foo: 0, bar: 1, baz: [2, 3]} :: MA Int) == M3 {foo: 0, bar: "1", baz: ["2", "3"]}
27-
assert $ map show (M4 { myField: 42 }) == M4 { myField: "42" } :: MA String
28+
assert $ map show (M4 { myField: 42 }) == M4 { myField: "42" } :: MA String
2829
log "Done"

‎examples/passing/Eq1Deriving.purs‎

Lines changed: 12 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,12 @@
1+
module Main where
2+
3+
import Prelude
4+
import Data.Eq (class Eq1)
5+
import Control.Monad.Eff.Console (log)
6+
7+
data Product a b = Product a b
8+
9+
derive instance eqMu :: (Eq a, Eq b) => Eq (Product a b)
10+
derive instance eq1Mu :: Eq a => Eq1 (Product a)
11+
12+
main = log "Done"

‎examples/passing/Eq1InEqDeriving.purs‎

Lines changed: 11 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,11 @@
1+
module Main where
2+
3+
import Prelude
4+
import Data.Eq (class Eq1)
5+
import Control.Monad.Eff.Console (log)
6+
7+
newtype Mu f = In (f (Mu f))
8+
9+
derive instance eqMu :: Eq1 f => Eq (Mu f)
10+
11+
main = log "Done"

‎examples/passing/Ord1Deriving.purs‎

Lines changed: 16 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,16 @@
1+
module Main where
2+
3+
import Prelude
4+
import Data.Eq (class Eq1)
5+
import Data.Ord (class Ord1)
6+
import Control.Monad.Eff.Console (log)
7+
8+
data Product a b = Product a b
9+
10+
derive instance eqMu :: (Eq a, Eq b) => Eq (Product a b)
11+
derive instance eq1Mu :: Eq a => Eq1 (Product a)
12+
13+
derive instance ordMu :: (Ord a, Ord b) => Ord (Product a b)
14+
derive instance ord1Mu :: Ord a => Ord1 (Product a)
15+
16+
main = log "Done"

‎examples/passing/Ord1InOrdDeriving.purs‎

Lines changed: 13 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,13 @@
1+
module Main where
2+
3+
import Prelude
4+
import Data.Eq (class Eq1)
5+
import Data.Ord (class Ord1)
6+
import Control.Monad.Eff.Console (log)
7+
8+
newtype Mu f = In (f (Mu f))
9+
10+
derive instance eqMu :: Eq1 f => Eq (Mu f)
11+
derive instance ordMu :: Ord1 f => Ord (Mu f)
12+
13+
main = log "Done"

‎src/Language/PureScript/Constants.hs‎

Lines changed: 6 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -100,6 +100,9 @@ greaterThanOrEq = "greaterThanOrEq"
100100
eq :: forall a. (IsString a) => a
101101
eq = "eq"
102102

103+
eq1 :: forall a. (IsString a) => a
104+
eq1 = "eq1"
105+
103106
(/=) :: forall a. (IsString a) => a
104107
(/=) = "/="
105108

@@ -109,6 +112,9 @@ notEq = "notEq"
109112
compare :: forall a. (IsString a) => a
110113
compare = "compare"
111114

115+
compare1 :: forall a. (IsString a) => a
116+
compare1 = "compare1"
117+
112118
(&&) :: forall a. (IsString a) => a
113119
(&&) = "&&"
114120

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

Lines changed: 54 additions & 12 deletions
Original file line numberDiff line numberDiff line change
@@ -121,13 +121,27 @@ deriveInstance mn syns _ ds (TypeInstanceDeclaration sa@(ss, _) ch idx nm deps c
121121
-> TypeInstanceDeclaration sa ch idx nm deps className tys . ExplicitInstance <$> deriveEq ss mn syns ds tyCon
122122
| otherwise -> throwError . errorMessage' ss $ ExpectedTypeConstructor className tys ty
123123
_ -> throwError . errorMessage' ss $ InvalidDerivedInstance className tys 1
124+
| className == Qualified (Just dataEq) (ProperName "Eq1")
125+
= case tys of
126+
[ty] | Just (Qualified mn' _, _) <- unwrapTypeConstructor ty
127+
, mn == fromMaybe mn mn'
128+
-> pure . TypeInstanceDeclaration sa ch idx nm deps className tys . ExplicitInstance $ deriveEq1 ss
129+
| otherwise -> throwError . errorMessage' ss $ ExpectedTypeConstructor className tys ty
130+
_ -> throwError . errorMessage' ss $ InvalidDerivedInstance className tys 1
124131
| className == Qualified (Just dataOrd) (ProperName "Ord")
125132
= case tys of
126133
[ty] | Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor ty
127134
, mn == fromMaybe mn mn'
128135
-> TypeInstanceDeclaration sa ch idx nm deps className tys . ExplicitInstance <$> deriveOrd ss mn syns ds tyCon
129136
| otherwise -> throwError . errorMessage' ss $ ExpectedTypeConstructor className tys ty
130137
_ -> throwError . errorMessage' ss $ InvalidDerivedInstance className tys 1
138+
| className == Qualified (Just dataOrd) (ProperName "Ord1")
139+
= case tys of
140+
[ty] | Just (Qualified mn' _, _) <- unwrapTypeConstructor ty
141+
, mn == fromMaybe mn mn'
142+
-> pure . TypeInstanceDeclaration sa ch idx nm deps className tys . ExplicitInstance $ deriveOrd1 ss
143+
| otherwise -> throwError . errorMessage' ss $ ExpectedTypeConstructor className tys ty
144+
_ -> throwError . errorMessage' ss $ InvalidDerivedInstance className tys 1
131145
| className == Qualified (Just dataFunctor) (ProperName "Functor")
132146
= case tys of
133147
[ty] | Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor ty
@@ -436,6 +450,9 @@ deriveEq ss mn syns ds tyConNm = do
436450
preludeEq :: Expr -> Expr -> Expr
437451
preludeEq = App . App (Var (Qualified (Just dataEq) (Ident C.eq)))
438452

453+
preludeEq1 :: Expr -> Expr -> Expr
454+
preludeEq1 = App . App (Var (Qualified (Just dataEq) (Ident C.eq1)))
455+
439456
addCatch :: [CaseAlternative] -> [CaseAlternative]
440457
addCatch xs
441458
| length xs /= 1 = xs ++ [catchAll]
@@ -458,12 +475,21 @@ deriveEq ss mn syns ds tyConNm = do
458475
conjAll xs = foldl1 preludeConj xs
459476

460477
toEqTest :: Expr -> Expr -> Type -> Expr
461-
toEqTest l r ty | Just rec <- objectType ty
462-
, Just fields <- decomposeRec rec =
463-
conjAll
464-
. map (\((Label str), typ) -> toEqTest (Accessor str l) (Accessor str r) typ)
465-
$ fields
466-
toEqTest l r _ = preludeEq l r
478+
toEqTest l r ty
479+
| Just rec <- objectType ty
480+
, Just fields <- decomposeRec rec =
481+
conjAll
482+
. map (\((Label str), typ) -> toEqTest (Accessor str l) (Accessor str r) typ)
483+
$ fields
484+
| isAppliedVar ty = preludeEq1 l r
485+
| otherwise = preludeEq l r
486+
487+
deriveEq1 :: SourceSpan -> [Declaration]
488+
deriveEq1 ss =
489+
[ ValueDecl (ss, []) (Ident C.eq1) Public [] (unguarded preludeEq)]
490+
where
491+
preludeEq :: Expr
492+
preludeEq = Var (Qualified (Just dataEq) (Ident C.eq))
467493

468494
deriveOrd
469495
:: forall m
@@ -510,6 +536,9 @@ deriveOrd ss mn syns ds tyConNm = do
510536
ordCompare :: Expr -> Expr -> Expr
511537
ordCompare = App . App (Var (Qualified (Just dataOrd) (Ident C.compare)))
512538

539+
ordCompare1 :: Expr -> Expr -> Expr
540+
ordCompare1 = App . App (Var (Qualified (Just dataOrd) (Ident C.compare1)))
541+
513542
mkCtorClauses :: ((ProperName 'ConstructorName, [Type]), Bool) -> m [CaseAlternative]
514543
mkCtorClauses ((ctorName, tys), isLast) = do
515544
identsL <- replicateM (length tys) (freshIdent "l")
@@ -547,12 +576,21 @@ deriveOrd ss mn syns ds tyConNm = do
547576
]
548577

549578
toOrdering :: Expr -> Expr -> Type -> Expr
550-
toOrdering l r ty | Just rec <- objectType ty
551-
, Just fields <- decomposeRec rec =
552-
appendAll
553-
. map (\((Label str), typ) -> toOrdering (Accessor str l) (Accessor str r) typ)
554-
$ fields
555-
toOrdering l r _ = ordCompare l r
579+
toOrdering l r ty
580+
| Just rec <- objectType ty
581+
, Just fields <- decomposeRec rec =
582+
appendAll
583+
. map (\((Label str), typ) -> toOrdering (Accessor str l) (Accessor str r) typ)
584+
$ fields
585+
| isAppliedVar ty = ordCompare1 l r
586+
| otherwise = ordCompare l r
587+
588+
deriveOrd1 :: SourceSpan -> [Declaration]
589+
deriveOrd1 ss =
590+
[ ValueDecl (ss, []) (Ident C.compare1) Public [] (unguarded dataOrdCompare)]
591+
where
592+
dataOrdCompare :: Expr
593+
dataOrdCompare = Var (Qualified (Just dataOrd) (Ident C.compare))
556594

557595
deriveNewtype
558596
:: forall m
@@ -617,6 +655,10 @@ mkVarMn mn = Var . Qualified mn
617655
mkVar :: Ident -> Expr
618656
mkVar = mkVarMn Nothing
619657

658+
isAppliedVar :: Type -> Bool
659+
isAppliedVar (TypeApp (TypeVar _) _) = True
660+
isAppliedVar _ = False
661+
620662
objectType :: Type -> Maybe Type
621663
objectType (TypeApp (TypeConstructor (Qualified (Just (ModuleName [ProperName "Prim"])) (ProperName "Record"))) rec) = Just rec
622664
objectType _ = Nothing

0 commit comments

Comments
 (0)