diff --git a/app/Command/Docs/Tags.hs b/app/Command/Docs/Tags.hs --- a/app/Command/Docs/Tags.hs +++ b/app/Command/Docs/Tags.hs @@ -6,16 +6,16 @@ tags :: P.Module -> [(String, Int)] tags = map (first T.unpack) . concatMap dtags . P.exportedDeclarations - where dtags (P.PositionedDeclaration sp _ d) = map tag $ names d - where tag name = (name, line) - line = P.sourcePosLine $ P.spanStart sp - dtags _ = [] - names (P.DataDeclaration _ name _ dcons) = P.runProperName name : consNames - where consNames = map (\(cname, _) -> P.runProperName cname) dcons - names (P.TypeDeclaration ident _) = [P.showIdent ident] - names (P.ExternDeclaration ident _) = [P.showIdent ident] - names (P.TypeSynonymDeclaration name _ _) = [P.runProperName name] - names (P.TypeClassDeclaration name _ _ _ _) = [P.runProperName name] - names (P.TypeInstanceDeclaration name _ _ _ _) = [P.showIdent name] - names (P.ExternKindDeclaration name) = [P.runProperName name] - names _ = [] + where + dtags :: P.Declaration -> [(P.Text, Int)] + dtags (P.DataDeclaration (ss, _) _ name _ dcons) = (P.runProperName name, pos ss) : consNames + where consNames = map (\(cname, _) -> (P.runProperName cname, pos ss)) dcons + dtags (P.TypeDeclaration (ss, _) ident _) = [(P.showIdent ident, pos ss)] + dtags (P.ExternDeclaration (ss, _) ident _) = [(P.showIdent ident, pos ss)] + dtags (P.TypeSynonymDeclaration (ss, _) name _ _) = [(P.runProperName name, pos ss)] + dtags (P.TypeClassDeclaration (ss, _) name _ _ _ _) = [(P.runProperName name, pos ss)] + dtags (P.TypeInstanceDeclaration (ss, _) name _ _ _ _) = [(P.showIdent name, pos ss)] + dtags (P.ExternKindDeclaration (ss, _) name) = [(P.runProperName name, pos ss)] + dtags _ = [] + pos :: P.SourceSpan -> Int + pos = P.sourcePosLine . P.spanStart diff --git a/app/Command/Hierarchy.hs b/app/Command/Hierarchy.hs --- a/app/Command/Hierarchy.hs +++ b/app/Command/Hierarchy.hs @@ -84,10 +84,9 @@ exitSuccess superClasses :: P.Declaration -> [SuperMap] -superClasses (P.TypeClassDeclaration sub _ supers@(_:_) _ _) = +superClasses (P.TypeClassDeclaration _ sub _ supers@(_:_) _ _) = fmap (\(P.Constraint (P.Qualified _ super) _ _) -> SuperMap (Right (super, sub))) supers -superClasses (P.TypeClassDeclaration sub _ _ _ _) = [SuperMap (Left sub)] -superClasses (P.PositionedDeclaration _ _ decl) = superClasses decl +superClasses (P.TypeClassDeclaration _ sub _ _ _ _) = [SuperMap (Left sub)] superClasses _ = [] inputFile :: Parser FilePath diff --git a/app/Command/REPL.hs b/app/Command/REPL.hs --- a/app/Command/REPL.hs +++ b/app/Command/REPL.hs @@ -57,7 +57,7 @@ -- | Command line options data PSCiOptions = PSCiOptions - { psciInputFile :: [FilePath] + { psciInputGlob :: [String] , psciBackend :: Backend } @@ -310,7 +310,7 @@ where loop :: PSCiOptions -> IO () loop PSCiOptions{..} = do - inputFiles <- concat <$> traverse glob psciInputFile + inputFiles <- concat <$> traverse glob psciInputGlob e <- runExceptT $ do modules <- ExceptT (loadAllModules inputFiles) when (null modules) . liftIO $ do @@ -331,7 +331,7 @@ historyFilename <- getHistoryFilename let settings = defaultSettings { historyFile = Just historyFilename } initialState = PSCiState [] [] (zip (map snd modules) externs) - config = PSCiConfig inputFiles env + config = PSCiConfig psciInputGlob env runner = flip runReaderT config . flip evalStateT initialState . runInputT (setComplete completion settings) diff --git a/app/static/pursuit.css b/app/static/pursuit.css --- a/app/static/pursuit.css +++ b/app/static/pursuit.css @@ -413,6 +413,10 @@ .decl__body .syntax { color: #0B71B4; } +.decl__child_comments { + margin-top: 1rem; + margin-bottom: 1rem; +} /* Component: Dependency Link * -------------------------------------------------------------------------- */ .deplink { diff --git a/examples/docs/src/ChildDeclOrder.purs b/examples/docs/src/ChildDeclOrder.purs new file mode 100644 --- /dev/null +++ b/examples/docs/src/ChildDeclOrder.purs @@ -0,0 +1,27 @@ +-- Tests should ensure that, in the docs: +-- - First should come before Second +-- - foo1 should be listed before foo2 +-- - the instances should be listed in the same order as this source file +module ChildDeclOrder where + +data Two + = First + | Second + +class Show a where + show :: a -> String + +class Foo a where + foo1 :: a + foo2 :: a + +instance showTwo :: Show Two where + show _ = "" + +instance fooTwo :: Foo Two where + foo1 = First + foo2 = Second + +instance fooInt :: Foo Int where + foo1 = 1 + foo2 = 2 diff --git a/examples/passing/2972.purs b/examples/passing/2972.purs new file mode 100644 --- /dev/null +++ b/examples/passing/2972.purs @@ -0,0 +1,13 @@ +module Main where + +import Control.Monad.Eff.Console (log) +import Prelude (class Show, show) + +type I t = t + +newtype Id t = Id t + +instance foo :: Show (I t) => Show (Id t) where + show (Id t) = "Done" + +main = log (show (Id "other")) diff --git a/purescript.cabal b/purescript.cabal --- a/purescript.cabal +++ b/purescript.cabal @@ -1,1049 +1,1053 @@ --- This file has been generated from package.yaml by hpack version 0.17.0. --- --- see: https://github.com/sol/hpack - -name: purescript -version: 0.11.5 -cabal-version: >= 1.10 -build-type: Simple -license: BSD3 -license-file: LICENSE -copyright: (c) 2013-17 Phil Freeman, (c) 2014-17 Gary Burgess -maintainer: Phil Freeman -stability: experimental -homepage: http://www.purescript.org/ -bug-reports: https://github.com/purescript/purescript/issues -synopsis: PureScript Programming Language Compiler -description: A small strongly, statically typed programming language with expressive types, inspired by Haskell and compiling to JavaScript. -category: Language -author: Phil Freeman , Gary Burgess , Hardy Jones , Harry Garrood , Christoph Hegemann - - -extra-source-files: - app/static/index.html - app/static/index.js - app/static/normalize.css - app/static/pursuit.css - CONTRIBUTING.md - CONTRIBUTORS.md - examples/docs/bower.json - examples/docs/bower_components/purescript-prelude/src/Prelude.purs - examples/docs/resolutions.json - examples/docs/src/Clash.purs - examples/docs/src/Clash1.purs - examples/docs/src/Clash1a.purs - examples/docs/src/Clash2.purs - examples/docs/src/Clash2a.purs - examples/docs/src/ConstrainedArgument.purs - examples/docs/src/Desugar.purs - examples/docs/src/DocComments.purs - examples/docs/src/DuplicateNames.purs - examples/docs/src/Example.purs - examples/docs/src/Example2.purs - examples/docs/src/ExplicitTypeSignatures.purs - examples/docs/src/ImportedTwice.purs - examples/docs/src/ImportedTwiceA.purs - examples/docs/src/ImportedTwiceB.purs - examples/docs/src/MultiVirtual.purs - examples/docs/src/MultiVirtual1.purs - examples/docs/src/MultiVirtual2.purs - examples/docs/src/MultiVirtual3.purs - examples/docs/src/NewOperators.purs - examples/docs/src/NewOperators2.purs - examples/docs/src/NotAllCtors.purs - examples/docs/src/ReExportedTypeClass.purs - examples/docs/src/SolitaryTypeClassMember.purs - examples/docs/src/SomeTypeClass.purs - examples/docs/src/Transitive1.purs - examples/docs/src/Transitive2.purs - examples/docs/src/Transitive3.purs - examples/docs/src/TypeClassWithFunDeps.purs - examples/docs/src/TypeClassWithoutMembers.purs - examples/docs/src/TypeClassWithoutMembersIntermediate.purs - examples/docs/src/TypeLevelString.purs - examples/docs/src/TypeOpAliases.purs - examples/docs/src/UTF8.purs - examples/docs/src/Virtual.purs - examples/failing/1071.purs - examples/failing/1169.purs - examples/failing/1175.purs - examples/failing/1310.purs - examples/failing/1570.purs - examples/failing/1733.purs - examples/failing/1733/Thingy.purs - examples/failing/1825.purs - examples/failing/1881.purs - examples/failing/2128-class.purs - examples/failing/2128-instance.purs - examples/failing/2378.purs - examples/failing/2378/Lib.purs - examples/failing/2379.purs - examples/failing/2379/Lib.purs - examples/failing/2434.purs - examples/failing/2534.purs - examples/failing/2542.purs - examples/failing/2567.purs - examples/failing/2601.purs - examples/failing/2616.purs - examples/failing/2806.purs - examples/failing/2874-forall.purs - examples/failing/2874-forall2.purs - examples/failing/2874-wildcard.purs - examples/failing/365.purs - examples/failing/438.purs - examples/failing/881.purs - examples/failing/AnonArgument1.purs - examples/failing/AnonArgument2.purs - examples/failing/AnonArgument3.purs - examples/failing/ArgLengthMismatch.purs - examples/failing/Arrays.purs - examples/failing/ArrayType.purs - examples/failing/BindInDo-2.purs - examples/failing/BindInDo.purs - examples/failing/CannotDeriveNewtypeForData.purs - examples/failing/CaseBinderLengthsDiffer.purs - examples/failing/CaseDoesNotMatchAllConstructorArgs.purs - examples/failing/ConflictingExports.purs - examples/failing/ConflictingExports/A.purs - examples/failing/ConflictingExports/B.purs - examples/failing/ConflictingImports.purs - examples/failing/ConflictingImports/A.purs - examples/failing/ConflictingImports/B.purs - examples/failing/ConflictingImports2.purs - examples/failing/ConflictingImports2/A.purs - examples/failing/ConflictingImports2/B.purs - examples/failing/ConflictingQualifiedImports.purs - examples/failing/ConflictingQualifiedImports/A.purs - examples/failing/ConflictingQualifiedImports/B.purs - examples/failing/ConflictingQualifiedImports2.purs - examples/failing/ConflictingQualifiedImports2/A.purs - examples/failing/ConflictingQualifiedImports2/B.purs - examples/failing/ConstraintFailure.purs - examples/failing/ConstraintInference.purs - examples/failing/DctorOperatorAliasExport.purs - examples/failing/DeclConflictClassCtor.purs - examples/failing/DeclConflictClassSynonym.purs - examples/failing/DeclConflictClassType.purs - examples/failing/DeclConflictCtorClass.purs - examples/failing/DeclConflictCtorCtor.purs - examples/failing/DeclConflictDuplicateCtor.purs - examples/failing/DeclConflictSynonymClass.purs - examples/failing/DeclConflictSynonymType.purs - examples/failing/DeclConflictTypeClass.purs - examples/failing/DeclConflictTypeSynonym.purs - examples/failing/DeclConflictTypeType.purs - examples/failing/DiffKindsSameName.purs - examples/failing/DiffKindsSameName/LibA.purs - examples/failing/DiffKindsSameName/LibB.purs - examples/failing/Do.purs - examples/failing/DoNotSuggestComposition.purs - examples/failing/DoNotSuggestComposition2.purs - examples/failing/DuplicateDeclarationsInLet.purs - examples/failing/DuplicateModule.purs - examples/failing/DuplicateModule/M1.purs - examples/failing/DuplicateProperties.purs - examples/failing/DuplicateTypeVars.purs - examples/failing/Eff.purs - examples/failing/EmptyCase.purs - examples/failing/EmptyClass.purs - examples/failing/EmptyDo.purs - examples/failing/ExportConflictClass.purs - examples/failing/ExportConflictClass/A.purs - examples/failing/ExportConflictClass/B.purs - examples/failing/ExportConflictCtor.purs - examples/failing/ExportConflictCtor/A.purs - examples/failing/ExportConflictCtor/B.purs - examples/failing/ExportConflictType.purs - examples/failing/ExportConflictType/A.purs - examples/failing/ExportConflictType/B.purs - examples/failing/ExportConflictTypeOp.purs - examples/failing/ExportConflictTypeOp/A.purs - examples/failing/ExportConflictTypeOp/B.purs - examples/failing/ExportConflictValue.purs - examples/failing/ExportConflictValue/A.purs - examples/failing/ExportConflictValue/B.purs - examples/failing/ExportConflictValueOp.purs - examples/failing/ExportConflictValueOp/A.purs - examples/failing/ExportConflictValueOp/B.purs - examples/failing/ExportExplicit.purs - examples/failing/ExportExplicit1.purs - examples/failing/ExportExplicit1/M1.purs - examples/failing/ExportExplicit2.purs - examples/failing/ExportExplicit3.purs - examples/failing/ExportExplicit3/M1.purs - examples/failing/ExtraRecordField.purs - examples/failing/Foldable.purs - examples/failing/Generalization1.purs - examples/failing/Generalization2.purs - examples/failing/ImportExplicit.purs - examples/failing/ImportExplicit/M1.purs - examples/failing/ImportExplicit2.purs - examples/failing/ImportExplicit2/M1.purs - examples/failing/ImportHidingModule.purs - examples/failing/ImportHidingModule/A.purs - examples/failing/ImportHidingModule/B.purs - examples/failing/ImportModule.purs - examples/failing/ImportModule/M2.purs - examples/failing/InfiniteKind.purs - examples/failing/InfiniteType.purs - examples/failing/InstanceExport.purs - examples/failing/InstanceExport/InstanceExport.purs - examples/failing/InstanceSigsBodyIncorrect.purs - examples/failing/InstanceSigsDifferentTypes.purs - examples/failing/InstanceSigsIncorrectType.purs - examples/failing/InstanceSigsOrphanTypeDeclaration.purs - examples/failing/IntOutOfRange.purs - examples/failing/InvalidDerivedInstance.purs - examples/failing/InvalidDerivedInstance2.purs - examples/failing/InvalidOperatorInBinder.purs - examples/failing/KindError.purs - examples/failing/KindStar.purs - examples/failing/LeadingZeros1.purs - examples/failing/LeadingZeros2.purs - examples/failing/Let.purs - examples/failing/LetPatterns1.purs - examples/failing/LetPatterns2.purs - examples/failing/LetPatterns3.purs - examples/failing/LetPatterns4.purs - examples/failing/MissingClassExport.purs - examples/failing/MissingClassMemberExport.purs - examples/failing/MissingRecordField.purs - examples/failing/MPTCs.purs - examples/failing/MultipleErrors.purs - examples/failing/MultipleErrors2.purs - examples/failing/MultipleTypeOpFixities.purs - examples/failing/MultipleValueOpFixities.purs - examples/failing/MutRec.purs - examples/failing/MutRec2.purs - examples/failing/NewtypeInstance.purs - examples/failing/NewtypeInstance2.purs - examples/failing/NewtypeInstance3.purs - examples/failing/NewtypeInstance4.purs - examples/failing/NewtypeInstance5.purs - examples/failing/NewtypeInstance6.purs - examples/failing/NewtypeMultiArgs.purs - examples/failing/NewtypeMultiCtor.purs - examples/failing/NonExhaustivePatGuard.purs - examples/failing/NonWildcardNewtypeInstance.purs - examples/failing/NullaryAbs.purs - examples/failing/Object.purs - examples/failing/OperatorAliasNoExport.purs - examples/failing/OperatorSections.purs - examples/failing/OrphanInstance.purs - examples/failing/OrphanInstance/Class.purs - examples/failing/OrphanInstanceFunDepCycle.purs - examples/failing/OrphanInstanceFunDepCycle/Lib.purs - examples/failing/OrphanInstanceNullary.purs - examples/failing/OrphanInstanceNullary/Lib.purs - examples/failing/OrphanInstanceWithDetermined.purs - examples/failing/OrphanInstanceWithDetermined/Lib.purs - examples/failing/OrphanTypeDecl.purs - examples/failing/OverlappingArguments.purs - examples/failing/OverlappingBinders.purs - examples/failing/OverlappingVars.purs - examples/failing/ProgrammableTypeErrors.purs - examples/failing/ProgrammableTypeErrorsTypeString.purs - examples/failing/Rank2Types.purs - examples/failing/RequiredHiddenType.purs - examples/failing/Reserved.purs - examples/failing/RowConstructors1.purs - examples/failing/RowConstructors2.purs - examples/failing/RowConstructors3.purs - examples/failing/RowInInstanceNotDetermined0.purs - examples/failing/RowInInstanceNotDetermined1.purs - examples/failing/RowInInstanceNotDetermined2.purs - examples/failing/SkolemEscape.purs - examples/failing/SkolemEscape2.purs - examples/failing/SuggestComposition.purs - examples/failing/Superclasses1.purs - examples/failing/Superclasses2.purs - examples/failing/Superclasses3.purs - examples/failing/Superclasses5.purs - examples/failing/TooFewClassInstanceArgs.purs - examples/failing/TopLevelCaseNoArgs.purs - examples/failing/TransitiveDctorExport.purs - examples/failing/TransitiveSynonymExport.purs - examples/failing/TypeClasses2.purs - examples/failing/TypeClassInstances.purs - examples/failing/TypedBinders.purs - examples/failing/TypedBinders2.purs - examples/failing/TypedBinders3.purs - examples/failing/TypedHole.purs - examples/failing/TypeError.purs - examples/failing/TypeOperatorAliasNoExport.purs - examples/failing/TypeSynonyms.purs - examples/failing/TypeSynonyms2.purs - examples/failing/TypeSynonyms3.purs - examples/failing/TypeSynonyms4.purs - examples/failing/TypeSynonyms5.purs - examples/failing/TypeWildcards1.purs - examples/failing/TypeWildcards2.purs - examples/failing/TypeWildcards3.purs - examples/failing/UnderscoreModuleName.purs - examples/failing/UnknownType.purs - examples/failing/UnusableTypeClassMethod.purs - examples/failing/UnusableTypeClassMethodConflictingIdent.purs - examples/failing/UnusableTypeClassMethodSynonym.purs - examples/passing/1110.purs - examples/passing/1185.purs - examples/passing/1335.purs - examples/passing/1570.purs - examples/passing/1664.purs - examples/passing/1697.purs - examples/passing/1807.purs - examples/passing/1881.purs - examples/passing/1991.purs - examples/passing/2018.purs - examples/passing/2018/A.purs - examples/passing/2018/B.purs - examples/passing/2049.purs - examples/passing/2136.purs - examples/passing/2138.purs - examples/passing/2138/Lib.purs - examples/passing/2172.js - examples/passing/2172.purs - examples/passing/2252.purs - examples/passing/2288.purs - examples/passing/2378.purs - examples/passing/2438.purs - examples/passing/2609.purs - examples/passing/2609/Eg.purs - examples/passing/2616.purs - examples/passing/2626.purs - examples/passing/2663.purs - examples/passing/2689.purs - examples/passing/2695.purs - examples/passing/2756.purs - examples/passing/2787.purs - examples/passing/2795.purs - examples/passing/2806.purs - examples/passing/652.purs - examples/passing/810.purs - examples/passing/862.purs - examples/passing/922.purs - examples/passing/Applicative.purs - examples/passing/ArrayType.purs - examples/passing/Auto.purs - examples/passing/AutoPrelude.purs - examples/passing/AutoPrelude2.purs - examples/passing/BindersInFunctions.purs - examples/passing/BindingGroups.purs - examples/passing/BlockString.purs - examples/passing/CaseInDo.purs - examples/passing/CaseInputWildcard.purs - examples/passing/CaseMultipleExpressions.purs - examples/passing/CaseStatement.purs - examples/passing/CheckFunction.purs - examples/passing/CheckSynonymBug.purs - examples/passing/CheckTypeClass.purs - examples/passing/Church.purs - examples/passing/ClassRefSyntax.purs - examples/passing/ClassRefSyntax/Lib.purs - examples/passing/Collatz.purs - examples/passing/Comparisons.purs - examples/passing/Conditional.purs - examples/passing/Console.purs - examples/passing/ConstraintInference.purs - examples/passing/ConstraintParens.purs - examples/passing/ConstraintParsingIssue.purs - examples/passing/ContextSimplification.purs - examples/passing/DataAndType.purs - examples/passing/DctorName.purs - examples/passing/DctorOperatorAlias.purs - examples/passing/DctorOperatorAlias/List.purs - examples/passing/DeepArrayBinder.purs - examples/passing/DeepCase.purs - examples/passing/DeriveNewtype.purs - examples/passing/DeriveWithNestedSynonyms.purs - examples/passing/Deriving.purs - examples/passing/DerivingFunctor.purs - examples/passing/Do.purs - examples/passing/Dollar.purs - examples/passing/DuplicateProperties.purs - examples/passing/Eff.purs - examples/passing/EmptyDataDecls.purs - examples/passing/EmptyRow.purs - examples/passing/EmptyTypeClass.purs - examples/passing/EntailsKindedType.purs - examples/passing/EqOrd.purs - examples/passing/ExplicitImportReExport.purs - examples/passing/ExplicitImportReExport/Bar.purs - examples/passing/ExplicitImportReExport/Foo.purs - examples/passing/ExplicitOperatorSections.purs - examples/passing/ExportedInstanceDeclarations.purs - examples/passing/ExportExplicit.purs - examples/passing/ExportExplicit/M1.purs - examples/passing/ExportExplicit2.purs - examples/passing/ExportExplicit2/M1.purs - examples/passing/ExtendedInfixOperators.purs - examples/passing/Fib.purs - examples/passing/FieldConsPuns.purs - examples/passing/FieldPuns.purs - examples/passing/FinalTagless.purs - examples/passing/ForeignKind.purs - examples/passing/ForeignKind/Lib.purs - examples/passing/FunctionalDependencies.purs - examples/passing/Functions.purs - examples/passing/Functions2.purs - examples/passing/FunctionScope.purs - examples/passing/FunWithFunDeps.js - examples/passing/FunWithFunDeps.purs - examples/passing/Generalization1.purs - examples/passing/GenericsRep.purs - examples/passing/Guards.purs - examples/passing/HasOwnProperty.purs - examples/passing/HoistError.purs - examples/passing/IfThenElseMaybe.purs - examples/passing/IfWildcard.purs - examples/passing/ImplicitEmptyImport.purs - examples/passing/Import.purs - examples/passing/Import/M1.purs - examples/passing/Import/M2.purs - examples/passing/ImportExplicit.purs - examples/passing/ImportExplicit/M1.purs - examples/passing/ImportHiding.purs - examples/passing/ImportQualified.purs - examples/passing/ImportQualified/M1.purs - examples/passing/InferRecFunWithConstrainedArgument.purs - examples/passing/InstanceBeforeClass.purs - examples/passing/InstanceSigs.purs - examples/passing/InstanceSigsGeneral.purs - examples/passing/IntAndChar.purs - examples/passing/iota.purs - examples/passing/JSReserved.purs - examples/passing/KindedType.purs - examples/passing/LargeSumType.purs - examples/passing/Let.purs - examples/passing/Let2.purs - examples/passing/LetInInstance.purs - examples/passing/LetPattern.purs - examples/passing/LiberalTypeSynonyms.purs - examples/passing/Match.purs - examples/passing/Module.purs - examples/passing/Module/M1.purs - examples/passing/Module/M2.purs - examples/passing/ModuleDeps.purs - examples/passing/ModuleDeps/M1.purs - examples/passing/ModuleDeps/M2.purs - examples/passing/ModuleDeps/M3.purs - examples/passing/ModuleExport.purs - examples/passing/ModuleExport/A.purs - examples/passing/ModuleExportDupes.purs - examples/passing/ModuleExportDupes/A.purs - examples/passing/ModuleExportDupes/B.purs - examples/passing/ModuleExportDupes/C.purs - examples/passing/ModuleExportExcluded.purs - examples/passing/ModuleExportExcluded/A.purs - examples/passing/ModuleExportQualified.purs - examples/passing/ModuleExportQualified/A.purs - examples/passing/ModuleExportSelf.purs - examples/passing/ModuleExportSelf/A.purs - examples/passing/Monad.purs - examples/passing/MonadState.purs - examples/passing/MPTCs.purs - examples/passing/MultiArgFunctions.purs - examples/passing/MutRec.purs - examples/passing/MutRec2.purs - examples/passing/MutRec3.purs - examples/passing/NakedConstraint.purs - examples/passing/NamedPatterns.purs - examples/passing/NegativeBinder.purs - examples/passing/NegativeIntInRange.purs - examples/passing/Nested.purs - examples/passing/NestedRecordUpdate.purs - examples/passing/NestedRecordUpdateWildcards.purs - examples/passing/NestedTypeSynonyms.purs - examples/passing/NestedWhere.purs - examples/passing/Newtype.purs - examples/passing/NewtypeClass.purs - examples/passing/NewtypeEff.purs - examples/passing/NewtypeInstance.purs - examples/passing/NewtypeWithRecordUpdate.purs - examples/passing/NonConflictingExports.purs - examples/passing/NonConflictingExports/A.purs - examples/passing/NonOrphanInstanceFunDepExtra.purs - examples/passing/NonOrphanInstanceFunDepExtra/Lib.purs - examples/passing/NonOrphanInstanceMulti.purs - examples/passing/NonOrphanInstanceMulti/Lib.purs - examples/passing/NumberLiterals.purs - examples/passing/ObjectGetter.purs - examples/passing/Objects.purs - examples/passing/ObjectSynonym.purs - examples/passing/ObjectUpdate.purs - examples/passing/ObjectUpdate2.purs - examples/passing/ObjectUpdater.purs - examples/passing/ObjectWildcards.purs - examples/passing/OneConstructor.purs - examples/passing/OperatorAlias.purs - examples/passing/OperatorAliasElsewhere.purs - examples/passing/OperatorAliasElsewhere/Def.purs - examples/passing/OperatorAssociativity.purs - examples/passing/OperatorInlining.purs - examples/passing/Operators.purs - examples/passing/Operators/Other.purs - examples/passing/OperatorSections.purs - examples/passing/OptimizerBug.purs - examples/passing/OptionalQualified.purs - examples/passing/OverlappingInstances.purs - examples/passing/OverlappingInstances2.purs - examples/passing/OverlappingInstances3.purs - examples/passing/ParensInTypedBinder.purs - examples/passing/PartialFunction.purs - examples/passing/Patterns.purs - examples/passing/PendingConflictingImports.purs - examples/passing/PendingConflictingImports/A.purs - examples/passing/PendingConflictingImports/B.purs - examples/passing/PendingConflictingImports2.purs - examples/passing/PendingConflictingImports2/A.purs - examples/passing/Person.purs - examples/passing/PolyLabels.js - examples/passing/PolyLabels.purs - examples/passing/PrimedTypeName.purs - examples/passing/QualifiedNames.purs - examples/passing/QualifiedNames/Either.purs - examples/passing/QualifiedQualifiedImports.purs - examples/passing/Rank2Data.purs - examples/passing/Rank2Object.purs - examples/passing/Rank2Types.purs - examples/passing/Rank2TypeSynonym.purs - examples/passing/RebindableSyntax.purs - examples/passing/Recursion.purs - examples/passing/RedefinedFixity.purs - examples/passing/RedefinedFixity/M1.purs - examples/passing/RedefinedFixity/M2.purs - examples/passing/RedefinedFixity/M3.purs - examples/passing/ReExportQualified.purs - examples/passing/ReExportQualified/A.purs - examples/passing/ReExportQualified/B.purs - examples/passing/ReExportQualified/C.purs - examples/passing/ReservedWords.purs - examples/passing/ResolvableScopeConflict.purs - examples/passing/ResolvableScopeConflict/A.purs - examples/passing/ResolvableScopeConflict/B.purs - examples/passing/ResolvableScopeConflict2.purs - examples/passing/ResolvableScopeConflict2/A.purs - examples/passing/ResolvableScopeConflict3.purs - examples/passing/ResolvableScopeConflict3/A.purs - examples/passing/RowConstructors.purs - examples/passing/RowInInstanceHeadDetermined.purs - examples/passing/RowPolyInstanceContext.purs - examples/passing/RowsInInstanceContext.purs - examples/passing/RowUnion.js - examples/passing/RowUnion.purs - examples/passing/RuntimeScopeIssue.purs - examples/passing/s.purs - examples/passing/ScopedTypeVariables.purs - examples/passing/Sequence.purs - examples/passing/SequenceDesugared.purs - examples/passing/ShadowedModuleName.purs - examples/passing/ShadowedModuleName/Test.purs - examples/passing/ShadowedName.purs - examples/passing/ShadowedRename.purs - examples/passing/ShadowedTCO.purs - examples/passing/ShadowedTCOLet.purs - examples/passing/SignedNumericLiterals.purs - examples/passing/SolvingAppendSymbol.purs - examples/passing/SolvingCompareSymbol.purs - examples/passing/SolvingIsSymbol.purs - examples/passing/SolvingIsSymbol/Lib.purs - examples/passing/Stream.purs - examples/passing/StringEdgeCases.purs - examples/passing/StringEdgeCases/Records.purs - examples/passing/StringEdgeCases/Symbols.purs - examples/passing/StringEscapes.purs - examples/passing/Superclasses1.purs - examples/passing/Superclasses3.purs - examples/passing/TailCall.purs - examples/passing/TCO.purs - examples/passing/TCOCase.purs - examples/passing/Tick.purs - examples/passing/TopLevelCase.purs - examples/passing/TransitiveImport.purs - examples/passing/TransitiveImport/Middle.purs - examples/passing/TransitiveImport/Test.purs - examples/passing/TypeClasses.purs - examples/passing/TypeClassesInOrder.purs - examples/passing/TypeClassesWithOverlappingTypeVariables.purs - examples/passing/TypeClassMemberOrderChange.purs - examples/passing/TypedBinders.purs - examples/passing/TypeDecl.purs - examples/passing/TypedWhere.purs - examples/passing/TypeOperators.purs - examples/passing/TypeOperators/A.purs - examples/passing/TypeSynonymInData.purs - examples/passing/TypeSynonyms.purs - examples/passing/TypeWildcards.purs - examples/passing/TypeWildcardsRecordExtension.purs - examples/passing/TypeWithoutParens.purs - examples/passing/TypeWithoutParens/Lib.purs - examples/passing/UnderscoreIdent.purs - examples/passing/UnicodeIdentifier.purs - examples/passing/UnicodeOperators.purs - examples/passing/UnicodeType.purs - examples/passing/UnifyInTypeInstanceLookup.purs - examples/passing/Unit.purs - examples/passing/UnknownInTypeClassLookup.purs - examples/passing/UntupledConstraints.purs - examples/passing/UsableTypeClassMethods.purs - examples/passing/UTF8Sourcefile.purs - examples/passing/Where.purs - examples/passing/WildcardInInstance.purs - examples/passing/WildcardType.purs - examples/psci/BasicEval.purs - examples/psci/Multiline.purs - examples/warning/2140.purs - examples/warning/2383.purs - examples/warning/2411.purs - examples/warning/2542.purs - examples/warning/CustomWarning.purs - examples/warning/CustomWarning2.purs - examples/warning/CustomWarning3.purs - examples/warning/DuplicateExportRef.purs - examples/warning/DuplicateImport.purs - examples/warning/DuplicateImportRef.purs - examples/warning/DuplicateSelectiveImport.purs - examples/warning/HidingImport.purs - examples/warning/ImplicitImport.purs - examples/warning/ImplicitQualifiedImport.purs - examples/warning/MissingTypeDeclaration.purs - examples/warning/NewtypeInstance.purs - examples/warning/NewtypeInstance2.purs - examples/warning/NewtypeInstance3.purs - examples/warning/NewtypeInstance4.purs - examples/warning/OverlappingInstances.purs - examples/warning/OverlappingPattern.purs - examples/warning/ScopeShadowing.purs - examples/warning/ShadowedBinderPatternGuard.purs - examples/warning/ShadowedNameParens.purs - examples/warning/ShadowedTypeVar.purs - examples/warning/UnnecessaryFFIModule.js - examples/warning/UnnecessaryFFIModule.purs - examples/warning/UnusedDctorExplicitImport.purs - examples/warning/UnusedDctorImportAll.purs - examples/warning/UnusedDctorImportExplicit.purs - examples/warning/UnusedExplicitImport.purs - examples/warning/UnusedExplicitImportTypeOp.purs - examples/warning/UnusedExplicitImportTypeOp/Lib.purs - examples/warning/UnusedExplicitImportValOp.purs - examples/warning/UnusedFFIImplementations.js - examples/warning/UnusedFFIImplementations.purs - examples/warning/UnusedImport.purs - examples/warning/UnusedTypeVar.purs - examples/warning/WildcardInferredType.purs - INSTALL.md - README.md - stack.yaml - tests/support/bower.json - tests/support/package.json - tests/support/prelude-resolutions.json - tests/support/psci/Sample.purs - tests/support/pscide/src/ImportsSpec.purs - tests/support/pscide/src/ImportsSpec1.purs - tests/support/pscide/src/MatcherSpec.purs - tests/support/pscide/src/RebuildSpecDep.purs - tests/support/pscide/src/RebuildSpecSingleModule.fail - tests/support/pscide/src/RebuildSpecSingleModule.purs - tests/support/pscide/src/RebuildSpecWithDeps.purs - tests/support/pscide/src/RebuildSpecWithForeign.js - tests/support/pscide/src/RebuildSpecWithForeign.purs - tests/support/pscide/src/RebuildSpecWithHiddenIdent.purs - tests/support/pscide/src/RebuildSpecWithMissingForeign.fail - tests/support/setup-win.cmd - -source-repository head - type: git - location: https://github.com/purescript/purescript - -flag release - description: Mark this build as a release build: prevents inclusion of extra info e.g. commit SHA in --version output) - - manual: False - default: False - -library - build-depends: - aeson >=1.0 && <1.1 - , aeson-better-errors >=0.8 - , ansi-terminal >=0.6.2 && <0.7 - , base >=4.8 && <5 - , base-compat >=0.6.0 - , blaze-html >=0.8.1 && <0.9 - , bower-json >=1.0.0.1 && <1.1 - , boxes >=0.1.4 && <0.2.0 - , bytestring - , cheapskate >=0.1 && <0.2 - , clock - , containers - , data-ordlist >=0.4.7.0 - , deepseq - , directory >=1.2.3 - , dlist - , edit-distance - , filepath - , fsnotify >=0.2.1 - , Glob >=0.7 && <0.8 - , haskeline >=0.7.0.0 - , http-client >=0.4.30 && <0.6.0 - , http-types - , language-javascript >=0.6.0.9 && <0.7 - , lens ==4.* - , lifted-base >=0.2.3 && <0.2.4 - , monad-control >=1.0.0.0 && <1.1 - , monad-logger >=0.3 && <0.4 - , mtl >=2.1.0 && <2.3.0 - , parallel >=3.2 && <3.3 - , parsec >=3.1.10 - , pattern-arrows >=0.0.2 && <0.1 - , pipes >=4.0.0 && <4.4.0 - , pipes-http - , process >=1.2.0 && <1.5 - , protolude >=0.1.6 - , regex-tdfa - , safe >=0.3.9 && <0.4 - , scientific >=0.3.4.9 && <0.4 - , semigroups >=0.16.2 && <0.19 - , sourcemap >=0.1.6 - , spdx ==0.2.* - , split - , stm >=0.2.4.0 - , stringsearch - , syb - , text - , time - , transformers >=0.3.0 && <0.6 - , transformers-base >=0.4.0 && <0.5 - , transformers-compat >=0.3.0 - , unordered-containers - , utf8-string >=1 && <2 - , vector - exposed-modules: - Control.Monad.Logger - Control.Monad.Supply - Control.Monad.Supply.Class - Language.PureScript - Language.PureScript.AST - Language.PureScript.AST.Binders - Language.PureScript.AST.Declarations - Language.PureScript.AST.Exported - Language.PureScript.AST.Literals - Language.PureScript.AST.Operators - Language.PureScript.AST.SourcePos - Language.PureScript.AST.Traversals - Language.PureScript.Bundle - Language.PureScript.CodeGen - Language.PureScript.CodeGen.JS - Language.PureScript.CodeGen.JS.Common - Language.PureScript.CodeGen.JS.Printer - Language.PureScript.Comments - Language.PureScript.Constants - Language.PureScript.CoreFn - Language.PureScript.CoreFn.Ann - Language.PureScript.CoreFn.Binders - Language.PureScript.CoreFn.Desugar - Language.PureScript.CoreFn.Expr - Language.PureScript.CoreFn.Meta - Language.PureScript.CoreFn.Module - Language.PureScript.CoreFn.ToJSON - Language.PureScript.CoreFn.Traversals - Language.PureScript.CoreImp - Language.PureScript.CoreImp.AST - Language.PureScript.CoreImp.Optimizer - Language.PureScript.CoreImp.Optimizer.Blocks - Language.PureScript.CoreImp.Optimizer.Common - Language.PureScript.CoreImp.Optimizer.Inliner - Language.PureScript.CoreImp.Optimizer.MagicDo - Language.PureScript.CoreImp.Optimizer.TCO - Language.PureScript.CoreImp.Optimizer.Unused - Language.PureScript.Crash - Language.PureScript.Docs - Language.PureScript.Docs.AsHtml - Language.PureScript.Docs.AsMarkdown - Language.PureScript.Docs.Convert - Language.PureScript.Docs.Convert.ReExports - Language.PureScript.Docs.Convert.Single - Language.PureScript.Docs.ParseInPackage - Language.PureScript.Docs.Prim - Language.PureScript.Docs.Render - Language.PureScript.Docs.RenderedCode - Language.PureScript.Docs.RenderedCode.RenderKind - Language.PureScript.Docs.RenderedCode.RenderType - Language.PureScript.Docs.RenderedCode.Types - Language.PureScript.Docs.Types - Language.PureScript.Docs.Utils.MonoidExtras - Language.PureScript.Environment - Language.PureScript.Errors - Language.PureScript.Errors.JSON - Language.PureScript.Externs - Language.PureScript.Ide - Language.PureScript.Ide.CaseSplit - Language.PureScript.Ide.Command - Language.PureScript.Ide.Completion - Language.PureScript.Ide.Error - Language.PureScript.Ide.Externs - Language.PureScript.Ide.Filter - Language.PureScript.Ide.Imports - Language.PureScript.Ide.Logging - Language.PureScript.Ide.Matcher - Language.PureScript.Ide.Pursuit - Language.PureScript.Ide.Rebuild - Language.PureScript.Ide.Reexports - Language.PureScript.Ide.SourceFile - Language.PureScript.Ide.State - Language.PureScript.Ide.Types - Language.PureScript.Ide.Util - Language.PureScript.Ide.Watcher - Language.PureScript.Interactive - Language.PureScript.Interactive.Completion - Language.PureScript.Interactive.Directive - Language.PureScript.Interactive.IO - Language.PureScript.Interactive.Message - Language.PureScript.Interactive.Module - Language.PureScript.Interactive.Parser - Language.PureScript.Interactive.Printer - Language.PureScript.Interactive.Types - Language.PureScript.Kinds - Language.PureScript.Label - Language.PureScript.Linter - Language.PureScript.Linter.Exhaustive - Language.PureScript.Linter.Imports - Language.PureScript.Make - Language.PureScript.ModuleDependencies - Language.PureScript.Names - Language.PureScript.Options - Language.PureScript.Parser - Language.PureScript.Parser.Common - Language.PureScript.Parser.Declarations - Language.PureScript.Parser.Kinds - Language.PureScript.Parser.Lexer - Language.PureScript.Parser.State - Language.PureScript.Parser.Types - Language.PureScript.Pretty - Language.PureScript.Pretty.Common - Language.PureScript.Pretty.Kinds - Language.PureScript.Pretty.Types - Language.PureScript.Pretty.Values - Language.PureScript.PSString - Language.PureScript.Publish - Language.PureScript.Publish.BoxesHelpers - Language.PureScript.Publish.ErrorsWarnings - Language.PureScript.Publish.Utils - Language.PureScript.Renamer - Language.PureScript.Sugar - Language.PureScript.Sugar.BindingGroups - Language.PureScript.Sugar.CaseDeclarations - Language.PureScript.Sugar.DoNotation - Language.PureScript.Sugar.LetPattern - Language.PureScript.Sugar.Names - Language.PureScript.Sugar.Names.Common - Language.PureScript.Sugar.Names.Env - Language.PureScript.Sugar.Names.Exports - Language.PureScript.Sugar.Names.Imports - Language.PureScript.Sugar.ObjectWildcards - Language.PureScript.Sugar.Operators - Language.PureScript.Sugar.Operators.Binders - Language.PureScript.Sugar.Operators.Common - Language.PureScript.Sugar.Operators.Expr - Language.PureScript.Sugar.Operators.Types - Language.PureScript.Sugar.TypeClasses - Language.PureScript.Sugar.TypeClasses.Deriving - Language.PureScript.Sugar.TypeDeclarations - Language.PureScript.Traversals - Language.PureScript.TypeChecker - Language.PureScript.TypeChecker.Entailment - Language.PureScript.TypeChecker.Kinds - Language.PureScript.TypeChecker.Monad - Language.PureScript.TypeChecker.Skolems - Language.PureScript.TypeChecker.Subsumption - Language.PureScript.TypeChecker.Synonyms - Language.PureScript.TypeChecker.Types - Language.PureScript.TypeChecker.TypeSearch - Language.PureScript.TypeChecker.Unify - Language.PureScript.TypeClassDictionaries - Language.PureScript.Types - System.IO.UTF8 - other-modules: - Paths_purescript - hs-source-dirs: - src - default-extensions: ConstraintKinds DataKinds DeriveFunctor EmptyDataDecls FlexibleContexts KindSignatures LambdaCase MultiParamTypeClasses NoImplicitPrelude PatternGuards PatternSynonyms RankNTypes RecordWildCards OverloadedStrings ScopedTypeVariables TupleSections ViewPatterns - default-language: Haskell2010 - ghc-options: -Wall -O2 - -executable purs - build-depends: - aeson >=1.0 && <1.1 - , aeson-better-errors >=0.8 - , ansi-terminal >=0.6.2 && <0.7 - , base >=4.8 && <5 - , base-compat >=0.6.0 - , blaze-html >=0.8.1 && <0.9 - , bower-json >=1.0.0.1 && <1.1 - , boxes >=0.1.4 && <0.2.0 - , bytestring - , cheapskate >=0.1 && <0.2 - , clock - , containers - , data-ordlist >=0.4.7.0 - , deepseq - , directory >=1.2.3 - , dlist - , edit-distance - , filepath - , fsnotify >=0.2.1 - , Glob >=0.7 && <0.8 - , haskeline >=0.7.0.0 - , http-client >=0.4.30 && <0.6.0 - , http-types - , language-javascript >=0.6.0.9 && <0.7 - , lens ==4.* - , lifted-base >=0.2.3 && <0.2.4 - , monad-control >=1.0.0.0 && <1.1 - , monad-logger >=0.3 && <0.4 - , mtl >=2.1.0 && <2.3.0 - , parallel >=3.2 && <3.3 - , parsec >=3.1.10 - , pattern-arrows >=0.0.2 && <0.1 - , pipes >=4.0.0 && <4.4.0 - , pipes-http - , process >=1.2.0 && <1.5 - , protolude >=0.1.6 - , regex-tdfa - , safe >=0.3.9 && <0.4 - , scientific >=0.3.4.9 && <0.4 - , semigroups >=0.16.2 && <0.19 - , sourcemap >=0.1.6 - , spdx ==0.2.* - , split - , stm >=0.2.4.0 - , stringsearch - , syb - , text - , time - , transformers >=0.3.0 && <0.6 - , transformers-base >=0.4.0 && <0.5 - , transformers-compat >=0.3.0 - , unordered-containers - , utf8-string >=1 && <2 - , vector - , ansi-wl-pprint - , file-embed - , network - , optparse-applicative >=0.13.0 - , purescript - , wai ==3.* - , wai-websockets ==3.* - , warp ==3.* - , websockets >=0.9 && <0.11 - if flag(release) - cpp-options: -DRELEASE - else - build-depends: - gitrev >=1.2.0 && <1.3 - main-is: Main.hs - hs-source-dirs: - app - other-modules: - Command.Bundle - Command.Compile - Command.Docs - Command.Docs.Ctags - Command.Docs.Etags - Command.Docs.Html - Command.Docs.Tags - Command.Hierarchy - Command.Ide - Command.Publish - Command.REPL - Version - default-language: Haskell2010 - ghc-options: -Wall -O2 -fno-warn-unused-do-bind -threaded -rtsopts -with-rtsopts=-N - -test-suite tests - build-depends: - aeson >=1.0 && <1.1 - , aeson-better-errors >=0.8 - , ansi-terminal >=0.6.2 && <0.7 - , base >=4.8 && <5 - , base-compat >=0.6.0 - , blaze-html >=0.8.1 && <0.9 - , bower-json >=1.0.0.1 && <1.1 - , boxes >=0.1.4 && <0.2.0 - , bytestring - , cheapskate >=0.1 && <0.2 - , clock - , containers - , data-ordlist >=0.4.7.0 - , deepseq - , directory >=1.2.3 - , dlist - , edit-distance - , filepath - , fsnotify >=0.2.1 - , Glob >=0.7 && <0.8 - , haskeline >=0.7.0.0 - , http-client >=0.4.30 && <0.6.0 - , http-types - , language-javascript >=0.6.0.9 && <0.7 - , lens ==4.* - , lifted-base >=0.2.3 && <0.2.4 - , monad-control >=1.0.0.0 && <1.1 - , monad-logger >=0.3 && <0.4 - , mtl >=2.1.0 && <2.3.0 - , parallel >=3.2 && <3.3 - , parsec >=3.1.10 - , pattern-arrows >=0.0.2 && <0.1 - , pipes >=4.0.0 && <4.4.0 - , pipes-http - , process >=1.2.0 && <1.5 - , protolude >=0.1.6 - , regex-tdfa - , safe >=0.3.9 && <0.4 - , scientific >=0.3.4.9 && <0.4 - , semigroups >=0.16.2 && <0.19 - , sourcemap >=0.1.6 - , spdx ==0.2.* - , split - , stm >=0.2.4.0 - , stringsearch - , syb - , text - , time - , transformers >=0.3.0 && <0.6 - , transformers-base >=0.4.0 && <0.5 - , transformers-compat >=0.3.0 - , unordered-containers - , utf8-string >=1 && <2 - , vector - , purescript - , hspec - , hspec-discover - , HUnit - , silently - ghc-options: -Wall - type: exitcode-stdio-1.0 - main-is: Main.hs - other-modules: - Language.PureScript.Ide.CompletionSpec - Language.PureScript.Ide.FilterSpec - Language.PureScript.Ide.ImportsSpec - Language.PureScript.Ide.MatcherSpec - Language.PureScript.Ide.RebuildSpec - Language.PureScript.Ide.ReexportsSpec - Language.PureScript.Ide.SourceFileSpec - Language.PureScript.Ide.StateSpec - Language.PureScript.Ide.Test - PscIdeSpec - TestCompiler - TestDocs - TestPrimDocs - TestPsci - TestPsci.CommandTest - TestPsci.CompletionTest - TestPsci.EvalTest - TestPsci.TestEnv - TestPscIde - TestPscPublish - TestUtils - default-language: Haskell2010 - hs-source-dirs: - tests +-- This file has been generated from package.yaml by hpack version 0.15.0. +-- +-- see: https://github.com/sol/hpack + +name: purescript +version: 0.11.6 +synopsis: PureScript Programming Language Compiler +description: A small strongly, statically typed programming language with expressive types, inspired by Haskell and compiling to JavaScript. +category: Language +stability: experimental +homepage: http://www.purescript.org/ +bug-reports: https://github.com/purescript/purescript/issues +author: Phil Freeman , Gary Burgess , Hardy Jones , Harry Garrood , Christoph Hegemann + +maintainer: Phil Freeman +copyright: (c) 2013-17 Phil Freeman, (c) 2014-17 Gary Burgess +license: BSD3 +license-file: LICENSE +build-type: Simple +cabal-version: >= 1.10 + +extra-source-files: + app/static/index.html + app/static/index.js + app/static/normalize.css + app/static/pursuit.css + CONTRIBUTING.md + CONTRIBUTORS.md + examples/docs/bower.json + examples/docs/bower_components/purescript-prelude/src/Prelude.purs + examples/docs/resolutions.json + examples/docs/src/ChildDeclOrder.purs + examples/docs/src/Clash.purs + examples/docs/src/Clash1.purs + examples/docs/src/Clash1a.purs + examples/docs/src/Clash2.purs + examples/docs/src/Clash2a.purs + examples/docs/src/ConstrainedArgument.purs + examples/docs/src/Desugar.purs + examples/docs/src/DocComments.purs + examples/docs/src/DuplicateNames.purs + examples/docs/src/Example.purs + examples/docs/src/Example2.purs + examples/docs/src/ExplicitTypeSignatures.purs + examples/docs/src/ImportedTwice.purs + examples/docs/src/ImportedTwiceA.purs + examples/docs/src/ImportedTwiceB.purs + examples/docs/src/MultiVirtual.purs + examples/docs/src/MultiVirtual1.purs + examples/docs/src/MultiVirtual2.purs + examples/docs/src/MultiVirtual3.purs + examples/docs/src/NewOperators.purs + examples/docs/src/NewOperators2.purs + examples/docs/src/NotAllCtors.purs + examples/docs/src/ReExportedTypeClass.purs + examples/docs/src/SolitaryTypeClassMember.purs + examples/docs/src/SomeTypeClass.purs + examples/docs/src/Transitive1.purs + examples/docs/src/Transitive2.purs + examples/docs/src/Transitive3.purs + examples/docs/src/TypeClassWithFunDeps.purs + examples/docs/src/TypeClassWithoutMembers.purs + examples/docs/src/TypeClassWithoutMembersIntermediate.purs + examples/docs/src/TypeLevelString.purs + examples/docs/src/TypeOpAliases.purs + examples/docs/src/UTF8.purs + examples/docs/src/Virtual.purs + examples/failing/1071.purs + examples/failing/1169.purs + examples/failing/1175.purs + examples/failing/1310.purs + examples/failing/1570.purs + examples/failing/1733.purs + examples/failing/1733/Thingy.purs + examples/failing/1825.purs + examples/failing/1881.purs + examples/failing/2128-class.purs + examples/failing/2128-instance.purs + examples/failing/2378.purs + examples/failing/2378/Lib.purs + examples/failing/2379.purs + examples/failing/2379/Lib.purs + examples/failing/2434.purs + examples/failing/2534.purs + examples/failing/2542.purs + examples/failing/2567.purs + examples/failing/2601.purs + examples/failing/2616.purs + examples/failing/2806.purs + examples/failing/2874-forall.purs + examples/failing/2874-forall2.purs + examples/failing/2874-wildcard.purs + examples/failing/365.purs + examples/failing/438.purs + examples/failing/881.purs + examples/failing/AnonArgument1.purs + examples/failing/AnonArgument2.purs + examples/failing/AnonArgument3.purs + examples/failing/ArgLengthMismatch.purs + examples/failing/Arrays.purs + examples/failing/ArrayType.purs + examples/failing/BindInDo-2.purs + examples/failing/BindInDo.purs + examples/failing/CannotDeriveNewtypeForData.purs + examples/failing/CaseBinderLengthsDiffer.purs + examples/failing/CaseDoesNotMatchAllConstructorArgs.purs + examples/failing/ConflictingExports.purs + examples/failing/ConflictingExports/A.purs + examples/failing/ConflictingExports/B.purs + examples/failing/ConflictingImports.purs + examples/failing/ConflictingImports/A.purs + examples/failing/ConflictingImports/B.purs + examples/failing/ConflictingImports2.purs + examples/failing/ConflictingImports2/A.purs + examples/failing/ConflictingImports2/B.purs + examples/failing/ConflictingQualifiedImports.purs + examples/failing/ConflictingQualifiedImports/A.purs + examples/failing/ConflictingQualifiedImports/B.purs + examples/failing/ConflictingQualifiedImports2.purs + examples/failing/ConflictingQualifiedImports2/A.purs + examples/failing/ConflictingQualifiedImports2/B.purs + examples/failing/ConstraintFailure.purs + examples/failing/ConstraintInference.purs + examples/failing/DctorOperatorAliasExport.purs + examples/failing/DeclConflictClassCtor.purs + examples/failing/DeclConflictClassSynonym.purs + examples/failing/DeclConflictClassType.purs + examples/failing/DeclConflictCtorClass.purs + examples/failing/DeclConflictCtorCtor.purs + examples/failing/DeclConflictDuplicateCtor.purs + examples/failing/DeclConflictSynonymClass.purs + examples/failing/DeclConflictSynonymType.purs + examples/failing/DeclConflictTypeClass.purs + examples/failing/DeclConflictTypeSynonym.purs + examples/failing/DeclConflictTypeType.purs + examples/failing/DiffKindsSameName.purs + examples/failing/DiffKindsSameName/LibA.purs + examples/failing/DiffKindsSameName/LibB.purs + examples/failing/Do.purs + examples/failing/DoNotSuggestComposition.purs + examples/failing/DoNotSuggestComposition2.purs + examples/failing/DuplicateDeclarationsInLet.purs + examples/failing/DuplicateModule.purs + examples/failing/DuplicateModule/M1.purs + examples/failing/DuplicateProperties.purs + examples/failing/DuplicateTypeVars.purs + examples/failing/Eff.purs + examples/failing/EmptyCase.purs + examples/failing/EmptyClass.purs + examples/failing/EmptyDo.purs + examples/failing/ExportConflictClass.purs + examples/failing/ExportConflictClass/A.purs + examples/failing/ExportConflictClass/B.purs + examples/failing/ExportConflictCtor.purs + examples/failing/ExportConflictCtor/A.purs + examples/failing/ExportConflictCtor/B.purs + examples/failing/ExportConflictType.purs + examples/failing/ExportConflictType/A.purs + examples/failing/ExportConflictType/B.purs + examples/failing/ExportConflictTypeOp.purs + examples/failing/ExportConflictTypeOp/A.purs + examples/failing/ExportConflictTypeOp/B.purs + examples/failing/ExportConflictValue.purs + examples/failing/ExportConflictValue/A.purs + examples/failing/ExportConflictValue/B.purs + examples/failing/ExportConflictValueOp.purs + examples/failing/ExportConflictValueOp/A.purs + examples/failing/ExportConflictValueOp/B.purs + examples/failing/ExportExplicit.purs + examples/failing/ExportExplicit1.purs + examples/failing/ExportExplicit1/M1.purs + examples/failing/ExportExplicit2.purs + examples/failing/ExportExplicit3.purs + examples/failing/ExportExplicit3/M1.purs + examples/failing/ExtraRecordField.purs + examples/failing/Foldable.purs + examples/failing/Generalization1.purs + examples/failing/Generalization2.purs + examples/failing/ImportExplicit.purs + examples/failing/ImportExplicit/M1.purs + examples/failing/ImportExplicit2.purs + examples/failing/ImportExplicit2/M1.purs + examples/failing/ImportHidingModule.purs + examples/failing/ImportHidingModule/A.purs + examples/failing/ImportHidingModule/B.purs + examples/failing/ImportModule.purs + examples/failing/ImportModule/M2.purs + examples/failing/InfiniteKind.purs + examples/failing/InfiniteType.purs + examples/failing/InstanceExport.purs + examples/failing/InstanceExport/InstanceExport.purs + examples/failing/InstanceSigsBodyIncorrect.purs + examples/failing/InstanceSigsDifferentTypes.purs + examples/failing/InstanceSigsIncorrectType.purs + examples/failing/InstanceSigsOrphanTypeDeclaration.purs + examples/failing/IntOutOfRange.purs + examples/failing/InvalidDerivedInstance.purs + examples/failing/InvalidDerivedInstance2.purs + examples/failing/InvalidOperatorInBinder.purs + examples/failing/KindError.purs + examples/failing/KindStar.purs + examples/failing/LeadingZeros1.purs + examples/failing/LeadingZeros2.purs + examples/failing/Let.purs + examples/failing/LetPatterns1.purs + examples/failing/LetPatterns2.purs + examples/failing/LetPatterns3.purs + examples/failing/LetPatterns4.purs + examples/failing/MissingClassExport.purs + examples/failing/MissingClassMemberExport.purs + examples/failing/MissingRecordField.purs + examples/failing/MPTCs.purs + examples/failing/MultipleErrors.purs + examples/failing/MultipleErrors2.purs + examples/failing/MultipleTypeOpFixities.purs + examples/failing/MultipleValueOpFixities.purs + examples/failing/MutRec.purs + examples/failing/MutRec2.purs + examples/failing/NewtypeInstance.purs + examples/failing/NewtypeInstance2.purs + examples/failing/NewtypeInstance3.purs + examples/failing/NewtypeInstance4.purs + examples/failing/NewtypeInstance5.purs + examples/failing/NewtypeInstance6.purs + examples/failing/NewtypeMultiArgs.purs + examples/failing/NewtypeMultiCtor.purs + examples/failing/NonExhaustivePatGuard.purs + examples/failing/NonWildcardNewtypeInstance.purs + examples/failing/NullaryAbs.purs + examples/failing/Object.purs + examples/failing/OperatorAliasNoExport.purs + examples/failing/OperatorSections.purs + examples/failing/OrphanInstance.purs + examples/failing/OrphanInstance/Class.purs + examples/failing/OrphanInstanceFunDepCycle.purs + examples/failing/OrphanInstanceFunDepCycle/Lib.purs + examples/failing/OrphanInstanceNullary.purs + examples/failing/OrphanInstanceNullary/Lib.purs + examples/failing/OrphanInstanceWithDetermined.purs + examples/failing/OrphanInstanceWithDetermined/Lib.purs + examples/failing/OrphanTypeDecl.purs + examples/failing/OverlappingArguments.purs + examples/failing/OverlappingBinders.purs + examples/failing/OverlappingVars.purs + examples/failing/ProgrammableTypeErrors.purs + examples/failing/ProgrammableTypeErrorsTypeString.purs + examples/failing/Rank2Types.purs + examples/failing/RequiredHiddenType.purs + examples/failing/Reserved.purs + examples/failing/RowConstructors1.purs + examples/failing/RowConstructors2.purs + examples/failing/RowConstructors3.purs + examples/failing/RowInInstanceNotDetermined0.purs + examples/failing/RowInInstanceNotDetermined1.purs + examples/failing/RowInInstanceNotDetermined2.purs + examples/failing/SkolemEscape.purs + examples/failing/SkolemEscape2.purs + examples/failing/SuggestComposition.purs + examples/failing/Superclasses1.purs + examples/failing/Superclasses2.purs + examples/failing/Superclasses3.purs + examples/failing/Superclasses5.purs + examples/failing/TooFewClassInstanceArgs.purs + examples/failing/TopLevelCaseNoArgs.purs + examples/failing/TransitiveDctorExport.purs + examples/failing/TransitiveSynonymExport.purs + examples/failing/TypeClasses2.purs + examples/failing/TypeClassInstances.purs + examples/failing/TypedBinders.purs + examples/failing/TypedBinders2.purs + examples/failing/TypedBinders3.purs + examples/failing/TypedHole.purs + examples/failing/TypeError.purs + examples/failing/TypeOperatorAliasNoExport.purs + examples/failing/TypeSynonyms.purs + examples/failing/TypeSynonyms2.purs + examples/failing/TypeSynonyms3.purs + examples/failing/TypeSynonyms4.purs + examples/failing/TypeSynonyms5.purs + examples/failing/TypeWildcards1.purs + examples/failing/TypeWildcards2.purs + examples/failing/TypeWildcards3.purs + examples/failing/UnderscoreModuleName.purs + examples/failing/UnknownType.purs + examples/failing/UnusableTypeClassMethod.purs + examples/failing/UnusableTypeClassMethodConflictingIdent.purs + examples/failing/UnusableTypeClassMethodSynonym.purs + examples/passing/1110.purs + examples/passing/1185.purs + examples/passing/1335.purs + examples/passing/1570.purs + examples/passing/1664.purs + examples/passing/1697.purs + examples/passing/1807.purs + examples/passing/1881.purs + examples/passing/1991.purs + examples/passing/2018.purs + examples/passing/2018/A.purs + examples/passing/2018/B.purs + examples/passing/2049.purs + examples/passing/2136.purs + examples/passing/2138.purs + examples/passing/2138/Lib.purs + examples/passing/2172.js + examples/passing/2172.purs + examples/passing/2252.purs + examples/passing/2288.purs + examples/passing/2378.purs + examples/passing/2438.purs + examples/passing/2609.purs + examples/passing/2609/Eg.purs + examples/passing/2616.purs + examples/passing/2626.purs + examples/passing/2663.purs + examples/passing/2689.purs + examples/passing/2695.purs + examples/passing/2756.purs + examples/passing/2787.purs + examples/passing/2795.purs + examples/passing/2806.purs + examples/passing/2972.purs + examples/passing/652.purs + examples/passing/810.purs + examples/passing/862.purs + examples/passing/922.purs + examples/passing/Applicative.purs + examples/passing/ArrayType.purs + examples/passing/Auto.purs + examples/passing/AutoPrelude.purs + examples/passing/AutoPrelude2.purs + examples/passing/BindersInFunctions.purs + examples/passing/BindingGroups.purs + examples/passing/BlockString.purs + examples/passing/CaseInDo.purs + examples/passing/CaseInputWildcard.purs + examples/passing/CaseMultipleExpressions.purs + examples/passing/CaseStatement.purs + examples/passing/CheckFunction.purs + examples/passing/CheckSynonymBug.purs + examples/passing/CheckTypeClass.purs + examples/passing/Church.purs + examples/passing/ClassRefSyntax.purs + examples/passing/ClassRefSyntax/Lib.purs + examples/passing/Collatz.purs + examples/passing/Comparisons.purs + examples/passing/Conditional.purs + examples/passing/Console.purs + examples/passing/ConstraintInference.purs + examples/passing/ConstraintParens.purs + examples/passing/ConstraintParsingIssue.purs + examples/passing/ContextSimplification.purs + examples/passing/DataAndType.purs + examples/passing/DctorName.purs + examples/passing/DctorOperatorAlias.purs + examples/passing/DctorOperatorAlias/List.purs + examples/passing/DeepArrayBinder.purs + examples/passing/DeepCase.purs + examples/passing/DeriveNewtype.purs + examples/passing/DeriveWithNestedSynonyms.purs + examples/passing/Deriving.purs + examples/passing/DerivingFunctor.purs + examples/passing/Do.purs + examples/passing/Dollar.purs + examples/passing/DuplicateProperties.purs + examples/passing/Eff.purs + examples/passing/EmptyDataDecls.purs + examples/passing/EmptyRow.purs + examples/passing/EmptyTypeClass.purs + examples/passing/EntailsKindedType.purs + examples/passing/EqOrd.purs + examples/passing/ExplicitImportReExport.purs + examples/passing/ExplicitImportReExport/Bar.purs + examples/passing/ExplicitImportReExport/Foo.purs + examples/passing/ExplicitOperatorSections.purs + examples/passing/ExportedInstanceDeclarations.purs + examples/passing/ExportExplicit.purs + examples/passing/ExportExplicit/M1.purs + examples/passing/ExportExplicit2.purs + examples/passing/ExportExplicit2/M1.purs + examples/passing/ExtendedInfixOperators.purs + examples/passing/Fib.purs + examples/passing/FieldConsPuns.purs + examples/passing/FieldPuns.purs + examples/passing/FinalTagless.purs + examples/passing/ForeignKind.purs + examples/passing/ForeignKind/Lib.purs + examples/passing/FunctionalDependencies.purs + examples/passing/Functions.purs + examples/passing/Functions2.purs + examples/passing/FunctionScope.purs + examples/passing/FunWithFunDeps.js + examples/passing/FunWithFunDeps.purs + examples/passing/Generalization1.purs + examples/passing/GenericsRep.purs + examples/passing/Guards.purs + examples/passing/HasOwnProperty.purs + examples/passing/HoistError.purs + examples/passing/IfThenElseMaybe.purs + examples/passing/IfWildcard.purs + examples/passing/ImplicitEmptyImport.purs + examples/passing/Import.purs + examples/passing/Import/M1.purs + examples/passing/Import/M2.purs + examples/passing/ImportExplicit.purs + examples/passing/ImportExplicit/M1.purs + examples/passing/ImportHiding.purs + examples/passing/ImportQualified.purs + examples/passing/ImportQualified/M1.purs + examples/passing/InferRecFunWithConstrainedArgument.purs + examples/passing/InstanceBeforeClass.purs + examples/passing/InstanceSigs.purs + examples/passing/InstanceSigsGeneral.purs + examples/passing/IntAndChar.purs + examples/passing/iota.purs + examples/passing/JSReserved.purs + examples/passing/KindedType.purs + examples/passing/LargeSumType.purs + examples/passing/Let.purs + examples/passing/Let2.purs + examples/passing/LetInInstance.purs + examples/passing/LetPattern.purs + examples/passing/LiberalTypeSynonyms.purs + examples/passing/Match.purs + examples/passing/Module.purs + examples/passing/Module/M1.purs + examples/passing/Module/M2.purs + examples/passing/ModuleDeps.purs + examples/passing/ModuleDeps/M1.purs + examples/passing/ModuleDeps/M2.purs + examples/passing/ModuleDeps/M3.purs + examples/passing/ModuleExport.purs + examples/passing/ModuleExport/A.purs + examples/passing/ModuleExportDupes.purs + examples/passing/ModuleExportDupes/A.purs + examples/passing/ModuleExportDupes/B.purs + examples/passing/ModuleExportDupes/C.purs + examples/passing/ModuleExportExcluded.purs + examples/passing/ModuleExportExcluded/A.purs + examples/passing/ModuleExportQualified.purs + examples/passing/ModuleExportQualified/A.purs + examples/passing/ModuleExportSelf.purs + examples/passing/ModuleExportSelf/A.purs + examples/passing/Monad.purs + examples/passing/MonadState.purs + examples/passing/MPTCs.purs + examples/passing/MultiArgFunctions.purs + examples/passing/MutRec.purs + examples/passing/MutRec2.purs + examples/passing/MutRec3.purs + examples/passing/NakedConstraint.purs + examples/passing/NamedPatterns.purs + examples/passing/NegativeBinder.purs + examples/passing/NegativeIntInRange.purs + examples/passing/Nested.purs + examples/passing/NestedRecordUpdate.purs + examples/passing/NestedRecordUpdateWildcards.purs + examples/passing/NestedTypeSynonyms.purs + examples/passing/NestedWhere.purs + examples/passing/Newtype.purs + examples/passing/NewtypeClass.purs + examples/passing/NewtypeEff.purs + examples/passing/NewtypeInstance.purs + examples/passing/NewtypeWithRecordUpdate.purs + examples/passing/NonConflictingExports.purs + examples/passing/NonConflictingExports/A.purs + examples/passing/NonOrphanInstanceFunDepExtra.purs + examples/passing/NonOrphanInstanceFunDepExtra/Lib.purs + examples/passing/NonOrphanInstanceMulti.purs + examples/passing/NonOrphanInstanceMulti/Lib.purs + examples/passing/NumberLiterals.purs + examples/passing/ObjectGetter.purs + examples/passing/Objects.purs + examples/passing/ObjectSynonym.purs + examples/passing/ObjectUpdate.purs + examples/passing/ObjectUpdate2.purs + examples/passing/ObjectUpdater.purs + examples/passing/ObjectWildcards.purs + examples/passing/OneConstructor.purs + examples/passing/OperatorAlias.purs + examples/passing/OperatorAliasElsewhere.purs + examples/passing/OperatorAliasElsewhere/Def.purs + examples/passing/OperatorAssociativity.purs + examples/passing/OperatorInlining.purs + examples/passing/Operators.purs + examples/passing/Operators/Other.purs + examples/passing/OperatorSections.purs + examples/passing/OptimizerBug.purs + examples/passing/OptionalQualified.purs + examples/passing/OverlappingInstances.purs + examples/passing/OverlappingInstances2.purs + examples/passing/OverlappingInstances3.purs + examples/passing/ParensInTypedBinder.purs + examples/passing/PartialFunction.purs + examples/passing/Patterns.purs + examples/passing/PendingConflictingImports.purs + examples/passing/PendingConflictingImports/A.purs + examples/passing/PendingConflictingImports/B.purs + examples/passing/PendingConflictingImports2.purs + examples/passing/PendingConflictingImports2/A.purs + examples/passing/Person.purs + examples/passing/PolyLabels.js + examples/passing/PolyLabels.purs + examples/passing/PrimedTypeName.purs + examples/passing/QualifiedNames.purs + examples/passing/QualifiedNames/Either.purs + examples/passing/QualifiedQualifiedImports.purs + examples/passing/Rank2Data.purs + examples/passing/Rank2Object.purs + examples/passing/Rank2Types.purs + examples/passing/Rank2TypeSynonym.purs + examples/passing/RebindableSyntax.purs + examples/passing/Recursion.purs + examples/passing/RedefinedFixity.purs + examples/passing/RedefinedFixity/M1.purs + examples/passing/RedefinedFixity/M2.purs + examples/passing/RedefinedFixity/M3.purs + examples/passing/ReExportQualified.purs + examples/passing/ReExportQualified/A.purs + examples/passing/ReExportQualified/B.purs + examples/passing/ReExportQualified/C.purs + examples/passing/ReservedWords.purs + examples/passing/ResolvableScopeConflict.purs + examples/passing/ResolvableScopeConflict/A.purs + examples/passing/ResolvableScopeConflict/B.purs + examples/passing/ResolvableScopeConflict2.purs + examples/passing/ResolvableScopeConflict2/A.purs + examples/passing/ResolvableScopeConflict3.purs + examples/passing/ResolvableScopeConflict3/A.purs + examples/passing/RowConstructors.purs + examples/passing/RowInInstanceHeadDetermined.purs + examples/passing/RowPolyInstanceContext.purs + examples/passing/RowsInInstanceContext.purs + examples/passing/RowUnion.js + examples/passing/RowUnion.purs + examples/passing/RuntimeScopeIssue.purs + examples/passing/s.purs + examples/passing/ScopedTypeVariables.purs + examples/passing/Sequence.purs + examples/passing/SequenceDesugared.purs + examples/passing/ShadowedModuleName.purs + examples/passing/ShadowedModuleName/Test.purs + examples/passing/ShadowedName.purs + examples/passing/ShadowedRename.purs + examples/passing/ShadowedTCO.purs + examples/passing/ShadowedTCOLet.purs + examples/passing/SignedNumericLiterals.purs + examples/passing/SolvingAppendSymbol.purs + examples/passing/SolvingCompareSymbol.purs + examples/passing/SolvingIsSymbol.purs + examples/passing/SolvingIsSymbol/Lib.purs + examples/passing/Stream.purs + examples/passing/StringEdgeCases.purs + examples/passing/StringEdgeCases/Records.purs + examples/passing/StringEdgeCases/Symbols.purs + examples/passing/StringEscapes.purs + examples/passing/Superclasses1.purs + examples/passing/Superclasses3.purs + examples/passing/TailCall.purs + examples/passing/TCO.purs + examples/passing/TCOCase.purs + examples/passing/Tick.purs + examples/passing/TopLevelCase.purs + examples/passing/TransitiveImport.purs + examples/passing/TransitiveImport/Middle.purs + examples/passing/TransitiveImport/Test.purs + examples/passing/TypeClasses.purs + examples/passing/TypeClassesInOrder.purs + examples/passing/TypeClassesWithOverlappingTypeVariables.purs + examples/passing/TypeClassMemberOrderChange.purs + examples/passing/TypedBinders.purs + examples/passing/TypeDecl.purs + examples/passing/TypedWhere.purs + examples/passing/TypeOperators.purs + examples/passing/TypeOperators/A.purs + examples/passing/TypeSynonymInData.purs + examples/passing/TypeSynonyms.purs + examples/passing/TypeWildcards.purs + examples/passing/TypeWildcardsRecordExtension.purs + examples/passing/TypeWithoutParens.purs + examples/passing/TypeWithoutParens/Lib.purs + examples/passing/UnderscoreIdent.purs + examples/passing/UnicodeIdentifier.purs + examples/passing/UnicodeOperators.purs + examples/passing/UnicodeType.purs + examples/passing/UnifyInTypeInstanceLookup.purs + examples/passing/Unit.purs + examples/passing/UnknownInTypeClassLookup.purs + examples/passing/UntupledConstraints.purs + examples/passing/UsableTypeClassMethods.purs + examples/passing/UTF8Sourcefile.purs + examples/passing/Where.purs + examples/passing/WildcardInInstance.purs + examples/passing/WildcardType.purs + examples/psci/BasicEval.purs + examples/psci/Multiline.purs + examples/warning/2140.purs + examples/warning/2383.purs + examples/warning/2411.purs + examples/warning/2542.purs + examples/warning/CustomWarning.purs + examples/warning/CustomWarning2.purs + examples/warning/CustomWarning3.purs + examples/warning/DuplicateExportRef.purs + examples/warning/DuplicateImport.purs + examples/warning/DuplicateImportRef.purs + examples/warning/DuplicateSelectiveImport.purs + examples/warning/HidingImport.purs + examples/warning/ImplicitImport.purs + examples/warning/ImplicitQualifiedImport.purs + examples/warning/MissingTypeDeclaration.purs + examples/warning/NewtypeInstance.purs + examples/warning/NewtypeInstance2.purs + examples/warning/NewtypeInstance3.purs + examples/warning/NewtypeInstance4.purs + examples/warning/OverlappingInstances.purs + examples/warning/OverlappingPattern.purs + examples/warning/ScopeShadowing.purs + examples/warning/ShadowedBinderPatternGuard.purs + examples/warning/ShadowedNameParens.purs + examples/warning/ShadowedTypeVar.purs + examples/warning/UnnecessaryFFIModule.js + examples/warning/UnnecessaryFFIModule.purs + examples/warning/UnusedDctorExplicitImport.purs + examples/warning/UnusedDctorImportAll.purs + examples/warning/UnusedDctorImportExplicit.purs + examples/warning/UnusedExplicitImport.purs + examples/warning/UnusedExplicitImportTypeOp.purs + examples/warning/UnusedExplicitImportTypeOp/Lib.purs + examples/warning/UnusedExplicitImportValOp.purs + examples/warning/UnusedFFIImplementations.js + examples/warning/UnusedFFIImplementations.purs + examples/warning/UnusedImport.purs + examples/warning/UnusedTypeVar.purs + examples/warning/WildcardInferredType.purs + INSTALL.md + README.md + stack.yaml + tests/support/bower.json + tests/support/package.json + tests/support/prelude-resolutions.json + tests/support/psci/Sample.purs + tests/support/pscide/src/ImportsSpec.purs + tests/support/pscide/src/ImportsSpec1.purs + tests/support/pscide/src/MatcherSpec.purs + tests/support/pscide/src/RebuildSpecDep.purs + tests/support/pscide/src/RebuildSpecSingleModule.fail + tests/support/pscide/src/RebuildSpecSingleModule.purs + tests/support/pscide/src/RebuildSpecWithDeps.purs + tests/support/pscide/src/RebuildSpecWithForeign.js + tests/support/pscide/src/RebuildSpecWithForeign.purs + tests/support/pscide/src/RebuildSpecWithHiddenIdent.purs + tests/support/pscide/src/RebuildSpecWithMissingForeign.fail + tests/support/setup-win.cmd + +source-repository head + type: git + location: https://github.com/purescript/purescript + +flag release + description: Mark this build as a release build: prevents inclusion of extra info e.g. commit SHA in --version output) + + manual: False + default: False + +library + hs-source-dirs: + src + default-extensions: ConstraintKinds DataKinds DeriveFunctor EmptyDataDecls FlexibleContexts KindSignatures LambdaCase MultiParamTypeClasses NoImplicitPrelude PatternGuards PatternSynonyms RankNTypes RecordWildCards OverloadedStrings ScopedTypeVariables TupleSections ViewPatterns + ghc-options: -Wall -O2 + build-depends: + aeson >=1.0 && <1.2 + , aeson-better-errors >=0.8 + , ansi-terminal >=0.6.2 && <0.7 + , base >=4.8 && <5 + , base-compat >=0.6.0 + , blaze-html >=0.8.1 && <0.9 + , bower-json >=1.0.0.1 && <1.1 + , boxes >=0.1.4 && <0.2.0 + , bytestring + , cheapskate >=0.1 && <0.2 + , clock + , containers + , data-ordlist >=0.4.7.0 + , deepseq + , directory >=1.2.3 + , dlist + , edit-distance + , filepath + , fsnotify >=0.2.1 + , Glob >=0.7 && <0.8 + , haskeline >=0.7.0.0 + , http-client >=0.4.30 && <0.6.0 + , http-types + , language-javascript >=0.6.0.9 && <0.7 + , lens ==4.* + , lifted-base >=0.2.3 && <0.2.4 + , monad-control >=1.0.0.0 && <1.1 + , monad-logger >=0.3 && <0.4 + , mtl >=2.1.0 && <2.3.0 + , parallel >=3.2 && <3.3 + , parsec >=3.1.10 + , pattern-arrows >=0.0.2 && <0.1 + , pipes >=4.0.0 && <4.4.0 + , pipes-http + , process >=1.2.0 && <1.5 + , protolude >=0.1.6 + , regex-tdfa + , safe >=0.3.9 && <0.4 + , scientific >=0.3.4.9 && <0.4 + , semigroups >=0.16.2 && <0.19 + , sourcemap >=0.1.6 + , spdx ==0.2.* + , split + , stm >=0.2.4.0 + , stringsearch + , syb + , text + , time + , transformers >=0.3.0 && <0.6 + , transformers-base >=0.4.0 && <0.5 + , transformers-compat >=0.3.0 + , unordered-containers + , utf8-string >=1 && <2 + , vector + exposed-modules: + Control.Monad.Logger + Control.Monad.Supply + Control.Monad.Supply.Class + Language.PureScript + Language.PureScript.AST + Language.PureScript.AST.Binders + Language.PureScript.AST.Declarations + Language.PureScript.AST.Exported + Language.PureScript.AST.Literals + Language.PureScript.AST.Operators + Language.PureScript.AST.SourcePos + Language.PureScript.AST.Traversals + Language.PureScript.Bundle + Language.PureScript.CodeGen + Language.PureScript.CodeGen.JS + Language.PureScript.CodeGen.JS.Common + Language.PureScript.CodeGen.JS.Printer + Language.PureScript.Comments + Language.PureScript.Constants + Language.PureScript.CoreFn + Language.PureScript.CoreFn.Ann + Language.PureScript.CoreFn.Binders + Language.PureScript.CoreFn.Desugar + Language.PureScript.CoreFn.Expr + Language.PureScript.CoreFn.Meta + Language.PureScript.CoreFn.Module + Language.PureScript.CoreFn.ToJSON + Language.PureScript.CoreFn.Traversals + Language.PureScript.CoreImp + Language.PureScript.CoreImp.AST + Language.PureScript.CoreImp.Optimizer + Language.PureScript.CoreImp.Optimizer.Blocks + Language.PureScript.CoreImp.Optimizer.Common + Language.PureScript.CoreImp.Optimizer.Inliner + Language.PureScript.CoreImp.Optimizer.MagicDo + Language.PureScript.CoreImp.Optimizer.TCO + Language.PureScript.CoreImp.Optimizer.Unused + Language.PureScript.Crash + Language.PureScript.Docs + Language.PureScript.Docs.AsHtml + Language.PureScript.Docs.AsMarkdown + Language.PureScript.Docs.Convert + Language.PureScript.Docs.Convert.ReExports + Language.PureScript.Docs.Convert.Single + Language.PureScript.Docs.ParseInPackage + Language.PureScript.Docs.Prim + Language.PureScript.Docs.Render + Language.PureScript.Docs.RenderedCode + Language.PureScript.Docs.RenderedCode.RenderKind + Language.PureScript.Docs.RenderedCode.RenderType + Language.PureScript.Docs.RenderedCode.Types + Language.PureScript.Docs.Types + Language.PureScript.Docs.Utils.MonoidExtras + Language.PureScript.Environment + Language.PureScript.Errors + Language.PureScript.Errors.JSON + Language.PureScript.Externs + Language.PureScript.Ide + Language.PureScript.Ide.CaseSplit + Language.PureScript.Ide.Command + Language.PureScript.Ide.Completion + Language.PureScript.Ide.Error + Language.PureScript.Ide.Externs + Language.PureScript.Ide.Filter + Language.PureScript.Ide.Filter.Declaration + Language.PureScript.Ide.Imports + Language.PureScript.Ide.Logging + Language.PureScript.Ide.Matcher + Language.PureScript.Ide.Prim + Language.PureScript.Ide.Pursuit + Language.PureScript.Ide.Rebuild + Language.PureScript.Ide.Reexports + Language.PureScript.Ide.SourceFile + Language.PureScript.Ide.State + Language.PureScript.Ide.Types + Language.PureScript.Ide.Util + Language.PureScript.Ide.Watcher + Language.PureScript.Interactive + Language.PureScript.Interactive.Completion + Language.PureScript.Interactive.Directive + Language.PureScript.Interactive.IO + Language.PureScript.Interactive.Message + Language.PureScript.Interactive.Module + Language.PureScript.Interactive.Parser + Language.PureScript.Interactive.Printer + Language.PureScript.Interactive.Types + Language.PureScript.Kinds + Language.PureScript.Label + Language.PureScript.Linter + Language.PureScript.Linter.Exhaustive + Language.PureScript.Linter.Imports + Language.PureScript.Make + Language.PureScript.ModuleDependencies + Language.PureScript.Names + Language.PureScript.Options + Language.PureScript.Parser + Language.PureScript.Parser.Common + Language.PureScript.Parser.Declarations + Language.PureScript.Parser.Kinds + Language.PureScript.Parser.Lexer + Language.PureScript.Parser.State + Language.PureScript.Parser.Types + Language.PureScript.Pretty + Language.PureScript.Pretty.Common + Language.PureScript.Pretty.Kinds + Language.PureScript.Pretty.Types + Language.PureScript.Pretty.Values + Language.PureScript.PSString + Language.PureScript.Publish + Language.PureScript.Publish.BoxesHelpers + Language.PureScript.Publish.ErrorsWarnings + Language.PureScript.Publish.Utils + Language.PureScript.Renamer + Language.PureScript.Sugar + Language.PureScript.Sugar.BindingGroups + Language.PureScript.Sugar.CaseDeclarations + Language.PureScript.Sugar.DoNotation + Language.PureScript.Sugar.LetPattern + Language.PureScript.Sugar.Names + Language.PureScript.Sugar.Names.Common + Language.PureScript.Sugar.Names.Env + Language.PureScript.Sugar.Names.Exports + Language.PureScript.Sugar.Names.Imports + Language.PureScript.Sugar.ObjectWildcards + Language.PureScript.Sugar.Operators + Language.PureScript.Sugar.Operators.Binders + Language.PureScript.Sugar.Operators.Common + Language.PureScript.Sugar.Operators.Expr + Language.PureScript.Sugar.Operators.Types + Language.PureScript.Sugar.TypeClasses + Language.PureScript.Sugar.TypeClasses.Deriving + Language.PureScript.Sugar.TypeDeclarations + Language.PureScript.Traversals + Language.PureScript.TypeChecker + Language.PureScript.TypeChecker.Entailment + Language.PureScript.TypeChecker.Kinds + Language.PureScript.TypeChecker.Monad + Language.PureScript.TypeChecker.Skolems + Language.PureScript.TypeChecker.Subsumption + Language.PureScript.TypeChecker.Synonyms + Language.PureScript.TypeChecker.Types + Language.PureScript.TypeChecker.TypeSearch + Language.PureScript.TypeChecker.Unify + Language.PureScript.TypeClassDictionaries + Language.PureScript.Types + System.IO.UTF8 + other-modules: + Paths_purescript + default-language: Haskell2010 + +executable purs + main-is: Main.hs + hs-source-dirs: + app + ghc-options: -Wall -O2 -fno-warn-unused-do-bind -threaded -rtsopts -with-rtsopts=-N + build-depends: + aeson >=1.0 && <1.2 + , aeson-better-errors >=0.8 + , ansi-terminal >=0.6.2 && <0.7 + , base >=4.8 && <5 + , base-compat >=0.6.0 + , blaze-html >=0.8.1 && <0.9 + , bower-json >=1.0.0.1 && <1.1 + , boxes >=0.1.4 && <0.2.0 + , bytestring + , cheapskate >=0.1 && <0.2 + , clock + , containers + , data-ordlist >=0.4.7.0 + , deepseq + , directory >=1.2.3 + , dlist + , edit-distance + , filepath + , fsnotify >=0.2.1 + , Glob >=0.7 && <0.8 + , haskeline >=0.7.0.0 + , http-client >=0.4.30 && <0.6.0 + , http-types + , language-javascript >=0.6.0.9 && <0.7 + , lens ==4.* + , lifted-base >=0.2.3 && <0.2.4 + , monad-control >=1.0.0.0 && <1.1 + , monad-logger >=0.3 && <0.4 + , mtl >=2.1.0 && <2.3.0 + , parallel >=3.2 && <3.3 + , parsec >=3.1.10 + , pattern-arrows >=0.0.2 && <0.1 + , pipes >=4.0.0 && <4.4.0 + , pipes-http + , process >=1.2.0 && <1.5 + , protolude >=0.1.6 + , regex-tdfa + , safe >=0.3.9 && <0.4 + , scientific >=0.3.4.9 && <0.4 + , semigroups >=0.16.2 && <0.19 + , sourcemap >=0.1.6 + , spdx ==0.2.* + , split + , stm >=0.2.4.0 + , stringsearch + , syb + , text + , time + , transformers >=0.3.0 && <0.6 + , transformers-base >=0.4.0 && <0.5 + , transformers-compat >=0.3.0 + , unordered-containers + , utf8-string >=1 && <2 + , vector + , ansi-wl-pprint + , file-embed + , network + , optparse-applicative >=0.13.0 + , purescript + , wai ==3.* + , wai-websockets ==3.* + , warp ==3.* + , websockets >=0.9 && <0.11 + if flag(release) + cpp-options: -DRELEASE + else + build-depends: + gitrev >=1.2.0 && <1.3 + other-modules: + Command.Bundle + Command.Compile + Command.Docs + Command.Docs.Ctags + Command.Docs.Etags + Command.Docs.Html + Command.Docs.Tags + Command.Hierarchy + Command.Ide + Command.Publish + Command.REPL + Version + default-language: Haskell2010 + +test-suite tests + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: + tests + ghc-options: -Wall + build-depends: + aeson >=1.0 && <1.2 + , aeson-better-errors >=0.8 + , ansi-terminal >=0.6.2 && <0.7 + , base >=4.8 && <5 + , base-compat >=0.6.0 + , blaze-html >=0.8.1 && <0.9 + , bower-json >=1.0.0.1 && <1.1 + , boxes >=0.1.4 && <0.2.0 + , bytestring + , cheapskate >=0.1 && <0.2 + , clock + , containers + , data-ordlist >=0.4.7.0 + , deepseq + , directory >=1.2.3 + , dlist + , edit-distance + , filepath + , fsnotify >=0.2.1 + , Glob >=0.7 && <0.8 + , haskeline >=0.7.0.0 + , http-client >=0.4.30 && <0.6.0 + , http-types + , language-javascript >=0.6.0.9 && <0.7 + , lens ==4.* + , lifted-base >=0.2.3 && <0.2.4 + , monad-control >=1.0.0.0 && <1.1 + , monad-logger >=0.3 && <0.4 + , mtl >=2.1.0 && <2.3.0 + , parallel >=3.2 && <3.3 + , parsec >=3.1.10 + , pattern-arrows >=0.0.2 && <0.1 + , pipes >=4.0.0 && <4.4.0 + , pipes-http + , process >=1.2.0 && <1.5 + , protolude >=0.1.6 + , regex-tdfa + , safe >=0.3.9 && <0.4 + , scientific >=0.3.4.9 && <0.4 + , semigroups >=0.16.2 && <0.19 + , sourcemap >=0.1.6 + , spdx ==0.2.* + , split + , stm >=0.2.4.0 + , stringsearch + , syb + , text + , time + , transformers >=0.3.0 && <0.6 + , transformers-base >=0.4.0 && <0.5 + , transformers-compat >=0.3.0 + , unordered-containers + , utf8-string >=1 && <2 + , vector + , purescript + , hspec + , hspec-discover + , HUnit + , silently + other-modules: + Language.PureScript.Ide.CompletionSpec + Language.PureScript.Ide.FilterSpec + Language.PureScript.Ide.ImportsSpec + Language.PureScript.Ide.MatcherSpec + Language.PureScript.Ide.RebuildSpec + Language.PureScript.Ide.ReexportsSpec + Language.PureScript.Ide.SourceFileSpec + Language.PureScript.Ide.StateSpec + Language.PureScript.Ide.Test + PscIdeSpec + TestCompiler + TestDocs + TestPrimDocs + TestPsci + TestPsci.CommandTest + TestPsci.CompletionTest + TestPsci.EvalTest + TestPsci.TestEnv + TestPscIde + TestPscPublish + TestUtils + default-language: Haskell2010 diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -14,6 +14,7 @@ import Data.Aeson.TH import qualified Data.Map as M import Data.Text (Text) +import qualified Data.List.NonEmpty as NEL import Language.PureScript.AST.Binders import Language.PureScript.AST.Literals @@ -28,6 +29,7 @@ import Language.PureScript.Comments import Language.PureScript.Environment import qualified Language.PureScript.Bundle as Bundle +import qualified Language.PureScript.Constants as C import qualified Text.Parsec as P @@ -182,7 +184,7 @@ | ErrorInApplication Expr Type Expr | ErrorInDataConstructor (ProperName 'ConstructorName) | ErrorInTypeConstructor (ProperName 'TypeName) - | ErrorInBindingGroup [Ident] + | ErrorInBindingGroup (NEL.NonEmpty Ident) | ErrorInDataBindingGroup [ProperName 'TypeName] | ErrorInTypeSynonym (ProperName 'TypeName) | ErrorInValueDeclaration Ident @@ -227,15 +229,24 @@ -- | -- Add an import declaration for a module if it does not already explicitly import it. -- -addDefaultImport :: ModuleName -> Module -> Module -addDefaultImport toImport m@(Module ss coms mn decls exps) = +addDefaultImport :: Qualified ModuleName -> Module -> Module +addDefaultImport (Qualified toImportAs toImport) m@(Module ss coms mn decls exps) = if isExistingImport `any` decls || mn == toImport then m - else Module ss coms mn (ImportDeclaration toImport Implicit Nothing : decls) exps + else Module ss coms mn (ImportDeclaration (ss, []) toImport Implicit toImportAs : decls) exps where - isExistingImport (ImportDeclaration mn' _ _) | mn' == toImport = True - isExistingImport (PositionedDeclaration _ _ d) = isExistingImport d + isExistingImport (ImportDeclaration _ mn' _ as') | mn' == toImport && as' == toImportAs = True isExistingImport _ = False +-- | Adds import declarations to a module for an implicit Prim import and Prim +-- | qualified as Prim, as necessary. +importPrim :: Module -> Module +importPrim = + let + primModName = ModuleName [ProperName C.prim] + in + addDefaultImport (Qualified Nothing primModName) + . addDefaultImport (Qualified (Just primModName) primModName) + -- | -- An item in a list of explicit imports or exports -- @@ -243,120 +254,116 @@ -- | -- A type constructor with data constructors -- - = TypeRef (ProperName 'TypeName) (Maybe [ProperName 'ConstructorName]) + = TypeRef SourceSpan (ProperName 'TypeName) (Maybe [ProperName 'ConstructorName]) -- | -- A type operator -- - | TypeOpRef (OpName 'TypeOpName) + | TypeOpRef SourceSpan (OpName 'TypeOpName) -- | -- A value -- - | ValueRef Ident + | ValueRef SourceSpan Ident -- | -- A value-level operator -- - | ValueOpRef (OpName 'ValueOpName) + | ValueOpRef SourceSpan (OpName 'ValueOpName) -- | -- A type class -- - | TypeClassRef (ProperName 'ClassName) + | TypeClassRef SourceSpan (ProperName 'ClassName) -- | -- A type class instance, created during typeclass desugaring (name, class name, instance types) -- - | TypeInstanceRef Ident + | TypeInstanceRef SourceSpan Ident -- | -- A module, in its entirety -- - | ModuleRef ModuleName + | ModuleRef SourceSpan ModuleName -- | -- A named kind -- - | KindRef (ProperName 'KindName) + | KindRef SourceSpan (ProperName 'KindName) -- | -- A value re-exported from another module. These will be inserted during -- elaboration in name desugaring. -- - | ReExportRef ModuleName DeclarationRef - -- | - -- A declaration reference with source position information - -- - | PositionedDeclarationRef SourceSpan [Comment] DeclarationRef + | ReExportRef SourceSpan ModuleName DeclarationRef deriving (Show) instance Eq DeclarationRef where - (TypeRef name dctors) == (TypeRef name' dctors') = name == name' && dctors == dctors' - (TypeOpRef name) == (TypeOpRef name') = name == name' - (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' - (KindRef name) == (KindRef name') = name == name' - (ReExportRef mn ref) == (ReExportRef mn' ref') = mn == mn' && ref == ref' - (PositionedDeclarationRef _ _ r) == r' = r == r' - r == (PositionedDeclarationRef _ _ r') = r == r' + (TypeRef _ name dctors) == (TypeRef _ name' dctors') = name == name' && dctors == dctors' + (TypeOpRef _ name) == (TypeOpRef _ name') = name == name' + (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' + (KindRef _ name) == (KindRef _ name') = name == name' + (ReExportRef _ mn ref) == (ReExportRef _ mn' ref') = mn == mn' && ref == ref' _ == _ = False -- 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 (KindRef name) (KindRef name') = compare name name' -compDecRef (ReExportRef name _) (ReExportRef name' _) = compare name name' -compDecRef (PositionedDeclarationRef _ _ ref) ref' = compDecRef ref ref' -compDecRef ref (PositionedDeclarationRef _ _ ref') = compDecRef ref ref' +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 (KindRef _ name) (KindRef _ 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 (KindRef _) = 5 + orderOf TypeClassRef{} = 0 + orderOf TypeOpRef{} = 1 + orderOf TypeRef{} = 2 + orderOf ValueRef{} = 3 + orderOf ValueOpRef{} = 4 + orderOf KindRef{} = 5 orderOf _ = 6 +declRefSourceSpan :: DeclarationRef -> SourceSpan +declRefSourceSpan (TypeRef ss _ _) = ss +declRefSourceSpan (TypeOpRef ss _) = ss +declRefSourceSpan (ValueRef ss _) = ss +declRefSourceSpan (ValueOpRef ss _) = ss +declRefSourceSpan (TypeClassRef ss _) = ss +declRefSourceSpan (TypeInstanceRef ss _) = ss +declRefSourceSpan (ModuleRef ss _) = ss +declRefSourceSpan (KindRef ss _) = ss +declRefSourceSpan (ReExportRef ss _ _) = ss + getTypeRef :: DeclarationRef -> Maybe (ProperName 'TypeName, Maybe [ProperName 'ConstructorName]) -getTypeRef (TypeRef name dctors) = Just (name, dctors) -getTypeRef (PositionedDeclarationRef _ _ r) = getTypeRef r +getTypeRef (TypeRef _ name dctors) = Just (name, dctors) getTypeRef _ = Nothing getTypeOpRef :: DeclarationRef -> Maybe (OpName 'TypeOpName) -getTypeOpRef (TypeOpRef op) = Just op -getTypeOpRef (PositionedDeclarationRef _ _ r) = getTypeOpRef r +getTypeOpRef (TypeOpRef _ op) = Just op getTypeOpRef _ = Nothing getValueRef :: DeclarationRef -> Maybe Ident -getValueRef (ValueRef name) = Just name -getValueRef (PositionedDeclarationRef _ _ r) = getValueRef r +getValueRef (ValueRef _ name) = Just name getValueRef _ = Nothing getValueOpRef :: DeclarationRef -> Maybe (OpName 'ValueOpName) -getValueOpRef (ValueOpRef op) = Just op -getValueOpRef (PositionedDeclarationRef _ _ r) = getValueOpRef r +getValueOpRef (ValueOpRef _ op) = Just op getValueOpRef _ = Nothing getTypeClassRef :: DeclarationRef -> Maybe (ProperName 'ClassName) -getTypeClassRef (TypeClassRef name) = Just name -getTypeClassRef (PositionedDeclarationRef _ _ r) = getTypeClassRef r +getTypeClassRef (TypeClassRef _ name) = Just name getTypeClassRef _ = Nothing getKindRef :: DeclarationRef -> Maybe (ProperName 'KindName) -getKindRef (KindRef name) = Just name -getKindRef (PositionedDeclarationRef _ _ r) = getKindRef r +getKindRef (KindRef _ name) = Just name getKindRef _ = Nothing isModuleRef :: DeclarationRef -> Bool -isModuleRef (PositionedDeclarationRef _ _ r) = isModuleRef r -isModuleRef (ModuleRef _) = True +isModuleRef ModuleRef{} = True isModuleRef _ = False -- | @@ -392,63 +399,59 @@ -- | -- A data type declaration (data or newtype, name, arguments, data constructors) -- - = DataDeclaration DataDeclType (ProperName 'TypeName) [(Text, Maybe Kind)] [(ProperName 'ConstructorName, [Type])] + = DataDeclaration SourceAnn DataDeclType (ProperName 'TypeName) [(Text, Maybe Kind)] [(ProperName 'ConstructorName, [Type])] -- | -- A minimal mutually recursive set of data type declarations -- - | DataBindingGroupDeclaration [Declaration] + | DataBindingGroupDeclaration (NEL.NonEmpty Declaration) -- | -- A type synonym declaration (name, arguments, type) -- - | TypeSynonymDeclaration (ProperName 'TypeName) [(Text, Maybe Kind)] Type + | TypeSynonymDeclaration SourceAnn (ProperName 'TypeName) [(Text, Maybe Kind)] Type -- | -- A type declaration for a value (name, ty) -- - | TypeDeclaration Ident Type + | TypeDeclaration SourceAnn Ident Type -- | -- A value declaration (name, top-level binders, optional guard, value) -- - | ValueDeclaration Ident NameKind [Binder] [GuardedExpr] + | ValueDeclaration SourceAnn Ident NameKind [Binder] [GuardedExpr] -- | -- A declaration paired with pattern matching in let-in expression (binder, optional guard, value) - | BoundValueDeclaration Binder Expr + | BoundValueDeclaration SourceAnn Binder Expr -- | -- A minimal mutually recursive set of value declarations -- - | BindingGroupDeclaration [(Ident, NameKind, Expr)] + | BindingGroupDeclaration (NEL.NonEmpty ((SourceAnn, Ident), NameKind, Expr)) -- | -- A foreign import declaration (name, type) -- - | ExternDeclaration Ident Type + | ExternDeclaration SourceAnn Ident Type -- | -- A data type foreign import (name, kind) -- - | ExternDataDeclaration (ProperName 'TypeName) Kind + | ExternDataDeclaration SourceAnn (ProperName 'TypeName) Kind -- | -- A foreign kind import (name) -- - | ExternKindDeclaration (ProperName 'KindName) + | ExternKindDeclaration SourceAnn (ProperName 'KindName) -- | -- A fixity declaration -- - | FixityDeclaration (Either ValueFixity TypeFixity) + | FixityDeclaration SourceAnn (Either ValueFixity TypeFixity) -- | -- A module import (module name, qualified/unqualified/hiding, optional "qualified as" name) -- - | ImportDeclaration ModuleName ImportDeclarationType (Maybe ModuleName) + | ImportDeclaration SourceAnn ModuleName ImportDeclarationType (Maybe ModuleName) -- | -- A type class declaration (name, argument, implies, member declarations) -- - | TypeClassDeclaration (ProperName 'ClassName) [(Text, Maybe Kind)] [Constraint] [FunctionalDependency] [Declaration] + | TypeClassDeclaration SourceAnn (ProperName 'ClassName) [(Text, Maybe Kind)] [Constraint] [FunctionalDependency] [Declaration] -- | -- A type instance declaration (name, dependencies, class name, instance types, member -- declarations) -- - | TypeInstanceDeclaration Ident [Constraint] (Qualified (ProperName 'ClassName)) [Type] TypeInstanceBody - -- | - -- A declaration with source position information - -- - | PositionedDeclaration SourceSpan [Comment] Declaration + | TypeInstanceDeclaration SourceAnn Ident [Constraint] (Qualified (ProperName 'ClassName)) [Type] TypeInstanceBody deriving (Show) data ValueFixity = ValueFixity Fixity (Qualified (Either Ident (ProperName 'ConstructorName))) (OpName 'ValueOpName) @@ -457,11 +460,11 @@ data TypeFixity = TypeFixity Fixity (Qualified (ProperName 'TypeName)) (OpName 'TypeOpName) deriving (Eq, Ord, Show) -pattern ValueFixityDeclaration :: Fixity -> Qualified (Either Ident (ProperName 'ConstructorName)) -> OpName 'ValueOpName -> Declaration -pattern ValueFixityDeclaration fixity name op = FixityDeclaration (Left (ValueFixity fixity name op)) +pattern ValueFixityDeclaration :: SourceAnn -> Fixity -> Qualified (Either Ident (ProperName 'ConstructorName)) -> OpName 'ValueOpName -> Declaration +pattern ValueFixityDeclaration sa fixity name op = FixityDeclaration sa (Left (ValueFixity fixity name op)) -pattern TypeFixityDeclaration :: Fixity -> Qualified (ProperName 'TypeName) -> OpName 'TypeOpName -> Declaration -pattern TypeFixityDeclaration fixity name op = FixityDeclaration (Right (TypeFixity fixity name op)) +pattern TypeFixityDeclaration :: SourceAnn -> Fixity -> Qualified (ProperName 'TypeName) -> OpName 'TypeOpName -> Declaration +pattern TypeFixityDeclaration sa fixity name op = FixityDeclaration sa (Right (TypeFixity fixity name op)) -- | The members of a type class instance declaration data TypeInstanceBody @@ -484,12 +487,30 @@ traverseTypeInstanceBody f (ExplicitInstance ds) = ExplicitInstance <$> f ds traverseTypeInstanceBody _ other = pure other +declSourceAnn :: Declaration -> SourceAnn +declSourceAnn (DataDeclaration sa _ _ _ _) = sa +declSourceAnn (DataBindingGroupDeclaration ds) = declSourceAnn (NEL.head ds) +declSourceAnn (TypeSynonymDeclaration sa _ _ _) = sa +declSourceAnn (TypeDeclaration sa _ _) = sa +declSourceAnn (ValueDeclaration sa _ _ _ _) = sa +declSourceAnn (BoundValueDeclaration sa _ _) = sa +declSourceAnn (BindingGroupDeclaration ds) = let ((sa, _), _, _) = NEL.head ds in sa +declSourceAnn (ExternDeclaration sa _ _) = sa +declSourceAnn (ExternDataDeclaration sa _ _) = sa +declSourceAnn (ExternKindDeclaration sa _) = sa +declSourceAnn (FixityDeclaration sa _) = sa +declSourceAnn (ImportDeclaration sa _ _ _) = sa +declSourceAnn (TypeClassDeclaration sa _ _ _ _ _) = sa +declSourceAnn (TypeInstanceDeclaration sa _ _ _ _ _) = sa + +declSourceSpan :: Declaration -> SourceSpan +declSourceSpan = fst . declSourceAnn + -- | -- Test if a declaration is a value declaration -- isValueDecl :: Declaration -> Bool isValueDecl ValueDeclaration{} = True -isValueDecl (PositionedDeclaration _ _ d) = isValueDecl d isValueDecl _ = False -- | @@ -498,7 +519,6 @@ isDataDecl :: Declaration -> Bool isDataDecl DataDeclaration{} = True isDataDecl TypeSynonymDeclaration{} = True -isDataDecl (PositionedDeclaration _ _ d) = isDataDecl d isDataDecl _ = False -- | @@ -506,7 +526,6 @@ -- isImportDecl :: Declaration -> Bool isImportDecl ImportDeclaration{} = True -isImportDecl (PositionedDeclaration _ _ d) = isImportDecl d isImportDecl _ = False -- | @@ -514,7 +533,6 @@ -- isExternDataDecl :: Declaration -> Bool isExternDataDecl ExternDataDeclaration{} = True -isExternDataDecl (PositionedDeclaration _ _ d) = isExternDataDecl d isExternDataDecl _ = False -- | @@ -522,7 +540,6 @@ -- isExternKindDecl :: Declaration -> Bool isExternKindDecl ExternKindDeclaration{} = True -isExternKindDecl (PositionedDeclaration _ _ d) = isExternKindDecl d isExternKindDecl _ = False -- | @@ -530,12 +547,10 @@ -- isFixityDecl :: Declaration -> Bool isFixityDecl FixityDeclaration{} = True -isFixityDecl (PositionedDeclaration _ _ d) = isFixityDecl d isFixityDecl _ = False getFixityDecl :: Declaration -> Maybe (Either ValueFixity TypeFixity) -getFixityDecl (FixityDeclaration fixity) = Just fixity -getFixityDecl (PositionedDeclaration _ _ d) = getFixityDecl d +getFixityDecl (FixityDeclaration _ fixity) = Just fixity getFixityDecl _ = Nothing -- | @@ -543,7 +558,6 @@ -- isExternDecl :: Declaration -> Bool isExternDecl ExternDeclaration{} = True -isExternDecl (PositionedDeclaration _ _ d) = isExternDecl d isExternDecl _ = False -- | @@ -551,7 +565,6 @@ -- isTypeClassInstanceDeclaration :: Declaration -> Bool isTypeClassInstanceDeclaration TypeInstanceDeclaration{} = True -isTypeClassInstanceDeclaration (PositionedDeclaration _ _ d) = isTypeClassInstanceDeclaration d isTypeClassInstanceDeclaration _ = False -- | @@ -559,7 +572,6 @@ -- isTypeClassDeclaration :: Declaration -> Bool isTypeClassDeclaration TypeClassDeclaration{} = True -isTypeClassDeclaration (PositionedDeclaration _ _ d) = isTypeClassDeclaration d isTypeClassDeclaration _ = False -- | diff --git a/src/Language/PureScript/AST/Exported.hs b/src/Language/PureScript/AST/Exported.hs --- a/src/Language/PureScript/AST/Exported.hs +++ b/src/Language/PureScript/AST/Exported.hs @@ -38,11 +38,9 @@ -- it unchanged. -- filterDataConstructors :: Maybe [DeclarationRef] -> Declaration -> Declaration -filterDataConstructors exps (DataDeclaration dType tyName tyArgs dctors) = - DataDeclaration dType tyName tyArgs $ +filterDataConstructors exps (DataDeclaration sa dType tyName tyArgs dctors) = + DataDeclaration sa dType tyName tyArgs $ filter (isDctorExported tyName exps . fst) dctors -filterDataConstructors exps (PositionedDeclaration srcSpan coms d) = - PositionedDeclaration srcSpan coms (filterDataConstructors exps d) filterDataConstructors _ other = other -- | @@ -85,20 +83,18 @@ checkQual q = isQualified q && not (isQualifiedWith mn q) typeName :: DeclarationRef -> Maybe (ProperName 'TypeName) - typeName (TypeRef n _) = Just n - typeName (PositionedDeclarationRef _ _ r) = typeName r + typeName (TypeRef _ n _) = Just n typeName _ = Nothing typeClassName :: DeclarationRef -> Maybe (ProperName 'ClassName) - typeClassName (TypeClassRef n) = Just n - typeClassName (PositionedDeclarationRef _ _ r) = typeClassName r + typeClassName (TypeClassRef _ n) = Just n typeClassName _ = Nothing -- | -- Get all type and type class names referenced by a type instance declaration. -- typeInstanceConstituents :: Declaration -> [Either (Qualified (ProperName 'ClassName)) (Qualified (ProperName 'TypeName))] -typeInstanceConstituents (TypeInstanceDeclaration _ constraints className tys _) = +typeInstanceConstituents (TypeInstanceDeclaration _ _ constraints className tys _) = Left className : (concatMap fromConstraint constraints ++ concatMap fromType tys) where @@ -111,7 +107,6 @@ go (ConstrainedType c _) = fromConstraint c go _ = [] -typeInstanceConstituents (PositionedDeclaration _ _ d) = typeInstanceConstituents d typeInstanceConstituents _ = [] @@ -124,21 +119,18 @@ isExported :: Maybe [DeclarationRef] -> Declaration -> Bool isExported Nothing _ = True isExported _ TypeInstanceDeclaration{} = True -isExported exps (PositionedDeclaration _ _ d) = isExported exps d isExported (Just exps) decl = any (matches decl) exps where - matches (TypeDeclaration ident _) (ValueRef ident') = ident == ident' - matches (ValueDeclaration ident _ _ _) (ValueRef ident') = ident == ident' - matches (ExternDeclaration ident _) (ValueRef ident') = ident == ident' - matches (DataDeclaration _ ident _ _) (TypeRef ident' _) = ident == ident' - matches (ExternDataDeclaration ident _) (TypeRef ident' _) = ident == ident' - matches (ExternKindDeclaration ident) (KindRef ident') = ident == ident' - matches (TypeSynonymDeclaration ident _ _) (TypeRef ident' _) = ident == ident' - matches (TypeClassDeclaration ident _ _ _ _) (TypeClassRef ident') = ident == ident' - matches (ValueFixityDeclaration _ _ op) (ValueOpRef op') = op == op' - matches (TypeFixityDeclaration _ _ op) (TypeOpRef op') = op == op' - matches (PositionedDeclaration _ _ d) r = d `matches` r - matches d (PositionedDeclarationRef _ _ r) = d `matches` r + matches (TypeDeclaration _ ident _) (ValueRef _ ident') = ident == ident' + matches (ValueDeclaration _ ident _ _ _) (ValueRef _ ident') = ident == ident' + matches (ExternDeclaration _ ident _) (ValueRef _ ident') = ident == ident' + matches (DataDeclaration _ _ ident _ _) (TypeRef _ ident' _) = ident == ident' + matches (ExternDataDeclaration _ ident _) (TypeRef _ ident' _) = ident == ident' + matches (ExternKindDeclaration _ ident) (KindRef _ ident') = ident == ident' + matches (TypeSynonymDeclaration _ ident _ _) (TypeRef _ ident' _) = ident == ident' + matches (TypeClassDeclaration _ ident _ _ _ _) (TypeClassRef _ ident') = ident == ident' + matches (ValueFixityDeclaration _ _ _ op) (ValueOpRef _ op') = op == op' + matches (TypeFixityDeclaration _ _ _ op) (TypeOpRef _ op') = op == op' matches _ _ = False -- | @@ -149,7 +141,6 @@ isDctorExported _ Nothing _ = True isDctorExported ident (Just exps) ctor = test `any` exps where - test (PositionedDeclarationRef _ _ d) = test d - test (TypeRef ident' Nothing) = ident == ident' - test (TypeRef ident' (Just ctors)) = ident == ident' && ctor `elem` ctors + test (TypeRef _ ident' Nothing) = ident == ident' + test (TypeRef _ ident' (Just ctors)) = ident == ident' && ctor `elem` ctors test _ = False diff --git a/src/Language/PureScript/AST/SourcePos.hs b/src/Language/PureScript/AST/SourcePos.hs --- a/src/Language/PureScript/AST/SourcePos.hs +++ b/src/Language/PureScript/AST/SourcePos.hs @@ -6,27 +6,25 @@ import Prelude.Compat -import GHC.Generics (Generic) import Control.DeepSeq (NFData) import Data.Aeson ((.=), (.:)) -import qualified Data.Aeson as A import Data.Monoid -import qualified Data.Text as T import Data.Text (Text) +import GHC.Generics (Generic) +import Language.PureScript.Comments +import qualified Data.Aeson as A +import qualified Data.Text as T import System.FilePath (makeRelative) --- | --- Source position information --- +-- | Source annotation - position information and comments. +type SourceAnn = (SourceSpan, [Comment]) + +-- | Source position information data SourcePos = SourcePos - { -- | - -- Line number - -- - sourcePosLine :: Int - -- | - -- Column number - -- + { sourcePosLine :: Int + -- ^ Line number , sourcePosColumn :: Int + -- ^ Column number } deriving (Show, Eq, Ord, Generic) instance NFData SourcePos @@ -46,17 +44,12 @@ return $ SourcePos line col data SourceSpan = SourceSpan - { -- | - -- Source name - -- - spanName :: String - -- | - -- Start of the span - -- + { spanName :: String + -- ^ Source name , spanStart :: SourcePos - -- End of the span - -- + -- ^ Start of the span , spanEnd :: SourcePos + -- ^ End of the span } deriving (Show, Eq, Ord, Generic) instance NFData SourceSpan diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs --- a/src/Language/PureScript/AST/Traversals.hs +++ b/src/Language/PureScript/AST/Traversals.hs @@ -10,6 +10,7 @@ import Data.Foldable (fold) import Data.List (mapAccumL) import Data.Maybe (mapMaybe) +import qualified Data.List.NonEmpty as NEL import qualified Data.Set as S import Language.PureScript.AST.Binders @@ -33,8 +34,13 @@ -> GuardedExpr -> GuardedExpr mapGuardedExpr f g (GuardedExpr guards rhs) = - GuardedExpr (map f guards) (g rhs) + GuardedExpr (fmap f guards) (g rhs) +litM :: Monad m => (a -> m a) -> Literal a -> m (Literal a) +litM go (ObjectLiteral as) = ObjectLiteral <$> traverse (sndM go) as +litM go (ArrayLiteral as) = ArrayLiteral <$> traverse go as +litM _ other = pure other + everywhereOnValues :: (Declaration -> Declaration) -> (Expr -> Expr) @@ -46,13 +52,12 @@ everywhereOnValues f g h = (f', g', h') where f' :: Declaration -> Declaration - f' (DataBindingGroupDeclaration ds) = f (DataBindingGroupDeclaration (map f' ds)) - f' (ValueDeclaration name nameKind bs val) = f (ValueDeclaration name nameKind (map h' bs) (map (mapGuardedExpr handleGuard g') val)) - f' (BoundValueDeclaration b expr) = f (BoundValueDeclaration (h' b) (g' expr)) - f' (BindingGroupDeclaration ds) = f (BindingGroupDeclaration (map (\(name, nameKind, val) -> (name, nameKind, g' val)) ds)) - f' (TypeClassDeclaration name args implies deps ds) = f (TypeClassDeclaration name args implies deps (map f' ds)) - f' (TypeInstanceDeclaration name cs className args ds) = f (TypeInstanceDeclaration name cs className args (mapTypeInstanceBody (map f') ds)) - f' (PositionedDeclaration pos com d) = f (PositionedDeclaration pos com (f' d)) + f' (DataBindingGroupDeclaration ds) = f (DataBindingGroupDeclaration (fmap f' ds)) + f' (ValueDeclaration sa name nameKind bs val) = f (ValueDeclaration sa name nameKind (fmap h' bs) (fmap (mapGuardedExpr handleGuard g') val)) + f' (BoundValueDeclaration sa b expr) = f (BoundValueDeclaration sa (h' b) (g' expr)) + f' (BindingGroupDeclaration ds) = f (BindingGroupDeclaration (fmap (\(name, nameKind, val) -> (name, nameKind, g' val)) ds)) + f' (TypeClassDeclaration sa name args implies deps ds) = f (TypeClassDeclaration sa name args implies deps (fmap f' ds)) + f' (TypeInstanceDeclaration sa name cs className args ds) = f (TypeInstanceDeclaration sa name cs className args (mapTypeInstanceBody (fmap f') ds)) f' other = f other g' :: Expr -> Expr @@ -62,20 +67,20 @@ g' (Parens v) = g (Parens (g' v)) g' (TypeClassDictionaryConstructorApp name v) = g (TypeClassDictionaryConstructorApp name (g' v)) g' (Accessor prop v) = g (Accessor prop (g' v)) - g' (ObjectUpdate obj vs) = g (ObjectUpdate (g' obj) (map (fmap g') vs)) + g' (ObjectUpdate obj vs) = g (ObjectUpdate (g' obj) (fmap (fmap g') vs)) g' (ObjectUpdateNested obj vs) = g (ObjectUpdateNested (g' obj) (fmap g' vs)) g' (Abs binder v) = g (Abs (h' binder) (g' v)) g' (App v1 v2) = g (App (g' v1) (g' v2)) g' (IfThenElse v1 v2 v3) = g (IfThenElse (g' v1) (g' v2) (g' v3)) - g' (Case vs alts) = g (Case (map g' vs) (map handleCaseAlternative alts)) + g' (Case vs alts) = g (Case (fmap g' vs) (fmap handleCaseAlternative alts)) g' (TypedValue check v ty) = g (TypedValue check (g' v) ty) - g' (Let ds v) = g (Let (map f' ds) (g' v)) - g' (Do es) = g (Do (map handleDoNotationElement es)) + g' (Let ds v) = g (Let (fmap f' ds) (g' v)) + g' (Do es) = g (Do (fmap handleDoNotationElement es)) g' (PositionedValue pos com v) = g (PositionedValue pos com (g' v)) g' other = g other h' :: Binder -> Binder - h' (ConstructorBinder ctor bs) = h (ConstructorBinder ctor (map h' bs)) + h' (ConstructorBinder ctor bs) = h (ConstructorBinder ctor (fmap h' bs)) h' (BinaryNoParensBinder b1 b2 b3) = h (BinaryNoParensBinder (h' b1) (h' b2) (h' b3)) h' (ParensInBinder b) = h (ParensInBinder (h' b)) h' (LiteralBinder l) = h (LiteralBinder (lit h' l)) @@ -85,20 +90,20 @@ h' other = h other lit :: (a -> a) -> Literal a -> Literal a - lit go (ArrayLiteral as) = ArrayLiteral (map go as) - lit go (ObjectLiteral as) = ObjectLiteral (map (fmap go) as) + lit go (ArrayLiteral as) = ArrayLiteral (fmap go as) + lit go (ObjectLiteral as) = ObjectLiteral (fmap (fmap go) as) lit _ other = other handleCaseAlternative :: CaseAlternative -> CaseAlternative handleCaseAlternative ca = - ca { caseAlternativeBinders = map h' (caseAlternativeBinders ca) - , caseAlternativeResult = map (mapGuardedExpr handleGuard g') (caseAlternativeResult ca) + ca { caseAlternativeBinders = fmap h' (caseAlternativeBinders ca) + , caseAlternativeResult = fmap (mapGuardedExpr handleGuard g') (caseAlternativeResult ca) } handleDoNotationElement :: DoNotationElement -> DoNotationElement handleDoNotationElement (DoNotationValue v) = DoNotationValue (g' v) handleDoNotationElement (DoNotationBind b v) = DoNotationBind (h' b) (g' v) - handleDoNotationElement (DoNotationLet ds) = DoNotationLet (map f' ds) + handleDoNotationElement (DoNotationLet ds) = DoNotationLet (fmap f' ds) handleDoNotationElement (PositionedDoNotationElement pos com e) = PositionedDoNotationElement pos com (handleDoNotationElement e) handleGuard :: Guard -> Guard @@ -120,16 +125,15 @@ f' :: Declaration -> m Declaration f' (DataBindingGroupDeclaration ds) = DataBindingGroupDeclaration <$> traverse (f' <=< f) ds - f' (ValueDeclaration name nameKind bs val) = ValueDeclaration name nameKind <$> traverse (h' <=< h) bs <*> traverse (guardedExprM handleGuard (g' <=< g)) val + f' (ValueDeclaration sa name nameKind bs val) = ValueDeclaration sa name nameKind <$> traverse (h' <=< h) bs <*> traverse (guardedExprM handleGuard (g' <=< g)) val f' (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> traverse (\(name, nameKind, val) -> (,,) name nameKind <$> (g val >>= g')) ds - f' (TypeClassDeclaration name args implies deps ds) = TypeClassDeclaration name args implies deps <$> traverse (f' <=< f) ds - f' (TypeInstanceDeclaration name cs className args ds) = TypeInstanceDeclaration name cs className args <$> traverseTypeInstanceBody (traverse (f' <=< f)) ds - f' (BoundValueDeclaration b expr) = BoundValueDeclaration <$> h' b <*> g' expr - f' (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> (f d >>= f') + f' (TypeClassDeclaration sa name args implies deps ds) = TypeClassDeclaration sa name args implies deps <$> traverse (f' <=< f) ds + f' (TypeInstanceDeclaration sa name cs className args ds) = TypeInstanceDeclaration sa name cs className args <$> traverseTypeInstanceBody (traverse (f' <=< f)) ds + f' (BoundValueDeclaration sa b expr) = BoundValueDeclaration sa <$> h' b <*> g' expr f' other = f other g' :: Expr -> m Expr - g' (Literal l) = Literal <$> lit (g >=> g') l + g' (Literal l) = Literal <$> litM (g >=> g') l g' (UnaryMinus v) = UnaryMinus <$> (g v >>= g') g' (BinaryNoParens op v1 v2) = BinaryNoParens <$> (g op >>= g') <*> (g v1 >>= g') <*> (g v2 >>= g') g' (Parens v) = Parens <$> (g v >>= g') @@ -148,7 +152,7 @@ g' other = g other h' :: Binder -> m Binder - h' (LiteralBinder l) = LiteralBinder <$> lit (h >=> h') l + h' (LiteralBinder l) = LiteralBinder <$> litM (h >=> h') l h' (ConstructorBinder ctor bs) = ConstructorBinder ctor <$> traverse (h' <=< h) bs h' (BinaryNoParensBinder b1 b2 b3) = BinaryNoParensBinder <$> (h b1 >>= h') <*> (h b2 >>= h') <*> (h b3 >>= h') h' (ParensInBinder b) = ParensInBinder <$> (h b >>= h') @@ -157,11 +161,6 @@ h' (TypedBinder t b) = TypedBinder t <$> (h b >>= h') h' other = h other - lit :: (a -> m a) -> Literal a -> m (Literal a) - lit go (ObjectLiteral as) = ObjectLiteral <$> traverse (sndM go) as - lit go (ArrayLiteral as) = ArrayLiteral <$> traverse go as - lit _ other = pure other - handleCaseAlternative :: CaseAlternative -> m CaseAlternative handleCaseAlternative (CaseAlternative bs val) = CaseAlternative @@ -193,16 +192,15 @@ f' :: Declaration -> m Declaration f' (DataBindingGroupDeclaration ds) = (DataBindingGroupDeclaration <$> traverse f' ds) >>= f - f' (ValueDeclaration name nameKind bs val) = (ValueDeclaration name nameKind <$> traverse h' bs <*> traverse (guardedExprM handleGuard g') val) >>= f + f' (ValueDeclaration sa name nameKind bs val) = (ValueDeclaration sa name nameKind <$> traverse h' bs <*> traverse (guardedExprM handleGuard g') val) >>= f f' (BindingGroupDeclaration ds) = (BindingGroupDeclaration <$> traverse (\(name, nameKind, val) -> (,,) name nameKind <$> g' val) ds) >>= f - f' (BoundValueDeclaration b expr) = (BoundValueDeclaration <$> h' b <*> g' expr) >>= f - f' (TypeClassDeclaration name args implies deps ds) = (TypeClassDeclaration name args implies deps <$> traverse f' ds) >>= f - f' (TypeInstanceDeclaration name cs className args ds) = (TypeInstanceDeclaration name cs className args <$> traverseTypeInstanceBody (traverse f') ds) >>= f - f' (PositionedDeclaration pos com d) = (PositionedDeclaration pos com <$> f' d) >>= f + f' (BoundValueDeclaration sa b expr) = (BoundValueDeclaration sa <$> h' b <*> g' expr) >>= f + f' (TypeClassDeclaration sa name args implies deps ds) = (TypeClassDeclaration sa name args implies deps <$> traverse f' ds) >>= f + f' (TypeInstanceDeclaration sa name cs className args ds) = (TypeInstanceDeclaration sa name cs className args <$> traverseTypeInstanceBody (traverse f') ds) >>= f f' other = f other g' :: Expr -> m Expr - g' (Literal l) = (Literal <$> lit g' l) >>= g + g' (Literal l) = (Literal <$> litM g' l) >>= g g' (UnaryMinus v) = (UnaryMinus <$> g' v) >>= g g' (BinaryNoParens op v1 v2) = (BinaryNoParens <$> g' op <*> g' v1 <*> g' v2) >>= g g' (Parens v) = (Parens <$> g' v) >>= g @@ -221,7 +219,7 @@ g' other = g other h' :: Binder -> m Binder - h' (LiteralBinder l) = (LiteralBinder <$> lit h' l) >>= h + h' (LiteralBinder l) = (LiteralBinder <$> litM h' l) >>= h h' (ConstructorBinder ctor bs) = (ConstructorBinder ctor <$> traverse h' bs) >>= h h' (BinaryNoParensBinder b1 b2 b3) = (BinaryNoParensBinder <$> h' b1 <*> h' b2 <*> h' b3) >>= h h' (ParensInBinder b) = (ParensInBinder <$> h' b) >>= h @@ -230,11 +228,6 @@ h' (TypedBinder t b) = (TypedBinder t <$> h' b) >>= h h' other = h other - lit :: (a -> m a) -> Literal a -> m (Literal a) - lit go (ObjectLiteral as) = ObjectLiteral <$> traverse (sndM go) as - lit go (ArrayLiteral as) = ArrayLiteral <$> traverse go as - lit _ other = pure other - handleCaseAlternative :: CaseAlternative -> m CaseAlternative handleCaseAlternative (CaseAlternative bs val) = CaseAlternative @@ -269,13 +262,12 @@ where f' :: Declaration -> r - f' d@(DataBindingGroupDeclaration ds) = foldl (<>) (f d) (map f' ds) - f' d@(ValueDeclaration _ _ bs val) = foldl (<>) (f d) (map h' bs ++ concatMap (\(GuardedExpr grd v) -> map k' grd ++ [g' v]) val) - f' d@(BindingGroupDeclaration ds) = foldl (<>) (f d) (map (\(_, _, val) -> g' val) ds) - f' d@(TypeClassDeclaration _ _ _ _ ds) = foldl (<>) (f d) (map f' ds) - f' d@(TypeInstanceDeclaration _ _ _ _ (ExplicitInstance ds)) = foldl (<>) (f d) (map f' ds) - f' d@(BoundValueDeclaration b expr) = f d <> h' b <> g' expr - f' d@(PositionedDeclaration _ _ d1) = f d <> f' d1 + f' d@(DataBindingGroupDeclaration ds) = foldl (<>) (f d) (fmap f' ds) + f' d@(ValueDeclaration _ _ _ bs val) = foldl (<>) (f d) (fmap h' bs ++ concatMap (\(GuardedExpr grd v) -> fmap k' grd ++ [g' v]) val) + f' d@(BindingGroupDeclaration ds) = foldl (<>) (f d) (fmap (\(_, _, val) -> g' val) ds) + f' d@(TypeClassDeclaration _ _ _ _ _ ds) = foldl (<>) (f d) (fmap f' ds) + f' d@(TypeInstanceDeclaration _ _ _ _ _ (ExplicitInstance ds)) = foldl (<>) (f d) (fmap f' ds) + f' d@(BoundValueDeclaration _ b expr) = f d <> h' b <> g' expr f' d = f d g' :: Expr -> r @@ -285,21 +277,21 @@ g' v@(Parens v1) = g v <> g' v1 g' v@(TypeClassDictionaryConstructorApp _ v1) = g v <> g' v1 g' v@(Accessor _ v1) = g v <> g' v1 - g' v@(ObjectUpdate obj vs) = foldl (<>) (g v <> g' obj) (map (g' . snd) vs) + g' v@(ObjectUpdate obj vs) = foldl (<>) (g v <> g' obj) (fmap (g' . snd) vs) g' v@(ObjectUpdateNested obj vs) = foldl (<>) (g v <> g' obj) (fmap g' vs) g' v@(Abs b v1) = g v <> h' b <> g' v1 g' v@(App v1 v2) = g v <> g' v1 <> g' v2 g' v@(IfThenElse v1 v2 v3) = g v <> g' v1 <> g' v2 <> g' v3 - g' v@(Case vs alts) = foldl (<>) (foldl (<>) (g v) (map g' vs)) (map i' alts) + g' v@(Case vs alts) = foldl (<>) (foldl (<>) (g v) (fmap g' vs)) (fmap i' alts) g' v@(TypedValue _ v1 _) = g v <> g' v1 - g' v@(Let ds v1) = foldl (<>) (g v) (map f' ds) <> g' v1 - g' v@(Do es) = foldl (<>) (g v) (map j' es) + g' v@(Let ds v1) = foldl (<>) (g v) (fmap f' ds) <> g' v1 + g' v@(Do es) = foldl (<>) (g v) (fmap j' es) g' v@(PositionedValue _ _ v1) = g v <> g' v1 g' v = g v h' :: Binder -> r h' b@(LiteralBinder l) = lit (h b) h' l - h' b@(ConstructorBinder _ bs) = foldl (<>) (h b) (map h' bs) + h' b@(ConstructorBinder _ bs) = foldl (<>) (h b) (fmap h' bs) h' b@(BinaryNoParensBinder b1 b2 b3) = h b <> h' b1 <> h' b2 <> h' b3 h' b@(ParensInBinder b1) = h b <> h' b1 h' b@(NamedBinder _ b1) = h b <> h' b1 @@ -308,18 +300,18 @@ h' b = h b lit :: r -> (a -> r) -> Literal a -> r - lit r go (ArrayLiteral as) = foldl (<>) r (map go as) - lit r go (ObjectLiteral as) = foldl (<>) r (map (go . snd) as) + lit r go (ArrayLiteral as) = foldl (<>) r (fmap go as) + lit r go (ObjectLiteral as) = foldl (<>) r (fmap (go . snd) as) lit r _ _ = r i' :: CaseAlternative -> r i' ca@(CaseAlternative bs gs) = - foldl (<>) (i ca) (map h' bs ++ concatMap (\(GuardedExpr grd val) -> map k' grd ++ [g' val]) gs) + foldl (<>) (i ca) (fmap h' bs ++ concatMap (\(GuardedExpr grd val) -> fmap k' grd ++ [g' val]) gs) j' :: DoNotationElement -> r j' e@(DoNotationValue v) = j e <> g' v j' e@(DoNotationBind b v) = j e <> h' b <> g' v - j' e@(DoNotationLet ds) = foldl (<>) (j e) (map f' ds) + j' e@(DoNotationLet ds) = foldl (<>) (j e) (fmap f' ds) j' e@(PositionedDoNotationElement _ _ e1) = j e <> j' e1 k' :: Guard -> r @@ -348,12 +340,11 @@ f'' s d = let (s', r) = f s d in r <> f' s' d f' :: s -> Declaration -> r - f' s (DataBindingGroupDeclaration ds) = foldl (<>) r0 (map (f'' s) ds) - f' s (ValueDeclaration _ _ bs val) = foldl (<>) r0 (map (h'' s) bs ++ concatMap (\(GuardedExpr grd v) -> map (k' s) grd ++ [g'' s v]) val) - f' s (BindingGroupDeclaration ds) = foldl (<>) r0 (map (\(_, _, val) -> g'' s val) ds) - f' s (TypeClassDeclaration _ _ _ _ ds) = foldl (<>) r0 (map (f'' s) ds) - f' s (TypeInstanceDeclaration _ _ _ _ (ExplicitInstance ds)) = foldl (<>) r0 (map (f'' s) ds) - f' s (PositionedDeclaration _ _ d1) = f'' s d1 + f' s (DataBindingGroupDeclaration ds) = foldl (<>) r0 (fmap (f'' s) ds) + f' s (ValueDeclaration _ _ _ bs val) = foldl (<>) r0 (fmap (h'' s) bs ++ concatMap (\(GuardedExpr grd v) -> fmap (k' s) grd ++ [g'' s v]) val) + f' s (BindingGroupDeclaration ds) = foldl (<>) r0 (fmap (\(_, _, val) -> g'' s val) ds) + f' s (TypeClassDeclaration _ _ _ _ _ ds) = foldl (<>) r0 (fmap (f'' s) ds) + f' s (TypeInstanceDeclaration _ _ _ _ _ (ExplicitInstance ds)) = foldl (<>) r0 (fmap (f'' s) ds) f' _ _ = r0 g'' :: s -> Expr -> r @@ -366,15 +357,15 @@ g' s (Parens v1) = g'' s v1 g' s (TypeClassDictionaryConstructorApp _ v1) = g'' s v1 g' s (Accessor _ v1) = g'' s v1 - g' s (ObjectUpdate obj vs) = foldl (<>) (g'' s obj) (map (g'' s . snd) vs) + g' s (ObjectUpdate obj vs) = foldl (<>) (g'' s obj) (fmap (g'' s . snd) vs) g' s (ObjectUpdateNested obj vs) = foldl (<>) (g'' s obj) (fmap (g'' s) vs) g' s (Abs binder v1) = h'' s binder <> g'' s v1 g' s (App v1 v2) = g'' s v1 <> g'' s v2 g' s (IfThenElse v1 v2 v3) = g'' s v1 <> g'' s v2 <> g'' s v3 - g' s (Case vs alts) = foldl (<>) (foldl (<>) r0 (map (g'' s) vs)) (map (i'' s) alts) + g' s (Case vs alts) = foldl (<>) (foldl (<>) r0 (fmap (g'' s) vs)) (fmap (i'' s) alts) g' s (TypedValue _ v1 _) = g'' s v1 - g' s (Let ds v1) = foldl (<>) r0 (map (f'' s) ds) <> g'' s v1 - g' s (Do es) = foldl (<>) r0 (map (j'' s) es) + g' s (Let ds v1) = foldl (<>) r0 (fmap (f'' s) ds) <> g'' s v1 + g' s (Do es) = foldl (<>) r0 (fmap (j'' s) es) g' s (PositionedValue _ _ v1) = g'' s v1 g' _ _ = r0 @@ -383,7 +374,7 @@ h' :: s -> Binder -> r h' s (LiteralBinder l) = lit h'' s l - h' s (ConstructorBinder _ bs) = foldl (<>) r0 (map (h'' s) bs) + h' s (ConstructorBinder _ bs) = foldl (<>) r0 (fmap (h'' s) bs) h' s (BinaryNoParensBinder b1 b2 b3) = h'' s b1 <> h'' s b2 <> h'' s b3 h' s (ParensInBinder b) = h'' s b h' s (NamedBinder _ b1) = h'' s b1 @@ -392,15 +383,15 @@ h' _ _ = r0 lit :: (s -> a -> r) -> s -> Literal a -> r - lit go s (ArrayLiteral as) = foldl (<>) r0 (map (go s) as) - lit go s (ObjectLiteral as) = foldl (<>) r0 (map (go s . snd) as) + lit go s (ArrayLiteral as) = foldl (<>) r0 (fmap (go s) as) + lit go s (ObjectLiteral as) = foldl (<>) r0 (fmap (go s . snd) as) lit _ _ _ = r0 i'' :: s -> CaseAlternative -> r i'' s ca = let (s', r) = i s ca in r <> i' s' ca i' :: s -> CaseAlternative -> r - i' s (CaseAlternative bs gs) = foldl (<>) r0 (map (h'' s) bs ++ concatMap (\(GuardedExpr grd val) -> map (k' s) grd ++ [g'' s val]) gs) + i' s (CaseAlternative bs gs) = foldl (<>) r0 (fmap (h'' s) bs ++ concatMap (\(GuardedExpr grd val) -> fmap (k' s) grd ++ [g'' s val]) gs) j'' :: s -> DoNotationElement -> r j'' s e = let (s', r) = j s e in r <> j' s' e @@ -408,7 +399,7 @@ j' :: s -> DoNotationElement -> r j' s (DoNotationValue v) = g'' s v j' s (DoNotationBind b v) = h'' s b <> g'' s v - j' s (DoNotationLet ds) = foldl (<>) r0 (map (f'' s) ds) + j' s (DoNotationLet ds) = foldl (<>) r0 (fmap (f'' s) ds) j' s (PositionedDoNotationElement _ _ e1) = j'' s e1 k' :: s -> Guard -> r @@ -435,11 +426,10 @@ f'' s = uncurry f' <=< f s f' s (DataBindingGroupDeclaration ds) = DataBindingGroupDeclaration <$> traverse (f'' s) ds - f' s (ValueDeclaration name nameKind bs val) = ValueDeclaration name nameKind <$> traverse (h'' s) bs <*> traverse (guardedExprM (k' s) (g'' s)) val + f' s (ValueDeclaration sa name nameKind bs val) = ValueDeclaration sa name nameKind <$> traverse (h'' s) bs <*> traverse (guardedExprM (k' s) (g'' s)) val f' s (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> traverse (thirdM (g'' s)) ds - f' s (TypeClassDeclaration name args implies deps ds) = TypeClassDeclaration name args implies deps <$> traverse (f'' s) ds - f' s (TypeInstanceDeclaration name cs className args ds) = TypeInstanceDeclaration name cs className args <$> traverseTypeInstanceBody (traverse (f'' s)) ds - f' s (PositionedDeclaration pos com d1) = PositionedDeclaration pos com <$> f'' s d1 + f' s (TypeClassDeclaration sa name args implies deps ds) = TypeClassDeclaration sa name args implies deps <$> traverse (f'' s) ds + f' s (TypeInstanceDeclaration sa name cs className args ds) = TypeInstanceDeclaration sa name cs className args <$> traverseTypeInstanceBody (traverse (f'' s)) ds f' _ other = return other g'' s = uncurry g' <=< g s @@ -516,18 +506,17 @@ f' :: S.Set Ident -> Declaration -> r f' s (DataBindingGroupDeclaration ds) = - let s' = S.union s (S.fromList (mapMaybe getDeclIdent ds)) + let s' = S.union s (S.fromList (mapMaybe getDeclIdent (NEL.toList ds))) in foldMap (f'' s') ds - f' s (ValueDeclaration name _ bs val) = + f' s (ValueDeclaration _ name _ bs val) = let s' = S.insert name s s'' = S.union s' (S.fromList (concatMap binderNames bs)) in foldMap (h'' s') bs <> foldMap (l' s'') val f' s (BindingGroupDeclaration ds) = - let s' = S.union s (S.fromList (map (\(name, _, _) -> name) ds)) + let s' = S.union s (S.fromList (NEL.toList (fmap (\((_, name), _, _) -> name) ds))) in foldMap (\(_, _, val) -> g'' s' val) ds - f' s (TypeClassDeclaration _ _ _ _ ds) = foldMap (f'' s) ds - f' s (TypeInstanceDeclaration _ _ _ _ (ExplicitInstance ds)) = foldMap (f'' s) ds - f' s (PositionedDeclaration _ _ d) = f'' s d + f' s (TypeClassDeclaration _ _ _ _ _ ds) = foldMap (f'' s) ds + f' s (TypeInstanceDeclaration _ _ _ _ _ (ExplicitInstance ds)) = foldMap (f'' s) ds f' _ _ = mempty g'' :: S.Set Ident -> Expr -> r @@ -607,9 +596,8 @@ in r <> l' s' (GuardedExpr gs e) getDeclIdent :: Declaration -> Maybe Ident - getDeclIdent (PositionedDeclaration _ _ d) = getDeclIdent d - getDeclIdent (ValueDeclaration ident _ _ _) = Just ident - getDeclIdent (TypeDeclaration ident _) = Just ident + getDeclIdent (ValueDeclaration _ ident _ _ _) = Just ident + getDeclIdent (TypeDeclaration _ ident _) = Just ident getDeclIdent _ = Nothing accumTypes @@ -623,16 +611,16 @@ ) accumTypes f = everythingOnValues mappend forDecls forValues (const mempty) (const mempty) (const mempty) where - forDecls (DataDeclaration _ _ _ dctors) = mconcat (concatMap (map f . snd) dctors) - forDecls (ExternDeclaration _ ty) = f ty - forDecls (TypeClassDeclaration _ _ implies _ _) = mconcat (concatMap (map f . constraintArgs) implies) - forDecls (TypeInstanceDeclaration _ cs _ tys _) = mconcat (concatMap (map f . constraintArgs) cs) `mappend` mconcat (map f tys) - forDecls (TypeSynonymDeclaration _ _ ty) = f ty - forDecls (TypeDeclaration _ ty) = f ty + forDecls (DataDeclaration _ _ _ _ dctors) = mconcat (concatMap (fmap f . snd) dctors) + forDecls (ExternDeclaration _ _ ty) = f ty + forDecls (TypeClassDeclaration _ _ _ implies _ _) = mconcat (concatMap (fmap f . constraintArgs) implies) + forDecls (TypeInstanceDeclaration _ _ cs _ tys _) = mconcat (concatMap (fmap f . constraintArgs) cs) `mappend` mconcat (fmap f tys) + forDecls (TypeSynonymDeclaration _ _ _ ty) = f ty + forDecls (TypeDeclaration _ _ ty) = f ty forDecls _ = mempty - forValues (TypeClassDictionary c _ _) = mconcat (map f (constraintArgs c)) - forValues (DeferredDictionary _ tys) = mconcat (map f tys) + forValues (TypeClassDictionary c _ _) = mconcat (fmap f (constraintArgs c)) + forValues (DeferredDictionary _ tys) = mconcat (fmap f tys) forValues (TypedValue _ _ ty) = f ty forValues _ = mempty @@ -647,21 +635,21 @@ ) accumKinds f = everythingOnValues mappend forDecls forValues (const mempty) (const mempty) (const mempty) where - forDecls (DataDeclaration _ _ args dctors) = + forDecls (DataDeclaration _ _ _ args dctors) = foldMap (foldMap f . snd) args `mappend` foldMap (foldMap forTypes . snd) dctors - forDecls (TypeClassDeclaration _ args implies _ _) = + forDecls (TypeClassDeclaration _ _ args implies _ _) = foldMap (foldMap f . snd) args `mappend` foldMap (foldMap forTypes . constraintArgs) implies - forDecls (TypeInstanceDeclaration _ cs _ tys _) = + forDecls (TypeInstanceDeclaration _ _ cs _ tys _) = foldMap (foldMap forTypes . constraintArgs) cs `mappend` foldMap forTypes tys - forDecls (TypeSynonymDeclaration _ args ty) = + forDecls (TypeSynonymDeclaration _ _ args ty) = foldMap (foldMap f . snd) args `mappend` forTypes ty - forDecls (TypeDeclaration _ ty) = forTypes ty - forDecls (ExternDeclaration _ ty) = forTypes ty - forDecls (ExternDataDeclaration _ kn) = f kn + forDecls (TypeDeclaration _ _ ty) = forTypes ty + forDecls (ExternDeclaration _ _ ty) = forTypes ty + forDecls (ExternDataDeclaration _ _ kn) = f kn forDecls _ = mempty forValues (TypeClassDictionary c _ _) = foldMap forTypes (constraintArgs c) @@ -680,5 +668,5 @@ where g :: Expr -> Expr g (TypedValue checkTy val t) = TypedValue checkTy val (f t) - g (TypeClassDictionary c sco hints) = TypeClassDictionary (mapConstraintArgs (map f) c) sco hints + g (TypeClassDictionary c sco hints) = TypeClassDictionary (mapConstraintArgs (fmap f) c) sco hints g other = other diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -146,13 +146,12 @@ js <- valueToJs val withPos ss $ AST.VariableIntroduction Nothing (identToJs ident) (Just js) - withPos :: Maybe SourceSpan -> AST -> m AST - withPos (Just ss) js = do + withPos :: SourceSpan -> AST -> m AST + withPos ss js = do withSM <- asks optionsSourceMaps return $ if withSM then withSourceSpan ss js else js - withPos Nothing js = return js -- | Generate code in the simplified JavaScript intermediate representation for a variable based on a -- PureScript identifier. @@ -177,7 +176,7 @@ valueToJs' :: Expr Ann -> m AST valueToJs' (Literal (pos, _, _, _) l) = - maybe id rethrowWithPosition pos $ literalToValueJS l + rethrowWithPosition pos $ literalToValueJS l valueToJs' (Var (_, _, _, Just (IsConstructor _ [])) name) = return $ accessorString "value" $ qualifiedToJS id name valueToJs' (Var (_, _, _, Just (IsConstructor _ _)) name) = @@ -222,9 +221,9 @@ valueToJs' (Var (_, _, _, Just IsForeign) ident) = internalError $ "Encountered an unqualified reference to a foreign ident " ++ T.unpack (showQualified showIdent ident) valueToJs' (Var _ ident) = return $ varToJs ident - valueToJs' (Case (maybeSpan, _, _, _) values binders) = do + valueToJs' (Case (ss, _, _, _) values binders) = do vals <- mapM valueToJs values - bindersToJs maybeSpan binders vals + bindersToJs ss binders vals valueToJs' (Let _ ds val) = do ds' <- concat <$> mapM bindToJs ds ret <- valueToJs val @@ -299,8 +298,8 @@ -- | Generate code in the simplified JavaScript intermediate representation for pattern match binders -- and guards. - bindersToJs :: Maybe SourceSpan -> [CaseAlternative Ann] -> [AST] -> m AST - bindersToJs maybeSpan binders vals = do + bindersToJs :: SourceSpan -> [CaseAlternative Ann] -> [AST] -> m AST + bindersToJs ss binders vals = do valNames <- replicateM (length vals) freshName let assignments = zipWith (AST.VariableIntroduction Nothing) valNames (map Just vals) jss <- forM binders $ \(CaseAlternative bs result) -> do @@ -320,7 +319,7 @@ failedPatternError names = AST.Unary Nothing AST.New $ AST.App Nothing (AST.Var Nothing "Error") [AST.Binary Nothing AST.Add (AST.StringLiteral Nothing $ mkString failedPatternMessage) (AST.ArrayLiteral Nothing $ zipWith valueError names vals)] failedPatternMessage :: Text - failedPatternMessage = "Failed pattern match" <> maybe "" (((" at " <> runModuleName mn <> " ") <>) . displayStartEndPos) maybeSpan <> ": " + failedPatternMessage = "Failed pattern match at " <> runModuleName mn <> " " <> displayStartEndPos ss <> ": " valueError :: Text -> AST -> AST valueError _ l@(AST.NumericLiteral _ _) = l diff --git a/src/Language/PureScript/Constants.hs b/src/Language/PureScript/Constants.hs --- a/src/Language/PureScript/Constants.hs +++ b/src/Language/PureScript/Constants.hs @@ -359,6 +359,20 @@ orderingGT :: Qualified (ProperName 'TypeName) orderingGT = Qualified (Just typeDataOrdering) (ProperName "GT") +-- Type.Row + +pattern TypeRow :: ModuleName +pattern TypeRow = ModuleName [ProperName "Type", ProperName "Row"] + +pattern RowToList :: Qualified (ProperName 'ClassName) +pattern RowToList = Qualified (Just TypeRow) (ProperName "RowToList") + +pattern RowListNil :: Qualified (ProperName 'TypeName) +pattern RowListNil = Qualified (Just TypeRow) (ProperName "Nil") + +pattern RowListCons :: Qualified (ProperName 'TypeName) +pattern RowListCons = Qualified (Just TypeRow) (ProperName "Cons") + -- Main module main :: forall a. (IsString a) => a diff --git a/src/Language/PureScript/CoreFn/Ann.hs b/src/Language/PureScript/CoreFn/Ann.hs --- a/src/Language/PureScript/CoreFn/Ann.hs +++ b/src/Language/PureScript/CoreFn/Ann.hs @@ -10,13 +10,13 @@ -- | -- Type alias for basic annotations -- -type Ann = (Maybe SourceSpan, [Comment], Maybe Type, Maybe Meta) +type Ann = (SourceSpan, [Comment], Maybe Type, Maybe Meta) -- | --- Initial annotation with no metadata +-- An annotation empty of metadata aside from a source span. -- -nullAnn :: Ann -nullAnn = (Nothing, [], Nothing, Nothing) +ssAnn :: SourceSpan -> Ann +ssAnn ss = (ss, [], Nothing, Nothing) -- | -- Remove the comments from an annotation diff --git a/src/Language/PureScript/CoreFn/Desugar.hs b/src/Language/PureScript/CoreFn/Desugar.hs --- a/src/Language/PureScript/CoreFn/Desugar.hs +++ b/src/Language/PureScript/CoreFn/Desugar.hs @@ -9,6 +9,7 @@ import Data.List (sort, sortBy) import Data.Maybe (mapMaybe) import Data.Tuple (swap) +import qualified Data.List.NonEmpty as NEL import qualified Data.Map as M import Language.PureScript.AST.Literals @@ -32,63 +33,52 @@ moduleToCoreFn :: Environment -> A.Module -> Module Ann moduleToCoreFn _ (A.Module _ _ _ _ Nothing) = internalError "Module exports were not elaborated before moduleToCoreFn" -moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) = - let imports = mapMaybe importToCoreFn decls ++ findQualModules decls - imports' = keepPositionedImports imports +moduleToCoreFn env (A.Module modSS coms mn decls (Just exps)) = + let imports = mapMaybe importToCoreFn decls ++ fmap (ssAnn modSS,) (findQualModules decls) + imports' = dedupeImports imports exps' = ordNub $ concatMap exportToCoreFn exps externs = ordNub $ mapMaybe externToCoreFn decls - decls' = concatMap (declToCoreFn Nothing []) decls + decls' = concatMap declToCoreFn decls in Module coms mn imports' exps' externs decls' where - -- | Remove duplicate imports favoring the ones containing source span - -- information - keepPositionedImports :: [(Ann, ModuleName)] -> [(Ann, ModuleName)] - keepPositionedImports = - map swap . M.toList . M.fromListWith preferSSpan . map swap - where - preferSSpan x y - | hasSS x = x - | otherwise = y - - hasSS :: Ann -> Bool - hasSS (Just _, _, _, _) = True - hasSS _ = False + -- | Remove duplicate imports + dedupeImports :: [(Ann, ModuleName)] -> [(Ann, ModuleName)] + dedupeImports = fmap swap . M.toList . M.fromListWith const . fmap swap - ssA :: Maybe SourceSpan -> Ann + ssA :: SourceSpan -> Ann ssA ss = (ss, [], Nothing, Nothing) -- | Desugars member declarations from AST to CoreFn representation. - declToCoreFn :: Maybe SourceSpan -> [Comment] -> A.Declaration -> [Bind Ann] - declToCoreFn ss com (A.DataDeclaration Newtype _ _ [(ctor, _)]) = + declToCoreFn :: A.Declaration -> [Bind Ann] + declToCoreFn (A.DataDeclaration (ss, com) Newtype _ _ [(ctor, _)]) = [NonRec (ssA ss) (properToIdent ctor) $ - Abs (ss, com, Nothing, Just IsNewtype) (Ident "x") (Var nullAnn $ Qualified Nothing (Ident "x"))] - declToCoreFn _ _ d@(A.DataDeclaration Newtype _ _ _) = + Abs (ss, com, Nothing, Just IsNewtype) (Ident "x") (Var (ssAnn ss) $ Qualified Nothing (Ident "x"))] + declToCoreFn d@(A.DataDeclaration _ Newtype _ _ _) = error $ "Found newtype with multiple constructors: " ++ show d - declToCoreFn ss com (A.DataDeclaration Data tyName _ ctors) = - flip map ctors $ \(ctor, _) -> + declToCoreFn (A.DataDeclaration (ss, com) Data tyName _ ctors) = + flip fmap ctors $ \(ctor, _) -> let (_, _, _, fields) = lookupConstructor env (Qualified (Just mn) ctor) in NonRec (ssA ss) (properToIdent ctor) $ Constructor (ss, com, Nothing, Nothing) tyName ctor fields - declToCoreFn ss _ (A.DataBindingGroupDeclaration ds) = concatMap (declToCoreFn ss []) ds - declToCoreFn ss com (A.ValueDeclaration name _ _ [A.MkUnguarded e]) = + declToCoreFn (A.DataBindingGroupDeclaration ds) = + concatMap declToCoreFn ds + declToCoreFn (A.ValueDeclaration (ss, com) name _ _ [A.MkUnguarded e]) = [NonRec (ssA ss) name (exprToCoreFn ss com Nothing e)] - declToCoreFn ss _ (A.BindingGroupDeclaration ds) = - [Rec $ map (\(name, _, e) -> ((ssA ss, name), exprToCoreFn ss [] Nothing e)) ds] - declToCoreFn ss com (A.TypeClassDeclaration name _ supers _ members) = - [NonRec (ssA ss) (properToIdent name) $ mkTypeClassConstructor ss com supers members] - declToCoreFn _ com (A.PositionedDeclaration ss com1 d) = - declToCoreFn (Just ss) (com ++ com1) d - declToCoreFn _ _ _ = [] + declToCoreFn (A.BindingGroupDeclaration ds) = + [Rec . NEL.toList $ fmap (\(((ss, com), name), _, e) -> ((ssA ss, name), exprToCoreFn ss com Nothing e)) ds] + declToCoreFn (A.TypeClassDeclaration sa@(ss, _) name _ supers _ members) = + [NonRec (ssA ss) (properToIdent name) $ mkTypeClassConstructor sa supers members] + declToCoreFn _ = [] -- | Desugars expressions from AST to CoreFn representation. - exprToCoreFn :: Maybe SourceSpan -> [Comment] -> Maybe Type -> A.Expr -> Expr Ann + exprToCoreFn :: SourceSpan -> [Comment] -> Maybe Type -> A.Expr -> Expr Ann exprToCoreFn ss com ty (A.Literal lit) = Literal (ss, com, ty, Nothing) (fmap (exprToCoreFn ss com Nothing) lit) exprToCoreFn ss com ty (A.Accessor name v) = Accessor (ss, com, ty, Nothing) name (exprToCoreFn ss [] Nothing v) exprToCoreFn ss com ty (A.ObjectUpdate obj vs) = - ObjectUpdate (ss, com, ty, Nothing) (exprToCoreFn ss [] Nothing obj) $ map (second (exprToCoreFn ss [] Nothing)) vs + ObjectUpdate (ss, com, ty, Nothing) (exprToCoreFn ss [] Nothing obj) $ fmap (second (exprToCoreFn ss [] Nothing)) vs exprToCoreFn ss com ty (A.Abs (A.VarBinder name) v) = Abs (ss, com, ty, Nothing) name (exprToCoreFn ss [] Nothing v) exprToCoreFn _ _ _ (A.Abs _ _) = @@ -99,34 +89,34 @@ Var (ss, com, ty, getValueMeta ident) ident exprToCoreFn ss com ty (A.IfThenElse v1 v2 v3) = Case (ss, com, ty, Nothing) [exprToCoreFn ss [] Nothing v1] - [ CaseAlternative [LiteralBinder nullAnn $ BooleanLiteral True] - (Right $ exprToCoreFn Nothing [] Nothing v2) - , CaseAlternative [NullBinder nullAnn] - (Right $ exprToCoreFn Nothing [] Nothing v3) ] + [ CaseAlternative [LiteralBinder (ssAnn ss) $ BooleanLiteral True] + (Right $ exprToCoreFn ss [] Nothing v2) + , CaseAlternative [NullBinder (ssAnn ss)] + (Right $ exprToCoreFn ss [] Nothing v3) ] exprToCoreFn ss com ty (A.Constructor name) = Var (ss, com, ty, Just $ getConstructorMeta name) $ fmap properToIdent name exprToCoreFn ss com ty (A.Case vs alts) = - Case (ss, com, ty, Nothing) (map (exprToCoreFn ss [] Nothing) vs) (map (altToCoreFn ss) alts) + Case (ss, com, ty, Nothing) (fmap (exprToCoreFn ss [] Nothing) vs) (fmap (altToCoreFn ss) alts) exprToCoreFn ss com _ (A.TypedValue _ v ty) = exprToCoreFn ss com (Just ty) v exprToCoreFn ss com ty (A.Let ds v) = - Let (ss, com, ty, Nothing) (concatMap (declToCoreFn ss []) ds) (exprToCoreFn ss [] Nothing v) + Let (ss, com, ty, Nothing) (concatMap declToCoreFn ds) (exprToCoreFn ss [] Nothing v) exprToCoreFn ss com ty (A.TypeClassDictionaryConstructorApp name (A.TypedValue _ lit@(A.Literal (A.ObjectLiteral _)) _)) = exprToCoreFn ss com ty (A.TypeClassDictionaryConstructorApp name lit) exprToCoreFn ss com _ (A.TypeClassDictionaryConstructorApp name (A.Literal (A.ObjectLiteral vs))) = - let args = map (exprToCoreFn ss [] Nothing . snd) $ sortBy (compare `on` fst) vs + let args = fmap (exprToCoreFn ss [] Nothing . snd) $ sortBy (compare `on` fst) vs ctor = Var (ss, [], Nothing, Just IsTypeClassConstructor) (fmap properToIdent name) in foldl (App (ss, com, Nothing, Nothing)) ctor args exprToCoreFn ss com ty (A.TypeClassDictionaryAccessor _ ident) = Abs (ss, com, ty, Nothing) (Ident "dict") - (Accessor nullAnn (mkString $ runIdent ident) (Var nullAnn $ Qualified Nothing (Ident "dict"))) + (Accessor (ssAnn ss) (mkString $ runIdent ident) (Var (ssAnn ss) $ Qualified Nothing (Ident "dict"))) exprToCoreFn _ com ty (A.PositionedValue ss com1 v) = - exprToCoreFn (Just ss) (com ++ com1) ty v + exprToCoreFn ss (com ++ com1) ty v exprToCoreFn _ _ _ e = error $ "Unexpected value in exprToCoreFn mn: " ++ show e -- | Desugars case alternatives from AST to CoreFn representation. - altToCoreFn :: Maybe SourceSpan -> A.CaseAlternative -> CaseAlternative Ann + altToCoreFn :: SourceSpan -> A.CaseAlternative -> CaseAlternative Ann altToCoreFn ss (A.CaseAlternative bs vs) = CaseAlternative (map (binderToCoreFn ss []) bs) (go vs) where go :: [A.GuardedExpr] -> Either [(Guard Ann, Expr Ann)] (Expr Ann) @@ -142,7 +132,7 @@ guardToExpr _ = internalError "Guard not correctly desugared" -- | Desugars case binders from AST to CoreFn representation. - binderToCoreFn :: Maybe SourceSpan -> [Comment] -> A.Binder -> Binder Ann + binderToCoreFn :: SourceSpan -> [Comment] -> A.Binder -> Binder Ann binderToCoreFn ss com (A.LiteralBinder lit) = LiteralBinder (ss, com, Nothing, Nothing) (fmap (binderToCoreFn ss com) lit) binderToCoreFn ss com A.NullBinder = @@ -151,11 +141,11 @@ VarBinder (ss, com, Nothing, Nothing) name binderToCoreFn ss com (A.ConstructorBinder dctor@(Qualified mn' _) bs) = let (_, tctor, _, _) = lookupConstructor env dctor - in ConstructorBinder (ss, com, Nothing, Just $ getConstructorMeta dctor) (Qualified mn' tctor) dctor (map (binderToCoreFn ss []) bs) + in ConstructorBinder (ss, com, Nothing, Just $ getConstructorMeta dctor) (Qualified mn' tctor) dctor (fmap (binderToCoreFn ss []) bs) binderToCoreFn ss com (A.NamedBinder name b) = NamedBinder (ss, com, Nothing, Nothing) name (binderToCoreFn ss [] b) binderToCoreFn _ com (A.PositionedBinder ss com1 b) = - binderToCoreFn (Just ss) (com ++ com1) b + binderToCoreFn ss (com ++ com1) b binderToCoreFn ss com (A.TypedBinder _ b) = binderToCoreFn ss com b binderToCoreFn _ _ A.OpBinder{} = @@ -196,15 +186,15 @@ -- | Find module names from qualified references to values. This is used to -- ensure instances are imported from any module that is referenced by the -- current module, not just from those that are imported explicitly (#667). -findQualModules :: [A.Declaration] -> [(Ann, ModuleName)] +findQualModules :: [A.Declaration] -> [ModuleName] findQualModules decls = let (f, _, _, _, _) = everythingOnValues (++) fqDecls fqValues fqBinders (const []) (const []) - in map (nullAnn,) $ f `concatMap` decls + in f `concatMap` decls where fqDecls :: A.Declaration -> [ModuleName] - fqDecls (A.TypeInstanceDeclaration _ _ q _ _) = getQual' q - fqDecls (A.ValueFixityDeclaration _ q _) = getQual' q - fqDecls (A.TypeFixityDeclaration _ q _) = getQual' q + fqDecls (A.TypeInstanceDeclaration _ _ _ q _ _) = getQual' q + fqDecls (A.ValueFixityDeclaration _ _ q _) = getQual' q + fqDecls (A.TypeFixityDeclaration _ _ q _) = getQual' q fqDecls _ = [] fqValues :: A.Expr -> [ModuleName] @@ -225,40 +215,36 @@ -- | Desugars import declarations from AST to CoreFn representation. importToCoreFn :: A.Declaration -> Maybe (Ann, ModuleName) -importToCoreFn (A.ImportDeclaration name _ _) = Just (nullAnn, name) -importToCoreFn (A.PositionedDeclaration ss _ d) = - ((,) (Just ss, [], Nothing, Nothing) . snd) <$> importToCoreFn d +importToCoreFn (A.ImportDeclaration (ss, com) name _ _) = Just ((ss, com, Nothing, Nothing), name) importToCoreFn _ = Nothing -- | Desugars foreign declarations from AST to CoreFn representation. externToCoreFn :: A.Declaration -> Maybe ForeignDecl -externToCoreFn (A.ExternDeclaration name ty) = Just (name, ty) -externToCoreFn (A.PositionedDeclaration _ _ d) = externToCoreFn d +externToCoreFn (A.ExternDeclaration _ name ty) = Just (name, ty) externToCoreFn _ = Nothing -- | Desugars export declarations references from AST to CoreFn representation. -- CoreFn modules only export values, so all data constructors, class -- constructor, instances and values are flattened into one list. exportToCoreFn :: A.DeclarationRef -> [Ident] -exportToCoreFn (A.TypeRef _ (Just dctors)) = map properToIdent dctors -exportToCoreFn (A.ValueRef name) = [name] -exportToCoreFn (A.TypeClassRef name) = [properToIdent name] -exportToCoreFn (A.TypeInstanceRef name) = [name] -exportToCoreFn (A.PositionedDeclarationRef _ _ d) = exportToCoreFn d +exportToCoreFn (A.TypeRef _ _ (Just dctors)) = fmap properToIdent dctors +exportToCoreFn (A.ValueRef _ name) = [name] +exportToCoreFn (A.TypeClassRef _ name) = [properToIdent name] +exportToCoreFn (A.TypeInstanceRef _ name) = [name] exportToCoreFn _ = [] -- | Makes a typeclass dictionary constructor function. The returned expression -- is a function that accepts the superclass instances and member -- implementations and returns a record for the instance dictionary. -mkTypeClassConstructor :: Maybe SourceSpan -> [Comment] -> [Constraint] -> [A.Declaration] -> Expr Ann -mkTypeClassConstructor ss com [] [] = Literal (ss, com, Nothing, Just IsTypeClassConstructor) (ObjectLiteral []) -mkTypeClassConstructor ss com supers members = - let args@(a:as) = sort $ map typeClassMemberName members ++ superClassDictionaryNames supers - props = [ (mkString arg, Var nullAnn $ Qualified Nothing (Ident arg)) | arg <- args ] - dict = Literal nullAnn (ObjectLiteral props) +mkTypeClassConstructor :: SourceAnn -> [Constraint] -> [A.Declaration] -> Expr Ann +mkTypeClassConstructor (ss, com) [] [] = Literal (ss, com, Nothing, Just IsTypeClassConstructor) (ObjectLiteral []) +mkTypeClassConstructor (ss, com) supers members = + let args@(a:as) = sort $ fmap typeClassMemberName members ++ superClassDictionaryNames supers + props = [ (mkString arg, Var (ssAnn ss) $ Qualified Nothing (Ident arg)) | arg <- args ] + dict = Literal (ssAnn ss) (ObjectLiteral props) in Abs (ss, com, Nothing, Just IsTypeClassConstructor) (Ident a) - (foldr (Abs nullAnn . Ident) dict as) + (foldr (Abs (ssAnn ss) . Ident) dict as) -- | Converts a ProperName to an Ident. properToIdent :: ProperName a -> Ident diff --git a/src/Language/PureScript/Docs/AsHtml.hs b/src/Language/PureScript/Docs/AsHtml.hs --- a/src/Language/PureScript/Docs/AsHtml.hs +++ b/src/Language/PureScript/Docs/AsHtml.hs @@ -163,12 +163,17 @@ renderChildren :: HtmlRenderContext -> [ChildDeclaration] -> Html renderChildren _ [] = return () -renderChildren r xs = ul $ mapM_ go xs +renderChildren r xs = ul $ mapM_ item xs where - go decl = item decl . code . codeAsHtml r . Render.renderChildDeclaration $ decl - item decl = let fragment = makeFragment (childDeclInfoNamespace (cdeclInfo decl)) (cdeclTitle decl) - in li ! A.id (v (T.drop 1 fragment)) + item decl = + li ! A.id (v (T.drop 1 (fragment decl))) $ do + renderCode decl + for_ (cdeclComments decl) $ \coms -> + H.div ! A.class_ "decl__child_comments" $ renderMarkdown coms + fragment decl = makeFragment (childDeclInfoNamespace (cdeclInfo decl)) (cdeclTitle decl) + renderCode = code . codeAsHtml r . Render.renderChildDeclaration + codeAsHtml :: HtmlRenderContext -> RenderedCode -> Html codeAsHtml r = outputWith elemAsHtml where @@ -184,8 +189,9 @@ Link mn -> let class_ = if startsWithUpper name then "ctor" else "ident" + target = if ns == TypeLevel then "type (" <> name <> ")" else name in - linkToDecl ns name mn (withClass class_ (text name)) + linkToDecl ns target mn (withClass class_ (text name)) NoLink -> text name @@ -293,10 +299,13 @@ partitionChildren :: [ChildDeclaration] -> ([ChildDeclaration], [ChildDeclaration], [ChildDeclaration]) -partitionChildren = foldl go ([], [], []) +partitionChildren = + reverseAll . foldl go ([], [], []) where go (instances, dctors, members) rcd = case cdeclInfo rcd of ChildInstance _ _ -> (rcd : instances, dctors, members) ChildDataConstructor _ -> (instances, rcd : dctors, members) ChildTypeClassMember _ -> (instances, dctors, rcd : members) + + reverseAll (xs, ys, zs) = (reverse xs, reverse ys, reverse zs) diff --git a/src/Language/PureScript/Docs/Convert.hs b/src/Language/PureScript/Docs/Convert.hs --- a/src/Language/PureScript/Docs/Convert.hs +++ b/src/Language/PureScript/Docs/Convert.hs @@ -20,7 +20,6 @@ import Language.PureScript.Docs.Convert.Single (convertSingleModule) import Language.PureScript.Docs.Types import qualified Language.PureScript as P -import qualified Language.PureScript.Constants as C import Web.Bower.PackageMeta (PackageName) @@ -87,11 +86,8 @@ m ([Module], P.Env) convertModulesWithEnv withPackage = P.sortModules - >>> fmap (fst >>> map importPrim) + >>> fmap (fst >>> map P.importPrim) >=> convertSorted withPackage - -importPrim :: P.Module -> P.Module -importPrim = P.addDefaultImport (P.ModuleName [P.ProperName C.prim]) -- | -- Convert a sorted list of modules, returning both the list of converted diff --git a/src/Language/PureScript/Docs/Convert/Single.hs b/src/Language/PureScript/Docs/Convert/Single.hs --- a/src/Language/PureScript/Docs/Convert/Single.hs +++ b/src/Language/PureScript/Docs/Convert/Single.hs @@ -82,66 +82,63 @@ d { declChildren = declChildren d ++ [child] } getDeclarationTitle :: P.Declaration -> Maybe Text -getDeclarationTitle (P.ValueDeclaration name _ _ _) = Just (P.showIdent name) -getDeclarationTitle (P.ExternDeclaration name _) = Just (P.showIdent name) -getDeclarationTitle (P.DataDeclaration _ name _ _) = Just (P.runProperName name) -getDeclarationTitle (P.ExternDataDeclaration name _) = Just (P.runProperName name) -getDeclarationTitle (P.ExternKindDeclaration name) = Just (P.runProperName name) -getDeclarationTitle (P.TypeSynonymDeclaration name _ _) = Just (P.runProperName name) -getDeclarationTitle (P.TypeClassDeclaration name _ _ _ _) = Just (P.runProperName name) -getDeclarationTitle (P.TypeInstanceDeclaration name _ _ _ _) = Just (P.showIdent name) -getDeclarationTitle (P.TypeFixityDeclaration _ _ op) = Just ("type " <> P.showOp op) -getDeclarationTitle (P.ValueFixityDeclaration _ _ op) = Just (P.showOp op) -getDeclarationTitle (P.PositionedDeclaration _ _ d) = getDeclarationTitle d +getDeclarationTitle (P.ValueDeclaration _ name _ _ _) = Just (P.showIdent name) +getDeclarationTitle (P.ExternDeclaration _ name _) = Just (P.showIdent name) +getDeclarationTitle (P.DataDeclaration _ _ name _ _) = Just (P.runProperName name) +getDeclarationTitle (P.ExternDataDeclaration _ name _) = Just (P.runProperName name) +getDeclarationTitle (P.ExternKindDeclaration _ name) = Just (P.runProperName name) +getDeclarationTitle (P.TypeSynonymDeclaration _ name _ _) = Just (P.runProperName name) +getDeclarationTitle (P.TypeClassDeclaration _ name _ _ _ _) = Just (P.runProperName name) +getDeclarationTitle (P.TypeInstanceDeclaration _ name _ _ _ _) = Just (P.showIdent name) +getDeclarationTitle (P.TypeFixityDeclaration _ _ _ op) = Just ("type " <> P.showOp op) +getDeclarationTitle (P.ValueFixityDeclaration _ _ _ op) = Just (P.showOp op) getDeclarationTitle _ = Nothing -- | Create a basic Declaration value. -mkDeclaration :: Text -> DeclarationInfo -> Declaration -mkDeclaration title info = +mkDeclaration :: P.SourceAnn -> Text -> DeclarationInfo -> Declaration +mkDeclaration (ss, com) title info = Declaration { declTitle = title - , declComments = Nothing - , declSourceSpan = Nothing + , declComments = convertComments com + , declSourceSpan = Just ss -- TODO: make this non-optional when we next break the format , declChildren = [] , declInfo = info } -basicDeclaration :: Text -> DeclarationInfo -> Maybe IntermediateDeclaration -basicDeclaration title info = Just $ Right $ mkDeclaration title info +basicDeclaration :: P.SourceAnn -> Text -> DeclarationInfo -> Maybe IntermediateDeclaration +basicDeclaration sa title = Just . Right . mkDeclaration sa title convertDeclaration :: P.Declaration -> Text -> Maybe IntermediateDeclaration -convertDeclaration (P.ValueDeclaration _ _ _ [P.MkUnguarded (P.TypedValue _ _ ty)]) title = - basicDeclaration title (ValueDeclaration ty) -convertDeclaration P.ValueDeclaration{} title = +convertDeclaration (P.ValueDeclaration sa _ _ _ [P.MkUnguarded (P.TypedValue _ _ ty)]) title = + basicDeclaration sa title (ValueDeclaration ty) +convertDeclaration (P.ValueDeclaration sa _ _ _ _) title = -- If no explicit type declaration was provided, insert a wildcard, so that -- the actual type will be added during type checking. - basicDeclaration title (ValueDeclaration P.TypeWildcard{}) -convertDeclaration (P.ExternDeclaration _ ty) title = - basicDeclaration title (ValueDeclaration ty) -convertDeclaration (P.DataDeclaration dtype _ args ctors) title = - Just (Right (mkDeclaration title info) { declChildren = children }) + basicDeclaration sa title (ValueDeclaration P.TypeWildcard{}) +convertDeclaration (P.ExternDeclaration sa _ ty) title = + basicDeclaration sa title (ValueDeclaration ty) +convertDeclaration (P.DataDeclaration sa dtype _ args ctors) title = + Just (Right (mkDeclaration sa title info) { declChildren = children }) where info = DataDeclaration dtype args children = map convertCtor ctors convertCtor (ctor', tys) = ChildDeclaration (P.runProperName ctor') Nothing Nothing (ChildDataConstructor tys) -convertDeclaration (P.ExternDataDeclaration _ kind') title = - basicDeclaration title (ExternDataDeclaration kind') -convertDeclaration (P.ExternKindDeclaration _) title = - basicDeclaration title ExternKindDeclaration -convertDeclaration (P.TypeSynonymDeclaration _ args ty) title = - basicDeclaration title (TypeSynonymDeclaration args ty) -convertDeclaration (P.TypeClassDeclaration _ args implies fundeps ds) title = - Just (Right (mkDeclaration title info) { declChildren = children }) +convertDeclaration (P.ExternDataDeclaration sa _ kind') title = + basicDeclaration sa title (ExternDataDeclaration kind') +convertDeclaration (P.ExternKindDeclaration sa _) title = + basicDeclaration sa title ExternKindDeclaration +convertDeclaration (P.TypeSynonymDeclaration sa _ args ty) title = + basicDeclaration sa title (TypeSynonymDeclaration args ty) +convertDeclaration (P.TypeClassDeclaration sa _ args implies fundeps ds) title = + Just (Right (mkDeclaration sa title info) { declChildren = children }) where info = TypeClassDeclaration args implies (convertFundepsToStrings args fundeps) children = map convertClassMember ds - convertClassMember (P.PositionedDeclaration _ _ d) = - convertClassMember d - convertClassMember (P.TypeDeclaration ident' ty) = - ChildDeclaration (P.showIdent ident') Nothing Nothing (ChildTypeClassMember ty) + convertClassMember (P.TypeDeclaration (ss, com) ident' ty) = + ChildDeclaration (P.showIdent ident') (convertComments com) (Just ss) (ChildTypeClassMember ty) convertClassMember _ = P.internalError "convertDeclaration: Invalid argument to convertClassMember." -convertDeclaration (P.TypeInstanceDeclaration _ constraints className tys _) title = +convertDeclaration (P.TypeInstanceDeclaration (ss, com) _ constraints className tys _) title = Just (Left ((classNameString, AugmentClass) : map (, AugmentType) typeNameStrings, AugmentChild childDecl)) where classNameString = unQual className @@ -151,28 +148,12 @@ extractProperNames (P.TypeConstructor n) = [unQual n] extractProperNames _ = [] - childDecl = ChildDeclaration title Nothing Nothing (ChildInstance constraints classApp) + childDecl = ChildDeclaration title (convertComments com) (Just ss) (ChildInstance constraints classApp) classApp = foldl' P.TypeApp (P.TypeConstructor (fmap P.coerceProperName className)) tys -convertDeclaration (P.ValueFixityDeclaration fixity (P.Qualified mn alias) _) title = - Just $ Right $ mkDeclaration title (AliasDeclaration fixity (P.Qualified mn (Right alias))) -convertDeclaration (P.TypeFixityDeclaration fixity (P.Qualified mn alias) _) title = - Just $ Right $ mkDeclaration title (AliasDeclaration fixity (P.Qualified mn (Left alias))) -convertDeclaration (P.PositionedDeclaration srcSpan com d') title = - fmap (addComments . addSourceSpan) (convertDeclaration d' title) - where - addComments (Right d) = - Right (d { declComments = convertComments com }) - addComments (Left augment) = - Left (withAugmentChild (\d -> d { cdeclComments = convertComments com }) - augment) - - addSourceSpan (Right d) = - Right (d { declSourceSpan = Just srcSpan }) - addSourceSpan (Left augment) = - Left (withAugmentChild (\d -> d { cdeclSourceSpan = Just srcSpan }) - augment) - - withAugmentChild f (t, AugmentChild d) = (t, AugmentChild (f d)) +convertDeclaration (P.ValueFixityDeclaration sa fixity (P.Qualified mn alias) _) title = + Just . Right $ mkDeclaration sa title (AliasDeclaration fixity (P.Qualified mn (Right alias))) +convertDeclaration (P.TypeFixityDeclaration sa fixity (P.Qualified mn alias) _) title = + Just . Right $ mkDeclaration sa title (AliasDeclaration fixity (P.Qualified mn (Left alias))) convertDeclaration _ _ = Nothing convertComments :: [P.Comment] -> Maybe Text diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -19,6 +19,7 @@ import Data.Foldable (fold) import Data.Functor.Identity (Identity(..)) import Data.List (transpose, nubBy, sort, partition, dropWhileEnd) +import qualified Data.List.NonEmpty as NEL import Data.Maybe (maybeToList, fromMaybe, mapMaybe) import qualified Data.Map as M import qualified Data.Text as T @@ -189,6 +190,10 @@ errorMessage :: SimpleErrorMessage -> MultipleErrors errorMessage err = MultipleErrors [ErrorMessage [] err] +-- | Create an error set from a single simple error message and source annotation +errorMessage' :: SourceSpan -> SimpleErrorMessage -> MultipleErrors +errorMessage' ss err = MultipleErrors [ErrorMessage [PositionedError ss] err] + -- | Create an error set from a single error message singleError :: ErrorMessage -> MultipleErrors singleError = MultipleErrors . pure @@ -1040,7 +1045,7 @@ ] renderHint (ErrorInBindingGroup nms) detail = paras [ detail - , line $ "in binding group " <> T.intercalate ", " (map showIdent nms) + , line $ "in binding group " <> T.intercalate ", " (NEL.toList (fmap showIdent nms)) ] renderHint (ErrorInDataBindingGroup nms) detail = paras [ detail @@ -1190,7 +1195,7 @@ -- Pretty print and export declaration prettyPrintExport :: DeclarationRef -> Text -prettyPrintExport (TypeRef pn _) = runProperName pn +prettyPrintExport (TypeRef _ pn _) = runProperName pn prettyPrintExport ref = fromMaybe (internalError "prettyPrintRef returned Nothing in prettyPrintExport") @@ -1205,30 +1210,28 @@ in i <> maybe "" (\q -> " as " <> runModuleName q) qual prettyPrintRef :: DeclarationRef -> Maybe Text -prettyPrintRef (TypeRef pn Nothing) = +prettyPrintRef (TypeRef _ pn Nothing) = Just $ runProperName pn <> "(..)" -prettyPrintRef (TypeRef pn (Just [])) = +prettyPrintRef (TypeRef _ pn (Just [])) = Just $ runProperName pn -prettyPrintRef (TypeRef pn (Just dctors)) = +prettyPrintRef (TypeRef _ pn (Just dctors)) = Just $ runProperName pn <> "(" <> T.intercalate ", " (map runProperName dctors) <> ")" -prettyPrintRef (TypeOpRef op) = +prettyPrintRef (TypeOpRef _ op) = Just $ "type " <> showOp op -prettyPrintRef (ValueRef ident) = +prettyPrintRef (ValueRef _ ident) = Just $ showIdent ident -prettyPrintRef (ValueOpRef op) = +prettyPrintRef (ValueOpRef _ op) = Just $ showOp op -prettyPrintRef (TypeClassRef pn) = +prettyPrintRef (TypeClassRef _ pn) = Just $ "class " <> runProperName pn -prettyPrintRef (TypeInstanceRef ident) = +prettyPrintRef (TypeInstanceRef _ ident) = Just $ showIdent ident -prettyPrintRef (ModuleRef name) = +prettyPrintRef (ModuleRef _ name) = Just $ "module " <> runModuleName name -prettyPrintRef (KindRef pn) = +prettyPrintRef (KindRef _ pn) = Just $ "kind " <> runProperName pn -prettyPrintRef (ReExportRef _ _) = +prettyPrintRef ReExportRef{} = Nothing -prettyPrintRef (PositionedDeclarationRef _ _ ref) = - prettyPrintRef ref -- | Pretty print multiple errors prettyPrintMultipleErrors :: PPEOptions -> MultipleErrors -> String diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs --- a/src/Language/PureScript/Externs.hs +++ b/src/Language/PureScript/Externs.hs @@ -178,28 +178,24 @@ efSourceSpan = ss fixityDecl :: Declaration -> Maybe ExternsFixity - fixityDecl (ValueFixityDeclaration (Fixity assoc prec) name op) = - fmap (const (ExternsFixity assoc prec op name)) (find (findOp getValueOpRef op) exps) - fixityDecl (PositionedDeclaration _ _ d) = fixityDecl d + fixityDecl (ValueFixityDeclaration _ (Fixity assoc prec) name op) = + fmap (const (ExternsFixity assoc prec op name)) (find (findOp getValueOpRef op) exps) fixityDecl _ = Nothing typeFixityDecl :: Declaration -> Maybe ExternsTypeFixity - typeFixityDecl (TypeFixityDeclaration (Fixity assoc prec) name op) = - fmap (const (ExternsTypeFixity assoc prec op name)) (find (findOp getTypeOpRef op) exps) - typeFixityDecl (PositionedDeclaration _ _ d) = typeFixityDecl d + typeFixityDecl (TypeFixityDeclaration _ (Fixity assoc prec) name op) = + fmap (const (ExternsTypeFixity assoc prec op name)) (find (findOp getTypeOpRef op) exps) typeFixityDecl _ = Nothing findOp :: (DeclarationRef -> Maybe (OpName a)) -> OpName a -> DeclarationRef -> Bool findOp g op = maybe False (== op) . g importDecl :: Declaration -> Maybe ExternsImport - importDecl (ImportDeclaration m mt qmn) = Just (ExternsImport m mt qmn) - importDecl (PositionedDeclaration _ _ d) = importDecl d + importDecl (ImportDeclaration _ m mt qmn) = Just (ExternsImport m mt qmn) importDecl _ = Nothing toExternsDeclaration :: DeclarationRef -> [ExternsDeclaration] - toExternsDeclaration (PositionedDeclarationRef _ _ r) = toExternsDeclaration r - toExternsDeclaration (TypeRef pn dctors) = + toExternsDeclaration (TypeRef _ pn dctors) = case Qualified (Just mn) pn `M.lookup` types env of Nothing -> internalError "toExternsDeclaration: no kind in toExternsDeclaration" Just (kind, TypeSynonym) @@ -211,10 +207,10 @@ , (dty, _, ty, args) <- maybeToList (Qualified (Just mn) dctor `M.lookup` dataConstructors env) ] _ -> internalError "toExternsDeclaration: Invalid input" - toExternsDeclaration (ValueRef ident) + toExternsDeclaration (ValueRef _ ident) | Just (ty, _, _) <- Qualified (Just mn) ident `M.lookup` names env = [ EDValue ident ty ] - toExternsDeclaration (TypeClassRef className) + toExternsDeclaration (TypeClassRef _ className) | Just TypeClassData{..} <- Qualified (Just mn) className `M.lookup` typeClasses env , Just (kind, TypeSynonym) <- Qualified (Just mn) (coerceProperName className) `M.lookup` types env , Just (_, synTy) <- Qualified (Just mn) (coerceProperName className) `M.lookup` typeSynonyms env @@ -222,13 +218,13 @@ , EDTypeSynonym (coerceProperName className) typeClassArguments synTy , EDClass className typeClassArguments typeClassMembers typeClassSuperclasses typeClassDependencies ] - toExternsDeclaration (TypeInstanceRef ident) + toExternsDeclaration (TypeInstanceRef _ ident) = [ EDInstance tcdClassName ident tcdInstanceTypes tcdDependencies | m1 <- maybeToList (M.lookup (Just mn) (typeClassDictionaries env)) , m2 <- M.elems m1 , TypeClassDictionaryInScope{..} <- maybeToList (M.lookup (Qualified (Just mn) ident) m2) ] - toExternsDeclaration (KindRef pn) + toExternsDeclaration (KindRef _ pn) | Qualified (Just mn) pn `S.member` kinds env = [ EDKind pn ] toExternsDeclaration _ = [] diff --git a/src/Language/PureScript/Ide.hs b/src/Language/PureScript/Ide.hs --- a/src/Language/PureScript/Ide.hs +++ b/src/Language/PureScript/Ide.hs @@ -12,8 +12,7 @@ -- Interface for the psc-ide-server ----------------------------------------------------------------------------- -{-# LANGUAGE PackageImports #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE PackageImports #-} module Language.PureScript.Ide ( handleCommand @@ -23,6 +22,7 @@ import "monad-logger" Control.Monad.Logger import qualified Language.PureScript as P +import qualified Language.PureScript.Constants as C import qualified Language.PureScript.Ide.CaseSplit as CS import Language.PureScript.Ide.Command import Language.PureScript.Ide.Completion @@ -31,6 +31,7 @@ import Language.PureScript.Ide.Filter import Language.PureScript.Ide.Imports hiding (Import) import Language.PureScript.Ide.Matcher +import Language.PureScript.Ide.Prim import Language.PureScript.Ide.Pursuit import Language.PureScript.Ide.Rebuild import Language.PureScript.Ide.SourceFile @@ -43,8 +44,10 @@ -- | Accepts a Commmand and runs it against psc-ide's State. This is the main -- entry point for the server. -handleCommand :: (Ide m, MonadLogger m, MonadError IdeError m) => - Command -> m Success +handleCommand + :: (Ide m, MonadLogger m, MonadError IdeError m) + => Command + -> m Success handleCommand c = case c of Load [] -> findAvailableExterns >>= loadModulesAsync @@ -104,13 +107,15 @@ -> m Success findCompletions filters matcher currentModule complOptions = do modules <- getAllModules currentModule - pure (CompletionResult (getCompletions filters matcher complOptions modules)) + let insertPrim = (:) (C.Prim, idePrimDeclarations) + pure (CompletionResult (getCompletions filters matcher complOptions (insertPrim modules))) findType :: Ide m => Text -> [Filter] -> Maybe P.ModuleName -> m Success findType search filters currentModule = do modules <- getAllModules currentModule - pure (CompletionResult (getExactCompletions search filters modules)) + let insertPrim = (:) (C.Prim, idePrimDeclarations) + pure (CompletionResult (getExactCompletions search filters (insertPrim modules))) findPursuitCompletions :: MonadIO m => PursuitQuery -> m Success @@ -218,7 +223,7 @@ (failures, allModules) <- partitionEithers <$> (parseModulesFromFiles =<< findAllSourceFiles) unless (null failures) $ - $(logWarn) ("Failed to parse: " <> show failures) + logWarnN ("Failed to parse: " <> show failures) traverse_ insertModule allModules pure (TextResult ("Loaded " <> show (length efiles) <> " modules and " diff --git a/src/Language/PureScript/Ide/CaseSplit.hs b/src/Language/PureScript/Ide/CaseSplit.hs --- a/src/Language/PureScript/Ide/CaseSplit.hs +++ b/src/Language/PureScript/Ide/CaseSplit.hs @@ -30,7 +30,6 @@ import Language.PureScript.Ide.Error import Language.PureScript.Ide.State import Language.PureScript.Ide.Types -import Language.PureScript.Ide.Util import Text.Parsec as Parsec import qualified Text.PrettyPrint.Boxes as Box @@ -129,8 +128,8 @@ ts <- P.lex "" (toS s) P.runTokenParser "" (P.parseDeclaration <* Parsec.eof) ts in - case unwrapPositioned <$> x of - Right (P.TypeDeclaration i t) -> pure (i, t) + case x of + Right (P.TypeDeclaration _ i t) -> pure (i, t) Right _ -> throwError (GeneralError "Found a non-type-declaration") Left err -> throwError (GeneralError ("Parsing the type signature failed with: " diff --git a/src/Language/PureScript/Ide/Completion.hs b/src/Language/PureScript/Ide/Completion.hs --- a/src/Language/PureScript/Ide/Completion.hs +++ b/src/Language/PureScript/Ide/Completion.hs @@ -76,11 +76,11 @@ defaultCompletionOptions = CompletionOptions { coMaxResults = Nothing, coGroupReexports = False } applyCompletionOptions :: CompletionOptions -> [Match IdeDeclarationAnn] -> [(Match IdeDeclarationAnn, [P.ModuleName])] -applyCompletionOptions co decls = - maybe identity take (coMaxResults co) decls - & if coGroupReexports co - then groupCompletionReexports - else map simpleExport +applyCompletionOptions co decls = decls + & (if coGroupReexports co + then groupCompletionReexports + else map simpleExport) + & maybe identity take (coMaxResults co) simpleExport :: Match a -> (Match a, [P.ModuleName]) simpleExport match@(Match (moduleName, _)) = (match, [moduleName]) diff --git a/src/Language/PureScript/Ide/Externs.hs b/src/Language/PureScript/Ide/Externs.hs --- a/src/Language/PureScript/Ide/Externs.hs +++ b/src/Language/PureScript/Ide/Externs.hs @@ -28,12 +28,13 @@ import Data.Version (showVersion) import Language.PureScript.Ide.Error (IdeError (..)) import Language.PureScript.Ide.Types -import Language.PureScript.Ide.Util import qualified Language.PureScript as P -readExternFile :: (MonadIO m, MonadError IdeError m, MonadLogger m) => - FilePath -> m P.ExternsFile +readExternFile + :: (MonadIO m, MonadError IdeError m, MonadLogger m) + => FilePath + -> m P.ExternsFile readExternFile fp = do parseResult <- liftIO (decodeStrict <$> BS.readFile fp) case parseResult of @@ -58,8 +59,8 @@ where decls = map (IdeDeclarationAnn emptyAnn) - (resolvedDeclarations ++ operatorDecls ++ tyOperatorDecls) - exportDecls = mapMaybe (convertExport . unwrapPositionedRef) (P.efExports ef) + (resolvedDeclarations <> operatorDecls <> tyOperatorDecls) + exportDecls = mapMaybe convertExport (P.efExports ef) operatorDecls = convertOperator <$> P.efFixities ef tyOperatorDecls = convertTypeOperator <$> P.efTypeFixities ef (toResolve, declarations) = @@ -114,35 +115,45 @@ | SynonymToResolve (P.ProperName 'P.TypeName) P.Type convertExport :: P.DeclarationRef -> Maybe (P.ModuleName, P.DeclarationRef) -convertExport (P.ReExportRef m r) = Just (m, r) +convertExport (P.ReExportRef _ m r) = Just (m, r) convertExport _ = Nothing convertDecl :: P.ExternsDeclaration -> Either ToResolve (Maybe IdeDeclaration) -convertDecl P.EDType{..} = Right $ Just $ IdeDeclType $ - IdeType edTypeName edTypeKind -convertDecl P.EDTypeSynonym{..} = Left (SynonymToResolve edTypeSynonymName edTypeSynonymType) -convertDecl P.EDDataConstructor{..} = Right $ Just $ IdeDeclDataConstructor $ - IdeDataConstructor edDataCtorName edDataCtorTypeCtor edDataCtorType -convertDecl P.EDValue{..} = Right $ Just $ IdeDeclValue $ - IdeValue edValueName edValueType -convertDecl P.EDClass{..} = Left (TypeClassToResolve edClassName) -convertDecl P.EDKind{..} = Right (Just (IdeDeclKind edKindName)) -convertDecl P.EDInstance{} = Right Nothing +convertDecl ed = case ed of + P.EDType{..} -> + Right (Just (IdeDeclType (IdeType edTypeName edTypeKind []))) + P.EDTypeSynonym{..} -> + Left (SynonymToResolve edTypeSynonymName edTypeSynonymType) + P.EDDataConstructor{..} -> + Right + (Just + (IdeDeclDataConstructor + (IdeDataConstructor edDataCtorName edDataCtorTypeCtor edDataCtorType))) + P.EDValue{..} -> + Right (Just (IdeDeclValue (IdeValue edValueName edValueType))) + P.EDClass{..} -> + Left (TypeClassToResolve edClassName) + P.EDKind{..} -> + Right (Just (IdeDeclKind edKindName)) + P.EDInstance{} -> + Right Nothing convertOperator :: P.ExternsFixity -> IdeDeclaration convertOperator P.ExternsFixity{..} = - IdeDeclValueOperator $ IdeValueOperator - efOperator - efAlias - efPrecedence - efAssociativity - Nothing + IdeDeclValueOperator + (IdeValueOperator + efOperator + efAlias + efPrecedence + efAssociativity + Nothing) convertTypeOperator :: P.ExternsTypeFixity -> IdeDeclaration convertTypeOperator P.ExternsTypeFixity{..} = - IdeDeclTypeOperator $ IdeTypeOperator - efTypeOperator - efTypeAlias - efTypePrecedence - efTypeAssociativity - Nothing + IdeDeclTypeOperator + (IdeTypeOperator + efTypeOperator + efTypeAlias + efTypePrecedence + efTypeAssociativity + Nothing) diff --git a/src/Language/PureScript/Ide/Filter.hs b/src/Language/PureScript/Ide/Filter.hs --- a/src/Language/PureScript/Ide/Filter.hs +++ b/src/Language/PureScript/Ide/Filter.hs @@ -16,6 +16,7 @@ module Language.PureScript.Ide.Filter ( Filter + , declarationTypeFilter , namespaceFilter , moduleFilter , prefixFilter @@ -28,6 +29,7 @@ import Data.Aeson import Data.List.NonEmpty (NonEmpty) import Data.Text (isPrefixOf) +import qualified Language.PureScript.Ide.Filter.Declaration as D import Language.PureScript.Ide.Types import Language.PureScript.Ide.Util import qualified Language.PureScript as P @@ -77,6 +79,15 @@ declarationFilter predicate search = filterModuleDecls (flip predicate search) +-- | Only keeps Identifiers in the given type declarations +declarationTypeFilter :: [D.IdeDeclaration] -> Filter +declarationTypeFilter [] = mkFilter identity +declarationTypeFilter decls = + mkFilter $ filterModuleDecls filterDecls + where + filterDecls :: IdeDeclaration -> Bool + filterDecls decl = D.typeDeclarationForDeclaration decl `elem` decls + filterModuleDecls :: (IdeDeclaration -> Bool) -> [Module] -> [Module] filterModuleDecls predicate = filter (not . null . snd) . fmap filterDecls @@ -109,4 +120,7 @@ params <- o .: "params" namespaces <- params .: "namespaces" return $ namespaceFilter namespaces + "declarations" -> do + declarations <- o.: "params" + return $ declarationTypeFilter declarations _ -> mzero diff --git a/src/Language/PureScript/Ide/Filter/Declaration.hs b/src/Language/PureScript/Ide/Filter/Declaration.hs new file mode 100644 --- /dev/null +++ b/src/Language/PureScript/Ide/Filter/Declaration.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Language.PureScript.Ide.Filter.Declaration + ( IdeDeclaration(..) + , DeclarationType(..) + , typeDeclarationForDeclaration + ) where + +import Protolude hiding (isPrefixOf) + +import Data.Aeson +import qualified Language.PureScript.Ide.Types as PI + +data DeclarationType = Value + | Type + | Synonym + | DataConstructor + | TypeClass + | ValueOperator + | TypeOperator + | Kind + deriving (Show, Eq, Ord) + +instance FromJSON DeclarationType where + parseJSON = withText "Declaration type tag" $ \str -> + case str of + "value" -> pure Value + "type" -> pure Type + "synonym" -> pure Synonym + "dataconstructor" -> pure DataConstructor + "typeclass" -> pure TypeClass + "valueoperator" -> pure ValueOperator + "typeoperator" -> pure TypeOperator + "kind" -> pure Kind + _ -> mzero + +newtype IdeDeclaration = IdeDeclaration + { declarationtype :: DeclarationType + } deriving (Show, Eq, Ord) + +instance FromJSON IdeDeclaration where + parseJSON (Object o) = + IdeDeclaration <$> o .: "declarationtype" + parseJSON _ = mzero + +typeDeclarationForDeclaration :: PI.IdeDeclaration -> IdeDeclaration +typeDeclarationForDeclaration decl = case decl of + PI.IdeDeclValue _ -> IdeDeclaration Value + PI.IdeDeclType _ -> IdeDeclaration Type + PI.IdeDeclTypeSynonym _ -> IdeDeclaration Synonym + PI.IdeDeclDataConstructor _ -> IdeDeclaration DataConstructor + PI.IdeDeclTypeClass _ -> IdeDeclaration TypeClass + PI.IdeDeclValueOperator _ -> IdeDeclaration ValueOperator + PI.IdeDeclTypeOperator _ -> IdeDeclaration TypeOperator + PI.IdeDeclKind _ -> IdeDeclaration Kind diff --git a/src/Language/PureScript/Ide/Imports.hs b/src/Language/PureScript/Ide/Imports.hs --- a/src/Language/PureScript/Ide/Imports.hs +++ b/src/Language/PureScript/Ide/Imports.hs @@ -93,7 +93,7 @@ (P.mark (Parsec.many (P.same *> P.parseImportDeclaration'))) pure (ImportParse mn ipStart ipEnd (map mkImport decls)) where - mkImport (mn, (P.Explicit refs), qual) = Import mn (P.Explicit (unwrapPositionedRef <$> refs)) qual + mkImport (mn, (P.Explicit refs), qual) = Import mn (P.Explicit refs) qual mkImport (mn, it, qual) = Import mn it qual sliceImportSection :: [Text] -> Either Text (P.ModuleName, [Text], [Import], [Text]) @@ -192,19 +192,19 @@ else updateAtFirstOrPrepend matches (insertDeclIntoImport decl) freshImport imports where refFromDeclaration (IdeDeclTypeClass tc) = - P.TypeClassRef (tc ^. ideTCName) + P.TypeClassRef ideSpan (tc ^. ideTCName) refFromDeclaration (IdeDeclDataConstructor dtor) = - P.TypeRef (dtor ^. ideDtorTypeName) Nothing + P.TypeRef ideSpan (dtor ^. ideDtorTypeName) Nothing refFromDeclaration (IdeDeclType t) = - P.TypeRef (t ^. ideTypeName) (Just []) + P.TypeRef ideSpan (t ^. ideTypeName) (Just []) refFromDeclaration (IdeDeclValueOperator op) = - P.ValueOpRef (op ^. ideValueOpName) + P.ValueOpRef ideSpan (op ^. ideValueOpName) refFromDeclaration (IdeDeclTypeOperator op) = - P.TypeOpRef (op ^. ideTypeOpName) + P.TypeOpRef ideSpan (op ^. ideTypeOpName) refFromDeclaration (IdeDeclKind kn) = - P.KindRef kn + P.KindRef ideSpan kn refFromDeclaration d = - P.ValueRef (P.Ident (identifierFromIdeDeclaration d)) + P.ValueRef ideSpan (P.Ident (identifierFromIdeDeclaration d)) -- | Adds a declaration to an import: -- TypeDeclaration "Maybe" + Data.Maybe (maybe) -> Data.Maybe(Maybe, maybe) @@ -222,13 +222,16 @@ refs insertDeclIntoRefs dr refs = nubBy ((==) `on` P.prettyPrintRef) (refFromDeclaration dr : refs) - insertDtor _ (P.TypeRef tn' _) = P.TypeRef tn' Nothing + insertDtor _ (P.TypeRef ss tn' _) = P.TypeRef ss tn' Nothing insertDtor _ refs = refs matchType :: P.ProperName 'P.TypeName -> P.DeclarationRef -> Bool - matchType tn (P.TypeRef n _) = tn == n + matchType tn (P.TypeRef _ n _) = tn == n matchType _ _ = False +ideSpan :: P.SourceSpan +ideSpan = P.internalModuleSourceSpan "" + updateAtFirstOrPrepend :: (a -> Bool) -> (a -> a) -> a -> [a] -> [a] updateAtFirstOrPrepend p t d l = case findIndex p l of @@ -336,6 +339,6 @@ case P.lex "" t >>= P.runTokenParser "" P.parseImportDeclaration' of Right (mn, P.Explicit refs, mmn) -> - Just (Import mn (P.Explicit (unwrapPositionedRef <$> refs)) mmn) + Just (Import mn (P.Explicit refs) mmn) Right (mn, idt, mmn) -> Just (Import mn idt mmn) Left _ -> Nothing diff --git a/src/Language/PureScript/Ide/Prim.hs b/src/Language/PureScript/Ide/Prim.hs new file mode 100644 --- /dev/null +++ b/src/Language/PureScript/Ide/Prim.hs @@ -0,0 +1,20 @@ +module Language.PureScript.Ide.Prim (idePrimDeclarations) where + +import Protolude +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Language.PureScript as P +import qualified Language.PureScript.Environment as PEnv +import Language.PureScript.Ide.Types + +idePrimDeclarations :: [IdeDeclarationAnn] +idePrimDeclarations = + primTypes <> primKinds <> primClasses + where + primTypes = foreach (Map.toList PEnv.primTypes) $ \(tn, (kind, _)) -> + IdeDeclarationAnn emptyAnn (IdeDeclType (IdeType (P.disqualify tn) kind [])) + primKinds = foreach (Set.toList PEnv.primKinds) $ \kn -> + IdeDeclarationAnn emptyAnn (IdeDeclKind (P.disqualify kn)) + primClasses = foreach (Map.toList PEnv.primClasses) $ \(cn, _) -> + -- Dummy kind and instances here, but we primarily care about the name completion + IdeDeclarationAnn emptyAnn (IdeDeclTypeClass (IdeTypeClass (P.disqualify cn) P.kindType []) ) diff --git a/src/Language/PureScript/Ide/Rebuild.hs b/src/Language/PureScript/Ide/Rebuild.hs --- a/src/Language/PureScript/Ide/Rebuild.hs +++ b/src/Language/PureScript/Ide/Rebuild.hs @@ -176,7 +176,7 @@ mkShallowModule P.ExternsFile{..} = P.Module (P.internalModuleSourceSpan "") [] efModuleName (map mkImport efImports) Nothing mkImport (P.ExternsImport mn it iq) = - P.ImportDeclaration mn it iq + P.ImportDeclaration (P.internalModuleSourceSpan "", []) mn it iq getExtern mn = M.lookup mn ex -- Sort a list so its elements appear in the same order as in another list. inOrderOf :: (Ord a) => [a] -> [a] -> [a] diff --git a/src/Language/PureScript/Ide/Reexports.hs b/src/Language/PureScript/Ide/Reexports.hs --- a/src/Language/PureScript/Ide/Reexports.hs +++ b/src/Language/PureScript/Ide/Reexports.hs @@ -92,7 +92,7 @@ -> P.DeclarationRef -> Either P.DeclarationRef [IdeDeclarationAnn] resolveRef decls ref = case ref of - P.TypeRef tn mdtors -> + P.TypeRef _ tn mdtors -> case findRef (anyOf (_IdeDeclType . ideTypeName) (== tn)) <|> findRef (anyOf (_IdeDeclTypeSynonym . ideSynonymName) (== tn)) of Nothing -> @@ -104,15 +104,15 @@ -- those up ourselfes findDtors tn Just dtors -> mapMaybe lookupDtor dtors - P.ValueRef i -> + P.ValueRef _ i -> findWrapped (anyOf (_IdeDeclValue . ideValueIdent) (== i)) - P.ValueOpRef name -> + P.ValueOpRef _ name -> findWrapped (anyOf (_IdeDeclValueOperator . ideValueOpName) (== name)) - P.TypeOpRef name -> + P.TypeOpRef _ name -> findWrapped (anyOf (_IdeDeclTypeOperator . ideTypeOpName) (== name)) - P.TypeClassRef name -> + P.TypeClassRef _ name -> findWrapped (anyOf (_IdeDeclTypeClass . ideTCName) (== name)) - P.KindRef name -> + P.KindRef _ name -> findWrapped (anyOf _IdeDeclKind (== name)) _ -> Left ref diff --git a/src/Language/PureScript/Ide/SourceFile.hs b/src/Language/PureScript/Ide/SourceFile.hs --- a/src/Language/PureScript/Ide/SourceFile.hs +++ b/src/Language/PureScript/Ide/SourceFile.hs @@ -59,8 +59,8 @@ extractAstInformation :: P.Module -> (DefinitionSites P.SourceSpan, TypeAnnotations) -extractAstInformation (P.Module ss _ _ decls _) = - let definitions = Map.fromList (concatMap (extractSpans ss) decls) +extractAstInformation (P.Module _ _ _ decls _) = + let definitions = Map.fromList (concatMap extractSpans decls) typeAnnotations = Map.fromList (extractTypeAnnotations decls) in (definitions, typeAnnotations) @@ -70,40 +70,35 @@ -> [(P.Ident, P.Type)] extractTypeAnnotations = mapMaybe extract where - extract d = case unwrapPositioned d of - P.TypeDeclaration ident ty -> Just (ident, ty) - _ -> Nothing + extract (P.TypeDeclaration _ ident ty) = Just (ident, ty) + extract _ = Nothing -- | Given a surrounding Sourcespan and a Declaration from the PS AST, extracts -- definition sites inside that Declaration. extractSpans - :: P.SourceSpan - -- ^ The surrounding span - -> P.Declaration + :: P.Declaration -- ^ The declaration to extract spans from -> [(IdeNamespaced, P.SourceSpan)] -- ^ Declarations and their source locations -extractSpans ss d = case d of - P.PositionedDeclaration ss' _ d' -> - extractSpans ss' d' - P.ValueDeclaration i _ _ _ -> +extractSpans d = case d of + P.ValueDeclaration (ss, _) i _ _ _ -> [(IdeNamespaced IdeNSValue (P.runIdent i), ss)] - P.TypeSynonymDeclaration name _ _ -> + P.TypeSynonymDeclaration (ss, _) name _ _ -> [(IdeNamespaced IdeNSType (P.runProperName name), ss)] - P.TypeClassDeclaration name _ _ _ members -> - (IdeNamespaced IdeNSType (P.runProperName name), ss) : concatMap (extractSpans' ss) members - P.DataDeclaration _ name _ ctors -> + P.TypeClassDeclaration (ss, _) name _ _ _ members -> + (IdeNamespaced IdeNSType (P.runProperName name), ss) : concatMap extractSpans' members + P.DataDeclaration (ss, _) _ name _ ctors -> (IdeNamespaced IdeNSType (P.runProperName name), ss) : map (\(cname, _) -> (IdeNamespaced IdeNSValue (P.runProperName cname), ss)) ctors - P.FixityDeclaration (Left (P.ValueFixity _ _ opName)) -> + P.FixityDeclaration (ss, _) (Left (P.ValueFixity _ _ opName)) -> [(IdeNamespaced IdeNSValue (P.runOpName opName), ss)] - P.FixityDeclaration (Right (P.TypeFixity _ _ opName)) -> + P.FixityDeclaration (ss, _) (Right (P.TypeFixity _ _ opName)) -> [(IdeNamespaced IdeNSType (P.runOpName opName), ss)] - P.ExternDeclaration ident _ -> + P.ExternDeclaration (ss, _) ident _ -> [(IdeNamespaced IdeNSValue (P.runIdent ident), ss)] - P.ExternDataDeclaration name _ -> + P.ExternDataDeclaration (ss, _) name _ -> [(IdeNamespaced IdeNSType (P.runProperName name), ss)] - P.ExternKindDeclaration name -> + P.ExternKindDeclaration (ss, _) name -> [(IdeNamespaced IdeNSKind (P.runProperName name), ss)] _ -> [] where @@ -111,9 +106,7 @@ -- typeclass member functions. Typedeclarations would clash with value -- declarations for non-typeclass members, which is why we can't handle them -- in extractSpans. - extractSpans' ssP dP = case dP of - P.PositionedDeclaration ssP' _ dP' -> - extractSpans' ssP' dP' - P.TypeDeclaration ident _ -> - [(IdeNamespaced IdeNSValue (P.runIdent ident), ssP)] + extractSpans' dP = case dP of + P.TypeDeclaration (ss', _) ident _ -> + [(IdeNamespaced IdeNSValue (P.runIdent ident), ss')] _ -> [] diff --git a/src/Language/PureScript/Ide/State.hs b/src/Language/PureScript/Ide/State.hs --- a/src/Language/PureScript/Ide/State.hs +++ b/src/Language/PureScript/Ide/State.hs @@ -30,6 +30,7 @@ -- for tests , resolveOperatorsForModule , resolveInstances + , resolveDataConstructorsForModule ) where import Protolude @@ -82,7 +83,7 @@ getFileState :: Ide m => m IdeFileState getFileState = do st <- ideStateVar <$> ask - fmap ideFileState . liftIO . readTVarIO $ st + ideFileState <$> liftIO (readTVarIO st) -- | STM version of getFileState getFileStateSTM :: TVar IdeState -> STM IdeFileState @@ -93,8 +94,12 @@ getVolatileState :: Ide m => m IdeVolatileState getVolatileState = do st <- ideStateVar <$> ask - fmap ideVolatileState . liftIO . readTVarIO $ st + liftIO (atomically (getVolatileStateSTM st)) +-- | STM version of getVolatileState +getVolatileStateSTM :: TVar IdeState -> STM IdeVolatileState +getVolatileStateSTM st = ideVolatileState <$> readTVar st + -- | Sets the VolatileState inside Ide's state setVolatileStateSTM :: TVar IdeState -> IdeVolatileState -> STM () setVolatileStateSTM ref vs = do @@ -172,14 +177,17 @@ -> STM (ModuleMap (ReexportResult [IdeDeclarationAnn])) populateVolatileStateSTM ref = do IdeFileState{fsExterns = externs, fsModules = modules} <- getFileStateSTM ref + rebuildCache <- vsCachedRebuild <$> getVolatileStateSTM ref let asts = map (extractAstInformation . fst) modules let (moduleDeclarations, reexportRefs) = (map fst &&& map snd) (Map.map convertExterns externs) results = - resolveLocations asts moduleDeclarations + moduleDeclarations + & map resolveDataConstructorsForModule + & resolveLocations asts & resolveInstances externs & resolveOperators & resolveReexports reexportRefs - setVolatileStateSTM ref (IdeVolatileState (AstData asts) (map reResolved results) Nothing) + setVolatileStateSTM ref (IdeVolatileState (AstData asts) (map reResolved results) rebuildCache) pure results resolveLocations @@ -306,3 +314,22 @@ mapIf :: Functor f => (b -> Bool) -> (b -> b) -> f b -> f b mapIf p f = map (\x -> if p x then f x else x) + +resolveDataConstructorsForModule + :: [IdeDeclarationAnn] + -> [IdeDeclarationAnn] +resolveDataConstructorsForModule decls = + map (idaDeclaration %~ resolveDataConstructors) decls + where + resolveDataConstructors :: IdeDeclaration -> IdeDeclaration + resolveDataConstructors decl = case decl of + IdeDeclType ty -> + IdeDeclType (ty & ideTypeDtors .~ fromMaybe [] (Map.lookup (ty^.ideTypeName) dtors)) + _ -> + decl + + dtors = + decls + & mapMaybe (preview (idaDeclaration._IdeDeclDataConstructor)) + & foldr (\(IdeDataConstructor name typeName type') -> + Map.insertWith (<>) typeName [(name, type')]) Map.empty diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs --- a/src/Language/PureScript/Ide/Types.hs +++ b/src/Language/PureScript/Ide/Types.hs @@ -48,6 +48,7 @@ data IdeType = IdeType { _ideTypeName :: P.ProperName 'P.TypeName , _ideTypeKind :: P.Kind + , _ideTypeDtors :: [(P.ProperName 'P.ConstructorName, P.Type)] } deriving (Show, Eq, Ord) data IdeTypeSynonym = IdeTypeSynonym @@ -204,16 +205,16 @@ , "expandedType" .= complExpandedType , "definedAt" .= complLocation , "documentation" .= complDocumentation - , "exportedFrom" .= complExportedFrom + , "exportedFrom" .= map P.runModuleName complExportedFrom ] identifierFromDeclarationRef :: P.DeclarationRef -> Text -identifierFromDeclarationRef (P.TypeRef name _) = P.runProperName name -identifierFromDeclarationRef (P.ValueRef ident) = P.runIdent ident -identifierFromDeclarationRef (P.TypeClassRef name) = P.runProperName name -identifierFromDeclarationRef (P.KindRef name) = P.runProperName name -identifierFromDeclarationRef (P.ValueOpRef op) = P.showOp op -identifierFromDeclarationRef (P.TypeOpRef op) = P.showOp op +identifierFromDeclarationRef (P.TypeRef _ name _) = P.runProperName name +identifierFromDeclarationRef (P.ValueRef _ ident) = P.runIdent ident +identifierFromDeclarationRef (P.TypeClassRef _ name) = P.runProperName name +identifierFromDeclarationRef (P.KindRef _ name) = P.runProperName name +identifierFromDeclarationRef (P.ValueOpRef _ op) = P.showOp op +identifierFromDeclarationRef (P.TypeOpRef _ op) = P.showOp op identifierFromDeclarationRef _ = "" data Success = diff --git a/src/Language/PureScript/Ide/Util.hs b/src/Language/PureScript/Ide/Util.hs --- a/src/Language/PureScript/Ide/Util.hs +++ b/src/Language/PureScript/Ide/Util.hs @@ -15,8 +15,6 @@ module Language.PureScript.Ide.Util ( identifierFromIdeDeclaration , unwrapMatch - , unwrapPositioned - , unwrapPositionedRef , namespaceForDeclaration , encodeT , decodeT @@ -91,14 +89,6 @@ decodeT :: (FromJSON a) => Text -> Maybe a decodeT = decode . TLE.encodeUtf8 . TL.fromStrict - -unwrapPositioned :: P.Declaration -> P.Declaration -unwrapPositioned (P.PositionedDeclaration _ _ x) = unwrapPositioned x -unwrapPositioned x = x - -unwrapPositionedRef :: P.DeclarationRef -> P.DeclarationRef -unwrapPositionedRef (P.PositionedDeclarationRef _ _ x) = unwrapPositionedRef x -unwrapPositionedRef x = x properNameT :: Iso' (P.ProperName a) Text properNameT = iso P.runProperName P.ProperName diff --git a/src/Language/PureScript/Interactive.hs b/src/Language/PureScript/Interactive.hs --- a/src/Language/PureScript/Interactive.hs +++ b/src/Language/PureScript/Interactive.hs @@ -40,6 +40,7 @@ import System.Directory (getCurrentDirectory) import System.FilePath (()) +import System.FilePath.Glob (glob) -- | Pretty-print errors printErrors :: MonadIO m => P.MultipleErrors -> m () @@ -118,7 +119,8 @@ -> m () handleReloadState reload = do modify $ updateLets (const []) - files <- asks psciLoadedFiles + globs <- asks psciFileGlobs + files <- liftIO $ concat <$> traverse glob globs e <- runExceptT $ do modules <- ExceptT . liftIO $ loadAllModules files (externs, _) <- ExceptT . liftIO . runMake . make $ modules @@ -202,26 +204,24 @@ refsList refs = " (" <> commaList (mapMaybe showRef refs) <> ")" showRef :: P.DeclarationRef -> Maybe Text - showRef (P.TypeRef pn dctors) = + showRef (P.TypeRef _ pn dctors) = Just $ N.runProperName pn <> "(" <> maybe ".." (commaList . map N.runProperName) dctors <> ")" - showRef (P.TypeOpRef op) = + showRef (P.TypeOpRef _ op) = Just $ "type " <> N.showOp op - showRef (P.ValueRef ident) = + showRef (P.ValueRef _ ident) = Just $ N.runIdent ident - showRef (P.ValueOpRef op) = + showRef (P.ValueOpRef _ op) = Just $ N.showOp op - showRef (P.TypeClassRef pn) = + showRef (P.TypeClassRef _ pn) = Just $ "class " <> N.runProperName pn - showRef (P.TypeInstanceRef ident) = + showRef (P.TypeInstanceRef _ ident) = Just $ N.runIdent ident - showRef (P.ModuleRef name) = + showRef (P.ModuleRef _ name) = Just $ "module " <> N.runModuleName name - showRef (P.KindRef pn) = + showRef (P.KindRef _ pn) = Just $ "kind " <> N.runProperName pn - showRef (P.ReExportRef _ _) = + showRef (P.ReExportRef _ _ _) = Nothing - showRef (P.PositionedDeclarationRef _ _ ref) = - showRef ref commaList :: [Text] -> Text commaList = T.intercalate ", " diff --git a/src/Language/PureScript/Interactive/Completion.hs b/src/Language/PureScript/Interactive/Completion.hs --- a/src/Language/PureScript/Interactive/Completion.hs +++ b/src/Language/PureScript/Interactive/Completion.hs @@ -197,28 +197,25 @@ typeDecls = mapMaybe getTypeName . filter P.isDataDecl . P.exportedDeclarations where getTypeName :: P.Declaration -> Maybe (N.ProperName 'N.TypeName, P.Declaration) - getTypeName d@(P.TypeSynonymDeclaration name _ _) = Just (name, d) - getTypeName d@(P.DataDeclaration _ name _ _) = Just (name, d) - getTypeName (P.PositionedDeclaration _ _ d) = getTypeName d + getTypeName d@(P.TypeSynonymDeclaration _ name _ _) = Just (name, d) + getTypeName d@(P.DataDeclaration _ _ name _ _) = Just (name, d) getTypeName _ = Nothing identNames :: P.Module -> [(N.Ident, P.Declaration)] identNames = nubOnFst . concatMap getDeclNames . P.exportedDeclarations where getDeclNames :: P.Declaration -> [(P.Ident, P.Declaration)] - getDeclNames d@(P.ValueDeclaration ident _ _ _) = [(ident, d)] - getDeclNames d@(P.TypeDeclaration ident _ ) = [(ident, d)] - getDeclNames d@(P.ExternDeclaration ident _) = [(ident, d)] - getDeclNames d@(P.TypeClassDeclaration _ _ _ _ ds) = map (second (const d)) $ concatMap getDeclNames ds - getDeclNames (P.PositionedDeclaration _ _ d) = getDeclNames d + getDeclNames d@(P.ValueDeclaration _ ident _ _ _) = [(ident, d)] + getDeclNames d@(P.TypeDeclaration _ ident _ ) = [(ident, d)] + getDeclNames d@(P.ExternDeclaration _ ident _) = [(ident, d)] + getDeclNames d@(P.TypeClassDeclaration _ _ _ _ _ ds) = map (second (const d)) $ concatMap getDeclNames ds getDeclNames _ = [] dctorNames :: P.Module -> [(N.ProperName 'N.ConstructorName, P.Declaration)] dctorNames = nubOnFst . concatMap go . P.exportedDeclarations where go :: P.Declaration -> [(N.ProperName 'N.ConstructorName, P.Declaration)] - go decl@(P.DataDeclaration _ _ _ ctors) = map ((\n -> (n, decl)) . fst) ctors - go (P.PositionedDeclaration _ _ d) = go d + go decl@(P.DataDeclaration _ _ _ _ ctors) = map ((\n -> (n, decl)) . fst) ctors go _ = [] moduleNames :: [P.Module] -> [String] diff --git a/src/Language/PureScript/Interactive/Module.hs b/src/Language/PureScript/Interactive/Module.hs --- a/src/Language/PureScript/Interactive/Module.hs +++ b/src/Language/PureScript/Interactive/Module.hs @@ -51,17 +51,16 @@ supportImport = (supportModuleName, P.Implicit, Just (P.ModuleName [P.ProperName "$Support"])) eval = P.Var (P.Qualified (Just (P.ModuleName [P.ProperName "$Support"])) (P.Ident "eval")) mainValue = P.App eval (P.Var (P.Qualified Nothing (P.Ident "it"))) - itDecl = P.ValueDeclaration (P.Ident "it") P.Public [] [P.MkUnguarded val] - typeDecl = P.TypeDeclaration (P.Ident "$main") + itDecl = P.ValueDeclaration (internalSpan, []) (P.Ident "it") P.Public [] [P.MkUnguarded val] + typeDecl = P.TypeDeclaration (internalSpan, []) (P.Ident "$main") (P.TypeApp (P.TypeApp (P.TypeConstructor (P.Qualified (Just (P.ModuleName [P.ProperName "$Eff"])) (P.ProperName "Eff"))) (P.TypeWildcard internalSpan)) (P.TypeWildcard internalSpan)) - mainDecl = P.ValueDeclaration (P.Ident "$main") P.Public [] [P.MkUnguarded mainValue] + mainDecl = P.ValueDeclaration (internalSpan, []) (P.Ident "$main") P.Public [] [P.MkUnguarded mainValue] decls = if exec then [itDecl, typeDecl, mainDecl] else [itDecl] - internalSpan = P.internalModuleSourceSpan "" in P.Module internalSpan [] moduleName @@ -76,9 +75,9 @@ createTemporaryModuleForKind PSCiState{psciImportedModules = imports, psciLetBindings = lets} typ = let moduleName = P.ModuleName [P.ProperName "$PSCI"] - itDecl = P.TypeSynonymDeclaration (P.ProperName "IT") [] typ + itDecl = P.TypeSynonymDeclaration (internalSpan, []) (P.ProperName "IT") [] typ in - P.Module (P.internalModuleSourceSpan "") [] moduleName ((importDecl `map` imports) ++ lets ++ [itDecl]) Nothing + P.Module internalSpan [] moduleName ((importDecl `map` imports) ++ lets ++ [itDecl]) Nothing -- | -- Makes a volatile module to execute the current imports. @@ -88,13 +87,16 @@ let moduleName = P.ModuleName [P.ProperName "$PSCI"] in - P.Module (P.internalModuleSourceSpan "") [] moduleName (importDecl `map` imports) Nothing + P.Module internalSpan [] moduleName (importDecl `map` imports) Nothing importDecl :: ImportedModule -> P.Declaration -importDecl (mn, declType, asQ) = P.ImportDeclaration mn declType asQ +importDecl (mn, declType, asQ) = P.ImportDeclaration (internalSpan, []) mn declType asQ indexFile :: FilePath indexFile = ".psci_modules" ++ pathSeparator : "index.js" modulesDir :: FilePath modulesDir = ".psci_modules" ++ pathSeparator : "node_modules" + +internalSpan :: P.SourceSpan +internalSpan = P.internalModuleSourceSpan "" diff --git a/src/Language/PureScript/Interactive/Parser.hs b/src/Language/PureScript/Interactive/Parser.hs --- a/src/Language/PureScript/Interactive/Parser.hs +++ b/src/Language/PureScript/Interactive/Parser.hs @@ -88,14 +88,10 @@ -- (like import declarations). psciDeclaration :: P.TokenParser Command psciDeclaration = fmap Decls $ mark $ many1 $ same *> do - decl <- discardPositionInfo <$> P.parseDeclaration + decl <- P.parseDeclaration if acceptable decl then return decl else fail "this kind of declaration is not supported in psci" - -discardPositionInfo :: P.Declaration -> P.Declaration -discardPositionInfo (P.PositionedDeclaration _ _ d) = d -discardPositionInfo d = d acceptable :: P.Declaration -> Bool acceptable P.DataDeclaration{} = True diff --git a/src/Language/PureScript/Interactive/Types.hs b/src/Language/PureScript/Interactive/Types.hs --- a/src/Language/PureScript/Interactive/Types.hs +++ b/src/Language/PureScript/Interactive/Types.hs @@ -12,7 +12,7 @@ -- These configuration values do not change during execution. -- data PSCiConfig = PSCiConfig - { psciLoadedFiles :: [FilePath] + { psciFileGlobs :: [String] , psciEnvironment :: P.Environment } deriving Show diff --git a/src/Language/PureScript/Linter.hs b/src/Language/PureScript/Linter.hs --- a/src/Language/PureScript/Linter.hs +++ b/src/Language/PureScript/Linter.hs @@ -32,11 +32,10 @@ moduleNames = S.fromList (ordNub (mapMaybe getDeclIdent ds)) getDeclIdent :: Declaration -> Maybe Ident - getDeclIdent (PositionedDeclaration _ _ d) = getDeclIdent d - getDeclIdent (ValueDeclaration ident _ _ _) = Just ident - getDeclIdent (ExternDeclaration ident _) = Just ident - getDeclIdent (TypeInstanceDeclaration ident _ _ _ _) = Just ident - getDeclIdent (BindingGroupDeclaration _) = internalError "lint: binding groups should not be desugared yet." + getDeclIdent (ValueDeclaration _ ident _ _ _) = Just ident + getDeclIdent (ExternDeclaration _ ident _) = Just ident + getDeclIdent (TypeInstanceDeclaration _ ident _ _ _ _) = Just ident + getDeclIdent BindingGroupDeclaration{} = internalError "lint: binding groups should not be desugared yet." getDeclIdent _ = Nothing lintDeclaration :: Declaration -> m () @@ -45,14 +44,12 @@ (warningsInDecl, _, _, _, _) = everythingWithScope (\_ _ -> mempty) stepE stepB (\_ _ -> mempty) stepDo f :: Declaration -> MultipleErrors - f (PositionedDeclaration pos _ dec) = addHint (PositionedError pos) (f dec) - f (TypeClassDeclaration name args _ _ decs) = addHint (ErrorInTypeClassDeclaration name) (foldMap (f' (S.fromList $ fst <$> args)) decs) + f (TypeClassDeclaration _ name args _ _ decs) = addHint (ErrorInTypeClassDeclaration name) (foldMap (f' (S.fromList $ fst <$> args)) decs) f dec = f' S.empty dec f' :: S.Set Text -> Declaration -> MultipleErrors - f' s (PositionedDeclaration pos _ dec) = addHint (PositionedError pos) (f' s dec) - f' s dec@(ValueDeclaration name _ _ _) = addHint (ErrorInValueDeclaration name) (warningsInDecl moduleNames dec <> checkTypeVarsInDecl s dec) - f' s (TypeDeclaration name ty) = addHint (ErrorInTypeDeclaration name) (checkTypeVars s ty) + f' s dec@(ValueDeclaration _ name _ _ _) = addHint (ErrorInValueDeclaration name) (warningsInDecl moduleNames dec <> checkTypeVarsInDecl s dec) + f' s (TypeDeclaration _ name ty) = addHint (ErrorInTypeDeclaration name) (checkTypeVars s ty) f' s dec = warningsInDecl moduleNames dec <> checkTypeVarsInDecl s dec stepE :: S.Set Ident -> Expr -> MultipleErrors diff --git a/src/Language/PureScript/Linter/Exhaustive.hs b/src/Language/PureScript/Linter/Exhaustive.hs --- a/src/Language/PureScript/Linter/Exhaustive.hs +++ b/src/Language/PureScript/Linter/Exhaustive.hs @@ -242,13 +242,14 @@ checkExhaustive :: forall m . (MonadWriter MultipleErrors m, MonadSupply m) - => Environment + => SourceSpan + -> Environment -> ModuleName -> Int -> [CaseAlternative] -> Expr -> m Expr -checkExhaustive env mn numArgs cas expr = makeResult . first ordNub $ foldl' step ([initialize numArgs], (pure True, [])) cas +checkExhaustive ss env mn numArgs cas expr = makeResult . first ordNub $ foldl' step ([initialize numArgs], (pure True, [])) cas where step :: ([[Binder]], (Either RedundancyError Bool, [[Binder]])) -> CaseAlternative -> ([[Binder]], (Either RedundancyError Bool, [[Binder]])) step (uncovered, (nec, redundant)) ca = @@ -274,8 +275,8 @@ then return expr else addPartialConstraint (second null (splitAt 5 bss)) expr where - tellRedundant = tell . errorMessage . uncurry OverlappingPattern . second null . splitAt 5 $ bss' - tellIncomplete = tell . errorMessage $ IncompleteExhaustivityCheck + tellRedundant = tell . errorMessage' ss . uncurry OverlappingPattern . second null . splitAt 5 $ bss' + tellIncomplete = tell . errorMessage' ss $ IncompleteExhaustivityCheck -- | We add a Partial constraint by adding a call to the following identity function: -- @@ -294,7 +295,7 @@ where partial :: Text -> Text -> Declaration partial var tyVar = - ValueDeclaration (Ident C.__unused) Private [] $ + ValueDeclaration (ss, []) (Ident C.__unused) Private [] $ [MkUnguarded (TypedValue True @@ -321,41 +322,41 @@ checkExhaustiveExpr :: forall m . (MonadWriter MultipleErrors m, MonadSupply m) - => Environment + => SourceSpan + -> Environment -> ModuleName -> Expr -> m Expr -checkExhaustiveExpr env mn = onExpr +checkExhaustiveExpr initSS env mn = onExpr initSS where onDecl :: Declaration -> m Declaration - onDecl (BindingGroupDeclaration bs) = BindingGroupDeclaration <$> mapM (thirdM onExpr) bs - onDecl (ValueDeclaration name x y [MkUnguarded e]) = ValueDeclaration name x y . mkUnguardedExpr <$> censor (addHint (ErrorInValueDeclaration name)) (onExpr e) - onDecl (PositionedDeclaration pos x dec) = PositionedDeclaration pos x <$> censor (addHint (PositionedError pos)) (onDecl dec) + onDecl (BindingGroupDeclaration bs) = BindingGroupDeclaration <$> mapM (\(sai@((ss, _), _), nk, expr) -> (sai, nk,) <$> onExpr ss expr) bs + onDecl (ValueDeclaration sa@(ss, _) name x y [MkUnguarded e]) = ValueDeclaration sa name x y . mkUnguardedExpr <$> censor (addHint (ErrorInValueDeclaration name)) (onExpr ss e) onDecl decl = return decl - onExpr :: Expr -> m Expr - onExpr (UnaryMinus e) = UnaryMinus <$> onExpr e - onExpr (Literal (ArrayLiteral es)) = Literal . ArrayLiteral <$> mapM onExpr es - onExpr (Literal (ObjectLiteral es)) = Literal . ObjectLiteral <$> mapM (sndM onExpr) es - onExpr (TypeClassDictionaryConstructorApp x e) = TypeClassDictionaryConstructorApp x <$> onExpr e - onExpr (Accessor x e) = Accessor x <$> onExpr e - onExpr (ObjectUpdate o es) = ObjectUpdate <$> onExpr o <*> mapM (sndM onExpr) es - onExpr (Abs x e) = Abs x <$> onExpr e - onExpr (App e1 e2) = App <$> onExpr e1 <*> onExpr e2 - onExpr (IfThenElse e1 e2 e3) = IfThenElse <$> onExpr e1 <*> onExpr e2 <*> onExpr e3 - onExpr (Case es cas) = do - case' <- Case <$> mapM onExpr es <*> mapM onCaseAlternative cas - checkExhaustive env mn (length es) cas case' - onExpr (TypedValue x e y) = TypedValue x <$> onExpr e <*> pure y - onExpr (Let ds e) = Let <$> mapM onDecl ds <*> onExpr e - onExpr (PositionedValue pos x e) = PositionedValue pos x <$> censor (addHint (PositionedError pos)) (onExpr e) - onExpr expr = return expr + onExpr :: SourceSpan -> Expr -> m Expr + onExpr ss (UnaryMinus e) = UnaryMinus <$> onExpr ss e + onExpr ss (Literal (ArrayLiteral es)) = Literal . ArrayLiteral <$> mapM (onExpr ss) es + onExpr ss (Literal (ObjectLiteral es)) = Literal . ObjectLiteral <$> mapM (sndM (onExpr ss)) es + onExpr ss (TypeClassDictionaryConstructorApp x e) = TypeClassDictionaryConstructorApp x <$> onExpr ss e + onExpr ss (Accessor x e) = Accessor x <$> onExpr ss e + onExpr ss (ObjectUpdate o es) = ObjectUpdate <$> onExpr ss o <*> mapM (sndM (onExpr ss)) es + onExpr ss (Abs x e) = Abs x <$> onExpr ss e + onExpr ss (App e1 e2) = App <$> onExpr ss e1 <*> onExpr ss e2 + onExpr ss (IfThenElse e1 e2 e3) = IfThenElse <$> onExpr ss e1 <*> onExpr ss e2 <*> onExpr ss e3 + onExpr ss (Case es cas) = do + case' <- Case <$> mapM (onExpr ss) es <*> mapM (onCaseAlternative ss) cas + checkExhaustive ss env mn (length es) cas case' + onExpr ss (TypedValue x e y) = TypedValue x <$> onExpr ss e <*> pure y + onExpr ss (Let ds e) = Let <$> mapM onDecl ds <*> onExpr ss e + onExpr _ (PositionedValue ss x e) = PositionedValue ss x <$> onExpr ss e + onExpr _ expr = return expr - onCaseAlternative :: CaseAlternative -> m CaseAlternative - onCaseAlternative (CaseAlternative x [MkUnguarded e]) = CaseAlternative x . mkUnguardedExpr <$> onExpr e - onCaseAlternative (CaseAlternative x es) = CaseAlternative x <$> mapM onGuardedExpr es + onCaseAlternative :: SourceSpan -> CaseAlternative -> m CaseAlternative + onCaseAlternative ss (CaseAlternative x [MkUnguarded e]) = CaseAlternative x . mkUnguardedExpr <$> onExpr ss e + onCaseAlternative ss (CaseAlternative x es) = CaseAlternative x <$> mapM (onGuardedExpr ss) es - onGuardedExpr :: GuardedExpr -> m GuardedExpr - onGuardedExpr (GuardedExpr guard rhs) = GuardedExpr guard <$> onExpr rhs + onGuardedExpr :: SourceSpan -> GuardedExpr -> m GuardedExpr + onGuardedExpr ss (GuardedExpr guard rhs) = GuardedExpr guard <$> onExpr ss rhs mkUnguardedExpr = pure . MkUnguarded diff --git a/src/Language/PureScript/Linter/Imports.hs b/src/Language/PureScript/Linter/Imports.hs --- a/src/Language/PureScript/Linter/Imports.hs +++ b/src/Language/PureScript/Linter/Imports.hs @@ -13,7 +13,7 @@ import Data.Function (on) import Data.Foldable (for_) import Data.List (find, intersect, groupBy, sortBy, (\\)) -import Data.Maybe (mapMaybe, fromMaybe) +import Data.Maybe (mapMaybe) import Data.Monoid (Sum(..)) import Data.Traversable (forM) import qualified Data.Text as T @@ -58,33 +58,31 @@ -> m () lintImports (Module _ _ _ _ Nothing) _ _ = internalError "lintImports needs desugared exports" -lintImports (Module ss _ mn mdecls (Just mexports)) env usedImps = do +lintImports (Module _ _ mn mdecls (Just mexports)) env usedImps = do -- TODO: this needs some work to be easier to understand - let scope = maybe primImports (\(_, imps', _) -> imps') (M.lookup mn env) + let scope = maybe nullImports (\(_, imps', _) -> imps') (M.lookup mn env) usedImps' = foldr (elaborateUsed scope) usedImps exportedModules numOpenImports = getSum $ foldMap (Sum . countOpenImports) mdecls allowImplicit = numOpenImports == 1 imports = M.toAscList (findImports mdecls) for_ imports $ \(mni, decls) -> - unless (isPrim mni) $ - for_ decls $ \(ss', declType, qualifierName) -> - maybe id warnWithPosition ss' $ do - let names = ordNub $ M.findWithDefault [] mni usedImps' - lintImportDecl env mni qualifierName names declType allowImplicit + unless (isPrim mni) . + for_ decls $ \(ss, declType, qualifierName) -> do + let names = ordNub $ M.findWithDefault [] mni usedImps' + lintImportDecl env mni qualifierName names ss declType allowImplicit for_ (M.toAscList (byQual imports)) $ \(mnq, entries) -> do let mnis = ordNub $ map (\(_, _, mni) -> mni) entries unless (length mnis == 1) $ do let implicits = filter (\(_, declType, _) -> not $ isExplicit declType) entries - for_ implicits $ \(ss', _, mni) -> - maybe id warnWithPosition ss' $ do - let names = ordNub $ M.findWithDefault [] mni usedImps' - usedRefs = findUsedRefs env mni (Just mnq) names - unless (null usedRefs) $ - tell $ errorMessage $ ImplicitQualifiedImport mni mnq usedRefs + for_ implicits $ \(ss, _, mni) -> do + let names = ordNub $ M.findWithDefault [] mni usedImps' + usedRefs = findUsedRefs ss env mni (Just mnq) names + unless (null usedRefs) . + tell . errorMessage' ss $ ImplicitQualifiedImport mni mnq usedRefs for_ imports $ \(mnq, imps) -> do @@ -100,11 +98,10 @@ $ unwarned for_ duplicates $ \(pos, _, _) -> - maybe id warnWithPosition pos $ - tell $ errorMessage $ DuplicateSelectiveImport mnq + tell . errorMessage' pos $ DuplicateSelectiveImport mnq for_ (imps \\ (warned ++ duplicates)) $ \(pos, typ, _) -> - warnDuplicateRefs (fromMaybe ss pos) DuplicateImportRef $ case typ of + warnDuplicateRefs pos DuplicateImportRef $ case typ of Explicit refs -> refs Hiding refs -> refs _ -> [] @@ -119,10 +116,9 @@ selfCartesianSubset [] = [] countOpenImports :: Declaration -> Int - countOpenImports (PositionedDeclaration _ _ d) = countOpenImports d - countOpenImports (ImportDeclaration mn' Implicit Nothing) + countOpenImports (ImportDeclaration _ mn' Implicit Nothing) | not (isPrim mn' || mn == mn') = 1 - countOpenImports (ImportDeclaration mn' (Hiding _) Nothing) + countOpenImports (ImportDeclaration _ mn' (Hiding _) Nothing) | not (isPrim mn' || mn == mn') = 1 countOpenImports _ = 0 @@ -135,8 +131,8 @@ -- import to that module, with the corresponding source span, import type, -- and module being imported byQual - :: [(ModuleName, [(Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)])] - -> M.Map ModuleName [(Maybe SourceSpan, ImportDeclarationType, ModuleName)] + :: [(ModuleName, [(SourceSpan, ImportDeclarationType, Maybe ModuleName)])] + -> M.Map ModuleName [(SourceSpan, ImportDeclarationType, ModuleName)] byQual = foldr goImp M.empty where goImp (mni, xs) acc = foldr (goDecl mni) acc xs @@ -150,8 +146,7 @@ exportedModules :: [ModuleName] exportedModules = ordNub $ mapMaybe extractModule mexports where - extractModule (PositionedDeclarationRef _ _ r) = extractModule r - extractModule (ModuleRef mne) = Just mne + extractModule (ModuleRef _ mne) = Just mne extractModule _ = Nothing -- Elaborates the UsedImports to include values from modules that are being @@ -195,10 +190,11 @@ -> ModuleName -> Maybe ModuleName -> [Qualified Name] + -> SourceSpan -> ImportDeclarationType -> Bool -> m Bool -lintImportDecl env mni qualifierName names declType allowImplicit = +lintImportDecl env mni qualifierName names ss declType allowImplicit = case declType of Implicit -> case qualifierName of Nothing -> @@ -224,8 +220,8 @@ -- used constructors explicity `T(X, Y, [...])` to `T(..)` for suggestion -- message. simplifyTypeRef :: DeclarationRef -> DeclarationRef - simplifyTypeRef (TypeRef name (Just dctors)) - | not (null dctors) = TypeRef name Nothing + simplifyTypeRef (TypeRef ss' name (Just dctors)) + | not (null dctors) = TypeRef ss' name Nothing simplifyTypeRef other = other checkExplicit @@ -250,7 +246,7 @@ (_, []) | c /= Just [] -> warn (UnusedDctorImport mni tn qualifierName allRefs) (Just ctors, dctors') -> let ddiff = ctors \\ dctors' - in unless' (null ddiff) $ warn $ UnusedDctorExplicitImport mni tn ddiff qualifierName allRefs + in unless' (null ddiff) . warn $ UnusedDctorExplicitImport mni tn ddiff qualifierName allRefs _ -> return False return (didWarn || or didWarn') @@ -259,7 +255,7 @@ unused = warn (UnusedImport mni) warn :: SimpleErrorMessage -> m Bool - warn err = tell (errorMessage err) >> return True + warn err = tell (errorMessage' ss err) >> return True -- Unless the boolean is true, run the action. Return false when the action is -- not run, otherwise return whatever the action does. @@ -272,7 +268,7 @@ unless' True _ = return False allRefs :: [DeclarationRef] - allRefs = findUsedRefs env mni qualifierName names + allRefs = findUsedRefs ss env mni qualifierName names dtys :: ModuleName @@ -292,24 +288,25 @@ typeForDCtor mn pn = fst <$> find (elem pn . fst . snd) (M.toList (dtys mn)) findUsedRefs - :: Env + :: SourceSpan + -> Env -> ModuleName -> Maybe ModuleName -> [Qualified Name] -> [DeclarationRef] -findUsedRefs env mni qn names = +findUsedRefs ss env mni qn names = let - classRefs = TypeClassRef <$> mapMaybe (getClassName <=< disqualifyFor qn) names - valueRefs = ValueRef <$> mapMaybe (getIdentName <=< disqualifyFor qn) names - valueOpRefs = ValueOpRef <$> mapMaybe (getValOpName <=< disqualifyFor qn) names - typeOpRefs = TypeOpRef <$> mapMaybe (getTypeOpName <=< disqualifyFor qn) names + classRefs = TypeClassRef ss <$> mapMaybe (getClassName <=< disqualifyFor qn) names + valueRefs = ValueRef ss <$> mapMaybe (getIdentName <=< disqualifyFor qn) names + valueOpRefs = ValueOpRef ss <$> mapMaybe (getValOpName <=< disqualifyFor qn) names + typeOpRefs = TypeOpRef ss <$> mapMaybe (getTypeOpName <=< disqualifyFor qn) names types = mapMaybe (getTypeName <=< disqualifyFor qn) names dctors = mapMaybe (getDctorName <=< disqualifyFor qn) names typesWithDctors = reconstructTypeRefs dctors typesWithoutDctors = filter (`M.notMember` typesWithDctors) types typesRefs - = map (flip TypeRef (Just [])) typesWithoutDctors - ++ map (\(ty, ds) -> TypeRef ty (Just ds)) (M.toList typesWithDctors) + = 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 where @@ -343,12 +340,11 @@ matchName _ name = Just name runDeclRef :: DeclarationRef -> Maybe Name -runDeclRef (PositionedDeclarationRef _ _ ref) = runDeclRef ref -runDeclRef (ValueRef ident) = Just $ IdentName ident -runDeclRef (ValueOpRef op) = Just $ ValOpName op -runDeclRef (TypeRef pn _) = Just $ TyName pn -runDeclRef (TypeOpRef op) = Just $ TyOpName op -runDeclRef (TypeClassRef pn) = Just $ TyClassName pn +runDeclRef (ValueRef _ ident) = Just $ IdentName ident +runDeclRef (ValueOpRef _ op) = Just $ ValOpName op +runDeclRef (TypeRef _ pn _) = Just $ TyName pn +runDeclRef (TypeOpRef _ op) = Just $ TyOpName op +runDeclRef (TypeClassRef _ pn) = Just $ TyClassName pn runDeclRef _ = Nothing checkDuplicateImports @@ -360,7 +356,6 @@ checkDuplicateImports mn xs ((_, t1, q1), (pos, t2, q2)) = if t1 == t2 && q1 == q2 then do - maybe id warnWithPosition pos $ - tell $ errorMessage $ DuplicateImport mn t2 q2 + tell . errorMessage' pos $ DuplicateImport mn t2 q2 return $ (pos, t2, q2) : xs else return xs diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs --- a/src/Language/PureScript/Make.hs +++ b/src/Language/PureScript/Make.hs @@ -68,7 +68,6 @@ import qualified Language.PureScript.Bundle as Bundle import qualified Language.PureScript.CodeGen.JS as J import Language.PureScript.CodeGen.JS.Printer -import qualified Language.PureScript.Constants as C import qualified Language.PureScript.CoreFn as CF import qualified Language.PureScript.CoreFn.ToJSON as CFJ import qualified Language.PureScript.CoreImp.AST as Imp @@ -258,9 +257,6 @@ externs <- decode bs guard $ T.unpack (efVersion externs) == showVersion Paths.version return externs - -importPrim :: Module -> Module -importPrim = addDefaultImport (ModuleName [ProperName C.prim]) -- | A monad for running make actions newtype Make a = Make diff --git a/src/Language/PureScript/ModuleDependencies.hs b/src/Language/PureScript/ModuleDependencies.hs --- a/src/Language/PureScript/ModuleDependencies.hs +++ b/src/Language/PureScript/ModuleDependencies.hs @@ -4,9 +4,10 @@ , ModuleGraph ) where -import Protolude +import Protolude hiding (head) import Data.Graph +import Data.List (head) import qualified Data.Set as S import Language.PureScript.AST import qualified Language.PureScript.Constants as C @@ -41,24 +42,25 @@ toGraphNode mns m@(Module _ _ mn ds _) = do let deps = ordNub (mapMaybe usedModules ds) void . parU deps $ \(dep, pos) -> - when (dep /= C.Prim && S.notMember dep mns) $ + when (dep /= C.Prim && S.notMember dep mns) . throwError . addHint (ErrorInModule mn) - . maybe identity (addHint . PositionedError) pos - . errorMessage + . errorMessage' pos $ ModuleNotFound dep pure (m, getModuleName m, map fst deps) -- | Calculate a list of used modules based on explicit imports and qualified names. -usedModules :: Declaration -> Maybe (ModuleName, Maybe SourceSpan) +usedModules :: Declaration -> Maybe (ModuleName, SourceSpan) -- Regardless of whether an imported module is qualified we still need to -- take into account its import to build an accurate list of dependencies. -usedModules (ImportDeclaration mn _ _) = pure (mn, Nothing) -usedModules (PositionedDeclaration ss _ d) = fmap (second (const (Just ss))) (usedModules d) +usedModules (ImportDeclaration (ss, _) mn _ _) = pure (mn, ss) usedModules _ = Nothing -- | Convert a strongly connected component of the module graph to a module toModule :: MonadError MultipleErrors m => SCC Module -> m Module toModule (AcyclicSCC m) = return m toModule (CyclicSCC [m]) = return m -toModule (CyclicSCC ms) = throwError . errorMessage $ CycleInModules (map getModuleName ms) +toModule (CyclicSCC ms) = + throwError + . errorMessage' (getModuleSourceSpan (head ms)) + $ CycleInModules (map getModuleName ms) diff --git a/src/Language/PureScript/Parser/Common.hs b/src/Language/PureScript/Parser/Common.hs --- a/src/Language/PureScript/Parser/Common.hs +++ b/src/Language/PureScript/Parser/Common.hs @@ -133,8 +133,8 @@ -> P.Parsec [PositionedToken] u a -> P.Parsec [PositionedToken] u b withSourceSpan f p = do - start <- P.getPosition comments <- readComments + start <- P.getPosition x <- p end <- P.getPosition input <- P.getInput @@ -143,3 +143,14 @@ _ -> Nothing let sp = SourceSpan (P.sourceName start) (toSourcePos start) (toSourcePos $ fromMaybe end end') return $ f sp comments x + +withSourceAnnF + :: P.Parsec [PositionedToken] u (SourceAnn -> a) + -> P.Parsec [PositionedToken] u a +withSourceAnnF = withSourceSpan (\ss com f -> f (ss, com)) + +withSourceSpan' + :: (SourceSpan -> a -> b) + -> P.Parsec [PositionedToken] u a + -> P.Parsec [PositionedToken] u b +withSourceSpan' f = withSourceSpan (\ss _ -> f ss) diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -24,6 +24,7 @@ import Control.Parallel.Strategies (withStrategy, parList, rseq) import Data.Functor (($>)) import Data.Maybe (fromMaybe) +import Data.Monoid ((<>)) import qualified Data.Set as S import Data.Text (Text) import Language.PureScript.AST @@ -45,25 +46,27 @@ <|> parens ((,) <$> identifier <*> (Just <$> (indented *> doubleColon *> indented *> parseKind))) parseDataDeclaration :: TokenParser Declaration -parseDataDeclaration = do +parseDataDeclaration = withSourceAnnF $ do dtype <- (reserved "data" *> return Data) <|> (reserved "newtype" *> return Newtype) name <- indented *> typeName tyArgs <- many (indented *> kindedIdent) ctors <- P.option [] $ do indented *> equals P.sepBy1 ((,) <$> dataConstructorName <*> P.many (indented *> noWildcards parseTypeAtom)) pipe - return $ DataDeclaration dtype name tyArgs ctors + return $ \sa -> DataDeclaration sa dtype name tyArgs ctors parseTypeDeclaration :: TokenParser Declaration -parseTypeDeclaration = - TypeDeclaration <$> P.try (parseIdent <* indented <* doubleColon) - <*> parsePolyType +parseTypeDeclaration = withSourceAnnF $ do + name <- P.try (parseIdent <* indented <* doubleColon) + ty <- parsePolyType + return $ \sa -> TypeDeclaration sa name ty parseTypeSynonymDeclaration :: TokenParser Declaration -parseTypeSynonymDeclaration = - TypeSynonymDeclaration <$> (reserved "type" *> indented *> typeName) - <*> many (indented *> kindedIdent) - <*> (indented *> equals *> noWildcards parsePolyType) +parseTypeSynonymDeclaration = withSourceAnnF $ do + name <- reserved "type" *> indented *> typeName + vars <- many (indented *> kindedIdent) + ty <- indented *> equals *> noWildcards parsePolyType + return $ \sa -> TypeSynonymDeclaration sa name vars ty parseValueWithWhereClause :: TokenParser Expr parseValueWithWhereClause = do @@ -76,7 +79,7 @@ mark $ P.many1 (same *> parseLocalDeclaration) return $ maybe value (`Let` value) whereClause -parseValueWithIdentAndBinders :: Ident -> [Binder] -> TokenParser Declaration +parseValueWithIdentAndBinders :: Ident -> [Binder] -> TokenParser (SourceAnn -> Declaration) parseValueWithIdentAndBinders ident bs = do value <- indented *> ( (\v -> [MkUnguarded v]) <$> (equals *> withSourceSpan PositionedValue parseValueWithWhereClause) <|> @@ -84,34 +87,43 @@ <*> (indented *> equals *> withSourceSpan PositionedValue parseValueWithWhereClause)) ) - return $ ValueDeclaration ident Public bs value + return $ \sa -> ValueDeclaration sa ident Public bs value parseValueDeclaration :: TokenParser Declaration -parseValueDeclaration = do +parseValueDeclaration = withSourceAnnF $ do ident <- parseIdent binders <- P.many parseBinderNoParens parseValueWithIdentAndBinders ident binders parseLocalValueDeclaration :: TokenParser Declaration -parseLocalValueDeclaration = join $ go <$> parseBinder <*> (P.many parseBinderNoParens) +parseLocalValueDeclaration = withSourceAnnF . + join $ go <$> parseBinder <*> P.many parseBinderNoParens where - go :: Binder -> [Binder] -> TokenParser Declaration + go :: Binder -> [Binder] -> TokenParser (SourceAnn -> Declaration) go (VarBinder ident) bs = parseValueWithIdentAndBinders ident bs go (PositionedBinder _ _ b) bs = go b bs - go binder [] = BoundValueDeclaration binder <$> (indented *> equals *> parseValueWithWhereClause) - go _ _ = P.unexpected $ "patterns in local value declaration" + go binder [] = do + boot <- indented *> equals *> parseValueWithWhereClause + return $ \sa -> BoundValueDeclaration sa binder boot + go _ _ = P.unexpected "patterns in local value declaration" parseExternDeclaration :: TokenParser Declaration -parseExternDeclaration = reserved "foreign" *> indented *> reserved "import" *> indented *> parseExternAlt where - parseExternAlt = parseExternData <|> P.try parseExternKind <|> parseExternTerm - - parseExternData = ExternDataDeclaration <$> (reserved "data" *> indented *> typeName) - <*> (indented *> doubleColon *> parseKind) - - parseExternKind = ExternKindDeclaration <$> (reserved "kind" *> indented *> kindName) - - parseExternTerm = ExternDeclaration <$> parseIdent - <*> (indented *> doubleColon *> noWildcards parsePolyType) +parseExternDeclaration = withSourceAnnF $ + reserved "foreign" *> + indented *> reserved "import" *> + indented *> (parseExternData <|> P.try parseExternKind <|> parseExternTerm) + where + parseExternData = + (\name kind sa -> ExternDataDeclaration sa name kind) + <$> (reserved "data" *> indented *> typeName) + <*> (indented *> doubleColon *> parseKind) + parseExternKind = + flip ExternKindDeclaration + <$> (reserved "kind" *> indented *> kindName) + parseExternTerm = + (\name ty sa -> ExternDeclaration sa name ty) + <$> parseIdent + <*> (indented *> doubleColon *> noWildcards parsePolyType) parseAssociativity :: TokenParser Associativity parseAssociativity = @@ -123,11 +135,11 @@ parseFixity = Fixity <$> parseAssociativity <*> (indented *> natural) parseFixityDeclaration :: TokenParser Declaration -parseFixityDeclaration = do +parseFixityDeclaration = withSourceAnnF $ do fixity <- parseFixity indented - FixityDeclaration - <$> ((Right <$> typeFixity fixity) <|> (Left <$> valueFixity fixity)) + def <- (Right <$> typeFixity fixity) <|> (Left <$> valueFixity fixity) + return $ \sa -> FixityDeclaration sa def where typeFixity fixity = TypeFixity fixity @@ -139,9 +151,9 @@ <*> (reserved "as" *> parseOperator) parseImportDeclaration :: TokenParser Declaration -parseImportDeclaration = withSourceSpan PositionedDeclaration $ do +parseImportDeclaration = withSourceAnnF $ do (mn, declType, asQ) <- parseImportDeclaration' - return $ ImportDeclaration mn declType asQ + return $ \sa -> ImportDeclaration sa mn declType asQ parseImportDeclaration' :: TokenParser (ModuleName, ImportDeclarationType, Maybe ModuleName) parseImportDeclaration' = do @@ -159,22 +171,21 @@ parseDeclarationRef :: TokenParser DeclarationRef parseDeclarationRef = - withSourceSpan PositionedDeclarationRef - $ (KindRef <$> P.try (reserved "kind" *> kindName)) - <|> (ValueRef <$> parseIdent) - <|> (ValueOpRef <$> parens parseOperator) - <|> parseTypeRef - <|> (TypeClassRef <$> (reserved "class" *> properName)) - <|> (ModuleRef <$> (indented *> reserved "module" *> moduleName)) - <|> (TypeOpRef <$> (indented *> reserved "type" *> parens parseOperator)) + withSourceSpan' KindRef (P.try (reserved "kind" *> kindName)) + <|> withSourceSpan' ValueRef parseIdent + <|> withSourceSpan' ValueOpRef (parens parseOperator) + <|> withSourceSpan' (\sa -> ($ TypeRef sa)) parseTypeRef + <|> withSourceSpan' TypeClassRef (reserved "class" *> properName) + <|> withSourceSpan' ModuleRef (indented *> reserved "module" *> moduleName) + <|> withSourceSpan' TypeOpRef (indented *> reserved "type" *> parens parseOperator) where parseTypeRef = do name <- typeName dctors <- P.optionMaybe $ parens (symbol' ".." *> pure Nothing <|> Just <$> commaSep dataConstructorName) - return $ TypeRef name (fromMaybe (Just []) dctors) + return $ \f -> f name (fromMaybe (Just []) dctors) parseTypeClassDeclaration :: TokenParser Declaration -parseTypeClassDeclaration = do +parseTypeClassDeclaration = withSourceAnnF $ do reserved "class" implies <- P.option [] . P.try $ do indented @@ -190,8 +201,8 @@ dependencies <- P.option [] (indented *> pipe *> commaSep1 parseFunctionalDependency) members <- P.option [] $ do indented *> reserved "where" - indented *> mark (P.many (same *> positioned parseTypeDeclaration)) - return $ TypeClassDeclaration className idents implies dependencies members + indented *> mark (P.many (same *> parseTypeDeclaration)) + return $ \sa -> TypeClassDeclaration sa className idents implies dependencies members parseConstraint :: TokenParser Constraint parseConstraint = Constraint <$> parseQualified properName @@ -199,24 +210,24 @@ <*> pure Nothing parseInstanceDeclaration :: TokenParser (TypeInstanceBody -> Declaration) -parseInstanceDeclaration = do +parseInstanceDeclaration = withSourceAnnF $ do reserved "instance" name <- parseIdent <* indented <* doubleColon - deps <- P.optionMaybe $ P.try $ do + deps <- P.optionMaybe . P.try $ do deps <- (return <$> parseConstraint) <|> parens (commaSep1 parseConstraint) indented rfatArrow return deps className <- indented *> parseQualified properName ty <- P.many (indented *> parseTypeAtom) - return $ TypeInstanceDeclaration name (fromMaybe [] deps) className ty + return $ \sa -> TypeInstanceDeclaration sa name (fromMaybe [] deps) className ty parseTypeInstanceDeclaration :: TokenParser Declaration parseTypeInstanceDeclaration = do instanceDecl <- parseInstanceDeclaration members <- P.option [] $ do indented *> reserved "where" - mark (P.many (same *> positioned declsInInstance)) + mark (P.many (same *> declsInInstance)) return $ instanceDecl (ExplicitInstance members) where declsInInstance :: TokenParser Declaration @@ -232,28 +243,27 @@ instanceDecl <- parseInstanceDeclaration return $ instanceDecl ty -positioned :: TokenParser Declaration -> TokenParser Declaration -positioned = withSourceSpan PositionedDeclaration - -- | Parse a single declaration parseDeclaration :: TokenParser Declaration -parseDeclaration = positioned (P.choice - [ parseDataDeclaration - , parseTypeDeclaration - , parseTypeSynonymDeclaration - , parseValueDeclaration - , parseExternDeclaration - , parseFixityDeclaration - , parseTypeClassDeclaration - , parseTypeInstanceDeclaration - , parseDerivingInstanceDeclaration - ]) P. "declaration" +parseDeclaration = + P.choice + [ parseDataDeclaration + , parseTypeDeclaration + , parseTypeSynonymDeclaration + , parseValueDeclaration + , parseExternDeclaration + , parseFixityDeclaration + , parseTypeClassDeclaration + , parseTypeInstanceDeclaration + , parseDerivingInstanceDeclaration + ] P. "declaration" parseLocalDeclaration :: TokenParser Declaration -parseLocalDeclaration = positioned (P.choice - [ parseTypeDeclaration - , parseLocalValueDeclaration - ] P. "local declaration") +parseLocalDeclaration = + P.choice + [ parseTypeDeclaration + , parseLocalValueDeclaration + ] P. "local declaration" -- | Parse a module declaration and its export declarations parseModuleDeclaration :: TokenParser (ModuleName, Maybe [DeclarationRef]) @@ -261,7 +271,7 @@ reserved "module" indented name <- moduleName - exports <- P.optionMaybe $ parens $ commaSep1 parseDeclarationRef + exports <- P.optionMaybe . parens $ commaSep1 parseDeclarationRef reserved "where" pure (name, exports) @@ -277,7 +287,7 @@ -- by only parsing as far as the module header. See PR #2054. imports <- P.many (same *> parseImportDeclaration) decls <- P.many (same *> parseDeclaration) - return (imports ++ decls) + return (imports <> decls) _ <- P.eof end <- P.getPosition let ss = SourceSpan (P.sourceName start) (toSourcePos start) (toSourcePos end) @@ -291,7 +301,7 @@ -> [(k, Text)] -> m [(k, Module)] parseModulesFromFiles toFilePath input = - flip parU wrapError . inParallel . flip map input $ parseModuleFromFile toFilePath + flip parU wrapError . inParallel . flip fmap input $ parseModuleFromFile toFilePath where wrapError :: Either P.ParseError a -> m a wrapError = either (throwError . MultipleErrors . pure . toPositionedError) return @@ -495,7 +505,7 @@ return (PathTree (AssocList (reverse tree))) where insertUpdate (seen, xs) (key, node) - | S.member key seen = P.unexpected ("Duplicate key in record update: " ++ show key) + | S.member key seen = P.unexpected ("Duplicate key in record update: " <> show key) | otherwise = return (S.insert key seen, (key, node) : xs) parseUpdaterBody :: Expr -> TokenParser Expr diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs --- a/src/Language/PureScript/Pretty/Values.hs +++ b/src/Language/PureScript/Pretty/Values.hs @@ -11,10 +11,10 @@ import Control.Arrow (second) +import Data.Text (Text) +import qualified Data.List.NonEmpty as NEL import qualified Data.Monoid as Monoid ((<>)) - import qualified Data.Text as T -import Data.Text (Text) import Language.PureScript.AST import Language.PureScript.Crash @@ -122,15 +122,14 @@ prettyPrintDeclaration :: Int -> Declaration -> Box prettyPrintDeclaration d _ | d < 0 = ellipsis -prettyPrintDeclaration _ (TypeDeclaration ident ty) = +prettyPrintDeclaration _ (TypeDeclaration _ ident ty) = text (T.unpack (showIdent ident) ++ " :: ") <> typeAsBox ty -prettyPrintDeclaration d (ValueDeclaration ident _ [] [GuardedExpr [] val]) = +prettyPrintDeclaration d (ValueDeclaration _ ident _ [] [GuardedExpr [] val]) = text (T.unpack (showIdent ident) ++ " = ") <> prettyPrintValue (d - 1) val prettyPrintDeclaration d (BindingGroupDeclaration ds) = - vsep 1 left (map (prettyPrintDeclaration (d - 1) . toDecl) ds) + vsep 1 left (NEL.toList (fmap (prettyPrintDeclaration (d - 1) . toDecl) ds)) where - toDecl (nm, t, e) = ValueDeclaration nm t [] [GuardedExpr [] e] -prettyPrintDeclaration d (PositionedDeclaration _ _ decl) = prettyPrintDeclaration d decl + toDecl ((sa, nm), t, e) = ValueDeclaration sa nm t [] [GuardedExpr [] e] prettyPrintDeclaration _ _ = internalError "Invalid argument to prettyPrintDeclaration" prettyPrintCaseAlternative :: Int -> CaseAlternative -> Box diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs --- a/src/Language/PureScript/Sugar/BindingGroups.hs +++ b/src/Language/PureScript/Sugar/BindingGroups.hs @@ -18,6 +18,7 @@ import Data.Graph import Data.List (intersect) import Data.Maybe (isJust) +import qualified Data.List.NonEmpty as NEL import qualified Data.Set as S import Language.PureScript.AST @@ -42,7 +43,7 @@ -- collapseBindingGroupsModule :: [Module] -> [Module] collapseBindingGroupsModule = - map $ \(Module ss coms name ds exps) -> + fmap $ \(Module ss coms name ds exps) -> Module ss coms name (collapseBindingGroups ds) exps createBindingGroups @@ -67,11 +68,11 @@ handleDecls ds = do let values = filter isValueDecl ds dataDecls = filter isDataDecl ds - allProperNames = map declTypeName dataDecls - dataVerts = map (\d -> (d, declTypeName d, usedTypeNames moduleName d `intersect` allProperNames)) dataDecls + allProperNames = fmap declTypeName dataDecls + dataVerts = fmap (\d -> (d, declTypeName d, usedTypeNames moduleName d `intersect` allProperNames)) dataDecls dataBindingGroupDecls <- parU (stronglyConnComp dataVerts) toDataBindingGroup - let allIdents = map declIdent values - valueVerts = map (\d -> (d, declIdent d, usedIdents moduleName d `intersect` allIdents)) values + let allIdents = fmap declIdent values + valueVerts = fmap (\d -> (d, declIdent d, usedIdents moduleName d `intersect` allIdents)) values bindingGroupDecls <- parU (stronglyConnComp valueVerts) (toBindingGroup moduleName) return $ filter isImportDecl ds ++ filter isExternKindDecl ds ++ @@ -89,14 +90,12 @@ collapseBindingGroups :: [Declaration] -> [Declaration] collapseBindingGroups = let (f, _, _) = everywhereOnValues id collapseBindingGroupsForValue id - in map f . concatMap go + in fmap f . concatMap go where - go (DataBindingGroupDeclaration ds) = ds + go (DataBindingGroupDeclaration ds) = NEL.toList ds go (BindingGroupDeclaration ds) = - map (\(ident, nameKind, val) -> - ValueDeclaration ident nameKind [] [MkUnguarded val]) ds - go (PositionedDeclaration pos com d) = - map (PositionedDeclaration pos com) $ go d + NEL.toList $ fmap (\((sa, ident), nameKind, val) -> + ValueDeclaration sa ident nameKind [] [MkUnguarded val]) ds go other = [other] collapseBindingGroupsForValue :: Expr -> Expr @@ -108,9 +107,8 @@ where def _ _ = [] - getValue (ValueDeclaration _ _ [] [MkUnguarded val]) = val + getValue (ValueDeclaration _ _ _ [] [MkUnguarded val]) = val getValue ValueDeclaration{} = internalError "Binders should have been desugared" - getValue (PositionedDeclaration _ _ d) = getValue d getValue _ = internalError "Expected ValueDeclaration" (_, usedIdents', _, _, _) = everythingWithScope def usedNamesE def def def @@ -152,14 +150,12 @@ usedNames _ = [] declIdent :: Declaration -> Ident -declIdent (ValueDeclaration ident _ _ _) = ident -declIdent (PositionedDeclaration _ _ d) = declIdent d +declIdent (ValueDeclaration _ ident _ _ _) = ident declIdent _ = internalError "Expected ValueDeclaration" declTypeName :: Declaration -> ProperName 'TypeName -declTypeName (DataDeclaration _ pn _ _) = pn -declTypeName (TypeSynonymDeclaration pn _ _) = pn -declTypeName (PositionedDeclaration _ _ d) = declTypeName d +declTypeName (DataDeclaration _ _ pn _ _) = pn +declTypeName (TypeSynonymDeclaration _ pn _ _) = pn declTypeName _ = internalError "Expected DataDeclaration" -- | @@ -173,7 +169,7 @@ -> SCC Declaration -> m Declaration toBindingGroup _ (AcyclicSCC d) = return d -toBindingGroup moduleName (CyclicSCC ds') = +toBindingGroup moduleName (CyclicSCC ds') = do -- Once we have a mutually-recursive group of declarations, we need to sort -- them further by their immediate dependencies (those outside function -- bodies). In particular, this is relevant for type instance dictionaries @@ -183,21 +179,20 @@ -- If we discover declarations that still contain mutually-recursive -- immediate references, we're guaranteed to get an undefined reference at -- runtime, so treat this as an error. See also github issue #365. - BindingGroupDeclaration <$> mapM toBinding (stronglyConnComp valueVerts) + BindingGroupDeclaration . NEL.fromList <$> mapM toBinding (stronglyConnComp valueVerts) where idents :: [Ident] - idents = map (\(_, i, _) -> i) valueVerts + idents = fmap (\(_, i, _) -> i) valueVerts valueVerts :: [(Declaration, Ident, [Ident])] - valueVerts = map (\d -> (d, declIdent d, usedImmediateIdents moduleName d `intersect` idents)) ds' + valueVerts = fmap (\d -> (d, declIdent d, usedImmediateIdents moduleName d `intersect` idents)) ds' - toBinding :: SCC Declaration -> m (Ident, NameKind, Expr) + toBinding :: SCC Declaration -> m ((SourceAnn, Ident), NameKind, Expr) toBinding (AcyclicSCC d) = return $ fromValueDecl d toBinding (CyclicSCC ds) = throwError $ foldMap cycleError ds cycleError :: Declaration -> MultipleErrors - cycleError (PositionedDeclaration p _ d) = onErrorMessages (withPosition p) $ cycleError d - cycleError (ValueDeclaration n _ _ [MkUnguarded _]) = errorMessage $ CycleInDeclaration n + cycleError (ValueDeclaration (ss, _) n _ _ [MkUnguarded _]) = errorMessage' ss $ CycleInDeclaration n cycleError _ = internalError "cycleError: Expected ValueDeclaration" toDataBindingGroup @@ -206,19 +201,17 @@ -> m Declaration toDataBindingGroup (AcyclicSCC d) = return d toDataBindingGroup (CyclicSCC [d]) = case isTypeSynonym d of - Just pn -> throwError . errorMessage $ CycleInTypeSynonym (Just pn) + Just pn -> throwError . errorMessage' (declSourceSpan d) $ CycleInTypeSynonym (Just pn) _ -> return d toDataBindingGroup (CyclicSCC ds') - | all (isJust . isTypeSynonym) ds' = throwError . errorMessage $ CycleInTypeSynonym Nothing - | otherwise = return $ DataBindingGroupDeclaration ds' + | all (isJust . isTypeSynonym) ds' = throwError . errorMessage' (declSourceSpan (head ds')) $ CycleInTypeSynonym Nothing + | otherwise = return . DataBindingGroupDeclaration $ NEL.fromList ds' isTypeSynonym :: Declaration -> Maybe (ProperName 'TypeName) -isTypeSynonym (TypeSynonymDeclaration pn _ _) = Just pn -isTypeSynonym (PositionedDeclaration _ _ d) = isTypeSynonym d +isTypeSynonym (TypeSynonymDeclaration _ pn _ _) = Just pn isTypeSynonym _ = Nothing -fromValueDecl :: Declaration -> (Ident, NameKind, Expr) -fromValueDecl (ValueDeclaration ident nameKind [] [MkUnguarded val]) = (ident, nameKind, val) +fromValueDecl :: Declaration -> ((SourceAnn, Ident), NameKind, Expr) +fromValueDecl (ValueDeclaration sa ident nameKind [] [MkUnguarded val]) = ((sa, ident), nameKind, val) fromValueDecl ValueDeclaration{} = internalError "Binders should have been desugared" -fromValueDecl (PositionedDeclaration _ _ d) = fromValueDecl d fromValueDecl _ = internalError "Expected ValueDeclaration" diff --git a/src/Language/PureScript/Sugar/CaseDeclarations.hs b/src/Language/PureScript/Sugar/CaseDeclarations.hs --- a/src/Language/PureScript/Sugar/CaseDeclarations.hs +++ b/src/Language/PureScript/Sugar/CaseDeclarations.hs @@ -42,9 +42,11 @@ :: forall m. (MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration] -desugarCaseGuards declarations = parU declarations f +desugarCaseGuards declarations = parU declarations go where - (f, _, _) = everywhereOnValuesM return desugarGuardedExprs return + go d = + let (f, _, _) = everywhereOnValuesM return (desugarGuardedExprs (declSourceSpan d)) return + in f d -- | -- Desugar case with pattern guards and pattern clauses to a @@ -52,9 +54,10 @@ -- desugarGuardedExprs :: forall m. (MonadSupply m) - => Expr + => SourceSpan + -> Expr -> m Expr -desugarGuardedExprs (Case scrut alternatives) +desugarGuardedExprs ss (Case scrut alternatives) | any (not . isTrivialExpr) scrut = do -- in case the scrutinee is non trivial (e.g. not a Var or Literal) -- we may evaluate the scrutinee more than once when a guard occurrs. @@ -62,10 +65,10 @@ (scrut', scrut_decls) <- unzip <$> forM scrut (\e -> do scrut_id <- freshIdent' pure ( Var (Qualified Nothing scrut_id) - , ValueDeclaration scrut_id Private [] [MkUnguarded e] + , ValueDeclaration (ss, []) scrut_id Private [] [MkUnguarded e] ) ) - Let scrut_decls <$> desugarGuardedExprs (Case scrut' alternatives) + Let scrut_decls <$> desugarGuardedExprs ss (Case scrut' alternatives) where isTrivialExpr (Var _) = True isTrivialExpr (Literal _) = True @@ -75,7 +78,7 @@ isTrivialExpr (TypedValue _ e _) = isTrivialExpr e isTrivialExpr _ = False -desugarGuardedExprs (Case scrut alternatives) = +desugarGuardedExprs ss (Case scrut alternatives) = let -- Alternatives which do not have guards are -- left as-is. Alternatives which @@ -217,7 +220,7 @@ desugarAltOutOfLine alt_binder rem_guarded rem_alts mk_body | Just rem_case <- mkCaseOfRemainingGuardsAndAlts = do - desugared <- desugarGuardedExprs rem_case + desugared <- desugarGuardedExprs ss rem_case rem_case_id <- freshIdent' unused_binder <- freshIdent' @@ -228,7 +231,7 @@ alt_fail = [CaseAlternative [NullBinder] [MkUnguarded goto_rem_case]] pure $ Let [ - ValueDeclaration rem_case_id Private [] + ValueDeclaration (ss, []) rem_case_id Private [] [MkUnguarded (Abs (VarBinder unused_binder) desugared)] ] (mk_body alt_fail) @@ -263,13 +266,13 @@ alts' <- desugarAlternatives alternatives return $ optimize (Case scrut alts') -desugarGuardedExprs (TypedValue infered e ty) = - TypedValue infered <$> desugarGuardedExprs e <*> pure ty +desugarGuardedExprs ss (TypedValue infered e ty) = + TypedValue infered <$> desugarGuardedExprs ss e <*> pure ty -desugarGuardedExprs (PositionedValue ss comms e) = - PositionedValue ss comms <$> desugarGuardedExprs e +desugarGuardedExprs _ (PositionedValue ss comms e) = + PositionedValue ss comms <$> desugarGuardedExprs ss e -desugarGuardedExprs v = pure v +desugarGuardedExprs _ v = pure v -- | -- Validates that case head and binder lengths match. @@ -323,33 +326,28 @@ desugarCases = desugarRest <=< fmap join . flip parU toDecls . groupBy inSameGroup where desugarRest :: [Declaration] -> m [Declaration] - desugarRest (TypeInstanceDeclaration name constraints className tys ds : rest) = - (:) <$> (TypeInstanceDeclaration name constraints className tys <$> traverseTypeInstanceBody desugarCases ds) <*> desugarRest rest - desugarRest (ValueDeclaration name nameKind bs result : rest) = + desugarRest (TypeInstanceDeclaration sa name constraints className tys ds : rest) = + (:) <$> (TypeInstanceDeclaration sa name constraints className tys <$> traverseTypeInstanceBody desugarCases ds) <*> desugarRest rest + desugarRest (ValueDeclaration sa name nameKind bs result : rest) = let (_, f, _) = everywhereOnValuesTopDownM return go return f' = mapM (\(GuardedExpr gs e) -> GuardedExpr gs <$> f e) - in (:) <$> (ValueDeclaration name nameKind bs <$> f' result) <*> desugarRest rest + in (:) <$> (ValueDeclaration sa name nameKind bs <$> f' result) <*> desugarRest rest where go (Let ds val') = Let <$> desugarCases ds <*> pure val' go other = return other - desugarRest (PositionedDeclaration pos com d : ds) = do - (d' : ds') <- desugarRest (d : ds) - return (PositionedDeclaration pos com d' : ds') desugarRest (d : ds) = (:) d <$> desugarRest ds desugarRest [] = pure [] inSameGroup :: Declaration -> Declaration -> Bool -inSameGroup (ValueDeclaration ident1 _ _ _) (ValueDeclaration ident2 _ _ _) = ident1 == ident2 -inSameGroup (PositionedDeclaration _ _ d1) d2 = inSameGroup d1 d2 -inSameGroup d1 (PositionedDeclaration _ _ d2) = inSameGroup d1 d2 +inSameGroup (ValueDeclaration _ ident1 _ _ _) (ValueDeclaration _ ident2 _ _ _) = ident1 == ident2 inSameGroup _ _ = False toDecls :: forall m. (MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration] -toDecls [ValueDeclaration ident nameKind bs [MkUnguarded val]] | all isIrrefutable bs = do +toDecls [ValueDeclaration sa@(ss, _) ident nameKind bs [MkUnguarded val]] | all isIrrefutable bs = do args <- mapM fromVarBinder bs let body = foldr (Abs . VarBinder) val args - guardWith (errorMessage (OverlappingArgNames (Just ident))) $ length (ordNub args) == length args - return [ValueDeclaration ident nameKind [] [MkUnguarded body]] + guardWith (errorMessage' ss (OverlappingArgNames (Just ident))) $ length (ordNub args) == length args + return [ValueDeclaration sa ident nameKind [] [MkUnguarded body]] where fromVarBinder :: Binder -> m Ident fromVarBinder NullBinder = freshIdent' @@ -357,30 +355,26 @@ fromVarBinder (PositionedBinder _ _ b) = fromVarBinder b fromVarBinder (TypedBinder _ b) = fromVarBinder b fromVarBinder _ = internalError "fromVarBinder: Invalid argument" -toDecls ds@(ValueDeclaration ident _ bs (result : _) : _) = do +toDecls ds@(ValueDeclaration (ss, _) ident _ bs (result : _) : _) = do let tuples = map toTuple ds isGuarded (MkUnguarded _) = False isGuarded _ = True - unless (all ((== length bs) . length . fst) tuples) $ - throwError . errorMessage $ ArgListLengthsDiffer ident - unless (not (null bs) || isGuarded result) $ - throwError . errorMessage $ DuplicateValueDeclaration ident - caseDecl <- makeCaseDeclaration ident tuples + unless (all ((== length bs) . length . fst) tuples) . + throwError . errorMessage' ss $ ArgListLengthsDiffer ident + unless (not (null bs) || isGuarded result) . + throwError . errorMessage' ss $ DuplicateValueDeclaration ident + caseDecl <- makeCaseDeclaration ss ident tuples return [caseDecl] -toDecls (PositionedDeclaration pos com d : ds) = do - (d' : ds') <- rethrowWithPosition pos $ toDecls (d : ds) - return (PositionedDeclaration pos com d' : ds') toDecls ds = return ds toTuple :: Declaration -> ([Binder], [GuardedExpr]) -toTuple (ValueDeclaration _ _ bs result) = (bs, result) -toTuple (PositionedDeclaration _ _ d) = toTuple d +toTuple (ValueDeclaration _ _ _ bs result) = (bs, result) toTuple _ = internalError "Not a value declaration" -makeCaseDeclaration :: forall m. (MonadSupply m) => Ident -> [([Binder], [GuardedExpr])] -> m Declaration -makeCaseDeclaration ident alternatives = do +makeCaseDeclaration :: forall m. (MonadSupply m) => SourceSpan -> Ident -> [([Binder], [GuardedExpr])] -> m Declaration +makeCaseDeclaration ss ident alternatives = do let namedArgs = map findName . fst <$> alternatives argNames = foldl1 resolveNames namedArgs args <- if allUnique (catMaybes argNames) @@ -390,7 +384,7 @@ binders = [ CaseAlternative bs result | (bs, result) <- alternatives ] let value = foldr (Abs . VarBinder) (Case vars binders) args - return $ ValueDeclaration ident Public [] [MkUnguarded value] + return $ ValueDeclaration (ss, []) ident Public [] [MkUnguarded value] where -- We will construct a table of potential names. -- VarBinders will become Just _ which is a potential name. diff --git a/src/Language/PureScript/Sugar/DoNotation.hs b/src/Language/PureScript/Sugar/DoNotation.hs --- a/src/Language/PureScript/Sugar/DoNotation.hs +++ b/src/Language/PureScript/Sugar/DoNotation.hs @@ -24,10 +24,9 @@ -- | Desugar a single do statement desugarDo :: forall m. (MonadSupply m, MonadError MultipleErrors m) => Declaration -> m Declaration -desugarDo (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> rethrowWithPosition pos (desugarDo d) desugarDo d = let (f, _, _) = everywhereOnValuesM return replace return - in f d + in rethrowWithPosition (declSourceSpan d) $ f d where bind :: Expr bind = Var (Qualified Nothing (Ident C.bind)) @@ -62,9 +61,8 @@ go [DoNotationLet _] = throwError . errorMessage $ InvalidDoLet go (DoNotationLet ds : rest) = do let checkBind :: Declaration -> m () - checkBind (ValueDeclaration i@(Ident name) _ _ _) - | name `elem` [ C.bind, C.discard ] = throwError . errorMessage $ CannotUseBindWithDo i - checkBind (PositionedDeclaration pos _ decl) = rethrowWithPosition pos (checkBind decl) + checkBind (ValueDeclaration (ss, _) i@(Ident name) _ _ _) + | name `elem` [ C.bind, C.discard ] = throwError . errorMessage' ss $ CannotUseBindWithDo i checkBind _ = pure () mapM_ checkBind ds rest' <- go rest diff --git a/src/Language/PureScript/Sugar/LetPattern.hs b/src/Language/PureScript/Sugar/LetPattern.hs --- a/src/Language/PureScript/Sugar/LetPattern.hs +++ b/src/Language/PureScript/Sugar/LetPattern.hs @@ -19,7 +19,6 @@ -- Desugar a single let expression -- desugarLetPattern :: Declaration -> Declaration -desugarLetPattern (PositionedDeclaration pos com d) = PositionedDeclaration pos com $ desugarLetPattern d desugarLetPattern decl = let (f, _, _) = everywhereOnValues id replace id in f decl @@ -34,12 +33,8 @@ -- ^ The original let-in result expression -> Expr go [] e = e - go (pd@(PositionedDeclaration pos com d) : ds) e = - case d of - BoundValueDeclaration {} -> PositionedValue pos com $ go (d:ds) e - _ -> append pd $ go ds e - go (BoundValueDeclaration binder boundE : ds) e = - Case [boundE] [CaseAlternative [binder] [MkUnguarded $ go ds e]] + go (BoundValueDeclaration (pos, com) binder boundE : ds) e = + PositionedValue pos com $ Case [boundE] [CaseAlternative [binder] [MkUnguarded $ go ds e]] go (d:ds) e = append d $ go ds e append :: Declaration -> Expr -> Expr diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -65,9 +65,9 @@ externsEnv :: Env -> ExternsFile -> m Env externsEnv env ExternsFile{..} = do let members = Exports{..} - env' = M.insert efModuleName (efSourceSpan, primImports, members) env - fromEFImport (ExternsImport mn mt qmn) = (mn, [(Nothing, Just mt, qmn)]) - imps <- foldM (resolveModuleImport env') primImports (map fromEFImport efImports) + env' = M.insert efModuleName (efSourceSpan, nullImports, members) env + fromEFImport (ExternsImport mn mt qmn) = (mn, [(efSourceSpan, Just mt, qmn)]) + imps <- foldM (resolveModuleImport env') nullImports (map fromEFImport efImports) exps <- resolveExports env' efSourceSpan efModuleName imps members efExports return $ M.insert efModuleName (efSourceSpan, imps, exps) env where @@ -75,12 +75,11 @@ exportedTypes :: M.Map (ProperName 'TypeName) ([ProperName 'ConstructorName], ModuleName) exportedTypes = M.fromList $ mapMaybe toExportedType efExports where - toExportedType (TypeRef tyCon dctors) = Just (tyCon, (fromMaybe (mapMaybe forTyCon efDeclarations) dctors, efModuleName)) + toExportedType (TypeRef _ tyCon dctors) = Just (tyCon, (fromMaybe (mapMaybe forTyCon efDeclarations) dctors, efModuleName)) where forTyCon :: ExternsDeclaration -> Maybe (ProperName 'ConstructorName) forTyCon (EDDataConstructor pn _ tNm _ _) | tNm == tyCon = Just pn forTyCon _ = Nothing - toExportedType (PositionedDeclarationRef _ _ r) = toExportedType r toExportedType _ = Nothing exportedTypeOps :: M.Map (OpName 'TypeOpName) ModuleName @@ -104,7 +103,7 @@ updateEnv :: ([Module], Env) -> Module -> m ([Module], Env) updateEnv (ms, env) m@(Module ss _ mn _ refs) = do members <- findExportable m - let env' = M.insert mn (ss, primImports, members) env + let env' = M.insert mn (ss, nullImports, members) env (m', imps) <- resolveImports env' m exps <- maybe (return members) (resolveExports env' ss mn imps members) refs return (m' : ms, M.insert mn (ss, imps, exps) env) @@ -127,24 +126,24 @@ elaborateExports exps (Module ss coms mn decls refs) = Module ss coms mn decls $ Just $ elaboratedTypeRefs - ++ go TypeOpRef exportedTypeOps - ++ go TypeClassRef exportedTypeClasses - ++ go ValueRef exportedValues - ++ go ValueOpRef exportedValueOps - ++ go KindRef exportedKinds + ++ go (TypeOpRef ss) exportedTypeOps + ++ go (TypeClassRef ss) exportedTypeClasses + ++ go (ValueRef ss) exportedValues + ++ go (ValueOpRef ss) exportedValueOps + ++ go (KindRef ss) exportedKinds ++ maybe [] (filter isModuleRef) refs where elaboratedTypeRefs :: [DeclarationRef] elaboratedTypeRefs = flip map (M.toList (exportedTypes exps)) $ \(tctor, (dctors, mn')) -> - let ref = TypeRef tctor (Just dctors) - in if mn == mn' then ref else ReExportRef mn' ref + let ref = TypeRef ss tctor (Just dctors) + in if mn == mn' then ref else ReExportRef ss mn' ref go :: (a -> DeclarationRef) -> (Exports -> M.Map a ModuleName) -> [DeclarationRef] go toRef select = flip map (M.toList (select exps)) $ \(export, mn') -> - if mn == mn' then toRef export else ReExportRef mn' (toRef export) + if mn == mn' then toRef export else ReExportRef ss mn' (toRef export) -- | -- Replaces all local names with qualified names within a module and checks that all existing @@ -156,58 +155,89 @@ => Imports -> Module -> m Module -renameInModule imports (Module ss coms mn decls exps) = - Module ss coms mn <$> parU decls go <*> pure exps +renameInModule imports (Module modSS coms mn decls exps) = + Module modSS coms mn <$> parU decls go <*> pure exps where - (go, _, _, _, _) = everywhereWithContextOnValuesM (Nothing, []) updateDecl updateValue updateBinder updateCase defS + (go, _, _, _, _) = + everywhereWithContextOnValuesM + (modSS, []) + (\(_, bound) d -> (\(bound', d') -> ((declSourceSpan d', bound'), d')) <$> updateDecl bound d) + updateValue + updateBinder + updateCase + defS updateDecl - :: (Maybe SourceSpan, [Ident]) + :: [Ident] -> Declaration - -> m ((Maybe SourceSpan, [Ident]), Declaration) - updateDecl (_, bound) d@(PositionedDeclaration pos _ _) = - return ((Just pos, bound), d) - updateDecl (pos, bound) (DataDeclaration dtype name args dctors) = - (,) (pos, bound) <$> (DataDeclaration dtype name <$> updateTypeArguments pos args - <*> traverse (sndM (traverse (updateTypesEverywhere pos))) dctors) - updateDecl (pos, bound) (TypeSynonymDeclaration name ps ty) = - (,) (pos, bound) <$> (TypeSynonymDeclaration name <$> updateTypeArguments pos ps - <*> updateTypesEverywhere pos ty) - updateDecl (pos, bound) (TypeClassDeclaration className args implies deps ds) = - (,) (pos, bound) <$> (TypeClassDeclaration className <$> updateTypeArguments pos args - <*> updateConstraints pos implies - <*> pure deps - <*> pure ds) - updateDecl (pos, bound) (TypeInstanceDeclaration name cs cn ts ds) = - (,) (pos, bound) <$> (TypeInstanceDeclaration name <$> updateConstraints pos cs <*> updateClassName cn pos <*> traverse (updateTypesEverywhere pos) ts <*> pure ds) - updateDecl (pos, bound) (TypeDeclaration name ty) = - (,) (pos, bound) <$> (TypeDeclaration name <$> updateTypesEverywhere pos ty) - updateDecl (pos, bound) (ExternDeclaration name ty) = - (,) (pos, name : bound) <$> (ExternDeclaration name <$> updateTypesEverywhere pos ty) - updateDecl (pos, bound) (ExternDataDeclaration name ki) = - (,) (pos, bound) <$> (ExternDataDeclaration name <$> updateKindsEverywhere pos ki) - updateDecl (pos, bound) (TypeFixityDeclaration fixity alias op) = - (,) (pos, bound) <$> (TypeFixityDeclaration fixity <$> updateTypeName alias pos <*> pure op) - updateDecl (pos, bound) (ValueFixityDeclaration fixity (Qualified mn' (Left alias)) op) = - (,) (pos, bound) <$> (ValueFixityDeclaration fixity . fmap Left <$> updateValueName (Qualified mn' alias) pos <*> pure op) - updateDecl (pos, bound) (ValueFixityDeclaration fixity (Qualified mn' (Right alias)) op) = - (,) (pos, bound) <$> (ValueFixityDeclaration fixity . fmap Right <$> updateDataConstructorName (Qualified mn' alias) pos <*> pure op) - updateDecl s d = return (s, d) + -> m ([Ident], Declaration) + updateDecl bound (DataDeclaration sa@(ss, _) dtype name args dctors) = + fmap (bound,) $ + DataDeclaration sa dtype name + <$> updateTypeArguments ss args + <*> traverse (sndM (traverse (updateTypesEverywhere ss))) dctors + updateDecl bound (TypeSynonymDeclaration sa@(ss, _) name ps ty) = + fmap (bound,) $ + TypeSynonymDeclaration sa name + <$> updateTypeArguments ss ps + <*> updateTypesEverywhere ss ty + updateDecl bound (TypeClassDeclaration sa@(ss, _) className args implies deps ds) = + fmap (bound,) $ + TypeClassDeclaration sa className + <$> updateTypeArguments ss args + <*> updateConstraints ss implies + <*> pure deps + <*> pure ds + updateDecl bound (TypeInstanceDeclaration sa@(ss, _) name cs cn ts ds) = + fmap (bound,) $ + TypeInstanceDeclaration sa name + <$> updateConstraints ss cs + <*> updateClassName cn ss + <*> traverse (updateTypesEverywhere ss) ts + <*> pure ds + updateDecl bound (TypeDeclaration sa@(ss, _) name ty) = + fmap (bound,) $ + TypeDeclaration sa name + <$> updateTypesEverywhere ss ty + updateDecl bound (ExternDeclaration sa@(ss, _) name ty) = + fmap (name : bound,) $ + ExternDeclaration sa name + <$> updateTypesEverywhere ss ty + updateDecl bound (ExternDataDeclaration sa@(ss, _) name ki) = + fmap (bound,) $ + ExternDataDeclaration sa name + <$> updateKindsEverywhere ss ki + updateDecl bound (TypeFixityDeclaration sa@(ss, _) fixity alias op) = + fmap (bound,) $ + TypeFixityDeclaration sa fixity + <$> updateTypeName alias ss + <*> pure op + updateDecl bound (ValueFixityDeclaration sa@(ss, _) fixity (Qualified mn' (Left alias)) op) = + fmap (bound,) $ + ValueFixityDeclaration sa fixity . fmap Left + <$> updateValueName (Qualified mn' alias) ss + <*> pure op + updateDecl bound (ValueFixityDeclaration sa@(ss, _) fixity (Qualified mn' (Right alias)) op) = + fmap (bound,) $ + ValueFixityDeclaration sa fixity . fmap Right + <$> updateDataConstructorName (Qualified mn' alias) ss + <*> pure op + updateDecl b d = + return (b, d) updateValue - :: (Maybe SourceSpan, [Ident]) + :: (SourceSpan, [Ident]) -> Expr - -> m ((Maybe SourceSpan, [Ident]), Expr) + -> m ((SourceSpan, [Ident]), Expr) updateValue (_, bound) v@(PositionedValue pos' _ _) = - return ((Just pos', bound), v) + return ((pos', bound), v) updateValue (pos, bound) (Abs (VarBinder arg) val') = return ((pos, arg : bound), Abs (VarBinder arg) val') updateValue (pos, bound) (Let ds val') = do let args = mapMaybe letBoundVariable ds - unless (length (ordNub args) == length args) $ - maybe id rethrowWithPosition pos $ - throwError . errorMessage $ OverlappingNamesInLet + unless (length (ordNub args) == length args) . + throwError . errorMessage' pos $ OverlappingNamesInLet return ((pos, args ++ bound), Let ds val') updateValue (pos, bound) (Var name'@(Qualified Nothing ident)) | ident `notElem` bound = (,) (pos, bound) <$> (Var <$> updateValueName name' pos) @@ -222,11 +252,11 @@ updateValue s v = return (s, v) updateBinder - :: (Maybe SourceSpan, [Ident]) + :: (SourceSpan, [Ident]) -> Binder - -> m ((Maybe SourceSpan, [Ident]), Binder) + -> m ((SourceSpan, [Ident]), Binder) updateBinder (_, bound) v@(PositionedBinder pos _ _) = - return ((Just pos, bound), v) + return ((pos, bound), v) updateBinder s@(pos, _) (ConstructorBinder name b) = (,) s <$> (ConstructorBinder <$> updateDataConstructorName name pos <*> pure b) updateBinder s@(pos, _) (OpBinder op) = @@ -238,9 +268,9 @@ return (s, v) updateCase - :: (Maybe SourceSpan, [Ident]) + :: (SourceSpan, [Ident]) -> CaseAlternative - -> m ((Maybe SourceSpan, [Ident]), CaseAlternative) + -> m ((SourceSpan, [Ident]), CaseAlternative) updateCase (pos, bound) c@(CaseAlternative bs gs) = return ((pos, concatMap binderNames bs ++ updateGuard gs ++ bound), c) where @@ -253,11 +283,10 @@ updatePatGuard _ = [] letBoundVariable :: Declaration -> Maybe Ident - letBoundVariable (ValueDeclaration ident _ _ _) = Just ident - letBoundVariable (PositionedDeclaration _ _ d) = letBoundVariable d + letBoundVariable (ValueDeclaration _ ident _ _ _) = Just ident letBoundVariable _ = Nothing - updateKindsEverywhere :: Maybe SourceSpan -> Kind -> m Kind + updateKindsEverywhere :: SourceSpan -> Kind -> m Kind updateKindsEverywhere pos = everywhereOnKindsM updateKind where updateKind :: Kind -> m Kind @@ -266,11 +295,11 @@ updateTypeArguments :: (Traversable f, Traversable g) - => Maybe SourceSpan + => SourceSpan -> f (a, g Kind) -> m (f (a, g Kind)) updateTypeArguments pos = traverse (sndM (traverse (updateKindsEverywhere pos))) - updateTypesEverywhere :: Maybe SourceSpan -> Type -> m Type + updateTypesEverywhere :: SourceSpan -> Type -> m Type updateTypesEverywhere pos = everywhereOnTypesM updateType where updateType :: Type -> m Type @@ -283,7 +312,7 @@ updateInConstraint (Constraint name ts info) = Constraint <$> updateClassName name pos <*> pure ts <*> pure info - updateConstraints :: Maybe SourceSpan -> [Constraint] -> m [Constraint] + updateConstraints :: SourceSpan -> [Constraint] -> m [Constraint] updateConstraints pos = traverse $ \(Constraint name ts info) -> Constraint <$> updateClassName name pos @@ -292,40 +321,40 @@ updateTypeName :: Qualified (ProperName 'TypeName) - -> Maybe SourceSpan + -> SourceSpan -> m (Qualified (ProperName 'TypeName)) updateTypeName = update (importedTypes imports) TyName updateTypeOpName :: Qualified (OpName 'TypeOpName) - -> Maybe SourceSpan + -> SourceSpan -> m (Qualified (OpName 'TypeOpName)) updateTypeOpName = update (importedTypeOps imports) TyOpName updateDataConstructorName :: Qualified (ProperName 'ConstructorName) - -> Maybe SourceSpan + -> SourceSpan -> m (Qualified (ProperName 'ConstructorName)) updateDataConstructorName = update (importedDataConstructors imports) DctorName updateClassName :: Qualified (ProperName 'ClassName) - -> Maybe SourceSpan + -> SourceSpan -> m (Qualified (ProperName 'ClassName)) updateClassName = update (importedTypeClasses imports) TyClassName - updateValueName :: Qualified Ident -> Maybe SourceSpan -> m (Qualified Ident) + updateValueName :: Qualified Ident -> SourceSpan -> m (Qualified Ident) updateValueName = update (importedValues imports) IdentName updateValueOpName :: Qualified (OpName 'ValueOpName) - -> Maybe SourceSpan + -> SourceSpan -> m (Qualified (OpName 'ValueOpName)) updateValueOpName = update (importedValueOps imports) ValOpName updateKindName :: Qualified (ProperName 'KindName) - -> Maybe SourceSpan + -> SourceSpan -> m (Qualified (ProperName 'KindName)) updateKindName = update (importedKinds imports) KiName @@ -337,9 +366,9 @@ => M.Map (Qualified a) [ImportRecord a] -> (a -> Name) -> Qualified a - -> Maybe SourceSpan + -> SourceSpan -> m (Qualified a) - update imps toName qname@(Qualified mn' name) pos = positioned $ + update imps toName qname@(Qualified mn' name) pos = warnAndRethrowWithPosition pos $ case (M.lookup qname imps, mn') of -- We found the name in our imports, so we return the name for it, @@ -367,5 +396,4 @@ _ -> throwUnknown where - positioned err = maybe err (`warnAndRethrowWithPosition` err) pos throwUnknown = throwError . errorMessage . UnknownName . fmap toName $ qname diff --git a/src/Language/PureScript/Sugar/Names/Common.hs b/src/Language/PureScript/Sugar/Names/Common.hs --- a/src/Language/PureScript/Sugar/Names/Common.hs +++ b/src/Language/PureScript/Sugar/Names/Common.hs @@ -6,8 +6,7 @@ import Control.Monad.Writer (MonadWriter(..)) import Data.Foldable (for_) -import Data.Function (on) -import Data.List (nubBy, (\\)) +import Data.List (nub, (\\)) import Data.Maybe (mapMaybe) import Language.PureScript.AST @@ -25,7 +24,7 @@ -> m () warnDuplicateRefs pos toError refs = do let withoutCtors = deleteCtors `map` refs - dupeRefs = mapMaybe (refToName pos) $ withoutCtors \\ nubBy ((==) `on` withoutPosInfo) withoutCtors + dupeRefs = mapMaybe (refToName pos) $ withoutCtors \\ nub withoutCtors dupeCtors = concat $ mapMaybe (extractCtors pos) refs for_ (dupeRefs ++ dupeCtors) $ \(pos', name) -> @@ -33,37 +32,26 @@ where - -- Returns a DeclarationRef unwrapped from any PositionedDeclarationRef - -- constructor(s) it may be wrapped within. Used so position info is ignored - -- when making the comparison for duplicates. - withoutPosInfo :: DeclarationRef -> DeclarationRef - withoutPosInfo (PositionedDeclarationRef _ _ ref) = withoutPosInfo ref - withoutPosInfo other = other - -- Deletes the constructor information from TypeRefs so that only the -- referenced type is used in the duplicate check - constructors are handled -- separately deleteCtors :: DeclarationRef -> DeclarationRef - deleteCtors (PositionedDeclarationRef ss com ref) = - PositionedDeclarationRef ss com (deleteCtors ref) - deleteCtors (TypeRef pn _) = TypeRef pn Nothing + deleteCtors (TypeRef sa pn _) = TypeRef sa pn Nothing deleteCtors other = other -- Extracts the names of duplicate constructor references from TypeRefs. extractCtors :: SourceSpan -> DeclarationRef -> Maybe [(SourceSpan, Name)] - extractCtors _ (PositionedDeclarationRef pos' _ ref) = extractCtors pos' ref - extractCtors pos' (TypeRef _ (Just dctors)) = + extractCtors pos' (TypeRef _ _ (Just dctors)) = let dupes = dctors \\ ordNub dctors in if null dupes then Nothing else Just $ ((pos',) . DctorName) <$> dupes extractCtors _ _ = Nothing -- Converts a DeclarationRef into a name for an error message. refToName :: SourceSpan -> DeclarationRef -> Maybe (SourceSpan, Name) - refToName pos' (TypeRef name _) = Just (pos', TyName name) - refToName pos' (TypeOpRef op) = Just (pos', TyOpName op) - refToName pos' (ValueRef name) = Just (pos', IdentName name) - refToName pos' (ValueOpRef op) = Just (pos', ValOpName op) - refToName pos' (TypeClassRef name) = Just (pos', TyClassName name) - refToName pos' (ModuleRef name) = Just (pos', ModName name) - refToName _ (PositionedDeclarationRef pos' _ ref) = refToName pos' ref + refToName pos' (TypeRef _ name _) = Just (pos', TyName name) + refToName pos' (TypeOpRef _ op) = Just (pos', TyOpName op) + refToName pos' (ValueRef _ name) = Just (pos', IdentName name) + refToName pos' (ValueOpRef _ op) = Just (pos', ValOpName op) + refToName pos' (TypeClassRef _ name) = Just (pos', TyClassName name) + refToName pos' (ModuleRef _ name) = Just (pos', ModName name) refToName _ _ = Nothing diff --git a/src/Language/PureScript/Sugar/Names/Env.hs b/src/Language/PureScript/Sugar/Names/Env.hs --- a/src/Language/PureScript/Sugar/Names/Env.hs +++ b/src/Language/PureScript/Sugar/Names/Env.hs @@ -2,7 +2,7 @@ ( ImportRecord(..) , ImportProvenance(..) , Imports(..) - , primImports + , nullImports , Exports(..) , nullExports , Env @@ -115,26 +115,6 @@ nullImports = Imports M.empty M.empty M.empty M.empty M.empty M.empty S.empty S.empty M.empty -- | --- An 'Imports' value with imports for the `Prim` module. --- -primImports :: Imports -primImports = - nullImports - { importedTypes = M.fromList $ mkEntries `concatMap` M.keys primTypes - , importedTypeClasses = M.fromList $ mkEntries `concatMap` M.keys primClasses - , importedKinds = M.fromList $ mkEntries `concatMap` S.toList primKinds - } - where - mkEntries :: Qualified a -> [(Qualified a, [ImportRecord a])] - mkEntries fullName@(Qualified _ name) = - [ (fullName, [ImportRecord fullName primModuleName Prim]) - , (Qualified Nothing name, [ImportRecord fullName primModuleName Prim]) - ] - -primModuleName :: ModuleName -primModuleName = ModuleName [ProperName "Prim"] - --- | -- The exported declarations from a module. -- data Exports = Exports @@ -216,7 +196,7 @@ -- | Environment which only contains the Prim module. primEnv :: Env primEnv = M.singleton - primModuleName + (ModuleName [ProperName "Prim"]) (internalModuleSourceSpan "", nullImports, primExports) -- | diff --git a/src/Language/PureScript/Sugar/Names/Exports.hs b/src/Language/PureScript/Sugar/Names/Exports.hs --- a/src/Language/PureScript/Sugar/Names/Exports.hs +++ b/src/Language/PureScript/Sugar/Names/Exports.hs @@ -27,34 +27,34 @@ -- findExportable :: forall m. (MonadError MultipleErrors m) => Module -> m Exports findExportable (Module _ _ mn ds _) = - rethrow (addHint (ErrorInModule mn)) $ foldM updateExports nullExports ds + rethrow (addHint (ErrorInModule mn)) $ foldM updateExports' nullExports ds where + updateExports' :: Exports -> Declaration -> m Exports + updateExports' exps decl = rethrowWithPosition (declSourceSpan decl) $ updateExports exps decl + updateExports :: Exports -> Declaration -> m Exports - updateExports exps (TypeClassDeclaration tcn _ _ _ ds') = do - exps' <- exportTypeClass Internal exps tcn mn + updateExports exps (TypeClassDeclaration (ss, _) tcn _ _ _ ds') = do + exps' <- rethrowWithPosition ss $ exportTypeClass Internal exps tcn mn foldM go exps' ds' where - go exps'' (TypeDeclaration name _) = exportValue exps'' name mn - go exps'' (PositionedDeclaration pos _ d) = rethrowWithPosition pos $ go exps'' d + go exps'' (TypeDeclaration (ss', _) name _) = rethrowWithPosition ss' $ exportValue exps'' name mn go _ _ = internalError "Invalid declaration in TypeClassDeclaration" - updateExports exps (DataDeclaration _ tn _ dcs) = + updateExports exps (DataDeclaration _ _ tn _ dcs) = exportType Internal exps tn (map fst dcs) mn - updateExports exps (TypeSynonymDeclaration tn _ _) = + updateExports exps (TypeSynonymDeclaration _ tn _ _) = exportType Internal exps tn [] mn - updateExports exps (ExternDataDeclaration tn _) = + updateExports exps (ExternDataDeclaration _ tn _) = exportType Internal exps tn [] mn - updateExports exps (ValueDeclaration name _ _ _) = + updateExports exps (ValueDeclaration _ name _ _ _) = exportValue exps name mn - updateExports exps (ValueFixityDeclaration _ _ op) = + updateExports exps (ValueFixityDeclaration _ _ _ op) = exportValueOp exps op mn - updateExports exps (TypeFixityDeclaration _ _ op) = + updateExports exps (TypeFixityDeclaration _ _ _ op) = exportTypeOp exps op mn - updateExports exps (ExternDeclaration name _) = + updateExports exps (ExternDeclaration _ name _) = exportValue exps name mn - updateExports exps (ExternKindDeclaration pn) = + updateExports exps (ExternKindDeclaration _ pn) = exportKind exps pn mn - updateExports exps (PositionedDeclaration pos _ d) = - rethrowWithPosition pos $ updateExports exps d updateExports exps _ = return exps -- | @@ -84,9 +84,7 @@ -- `DeclarationRef` for an explicit export. When the ref refers to another -- module, export anything from the imports that matches for that module. elaborateModuleExports :: Exports -> DeclarationRef -> m Exports - elaborateModuleExports result (PositionedDeclarationRef pos _ r) = - warnAndRethrowWithPosition pos $ elaborateModuleExports result r - elaborateModuleExports result (ModuleRef name) | name == mn = do + elaborateModuleExports result (ModuleRef _ name) | name == mn = do let types' = exportedTypes result `M.union` exportedTypes exps let typeOps' = exportedTypeOps result `M.union` exportedTypeOps exps let classes' = exportedTypeClasses result `M.union` exportedTypeClasses exps @@ -101,10 +99,10 @@ , exportedValueOps = valueOps' , exportedKinds = kinds' } - elaborateModuleExports result (ModuleRef name) = do + elaborateModuleExports result (ModuleRef ss' name) = do let isPseudo = isPseudoModule name when (not isPseudo && not (isImportedModule name)) - . throwError . errorMessage . UnknownExport $ ModName name + . throwError . errorMessage' ss' . UnknownExport $ ModName name reTypes <- extract isPseudo name TyName (importedTypes imps) reTypeOps <- extract isPseudo name TyOpName (importedTypeOps imps) reDctors <- extract isPseudo name DctorName (importedDataConstructors imps) @@ -270,21 +268,19 @@ -- listing for the last ref would be used. combineTypeRefs :: [DeclarationRef] -> [DeclarationRef] combineTypeRefs - = fmap (uncurry TypeRef) - . map (foldr1 $ \(tc, dcs1) (_, dcs2) -> (tc, liftM2 (++) dcs1 dcs2)) - . groupBy ((==) `on` fst) - . sortBy (compare `on` fst) - . mapMaybe getTypeRef + = fmap (\(ss', (tc, dcs)) -> TypeRef ss' tc dcs) + . fmap (foldr1 $ \(ss, (tc, dcs1)) (_, (_, dcs2)) -> (ss, (tc, liftM2 (++) dcs1 dcs2))) + . groupBy ((==) `on` (fst . snd)) + . sortBy (compare `on` (fst . snd)) + . mapMaybe (\ref -> (declRefSourceSpan ref,) <$> getTypeRef ref) filterTypes :: M.Map (ProperName 'TypeName) ([ProperName 'ConstructorName], ModuleName) -> DeclarationRef -> m (M.Map (ProperName 'TypeName) ([ProperName 'ConstructorName], ModuleName)) - filterTypes result (PositionedDeclarationRef pos _ r) = - rethrowWithPosition pos $ filterTypes result r - filterTypes result (TypeRef name expDcons) = + filterTypes result (TypeRef ss name expDcons) = case name `M.lookup` exportedTypes exps of - Nothing -> throwError . errorMessage . UnknownExport $ TyName name + Nothing -> throwError . errorMessage' ss . UnknownExport $ TyName name Just (dcons, _) -> do let expDcons' = fromMaybe dcons expDcons traverse_ (checkDcon name dcons) expDcons' @@ -299,8 +295,8 @@ -> ProperName 'ConstructorName -> m () checkDcon tcon dcons dcon = - unless (dcon `elem` dcons) $ - throwError . errorMessage $ UnknownExportDataConstructor tcon dcon + unless (dcon `elem` dcons) . + throwError . errorMessage' ss $ UnknownExportDataConstructor tcon dcon filterTypes result _ = return result filterExport @@ -311,12 +307,10 @@ -> M.Map a ModuleName -> DeclarationRef -> m (M.Map a ModuleName) - filterExport toName get fromExps result (PositionedDeclarationRef pos _ r) = - rethrowWithPosition pos $ filterExport toName get fromExps result r filterExport toName get fromExps result ref | Just name <- get ref = case name `M.lookup` fromExps exps of -- TODO: I'm not sure if we actually need to check mn == mn' here -gb Just mn' | mn == mn' -> return $ M.insert name mn result - _ -> throwError . errorMessage . UnknownExport $ toName name + _ -> throwError . errorMessage' (declRefSourceSpan ref) . UnknownExport $ toName name filterExport _ _ _ result _ = return result diff --git a/src/Language/PureScript/Sugar/Names/Imports.hs b/src/Language/PureScript/Sugar/Names/Imports.hs --- a/src/Language/PureScript/Sugar/Names/Imports.hs +++ b/src/Language/PureScript/Sugar/Names/Imports.hs @@ -21,7 +21,7 @@ import Language.PureScript.Names import Language.PureScript.Sugar.Names.Env -type ImportDef = (Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName) +type ImportDef = (SourceSpan, ImportDeclarationType, Maybe ModuleName) -- | -- Finds the imports within a module, mapping the imported module name to an optional set of @@ -30,13 +30,12 @@ findImports :: [Declaration] -> M.Map ModuleName [ImportDef] -findImports = foldl (go Nothing) M.empty +findImports = foldr go M.empty where - go pos result (ImportDeclaration mn typ qual) = + go (ImportDeclaration (pos, _) mn typ qual) result = let imp = (pos, typ, qual) in M.insert mn (maybe [imp] (imp :) (mn `M.lookup` result)) result - go _ result (PositionedDeclaration pos _ d) = go (Just pos) result d - go _ result _ = result + go _ result = result -- | -- Constructs a set of imports for a module. @@ -51,9 +50,9 @@ rethrow (addHint (ErrorInModule currentModule)) $ do let imports = findImports decls imports' = M.map (map (\(ss', dt, mmn) -> (ss', Just dt, mmn))) imports - scope = M.insert currentModule [(Nothing, Nothing, Nothing)] imports' + scope = M.insert currentModule [(internalModuleSourceSpan "", Nothing, Nothing)] imports' (Module ss coms currentModule decls exps,) <$> - foldM (resolveModuleImport env) primImports (M.toList scope) + foldM (resolveModuleImport env) nullImports (M.toList scope) -- | Constructs a set of imports for a single module import. resolveModuleImport @@ -61,17 +60,17 @@ . MonadError MultipleErrors m => Env -> Imports - -> (ModuleName, [(Maybe SourceSpan, Maybe ImportDeclarationType, Maybe ModuleName)]) + -> (ModuleName, [(SourceSpan, Maybe ImportDeclarationType, Maybe ModuleName)]) -> m Imports resolveModuleImport env ie (mn, imps) = foldM go ie imps where go :: Imports - -> (Maybe SourceSpan, Maybe ImportDeclarationType, Maybe ModuleName) + -> (SourceSpan, Maybe ImportDeclarationType, Maybe ModuleName) -> m Imports - go ie' (pos, typ, impQual) = do + go ie' (ss, typ, impQual) = do modExports <- - positioned $ maybe - (throwError . errorMessage . UnknownName . Qualified Nothing $ ModName mn) + maybe + (throwError . errorMessage' ss . UnknownName . Qualified Nothing $ ModName mn) (return . envModuleExports) (mn `M.lookup` env) let impModules = importedModules ie' @@ -79,11 +78,7 @@ ie'' = ie' { importedModules = maybe (S.insert mn impModules) (const impModules) impQual , importedQualModules = maybe qualModules (`S.insert` qualModules) impQual } - positioned $ resolveImport mn modExports ie'' impQual typ - where - positioned err = case pos of - Nothing -> err - Just pos' -> rethrowWithPosition pos' err + resolveImport mn modExports ie'' impQual ss typ -- | -- Extends the local environment for a module by resolving an import of another module. @@ -95,67 +90,68 @@ -> Exports -> Imports -> Maybe ModuleName + -> SourceSpan -> Maybe ImportDeclarationType -> m Imports resolveImport importModule exps imps impQual = resolveByType where - resolveByType :: Maybe ImportDeclarationType -> m Imports - resolveByType Nothing = - importAll (importRef Local) - resolveByType (Just Implicit) = - importAll (importRef FromImplicit) - resolveByType (Just (Explicit refs)) = + resolveByType :: SourceSpan -> Maybe ImportDeclarationType -> m Imports + resolveByType ss Nothing = + importAll ss (importRef Local) + resolveByType ss (Just Implicit) = + importAll ss (importRef FromImplicit) + resolveByType _ (Just (Explicit refs)) = checkRefs False refs >> foldM (importRef FromExplicit) imps refs - resolveByType (Just (Hiding refs)) = - checkRefs True refs >> importAll (importNonHidden refs) + resolveByType ss (Just (Hiding refs)) = + checkRefs True refs >> importAll ss (importNonHidden refs) -- Check that a 'DeclarationRef' refers to an importable symbol checkRefs :: Bool -> [DeclarationRef] -> m () checkRefs isHiding = traverse_ check where - check (PositionedDeclarationRef pos _ r) = - rethrowWithPosition pos $ check r - check (ValueRef name) = - checkImportExists IdentName (exportedValues exps) name - check (ValueOpRef op) = - checkImportExists ValOpName (exportedValueOps exps) op - check (TypeRef name dctors) = do - checkImportExists TyName (exportedTypes exps) name + check (ValueRef ss name) = + checkImportExists ss IdentName (exportedValues exps) name + check (ValueOpRef ss op) = + checkImportExists ss ValOpName (exportedValueOps exps) op + check (TypeRef ss name dctors) = do + checkImportExists ss TyName (exportedTypes exps) name let (allDctors, _) = allExportedDataConstructors name - for_ dctors $ traverse_ (checkDctorExists name allDctors) - check (TypeOpRef name) = - checkImportExists TyOpName (exportedTypeOps exps) name - check (TypeClassRef name) = - checkImportExists TyClassName (exportedTypeClasses exps) name - check (ModuleRef name) | isHiding = - throwError . errorMessage $ ImportHidingModule name - check (KindRef name) = do - checkImportExists KiName (exportedKinds exps) name + for_ dctors $ traverse_ (checkDctorExists ss name allDctors) + check (TypeOpRef ss name) = + checkImportExists ss TyOpName (exportedTypeOps exps) name + check (TypeClassRef ss name) = + checkImportExists ss TyClassName (exportedTypeClasses exps) name + check (ModuleRef ss name) | isHiding = + throwError . errorMessage' ss $ ImportHidingModule name + check (KindRef ss name) = + checkImportExists ss KiName (exportedKinds exps) name check r = internalError $ "Invalid argument to checkRefs: " ++ show r -- Check that an explicitly imported item exists in the module it is being imported from checkImportExists :: Ord a - => (a -> Name) + => SourceSpan + -> (a -> Name) -> M.Map a b -> a -> m () - checkImportExists toName exports item + checkImportExists ss toName exports item = when (item `M.notMember` exports) - . throwError . errorMessage + . throwError . errorMessage' ss $ UnknownImport importModule (toName item) -- Ensure that an explicitly imported data constructor exists for the type it is being imported -- from checkDctorExists - :: ProperName 'TypeName + :: SourceSpan + -> ProperName 'TypeName -> [ProperName 'ConstructorName] -> ProperName 'ConstructorName -> m () - checkDctorExists tcon exports dctor + checkDctorExists ss tcon exports dctor = when (dctor `notElem` exports) - . throwError . errorMessage + . throwError . errorMessage' ss $ UnknownImportDataConstructor importModule tcon dctor importNonHidden :: [DeclarationRef] -> Imports -> DeclarationRef -> m Imports @@ -164,51 +160,47 @@ where -- TODO: rework this to be not confusing isHidden :: DeclarationRef -> Bool - isHidden ref'@(TypeRef _ _) = foldl (checkTypeRef ref') False hidden + isHidden ref'@TypeRef{} = foldl (checkTypeRef ref') False hidden isHidden ref' = ref' `elem` hidden checkTypeRef :: DeclarationRef -> Bool -> DeclarationRef -> Bool checkTypeRef _ True _ = True - checkTypeRef r acc (PositionedDeclarationRef _ _ h) = checkTypeRef r acc h - checkTypeRef (TypeRef _ Nothing) acc (TypeRef _ (Just _)) = acc - checkTypeRef (TypeRef name (Just dctor)) _ (TypeRef name' (Just dctor')) = name == name' && dctor == dctor' - checkTypeRef (TypeRef name _) _ (TypeRef name' Nothing) = name == name' - checkTypeRef (PositionedDeclarationRef _ _ r) acc hiddenRef = checkTypeRef r acc hiddenRef + checkTypeRef (TypeRef _ _ Nothing) acc (TypeRef _ _ (Just _)) = acc + checkTypeRef (TypeRef _ name (Just dctor)) _ (TypeRef _ name' (Just dctor')) = name == name' && dctor == dctor' + checkTypeRef (TypeRef _ name _) _ (TypeRef _ name' Nothing) = name == name' checkTypeRef _ acc _ = acc -- Import all symbols - importAll :: (Imports -> DeclarationRef -> m Imports) -> m Imports - importAll importer = - foldM (\m (name, (dctors, _)) -> importer m (TypeRef name (Just dctors))) imps (M.toList (exportedTypes exps)) - >>= flip (foldM (\m (name, _) -> importer m (TypeOpRef name))) (M.toList (exportedTypeOps exps)) - >>= flip (foldM (\m (name, _) -> importer m (ValueRef name))) (M.toList (exportedValues exps)) - >>= flip (foldM (\m (name, _) -> importer m (ValueOpRef name))) (M.toList (exportedValueOps exps)) - >>= flip (foldM (\m (name, _) -> importer m (TypeClassRef name))) (M.toList (exportedTypeClasses exps)) - >>= flip (foldM (\m (name, _) -> importer m (KindRef name))) (M.toList (exportedKinds exps)) + importAll :: SourceSpan -> (Imports -> DeclarationRef -> m Imports) -> m Imports + importAll ss importer = + foldM (\m (name, (dctors, _)) -> importer m (TypeRef ss name (Just dctors))) imps (M.toList (exportedTypes exps)) + >>= flip (foldM (\m (name, _) -> importer m (TypeOpRef ss name))) (M.toList (exportedTypeOps exps)) + >>= flip (foldM (\m (name, _) -> importer m (ValueRef ss name))) (M.toList (exportedValues exps)) + >>= flip (foldM (\m (name, _) -> importer m (ValueOpRef ss name))) (M.toList (exportedValueOps exps)) + >>= flip (foldM (\m (name, _) -> importer m (TypeClassRef ss name))) (M.toList (exportedTypeClasses exps)) + >>= flip (foldM (\m (name, _) -> importer m (KindRef ss name))) (M.toList (exportedKinds exps)) importRef :: ImportProvenance -> Imports -> DeclarationRef -> m Imports - importRef prov imp (PositionedDeclarationRef pos _ r) = - rethrowWithPosition pos $ importRef prov imp r - importRef prov imp (ValueRef name) = do + importRef prov imp (ValueRef _ name) = do let values' = updateImports (importedValues imp) (exportedValues exps) id name prov return $ imp { importedValues = values' } - importRef prov imp (ValueOpRef name) = do + importRef prov imp (ValueOpRef _ name) = do let valueOps' = updateImports (importedValueOps imp) (exportedValueOps exps) id name prov return $ imp { importedValueOps = valueOps' } - importRef prov imp (TypeRef name dctors) = do + importRef prov imp (TypeRef ss name dctors) = do let types' = updateImports (importedTypes imp) (exportedTypes exps) snd name prov let (dctorNames, mn) = allExportedDataConstructors name dctorLookup :: M.Map (ProperName 'ConstructorName) ModuleName dctorLookup = M.fromList $ map (, mn) dctorNames - traverse_ (traverse_ $ checkDctorExists name dctorNames) dctors + traverse_ (traverse_ $ checkDctorExists ss name dctorNames) dctors let dctors' = foldl (\m d -> updateImports m dctorLookup id d prov) (importedDataConstructors imp) (fromMaybe dctorNames dctors) return $ imp { importedTypes = types', importedDataConstructors = dctors' } - importRef prov imp (TypeOpRef name) = do + importRef prov imp (TypeOpRef _ name) = do let ops' = updateImports (importedTypeOps imp) (exportedTypeOps exps) id name prov return $ imp { importedTypeOps = ops' } - importRef prov imp (TypeClassRef name) = do + importRef prov imp (TypeClassRef _ name) = do let typeClasses' = updateImports (importedTypeClasses imp) (exportedTypeClasses exps) id name prov return $ imp { importedTypeClasses = typeClasses' } - importRef prov imp (KindRef name) = do + importRef prov imp (KindRef _ name) = do let kinds' = updateImports (importedKinds imp) (exportedKinds exps) id name prov return $ imp { importedKinds = kinds' } importRef _ _ TypeInstanceRef{} = internalError "TypeInstanceRef in importRef" diff --git a/src/Language/PureScript/Sugar/ObjectWildcards.hs b/src/Language/PureScript/Sugar/ObjectWildcards.hs --- a/src/Language/PureScript/Sugar/ObjectWildcards.hs +++ b/src/Language/PureScript/Sugar/ObjectWildcards.hs @@ -26,8 +26,7 @@ desugarObjectConstructors (Module ss coms mn ds exts) = Module ss coms mn <$> mapM desugarDecl ds <*> pure exts desugarDecl :: forall m. (MonadSupply m, MonadError MultipleErrors m) => Declaration -> m Declaration -desugarDecl (PositionedDeclaration pos com d) = rethrowWithPosition pos $ PositionedDeclaration pos com <$> desugarDecl d -desugarDecl other = fn other +desugarDecl d = rethrowWithPosition (declSourceSpan d) $ fn d where (fn, _, _) = everywhereOnValuesTopDownM return desugarExpr return @@ -70,7 +69,7 @@ then Abs (VarBinder val) <$> wrapLambda (buildUpdates valExpr) ps else wrapLambda (buildLet val . buildUpdates valExpr) ps where - buildLet val = Let [ValueDeclaration val Public [] [MkUnguarded obj]] + buildLet val = Let [ValueDeclaration (declSourceSpan d, []) val Public [] [MkUnguarded obj]] -- recursively build up the nested `ObjectUpdate` expressions buildUpdates :: Expr -> PathTree Expr -> Expr diff --git a/src/Language/PureScript/Sugar/Operators.hs b/src/Language/PureScript/Sugar/Operators.hs --- a/src/Language/PureScript/Sugar/Operators.hs +++ b/src/Language/PureScript/Sugar/Operators.hs @@ -116,16 +116,12 @@ (f', _, _, _, _) = everywhereWithContextOnValuesM Nothing - (\pos -> uncurry goDecl <=< goDecl' pos) + (\_ d -> (Just (declSourceSpan d),) <$> goDecl' d) (\pos -> uncurry goExpr <=< goExpr' pos) (\pos -> uncurry goBinder <=< goBinder' pos) defS defS - goDecl :: Maybe SourceSpan -> Declaration -> m (Maybe SourceSpan, Declaration) - goDecl _ d@(PositionedDeclaration pos _ _) = return (Just pos, d) - goDecl pos other = return (pos, other) - goExpr :: Maybe SourceSpan -> Expr -> m (Maybe SourceSpan, Expr) goExpr _ e@(PositionedValue pos _ _) = return (Just pos, e) goExpr pos (Op op) = @@ -180,7 +176,7 @@ where (f, _, _) = everywhereOnValuesTopDownM - (decontextify goDecl) + goDecl (goExpr <=< decontextify goExpr') (goBinder <=< decontextify goBinder') @@ -203,7 +199,7 @@ where (f, _, _) = everywhereOnValues - (decontextify goDecl) + (runIdentity . goDecl) (goExpr . decontextify goExpr') (goBinder . decontextify goBinder') @@ -258,11 +254,10 @@ collectFixities (Module _ _ moduleName ds _) = concatMap collect ds where collect :: Declaration -> [Either ValueFixityRecord TypeFixityRecord] - collect (PositionedDeclaration pos _ (ValueFixityDeclaration fixity name op)) = - [Left (Qualified (Just moduleName) op, pos, fixity, name)] - collect (PositionedDeclaration pos _ (TypeFixityDeclaration fixity name op)) = - [Right (Qualified (Just moduleName) op, pos, fixity, name)] - collect FixityDeclaration{} = internalError "Fixity without srcpos info" + collect (ValueFixityDeclaration (ss, _) fixity name op) = + [Left (Qualified (Just moduleName) op, ss, fixity, name)] + collect (TypeFixityDeclaration (ss, _) fixity name op) = + [Right (Qualified (Just moduleName) op, ss, fixity, name)] collect _ = [] ensureNoDuplicates @@ -294,9 +289,9 @@ :: forall m . Monad m => (Maybe SourceSpan -> Type -> m Type) - -> ( Maybe SourceSpan -> Declaration -> m (Maybe SourceSpan, Declaration) - , Maybe SourceSpan -> Expr -> m (Maybe SourceSpan, Expr) - , Maybe SourceSpan -> Binder -> m (Maybe SourceSpan, Binder) + -> ( Declaration -> m Declaration + , Maybe SourceSpan -> Expr -> m (Maybe SourceSpan, Expr) + , Maybe SourceSpan -> Binder -> m (Maybe SourceSpan, Binder) ) updateTypes goType = (goDecl, goExpr, goBinder) where @@ -304,29 +299,28 @@ goType' :: Maybe SourceSpan -> Type -> m Type goType' = everywhereOnTypesM . goType - goDecl :: Maybe SourceSpan -> Declaration -> m (Maybe SourceSpan, Declaration) - goDecl _ d@(PositionedDeclaration pos _ _) = return (Just pos, d) - goDecl pos (DataDeclaration ddt name args dctors) = do - dctors' <- traverse (sndM (traverse (goType' pos))) dctors - return (pos, DataDeclaration ddt name args dctors') - goDecl pos (ExternDeclaration name ty) = do - ty' <- goType' pos ty - return (pos, ExternDeclaration name ty') - goDecl pos (TypeClassDeclaration name args implies deps decls) = do - implies' <- traverse (overConstraintArgs (traverse (goType' pos))) implies - return (pos, TypeClassDeclaration name args implies' deps decls) - goDecl pos (TypeInstanceDeclaration name cs className tys impls) = do - cs' <- traverse (overConstraintArgs (traverse (goType' pos))) cs - tys' <- traverse (goType' pos) tys - return (pos, TypeInstanceDeclaration name cs' className tys' impls) - goDecl pos (TypeSynonymDeclaration name args ty) = do - ty' <- goType' pos ty - return (pos, TypeSynonymDeclaration name args ty') - goDecl pos (TypeDeclaration expr ty) = do - ty' <- goType' pos ty - return (pos, TypeDeclaration expr ty') - goDecl pos other = return (pos, other) + goType'' :: SourceSpan -> Type -> m Type + goType'' = goType' . Just + goDecl :: Declaration -> m Declaration + goDecl (DataDeclaration sa@(ss, _) ddt name args dctors) = + DataDeclaration sa ddt name args <$> traverse (sndM (traverse (goType'' ss))) dctors + goDecl (ExternDeclaration sa@(ss, _) name ty) = + ExternDeclaration sa name <$> goType'' ss ty + goDecl (TypeClassDeclaration sa@(ss, _) name args implies deps decls) = do + implies' <- traverse (overConstraintArgs (traverse (goType'' ss))) implies + return $ TypeClassDeclaration sa name args implies' deps decls + goDecl (TypeInstanceDeclaration sa@(ss, _) name cs className tys impls) = do + cs' <- traverse (overConstraintArgs (traverse (goType'' ss))) cs + tys' <- traverse (goType'' ss) tys + return $ TypeInstanceDeclaration sa name cs' className tys' impls + goDecl (TypeSynonymDeclaration sa@(ss, _) name args ty) = + TypeSynonymDeclaration sa name args <$> goType'' ss ty + goDecl (TypeDeclaration sa@(ss, _) expr ty) = + TypeDeclaration sa expr <$> goType'' ss ty + goDecl other = + return other + goExpr :: Maybe SourceSpan -> Expr -> m (Maybe SourceSpan, Expr) goExpr _ e@(PositionedValue pos _ _) = return (Just pos, e) goExpr pos (TypeClassDictionary (Constraint name tys info) dicts hints) = do @@ -367,23 +361,21 @@ where checkRef :: DeclarationRef -> m () - checkRef (PositionedDeclarationRef pos _ d) = - rethrowWithPosition pos $ checkRef d - checkRef dr@(ValueOpRef op) = + checkRef dr@(ValueOpRef ss' op) = for_ (getValueOpAlias op) $ \case Left ident -> - unless (ValueRef ident `elem` exps) - . throwError . errorMessage - $ TransitiveExportError dr [ValueRef ident] + unless (ValueRef ss' ident `elem` exps) + . throwError . errorMessage' ss' + $ TransitiveExportError dr [ValueRef ss' ident] Right ctor -> unless (anyTypeRef (maybe False (elem ctor) . snd)) - . throwError . errorMessage + . throwError . errorMessage' ss $ TransitiveDctorExportError dr ctor - checkRef dr@(TypeOpRef op) = + checkRef dr@(TypeOpRef ss' op) = for_ (getTypeOpAlias op) $ \ty -> unless (anyTypeRef ((== ty) . fst)) - . throwError . errorMessage - $ TransitiveExportError dr [TypeRef ty Nothing] + . throwError . errorMessage' ss' + $ TransitiveExportError dr [TypeRef ss' ty Nothing] checkRef _ = return () -- Finds the name associated with a type operator when that type is also diff --git a/src/Language/PureScript/Sugar/TypeClasses.hs b/src/Language/PureScript/Sugar/TypeClasses.hs --- a/src/Language/PureScript/Sugar/TypeClasses.hs +++ b/src/Language/PureScript/Sugar/TypeClasses.hs @@ -176,30 +176,27 @@ -> Desugar m (Maybe DeclarationRef, [Declaration]) desugarDecl mn exps = go where - go d@(TypeClassDeclaration name args implies deps members) = do + go d@(TypeClassDeclaration sa name args implies deps members) = do modify (M.insert (mn, name) (makeTypeClassData args (map memberToNameAndType members) implies deps)) - return (Nothing, d : typeClassDictionaryDeclaration name args implies members : map (typeClassMemberToDictionaryAccessor mn name args) members) - go (TypeInstanceDeclaration _ _ _ _ DerivedInstance) = internalError "Derived instanced should have been desugared" - go d@(TypeInstanceDeclaration name deps className tys (ExplicitInstance members)) = do + return (Nothing, d : typeClassDictionaryDeclaration sa name args implies members : map (typeClassMemberToDictionaryAccessor mn name args) members) + go (TypeInstanceDeclaration _ _ _ _ _ DerivedInstance) = internalError "Derived instanced should have been desugared" + go d@(TypeInstanceDeclaration sa name deps className tys (ExplicitInstance members)) = do desugared <- desugarCases members - dictDecl <- typeInstanceDictionaryDeclaration name mn deps className tys desugared + dictDecl <- typeInstanceDictionaryDeclaration sa name mn deps className tys desugared return (expRef name className tys, [d, dictDecl]) - go d@(TypeInstanceDeclaration name deps className tys (NewtypeInstanceWithDictionary dict)) = do + go d@(TypeInstanceDeclaration sa name deps className tys (NewtypeInstanceWithDictionary dict)) = do let dictTy = foldl TypeApp (TypeConstructor (fmap coerceProperName className)) tys constrainedTy = quantify (foldr ConstrainedType dictTy deps) - return (expRef name className tys, [d, ValueDeclaration name Private [] [MkUnguarded (TypedValue True dict constrainedTy)]]) - go (PositionedDeclaration pos com d) = do - (dr, ds) <- rethrowWithPosition pos $ desugarDecl mn exps d - return (dr, map (PositionedDeclaration pos com) ds) + return (expRef name className tys, [d, ValueDeclaration sa name Private [] [MkUnguarded (TypedValue True dict constrainedTy)]]) go other = return (Nothing, [other]) expRef :: Ident -> Qualified (ProperName 'ClassName) -> [Type] -> Maybe DeclarationRef expRef name className tys - | isExportedClass className && all isExportedType (getConstructors `concatMap` tys) = Just $ TypeInstanceRef name + | isExportedClass className && all isExportedType (getConstructors `concatMap` tys) = Just $ TypeInstanceRef genSpan name | otherwise = Nothing isExportedClass :: Qualified (ProperName 'ClassName) -> Bool - isExportedClass = isExported (elem . TypeClassRef) + isExportedClass = isExported (elem . TypeClassRef genSpan) isExportedType :: Qualified (ProperName 'TypeName) -> Bool isExportedType = isExported $ \pn -> isJust . find (matchesTypeRef pn) @@ -212,7 +209,7 @@ isExported _ _ = internalError "Names should have been qualified in name desugaring" matchesTypeRef :: ProperName 'TypeName -> DeclarationRef -> Bool - matchesTypeRef pn (TypeRef pn' _) = pn == pn' + matchesTypeRef pn (TypeRef _ pn' _) = pn == pn' matchesTypeRef _ _ = False getConstructors :: Type -> [Qualified (ProperName 'TypeName)] @@ -221,25 +218,28 @@ getConstructor (TypeConstructor tcname) = [tcname] getConstructor _ = [] + genSpan :: SourceSpan + genSpan = internalModuleSourceSpan "" + memberToNameAndType :: Declaration -> (Ident, Type) -memberToNameAndType (TypeDeclaration ident ty) = (ident, ty) -memberToNameAndType (PositionedDeclaration _ _ d) = memberToNameAndType d +memberToNameAndType (TypeDeclaration _ ident ty) = (ident, ty) memberToNameAndType _ = internalError "Invalid declaration in type class definition" typeClassDictionaryDeclaration - :: ProperName 'ClassName + :: SourceAnn + -> ProperName 'ClassName -> [(Text, Maybe Kind)] -> [Constraint] -> [Declaration] -> Declaration -typeClassDictionaryDeclaration name args implies members = +typeClassDictionaryDeclaration sa name args implies members = let superclassTypes = superClassDictionaryNames implies `zip` [ function unit (foldl TypeApp (TypeConstructor (fmap coerceProperName superclass)) tyArgs) | (Constraint superclass tyArgs _) <- implies ] members' = map (first runIdent . memberToNameAndType) members mtys = members' ++ superclassTypes - in TypeSynonymDeclaration (coerceProperName name) args (TypeApp tyRecord $ rowFromList (map (first (Label . mkString)) mtys, REmpty)) + in TypeSynonymDeclaration sa (coerceProperName name) args (TypeApp tyRecord $ rowFromList (map (first (Label . mkString)) mtys, REmpty)) typeClassMemberToDictionaryAccessor :: ModuleName @@ -247,15 +247,13 @@ -> [(Text, Maybe Kind)] -> Declaration -> Declaration -typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration ident ty) = +typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration sa ident ty) = let className = Qualified (Just mn) name - in ValueDeclaration ident Private [] $ + in ValueDeclaration sa ident Private [] $ [MkUnguarded ( TypedValue False (TypeClassDictionaryAccessor className ident) $ moveQuantifiersToFront (quantify (ConstrainedType (Constraint className (map (TypeVar . fst) args) Nothing) ty)) )] -typeClassMemberToDictionaryAccessor mn name args (PositionedDeclaration pos com d) = - PositionedDeclaration pos com $ typeClassMemberToDictionaryAccessor mn name args d typeClassMemberToDictionaryAccessor _ _ _ _ = internalError "Invalid declaration in type class definition" unit :: Type @@ -264,14 +262,15 @@ typeInstanceDictionaryDeclaration :: forall m . (MonadSupply m, MonadError MultipleErrors m) - => Ident + => SourceAnn + -> Ident -> ModuleName -> [Constraint] -> Qualified (ProperName 'ClassName) -> [Type] -> [Declaration] -> Desugar m Declaration -typeInstanceDictionaryDeclaration name mn deps className tys decls = +typeInstanceDictionaryDeclaration sa name mn deps className tys decls = rethrow (addHint (ErrorInInstance className tys)) $ do m <- get @@ -302,30 +301,25 @@ dictTy = foldl TypeApp (TypeConstructor (fmap coerceProperName className)) tys constrainedTy = quantify (foldr ConstrainedType dictTy deps) dict = TypeClassDictionaryConstructorApp className props - result = ValueDeclaration name Private [] [MkUnguarded (TypedValue True dict constrainedTy)] + result = ValueDeclaration sa name Private [] [MkUnguarded (TypedValue True dict constrainedTy)] return result where declName :: Declaration -> Maybe Ident - declName (PositionedDeclaration _ _ d) = declName d - declName (ValueDeclaration ident _ _ _) = Just ident - declName (TypeDeclaration ident _) = Just ident + declName (ValueDeclaration _ ident _ _ _) = Just ident + declName (TypeDeclaration _ ident _) = Just ident declName _ = Nothing memberToValue :: [(Ident, Type)] -> Declaration -> Desugar m Expr - memberToValue tys' (ValueDeclaration ident _ [] [MkUnguarded val]) = do + memberToValue tys' (ValueDeclaration _ ident _ [] [MkUnguarded val]) = do _ <- maybe (throwError . errorMessage $ ExtraneousClassMember ident className) return $ lookup ident tys' return val - memberToValue tys' (PositionedDeclaration pos com d) = rethrowWithPosition pos $ do - val <- memberToValue tys' d - return (PositionedValue pos com val) memberToValue _ _ = internalError "Invalid declaration in type instance definition" typeClassMemberName :: Declaration -> Text -typeClassMemberName (TypeDeclaration ident _) = runIdent ident -typeClassMemberName (ValueDeclaration ident _ _ _) = runIdent ident -typeClassMemberName (PositionedDeclaration _ _ d) = typeClassMemberName d +typeClassMemberName (TypeDeclaration _ ident _) = runIdent ident +typeClassMemberName (ValueDeclaration _ ident _ _ _) = runIdent ident typeClassMemberName _ = internalError "typeClassMemberName: Invalid declaration in type class definition" superClassDictionaryNames :: [Constraint] -> [Text] diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -84,9 +84,8 @@ fromExternsDecl mn' (EDTypeSynonym name args ty) = Just (Qualified (Just mn') name, (args, ty)) fromExternsDecl _ _ = Nothing - fromLocalDecl (TypeSynonymDeclaration name args ty) = do + fromLocalDecl (TypeSynonymDeclaration _ name args ty) = Just (Qualified (Just mn) name, (args, ty)) - fromLocalDecl (PositionedDeclaration _ _ d) = fromLocalDecl d fromLocalDecl _ = Nothing instanceData :: NewtypeDerivedInstances @@ -99,11 +98,10 @@ foldMap (\nm -> NewtypeDerivedInstances mempty (S.singleton (qualify mn' edInstanceClassName, nm))) (extractNewtypeName mn' edInstanceTypes) fromExternsDecl _ _ = mempty - fromLocalDecl (TypeClassDeclaration cl args cons deps _) = + fromLocalDecl (TypeClassDeclaration _ cl args cons deps _) = NewtypeDerivedInstances (M.singleton (mn, cl) (map fst args, cons, deps)) mempty - fromLocalDecl (TypeInstanceDeclaration _ _ cl tys _) = + fromLocalDecl (TypeInstanceDeclaration _ _ _ cl tys _) = foldMap (\nm -> NewtypeDerivedInstances mempty (S.singleton (qualify mn cl, nm))) (extractNewtypeName mn tys) - fromLocalDecl (PositionedDeclaration _ _ d) = fromLocalDecl d fromLocalDecl _ = mempty -- | Takes a declaration, and if the declaration is a deriving TypeInstanceDeclaration, @@ -116,62 +114,61 @@ -> [Declaration] -> Declaration -> m Declaration -deriveInstance mn syns _ ds (TypeInstanceDeclaration nm deps className tys DerivedInstance) +deriveInstance mn syns _ ds (TypeInstanceDeclaration sa@(ss, _) nm deps className tys DerivedInstance) | className == Qualified (Just dataGeneric) (ProperName C.generic) = case tys of [ty] | Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor ty , mn == fromMaybe mn mn' - -> TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveGeneric mn syns ds tyCon args - | otherwise -> throwError . errorMessage $ ExpectedTypeConstructor className tys ty - _ -> throwError . errorMessage $ InvalidDerivedInstance className tys 1 + -> TypeInstanceDeclaration sa nm deps className tys . ExplicitInstance <$> deriveGeneric ss mn syns ds tyCon args + | otherwise -> throwError . errorMessage' ss $ ExpectedTypeConstructor className tys ty + _ -> throwError . errorMessage' ss $ InvalidDerivedInstance className tys 1 | className == Qualified (Just dataEq) (ProperName "Eq") = case tys of [ty] | Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor ty , mn == fromMaybe mn mn' - -> TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveEq mn syns ds tyCon - | otherwise -> throwError . errorMessage $ ExpectedTypeConstructor className tys ty - _ -> throwError . errorMessage $ InvalidDerivedInstance className tys 1 + -> TypeInstanceDeclaration sa 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 dataOrd) (ProperName "Ord") = case tys of [ty] | Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor ty , mn == fromMaybe mn mn' - -> TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveOrd mn syns ds tyCon - | otherwise -> throwError . errorMessage $ ExpectedTypeConstructor className tys ty - _ -> throwError . errorMessage $ InvalidDerivedInstance className tys 1 + -> TypeInstanceDeclaration sa 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 dataFunctor) (ProperName "Functor") = case tys of [ty] | Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor ty , mn == fromMaybe mn mn' - -> TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveFunctor mn syns ds tyCon - | otherwise -> throwError . errorMessage $ ExpectedTypeConstructor className tys ty - _ -> throwError . errorMessage $ InvalidDerivedInstance className tys 1 + -> TypeInstanceDeclaration sa nm deps className tys . ExplicitInstance <$> deriveFunctor ss mn syns ds tyCon + | otherwise -> throwError . errorMessage' ss $ ExpectedTypeConstructor className tys ty + _ -> throwError . errorMessage' ss $ InvalidDerivedInstance className tys 1 | className == Qualified (Just dataNewtype) (ProperName "Newtype") = case tys of [wrappedTy, unwrappedTy] | Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor wrappedTy , mn == fromMaybe mn mn' -> do (inst, actualUnwrappedTy) <- deriveNewtype mn syns ds tyCon args unwrappedTy - return $ TypeInstanceDeclaration nm deps className [wrappedTy, actualUnwrappedTy] (ExplicitInstance inst) - | otherwise -> throwError . errorMessage $ ExpectedTypeConstructor className tys wrappedTy - _ -> throwError . errorMessage $ InvalidDerivedInstance className tys 2 + return $ TypeInstanceDeclaration sa nm deps className [wrappedTy, actualUnwrappedTy] (ExplicitInstance inst) + | otherwise -> throwError . errorMessage' ss $ ExpectedTypeConstructor className tys wrappedTy + _ -> throwError . errorMessage' ss $ InvalidDerivedInstance className tys 2 | className == Qualified (Just dataGenericRep) (ProperName C.generic) = case tys of [actualTy, repTy] | Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor actualTy , mn == fromMaybe mn mn' -> do (inst, inferredRepTy) <- deriveGenericRep mn syns ds tyCon args repTy - return $ TypeInstanceDeclaration nm deps className [actualTy, inferredRepTy] (ExplicitInstance inst) - | otherwise -> throwError . errorMessage $ ExpectedTypeConstructor className tys actualTy - _ -> throwError . errorMessage $ InvalidDerivedInstance className tys 2 - | otherwise = throwError . errorMessage $ CannotDerive className tys -deriveInstance mn syns ndis ds (TypeInstanceDeclaration nm deps className tys NewtypeInstance) = + return $ TypeInstanceDeclaration sa nm deps className [actualTy, inferredRepTy] (ExplicitInstance inst) + | otherwise -> throwError . errorMessage' ss $ ExpectedTypeConstructor className tys actualTy + _ -> throwError . errorMessage' ss $ InvalidDerivedInstance className tys 2 + | otherwise = throwError . errorMessage' ss $ CannotDerive className tys +deriveInstance mn syns ndis ds (TypeInstanceDeclaration sa@(ss, _) nm deps className tys NewtypeInstance) = case tys of _ : _ | Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor (last tys) , mn == fromMaybe mn mn' - -> TypeInstanceDeclaration nm deps className tys . NewtypeInstanceWithDictionary <$> deriveNewtypeInstance mn syns ndis className ds tys tyCon args - | otherwise -> throwError . errorMessage $ ExpectedTypeConstructor className tys (last tys) - _ -> throwError . errorMessage $ InvalidNewtypeInstance className tys -deriveInstance mn syns ndis ds (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> deriveInstance mn syns ndis ds d + -> TypeInstanceDeclaration sa nm deps className tys . NewtypeInstanceWithDictionary <$> deriveNewtypeInstance ss mn syns ndis className ds tys tyCon args + | otherwise -> throwError . errorMessage' ss $ ExpectedTypeConstructor className tys (last tys) + _ -> throwError . errorMessage' ss $ InvalidNewtypeInstance className tys deriveInstance _ _ _ _ e = return e unwrapTypeConstructor :: Type -> Maybe (Qualified (ProperName 'TypeName), [Type]) @@ -186,7 +183,8 @@ deriveNewtypeInstance :: forall m . (MonadError MultipleErrors m, MonadWriter MultipleErrors m) - => ModuleName + => SourceSpan + -> ModuleName -> SynonymMap -> NewtypeDerivedInstances -> Qualified (ProperName 'ClassName) @@ -195,12 +193,12 @@ -> ProperName 'TypeName -> [Type] -> m Expr -deriveNewtypeInstance mn syns ndis className ds tys tyConNm dargs = do +deriveNewtypeInstance ss mn syns ndis className ds tys tyConNm dargs = do verifySuperclasses tyCon <- findTypeDecl tyConNm ds go tyCon where - go (DataDeclaration Newtype _ tyArgNames [(_, [wrapped])]) + go (DataDeclaration _ Newtype _ tyArgNames [(_, [wrapped])]) -- The newtype might not be applied to all type arguments. -- This is okay as long as the newtype wraps something which ends with -- sufficiently many type applications to variables. @@ -214,8 +212,7 @@ do let subst = zipWith (\(name, _) t -> (name, t)) tyArgNames dargs wrapped'' <- replaceAllTypeSynonymsM syns wrapped' return (DeferredDictionary className (init tys ++ [replaceAllTypeVars subst wrapped''])) - go (PositionedDeclaration _ _ d) = go d - go _ = throwError . errorMessage $ InvalidNewtypeInstance className tys + go _ = throwError . errorMessage' ss $ InvalidNewtypeInstance className tys takeReverse :: Int -> [a] -> [a] takeReverse n = take n . reverse @@ -248,8 +245,8 @@ -- be possible, so we warn again. for_ (extractNewtypeName mn tys) $ \nm -> unless ((constraintClass', nm) `S.member` ndiDerivedInstances ndis) $ - tell . errorMessage $ MissingNewtypeSuperclassInstance constraintClass className tys - else tell . errorMessage $ UnverifiableSuperclassInstance constraintClass className tys + tell . errorMessage' ss $ MissingNewtypeSuperclassInstance constraintClass className tys + else tell . errorMessage' ss $ UnverifiableSuperclassInstance constraintClass className tys dataGeneric :: ModuleName dataGeneric = ModuleName [ ProperName "Data", ProperName "Generic" ] @@ -280,24 +277,25 @@ deriveGeneric :: forall m. (MonadError MultipleErrors m, MonadSupply m) - => ModuleName + => SourceSpan + -> ModuleName -> SynonymMap -> [Declaration] -> ProperName 'TypeName -> [Type] -> m [Declaration] -deriveGeneric mn syns ds tyConNm dargs = do +deriveGeneric ss mn syns ds tyConNm dargs = do tyCon <- findTypeDecl tyConNm ds toSpine <- mkSpineFunction tyCon fromSpine <- mkFromSpineFunction tyCon toSignature <- mkSignatureFunction tyCon dargs - return [ ValueDeclaration (Ident C.toSpine) Public [] (unguarded toSpine) - , ValueDeclaration (Ident C.fromSpine) Public [] (unguarded fromSpine) - , ValueDeclaration (Ident C.toSignature) Public [] (unguarded toSignature) + return [ ValueDeclaration (ss, []) (Ident C.toSpine) Public [] (unguarded toSpine) + , ValueDeclaration (ss, []) (Ident C.fromSpine) Public [] (unguarded fromSpine) + , ValueDeclaration (ss, []) (Ident C.toSignature) Public [] (unguarded toSignature) ] where mkSpineFunction :: Declaration -> m Expr - mkSpineFunction (DataDeclaration _ _ _ args) = do + mkSpineFunction (DataDeclaration _ _ _ _ args) = do x <- freshIdent' lamCase x <$> mapM mkCtorClause args where @@ -330,11 +328,10 @@ ) $ fields toSpineFun i _ = lamNull $ App (mkGenVar (Ident C.toSpine)) i - mkSpineFunction (PositionedDeclaration _ _ d) = mkSpineFunction d mkSpineFunction _ = internalError "mkSpineFunction: expected DataDeclaration" mkSignatureFunction :: Declaration -> [Type] -> m Expr - mkSignatureFunction (DataDeclaration _ name tyArgs args) classArgs = lamNull . mkSigProd <$> mapM mkProdClause args + mkSignatureFunction (DataDeclaration _ _ name tyArgs args) classArgs = lamNull . mkSigProd <$> mapM mkProdClause args where mkSigProd :: [Expr] -> Expr mkSigProd = @@ -373,11 +370,10 @@ mkProductSignature typ = lamNull $ App (mkGenVar (Ident C.toSignature)) (TypedValue False (mkGenVar (Ident "anyProxy")) (proxy typ)) instantiate = replaceAllTypeVars (zipWith (\(arg, _) ty -> (arg, ty)) tyArgs classArgs) - mkSignatureFunction (PositionedDeclaration _ _ d) classArgs = mkSignatureFunction d classArgs mkSignatureFunction _ _ = internalError "mkSignatureFunction: expected DataDeclaration" mkFromSpineFunction :: Declaration -> m Expr - mkFromSpineFunction (DataDeclaration _ _ _ args) = do + mkFromSpineFunction (DataDeclaration _ _ _ _ args) = do x <- freshIdent' lamCase x <$> (addCatch <$> mapM mkAlternative args) where @@ -434,7 +430,6 @@ mkRecFun :: [(Label, Type)] -> Expr mkRecFun xs = mkJust $ foldr (lam . labelToIdent . fst) recLiteral xs where recLiteral = Literal . ObjectLiteral $ map (\(l@(Label s), _) -> (s, mkVar $ labelToIdent l)) xs - mkFromSpineFunction (PositionedDeclaration _ _ d) = mkFromSpineFunction d mkFromSpineFunction _ = internalError "mkFromSpineFunction: expected DataDeclaration" -- Helpers @@ -466,31 +461,30 @@ go =<< findTypeDecl tyConNm ds where go :: Declaration -> m ([Declaration], Type) - go (DataDeclaration _ _ args dctors) = do + go (DataDeclaration (ss, _) _ _ args dctors) = do x <- freshIdent "x" (reps, to, from) <- unzip3 <$> traverse makeInst dctors let rep = toRepTy reps inst | null reps = -- If there are no cases, spin - [ ValueDeclaration (Ident "to") Public [] $ unguarded $ + [ ValueDeclaration (ss, []) (Ident "to") Public [] $ unguarded $ lamCase x [ CaseAlternative [NullBinder] (unguarded (App toName (Var (Qualified Nothing x)))) ] - , ValueDeclaration (Ident "from") Public [] $ unguarded $ + , ValueDeclaration (ss, []) (Ident "from") Public [] $ unguarded $ lamCase x [ CaseAlternative [NullBinder] (unguarded (App fromName (Var (Qualified Nothing x)))) ] ] | otherwise = - [ ValueDeclaration (Ident "to") Public [] $ unguarded $ + [ ValueDeclaration (ss, []) (Ident "to") Public [] $ unguarded $ lamCase x (zipWith ($) (map underBinder (sumBinders (length dctors))) to) - , ValueDeclaration (Ident "from") Public [] $ unguarded $ + , ValueDeclaration (ss, []) (Ident "from") Public [] $ unguarded $ lamCase x (zipWith ($) (map underExpr (sumExprs (length dctors))) from) ] subst = zipWith ((,) . fst) args tyConArgs return (inst, replaceAllTypeVars subst rep) - go (PositionedDeclaration _ _ d) = go d go _ = internalError "deriveGenericRep go: expected DataDeclaration" select :: (a -> a) -> (a -> a) -> Int -> [a -> a] @@ -643,24 +637,25 @@ checkIsWildcard tyConNm _ = throwError . errorMessage $ ExpectedWildcard tyConNm -deriveEq :: - forall m. (MonadError MultipleErrors m, MonadSupply m) - => ModuleName +deriveEq + :: forall m + . (MonadError MultipleErrors m, MonadSupply m) + => SourceSpan + -> ModuleName -> SynonymMap -> [Declaration] -> ProperName 'TypeName -> m [Declaration] -deriveEq mn syns ds tyConNm = do +deriveEq ss mn syns ds tyConNm = do tyCon <- findTypeDecl tyConNm ds eqFun <- mkEqFunction tyCon - return [ ValueDeclaration (Ident C.eq) Public [] (unguarded eqFun) ] + return [ ValueDeclaration (ss, []) (Ident C.eq) Public [] (unguarded eqFun) ] where mkEqFunction :: Declaration -> m Expr - mkEqFunction (DataDeclaration _ _ _ args) = do + mkEqFunction (DataDeclaration _ _ _ _ args) = do x <- freshIdent "x" y <- freshIdent "y" lamCase2 x y <$> (addCatch <$> mapM mkCtorClause args) - mkEqFunction (PositionedDeclaration _ _ d) = mkEqFunction d mkEqFunction _ = internalError "mkEqFunction: expected DataDeclaration" preludeConj :: Expr -> Expr -> Expr @@ -698,24 +693,25 @@ $ fields toEqTest l r _ = preludeEq l r -deriveOrd :: - forall m. (MonadError MultipleErrors m, MonadSupply m) - => ModuleName +deriveOrd + :: forall m + . (MonadError MultipleErrors m, MonadSupply m) + => SourceSpan + -> ModuleName -> SynonymMap -> [Declaration] -> ProperName 'TypeName -> m [Declaration] -deriveOrd mn syns ds tyConNm = do +deriveOrd ss mn syns ds tyConNm = do tyCon <- findTypeDecl tyConNm ds compareFun <- mkCompareFunction tyCon - return [ ValueDeclaration (Ident C.compare) Public [] (unguarded compareFun) ] + return [ ValueDeclaration (ss, []) (Ident C.compare) Public [] (unguarded compareFun) ] where mkCompareFunction :: Declaration -> m Expr - mkCompareFunction (DataDeclaration _ _ _ args) = do + mkCompareFunction (DataDeclaration _ _ _ _ args) = do x <- freshIdent "x" y <- freshIdent "y" lamCase2 x y <$> (addCatch . concat <$> mapM mkCtorClauses (splitLast args)) - mkCompareFunction (PositionedDeclaration _ _ d) = mkCompareFunction d mkCompareFunction _ = internalError "mkCompareFunction: expected DataDeclaration" splitLast :: [a] -> [(a, Bool)] @@ -801,18 +797,18 @@ go =<< findTypeDecl tyConNm ds where go :: Declaration -> m ([Declaration], Type) - go (DataDeclaration Data name _ _) = - throwError . errorMessage $ CannotDeriveNewtypeForData name - go (DataDeclaration Newtype name args dctors) = do + go (DataDeclaration (ss, _) Data name _ _) = + throwError . errorMessage' ss $ CannotDeriveNewtypeForData name + go (DataDeclaration (ss, _) Newtype name args dctors) = do checkNewtype name dctors wrappedIdent <- freshIdent "n" unwrappedIdent <- freshIdent "a" let (ctorName, [ty]) = head dctors ty' <- replaceAllTypeSynonymsM syns ty let inst = - [ ValueDeclaration (Ident "wrap") Public [] $ unguarded $ + [ ValueDeclaration (ss, []) (Ident "wrap") Public [] $ unguarded $ Constructor (Qualified (Just mn) ctorName) - , ValueDeclaration (Ident "unwrap") Public [] $ unguarded $ + , ValueDeclaration (ss, []) (Ident "unwrap") Public [] $ unguarded $ lamCase wrappedIdent [ CaseAlternative [ConstructorBinder (Qualified (Just mn) ctorName) [VarBinder unwrappedIdent]] @@ -821,7 +817,6 @@ ] subst = zipWith ((,) . fst) args tyConArgs return (inst, replaceAllTypeVars subst ty') - go (PositionedDeclaration _ _ d) = go d go _ = internalError "deriveNewtype go: expected DataDeclaration" findTypeDecl @@ -832,8 +827,7 @@ findTypeDecl tyConNm = maybe (throwError . errorMessage $ CannotFindDerivingType tyConNm) return . find isTypeDecl where isTypeDecl :: Declaration -> Bool - isTypeDecl (DataDeclaration _ nm _ _) | nm == tyConNm = True - isTypeDecl (PositionedDeclaration _ _ d) = isTypeDecl d + isTypeDecl (DataDeclaration _ _ nm _ _) | nm == tyConNm = True isTypeDecl _ = False lam :: Ident -> Expr -> Expr @@ -883,24 +877,24 @@ deriveFunctor :: forall m . (MonadError MultipleErrors m, MonadSupply m) - => ModuleName + => SourceSpan + -> ModuleName -> SynonymMap -> [Declaration] -> ProperName 'TypeName -> m [Declaration] -deriveFunctor mn syns ds tyConNm = do +deriveFunctor ss mn syns ds tyConNm = do tyCon <- findTypeDecl tyConNm ds mapFun <- mkMapFunction tyCon - return [ ValueDeclaration (Ident C.map) Public [] (unguarded mapFun) ] + return [ ValueDeclaration (ss, []) (Ident C.map) Public [] (unguarded mapFun) ] where mkMapFunction :: Declaration -> m Expr - mkMapFunction (DataDeclaration _ _ tys ctors) = case reverse tys of - [] -> throwError . errorMessage $ KindsDoNotUnify (FunKind kindType kindType) kindType + mkMapFunction (DataDeclaration (ss', _) _ _ tys ctors) = case reverse tys of + [] -> throwError . errorMessage' ss' $ KindsDoNotUnify (FunKind kindType kindType) kindType ((iTy, _) : _) -> do f <- freshIdent "f" m <- freshIdent "m" lam f . lamCase m <$> mapM (mkCtorClause iTy f) ctors - mkMapFunction (PositionedDeclaration _ _ d) = mkMapFunction d mkMapFunction _ = internalError "mkMapFunction: expected DataDeclaration" mkCtorClause :: Text -> Ident -> (ProperName 'ConstructorName, [Type]) -> m CaseAlternative diff --git a/src/Language/PureScript/Sugar/TypeDeclarations.hs b/src/Language/PureScript/Sugar/TypeDeclarations.hs --- a/src/Language/PureScript/Sugar/TypeDeclarations.hs +++ b/src/Language/PureScript/Sugar/TypeDeclarations.hs @@ -23,39 +23,33 @@ . MonadError MultipleErrors m => Module -> m Module -desugarTypeDeclarationsModule (Module ss coms name ds exps) = +desugarTypeDeclarationsModule (Module modSS coms name ds exps) = rethrow (addHint (ErrorInModule name)) $ - Module ss coms name <$> desugarTypeDeclarations ds <*> pure exps + Module modSS coms name <$> desugarTypeDeclarations ds <*> pure exps where desugarTypeDeclarations :: [Declaration] -> m [Declaration] - desugarTypeDeclarations (PositionedDeclaration pos com d : rest) = do - (d' : rest') <- rethrowWithPosition pos $ desugarTypeDeclarations (d : rest) - return (PositionedDeclaration pos com d' : rest') - desugarTypeDeclarations (TypeDeclaration name' ty : d : rest) = do + desugarTypeDeclarations (TypeDeclaration sa name' ty : d : rest) = do (_, nameKind, val) <- fromValueDeclaration d - desugarTypeDeclarations (ValueDeclaration name' nameKind [] [MkUnguarded (TypedValue True val ty)] : rest) + desugarTypeDeclarations (ValueDeclaration sa name' nameKind [] [MkUnguarded (TypedValue True val ty)] : rest) where fromValueDeclaration :: Declaration -> m (Ident, NameKind, Expr) - fromValueDeclaration (ValueDeclaration name'' nameKind [] [MkUnguarded val]) + fromValueDeclaration (ValueDeclaration _ name'' nameKind [] [MkUnguarded val]) | name' == name'' = return (name'', nameKind, val) - fromValueDeclaration (PositionedDeclaration pos com d') = do - (ident, nameKind, val) <- rethrowWithPosition pos $ fromValueDeclaration d' - return (ident, nameKind, PositionedValue pos com val) - fromValueDeclaration _ = - throwError . errorMessage $ OrphanTypeDeclaration name' - desugarTypeDeclarations [TypeDeclaration name' _] = - throwError . errorMessage $ OrphanTypeDeclaration name' - desugarTypeDeclarations (ValueDeclaration name' nameKind bs val : rest) = do + fromValueDeclaration d' = + throwError . errorMessage' (declSourceSpan d') $ OrphanTypeDeclaration name' + desugarTypeDeclarations [TypeDeclaration (ss, _) name' _] = + throwError . errorMessage' ss $ OrphanTypeDeclaration name' + desugarTypeDeclarations (ValueDeclaration sa name' nameKind bs val : rest) = do let (_, f, _) = everywhereOnValuesTopDownM return go return f' = mapM (\(GuardedExpr g e) -> GuardedExpr g <$> f e) - (:) <$> (ValueDeclaration name' nameKind bs <$> f' val) + (:) <$> (ValueDeclaration sa name' nameKind bs <$> f' val) <*> desugarTypeDeclarations rest where go (Let ds' val') = Let <$> desugarTypeDeclarations ds' <*> pure val' go other = return other - desugarTypeDeclarations (TypeInstanceDeclaration nm deps cls args (ExplicitInstance ds') : rest) = - (:) <$> (TypeInstanceDeclaration nm deps cls args . ExplicitInstance <$> desugarTypeDeclarations ds') + desugarTypeDeclarations (TypeInstanceDeclaration sa nm deps cls args (ExplicitInstance ds') : rest) = + (:) <$> (TypeInstanceDeclaration sa nm deps cls args . ExplicitInstance <$> desugarTypeDeclarations ds') <*> desugarTypeDeclarations rest desugarTypeDeclarations (d:rest) = (:) d <$> desugarTypeDeclarations rest desugarTypeDeclarations [] = return [] diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -22,11 +22,12 @@ import Data.Foldable (for_, traverse_, toList) import Data.List (nubBy, (\\), sort, group) import Data.Maybe +import Data.Monoid ((<>)) +import Data.Text (Text) +import qualified Data.List.NonEmpty as NEL import qualified Data.Map as M import qualified Data.Set as S -import Data.Monoid ((<>)) import qualified Data.Text as T -import Data.Text (Text) import Language.PureScript.AST import Language.PureScript.Crash @@ -35,7 +36,6 @@ import Language.PureScript.Kinds import Language.PureScript.Linter import Language.PureScript.Names -import Language.PureScript.Traversals import Language.PureScript.TypeChecker.Kinds as T import Language.PureScript.TypeChecker.Monad as T import Language.PureScript.TypeChecker.Synonyms as T @@ -140,8 +140,7 @@ argToIndex :: Text -> Maybe Int argToIndex = flip M.lookup $ M.fromList (zipWith ((,) . fst) args [0..]) - toPair (TypeDeclaration ident ty) = (ident, ty) - toPair (PositionedDeclaration _ _ d) = toPair d + toPair (TypeDeclaration _ ident ty) = (ident, ty) toPair _ = internalError "Invalid declaration in TypeClassDeclaration" -- Currently we are only checking usability based on the type class currently @@ -229,17 +228,18 @@ typeCheckAll moduleName _ = traverse go where go :: Declaration -> m Declaration - go (DataDeclaration dtype name args dctors) = do - warnAndRethrow (addHint (ErrorInTypeConstructor name)) $ do + go (DataDeclaration sa@(ss, _) dtype name args dctors) = do + warnAndRethrow (addHint (ErrorInTypeConstructor name) . addHint (PositionedError ss)) $ do when (dtype == Newtype) $ checkNewtype name dctors checkDuplicateTypeArguments $ map fst args ctorKind <- kindsOf True moduleName name args (concatMap snd dctors) let args' = args `withKinds` ctorKind addDataType moduleName dtype name args' dctors ctorKind - return $ DataDeclaration dtype name args dctors + return $ DataDeclaration sa dtype name args dctors go (d@(DataBindingGroupDeclaration tys)) = do - let syns = mapMaybe toTypeSynonym tys - dataDecls = mapMaybe toDataDecl tys + let tysList = NEL.toList tys + syns = mapMaybe toTypeSynonym tysList + dataDecls = mapMaybe toDataDecl tysList bindingGroupNames = ordNub ((syns^..traverse._1) ++ (dataDecls^..traverse._2)) warnAndRethrow (addHint (ErrorInDataBindingGroup bindingGroupNames)) $ do (syn_ks, data_ks) <- kindsOfAll moduleName syns (map (\(_, name, args, dctors) -> (name, args, concatMap snd dctors)) dataDecls) @@ -254,56 +254,53 @@ addTypeSynonym moduleName name args' ty kind return d where - toTypeSynonym (TypeSynonymDeclaration nm args ty) = Just (nm, args, ty) - toTypeSynonym (PositionedDeclaration _ _ d') = toTypeSynonym d' + toTypeSynonym (TypeSynonymDeclaration _ nm args ty) = Just (nm, args, ty) toTypeSynonym _ = Nothing - toDataDecl (DataDeclaration dtype nm args dctors) = Just (dtype, nm, args, dctors) - toDataDecl (PositionedDeclaration _ _ d') = toDataDecl d' + toDataDecl (DataDeclaration _ dtype nm args dctors) = Just (dtype, nm, args, dctors) toDataDecl _ = Nothing - go (TypeSynonymDeclaration name args ty) = do - warnAndRethrow (addHint (ErrorInTypeSynonym name)) $ do + go (TypeSynonymDeclaration sa@(ss, _) name args ty) = do + warnAndRethrow (addHint (ErrorInTypeSynonym name) . addHint (PositionedError ss) ) $ do checkDuplicateTypeArguments $ map fst args kind <- kindsOf False moduleName name args [ty] let args' = args `withKinds` kind addTypeSynonym moduleName name args' ty kind - return $ TypeSynonymDeclaration name args ty + return $ TypeSynonymDeclaration sa name args ty go TypeDeclaration{} = internalError "Type declarations should have been removed before typeCheckAlld" - go (ValueDeclaration name nameKind [] [MkUnguarded val]) = do + go (ValueDeclaration sa@(ss, _) name nameKind [] [MkUnguarded val]) = do env <- getEnv - warnAndRethrow (addHint (ErrorInValueDeclaration name)) $ do - val' <- checkExhaustiveExpr env moduleName val + warnAndRethrow (addHint (ErrorInValueDeclaration name) . addHint (PositionedError ss)) $ do + val' <- checkExhaustiveExpr ss env moduleName val valueIsNotDefined moduleName name - [(_, (val'', ty))] <- typesOf NonRecursiveBindingGroup moduleName [(name, val')] + [(_, (val'', ty))] <- typesOf NonRecursiveBindingGroup moduleName [((sa, name), val')] addValue moduleName name ty nameKind - return $ ValueDeclaration name nameKind [] [MkUnguarded val''] + return $ ValueDeclaration sa name nameKind [] [MkUnguarded val''] go ValueDeclaration{} = internalError "Binders were not desugared" go BoundValueDeclaration{} = internalError "BoundValueDeclaration should be desugared" go (BindingGroupDeclaration vals) = do env <- getEnv - warnAndRethrow (addHint (ErrorInBindingGroup (map (\(ident, _, _) -> ident) vals))) $ do - for_ vals $ \(ident, _, _) -> - valueIsNotDefined moduleName ident - vals' <- mapM (thirdM (checkExhaustiveExpr env moduleName)) vals - tys <- typesOf RecursiveBindingGroup moduleName $ map (\(ident, _, ty) -> (ident, ty)) vals' - vals'' <- forM [ (name, val, nameKind, ty) - | (name, nameKind, _) <- vals' - , (name', (val, ty)) <- tys + warnAndRethrow (addHint (ErrorInBindingGroup (fmap (\((_, ident), _, _) -> ident) vals))) $ do + for_ vals $ \((_, ident), _, _) -> valueIsNotDefined moduleName ident + vals' <- NEL.toList <$> traverse (\(sai@((ss, _), _), nk, expr) -> (sai, nk,) <$> checkExhaustiveExpr ss env moduleName expr) vals + tys <- typesOf RecursiveBindingGroup moduleName $ fmap (\(sai, _, ty) -> (sai, ty)) vals' + vals'' <- forM [ (sai, val, nameKind, ty) + | (sai@(_, name), nameKind, _) <- vals' + , ((_, name'), (val, ty)) <- tys , name == name' - ] $ \(name, val, nameKind, ty) -> do + ] $ \(sai@(_, name), val, nameKind, ty) -> do addValue moduleName name ty nameKind - return (name, nameKind, val) - return $ BindingGroupDeclaration vals'' - go (d@(ExternDataDeclaration name kind)) = do + return (sai, nameKind, val) + return . BindingGroupDeclaration $ NEL.fromList vals'' + go (d@(ExternDataDeclaration _ name kind)) = do env <- getEnv putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (kind, ExternData) (types env) } return d - go (d@(ExternKindDeclaration name)) = do + go (d@(ExternKindDeclaration _ name)) = do env <- getEnv putEnv $ env { kinds = S.insert (Qualified (Just moduleName) name) (kinds env) } return d - go (d@(ExternDeclaration name ty)) = do - warnAndRethrow (addHint (ErrorInForeignImport name)) $ do + go (d@(ExternDeclaration (ss, _) name ty)) = do + warnAndRethrow (addHint (ErrorInForeignImport name) . addHint (PositionedError ss)) $ do env <- getEnv kind <- kindOf ty guardWith (errorMessage (ExpectedType ty kind)) $ kind == kindType @@ -313,23 +310,23 @@ return d go d@FixityDeclaration{} = return d go d@ImportDeclaration{} = return d - go d@(TypeClassDeclaration pn args implies deps tys) = do + go d@(TypeClassDeclaration _ pn args implies deps tys) = do addTypeClass moduleName pn args implies deps tys return d - go (d@(TypeInstanceDeclaration dictName deps className tys body)) = rethrow (addHint (ErrorInInstance className tys)) $ do - env <- getEnv - case M.lookup className (typeClasses env) of - Nothing -> internalError "typeCheckAll: Encountered unknown type class in instance declaration" - Just typeClass -> do - checkInstanceArity dictName className typeClass tys - sequence_ (zipWith (checkTypeClassInstance typeClass) [0..] tys) - checkOrphanInstance dictName className typeClass tys - _ <- traverseTypeInstanceBody checkInstanceMembers body - let dict = TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) [] className tys (Just deps) - addTypeClassDictionaries (Just moduleName) . M.singleton className $ M.singleton (tcdValue dict) dict - return d - go (PositionedDeclaration pos com d) = - warnAndRethrowWithPosition pos $ PositionedDeclaration pos com <$> go d + go (d@(TypeInstanceDeclaration (ss, _) dictName deps className tys body)) = + rethrow (addHint (ErrorInInstance className tys) . addHint (PositionedError ss)) $ do + env <- getEnv + case M.lookup className (typeClasses env) of + Nothing -> internalError "typeCheckAll: Encountered unknown type class in instance declaration" + Just typeClass -> do + checkInstanceArity dictName className typeClass tys + sequence_ (zipWith (checkTypeClassInstance typeClass) [0..] tys) + checkOrphanInstance dictName className typeClass tys + _ <- traverseTypeInstanceBody checkInstanceMembers body + deps' <- (traverse . overConstraintArgs . traverse) replaceAllTypeSynonyms deps + let dict = TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) [] className tys (Just deps') + addTypeClassDictionaries (Just moduleName) . M.singleton className $ M.singleton (tcdValue dict) dict + return d checkInstanceArity :: Ident -> Qualified (ProperName 'ClassName) -> TypeClassData -> [Type] -> m () checkInstanceArity dictName className typeClass tys = do @@ -346,8 +343,7 @@ return instDecls where memberName :: Declaration -> Ident - memberName (ValueDeclaration ident _ _ _) = ident - memberName (PositionedDeclaration _ _ d) = memberName d + memberName (ValueDeclaration _ ident _ _ _) = ident memberName _ = internalError "checkInstanceMembers: Invalid declaration in type instance definition" firstDuplicate :: (Eq a) => [a] -> Maybe a @@ -428,7 +424,7 @@ where checkMemberExport :: (Type -> [DeclarationRef]) -> DeclarationRef -> m () - checkMemberExport extract dr@(TypeRef name dctors) = do + checkMemberExport extract dr@(TypeRef _ name dctors) = do env <- getEnv case M.lookup (Qualified (Just mn) name) (typeSynonyms env) of Nothing -> return () @@ -440,7 +436,7 @@ Nothing -> return () Just (_, _, ty, _) -> checkExport dr extract ty return () - checkMemberExport extract dr@(ValueRef name) = do + checkMemberExport extract dr@(ValueRef _ name) = do ty <- lookupVariable (Qualified (Just mn) name) checkExport dr extract ty checkMemberExport _ _ = return () @@ -448,58 +444,55 @@ checkExport :: DeclarationRef -> (Type -> [DeclarationRef]) -> Type -> m () checkExport dr extract ty = case filter (not . exported) (extract ty) of [] -> return () - hidden -> throwError . errorMessage $ TransitiveExportError dr (nubBy nubEq hidden) + hidden -> throwError . errorMessage' (declRefSourceSpan dr) $ TransitiveExportError dr (nubBy nubEq hidden) where exported e = any (exports e) exps - exports (TypeRef pn1 _) (TypeRef pn2 _) = pn1 == pn2 - exports (ValueRef id1) (ValueRef id2) = id1 == id2 - exports (TypeClassRef pn1) (TypeClassRef pn2) = pn1 == pn2 - exports (PositionedDeclarationRef _ _ r1) r2 = exports r1 r2 - exports r1 (PositionedDeclarationRef _ _ r2) = exports r1 r2 + exports (TypeRef _ pn1 _) (TypeRef _ pn2 _) = pn1 == pn2 + exports (ValueRef _ id1) (ValueRef _ id2) = id1 == id2 + exports (TypeClassRef _ pn1) (TypeClassRef _ pn2) = pn1 == pn2 exports _ _ = False -- We avoid Eq for `nub`bing as the dctor part of `TypeRef` evaluates to -- `error` for the values generated here (we don't need them anyway) - nubEq (TypeRef pn1 _) (TypeRef pn2 _) = pn1 == pn2 + nubEq (TypeRef _ pn1 _) (TypeRef _ pn2 _) = pn1 == pn2 nubEq r1 r2 = r1 == r2 -- Check that all the type constructors defined in the current module that appear in member types -- have also been exported from the module checkTypesAreExported :: DeclarationRef -> m () - checkTypesAreExported = checkMemberExport findTcons + checkTypesAreExported ref = checkMemberExport findTcons ref where findTcons :: Type -> [DeclarationRef] findTcons = everythingOnTypes (++) go where - go (TypeConstructor (Qualified (Just mn') name)) | mn' == mn = [TypeRef name (internalError "Data constructors unused in checkTypesAreExported")] + go (TypeConstructor (Qualified (Just mn') name)) | mn' == mn = + [TypeRef (declRefSourceSpan ref) name (internalError "Data constructors unused in checkTypesAreExported")] go _ = [] -- Check that all the classes defined in the current module that appear in member types have also -- been exported from the module checkClassesAreExported :: DeclarationRef -> m () - checkClassesAreExported = checkMemberExport findClasses + checkClassesAreExported ref = checkMemberExport findClasses ref where findClasses :: Type -> [DeclarationRef] findClasses = everythingOnTypes (++) go where - go (ConstrainedType c _) = (fmap TypeClassRef . extractCurrentModuleClass . constraintClass) c + go (ConstrainedType c _) = (fmap (TypeClassRef (declRefSourceSpan ref)) . extractCurrentModuleClass . constraintClass) c go _ = [] extractCurrentModuleClass :: Qualified (ProperName 'ClassName) -> [ProperName 'ClassName] extractCurrentModuleClass (Qualified (Just mn') name) | mn == mn' = [name] extractCurrentModuleClass _ = [] checkClassMembersAreExported :: DeclarationRef -> m () - checkClassMembersAreExported dr@(TypeClassRef name) = do - let members = ValueRef `map` head (mapMaybe findClassMembers decls) + checkClassMembersAreExported dr@(TypeClassRef ss' name) = do + let members = ValueRef ss' `map` head (mapMaybe findClassMembers decls) let missingMembers = members \\ exps - unless (null missingMembers) $ throwError . errorMessage $ TransitiveExportError dr members + unless (null missingMembers) . throwError . errorMessage' ss' $ TransitiveExportError dr members where findClassMembers :: Declaration -> Maybe [Ident] - findClassMembers (TypeClassDeclaration name' _ _ _ ds) | name == name' = Just $ map extractMemberName ds - findClassMembers (PositionedDeclaration _ _ d) = findClassMembers d + findClassMembers (TypeClassDeclaration _ name' _ _ _ ds) | name == name' = Just $ map extractMemberName ds findClassMembers _ = Nothing extractMemberName :: Declaration -> Ident - extractMemberName (PositionedDeclaration _ _ d) = extractMemberName d - extractMemberName (TypeDeclaration memberName _) = memberName + extractMemberName (TypeDeclaration _ memberName _) = memberName extractMemberName _ = internalError "Unexpected declaration in typeclass member list" checkClassMembersAreExported _ = return () diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -44,20 +44,17 @@ -- | Describes what sort of dictionary to generate for type class instances data Evidence + -- | An existing named instance = NamedInstance (Qualified Ident) - -- ^ An existing named instance - | WarnInstance Type - -- ^ Computed instance of the Warn type class with a user-defined warning message - | IsSymbolInstance PSString - -- ^ Computed instance of the IsSymbol type class for a given Symbol literal + + -- | Computed instances + | WarnInstance Type -- ^ Warn type class with a user-defined warning message + | IsSymbolInstance PSString -- ^ The IsSymbol type class for a given Symbol literal | CompareSymbolInstance - -- ^ Computed instance of CompareSymbol | AppendSymbolInstance - -- ^ Computed instance of AppendSymbol | UnionInstance - -- ^ Computed instance of Union | ConsInstance - -- ^ Computed instance of RowCons + | RowToListInstance deriving (Show, Eq) -- | Extract the identifier of a named instance @@ -173,6 +170,9 @@ = [ TypeClassDictionaryInScope UnionInstance [] C.Union [lOut, rOut, uOut] cst ] forClassName _ C.RowCons [TypeLevelString sym, ty, r, _] = [ TypeClassDictionaryInScope ConsInstance [] C.RowCons [TypeLevelString sym, ty, r, RCons (Label sym) ty r] Nothing ] + forClassName _ C.RowToList [r, _] + | Just entries <- solveRowToList r + = [ TypeClassDictionaryInScope RowToListInstance [] C.RowToList [r, entries] Nothing ] forClassName ctx cn@(Qualified (Just mn) _) tys = concatMap (findDicts ctx cn) (ordNub (Nothing : Just mn : map Just (mapMaybe ctorModules tys))) forClassName _ _ _ = internalError "forClassName: expected qualified class name" @@ -333,6 +333,7 @@ return $ App (Abs (VarBinder (Ident C.__unused)) valUndefined) e mkDictionary UnionInstance _ = return valUndefined mkDictionary ConsInstance _ = return valUndefined + mkDictionary RowToListInstance _ = return valUndefined mkDictionary (WarnInstance msg) _ = do tell . errorMessage $ UserDefinedWarning msg -- We cannot call the type class constructor here because Warn is declared in Prim. @@ -373,6 +374,18 @@ -- the right hand side, and we can't be certain we won't reorder the -- types for such labels. _ -> (not (null fixed), (fixed, rowVar), Just [ Constraint C.Union [rest, r, rowVar] Nothing ]) + + -- | Convert a closed row to a sorted list of entries + solveRowToList :: Type -> Maybe Type + solveRowToList r = + guard (REmpty == rest) $> + foldr rowListCons (TypeConstructor C.RowListNil) fixed + where + (fixed, rest) = rowToSortedList r + rowListCons (lbl, ty) tl = foldl TypeApp (TypeConstructor C.RowListCons) + [ TypeLevelString (runLabel lbl) + , ty + , tl ] -- Check if an instance matches our list of types, allowing for types -- to be solved via functional dependencies. If the types match, we return a diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -40,9 +40,10 @@ import Data.List (transpose, (\\), partition, delete) import Data.Maybe (fromMaybe) import Data.Monoid ((<>)) +import Data.Traversable (for) +import qualified Data.List.NonEmpty as NEL import qualified Data.Map as M import qualified Data.Set as S -import Data.Traversable (for) import Language.PureScript.AST import Language.PureScript.Crash @@ -74,8 +75,8 @@ :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => BindingGroupType -> ModuleName - -> [(Ident, Expr)] - -> m [(Ident, (Expr, Type))] + -> [((SourceAnn, Ident), Expr)] + -> m [((SourceAnn, Ident), (Expr, Type))] typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do (tys, wInfer) <- capturingSubstitution tidyUp $ do (SplitBindingGroup untyped typed dict, w) <- withoutWarnings $ typeDictionaryForBindingGroup (Just moduleName) vals @@ -83,7 +84,7 @@ ds2 <- forM untyped $ \e -> withoutWarnings $ typeForBindingGroupElement e dict return (map (False, ) ds1 ++ map (True, ) ds2, w) - inferred <- forM tys $ \(shouldGeneralize, ((ident, (val, ty)), _)) -> do + inferred <- forM tys $ \(shouldGeneralize, ((sai@((ss, _), ident), (val, ty)), _)) -> do -- Replace type class dictionary placeholders with actual dictionaries (val', unsolved) <- replaceTypeClassDictionaries shouldGeneralize val -- Generalize and constrain the type @@ -94,12 +95,14 @@ when shouldGeneralize $ do -- Show the inferred type in a warning - tell . errorMessage $ MissingTypeDeclaration ident generalized + tell + . errorMessage' ss + $ MissingTypeDeclaration ident generalized -- For non-recursive binding groups, can generalize over constraints. -- For recursive binding groups, we throw an error here for now. when (bindingGroupType == RecursiveBindingGroup && not (null unsolved)) . throwError - . errorMessage + . errorMessage' ss $ CannotGeneralizeRecursiveFunction ident generalized -- Make sure any unsolved type constraints only use type variables which appear -- unknown in the inferred type. @@ -111,22 +114,25 @@ TypeClassData{ typeClassDependencies } <- gets (findClass . typeClasses . checkEnv) let solved = foldMap (S.fromList . fdDetermined) typeClassDependencies let constraintTypeVars = ordNub . foldMap (unknownsInType . fst) . filter ((`notElem` solved) . snd) $ zip (constraintArgs con) [0..] - when (any (`notElem` unsolvedTypeVars) constraintTypeVars) $ do - throwError . onErrorMessages (replaceTypes currentSubst) . errorMessage $ AmbiguousTypeVariables generalized con + when (any (`notElem` unsolvedTypeVars) constraintTypeVars) . + throwError + . onErrorMessages (replaceTypes currentSubst) + . errorMessage' ss + $ AmbiguousTypeVariables generalized con -- Check skolem variables did not escape their scope skolemEscapeCheck val' - return ((ident, (foldr (Abs . VarBinder . (\(x, _, _) -> x)) val' unsolved, generalized)), unsolved) + return ((sai, (foldr (Abs . VarBinder . (\(x, _, _) -> x)) val' unsolved, generalized)), unsolved) -- Show warnings here, since types in wildcards might have been solved during -- instance resolution (by functional dependencies). finalState <- get let replaceTypes' = replaceTypes (checkSubstitution finalState) runTypeSearch' gen = runTypeSearch (guard gen $> foldMap snd inferred) finalState - raisePreviousWarnings gen w = (escalateWarningWhen isHoleError . tell . onErrorMessages (runTypeSearch' gen . replaceTypes')) w + raisePreviousWarnings gen = (escalateWarningWhen isHoleError . tell . onErrorMessages (runTypeSearch' gen . replaceTypes')) raisePreviousWarnings False wInfer - forM_ tys $ \(shouldGeneralize, ((_, (_, _)), w)) -> do + forM_ tys $ \(shouldGeneralize, ((_, (_, _)), w)) -> raisePreviousWarnings shouldGeneralize w return (map fst inferred) @@ -172,9 +178,9 @@ -- -- This structure breaks down a binding group into typed and untyped parts. data SplitBindingGroup = SplitBindingGroup - { _splitBindingGroupUntyped :: [(Ident, (Expr, Type))] + { _splitBindingGroupUntyped :: [((SourceAnn, Ident), (Expr, Type))] -- ^ The untyped expressions - , _splitBindingGroupTyped :: [(Ident, (Expr, Type, Bool))] + , _splitBindingGroupTyped :: [((SourceAnn, Ident), (Expr, Type, Bool))] -- ^ The typed expressions, along with their type annotations , _splitBindingGroupNames :: M.Map (Qualified Ident) (Type, NameKind, NameVisibility) -- ^ A map containing all expressions and their assigned types (which might be @@ -190,46 +196,46 @@ typeDictionaryForBindingGroup :: (MonadState CheckState m, MonadWriter MultipleErrors m) => Maybe ModuleName - -> [(Ident, Expr)] + -> [((SourceAnn, Ident), Expr)] -> m SplitBindingGroup typeDictionaryForBindingGroup moduleName vals = do -- Filter the typed and untyped declarations and make a map of names to typed declarations. -- Replace type wildcards here so that the resulting dictionary of types contains the -- fully expanded types. let (untyped, typed) = partitionEithers (map splitTypeAnnotation vals) - (typedDict, typed') <- fmap unzip . for typed $ \(ident, (expr, ty, checkType)) -> do + (typedDict, typed') <- fmap unzip . for typed $ \(sai, (expr, ty, checkType)) -> do ty' <- replaceTypeWildcards ty - return ((ident, ty'), (ident, (expr, ty', checkType))) + return ((sai, ty'), (sai, (expr, ty', checkType))) -- Create fresh unification variables for the types of untyped declarations - (untypedDict, untyped') <- fmap unzip . for untyped $ \(ident, expr) -> do + (untypedDict, untyped') <- fmap unzip . for untyped $ \(sai, expr) -> do ty <- freshType - return ((ident, ty), (ident, (expr, ty))) + return ((sai, ty), (sai, (expr, ty))) -- Create the dictionary of all name/type pairs, which will be added to the -- environment during type checking let dict = M.fromList [ (Qualified moduleName ident, (ty, Private, Undefined)) - | (ident, ty) <- typedDict <> untypedDict + | ((_, ident), ty) <- typedDict <> untypedDict ] return (SplitBindingGroup untyped' typed' dict) where -- | Check if a value contains a type annotation, and if so, separate it -- from the value itself. - splitTypeAnnotation :: (Ident, Expr) -> Either (Ident, Expr) (Ident, (Expr, Type, Bool)) - splitTypeAnnotation (name, TypedValue checkType value ty) = Right (name, (value, ty, checkType)) - splitTypeAnnotation (name, PositionedValue pos c value) = + splitTypeAnnotation :: (a, Expr) -> Either (a, Expr) (a, (Expr, Type, Bool)) + splitTypeAnnotation (a, TypedValue checkType value ty) = Right (a, (value, ty, checkType)) + splitTypeAnnotation (a, PositionedValue pos c value) = bimap (second (PositionedValue pos c)) (second (\(e, t, b) -> (PositionedValue pos c e, t, b))) - (splitTypeAnnotation (name, value)) - splitTypeAnnotation (name, value) = Left (name, value) + (splitTypeAnnotation (a, value)) + splitTypeAnnotation (a, value) = Left (a, value) -- | Check the type annotation of a typed value in a binding group. checkTypedBindingGroupElement :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => ModuleName - -> (Ident, (Expr, Type, Bool)) + -> ((SourceAnn, Ident), (Expr, Type, Bool)) -- ^ The identifier we are trying to define, along with the expression and its type annotation -> M.Map (Qualified Ident) (Type, NameKind, NameVisibility) -- ^ Names brought into scope in this binding group - -> m (Ident, (Expr, Type)) + -> m ((SourceAnn, Ident), (Expr, Type)) checkTypedBindingGroupElement mn (ident, (val, ty, checkType)) dict = do -- Kind check (kind, args) <- kindOfWithScopedVars ty @@ -246,12 +252,12 @@ -- | Infer a type for a value in a binding group which lacks an annotation. typeForBindingGroupElement :: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) - => (Ident, (Expr, Type)) + => ((SourceAnn, Ident), (Expr, Type)) -- ^ The identifier we are trying to define, along with the expression and its assigned type -- (at this point, this should be a unification variable) -> M.Map (Qualified Ident) (Type, NameKind, NameVisibility) -- ^ Names brought into scope in this binding group - -> m (Ident, (Expr, Type)) + -> m ((SourceAnn, Ident), (Expr, Type)) typeForBindingGroupElement (ident, (val, ty)) dict = do -- Infer the type with the new names in scope TypedValue _ val' ty' <- bindNames dict $ infer val @@ -420,32 +426,31 @@ -> (Expr -> m Expr) -> m ([Declaration], Expr) inferLetBinding seen [] ret j = (,) seen <$> withBindingGroupVisible (j ret) -inferLetBinding seen (ValueDeclaration ident nameKind [] [MkUnguarded tv@(TypedValue checkType val ty)] : rest) ret j = do - Just moduleName <- checkCurrentModule <$> get - (kind, args) <- kindOfWithScopedVars ty - checkTypeKind ty kind - let dict = M.singleton (Qualified Nothing ident) (ty, nameKind, Undefined) - ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty - TypedValue _ val' ty'' <- if checkType then withScopedTypeVars moduleName args (bindNames dict (check val ty')) else return tv - bindNames (M.singleton (Qualified Nothing ident) (ty'', nameKind, Defined)) $ inferLetBinding (seen ++ [ValueDeclaration ident nameKind [] [MkUnguarded (TypedValue checkType val' ty'')]]) rest ret j -inferLetBinding seen (ValueDeclaration ident nameKind [] [MkUnguarded val] : rest) ret j = do - valTy <- freshType - let dict = M.singleton (Qualified Nothing ident) (valTy, nameKind, Undefined) - TypedValue _ val' valTy' <- bindNames dict $ infer val - unifyTypes valTy valTy' - bindNames (M.singleton (Qualified Nothing ident) (valTy', nameKind, Defined)) $ inferLetBinding (seen ++ [ValueDeclaration ident nameKind [] [MkUnguarded val']]) rest ret j +inferLetBinding seen (ValueDeclaration sa@(ss, _) ident nameKind [] [MkUnguarded tv@(TypedValue checkType val ty)] : rest) ret j = + warnAndRethrowWithPositionTC ss $ do + Just moduleName <- checkCurrentModule <$> get + (kind, args) <- kindOfWithScopedVars ty + checkTypeKind ty kind + let dict = M.singleton (Qualified Nothing ident) (ty, nameKind, Undefined) + ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty + TypedValue _ val' ty'' <- if checkType then withScopedTypeVars moduleName args (bindNames dict (check val ty')) else return tv + bindNames (M.singleton (Qualified Nothing ident) (ty'', nameKind, Defined)) $ inferLetBinding (seen ++ [ValueDeclaration sa ident nameKind [] [MkUnguarded (TypedValue checkType val' ty'')]]) rest ret j +inferLetBinding seen (ValueDeclaration sa@(ss, _) ident nameKind [] [MkUnguarded val] : rest) ret j = + warnAndRethrowWithPositionTC ss $ do + valTy <- freshType + let dict = M.singleton (Qualified Nothing ident) (valTy, nameKind, Undefined) + TypedValue _ val' valTy' <- bindNames dict $ infer val + unifyTypes valTy valTy' + bindNames (M.singleton (Qualified Nothing ident) (valTy', nameKind, Defined)) $ inferLetBinding (seen ++ [ValueDeclaration sa ident nameKind [] [MkUnguarded val']]) rest ret j inferLetBinding seen (BindingGroupDeclaration ds : rest) ret j = do Just moduleName <- checkCurrentModule <$> get - SplitBindingGroup untyped typed dict <- typeDictionaryForBindingGroup Nothing (map (\(i, _, v) -> (i, v)) ds) + SplitBindingGroup untyped typed dict <- typeDictionaryForBindingGroup Nothing . NEL.toList $ fmap (\(i, _, v) -> (i, v)) ds ds1' <- parU typed $ \e -> checkTypedBindingGroupElement moduleName e dict ds2' <- forM untyped $ \e -> typeForBindingGroupElement e dict - let ds' = [(ident, Private, val') | (ident, (val', _)) <- ds1' ++ ds2'] + let ds' = NEL.fromList [(ident, Private, val') | (ident, (val', _)) <- ds1' ++ ds2'] bindNames dict $ do makeBindingGroupVisible inferLetBinding (seen ++ [BindingGroupDeclaration ds']) rest ret j -inferLetBinding seen (PositionedDeclaration pos com d : ds) ret j = warnAndRethrowWithPositionTC pos $ do - (d' : ds', val') <- inferLetBinding seen (d : ds) ret j - return (PositionedDeclaration pos com d' : ds', val') inferLetBinding _ _ _ _ = internalError "Invalid argument to inferLetBinding" -- | Infer the types of variables brought into scope by a binder diff --git a/tests/Language/PureScript/Ide/CompletionSpec.hs b/tests/Language/PureScript/Ide/CompletionSpec.hs --- a/tests/Language/PureScript/Ide/CompletionSpec.hs +++ b/tests/Language/PureScript/Ide/CompletionSpec.hs @@ -19,7 +19,7 @@ moduleB = [ideKind "Kind" `annExp` "A"] matches :: [(Match IdeDeclarationAnn, [P.ModuleName])] -matches = map (\d -> (Match (mn "Main", d), [mn "Main"])) [ ideKind "Kind", ideType "Type" Nothing ] +matches = map (\d -> (Match (mn "Main", d), [mn "Main"])) [ ideKind "Kind", ideType "Type" Nothing [] ] spec :: Spec spec = describe "Applying completion options" $ do diff --git a/tests/Language/PureScript/Ide/FilterSpec.hs b/tests/Language/PureScript/Ide/FilterSpec.hs --- a/tests/Language/PureScript/Ide/FilterSpec.hs +++ b/tests/Language/PureScript/Ide/FilterSpec.hs @@ -5,6 +5,7 @@ import Protolude import Data.List.NonEmpty import Language.PureScript.Ide.Filter +import Language.PureScript.Ide.Filter.Declaration as D import Language.PureScript.Ide.Types import Language.PureScript.Ide.Test as T import qualified Language.PureScript as P @@ -12,11 +13,16 @@ type Module = (P.ModuleName, [IdeDeclarationAnn]) -moduleA, moduleB, moduleC, moduleD :: Module +moduleA, moduleB, moduleC, moduleD, moduleE, moduleF, moduleG, moduleH, moduleI :: Module moduleA = (P.moduleNameFromString "Module.A", [T.ideValue "function1" Nothing]) moduleB = (P.moduleNameFromString "Module.B", [T.ideValue "data1" Nothing]) -moduleC = (P.moduleNameFromString "Module.C", [T.ideType "List" Nothing]) +moduleC = (P.moduleNameFromString "Module.C", [T.ideType "List" Nothing []]) moduleD = (P.moduleNameFromString "Module.D", [T.ideKind "kind1"]) +moduleE = (P.moduleNameFromString "Module.E", [T.ideSynonym "SFType" Nothing Nothing `annLoc` synonymSS]) +moduleF = (P.moduleNameFromString "Module.F", [T.ideDtor "DtorA" "TypeA" Nothing]) +moduleG = (P.moduleNameFromString "Module.G", [T.ideTypeClass "MyClass" P.kindType []]) +moduleH = (P.moduleNameFromString "Module.H", [T.ideValueOp "<$>" (P.Qualified Nothing (Left "")) 0 Nothing Nothing]) +moduleI = (P.moduleNameFromString "Module.I", [T.ideTypeOp "~>" (P.Qualified Nothing "") 0 Nothing Nothing]) modules :: [Module] modules = [moduleA, moduleB] @@ -33,6 +39,9 @@ runNamespace :: NonEmpty IdeNamespace -> [Module] -> [Module] runNamespace namespaces = applyFilters [namespaceFilter namespaces] +runDeclaration :: [D.IdeDeclaration] -> [Module] -> [Module] +runDeclaration decls = applyFilters [declarationTypeFilter decls] + spec :: Spec spec = do describe "equality Filter" $ do @@ -91,3 +100,69 @@ runNamespace (fromList [ IdeNSValue, IdeNSType, IdeNSKind]) [moduleA, moduleB, moduleC, moduleD] `shouldBe` [moduleA, moduleB, moduleC, moduleD] + describe "declarationTypeFilter" $ do + let moduleADecl = D.IdeDeclaration D.Value + moduleCDecl = D.IdeDeclaration D.Type + moduleDDecl = D.IdeDeclaration D.Kind + moduleEDecl = D.IdeDeclaration D.Synonym + moduleFDecl = D.IdeDeclaration D.DataConstructor + moduleGDecl = D.IdeDeclaration D.TypeClass + moduleHDecl = D.IdeDeclaration D.ValueOperator + moduleIDecl = D.IdeDeclaration D.TypeOperator + it "keeps everything on empty list of declarations" $ + runDeclaration [] + [moduleA, moduleB, moduleD] `shouldBe` [moduleA, moduleB, moduleD] + it "extracts modules by filtering `value` declarations" $ + runDeclaration [moduleADecl] + [moduleA, moduleB, moduleD] `shouldBe` [moduleA, moduleB] + it "removes everything if no `value` declarations has been found" $ + runDeclaration [moduleADecl] + [moduleD, moduleG, moduleE, moduleH] `shouldBe` [] + it "extracts module by filtering `type` declarations" $ + runDeclaration [moduleCDecl] + [moduleA, moduleB, moduleC, moduleD, moduleE] `shouldBe` [moduleC] + it "removes everything if a `type` declaration have not been found" $ + runDeclaration [moduleCDecl] + [moduleA, moduleG, moduleE, moduleH] `shouldBe` [] + it "extracts module by filtering `synonym` declarations" $ + runDeclaration [moduleEDecl] + [moduleA, moduleB, moduleD, moduleE] `shouldBe` [moduleE] + it "removes everything if a `synonym` declaration have not been found" $ + runDeclaration [moduleEDecl] + [moduleA, moduleB, moduleC, moduleH] `shouldBe` [] + it "extracts module by filtering `constructor` declarations" $ + runDeclaration [moduleFDecl] + [moduleA, moduleB, moduleC, moduleF] `shouldBe` [moduleF] + it "removes everything if a `constructor` declaration have not been found" $ + runDeclaration [moduleFDecl] + [moduleA, moduleB, moduleC, moduleH] `shouldBe` [] + it "extracts module by filtering `typeclass` declarations" $ + runDeclaration [moduleGDecl] + [moduleA, moduleC, moduleG] `shouldBe` [moduleG] + it "removes everything if a `typeclass` declaration have not been found" $ + runDeclaration [moduleGDecl] + [moduleA, moduleB, moduleC, moduleH] `shouldBe` [] + it "extracts modules by filtering `valueoperator` declarations" $ + runDeclaration [moduleHDecl] + [moduleA, moduleC, moduleG, moduleH, moduleF] `shouldBe` [moduleH] + it "removes everything if a `valueoperator` declaration have not been found" $ + runDeclaration [moduleHDecl] + [moduleA, moduleB, moduleC, moduleD] `shouldBe` [] + it "extracts modules by filtering `typeoperator` declarations" $ + runDeclaration [moduleIDecl] + [moduleA, moduleC, moduleG, moduleI, moduleF] `shouldBe` [moduleI] + it "removes everything if a `typeoperator` declaration have not been found" $ + runDeclaration [moduleIDecl] + [moduleA, moduleD] `shouldBe` [] + it "extracts module by filtering `kind` declarations" $ + runDeclaration [moduleCDecl] + [moduleA, moduleC, moduleG, moduleI, moduleF] `shouldBe` [moduleC] + it "removes everything if a `kind` declaration have not been found" $ + runDeclaration [moduleCDecl] + [moduleA, moduleD] `shouldBe` [] + it "extracts modules by filtering `value` and `synonym` declarations" $ + runDeclaration [moduleADecl, moduleEDecl] + [moduleA, moduleB, moduleD, moduleE] `shouldBe` [moduleA, moduleB, moduleE] + it "extracts modules by filtering `kind`, `synonym` and `valueoperator` declarations" $ + runDeclaration [moduleADecl, moduleDDecl, moduleHDecl] + [moduleA, moduleB, moduleD, moduleG, moduleE, moduleH] `shouldBe` [moduleA, moduleB, moduleD, moduleH] diff --git a/tests/Language/PureScript/Ide/ImportsSpec.hs b/tests/Language/PureScript/Ide/ImportsSpec.hs --- a/tests/Language/PureScript/Ide/ImportsSpec.hs +++ b/tests/Language/PureScript/Ide/ImportsSpec.hs @@ -107,7 +107,7 @@ addDtorImport i t mn is = prettyPrintImportSection (addExplicitImport' (_idaDeclaration (Test.ideDtor i t Nothing)) mn is) addTypeImport i mn is = - prettyPrintImportSection (addExplicitImport' (_idaDeclaration (Test.ideType i Nothing)) mn is) + prettyPrintImportSection (addExplicitImport' (_idaDeclaration (Test.ideType i Nothing [])) mn is) addKindImport i mn is = prettyPrintImportSection (addExplicitImport' (_idaDeclaration (Test.ideKind i)) mn is) it "adds an implicit unqualified import to a file without any imports" $ @@ -208,7 +208,7 @@ moduleName = (P.moduleNameFromString "Control.Monad") addImport imports import' = addExplicitImport' import' moduleName imports valueImport ident = _idaDeclaration (Test.ideValue ident Nothing) - typeImport name = _idaDeclaration (Test.ideType name Nothing) + typeImport name = _idaDeclaration (Test.ideType name Nothing []) classImport name = _idaDeclaration (Test.ideTypeClass name P.kindType []) dtorImport name typeName = _idaDeclaration (Test.ideDtor name typeName Nothing) -- expect any list of provided identifiers, when imported, to come out as specified diff --git a/tests/Language/PureScript/Ide/ReexportsSpec.hs b/tests/Language/PureScript/Ide/ReexportsSpec.hs --- a/tests/Language/PureScript/Ide/ReexportsSpec.hs +++ b/tests/Language/PureScript/Ide/ReexportsSpec.hs @@ -13,7 +13,7 @@ valueA, typeA, synonymA, classA, dtorA1, dtorA2, kindA :: IdeDeclarationAnn valueA = ideValue "valueA" Nothing -typeA = ideType "TypeA" Nothing +typeA = ideType "TypeA" Nothing [] synonymA = ideSynonym "SynonymA" Nothing Nothing classA = ideTypeClass "ClassA" P.kindType [] dtorA1 = ideDtor "DtorA1" "TypeA" Nothing @@ -27,24 +27,27 @@ type Refs = [(P.ModuleName, P.DeclarationRef)] +testSpan :: P.SourceSpan +testSpan = P.internalModuleSourceSpan "" + succTestCases :: [(Text, Refs, [IdeDeclarationAnn])] succTestCases = - [ ("resolves a value reexport", [(mn "A", P.ValueRef (P.Ident "valueA"))], [valueA `annExp` "A"]) + [ ("resolves a value reexport", [(mn "A", P.ValueRef testSpan (P.Ident "valueA"))], [valueA `annExp` "A"]) , ("resolves a type reexport with explicit data constructors" - , [(mn "A", P.TypeRef (P.ProperName "TypeA") (Just [P.ProperName "DtorA1"]))], [typeA `annExp` "A", dtorA1 `annExp` "A"]) + , [(mn "A", P.TypeRef testSpan (P.ProperName "TypeA") (Just [P.ProperName "DtorA1"]))], [typeA `annExp` "A", dtorA1 `annExp` "A"]) , ("resolves a type reexport with implicit data constructors" - , [(mn "A", P.TypeRef (P.ProperName "TypeA") Nothing)], map (`annExp` "A") [typeA, dtorA1, dtorA2]) + , [(mn "A", P.TypeRef testSpan (P.ProperName "TypeA") Nothing)], map (`annExp` "A") [typeA, dtorA1, dtorA2]) , ("resolves a synonym reexport" - , [(mn "A", P.TypeRef (P.ProperName "SynonymA") Nothing)], [synonymA `annExp` "A"]) - , ("resolves a class reexport", [(mn "A", P.TypeClassRef (P.ProperName "ClassA"))], [classA `annExp` "A"]) - , ("resolves a kind reexport", [(mn "A", P.KindRef (P.ProperName "KindA"))], [kindA `annExp` "A"]) + , [(mn "A", P.TypeRef testSpan (P.ProperName "SynonymA") Nothing)], [synonymA `annExp` "A"]) + , ("resolves a class reexport", [(mn "A", P.TypeClassRef testSpan (P.ProperName "ClassA"))], [classA `annExp` "A"]) + , ("resolves a kind reexport", [(mn "A", P.KindRef testSpan (P.ProperName "KindA"))], [kindA `annExp` "A"]) ] failTestCases :: [(Text, Refs)] failTestCases = - [ ("fails to resolve a non existing value", [(mn "A", P.ValueRef (P.Ident "valueB"))]) - , ("fails to resolve a non existing type reexport" , [(mn "A", P.TypeRef (P.ProperName "TypeB") Nothing)]) - , ("fails to resolve a non existing class reexport", [(mn "A", P.TypeClassRef (P.ProperName "ClassB"))]) + [ ("fails to resolve a non existing value", [(mn "A", P.ValueRef testSpan (P.Ident "valueB"))]) + , ("fails to resolve a non existing type reexport" , [(mn "A", P.TypeRef testSpan (P.ProperName "TypeB") Nothing)]) + , ("fails to resolve a non existing class reexport", [(mn "A", P.TypeClassRef testSpan (P.ProperName "ClassB"))]) ] spec :: Spec diff --git a/tests/Language/PureScript/Ide/SourceFileSpec.hs b/tests/Language/PureScript/Ide/SourceFileSpec.hs --- a/tests/Language/PureScript/Ide/SourceFileSpec.hs +++ b/tests/Language/PureScript/Ide/SourceFileSpec.hs @@ -16,55 +16,61 @@ span1 = P.SourceSpan "" (P.SourcePos 1 1) (P.SourcePos 2 2) span2 = P.SourceSpan "" (P.SourcePos 2 2) (P.SourcePos 3 3) +ann0, ann1, ann2 :: P.SourceAnn +ann0 = (span0, []) +ann1 = (span1, []) +ann2 = (span2, []) + typeAnnotation1, value1, synonym1, class1, class2, data1, data2, valueFixity, typeFixity, foreign1, foreign2, foreign3, member1 :: P.Declaration -typeAnnotation1 = P.TypeDeclaration (P.Ident "value1") P.REmpty -value1 = P.ValueDeclaration (P.Ident "value1") P.Public [] [] -synonym1 = P.TypeSynonymDeclaration (P.ProperName "Synonym1") [] P.REmpty -class1 = P.TypeClassDeclaration (P.ProperName "Class1") [] [] [] [] -class2 = P.TypeClassDeclaration (P.ProperName "Class2") [] [] [] - [P.PositionedDeclaration span2 [] member1] -data1 = P.DataDeclaration P.Newtype (P.ProperName "Data1") [] [] -data2 = P.DataDeclaration P.Data (P.ProperName "Data2") [] [(P.ProperName "Cons1", [])] +typeAnnotation1 = P.TypeDeclaration ann1 (P.Ident "value1") P.REmpty +value1 = P.ValueDeclaration ann1 (P.Ident "value1") P.Public [] [] +synonym1 = P.TypeSynonymDeclaration ann1 (P.ProperName "Synonym1") [] P.REmpty +class1 = P.TypeClassDeclaration ann1 (P.ProperName "Class1") [] [] [] [] +class2 = P.TypeClassDeclaration ann1 (P.ProperName "Class2") [] [] [] [member1] +data1 = P.DataDeclaration ann1 P.Newtype (P.ProperName "Data1") [] [] +data2 = P.DataDeclaration ann1 P.Data (P.ProperName "Data2") [] [(P.ProperName "Cons1", [])] valueFixity = P.ValueFixityDeclaration + ann1 (P.Fixity P.Infix 0) (P.Qualified Nothing (Left (P.Ident ""))) (P.OpName "<$>") typeFixity = P.TypeFixityDeclaration + ann1 (P.Fixity P.Infix 0) (P.Qualified Nothing (P.ProperName "")) (P.OpName "~>") -foreign1 = P.ExternDeclaration (P.Ident "foreign1") P.REmpty -foreign2 = P.ExternDataDeclaration (P.ProperName "Foreign2") P.kindType -foreign3 = P.ExternKindDeclaration (P.ProperName "Foreign3") -member1 = P.TypeDeclaration (P.Ident "member1") P.REmpty +foreign1 = P.ExternDeclaration ann1 (P.Ident "foreign1") P.REmpty +foreign2 = P.ExternDataDeclaration ann1 (P.ProperName "Foreign2") P.kindType +foreign3 = P.ExternKindDeclaration ann1 (P.ProperName "Foreign3") +member1 = P.TypeDeclaration ann2 (P.Ident "member1") P.REmpty spec :: Spec spec = do describe "Extracting Spans" $ do it "extracts a span for a value declaration" $ - extractSpans span0 (P.PositionedDeclaration span1 [] value1) `shouldBe` [(IdeNamespaced IdeNSValue "value1", span1)] + extractSpans value1 `shouldBe` [(IdeNamespaced IdeNSValue "value1", span1)] it "extracts a span for a type synonym declaration" $ - extractSpans span0 (P.PositionedDeclaration span1 [] synonym1) `shouldBe` [(IdeNamespaced IdeNSType "Synonym1", span1)] + extractSpans synonym1 `shouldBe` [(IdeNamespaced IdeNSType "Synonym1", span1)] it "extracts a span for a typeclass declaration" $ - extractSpans span0 (P.PositionedDeclaration span1 [] class1) `shouldBe` [(IdeNamespaced IdeNSType "Class1", span1)] + extractSpans class1 `shouldBe` [(IdeNamespaced IdeNSType "Class1", span1)] it "extracts spans for a typeclass declaration and its members" $ - extractSpans span0 (P.PositionedDeclaration span1 [] class2) `shouldBe` [(IdeNamespaced IdeNSType "Class2", span1), (IdeNamespaced IdeNSValue "member1", span2)] + extractSpans class2 `shouldBe` [(IdeNamespaced IdeNSType "Class2", span1), (IdeNamespaced IdeNSValue "member1", span2)] it "extracts a span for a data declaration" $ - extractSpans span0 (P.PositionedDeclaration span1 [] data1) `shouldBe` [(IdeNamespaced IdeNSType "Data1", span1)] + extractSpans data1 `shouldBe` [(IdeNamespaced IdeNSType "Data1", span1)] it "extracts spans for a data declaration and its constructors" $ - extractSpans span0 (P.PositionedDeclaration span1 [] data2) `shouldBe` [(IdeNamespaced IdeNSType "Data2", span1), (IdeNamespaced IdeNSValue "Cons1", span1)] + extractSpans data2 `shouldBe` [(IdeNamespaced IdeNSType "Data2", span1), (IdeNamespaced IdeNSValue "Cons1", span1)] it "extracts a span for a value operator fixity declaration" $ - extractSpans span0 (P.PositionedDeclaration span1 [] valueFixity) `shouldBe` [(IdeNamespaced IdeNSValue "<$>", span1)] + extractSpans valueFixity `shouldBe` [(IdeNamespaced IdeNSValue "<$>", span1)] it "extracts a span for a type operator fixity declaration" $ - extractSpans span0 (P.PositionedDeclaration span1 [] typeFixity) `shouldBe` [(IdeNamespaced IdeNSType "~>", span1)] + extractSpans typeFixity `shouldBe` [(IdeNamespaced IdeNSType "~>", span1)] it "extracts a span for a foreign declaration" $ - extractSpans span0 (P.PositionedDeclaration span1 [] foreign1) `shouldBe` [(IdeNamespaced IdeNSValue "foreign1", span1)] + extractSpans foreign1 `shouldBe` [(IdeNamespaced IdeNSValue "foreign1", span1)] it "extracts a span for a data foreign declaration" $ - extractSpans span0 (P.PositionedDeclaration span1 [] foreign2) `shouldBe` [(IdeNamespaced IdeNSType "Foreign2", span1)] + extractSpans foreign2 `shouldBe` [(IdeNamespaced IdeNSType "Foreign2", span1)] it "extracts a span for a foreign kind declaration" $ - extractSpans span0 (P.PositionedDeclaration span1 [] foreign3) `shouldBe` [(IdeNamespaced IdeNSKind "Foreign3", span1)] + extractSpans foreign3 `shouldBe` [(IdeNamespaced IdeNSKind "Foreign3", span1)] describe "Type annotations" $ do it "extracts a type annotation" $ extractTypeAnnotations [typeAnnotation1] `shouldBe` [(P.Ident "value1", P.REmpty)] @@ -98,7 +104,7 @@ [ ("Test", [ ideValue "sfValue" Nothing `annLoc` valueSS , ideSynonym "SFType" Nothing Nothing `annLoc` synonymSS - , ideType "SFData" Nothing `annLoc` typeSS + , ideType "SFData" Nothing [] `annLoc` typeSS , ideDtor "SFOne" "SFData" Nothing `annLoc` typeSS , ideDtor "SFTwo" "SFData" Nothing `annLoc` typeSS , ideDtor "SFThree" "SFData" Nothing `annLoc` typeSS @@ -109,14 +115,3 @@ `annLoc` typeOpSS ]) ] - -valueSS, synonymSS, typeSS, classSS, valueOpSS, typeOpSS :: P.SourceSpan -valueSS = ss 3 1 -synonymSS = ss 5 1 -typeSS = ss 7 1 -classSS = ss 8 1 -valueOpSS = ss 12 1 -typeOpSS = ss 13 1 - -ss :: Int -> Int -> P.SourceSpan -ss x y = P.SourceSpan "Test.purs" (P.SourcePos x y) (P.SourcePos x y) diff --git a/tests/Language/PureScript/Ide/StateSpec.hs b/tests/Language/PureScript/Ide/StateSpec.hs --- a/tests/Language/PureScript/Ide/StateSpec.hs +++ b/tests/Language/PureScript/Ide/StateSpec.hs @@ -13,27 +13,26 @@ valueOperator :: Maybe P.Type -> IdeDeclarationAnn valueOperator = - d . IdeDeclValueOperator . IdeValueOperator (P.OpName "<$>") (P.Qualified (Just (mn "Test")) (Left (P.Ident "function"))) 2 P.Infix + ideValueOp "<$>" (P.Qualified (Just (mn "Test")) (Left "function")) 2 Nothing ctorOperator :: Maybe P.Type -> IdeDeclarationAnn ctorOperator = - d . IdeDeclValueOperator . IdeValueOperator (P.OpName ":") (P.Qualified (Just (mn "Test")) (Right (P.ProperName "Cons"))) 2 P.Infix + ideValueOp ":" (P.Qualified (Just (mn "Test")) (Right "Cons")) 2 Nothing typeOperator :: Maybe P.Kind -> IdeDeclarationAnn typeOperator = - d . IdeDeclTypeOperator . IdeTypeOperator (P.OpName ":") (P.Qualified (Just (mn "Test")) (P.ProperName "List")) 2 P.Infix + ideTypeOp ":" (P.Qualified (Just (mn "Test")) "List") 2 Nothing testModule :: (P.ModuleName, [IdeDeclarationAnn]) -testModule = (mn "Test", [ d (IdeDeclValue (IdeValue (P.Ident "function") P.REmpty)) - , d (IdeDeclDataConstructor (IdeDataConstructor (P.ProperName "Cons") (P.ProperName "List") (P.REmpty))) - , d (IdeDeclType (IdeType (P.ProperName "List") P.kindType)) - , valueOperator Nothing - , ctorOperator Nothing - , typeOperator Nothing - ]) - -d :: IdeDeclaration -> IdeDeclarationAnn -d = IdeDeclarationAnn emptyAnn +testModule = + (mn "Test", + [ ideValue "function" (Just P.REmpty) + , ideDtor "Cons" "List" (Just P.tyString) + , ideType "List" Nothing [] + , valueOperator Nothing + , ctorOperator Nothing + , typeOperator Nothing + ]) testState :: ModuleMap [IdeDeclarationAnn] testState = Map.fromList [testModule] @@ -81,7 +80,7 @@ it "resolves the type for a value operator" $ resolveOperatorsForModule testState (snd testModule) `shouldSatisfy` elem (valueOperator (Just P.REmpty)) it "resolves the type for a constructor operator" $ - resolveOperatorsForModule testState (snd testModule) `shouldSatisfy` elem (ctorOperator (Just P.REmpty)) + resolveOperatorsForModule testState (snd testModule) `shouldSatisfy` elem (ctorOperator (Just P.tyString)) it "resolves the kind for a type operator" $ resolveOperatorsForModule testState (snd testModule) `shouldSatisfy` elem (typeOperator (Just P.kindType)) describe "resolving instances for type classes" $ do @@ -89,3 +88,8 @@ resolveInstances (Map.singleton (mn "InstanceModule") ef) moduleMap `shouldSatisfy` elemOf (ix (mn "ClassModule") . ix 0 . idaDeclaration . _IdeDeclTypeClass . ideTCInstances . folded) ideInstance + describe "resolving data constructors" $ do + it "resolves a constructor" $ do + resolveDataConstructorsForModule (snd testModule) + `shouldSatisfy` + elem (ideType "List" Nothing [(P.ProperName "Cons", P.tyString)]) diff --git a/tests/Language/PureScript/Ide/Test.hs b/tests/Language/PureScript/Ide/Test.hs --- a/tests/Language/PureScript/Ide/Test.hs +++ b/tests/Language/PureScript/Ide/Test.hs @@ -1,6 +1,7 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PackageImports #-} +{-# LANGUAGE DataKinds #-} module Language.PureScript.Ide.Test where import Control.Concurrent.STM @@ -63,8 +64,8 @@ ideValue :: Text -> Maybe P.Type -> IdeDeclarationAnn ideValue i ty = ida (IdeDeclValue (IdeValue (P.Ident i) (fromMaybe P.tyString ty))) -ideType :: Text -> Maybe P.Kind -> IdeDeclarationAnn -ideType pn ki = ida (IdeDeclType (IdeType (P.ProperName pn) (fromMaybe P.kindType ki))) +ideType :: Text -> Maybe P.Kind -> [(P.ProperName 'P.ConstructorName, P.Type)] -> IdeDeclarationAnn +ideType pn ki dtors = ida (IdeDeclType (IdeType (P.ProperName pn) (fromMaybe P.kindType ki) dtors)) ideSynonym :: Text -> Maybe P.Type -> Maybe P.Kind -> IdeDeclarationAnn ideSynonym pn ty kind = ida (IdeDeclTypeSynonym (IdeTypeSynonym (P.ProperName pn) (fromMaybe P.tyString ty) (fromMaybe P.kindType kind))) @@ -97,6 +98,17 @@ ideKind :: Text -> IdeDeclarationAnn ideKind pn = ida (IdeDeclKind (P.ProperName pn)) + +valueSS, synonymSS, typeSS, classSS, valueOpSS, typeOpSS :: P.SourceSpan +valueSS = ss 3 1 +synonymSS = ss 5 1 +typeSS = ss 7 1 +classSS = ss 8 1 +valueOpSS = ss 12 1 +typeOpSS = ss 13 1 + +ss :: Int -> Int -> P.SourceSpan +ss x y = P.SourceSpan "Test.purs" (P.SourcePos x y) (P.SourcePos x y) mn :: Text -> P.ModuleName mn = P.moduleNameFromString diff --git a/tests/TestDocs.hs b/tests/TestDocs.hs --- a/tests/TestDocs.hs +++ b/tests/TestDocs.hs @@ -13,7 +13,6 @@ import Control.Monad.IO.Class (liftIO) import Data.Foldable -import Data.List ((\\)) import Data.Maybe (fromMaybe) import Data.Monoid import Data.Text (Text) @@ -99,7 +98,7 @@ data AssertionFailure -- | A declaration was not documented, but should have been = NotDocumented P.ModuleName Text - -- | A child declaration was not documented, but should have been + -- | The expected list of child declarations did not match the actual list | ChildrenNotDocumented P.ModuleName Text [Text] -- | A declaration was documented, but should not have been | Documented P.ModuleName Text @@ -152,9 +151,9 @@ Nothing -> Fail (NotDocumented mn decl) Just actualChildren -> - case children \\ actualChildren of - [] -> Pass - cs -> Fail (ChildrenNotDocumented mn decl cs) + if children == actualChildren + then Pass + else Fail (ChildrenNotDocumented mn decl actualChildren) ShouldNotBeDocumented mn decl -> case findChildren decl (declarationsFor mn) of @@ -405,6 +404,11 @@ , ("Desugar", [ ValueShouldHaveTypeSignature (n "Desugar") "test" (renderedType "forall a b. X (a -> b) a -> b") + ]) + + , ("ChildDeclOrder", + [ ShouldBeDocumented (n "ChildDeclOrder") "Two" ["First", "Second", "showTwo", "fooTwo"] + , ShouldBeDocumented (n "ChildDeclOrder") "Foo" ["foo1", "foo2", "fooTwo", "fooInt"] ]) ] diff --git a/tests/support/bower.json b/tests/support/bower.json --- a/tests/support/bower.json +++ b/tests/support/bower.json @@ -8,13 +8,14 @@ "purescript-functions": "3.0.0", "purescript-generics": "4.0.0", "purescript-generics-rep": "5.0.0", + "purescript-lists": "4.6.0", "purescript-newtype": "2.0.0", "purescript-partial": "1.2.0", "purescript-prelude": "3.0.0", "purescript-psci-support": "3.0.0", "purescript-st": "3.0.0", "purescript-symbols": "3.0.0", - "purescript-tailrec": "3.0.0", + "purescript-tailrec": "3.3.0", "purescript-typelevel-prelude": "2.0.0", "purescript-unsafe-coerce": "3.0.0" }