summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorPhilFreeman <>2017-07-10 20:00:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2017-07-10 20:00:00 (GMT)
commitbc80a9937fd209e5553541b5abddf8010f1e3b31 (patch)
treed4a4950483623e8b4fbea6207ebd0615a915c3d3
parent365104aef9239bb6b25980ffbeba1a1b5682ba78 (diff)
version 0.11.60.11.6
-rw-r--r--app/Command/Docs/Tags.hs26
-rw-r--r--app/Command/Hierarchy.hs5
-rw-r--r--app/Command/REPL.hs6
-rw-r--r--app/static/pursuit.css4
-rw-r--r--examples/docs/src/ChildDeclOrder.purs27
-rw-r--r--examples/passing/2972.purs13
-rw-r--r--purescript.cabal2056
-rw-r--r--src/Language/PureScript/AST/Declarations.hs200
-rw-r--r--src/Language/PureScript/AST/Exported.hs43
-rw-r--r--src/Language/PureScript/AST/SourcePos.hs37
-rw-r--r--src/Language/PureScript/AST/Traversals.hs192
-rw-r--r--src/Language/PureScript/CodeGen/JS.hs17
-rw-r--r--src/Language/PureScript/Constants.hs14
-rw-r--r--src/Language/PureScript/CoreFn/Ann.hs8
-rw-r--r--src/Language/PureScript/CoreFn/Desugar.hs126
-rw-r--r--src/Language/PureScript/Docs/AsHtml.hs21
-rw-r--r--src/Language/PureScript/Docs/Convert.hs6
-rw-r--r--src/Language/PureScript/Docs/Convert/Single.hs99
-rw-r--r--src/Language/PureScript/Errors.hs33
-rw-r--r--src/Language/PureScript/Externs.hs24
-rw-r--r--src/Language/PureScript/Ide.hs19
-rw-r--r--src/Language/PureScript/Ide/CaseSplit.hs5
-rw-r--r--src/Language/PureScript/Ide/Completion.hs10
-rw-r--r--src/Language/PureScript/Ide/Externs.hs67
-rw-r--r--src/Language/PureScript/Ide/Filter.hs14
-rw-r--r--src/Language/PureScript/Ide/Filter/Declaration.hs55
-rw-r--r--src/Language/PureScript/Ide/Imports.hs25
-rw-r--r--src/Language/PureScript/Ide/Prim.hs20
-rw-r--r--src/Language/PureScript/Ide/Rebuild.hs2
-rw-r--r--src/Language/PureScript/Ide/Reexports.hs12
-rw-r--r--src/Language/PureScript/Ide/SourceFile.hs45
-rw-r--r--src/Language/PureScript/Ide/State.hs35
-rw-r--r--src/Language/PureScript/Ide/Types.hs15
-rw-r--r--src/Language/PureScript/Ide/Util.hs10
-rw-r--r--src/Language/PureScript/Interactive.hs24
-rw-r--r--src/Language/PureScript/Interactive/Completion.hs17
-rw-r--r--src/Language/PureScript/Interactive/Module.hs18
-rw-r--r--src/Language/PureScript/Interactive/Parser.hs6
-rw-r--r--src/Language/PureScript/Interactive/Types.hs2
-rw-r--r--src/Language/PureScript/Linter.hs17
-rw-r--r--src/Language/PureScript/Linter/Exhaustive.hs69
-rw-r--r--src/Language/PureScript/Linter/Imports.hs87
-rw-r--r--src/Language/PureScript/Make.hs4
-rw-r--r--src/Language/PureScript/ModuleDependencies.hs18
-rw-r--r--src/Language/PureScript/Parser/Common.hs13
-rw-r--r--src/Language/PureScript/Parser/Declarations.hs148
-rw-r--r--src/Language/PureScript/Pretty/Values.hs13
-rw-r--r--src/Language/PureScript/Sugar/BindingGroups.hs59
-rw-r--r--src/Language/PureScript/Sugar/CaseDeclarations.hs76
-rw-r--r--src/Language/PureScript/Sugar/DoNotation.hs8
-rw-r--r--src/Language/PureScript/Sugar/LetPattern.hs9
-rw-r--r--src/Language/PureScript/Sugar/Names.hs176
-rw-r--r--src/Language/PureScript/Sugar/Names/Common.hs32
-rw-r--r--src/Language/PureScript/Sugar/Names/Env.hs24
-rw-r--r--src/Language/PureScript/Sugar/Names/Exports.hs62
-rw-r--r--src/Language/PureScript/Sugar/Names/Imports.hs134
-rw-r--r--src/Language/PureScript/Sugar/ObjectWildcards.hs5
-rw-r--r--src/Language/PureScript/Sugar/Operators.hs86
-rw-r--r--src/Language/PureScript/Sugar/TypeClasses.hs64
-rwxr-xr-xsrc/Language/PureScript/Sugar/TypeClasses/Deriving.hs158
-rw-r--r--src/Language/PureScript/Sugar/TypeDeclarations.hs32
-rw-r--r--src/Language/PureScript/TypeChecker.hs141
-rw-r--r--src/Language/PureScript/TypeChecker/Entailment.hs31
-rw-r--r--src/Language/PureScript/TypeChecker/Types.hs99
-rw-r--r--tests/Language/PureScript/Ide/CompletionSpec.hs2
-rw-r--r--tests/Language/PureScript/Ide/FilterSpec.hs79
-rw-r--r--tests/Language/PureScript/Ide/ImportsSpec.hs4
-rw-r--r--tests/Language/PureScript/Ide/ReexportsSpec.hs23
-rw-r--r--tests/Language/PureScript/Ide/SourceFileSpec.hs65
-rw-r--r--tests/Language/PureScript/Ide/StateSpec.hs32
-rw-r--r--tests/Language/PureScript/Ide/Test.hs16
-rw-r--r--tests/TestDocs.hs14
-rw-r--r--tests/support/bower.json3
73 files changed, 2670 insertions, 2491 deletions
diff --git a/app/Command/Docs/Tags.hs b/app/Command/Docs/Tags.hs
index 6f15169..6fd3275 100644
--- a/app/Command/Docs/Tags.hs
+++ b/app/Command/Docs/Tags.hs
@@ -6,16 +6,16 @@ import qualified Language.PureScript as P
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
index 90f3226..d06918e 100644
--- a/app/Command/Hierarchy.hs
+++ b/app/Command/Hierarchy.hs
@@ -84,10 +84,9 @@ compile (HierarchyOptions inputGlob mOutput) = do
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
index 9b8ad12..1b81994 100644
--- a/app/Command/REPL.hs
+++ b/app/Command/REPL.hs
@@ -57,7 +57,7 @@ import qualified Data.ByteString.Lazy.UTF8 as U
-- | Command line options
data PSCiOptions = PSCiOptions
- { psciInputFile :: [FilePath]
+ { psciInputGlob :: [String]
, psciBackend :: Backend
}
@@ -310,7 +310,7 @@ command = loop <$> options
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 @@ command = loop <$> options
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
index e0c7f6e..d250c36 100644
--- a/app/static/pursuit.css
+++ b/app/static/pursuit.css
@@ -413,6 +413,10 @@ ol li {
.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
index 0000000..7f67785
--- /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
index 0000000..fbf961e
--- /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
index 159e03c..9754981 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -1,1049 +1,1053 @@
--- This file has been generated from package.yaml by hpack version 0.17.0.
+-- 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.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 <paf31@cantab.net>
-stability: experimental
-homepage: http://www.purescript.org/
-bug-reports: https://github.com/purescript/purescript/issues
+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 <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>, Hardy Jones <jones3.hardy@gmail.com>, Harry Garrood <harry@garrood.me>, Christoph Hegemann <christoph.hegemann1337@gmail.com>
+maintainer: Phil Freeman <paf31@cantab.net>
+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/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
+ 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
+ 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)
+ description: Mark this build as a release build: prevents inclusion of extra info e.g. commit SHA in --version output)
- manual: False
- default: False
+ 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
+ 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:
- 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
+ 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
- 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
+ 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
index c067e5a..d897ee0 100644
--- a/src/Language/PureScript/AST/Declarations.hs
+++ b/src/Language/PureScript/AST/Declarations.hs
@@ -14,6 +14,7 @@ import Control.Monad.Identity
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.TypeClassDictionaries
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 @@ data ErrorMessageHint
| 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 @@ getModuleSourceSpan (Module ss _ _ _ _) = ss
-- |
-- 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 @@ data DeclarationRef
-- |
-- 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 @@ data Declaration
-- |
-- 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 ValueFixity = ValueFixity Fixity (Qualified (Either Ident (ProperName 'Cons
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 :: (Applicative f) => ([Declaration] -> f [Declaration]
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 @@ isValueDecl _ = False
isDataDecl :: Declaration -> Bool
isDataDecl DataDeclaration{} = True
isDataDecl TypeSynonymDeclaration{} = True
-isDataDecl (PositionedDeclaration _ _ d) = isDataDecl d
isDataDecl _ = False
-- |
@@ -506,7 +526,6 @@ isDataDecl _ = False
--
isImportDecl :: Declaration -> Bool
isImportDecl ImportDeclaration{} = True
-isImportDecl (PositionedDeclaration _ _ d) = isImportDecl d
isImportDecl _ = False
-- |
@@ -514,7 +533,6 @@ isImportDecl _ = False
--
isExternDataDecl :: Declaration -> Bool
isExternDataDecl ExternDataDeclaration{} = True
-isExternDataDecl (PositionedDeclaration _ _ d) = isExternDataDecl d
isExternDataDecl _ = False
-- |
@@ -522,7 +540,6 @@ isExternDataDecl _ = False
--
isExternKindDecl :: Declaration -> Bool
isExternKindDecl ExternKindDeclaration{} = True
-isExternKindDecl (PositionedDeclaration _ _ d) = isExternKindDecl d
isExternKindDecl _ = False
-- |
@@ -530,12 +547,10 @@ isExternKindDecl _ = False
--
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 @@ getFixityDecl _ = Nothing
--
isExternDecl :: Declaration -> Bool
isExternDecl ExternDeclaration{} = True
-isExternDecl (PositionedDeclaration _ _ d) = isExternDecl d
isExternDecl _ = False
-- |
@@ -551,7 +565,6 @@ isExternDecl _ = False
--
isTypeClassInstanceDeclaration :: Declaration -> Bool
isTypeClassInstanceDeclaration TypeInstanceDeclaration{} = True
-isTypeClassInstanceDeclaration (PositionedDeclaration _ _ d) = isTypeClassInstanceDeclaration d
isTypeClassInstanceDeclaration _ = False
-- |
@@ -559,7 +572,6 @@ isTypeClassInstanceDeclaration _ = False
--
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
index 759b9a3..1e5b033 100644
--- a/src/Language/PureScript/AST/Exported.hs
+++ b/src/Language/PureScript/AST/Exported.hs
@@ -38,11 +38,9 @@ exportedDeclarations (Module _ _ mn decls exps) = go decls
-- 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 @@ filterInstances mn (Just exps) =
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 @@ typeInstanceConstituents (TypeInstanceDeclaration _ constraints className tys _)
go (ConstrainedType c _) = fromConstraint c
go _ = []
-typeInstanceConstituents (PositionedDeclaration _ _ d) = typeInstanceConstituents d
typeInstanceConstituents _ = []
@@ -124,21 +119,18 @@ typeInstanceConstituents _ = []
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 :: ProperName 'TypeName -> Maybe [DeclarationRef] -> ProperName
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
index 55bcc23..f208dee 100644
--- a/src/Language/PureScript/AST/SourcePos.hs
+++ b/src/Language/PureScript/AST/SourcePos.hs
@@ -6,27 +6,25 @@ module Language.PureScript.AST.SourcePos where
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 @@ instance A.FromJSON SourcePos where
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
index d1a8ce5..3fe55a8 100644
--- a/src/Language/PureScript/AST/Traversals.hs
+++ b/src/Language/PureScript/AST/Traversals.hs
@@ -10,6 +10,7 @@ import Control.Monad
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,7 +34,12 @@ mapGuardedExpr :: (Guard -> Guard)
-> 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)
@@ -46,13 +52,12 @@ everywhereOnValues
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 @@ everywhereOnValues f g h = (f', g', h')
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 @@ everywhereOnValues f g h = (f', g', h')
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 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h)
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 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h)
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 @@ everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h)
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 @@ everywhereOnValuesM f g h = (f', g', h')
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 @@ everywhereOnValuesM f g h = (f', g', h')
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 @@ everywhereOnValuesM f g h = (f', g', h')
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 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j')
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 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j')
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 @@ everythingOnValues (<>) f g h i j = (f', g', h', i', j')
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 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i'
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 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i'
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 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i'
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 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i'
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 @@ everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i'
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 @@ everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j
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 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s)
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 @@ everythingWithScope f g h i j = (f'', g'', h'', i'', \s -> snd . j'' s)
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
)
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
)
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 @@ overTypes f = let (_, f', _) = everywhereOnValues id g id in f'
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
index 4a67550..de11a87 100644
--- a/src/Language/PureScript/CodeGen/JS.hs
+++ b/src/Language/PureScript/CodeGen/JS.hs
@@ -146,13 +146,12 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
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 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
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 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
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 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
-- | 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 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ =
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
index 0f2fd00..73341f8 100644
--- a/src/Language/PureScript/Constants.hs
+++ b/src/Language/PureScript/Constants.hs
@@ -359,6 +359,20 @@ orderingEQ = Qualified (Just typeDataOrdering) (ProperName "EQ")
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
index 823a755..5d5b96f 100644
--- a/src/Language/PureScript/CoreFn/Ann.hs
+++ b/src/Language/PureScript/CoreFn/Ann.hs
@@ -10,13 +10,13 @@ import Language.PureScript.Types
-- |
-- 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
index 800c630..f0a681e 100644
--- a/src/Language/PureScript/CoreFn/Desugar.hs
+++ b/src/Language/PureScript/CoreFn/Desugar.hs
@@ -9,6 +9,7 @@ import Data.Function (on)
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 @@ import qualified Language.PureScript.AST as A
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 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) =
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 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) =
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 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) =
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 @@ moduleToCoreFn env (A.Module _ coms mn decls (Just exps)) =
-- | 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 @@ findQualModules decls =
-- | 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
index c3eec5b..c33109f 100644
--- a/src/Language/PureScript/Docs/AsHtml.hs
+++ b/src/Language/PureScript/Docs/AsHtml.hs
@@ -163,11 +163,16 @@ declAsHtml r d@Declaration{..} = do
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
@@ -184,8 +189,9 @@ codeAsHtml r = outputWith elemAsHtml
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 @@ withClass className content = H.span ! A.class_ (fromString className) $ content
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
index 8aaf43c..2057a1e 100644
--- a/src/Language/PureScript/Docs/Convert.hs
+++ b/src/Language/PureScript/Docs/Convert.hs
@@ -20,7 +20,6 @@ import Language.PureScript.Docs.Convert.ReExports (updateReExports)
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,12 +86,9 @@ convertModulesWithEnv ::
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
-- modules and the Env produced during desugaring.
diff --git a/src/Language/PureScript/Docs/Convert/Single.hs b/src/Language/PureScript/Docs/Convert/Single.hs
index 0c4ce09..5c1e6ef 100644
--- a/src/Language/PureScript/Docs/Convert/Single.hs
+++ b/src/Language/PureScript/Docs/Convert/Single.hs
@@ -82,66 +82,63 @@ augmentDeclarations (partitionEithers -> (augments, toplevels)) =
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 @@ convertDeclaration (P.TypeInstanceDeclaration _ constraints className tys _) tit
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
index 742640a..474dc37 100644
--- a/src/Language/PureScript/Errors.hs
+++ b/src/Language/PureScript/Errors.hs
@@ -19,6 +19,7 @@ import Data.Either (partitionEithers)
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 @@ nonEmpty = not . null . runMultipleErrors
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 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl
]
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 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl
-- 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 @@ prettyPrintImport mn idt qual =
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
index 7a72099..4b64631 100644
--- a/src/Language/PureScript/Externs.hs
+++ b/src/Language/PureScript/Externs.hs
@@ -178,28 +178,24 @@ moduleToExternsFile (Module ss _ mn ds (Just exps)) env = ExternsFile{..}
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 @@ moduleToExternsFile (Module ss _ mn ds (Just exps)) env = ExternsFile{..}
, (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 @@ moduleToExternsFile (Module ss _ mn ds (Just exps)) env = ExternsFile{..}
, 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
index 7d232e6..c566fa5 100644
--- 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 Protolude
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.Externs
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 @@ import System.FilePath.Glob (glob)
-- | 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 @@ findCompletions
-> 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 @@ loadModules moduleNames = do
(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
index 460ea91..033120b 100644
--- a/src/Language/PureScript/Ide/CaseSplit.hs
+++ b/src/Language/PureScript/Ide/CaseSplit.hs
@@ -30,7 +30,6 @@ import Language.PureScript.Externs
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 @@ parseTypeDeclaration' s =
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
index 0b81812..44a4ac6 100644
--- a/src/Language/PureScript/Ide/Completion.hs
+++ b/src/Language/PureScript/Ide/Completion.hs
@@ -76,11 +76,11 @@ defaultCompletionOptions :: CompletionOptions
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
index b6315a8..0e9e17f 100644
--- a/src/Language/PureScript/Ide/Externs.hs
+++ b/src/Language/PureScript/Ide/Externs.hs
@@ -28,12 +28,13 @@ import qualified Data.ByteString as BS
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 @@ convertExterns ef =
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 @@ data ToResolve
| 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
index ae469d6..cdb29f4 100644
--- 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 Protolude hiding (isPrefixOf)
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 :: (IdeDeclaration -> Text -> Bool) -> Text -> [Module] -> [Mo
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 @@ instance FromJSON Filter where
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
index 0000000..f92b51e
--- /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
index a38f56d..1714b8e 100644
--- a/src/Language/PureScript/Ide/Imports.hs
+++ b/src/Language/PureScript/Ide/Imports.hs
@@ -93,7 +93,7 @@ parseModuleHeader = do
(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 @@ addExplicitImport' decl moduleName imports =
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 @@ addExplicitImport' decl moduleName imports =
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 "<psc-ide>"
+
updateAtFirstOrPrepend :: (a -> Bool) -> (a -> a) -> a -> [a] -> [a]
updateAtFirstOrPrepend p t d l =
case findIndex p l of
@@ -336,6 +339,6 @@ parseImport t =
case P.lex "<psc-ide>" t
>>= P.runTokenParser "<psc-ide>" 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
index 0000000..5519ad9
--- /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
index a26f4e5..a7e765b 100644
--- a/src/Language/PureScript/Ide/Rebuild.hs
+++ b/src/Language/PureScript/Ide/Rebuild.hs
@@ -176,7 +176,7 @@ sortExterns m ex = do
mkShallowModule P.ExternsFile{..} =
P.Module (P.internalModuleSourceSpan "<rebuild>") [] efModuleName (map mkImport efImports) Nothing
mkImport (P.ExternsImport mn it iq) =
- P.ImportDeclaration mn it iq
+ P.ImportDeclaration (P.internalModuleSourceSpan "<rebuild>", []) 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
index f36f04e..0a8b1de 100644
--- a/src/Language/PureScript/Ide/Reexports.hs
+++ b/src/Language/PureScript/Ide/Reexports.hs
@@ -92,7 +92,7 @@ resolveRef
-> 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 @@ resolveRef decls ref = case ref of
-- 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
index 23ec014..8a03a5a 100644
--- a/src/Language/PureScript/Ide/SourceFile.hs
+++ b/src/Language/PureScript/Ide/SourceFile.hs
@@ -59,8 +59,8 @@ parseModulesFromFiles paths = do
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 @@ extractTypeAnnotations
-> [(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 @@ extractSpans ss d = case d of
-- 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
index 86d30fa..81c290c 100644
--- a/src/Language/PureScript/Ide/State.hs
+++ b/src/Language/PureScript/Ide/State.hs
@@ -30,6 +30,7 @@ module Language.PureScript.Ide.State
-- for tests
, resolveOperatorsForModule
, resolveInstances
+ , resolveDataConstructorsForModule
) where
import Protolude
@@ -82,7 +83,7 @@ insertModuleSTM ref (fp, module') =
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,7 +94,11 @@ getFileStateSTM ref = ideFileState <$> readTVar ref
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 ()
@@ -172,14 +177,17 @@ populateVolatileStateSTM
-> 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 @@ resolveOperatorsForModule modules = map (idaDeclaration %~ resolveOperator)
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
index 2a7a93a..c951e49 100644
--- a/src/Language/PureScript/Ide/Types.hs
+++ b/src/Language/PureScript/Ide/Types.hs
@@ -48,6 +48,7 @@ data IdeValue = IdeValue
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 @@ instance ToJSON Completion where
, "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
index 1d8f68f..5e84626 100644
--- 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
@@ -92,14 +90,6 @@ encodeT = TL.toStrict . TLE.decodeUtf8 . encode
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
index 9d91c24..ac24735 100644
--- a/src/Language/PureScript/Interactive.hs
+++ b/src/Language/PureScript/Interactive.hs
@@ -40,6 +40,7 @@ import Language.PureScript.Interactive.Types as Interactive
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 @@ handleReloadState
-> 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 @@ handleShowImportedModules print' = do
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
index 5f891ae..dd94c74 100644
--- a/src/Language/PureScript/Interactive/Completion.hs
+++ b/src/Language/PureScript/Interactive/Completion.hs
@@ -197,28 +197,25 @@ typeDecls :: P.Module -> [(N.ProperName 'N.TypeName, P.Declaration)]
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
index a69448a..1837798 100644
--- a/src/Language/PureScript/Interactive/Module.hs
+++ b/src/Language/PureScript/Interactive/Module.hs
@@ -51,17 +51,16 @@ createTemporaryModule exec PSCiState{psciImportedModules = imports, psciLetBindi
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 "<internal>"
in
P.Module internalSpan
[] moduleName
@@ -76,9 +75,9 @@ createTemporaryModuleForKind :: PSCiState -> P.Type -> P.Module
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 "<internal>") [] 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 @@ createTemporaryModuleForImports PSCiState{psciImportedModules = imports} =
let
moduleName = P.ModuleName [P.ProperName "$PSCI"]
in
- P.Module (P.internalModuleSourceSpan "<internal>") [] 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 "<internal>"
diff --git a/src/Language/PureScript/Interactive/Parser.hs b/src/Language/PureScript/Interactive/Parser.hs
index a29c110..6f0fc18 100644
--- a/src/Language/PureScript/Interactive/Parser.hs
+++ b/src/Language/PureScript/Interactive/Parser.hs
@@ -88,15 +88,11 @@ psciImport = do
-- (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
acceptable P.TypeSynonymDeclaration{} = True
diff --git a/src/Language/PureScript/Interactive/Types.hs b/src/Language/PureScript/Interactive/Types.hs
index f54ee37..3ab26a6 100644
--- a/src/Language/PureScript/Interactive/Types.hs
+++ b/src/Language/PureScript/Interactive/Types.hs
@@ -12,7 +12,7 @@ import qualified Language.PureScript as P
-- 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
index d26f361..a1f99a7 100644
--- a/src/Language/PureScript/Linter.hs
+++ b/src/Language/PureScript/Linter.hs
@@ -32,11 +32,10 @@ lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDecl
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 @@ lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDecl
(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
index af9db13..a8a21f8 100644
--- a/src/Language/PureScript/Linter/Exhaustive.hs
+++ b/src/Language/PureScript/Linter/Exhaustive.hs
@@ -242,13 +242,14 @@ missingAlternative env mn ca uncovered
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 @@ checkExhaustive env mn numArgs cas expr = makeResult . first ordNub $ foldl' ste
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 @@ checkExhaustive env mn numArgs cas expr = makeResult . first ordNub $ foldl' ste
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 @@ checkExhaustive env mn numArgs cas expr = makeResult . first ordNub $ foldl' ste
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
-
- onCaseAlternative :: CaseAlternative -> m CaseAlternative
- onCaseAlternative (CaseAlternative x [MkUnguarded e]) = CaseAlternative x . mkUnguardedExpr <$> onExpr e
- onCaseAlternative (CaseAlternative x es) = CaseAlternative x <$> mapM onGuardedExpr es
-
- onGuardedExpr :: GuardedExpr -> m GuardedExpr
- onGuardedExpr (GuardedExpr guard rhs) = GuardedExpr guard <$> onExpr rhs
+ 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 :: 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 :: 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
index 680ca09..bba9e26 100644
--- a/src/Language/PureScript/Linter/Imports.hs
+++ b/src/Language/PureScript/Linter/Imports.hs
@@ -13,7 +13,7 @@ import Control.Monad.Writer.Class
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 @@ lintImports
-> 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 @@ lintImports (Module ss _ mn mdecls (Just mexports)) env usedImps = do
$ 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 @@ lintImports (Module ss _ mn mdecls (Just mexports)) env usedImps = do
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 @@ lintImports (Module ss _ mn mdecls (Just mexports)) env usedImps = do
-- 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 @@ lintImports (Module ss _ mn mdecls (Just mexports)) env usedImps = do
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 @@ lintImportDecl
-> 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 @@ lintImportDecl env mni qualifierName names declType allowImplicit =
-- 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 @@ lintImportDecl env mni qualifierName names declType allowImplicit =
(_, []) | 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 @@ lintImportDecl env mni qualifierName names declType allowImplicit =
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 @@ lintImportDecl env mni qualifierName names declType allowImplicit =
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 @@ lintImportDecl env mni qualifierName names declType allowImplicit =
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 _ ModName{} = Nothing
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
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
index 18a7b4f..e2f9d46 100644
--- a/src/Language/PureScript/Make.hs
+++ b/src/Language/PureScript/Make.hs
@@ -68,7 +68,6 @@ import qualified Language.JavaScript.Parser as JS
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
@@ -259,9 +258,6 @@ make ma@MakeActions{..} ms = do
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
{ unMake :: ReaderT Options (ExceptT MultipleErrors (Logger MultipleErrors)) a
diff --git a/src/Language/PureScript/ModuleDependencies.hs b/src/Language/PureScript/ModuleDependencies.hs
index 21885b0..a270c3e 100644
--- a/src/Language/PureScript/ModuleDependencies.hs
+++ b/src/Language/PureScript/ModuleDependencies.hs
@@ -4,9 +4,10 @@ module Language.PureScript.ModuleDependencies
, 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 @@ sortModules ms = do
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
index 5030033..4eb5bb6 100644
--- a/src/Language/PureScript/Parser/Common.hs
+++ b/src/Language/PureScript/Parser/Common.hs
@@ -133,8 +133,8 @@ withSourceSpan
-> 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 @@ withSourceSpan f p = do
_ -> 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
index e72f534..1dbb9d5 100644
--- a/src/Language/PureScript/Parser/Declarations.hs
+++ b/src/Language/PureScript/Parser/Declarations.hs
@@ -24,6 +24,7 @@ import Control.Monad.Error.Class (MonadError(..))
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 @@ kindedIdent = (, Nothing) <$> identifier
<|> 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 @@ parseValueWithWhereClause = do
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 @@ parseValueWithIdentAndBinders ident bs = do
<*> (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 :: TokenParser Fixity
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 @@ parseFixityDeclaration = do
<*> (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 @@ parseImportDeclaration' = do
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 @@ parseTypeClassDeclaration = do
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 @@ parseConstraint = Constraint <$> parseQualified properName
<*> 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 @@ parseDerivingInstanceDeclaration = do
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 @@ parseModuleDeclaration = do
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 @@ parseModule = do
-- 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 @@ parseModulesFromFiles
-> [(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 @@ parseUpdaterBodyFields = do
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
index 4182f42..2c28bcc 100644
--- a/src/Language/PureScript/Pretty/Values.hs
+++ b/src/Language/PureScript/Pretty/Values.hs
@@ -11,10 +11,10 @@ import Prelude.Compat
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 @@ prettyPrintLiteralValue d (ObjectLiteral ps) = prettyPrintObject (d - 1) $ secon
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
index df391fb..0cb2a8b 100644
--- a/src/Language/PureScript/Sugar/BindingGroups.hs
+++ b/src/Language/PureScript/Sugar/BindingGroups.hs
@@ -18,6 +18,7 @@ import Control.Monad.Error.Class (MonadError(..))
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 @@ createBindingGroupsModule (Module ss coms name ds exps) =
--
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 @@ createBindingGroups moduleName = mapM f <=< handleDecls
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 @@ createBindingGroups moduleName = mapM f <=< handleDecls
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 @@ usedIdents moduleName = ordNub . usedIdents' S.empty . getValue
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 @@ usedTypeNames moduleName =
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 @@ toBindingGroup
-> 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 @@ toBindingGroup moduleName (CyclicSCC ds') =
-- 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 @@ toDataBindingGroup
-> 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
index 3d63011..66cf9c9 100644
--- a/src/Language/PureScript/Sugar/CaseDeclarations.hs
+++ b/src/Language/PureScript/Sugar/CaseDeclarations.hs
@@ -42,9 +42,11 @@ desugarCaseGuards
:: 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 @@ desugarCaseGuards declarations = parU declarations f
--
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 @@ desugarGuardedExprs (Case scrut alternatives)
(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 @@ desugarGuardedExprs (Case scrut alternatives)
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 @@ desugarGuardedExprs (Case scrut alternatives) =
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 @@ desugarGuardedExprs (Case scrut alternatives) =
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 @@ desugarGuardedExprs (Case scrut alternatives) =
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 :: forall m. (MonadSupply m, MonadError MultipleErrors m) => [Decla
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 @@ toDecls [ValueDeclaration ident nameKind bs [MkUnguarded val]] | all isIrrefutab
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 @@ makeCaseDeclaration ident alternatives = do
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
index 4acd0ba..282602a 100644
--- a/src/Language/PureScript/Sugar/DoNotation.hs
+++ b/src/Language/PureScript/Sugar/DoNotation.hs
@@ -24,10 +24,9 @@ desugarDoModule (Module ss coms mn ds exts) = Module ss coms mn <$> parU ds desu
-- | 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 @@ desugarDo d =
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
index 901522b..9fb700d 100644
--- a/src/Language/PureScript/Sugar/LetPattern.hs
+++ b/src/Language/PureScript/Sugar/LetPattern.hs
@@ -19,7 +19,6 @@ desugarLetPatternModule (Module ss coms mn ds exts) = Module ss coms mn (map des
-- 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 @@ desugarLetPattern decl =
-- ^ 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
index 0fb49ed..24bbe47 100644
--- a/src/Language/PureScript/Sugar/Names.hs
+++ b/src/Language/PureScript/Sugar/Names.hs
@@ -65,9 +65,9 @@ desugarImportsWithEnv externs modules = do
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 @@ desugarImportsWithEnv externs modules = do
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 @@ desugarImportsWithEnv externs modules = do
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 :: Exports -> Module -> Module
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 @@ renameInModule
=> 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 @@ renameInModule imports (Module ss coms mn decls exps) =
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 @@ renameInModule imports (Module ss coms mn decls exps) =
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 @@ renameInModule imports (Module ss coms mn decls exps) =
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 @@ renameInModule imports (Module ss coms mn decls exps) =
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 @@ renameInModule imports (Module ss coms mn decls exps) =
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 @@ renameInModule imports (Module ss coms mn decls exps) =
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 @@ renameInModule imports (Module ss coms mn decls exps) =
=> 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 @@ renameInModule imports (Module ss coms mn decls exps) =
_ -> 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
index a827041..6a68140 100644
--- a/src/Language/PureScript/Sugar/Names/Common.hs
+++ b/src/Language/PureScript/Sugar/Names/Common.hs
@@ -6,8 +6,7 @@ import Protolude (ordNub)
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 @@ warnDuplicateRefs
-> 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 @@ warnDuplicateRefs pos toError refs = do
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
index 0ebbcac..dbb4d36 100644
--- a/src/Language/PureScript/Sugar/Names/Env.hs
+++ b/src/Language/PureScript/Sugar/Names/Env.hs
@@ -2,7 +2,7 @@ module Language.PureScript.Sugar.Names.Env
( ImportRecord(..)
, ImportProvenance(..)
, Imports(..)
- , primImports
+ , nullImports
, Exports(..)
, nullExports
, Env
@@ -115,26 +115,6 @@ nullImports :: Imports
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 @@ primExports =
-- | Environment which only contains the Prim module.
primEnv :: Env
primEnv = M.singleton
- primModuleName
+ (ModuleName [ProperName "Prim"])
(internalModuleSourceSpan "<Prim>", nullImports, primExports)
-- |
diff --git a/src/Language/PureScript/Sugar/Names/Exports.hs b/src/Language/PureScript/Sugar/Names/Exports.hs
index ac502f5..660efc1 100644
--- a/src/Language/PureScript/Sugar/Names/Exports.hs
+++ b/src/Language/PureScript/Sugar/Names/Exports.hs
@@ -27,34 +27,34 @@ import Language.PureScript.Sugar.Names.Common (warnDuplicateRefs)
--
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 @@ resolveExports env ss mn imps exps refs =
-- `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 @@ resolveExports env ss mn imps exps refs =
, 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 @@ filterModule mn exps refs = do
-- 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 @@ filterModule mn exps refs = do
-> 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 @@ filterModule mn exps refs = do
-> 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
index 9250038..e7680d1 100644
--- a/src/Language/PureScript/Sugar/Names/Imports.hs
+++ b/src/Language/PureScript/Sugar/Names/Imports.hs
@@ -21,7 +21,7 @@ import Language.PureScript.Errors
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 @@ type ImportDef = (Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)
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 @@ resolveImports env (Module ss coms currentModule decls exps) =
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 "<module>", 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 @@ resolveModuleImport
. 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 @@ resolveModuleImport env ie (mn, imps) = foldM go ie imps
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 @@ resolveImport
-> 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 @@ resolveImport importModule exps imps impQual = resolveByType
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
index a46d6cc..fafa345 100644
--- a/src/Language/PureScript/Sugar/ObjectWildcards.hs
+++ b/src/Language/PureScript/Sugar/ObjectWildcards.hs
@@ -26,8 +26,7 @@ desugarObjectConstructors
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 @@ desugarDecl other = fn other
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
index 82af60f..a55071a 100644
--- a/src/Language/PureScript/Sugar/Operators.hs
+++ b/src/Language/PureScript/Sugar/Operators.hs
@@ -116,16 +116,12 @@ rebracket externs modules = do
(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 @@ rebracketModule valueOpTable typeOpTable (Module ss coms mn ds exts) =
where
(f, _, _) =
everywhereOnValuesTopDownM
- (decontextify goDecl)
+ goDecl
(goExpr <=< decontextify goExpr')
(goBinder <=< decontextify goBinder')
@@ -203,7 +199,7 @@ removeParens = f
where
(f, _, _) =
everywhereOnValues
- (decontextify goDecl)
+ (runIdentity . goDecl)
(goExpr . decontextify goExpr')
(goBinder . decontextify goBinder')
@@ -258,11 +254,10 @@ collectFixities :: Module -> [Either ValueFixityRecord TypeFixityRecord]
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 @@ updateTypes
:: 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,28 +299,27 @@ updateTypes goType = (goDecl, goExpr, goBinder)
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)
@@ -367,23 +361,21 @@ checkFixityExports m@(Module ss _ mn ds (Just exps)) =
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
index 73fe3d6..5819bb8 100644
--- a/src/Language/PureScript/Sugar/TypeClasses.hs
+++ b/src/Language/PureScript/Sugar/TypeClasses.hs
@@ -176,30 +176,27 @@ desugarDecl
-> 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 @@ desugarDecl mn exps = go
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 @@ desugarDecl mn exps = go
getConstructor (TypeConstructor tcname) = [tcname]
getConstructor _ = []
+ genSpan :: SourceSpan
+ genSpan = internalModuleSourceSpan "<generated>"
+
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 @@ typeClassMemberToDictionaryAccessor
-> [(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 @@ unit = TypeApp tyRecord REmpty
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 @@ typeInstanceDictionaryDeclaration name mn deps className tys decls =
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
index 7bfe373..503487c 100755
--- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs
+++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs
@@ -84,9 +84,8 @@ deriveInstances externs (Module ss coms mn ds exts) =
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 @@ deriveInstances externs (Module ss coms mn ds exts) =
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 @@ deriveInstance
-> [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 @@ unwrapTypeConstructor = fmap (second reverse) . go
deriveNewtypeInstance
:: forall m
. (MonadError MultipleErrors m, MonadWriter MultipleErrors m)
- => ModuleName
+ => SourceSpan
+ -> ModuleName
-> SynonymMap
-> NewtypeDerivedInstances
-> Qualified (ProperName 'ClassName)
@@ -195,12 +193,12 @@ deriveNewtypeInstance
-> 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 @@ deriveNewtypeInstance mn syns ndis className ds tys tyConNm dargs = do
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 @@ deriveNewtypeInstance mn syns ndis className ds tys tyConNm dargs = do
-- 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 @@ unguarded e = [MkUnguarded e]
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 @@ deriveGeneric mn syns ds tyConNm dargs = do
)
$ 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 @@ deriveGeneric mn syns ds tyConNm dargs = do
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 @@ deriveGeneric mn syns ds tyConNm dargs = do
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 @@ deriveGenericRep mn syns ds tyConNm tyConArgs repTy = do
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 _ (TypeWildcard _) = return ()
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 @@ deriveEq mn syns ds tyConNm = do
$ 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 @@ deriveNewtype mn syns ds tyConNm tyConArgs unwrappedTy = do
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 @@ deriveNewtype mn syns ds tyConNm tyConArgs unwrappedTy = do
]
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
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 @@ decomposeRec' = sortBy (comparing fst) . go
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
index f9b09ef..8013f70 100644
--- a/src/Language/PureScript/Sugar/TypeDeclarations.hs
+++ b/src/Language/PureScript/Sugar/TypeDeclarations.hs
@@ -23,39 +23,33 @@ desugarTypeDeclarationsModule
. 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
index 1323b57..819328f 100644
--- a/src/Language/PureScript/TypeChecker.hs
+++ b/src/Language/PureScript/TypeChecker.hs
@@ -22,11 +22,12 @@ import Control.Lens ((^..), _1, _2)
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.Errors
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 @@ addTypeClass moduleName pn args implies dependencies ds = do
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
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 @@ typeCheckAll moduleName _ = traverse go
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 @@ typeCheckAll moduleName _ = traverse go
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 @@ typeCheckAll moduleName _ = traverse go
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 @@ typeCheckModule (Module ss coms mn decls (Just exps)) =
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 @@ typeCheckModule (Module ss coms mn decls (Just exps)) =
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 @@ typeCheckModule (Module ss coms mn decls (Just exps)) =
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
index e9f3d84..2ab1734 100644
--- a/src/Language/PureScript/TypeChecker/Entailment.hs
+++ b/src/Language/PureScript/TypeChecker/Entailment.hs
@@ -44,20 +44,17 @@ import qualified Language.PureScript.Constants as C
-- | 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 @@ entails SolverOptions{..} constraint context hints =
= [ 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 @@ entails SolverOptions{..} constraint context hints =
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.
@@ -374,6 +375,18 @@ entails SolverOptions{..} constraint context hints =
-- 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
-- substitution which makes them match. If not, we return 'Nothing'.
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
index 1d519ff..c3d95f8 100644
--- a/src/Language/PureScript/TypeChecker/Types.hs
+++ b/src/Language/PureScript/TypeChecker/Types.hs
@@ -40,9 +40,10 @@ import Data.Functor (($>))
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 @@ typesOf
:: (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 @@ typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do
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 @@ typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do
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 @@ typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do
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 @@ typesOf bindingGroupType moduleName vals = withFreshSubstitution $ do
--
-- 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 @@ data SplitBindingGroup = SplitBindingGroup
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 @@ checkTypedBindingGroupElement mn (ident, (val, ty, checkType)) dict = do
-- | 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 @@ inferLetBinding
-> (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
index 623a58e..255d697 100644
--- a/tests/Language/PureScript/Ide/CompletionSpec.hs
+++ b/tests/Language/PureScript/Ide/CompletionSpec.hs
@@ -19,7 +19,7 @@ reexportMatches =
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
index 2e1c8f9..ed0e376 100644
--- a/tests/Language/PureScript/Ide/FilterSpec.hs
+++ b/tests/Language/PureScript/Ide/FilterSpec.hs
@@ -5,6 +5,7 @@ module Language.PureScript.Ide.FilterSpec where
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 @@ import Test.Hspec
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 @@ runModule ms = applyFilters [moduleFilter ms] modules
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 @@ spec = do
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
index 908531b..e95309f 100644
--- a/tests/Language/PureScript/Ide/ImportsSpec.hs
+++ b/tests/Language/PureScript/Ide/ImportsSpec.hs
@@ -107,7 +107,7 @@ spec = do
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 @@ spec = do
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
index 2a6952e..731672a 100644
--- a/tests/Language/PureScript/Ide/ReexportsSpec.hs
+++ b/tests/Language/PureScript/Ide/ReexportsSpec.hs
@@ -13,7 +13,7 @@ import Test.Hspec
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 @@ env = Map.fromList
type Refs = [(P.ModuleName, P.DeclarationRef)]
+testSpan :: P.SourceSpan
+testSpan = P.internalModuleSourceSpan "<test>"
+
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
index 7937c0f..1bf01f4 100644
--- a/tests/Language/PureScript/Ide/SourceFileSpec.hs
+++ b/tests/Language/PureScript/Ide/SourceFileSpec.hs
@@ -16,55 +16,61 @@ span0 = P.SourceSpan "ModuleLevel" (P.SourcePos 0 0) (P.SourcePos 1 1)
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 @@ getLocation s = do
[ ("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 @@ getLocation s = do
`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
index 78f8cea..0a31331 100644
--- a/tests/Language/PureScript/Ide/StateSpec.hs
+++ b/tests/Language/PureScript/Ide/StateSpec.hs
@@ -13,27 +13,26 @@ import qualified Data.Map as Map
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 @@ spec = do
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 @@ spec = do
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
index 8cb8d3e..dd48b8f 100644
--- 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 @@ ida = IdeDeclarationAnn emptyAnn
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)))
@@ -98,6 +99,17 @@ ideTypeOp opName ident precedence assoc k =
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
index 0237bfe..d3dbbdb 100644
--- a/tests/TestDocs.hs
+++ b/tests/TestDocs.hs
@@ -13,7 +13,6 @@ import Control.Arrow (first)
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 @@ instance Show (ShowFn a) where
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 @@ runAssertion assertion linksCtx Docs.Module{..} =
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
@@ -406,6 +405,11 @@ testCases =
, ("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"]
+ ])
]
where
diff --git a/tests/support/bower.json b/tests/support/bower.json
index 6b67afd..932650f 100644
--- 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"
}