From a2f55120add5f851a85514eeea06e5316bd0307f Mon Sep 17 00:00:00 2001 From: Chris Allen Date: Mon, 5 Mar 2018 01:15:36 -0600 Subject: [PATCH 1/3] Skip SourceSpan in Binder Eq, Ord for faster exhaustivity check --- src/Language/PureScript/AST/Binders.hs | 102 ++++++++++++++++++++++++- 1 file changed, 101 insertions(+), 1 deletion(-) diff --git a/src/Language/PureScript/AST/Binders.hs b/src/Language/PureScript/AST/Binders.hs index c5054ce216..76b78108f5 100644 --- a/src/Language/PureScript/AST/Binders.hs +++ b/src/Language/PureScript/AST/Binders.hs @@ -61,7 +61,107 @@ data Binder -- A binder with a type annotation -- | TypedBinder Type Binder - deriving (Show, Eq, Ord) + deriving (Show) + +instance Eq Binder where + (==) NullBinder NullBinder = True + (==) NullBinder _ = False + + (==) (LiteralBinder lb) (LiteralBinder lb') = (==) lb lb' + (==) LiteralBinder{} _ = False + + (==) (VarBinder _ ident) (VarBinder _ ident') = (==) ident ident' + (==) VarBinder{} _ = False + + (==) (ConstructorBinder _ qpc bs) (ConstructorBinder _ qpc' bs') = + (==) qpc qpc' && (==) bs bs' + (==) ConstructorBinder{} _ = False + + (==) (OpBinder _ qov) (OpBinder _ qov') = + (==) qov qov' + (==) OpBinder{} _ = False + + (==) (BinaryNoParensBinder b1 b2 b3) (BinaryNoParensBinder b1' b2' b3') = + (==) b1 b1' && (==) b2 b2' && (==) b3 b3' + (==) BinaryNoParensBinder{} _ = False + + (==) (ParensInBinder b) (ParensInBinder b') = + (==) b b' + (==) ParensInBinder{} _ = False + + (==) (NamedBinder _ ident b) (NamedBinder _ ident' b') = + (==) ident ident' && (==) b b' + (==) NamedBinder{} _ = False + + (==) (PositionedBinder _ comments b) (PositionedBinder _ comments' b') = + (==) comments comments' && (==) b b' + (==) PositionedBinder{} _ = False + + (==) (TypedBinder ty b) (TypedBinder ty' b') = + (==) ty ty' && (==) b b' + (==) TypedBinder{} _ = False + +nextIfEq :: Ordering -> Ordering -> Ordering +nextIfEq EQ o = o +nextIfEq o _ = o + +instance Ord Binder where + compare NullBinder NullBinder = EQ + compare NullBinder _ = LT + + compare (LiteralBinder lb) (LiteralBinder lb') = compare lb lb' + compare LiteralBinder{} NullBinder = GT + compare LiteralBinder{} _ = LT + + compare (VarBinder _ ident) (VarBinder _ ident') = compare ident ident' + compare VarBinder{} NullBinder = GT + compare VarBinder{} LiteralBinder{} = GT + compare VarBinder{} _ = LT + + compare (ConstructorBinder _ qpc bs) (ConstructorBinder _ qpc' bs') = + compare qpc qpc' `nextIfEq` compare bs bs' + compare ConstructorBinder{} NullBinder = GT + compare ConstructorBinder{} LiteralBinder{} = GT + compare ConstructorBinder{} VarBinder{} = GT + compare ConstructorBinder{} _ = LT + + compare (OpBinder _ qov) (OpBinder _ qov') = + compare qov qov' + compare OpBinder{} NullBinder = GT + compare OpBinder{} LiteralBinder{} = GT + compare OpBinder{} VarBinder{} = GT + compare OpBinder{} ConstructorBinder{} = GT + compare OpBinder{} _ = LT + + compare (BinaryNoParensBinder b1 b2 b3) (BinaryNoParensBinder b1' b2' b3') = + compare b1 b1' `nextIfEq` compare b2 b2' `nextIfEq` compare b3 b3' + compare BinaryNoParensBinder{} ParensInBinder{} = LT + compare BinaryNoParensBinder{} NamedBinder{} = LT + compare BinaryNoParensBinder{} PositionedBinder{} = LT + compare BinaryNoParensBinder{} TypedBinder{} = LT + compare BinaryNoParensBinder{} _ = GT + + compare (ParensInBinder b) (ParensInBinder b') = + compare b b' + compare ParensInBinder{} NamedBinder{} = LT + compare ParensInBinder{} PositionedBinder{} = LT + compare ParensInBinder{} TypedBinder{} = LT + compare ParensInBinder{} _ = GT + + compare (NamedBinder _ ident b) (NamedBinder _ ident' b') = + compare ident ident' `nextIfEq` compare b b' + compare NamedBinder{} PositionedBinder{} = LT + compare NamedBinder{} TypedBinder{} = LT + compare NamedBinder{} _ = GT + + compare (PositionedBinder _ comments b) (PositionedBinder _ comments' b') = + compare comments comments' `nextIfEq` compare b b' + compare PositionedBinder{} TypedBinder{} = LT + compare PositionedBinder{} _ = GT + + compare (TypedBinder ty b) (TypedBinder ty' b') = + compare ty ty' `nextIfEq` compare b b' + compare TypedBinder{} _ = GT -- | -- Collect all names introduced in binders in an expression From d661bfa9a8873af0f8a229d37496e3c1dcf7ddf0 Mon Sep 17 00:00:00 2001 From: Chris Allen Date: Mon, 5 Mar 2018 11:34:51 -0600 Subject: [PATCH 2/3] Use Semigroup rather than sui generis function --- src/Language/PureScript/AST/Binders.hs | 16 +++++++--------- 1 file changed, 7 insertions(+), 9 deletions(-) diff --git a/src/Language/PureScript/AST/Binders.hs b/src/Language/PureScript/AST/Binders.hs index 76b78108f5..c27105c534 100644 --- a/src/Language/PureScript/AST/Binders.hs +++ b/src/Language/PureScript/AST/Binders.hs @@ -5,6 +5,8 @@ module Language.PureScript.AST.Binders where import Prelude.Compat +import Data.Semigroup + import Language.PureScript.AST.SourcePos import Language.PureScript.AST.Literals import Language.PureScript.Names @@ -101,10 +103,6 @@ instance Eq Binder where (==) ty ty' && (==) b b' (==) TypedBinder{} _ = False -nextIfEq :: Ordering -> Ordering -> Ordering -nextIfEq EQ o = o -nextIfEq o _ = o - instance Ord Binder where compare NullBinder NullBinder = EQ compare NullBinder _ = LT @@ -119,7 +117,7 @@ instance Ord Binder where compare VarBinder{} _ = LT compare (ConstructorBinder _ qpc bs) (ConstructorBinder _ qpc' bs') = - compare qpc qpc' `nextIfEq` compare bs bs' + compare qpc qpc' <> compare bs bs' compare ConstructorBinder{} NullBinder = GT compare ConstructorBinder{} LiteralBinder{} = GT compare ConstructorBinder{} VarBinder{} = GT @@ -134,7 +132,7 @@ instance Ord Binder where compare OpBinder{} _ = LT compare (BinaryNoParensBinder b1 b2 b3) (BinaryNoParensBinder b1' b2' b3') = - compare b1 b1' `nextIfEq` compare b2 b2' `nextIfEq` compare b3 b3' + compare b1 b1' <> compare b2 b2' <> compare b3 b3' compare BinaryNoParensBinder{} ParensInBinder{} = LT compare BinaryNoParensBinder{} NamedBinder{} = LT compare BinaryNoParensBinder{} PositionedBinder{} = LT @@ -149,18 +147,18 @@ instance Ord Binder where compare ParensInBinder{} _ = GT compare (NamedBinder _ ident b) (NamedBinder _ ident' b') = - compare ident ident' `nextIfEq` compare b b' + compare ident ident' <> compare b b' compare NamedBinder{} PositionedBinder{} = LT compare NamedBinder{} TypedBinder{} = LT compare NamedBinder{} _ = GT compare (PositionedBinder _ comments b) (PositionedBinder _ comments' b') = - compare comments comments' `nextIfEq` compare b b' + compare comments comments' <> compare b b' compare PositionedBinder{} TypedBinder{} = LT compare PositionedBinder{} _ = GT compare (TypedBinder ty b) (TypedBinder ty' b') = - compare ty ty' `nextIfEq` compare b b' + compare ty ty' <> compare b b' compare TypedBinder{} _ = GT -- | From cd491889c77771a9a91d98084c4e4075f2bd6141 Mon Sep 17 00:00:00 2001 From: Chris Allen Date: Mon, 5 Mar 2018 12:45:59 -0600 Subject: [PATCH 3/3] contributors.md --- CONTRIBUTORS.md | 1 + 1 file changed, 1 insertion(+) diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index b87b25adf3..c127ff37d4 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -26,6 +26,7 @@ If you would prefer to use different terms, please use the section below instead | [@balajirrao](https://github.com/balajirrao) | Balaji Rao | MIT license | | [@bbqbaron](https://github.com/bbqbaron) | Eric Loren | [MIT license](http://opensource.org/licenses/MIT) | | [@bergmark](https://github.com/bergmark) | Adam Bergmark | MIT license | +| [@bitemyapp](https://github.com/bitemyapp) | Chris Allen | [MIT license](http://opensource.org/licenses/MIT) | | [@bmjames](https://github.com/bmjames) | Ben James | [MIT license](http://opensource.org/licenses/MIT) | | [@Bogdanp](https://github.com/Bogdanp) | Bogdan Paul Popa | [MIT license](http://opensource.org/licenses/MIT) | | [@brandonhamilton](https://github.com/brandonhamilton) | Brandon Hamilton | [MIT license](http://opensource.org/licenses/MIT) |