Skip to content

Eq1 / Ord1 deriving again #3207

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
garyb merged 6 commits into from
Jan 21, 2018
Merged

Eq1 / Ord1 deriving again #3207

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
6 commits
Select commit Hold shift + click to select a range
4e75c67
Allow `Eq1` to be used when deriving `Eq`
garyb Jan 20, 2018
d4da7da
Derive `Eq1` (as `eq1 = eq`)
garyb Jan 20, 2018
d1e43fc
Allow `Ord1` to be used when deriving `Ord`
garyb Jan 20, 2018
60198af
Derive `Ord1` (as `compare1 = compare`)
garyb Jan 20, 2018
3bebc61
Remove unnecessary constraints
garyb Jan 20, 2018
de9e5ac
Update DerivingFunctor test for Eq1 deriving
garyb Jan 21, 2018
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
5 changes: 3 additions & 2 deletions examples/passing/DerivingFunctor.purs
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -1,6 +1,7 @@
module Main where

import Prelude
import Data.Eq (class Eq1)
import Control.Monad.Eff.Console (log)
import Test.Assert

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

derive instance eqM :: (Eq (f a), Eq a) => Eq (M f a)
derive instance eqM :: (Eq1 f, Eq a) => Eq (M f a)

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

Expand All @@ -24,5 +25,5 @@ main = do
assert $ map show (M1 0 :: MA Int) == M1 0
assert $ map show (M2 [0, 1] :: MA Int) == M2 ["0", "1"]
assert $ map show (M3 {foo: 0, bar: 1, baz: [2, 3]} :: MA Int) == M3 {foo: 0, bar: "1", baz: ["2", "3"]}
assert $ map show (M4 { myField: 42 }) == M4 { myField: "42" } :: MA String
assert $ map show (M4 { myField: 42 }) == M4 { myField: "42" } :: MA String
log "Done"
12 changes: 12 additions & 0 deletions examples/passing/Eq1Deriving.purs
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -0,0 +1,12 @@
module Main where

import Prelude
import Data.Eq (class Eq1)
import Control.Monad.Eff.Console (log)

data Product a b = Product a b

derive instance eqMu :: (Eq a, Eq b) => Eq (Product a b)
derive instance eq1Mu :: Eq a => Eq1 (Product a)

main = log "Done"
11 changes: 11 additions & 0 deletions examples/passing/Eq1InEqDeriving.purs
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -0,0 +1,11 @@
module Main where

import Prelude
import Data.Eq (class Eq1)
import Control.Monad.Eff.Console (log)

newtype Mu f = In (f (Mu f))

derive instance eqMu :: Eq1 f => Eq (Mu f)

main = log "Done"
16 changes: 16 additions & 0 deletions examples/passing/Ord1Deriving.purs
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -0,0 +1,16 @@
module Main where

import Prelude
import Data.Eq (class Eq1)
import Data.Ord (class Ord1)
import Control.Monad.Eff.Console (log)

data Product a b = Product a b

derive instance eqMu :: (Eq a, Eq b) => Eq (Product a b)
derive instance eq1Mu :: Eq a => Eq1 (Product a)

derive instance ordMu :: (Ord a, Ord b) => Ord (Product a b)
derive instance ord1Mu :: Ord a => Ord1 (Product a)

main = log "Done"
13 changes: 13 additions & 0 deletions examples/passing/Ord1InOrdDeriving.purs
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -0,0 +1,13 @@
module Main where

import Prelude
import Data.Eq (class Eq1)
import Data.Ord (class Ord1)
import Control.Monad.Eff.Console (log)

newtype Mu f = In (f (Mu f))

derive instance eqMu :: Eq1 f => Eq (Mu f)
derive instance ordMu :: Ord1 f => Ord (Mu f)

main = log "Done"
6 changes: 6 additions & 0 deletions src/Language/PureScript/Constants.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -100,6 +100,9 @@ greaterThanOrEq = "greaterThanOrEq"
eq :: forall a. (IsString a) => a
eq = "eq"

eq1 :: forall a. (IsString a) => a
eq1 = "eq1"

(/=) :: forall a. (IsString a) => a
(/=) = "/="

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

compare1 :: forall a. (IsString a) => a
compare1 = "compare1"

(&&) :: forall a. (IsString a) => a
(&&) = "&&"

Expand Down
66 changes: 54 additions & 12 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 @@ -121,13 +121,27 @@ deriveInstance mn syns _ ds (TypeInstanceDeclaration sa@(ss, _) ch idx nm deps c
-> TypeInstanceDeclaration sa ch idx nm deps className tys . ExplicitInstance <$> deriveEq ss mn syns ds tyCon
| otherwise -> throwError . errorMessage' ss $ ExpectedTypeConstructor className tys ty
_ -> throwError . errorMessage' ss $ InvalidDerivedInstance className tys 1
| className == Qualified (Just dataEq) (ProperName "Eq1")
= case tys of
[ty] | Just (Qualified mn' _, _) <- unwrapTypeConstructor ty
, mn == fromMaybe mn mn'

@kritzcreek kritzcreek Jan 20, 2018

Copy link
Copy Markdown
Member

Choose a reason for hiding this comment

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

maybe True (== mn) mn' ?

I was a little confused there for a second :D There's also the more obscure all (== mn) mn' but I think that's too cute :D

@garyb garyb Jan 20, 2018

Copy link
Copy Markdown
Member Author

Choose a reason for hiding this comment

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

I just copied exactly the form of the other matches here. There's some other cleaning up I'd like to do actually, but didn't want to mix it in this PR 😉 so I can change it, but maybe it'd be better to keep them consistent for now?

@kritzcreek kritzcreek Jan 20, 2018

Copy link
Copy Markdown
Member

Choose a reason for hiding this comment

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

Should've looked at the whole file 🤦‍♂️

-> pure . TypeInstanceDeclaration sa ch idx nm deps className tys . ExplicitInstance $ deriveEq1 ss
| otherwise -> throwError . errorMessage' ss $ ExpectedTypeConstructor className tys ty
_ -> throwError . errorMessage' ss $ InvalidDerivedInstance className tys 1
| className == Qualified (Just dataOrd) (ProperName "Ord")
= case tys of
[ty] | Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor ty
, mn == fromMaybe mn mn'
-> TypeInstanceDeclaration sa ch idx nm deps className tys . ExplicitInstance <$> deriveOrd ss mn syns ds tyCon
| otherwise -> throwError . errorMessage' ss $ ExpectedTypeConstructor className tys ty
_ -> throwError . errorMessage' ss $ InvalidDerivedInstance className tys 1
| className == Qualified (Just dataOrd) (ProperName "Ord1")
= case tys of
[ty] | Just (Qualified mn' _, _) <- unwrapTypeConstructor ty
, mn == fromMaybe mn mn'

@kritzcreek kritzcreek Jan 20, 2018

Copy link
Copy Markdown
Member

Choose a reason for hiding this comment

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

As above

-> pure . TypeInstanceDeclaration sa ch idx nm deps className tys . ExplicitInstance $ deriveOrd1 ss
| otherwise -> throwError . errorMessage' ss $ ExpectedTypeConstructor className tys ty
_ -> throwError . errorMessage' ss $ InvalidDerivedInstance className tys 1
| className == Qualified (Just dataFunctor) (ProperName "Functor")
= case tys of
[ty] | Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor ty
Expand Down Expand Up @@ -436,6 +450,9 @@ deriveEq ss mn syns ds tyConNm = do
preludeEq :: Expr -> Expr -> Expr
preludeEq = App . App (Var (Qualified (Just dataEq) (Ident C.eq)))

preludeEq1 :: Expr -> Expr -> Expr
preludeEq1 = App . App (Var (Qualified (Just dataEq) (Ident C.eq1)))

addCatch :: [CaseAlternative] -> [CaseAlternative]
addCatch xs
| length xs /= 1 = xs ++ [catchAll]
Expand All @@ -458,12 +475,21 @@ deriveEq ss mn syns ds tyConNm = do
conjAll xs = foldl1 preludeConj xs

toEqTest :: Expr -> Expr -> Type -> Expr
toEqTest l r ty | Just rec <- objectType ty
, Just fields <- decomposeRec rec =
conjAll
. map (\((Label str), typ) -> toEqTest (Accessor str l) (Accessor str r) typ)
$ fields
toEqTest l r _ = preludeEq l r
toEqTest l r ty
| Just rec <- objectType ty
, Just fields <- decomposeRec rec =
conjAll
. map (\((Label str), typ) -> toEqTest (Accessor str l) (Accessor str r) typ)
$ fields
| isAppliedVar ty = preludeEq1 l r
| otherwise = preludeEq l r

deriveEq1 :: SourceSpan -> [Declaration]
deriveEq1 ss =
[ ValueDecl (ss, []) (Ident C.eq1) Public [] (unguarded preludeEq)]
where
preludeEq :: Expr
preludeEq = Var (Qualified (Just dataEq) (Ident C.eq))

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

ordCompare1 :: Expr -> Expr -> Expr
ordCompare1 = App . App (Var (Qualified (Just dataOrd) (Ident C.compare1)))

mkCtorClauses :: ((ProperName 'ConstructorName, [Type]), Bool) -> m [CaseAlternative]
mkCtorClauses ((ctorName, tys), isLast) = do
identsL <- replicateM (length tys) (freshIdent "l")
Expand Down Expand Up @@ -547,12 +576,21 @@ deriveOrd ss mn syns ds tyConNm = do
]

toOrdering :: Expr -> Expr -> Type -> Expr
toOrdering l r ty | Just rec <- objectType ty
, Just fields <- decomposeRec rec =
appendAll
. map (\((Label str), typ) -> toOrdering (Accessor str l) (Accessor str r) typ)
$ fields
toOrdering l r _ = ordCompare l r
toOrdering l r ty
| Just rec <- objectType ty
, Just fields <- decomposeRec rec =
appendAll
. map (\((Label str), typ) -> toOrdering (Accessor str l) (Accessor str r) typ)
$ fields
| isAppliedVar ty = ordCompare1 l r
| otherwise = ordCompare l r

deriveOrd1 :: SourceSpan -> [Declaration]
deriveOrd1 ss =
[ ValueDecl (ss, []) (Ident C.compare1) Public [] (unguarded dataOrdCompare)]
where
dataOrdCompare :: Expr
dataOrdCompare = Var (Qualified (Just dataOrd) (Ident C.compare))

deriveNewtype
:: forall m
Expand Down Expand Up @@ -617,6 +655,10 @@ mkVarMn mn = Var . Qualified mn
mkVar :: Ident -> Expr
mkVar = mkVarMn Nothing

isAppliedVar :: Type -> Bool
isAppliedVar (TypeApp (TypeVar _) _) = True
isAppliedVar _ = False

objectType :: Type -> Maybe Type
objectType (TypeApp (TypeConstructor (Qualified (Just (ModuleName [ProperName "Prim"])) (ProperName "Record"))) rec) = Just rec
objectType _ = Nothing
Expand Down