From 9fc542d69ef32760c4df83c49267f67379fd3dd3 Mon Sep 17 00:00:00 2001 From: Miles Frain Date: Thu, 25 Jun 2020 21:45:50 -0700 Subject: [PATCH 1/3] Common code for Ord DeclarationRef --- .../Language/PureScript/AST/Declarations.hs | 51 +++++-------------- src/Language/PureScript/Ide/Imports.hs | 2 +- src/Language/PureScript/Linter/Imports.hs | 4 +- tests/purs/warning/DuplicateExportRef.out | 8 +-- tests/purs/warning/DuplicateImportRef.out | 8 +-- 5 files changed, 25 insertions(+), 48 deletions(-) diff --git a/lib/purescript-ast/src/Language/PureScript/AST/Declarations.hs b/lib/purescript-ast/src/Language/PureScript/AST/Declarations.hs index 5b451e904c..747beb543a 100644 --- a/lib/purescript-ast/src/Language/PureScript/AST/Declarations.hs +++ b/lib/purescript-ast/src/Language/PureScript/AST/Declarations.hs @@ -149,14 +149,18 @@ importPrim = -- data DeclarationRef -- | - -- A type constructor with data constructors + -- A type class -- - = TypeRef SourceSpan (ProperName 'TypeName) (Maybe [ProperName 'ConstructorName]) + = TypeClassRef SourceSpan (ProperName 'ClassName) -- | -- A type operator -- | TypeOpRef SourceSpan (OpName 'TypeOpName) -- | + -- A type constructor with data constructors + -- + | TypeRef SourceSpan (ProperName 'TypeName) (Maybe [ProperName 'ConstructorName]) + -- | -- A value -- | ValueRef SourceSpan Ident @@ -165,10 +169,6 @@ data DeclarationRef -- | ValueOpRef SourceSpan (OpName 'ValueOpName) -- | - -- A type class - -- - | TypeClassRef SourceSpan (ProperName 'ClassName) - -- | -- A type class instance, created during typeclass desugaring (name, class name, instance types) -- | TypeInstanceRef SourceSpan Ident @@ -184,22 +184,22 @@ data DeclarationRef deriving (Show, Generic, NFData, Serialise) instance Eq DeclarationRef where - (TypeRef _ name dctors) == (TypeRef _ name' dctors') = name == name' && dctors == dctors' + (TypeClassRef _ name) == (TypeClassRef _ name') = name == name' (TypeOpRef _ name) == (TypeOpRef _ name') = name == name' + (TypeRef _ name dctors) == (TypeRef _ name' dctors') = name == name' && dctors == dctors' (ValueRef _ name) == (ValueRef _ name') = name == name' (ValueOpRef _ name) == (ValueOpRef _ name') = name == name' - (TypeClassRef _ name) == (TypeClassRef _ name') = name == name' (TypeInstanceRef _ name) == (TypeInstanceRef _ name') = name == name' (ModuleRef _ name) == (ModuleRef _ name') = name == name' (ReExportRef _ mn ref) == (ReExportRef _ mn' ref') = mn == mn' && ref == ref' _ == _ = False instance Ord DeclarationRef where - TypeRef _ name dctors `compare` TypeRef _ name' dctors' = compare name name' <> compare dctors dctors' + TypeClassRef _ name `compare` TypeClassRef _ name' = compare name name' TypeOpRef _ name `compare` TypeOpRef _ name' = compare name name' + TypeRef _ name dctors `compare` TypeRef _ name' dctors' = compare name name' <> compare dctors dctors' ValueRef _ name `compare` ValueRef _ name' = compare name name' ValueOpRef _ name `compare` ValueOpRef _ name' = compare name name' - TypeClassRef _ name `compare` TypeClassRef _ name' = compare name name' TypeInstanceRef _ name `compare` TypeInstanceRef _ name' = compare name name' ModuleRef _ name `compare` ModuleRef _ name' = compare name name' ReExportRef _ mn ref `compare` ReExportRef _ mn' ref' = compare mn mn' <> compare ref ref' @@ -207,11 +207,11 @@ instance Ord DeclarationRef where compare (orderOf ref) (orderOf ref') where orderOf :: DeclarationRef -> Int - orderOf TypeRef{} = 0 + orderOf TypeClassRef{} = 0 orderOf TypeOpRef{} = 1 - orderOf ValueRef{} = 2 - orderOf ValueOpRef{} = 3 - orderOf TypeClassRef{} = 4 + orderOf TypeRef{} = 2 + orderOf ValueRef{} = 3 + orderOf ValueOpRef{} = 4 orderOf TypeInstanceRef{} = 5 orderOf ModuleRef{} = 6 orderOf ReExportRef{} = 7 @@ -223,29 +223,6 @@ data ExportSource = } deriving (Eq, Ord, Show, Generic, NFData, Serialise) --- enable sorting lists of explicitly imported refs when suggesting imports in linting, IDE, etc. --- not an Ord because this implementation is not consistent with its Eq instance. --- think of it as a notion of contextual, not inherent, ordering. -compDecRef :: DeclarationRef -> DeclarationRef -> Ordering -compDecRef (TypeRef _ name _) (TypeRef _ name' _) = compare name name' -compDecRef (TypeOpRef _ name) (TypeOpRef _ name') = compare name name' -compDecRef (ValueRef _ ident) (ValueRef _ ident') = compare ident ident' -compDecRef (ValueOpRef _ name) (ValueOpRef _ name') = compare name name' -compDecRef (TypeClassRef _ name) (TypeClassRef _ name') = compare name name' -compDecRef (TypeInstanceRef _ ident) (TypeInstanceRef _ ident') = compare ident ident' -compDecRef (ModuleRef _ name) (ModuleRef _ name') = compare name name' -compDecRef (ReExportRef _ name _) (ReExportRef _ name' _) = compare name name' -compDecRef ref ref' = compare - (orderOf ref) (orderOf ref') - where - orderOf :: DeclarationRef -> Int - orderOf TypeClassRef{} = 0 - orderOf TypeOpRef{} = 1 - orderOf TypeRef{} = 2 - orderOf ValueRef{} = 3 - orderOf ValueOpRef{} = 4 - orderOf _ = 6 - declRefSourceSpan :: DeclarationRef -> SourceSpan declRefSourceSpan (TypeRef ss _ _) = ss declRefSourceSpan (TypeOpRef ss _) = ss diff --git a/src/Language/PureScript/Ide/Imports.hs b/src/Language/PureScript/Ide/Imports.hs index 5afc7ccde6..69a8d68e53 100644 --- a/src/Language/PureScript/Ide/Imports.hs +++ b/src/Language/PureScript/Ide/Imports.hs @@ -229,7 +229,7 @@ addExplicitImport' decl moduleName qualifier imports = -- TypeDeclaration "Maybe" + Data.Maybe (maybe) -> Data.Maybe(Maybe, maybe) insertDeclIntoImport :: IdeDeclaration -> Import -> Import insertDeclIntoImport decl' (Import mn (P.Explicit refs) qual) = - Import mn (P.Explicit (sortBy P.compDecRef (insertDeclIntoRefs decl' refs))) qual + Import mn (P.Explicit (sort (insertDeclIntoRefs decl' refs))) qual insertDeclIntoImport _ is = is insertDeclIntoRefs :: IdeDeclaration -> [P.DeclarationRef] -> [P.DeclarationRef] diff --git a/src/Language/PureScript/Linter/Imports.hs b/src/Language/PureScript/Linter/Imports.hs index 69dc204368..b4d25ba011 100644 --- a/src/Language/PureScript/Linter/Imports.hs +++ b/src/Language/PureScript/Linter/Imports.hs @@ -12,7 +12,7 @@ import Control.Monad.Writer.Class import Data.Function (on) import Data.Foldable (for_) -import Data.List (find, intersect, groupBy, sortBy, (\\)) +import Data.List (find, intersect, groupBy, sort, sortBy, (\\)) import Data.Maybe (mapMaybe) import Data.Monoid (Sum(..)) import Data.Traversable (forM) @@ -334,7 +334,7 @@ findUsedRefs ss env mni qn names = typesRefs = map (flip (TypeRef ss) (Just [])) typesWithoutDctors ++ map (\(ty, ds) -> TypeRef ss ty (Just ds)) (M.toList typesWithDctors) - in sortBy compDecRef $ classRefs ++ typeOpRefs ++ typesRefs ++ valueRefs ++ valueOpRefs + in sort $ classRefs ++ typeOpRefs ++ typesRefs ++ valueRefs ++ valueOpRefs where diff --git a/tests/purs/warning/DuplicateExportRef.out b/tests/purs/warning/DuplicateExportRef.out index 82efd3bf36..385bf8cfb2 100644 --- a/tests/purs/warning/DuplicateExportRef.out +++ b/tests/purs/warning/DuplicateExportRef.out @@ -3,7 +3,7 @@ Warning 1 of 7: in module Main at tests/purs/warning/DuplicateExportRef.purs:8:1 - 30:28 (line 8, column 1 - line 30, column 28) - Export list contains multiple references to type X + Export list contains multiple references to type class Y See https://github.com/purescript/documentation/blob/master/errors/DuplicateExportRef.md for more information, @@ -25,7 +25,7 @@ Warning 3 of 7: in module Main at tests/purs/warning/DuplicateExportRef.purs:8:1 - 30:28 (line 8, column 1 - line 30, column 28) - Export list contains multiple references to value fn + Export list contains multiple references to type X See https://github.com/purescript/documentation/blob/master/errors/DuplicateExportRef.md for more information, @@ -36,7 +36,7 @@ Warning 4 of 7: in module Main at tests/purs/warning/DuplicateExportRef.purs:8:1 - 30:28 (line 8, column 1 - line 30, column 28) - Export list contains multiple references to operator (!) + Export list contains multiple references to value fn See https://github.com/purescript/documentation/blob/master/errors/DuplicateExportRef.md for more information, @@ -47,7 +47,7 @@ Warning 5 of 7: in module Main at tests/purs/warning/DuplicateExportRef.purs:8:1 - 30:28 (line 8, column 1 - line 30, column 28) - Export list contains multiple references to type class Y + Export list contains multiple references to operator (!) See https://github.com/purescript/documentation/blob/master/errors/DuplicateExportRef.md for more information, diff --git a/tests/purs/warning/DuplicateImportRef.out b/tests/purs/warning/DuplicateImportRef.out index 0e5f7101b9..c1ce0ba695 100644 --- a/tests/purs/warning/DuplicateImportRef.out +++ b/tests/purs/warning/DuplicateImportRef.out @@ -3,7 +3,7 @@ Warning 1 of 4: in module Main at tests/purs/warning/DuplicateImportRef.purs:7:1 - 12:4 (line 7, column 1 - line 12, column 4) - Import list contains multiple references to type Unit + Import list contains multiple references to type class Functor See https://github.com/purescript/documentation/blob/master/errors/DuplicateImportRef.md for more information, @@ -14,7 +14,7 @@ Warning 2 of 4: in module Main at tests/purs/warning/DuplicateImportRef.purs:7:1 - 12:4 (line 7, column 1 - line 12, column 4) - Import list contains multiple references to value unit + Import list contains multiple references to type Unit See https://github.com/purescript/documentation/blob/master/errors/DuplicateImportRef.md for more information, @@ -25,7 +25,7 @@ Warning 3 of 4: in module Main at tests/purs/warning/DuplicateImportRef.purs:7:1 - 12:4 (line 7, column 1 - line 12, column 4) - Import list contains multiple references to operator (<>) + Import list contains multiple references to value unit See https://github.com/purescript/documentation/blob/master/errors/DuplicateImportRef.md for more information, @@ -36,7 +36,7 @@ Warning 4 of 4: in module Main at tests/purs/warning/DuplicateImportRef.purs:7:1 - 12:4 (line 7, column 1 - line 12, column 4) - Import list contains multiple references to type class Functor + Import list contains multiple references to operator (<>) See https://github.com/purescript/documentation/blob/master/errors/DuplicateImportRef.md for more information, From 40b7de4345024bbad7752ecb6e1105d331f48c67 Mon Sep 17 00:00:00 2001 From: Miles Frain Date: Thu, 25 Jun 2020 21:54:54 -0700 Subject: [PATCH 2/3] Use orderOf for compareType --- .../src/Language/PureScript/Types.hs | 65 ++++++------------- 1 file changed, 20 insertions(+), 45 deletions(-) diff --git a/lib/purescript-ast/src/Language/PureScript/Types.hs b/lib/purescript-ast/src/Language/PureScript/Types.hs index f221d3619d..83be8fe8db 100644 --- a/lib/purescript-ast/src/Language/PureScript/Types.hs +++ b/lib/purescript-ast/src/Language/PureScript/Types.hs @@ -728,66 +728,41 @@ eqMaybeType _ _ = False compareType :: Type a -> Type b -> Ordering compareType (TUnknown _ a) (TUnknown _ a') = compare a a' -compareType (TUnknown {}) _ = LT - compareType (TypeVar _ a) (TypeVar _ a') = compare a a' -compareType (TypeVar {}) _ = LT -compareType _ (TypeVar {}) = GT - compareType (TypeLevelString _ a) (TypeLevelString _ a') = compare a a' -compareType (TypeLevelString {}) _ = LT -compareType _ (TypeLevelString {}) = GT - compareType (TypeWildcard _ a) (TypeWildcard _ a') = compare a a' -compareType (TypeWildcard {}) _ = LT -compareType _ (TypeWildcard {}) = GT - compareType (TypeConstructor _ a) (TypeConstructor _ a') = compare a a' -compareType (TypeConstructor {}) _ = LT -compareType _ (TypeConstructor {}) = GT - compareType (TypeOp _ a) (TypeOp _ a') = compare a a' -compareType (TypeOp {}) _ = LT -compareType _ (TypeOp {}) = GT - compareType (TypeApp _ a b) (TypeApp _ a' b') = compareType a a' <> compareType b b' -compareType (TypeApp {}) _ = LT -compareType _ (TypeApp {}) = GT - compareType (KindApp _ a b) (KindApp _ a' b') = compareType a a' <> compareType b b' -compareType (KindApp {}) _ = LT -compareType _ (KindApp {}) = GT - compareType (ForAll _ a b c d) (ForAll _ a' b' c' d') = compare a a' <> compareMaybeType b b' <> compareType c c' <> compare d d' -compareType (ForAll {}) _ = LT -compareType _ (ForAll {}) = GT - compareType (ConstrainedType _ a b) (ConstrainedType _ a' b') = compareConstraint a a' <> compareType b b' -compareType (ConstrainedType {}) _ = LT -compareType _ (ConstrainedType {}) = GT - compareType (Skolem _ a b c d) (Skolem _ a' b' c' d') = compare a a' <> compareMaybeType b b' <> compare c c' <> compare d d' -compareType (Skolem {}) _ = LT -compareType _ (Skolem {}) = GT - compareType (REmpty _) (REmpty _) = EQ -compareType (REmpty _) _ = LT -compareType _ (REmpty _) = GT - compareType (RCons _ a b c) (RCons _ a' b' c') = compare a a' <> compareType b b' <> compareType c c' -compareType (RCons {}) _ = LT -compareType _ (RCons {}) = GT - compareType (KindedType _ a b) (KindedType _ a' b') = compareType a a' <> compareType b b' -compareType (KindedType {}) _ = LT -compareType _ (KindedType {}) = GT - compareType (BinaryNoParensType _ a b c) (BinaryNoParensType _ a' b' c') = compareType a a' <> compareType b b' <> compareType c c' -compareType (BinaryNoParensType {}) _ = LT -compareType _ (BinaryNoParensType {}) = GT - compareType (ParensInType _ a) (ParensInType _ a') = compareType a a' -compareType (ParensInType {}) _ = GT +compareType typ typ' = + compare (orderOf typ) (orderOf typ') + where + orderOf :: Type a -> Int + orderOf TUnknown{} = 0 + orderOf TypeVar{} = 1 + orderOf TypeLevelString{} = 2 + orderOf TypeWildcard{} = 3 + orderOf TypeConstructor{} = 4 + orderOf TypeOp{} = 5 + orderOf TypeApp{} = 6 + orderOf KindApp{} = 7 + orderOf ForAll{} = 8 + orderOf ConstrainedType{} = 9 + orderOf Skolem{} = 10 + orderOf REmpty{} = 11 + orderOf RCons{} = 12 + orderOf KindedType{} = 13 + orderOf BinaryNoParensType{} = 14 + orderOf ParensInType{} = 15 compareMaybeType :: Maybe (Type a) -> Maybe (Type b) -> Ordering compareMaybeType (Just a) (Just b) = compareType a b From d91b4615d7282954ec29056f1d51df6ccbea03cd Mon Sep 17 00:00:00 2001 From: Miles Frain Date: Thu, 25 Jun 2020 22:31:30 -0700 Subject: [PATCH 3/3] Shrink Binder Eq and Ord --- .../src/Language/PureScript/AST/Binders.hs | 116 ++++++------------ 1 file changed, 39 insertions(+), 77 deletions(-) diff --git a/lib/purescript-ast/src/Language/PureScript/AST/Binders.hs b/lib/purescript-ast/src/Language/PureScript/AST/Binders.hs index 528ffb0987..01f9d5e129 100644 --- a/lib/purescript-ast/src/Language/PureScript/AST/Binders.hs +++ b/lib/purescript-ast/src/Language/PureScript/AST/Binders.hs @@ -71,100 +71,62 @@ data Binder -- the `Ord` instance was needed for the speed-up, but I did not want the `Eq` -- to have mismatched behavior. 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 + NullBinder == NullBinder = + True + (LiteralBinder _ lb) == (LiteralBinder _ lb') = + lb == lb' + (VarBinder _ ident) == (VarBinder _ ident') = + ident == ident' + (ConstructorBinder _ qpc bs) == (ConstructorBinder _ qpc' bs') = + qpc == qpc' && bs == bs' + (OpBinder _ qov) == (OpBinder _ qov') = + qov == qov' + (BinaryNoParensBinder b1 b2 b3) == (BinaryNoParensBinder b1' b2' b3') = + b1 == b1' && b2 == b2' && b3 == b3' + (ParensInBinder b) == (ParensInBinder b') = + b == b' + (NamedBinder _ ident b) == (NamedBinder _ ident' b') = + ident == ident' && b == b' + (PositionedBinder _ comments b) == (PositionedBinder _ comments' b') = + comments == comments' && b == b' + (TypedBinder ty b) == (TypedBinder ty' b') = + ty == ty' && b == b' + _ == _ = False 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 (LiteralBinder _ lb) (LiteralBinder _ lb') = + compare lb lb' + compare (VarBinder _ ident) (VarBinder _ ident') = + compare ident ident' compare (ConstructorBinder _ qpc bs) (ConstructorBinder _ qpc' bs') = compare qpc qpc' <> 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' <> compare b2 b2' <> 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' <> compare b b' - compare NamedBinder{} PositionedBinder{} = LT - compare NamedBinder{} TypedBinder{} = LT - compare NamedBinder{} _ = GT - compare (PositionedBinder _ comments b) (PositionedBinder _ comments' b') = compare comments comments' <> compare b b' - compare PositionedBinder{} TypedBinder{} = LT - compare PositionedBinder{} _ = GT - compare (TypedBinder ty b) (TypedBinder ty' b') = compare ty ty' <> compare b b' - compare TypedBinder{} _ = GT + compare binder binder' = + compare (orderOf binder) (orderOf binder') + where + orderOf :: Binder -> Int + orderOf NullBinder = 0 + orderOf LiteralBinder{} = 1 + orderOf VarBinder{} = 2 + orderOf ConstructorBinder{} = 3 + orderOf OpBinder{} = 4 + orderOf BinaryNoParensBinder{} = 5 + orderOf ParensInBinder{} = 6 + orderOf NamedBinder{} = 7 + orderOf PositionedBinder{} = 8 + orderOf TypedBinder{} = 9 -- | -- Collect all names introduced in binders in an expression