summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorhdgarrood <>2019-05-30 13:33:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2019-05-30 13:33:00 (GMT)
commit63881df15dcdd909729b6c594568196b53ae89bb (patch)
treeeed7a53b372587dc2e797f67079eb675b75e9e40
parent804880ea1af7ec064f146ccf2b1c65590dfca657 (diff)
version 0.13.00.13.0
-rw-r--r--CONTRIBUTORS.md2
-rw-r--r--INSTALL.md33
-rw-r--r--app/Command/Compile.hs5
-rw-r--r--app/Command/Docs.hs234
-rw-r--r--app/Command/Docs/Html.hs3
-rw-r--r--app/Command/Docs/Markdown.hs24
-rw-r--r--app/Command/Hierarchy.hs3
-rw-r--r--app/Command/Publish.hs65
-rw-r--r--app/Command/REPL.hs5
-rw-r--r--purescript.cabal486
-rw-r--r--src/Language/PureScript.hs1
-rw-r--r--src/Language/PureScript/AST/Declarations.hs2
-rw-r--r--src/Language/PureScript/CST.hs95
-rw-r--r--src/Language/PureScript/CST/Convert.hs636
-rw-r--r--src/Language/PureScript/CST/Errors.hs162
-rw-r--r--src/Language/PureScript/CST/Layout.hs396
-rw-r--r--src/Language/PureScript/CST/Lexer.hs712
-rw-r--r--src/Language/PureScript/CST/Monad.hs174
-rw-r--r--src/Language/PureScript/CST/Parser.y786
-rw-r--r--src/Language/PureScript/CST/Positions.hs352
-rw-r--r--src/Language/PureScript/CST/Print.hs82
-rw-r--r--src/Language/PureScript/CST/Traversals.hs11
-rw-r--r--src/Language/PureScript/CST/Traversals/Type.hs39
-rw-r--r--src/Language/PureScript/CST/Types.hs437
-rw-r--r--src/Language/PureScript/CST/Utils.hs313
-rw-r--r--src/Language/PureScript/CoreImp/Optimizer/Inliner.hs31
-rw-r--r--src/Language/PureScript/Crash.hs1
-rw-r--r--src/Language/PureScript/Docs.hs8
-rw-r--r--src/Language/PureScript/Docs/AsHtml.hs15
-rw-r--r--src/Language/PureScript/Docs/AsMarkdown.hs17
-rw-r--r--src/Language/PureScript/Docs/Collect.hs233
-rw-r--r--src/Language/PureScript/Docs/Convert.hs231
-rw-r--r--src/Language/PureScript/Docs/Convert/ReExports.hs97
-rw-r--r--src/Language/PureScript/Docs/Convert/Single.hs7
-rw-r--r--src/Language/PureScript/Docs/ParseInPackage.hs74
-rw-r--r--src/Language/PureScript/Docs/Prim.hs5
-rw-r--r--src/Language/PureScript/Docs/Render.hs6
-rw-r--r--src/Language/PureScript/Docs/RenderedCode/RenderType.hs14
-rw-r--r--src/Language/PureScript/Docs/Types.hs10
-rw-r--r--src/Language/PureScript/Errors.hs27
-rw-r--r--src/Language/PureScript/Externs.hs11
-rw-r--r--src/Language/PureScript/Ide/CaseSplit.hs23
-rw-r--r--src/Language/PureScript/Ide/Imports.hs65
-rw-r--r--src/Language/PureScript/Ide/Rebuild.hs12
-rw-r--r--src/Language/PureScript/Ide/SourceFile.hs5
-rw-r--r--src/Language/PureScript/Interactive.hs7
-rw-r--r--src/Language/PureScript/Interactive/Module.hs9
-rw-r--r--src/Language/PureScript/Interactive/Parser.hs134
-rw-r--r--src/Language/PureScript/Kinds.hs12
-rw-r--r--src/Language/PureScript/Linter.hs4
-rw-r--r--src/Language/PureScript/Linter/Exhaustive.hs1
-rw-r--r--src/Language/PureScript/Make.hs55
-rw-r--r--src/Language/PureScript/Make/Actions.hs25
-rw-r--r--src/Language/PureScript/Make/BuildPlan.hs85
-rw-r--r--src/Language/PureScript/ModuleDependencies.hs57
-rw-r--r--src/Language/PureScript/Options.hs3
-rw-r--r--src/Language/PureScript/Parser.hs23
-rw-r--r--src/Language/PureScript/Parser/Common.hs160
-rw-r--r--src/Language/PureScript/Parser/Declarations.hs665
-rw-r--r--src/Language/PureScript/Parser/Kinds.hs34
-rw-r--r--src/Language/PureScript/Parser/Lexer.hs610
-rw-r--r--src/Language/PureScript/Parser/State.hs18
-rw-r--r--src/Language/PureScript/Parser/Types.hs184
-rw-r--r--src/Language/PureScript/Pretty/Common.hs2
-rw-r--r--src/Language/PureScript/Pretty/Types.hs22
-rw-r--r--src/Language/PureScript/Publish.hs57
-rw-r--r--src/Language/PureScript/Sugar/Names.hs3
-rw-r--r--src/Language/PureScript/Sugar/Names/Env.hs20
-rwxr-xr-xsrc/Language/PureScript/Sugar/TypeClasses/Deriving.hs2
-rw-r--r--src/Language/PureScript/TypeChecker.hs12
-rw-r--r--src/Language/PureScript/TypeChecker/Kinds.hs16
-rw-r--r--src/Language/PureScript/TypeChecker/Monad.hs9
-rw-r--r--src/Language/PureScript/TypeChecker/Skolems.hs6
-rw-r--r--src/Language/PureScript/TypeChecker/Subsumption.hs4
-rw-r--r--src/Language/PureScript/TypeChecker/Types.hs235
-rw-r--r--src/Language/PureScript/TypeChecker/Unify.hs12
-rw-r--r--src/Language/PureScript/Types.hs56
-rw-r--r--tests/Language/PureScript/Ide/ImportsSpec.hs11
-rw-r--r--tests/Language/PureScript/Ide/UsageSpec.hs6
-rw-r--r--tests/Main.hs5
-rw-r--r--tests/TestCst.hs223
-rw-r--r--tests/TestDocs.hs46
-rw-r--r--tests/TestPscPublish.hs41
-rw-r--r--tests/TestPsci/TestEnv.hs3
-rw-r--r--tests/TestUtils.hs11
-rw-r--r--tests/purs/docs/bower_components/purescript-newtype/src/Data/Newtype.purs5
-rw-r--r--tests/purs/docs/output/Ado/docs.json1
-rw-r--r--tests/purs/docs/output/Ado/externs.json1
-rw-r--r--tests/purs/docs/output/ChildDeclOrder/docs.json1
-rw-r--r--tests/purs/docs/output/ChildDeclOrder/externs.json1
-rw-r--r--tests/purs/docs/output/Clash/docs.json1
-rw-r--r--tests/purs/docs/output/Clash/externs.json1
-rw-r--r--tests/purs/docs/output/Clash1/docs.json1
-rw-r--r--tests/purs/docs/output/Clash1/externs.json1
-rw-r--r--tests/purs/docs/output/Clash1a/docs.json1
-rw-r--r--tests/purs/docs/output/Clash1a/externs.json1
-rw-r--r--tests/purs/docs/output/Clash2/docs.json1
-rw-r--r--tests/purs/docs/output/Clash2/externs.json1
-rw-r--r--tests/purs/docs/output/Clash2a/docs.json1
-rw-r--r--tests/purs/docs/output/Clash2a/externs.json1
-rw-r--r--tests/purs/docs/output/ConstrainedArgument/docs.json1
-rw-r--r--tests/purs/docs/output/ConstrainedArgument/externs.json1
-rw-r--r--tests/purs/docs/output/Data.Newtype/docs.json1
-rw-r--r--tests/purs/docs/output/Data.Newtype/externs.json1
-rw-r--r--tests/purs/docs/output/DeclOrder/docs.json1
-rw-r--r--tests/purs/docs/output/DeclOrder/externs.json1
-rw-r--r--tests/purs/docs/output/DeclOrderNoExportList/docs.json1
-rw-r--r--tests/purs/docs/output/DeclOrderNoExportList/externs.json1
-rw-r--r--tests/purs/docs/output/Desugar/docs.json1
-rw-r--r--tests/purs/docs/output/Desugar/externs.json1
-rw-r--r--tests/purs/docs/output/DocComments/docs.json1
-rw-r--r--tests/purs/docs/output/DocComments/externs.json1
-rw-r--r--tests/purs/docs/output/DuplicateNames/docs.json1
-rw-r--r--tests/purs/docs/output/DuplicateNames/externs.json1
-rw-r--r--tests/purs/docs/output/Example/docs.json1
-rw-r--r--tests/purs/docs/output/Example/externs.json1
-rw-r--r--tests/purs/docs/output/Example2/docs.json1
-rw-r--r--tests/purs/docs/output/Example2/externs.json1
-rw-r--r--tests/purs/docs/output/ExplicitExport/docs.json1
-rw-r--r--tests/purs/docs/output/ExplicitExport/externs.json1
-rw-r--r--tests/purs/docs/output/ExplicitTypeSignatures/docs.json1
-rw-r--r--tests/purs/docs/output/ExplicitTypeSignatures/externs.json1
-rw-r--r--tests/purs/docs/output/ImportedTwice/docs.json1
-rw-r--r--tests/purs/docs/output/ImportedTwice/externs.json1
-rw-r--r--tests/purs/docs/output/ImportedTwiceA/docs.json1
-rw-r--r--tests/purs/docs/output/ImportedTwiceA/externs.json1
-rw-r--r--tests/purs/docs/output/ImportedTwiceB/docs.json1
-rw-r--r--tests/purs/docs/output/ImportedTwiceB/externs.json1
-rw-r--r--tests/purs/docs/output/MultiVirtual/docs.json1
-rw-r--r--tests/purs/docs/output/MultiVirtual/externs.json1
-rw-r--r--tests/purs/docs/output/MultiVirtual1/docs.json1
-rw-r--r--tests/purs/docs/output/MultiVirtual1/externs.json1
-rw-r--r--tests/purs/docs/output/MultiVirtual2/docs.json1
-rw-r--r--tests/purs/docs/output/MultiVirtual2/externs.json1
-rw-r--r--tests/purs/docs/output/MultiVirtual3/docs.json1
-rw-r--r--tests/purs/docs/output/MultiVirtual3/externs.json1
-rw-r--r--tests/purs/docs/output/NewOperators/docs.json1
-rw-r--r--tests/purs/docs/output/NewOperators/externs.json1
-rw-r--r--tests/purs/docs/output/NewOperators2/docs.json1
-rw-r--r--tests/purs/docs/output/NewOperators2/externs.json1
-rw-r--r--tests/purs/docs/output/NotAllCtors/docs.json1
-rw-r--r--tests/purs/docs/output/NotAllCtors/externs.json1
-rw-r--r--tests/purs/docs/output/Prelude/docs.json1
-rw-r--r--tests/purs/docs/output/Prelude/externs.json1
-rw-r--r--tests/purs/docs/output/PrimSubmodules/docs.json1
-rw-r--r--tests/purs/docs/output/PrimSubmodules/externs.json1
-rw-r--r--tests/purs/docs/output/ReExportedTypeClass/docs.json1
-rw-r--r--tests/purs/docs/output/ReExportedTypeClass/externs.json1
-rw-r--r--tests/purs/docs/output/SolitaryTypeClassMember/docs.json1
-rw-r--r--tests/purs/docs/output/SolitaryTypeClassMember/externs.json1
-rw-r--r--tests/purs/docs/output/SomeTypeClass/docs.json1
-rw-r--r--tests/purs/docs/output/SomeTypeClass/externs.json1
-rw-r--r--tests/purs/docs/output/Transitive1/docs.json1
-rw-r--r--tests/purs/docs/output/Transitive1/externs.json1
-rw-r--r--tests/purs/docs/output/Transitive2/docs.json1
-rw-r--r--tests/purs/docs/output/Transitive2/externs.json1
-rw-r--r--tests/purs/docs/output/Transitive3/docs.json1
-rw-r--r--tests/purs/docs/output/Transitive3/externs.json1
-rw-r--r--tests/purs/docs/output/TypeClassWithFunDeps/docs.json1
-rw-r--r--tests/purs/docs/output/TypeClassWithFunDeps/externs.json1
-rw-r--r--tests/purs/docs/output/TypeClassWithoutMembers/docs.json1
-rw-r--r--tests/purs/docs/output/TypeClassWithoutMembers/externs.json1
-rw-r--r--tests/purs/docs/output/TypeClassWithoutMembersIntermediate/docs.json1
-rw-r--r--tests/purs/docs/output/TypeClassWithoutMembersIntermediate/externs.json1
-rw-r--r--tests/purs/docs/output/TypeLevelString/docs.json1
-rw-r--r--tests/purs/docs/output/TypeLevelString/externs.json1
-rw-r--r--tests/purs/docs/output/TypeOpAliases/docs.json1
-rw-r--r--tests/purs/docs/output/TypeOpAliases/externs.json1
-rw-r--r--tests/purs/docs/output/TypeSynonym/docs.json1
-rw-r--r--tests/purs/docs/output/TypeSynonym/externs.json1
-rw-r--r--tests/purs/docs/output/TypeSynonymInstance/docs.json1
-rw-r--r--tests/purs/docs/output/TypeSynonymInstance/externs.json1
-rw-r--r--tests/purs/docs/output/TypeSynonymInstance/index.js16
-rw-r--r--tests/purs/docs/output/UTF8/docs.json1
-rw-r--r--tests/purs/docs/output/UTF8/externs.json1
-rw-r--r--tests/purs/docs/output/Virtual/docs.json1
-rw-r--r--tests/purs/docs/output/Virtual/externs.json1
-rw-r--r--tests/purs/docs/resolutions.json23
-rw-r--r--tests/purs/docs/src/TypeSynonym.purs3
-rw-r--r--tests/purs/docs/src/TypeSynonymInstance.purs11
-rw-r--r--tests/purs/failing/2616.purs2
-rw-r--r--tests/purs/failing/3549-a.purs10
-rw-r--r--tests/purs/failing/3549.purs11
-rw-r--r--tests/purs/failing/ApostropheModuleName.purs7
-rw-r--r--tests/purs/failing/AtPatternPrecedence.purs14
-rw-r--r--tests/purs/failing/ExportConflictClassAndType.purs5
-rw-r--r--tests/purs/failing/ExportConflictClassAndType/A.purs3
-rw-r--r--tests/purs/failing/ExportConflictClassAndType/B.purs3
-rw-r--r--tests/purs/failing/ImportHidingModule.purs2
-rw-r--r--tests/purs/failing/NewtypeMultiArgs.purs2
-rw-r--r--tests/purs/failing/NewtypeMultiCtor.purs2
-rw-r--r--tests/purs/failing/NonExhaustivePatGuard.purs2
-rw-r--r--tests/purs/failing/OperatorAt.purs8
-rw-r--r--tests/purs/failing/OperatorBackslash.purs8
-rw-r--r--tests/purs/failing/PrimRow.purs2
-rw-r--r--tests/purs/failing/SelfImport.purs9
-rw-r--r--tests/purs/failing/SelfImport/Dummy.purs5
-rw-r--r--tests/purs/failing/TypeClasses2.purs2
-rw-r--r--tests/purs/failing/Whitespace1.purs5
-rw-r--r--tests/purs/layout/AdoIn.purs13
-rw-r--r--tests/purs/layout/CaseGuards.purs53
-rw-r--r--tests/purs/layout/CaseWhere.purs12
-rw-r--r--tests/purs/layout/ClassHead.purs10
-rw-r--r--tests/purs/layout/Commas.purs22
-rw-r--r--tests/purs/layout/Delimiter.purs13
-rw-r--r--tests/purs/layout/DoLet.purs15
-rw-r--r--tests/purs/layout/DoOperator.purs8
-rw-r--r--tests/purs/layout/DoWhere.purs6
-rw-r--r--tests/purs/layout/IfThenElseDo.purs10
-rw-r--r--tests/purs/layout/InstanceChainElse.purs4
-rw-r--r--tests/purs/passing/1110.purs2
-rw-r--r--tests/purs/passing/2252.purs4
-rw-r--r--tests/purs/passing/3549.purs13
-rw-r--r--tests/purs/passing/ConstraintOutsideForall.purs12
-rw-r--r--tests/purs/passing/DeepCase.purs2
-rw-r--r--tests/purs/passing/DeriveWithNestedSynonyms.purs2
-rw-r--r--tests/purs/passing/DerivingFunctor.purs2
-rw-r--r--tests/purs/passing/FunctionAndCaseGuards.purs21
-rw-r--r--tests/purs/passing/GenericsRep.purs2
-rw-r--r--tests/purs/passing/Import/M1.purs2
-rw-r--r--tests/purs/passing/Import/M2.purs1
-rw-r--r--tests/purs/passing/KindedType.purs7
-rw-r--r--tests/purs/passing/Monad.purs6
-rw-r--r--tests/purs/passing/Rank2Data.purs4
-rw-r--r--tests/purs/passing/RedefinedFixity/M2.purs2
-rw-r--r--tests/purs/passing/RedefinedFixity/M3.purs2
-rw-r--r--tests/purs/passing/StringEscapes.purs6
-rw-r--r--tests/purs/passing/TypeAnnotationPrecedence.purs11
-rw-r--r--tests/purs/publish/basic-example/output/Control.Alt/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Control.Alt/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Control.Alternative/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Control.Alternative/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Control.Applicative/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Control.Applicative/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Control.Apply/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Control.Apply/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Control.Biapplicative/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Control.Biapplicative/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Control.Biapply/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Control.Biapply/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Control.Bind/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Control.Bind/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Control.Category/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Control.Category/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Control.Comonad/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Control.Comonad/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Control.Extend/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Control.Extend/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Control.Lazy/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Control.Lazy/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Control.Monad.Gen.Class/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Control.Monad.Gen.Class/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Control.Monad.Gen.Common/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Control.Monad.Gen.Common/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Control.Monad.Gen/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Control.Monad.Gen/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Control.Monad.Rec.Class/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Control.Monad.Rec.Class/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Control.Monad.ST.Internal/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Control.Monad.ST.Internal/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Control.Monad.ST.Ref/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Control.Monad.ST.Ref/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Control.Monad.ST/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Control.Monad.ST/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Control.Monad/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Control.Monad/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Control.MonadPlus/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Control.MonadPlus/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Control.MonadZero/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Control.MonadZero/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Control.Plus/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Control.Plus/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Control.Semigroupoid/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Control.Semigroupoid/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Array.NonEmpty.Internal/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Array.NonEmpty.Internal/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Array.NonEmpty/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Array.NonEmpty/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Array.Partial/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Array.Partial/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Array.ST.Iterator/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Array.ST.Iterator/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Array.ST.Partial/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Array.ST.Partial/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Array.ST/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Array.ST/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Array/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Array/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Bifoldable/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Bifoldable/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Bifunctor.Clown/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Bifunctor.Clown/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Bifunctor.Flip/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Bifunctor.Flip/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Bifunctor.Join/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Bifunctor.Join/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Bifunctor.Joker/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Bifunctor.Joker/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Bifunctor.Product/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Bifunctor.Product/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Bifunctor.Wrap/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Bifunctor.Wrap/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Bifunctor/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Bifunctor/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Bitraversable/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Bitraversable/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Boolean/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Boolean/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.BooleanAlgebra/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.BooleanAlgebra/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Bounded/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Bounded/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Char.Gen/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Char.Gen/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Char/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Char/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.CommutativeRing/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.CommutativeRing/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Distributive/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Distributive/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.DivisionRing/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.DivisionRing/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Either.Inject/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Either.Inject/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Either.Nested/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Either.Nested/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Either/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Either/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Enum.Gen/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Enum.Gen/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Enum/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Enum/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Eq/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Eq/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.EuclideanRing/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.EuclideanRing/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Field/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Field/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Foldable/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Foldable/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.FoldableWithIndex/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.FoldableWithIndex/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Function.Uncurried/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Function.Uncurried/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Function/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Function/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Functor.Invariant/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Functor.Invariant/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Functor/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Functor/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.FunctorWithIndex/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.FunctorWithIndex/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Generic.Rep.Bounded/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Generic.Rep.Bounded/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Generic.Rep.Enum/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Generic.Rep.Enum/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Generic.Rep.Eq/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Generic.Rep.Eq/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Generic.Rep.Monoid/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Generic.Rep.Monoid/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Generic.Rep.Ord/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Generic.Rep.Ord/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Generic.Rep.Semigroup/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Generic.Rep.Semigroup/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Generic.Rep.Show/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Generic.Rep.Show/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Generic.Rep/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Generic.Rep/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.HeytingAlgebra/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.HeytingAlgebra/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Identity/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Identity/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Int.Bits/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Int.Bits/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Int/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Int/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Lazy/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Lazy/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.List.Lazy.NonEmpty/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.List.Lazy.NonEmpty/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.List.Lazy.Types/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.List.Lazy.Types/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.List.Lazy/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.List.Lazy/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.List.NonEmpty/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.List.NonEmpty/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.List.Partial/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.List.Partial/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.List.Types/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.List.Types/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.List.ZipList/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.List.ZipList/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.List/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.List/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Maybe.First/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Maybe.First/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Maybe.Last/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Maybe.Last/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Maybe/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Maybe/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Monoid.Additive/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Monoid.Additive/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Monoid.Conj/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Monoid.Conj/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Monoid.Disj/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Monoid.Disj/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Monoid.Dual/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Monoid.Dual/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Monoid.Endo/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Monoid.Endo/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Monoid.Multiplicative/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Monoid.Multiplicative/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Monoid/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Monoid/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.NaturalTransformation/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.NaturalTransformation/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Newtype/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Newtype/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.NonEmpty/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.NonEmpty/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Ord.Down/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Ord.Down/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Ord.Max/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Ord.Max/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Ord.Min/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Ord.Min/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Ord.Unsafe/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Ord.Unsafe/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Ord/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Ord/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Ordering/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Ordering/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Ring/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Ring/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Semigroup.First/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Semigroup.First/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Semigroup.Foldable/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Semigroup.Foldable/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Semigroup.Last/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Semigroup.Last/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Semigroup.Traversable/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Semigroup.Traversable/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Semigroup/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Semigroup/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Semiring/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Semiring/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Show/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Show/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.String.CaseInsensitive/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.String.CaseInsensitive/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.String.CodePoints/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.String.CodePoints/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.String.CodeUnits/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.String.CodeUnits/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.String.Common/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.String.Common/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.String.Gen/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.String.Gen/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.String.NonEmpty.CaseInsensitive/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.String.NonEmpty.CaseInsensitive/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.String.NonEmpty.CodePoints/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.String.NonEmpty.CodePoints/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.String.NonEmpty.CodeUnits/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.String.NonEmpty.CodeUnits/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.String.NonEmpty.Internal/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.String.NonEmpty.Internal/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.String.NonEmpty/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.String.NonEmpty/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.String.Pattern/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.String.Pattern/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.String.Regex.Flags/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.String.Regex.Flags/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.String.Regex.Unsafe/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.String.Regex.Unsafe/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.String.Regex/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.String.Regex/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.String.Unsafe/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.String.Unsafe/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.String/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.String/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Symbol/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Symbol/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Traversable.Accum.Internal/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Traversable.Accum.Internal/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Traversable.Accum/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Traversable.Accum/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Traversable/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Traversable/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.TraversableWithIndex/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.TraversableWithIndex/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Tuple.Nested/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Tuple.Nested/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Tuple/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Tuple/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Unfoldable/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Unfoldable/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Unfoldable1/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Unfoldable1/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Unit/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Unit/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Void/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Data.Void/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Effect.Class.Console/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Effect.Class.Console/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Effect.Class/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Effect.Class/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Effect.Console/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Effect.Console/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Effect.Ref/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Effect.Ref/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Effect.Uncurried/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Effect.Uncurried/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Effect.Unsafe/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Effect.Unsafe/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Effect/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Effect/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Global.Unsafe/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Global.Unsafe/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Global/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Global/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Main/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Main/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Math/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Math/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/PSCI.Support/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/PSCI.Support/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Partial.Unsafe/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Partial.Unsafe/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Partial/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Partial/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Prelude/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Prelude/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Record.Unsafe/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Record.Unsafe/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Test.Assert/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Test.Assert/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Type.Data.Boolean/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Type.Data.Boolean/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Type.Data.Ordering/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Type.Data.Ordering/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Type.Data.Row/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Type.Data.Row/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Type.Data.RowList/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Type.Data.RowList/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Type.Data.Symbol/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Type.Data.Symbol/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Type.Equality/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Type.Equality/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Type.Prelude/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Type.Prelude/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Type.Proxy/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Type.Proxy/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Type.Row.Homogeneous/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Type.Row.Homogeneous/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Type.Row/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Type.Row/externs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Unsafe.Coerce/docs.json1
-rw-r--r--tests/purs/publish/basic-example/output/Unsafe.Coerce/externs.json1
-rw-r--r--tests/purs/warning/ShadowedBinderPatternGuard.purs4
-rw-r--r--tests/purs/warning/UnusedImport.purs2
-rw-r--r--tests/support/bower.json4
-rw-r--r--tests/support/package-lock.json6
562 files changed, 6945 insertions, 2756 deletions
diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md
index eee955b..ab5a25a 100644
--- a/CONTRIBUTORS.md
+++ b/CONTRIBUTORS.md
@@ -41,6 +41,7 @@ If you would prefer to use different terms, please use the section below instead
| [@DavidLindbom](https://github.com/DavidLindbom) | David Lindbom | [MIT license](http://opensource.org/licenses/MIT) |
| [@dckc](https://github.com/dckc) | Dan Connolly | [MIT license](http://opensource.org/licenses/MIT) |
| [@kleeneplus](https://github.com/dgendill) | Dominick Gendill | [MIT license](http://opensource.org/licenses/MIT) |
+| [@ealmansi](https://github.com/ealmansi) | Emilio Almansi | MIT license |
| [@eamelink](https://github.com/eamelink) | Erik Bakker | MIT license |
| [@epost](https://github.com/epost) | Erik Post | MIT license |
| [@erdeszt](https://github.com/erdeszt) | Tibor Erdesz | [MIT license](http://opensource.org/licenses/MIT) |
@@ -131,6 +132,7 @@ If you would prefer to use different terms, please use the section below instead
| [@dariooddenino](https://github.com/dariooddenino) | Dario Oddenino | [MIT license](http://opensource.org/licenses/MIT) |
| [@jordanmartinez](https://github.com/jordanmartinez) | Jordan Martinez | [MIT license](http://opensource.org/licenses/MIT) |
| [@Saulukass](https://github.com/Saulukass) | Saulius Skliutas | [MIT license](http://opensource.org/licenses/MIT) |
+| [@adnelson](https://github.com/adnelson) | Allen Nelson | [MIT license](http://opensource.org/licenses/MIT) |
### Contributors using Modified Terms
diff --git a/INSTALL.md b/INSTALL.md
index 232b5a6..7b4fe9f 100644
--- a/INSTALL.md
+++ b/INSTALL.md
@@ -4,25 +4,27 @@ If you are having difficulty installing the PureScript compiler, feel free to
ask for help! A good place is the #purescript IRC channel on Freenode, the #purescript channel on [FPChat Slack](https://fpchat-invite.herokuapp.com/), or
alternatively Stack Overflow.
-## Using prebuilt binaries
+## Requirements
-The prebuilt binaries are compiled with GHC 8.6.4 and therefore they should run on any operating system supported by GHC 8.6.4, such as:
+The PureScript compiler is built using GHC 8.6.4, and should be able to run on any operating system supported by GHC 8.6.4. In particular:
-* Windows Vista or later,
-* OS X 10.7 or later,
-* Linux ??? (we're not sure what the minimum version is)
+* for Windows users, versions predating Vista are not officially supported,
+* for macOS / OS X users, versions predating Mac OS X 10.7 (Lion) are not officially supported.
-This list is not exhaustive. If your OS is too old or not listed, or if the binaries fail to run, you may be able to install the compiler by building it from source; see below. See also <https://www.haskell.org/ghc/download_ghc_8_6_4.html> for more details about the operating systems which GHC 8.6.4 supports.
+See also <https://www.haskell.org/ghc/download_ghc_8_6_4.html> for more details about the operating systems which GHC 8.6.4 supports.
-Other prebuilt distributions (eg, Homebrew, AUR, npm) will probably have the
-same requirements.
+## Official prebuilt binaries
-## Installing a pre-built distribution
+Each release comes with prebuilt x86-64 binary bundles for Linux, mac OS, and Windows. Users of other operating systems or architectures will likely need to build the compiler from source; see below.
-There are several options available for aquiring a pre-built binary of the PureScript compiler. This is by no means an exhaustive list, and is presented in no particular order. Each example is expected to install the latest available compiler version at the time of running the command. Many of these are provided and maintained by the community, and may not be immediately up to date.
+To install a binary bundle, simply extract it and place the `purs` executable somewhere on your PATH.
+
+## Other distributions
+
+There are several other distributions of the PureScript compiler available, which may be more convenient to use in certain setups. This is by no means an exhaustive list, and is presented in no particular order. Many of these distributions are provided and maintained by the community, and may not be immediately up to date following a new release.
* NPM: `npm install -g purescript`
-* Homebrew (for OS X): `brew install purescript`
+* Homebrew (for macOS): `brew install purescript`
* [PSVM](https://github.com/ThomasCrevoisier/psvm-js): `npm install -g psvm`
## Compiling from source
@@ -36,14 +38,9 @@ $ cd purescript-x.y.z # (replace x.y.z with whichever version you just download
$ stack install --flag purescript:RELEASE
```
-This will then copy the compiler and utilities into `~/.local/bin`.
-
-
-If you don't have stack installed, there are install instructions
-[here](https://github.com/commercialhaskell/stack/blob/master/doc/install_and_upgrade.md).
+This will then copy the compiler executable (`purs`) into `~/.local/bin`.
-If you don't have GHC installed, stack will prompt you to run `stack setup`
-which will install the correct version of GHC for you.
+If you don't have stack installed, please see the [stack install documentation](https://github.com/commercialhaskell/stack/blob/master/doc/install_and_upgrade.md).
## The "curses" library
diff --git a/app/Command/Compile.hs b/app/Command/Compile.hs
index 555fc5b..461985f 100644
--- a/app/Command/Compile.hs
+++ b/app/Command/Compile.hs
@@ -18,6 +18,7 @@ import Data.Text (Text)
import qualified Data.Text as T
import Data.Traversable (for)
import qualified Language.PureScript as P
+import qualified Language.PureScript.CST as CST
import Language.PureScript.Errors.JSON
import Language.PureScript.Make
import qualified Options.Applicative as Opts
@@ -65,8 +66,8 @@ compile PSCMakeOptions{..} = do
exitFailure
moduleFiles <- readInput input
(makeErrors, makeWarnings) <- runMake pscmOpts $ do
- ms <- P.parseModulesFromFiles id moduleFiles
- let filePathMap = M.fromList $ map (\(fp, P.Module _ _ mn _ _) -> (mn, Right fp)) ms
+ ms <- CST.parseModulesFromFiles id moduleFiles
+ let filePathMap = M.fromList $ map (\(fp, pm) -> (P.getModuleName $ CST.resPartial pm, Right fp)) ms
foreigns <- inferForeignModules filePathMap
let makeActions = buildMakeActions pscmOutputDir filePathMap foreigns pscmUsePrefix
P.make makeActions (map snd ms)
diff --git a/app/Command/Docs.hs b/app/Command/Docs.hs
index 048cb64..f6bf57c 100644
--- a/app/Command/Docs.hs
+++ b/app/Command/Docs.hs
@@ -1,28 +1,22 @@
-{-# LANGUAGE TupleSections #-}
module Command.Docs (command, infoModList) where
import Command.Docs.Html
+import Command.Docs.Markdown
import Control.Applicative
-import Control.Arrow (first, second)
-import Control.Category ((>>>))
import Control.Monad.Writer
import Control.Monad.Trans.Except (runExceptT)
+import Data.Maybe (fromMaybe)
import qualified Data.Text as T
-import qualified Data.Text.IO as T
-import Data.Function (on)
-import Data.List
-import Data.Tuple (swap)
import qualified Language.PureScript as P
import qualified Language.PureScript.Docs as D
-import qualified Language.PureScript.Docs.AsMarkdown as D
import Language.PureScript.Docs.Tags (dumpCtags, dumpEtags)
import qualified Options.Applicative as Opts
import qualified Text.PrettyPrint.ANSI.Leijen as PP
-import System.Directory (createDirectoryIfMissing)
+import System.Directory (getCurrentDirectory, createDirectoryIfMissing, removeFile)
import System.Exit (exitFailure)
-import System.FilePath (takeDirectory)
-import System.FilePath.Glob (glob)
+import System.FilePath ((</>))
+import System.FilePath.Glob (compile, glob, globDir1)
import System.IO (hPutStrLn, stderr)
import System.IO.UTF8 (writeUTF8FileT)
@@ -34,67 +28,44 @@ data Format
| Etags -- Output etags symbol index suitable for use with emacs
deriving (Show, Eq, Ord)
--- | Available methods of outputting Markdown documentation
-data DocgenOutput
- = EverythingToStdOut
- | ToStdOut [P.ModuleName]
- | ToFiles [(P.ModuleName, FilePath)]
- deriving (Show)
-
data PSCDocsOptions = PSCDocsOptions
{ _pscdFormat :: Format
+ , _pscdOutput :: Maybe FilePath
+ , _pscdCompileOutputDir :: FilePath
, _pscdInputFiles :: [FilePath]
- , _pscdDocgen :: DocgenOutput
}
deriving (Show)
docgen :: PSCDocsOptions -> IO ()
-docgen (PSCDocsOptions fmt inputGlob output) = do
+docgen (PSCDocsOptions fmt moutput compileOutput inputGlob) = do
input <- concat <$> mapM glob inputGlob
when (null input) $ do
hPutStrLn stderr "purs docs: no input files."
exitFailure
+ let output = fromMaybe (defaultOutputForFormat fmt) moutput
+
fileMs <- parseAndConvert input
- let ms = map snd fileMs
+ let ms = D.primModules ++ map snd fileMs
case fmt of
- Etags -> mapM_ putStrLn $ dumpEtags fileMs
- Ctags -> mapM_ putStrLn $ dumpCtags fileMs
+ Etags -> writeTagsToFile output $ dumpEtags fileMs
+ Ctags -> writeTagsToFile output $ dumpCtags fileMs
Html -> do
- let outputDir = "./generated-docs" -- TODO: make this configurable
- let msHtml = map asHtml (D.primModules ++ ms)
- createDirectoryIfMissing False outputDir
- writeHtmlModules outputDir msHtml
-
- Markdown ->
- case output of
- EverythingToStdOut ->
- T.putStrLn (D.runDocs (D.modulesAsMarkdown ms))
- ToStdOut names -> do
- let (ms', missing) = takeByName ms names
- guardMissing missing
- T.putStrLn (D.runDocs (D.modulesAsMarkdown ms'))
- ToFiles names -> do
- let (ms', missing) = takeByName' ms names
- guardMissing missing
-
- let ms'' = groupBy ((==) `on` fst) . sortBy (compare `on` fst) $ map swap ms'
- forM_ ms'' $ \grp -> do
- let fp = fst (head grp)
- createDirectoryIfMissing True (takeDirectory fp)
- writeUTF8FileT fp (D.runDocs (D.modulesAsMarkdown (map snd grp)))
+ let ext = compile "*.html"
+ let msHtml = map asHtml ms
+ createDirectoryIfMissing True output
+ globDir1 ext output >>= mapM_ removeFile
+ writeHtmlModules output msHtml
+ Markdown -> do
+ let ext = compile "*.md"
+ let msMarkdown = map asMarkdown ms
+ createDirectoryIfMissing True output
+ globDir1 ext output >>= mapM_ removeFile
+ writeMarkdownModules output msMarkdown
+
+ putStrLn $ "Documentation written to: " ++ output
where
- guardMissing [] = return ()
- guardMissing [mn] = do
- hPutStrLn stderr ("purs docs: error: unknown module \"" ++ T.unpack (P.runModuleName mn) ++ "\"")
- exitFailure
- guardMissing mns = do
- hPutStrLn stderr "purs docs: error: unknown modules:"
- forM_ mns $ \mn ->
- hPutStrLn stderr (" * " ++ T.unpack (P.runModuleName mn))
- exitFailure
-
successOrExit :: Either P.MultipleErrors a -> IO a
successOrExit act =
case act of
@@ -104,39 +75,16 @@ docgen (PSCDocsOptions fmt inputGlob output) = do
hPutStrLn stderr $ P.prettyPrintMultipleErrors P.defaultPPEOptions err
exitFailure
- takeByName = takeModulesByName D.modName
- takeByName' = takeModulesByName' D.modName
-
parseAndConvert input =
- runExceptT (D.parseFilesInPackages input []
- >>= uncurry D.convertTaggedModulesInPackage)
+ runExceptT (fmap fst (D.collectDocs compileOutput input []))
>>= successOrExit
--- |
--- Given a list of module names and a list of modules, return a list of modules
--- whose names appeared in the given name list, together with a list of names
--- for which no module could be found in the module list.
---
-takeModulesByName :: (Eq n) => (m -> n) -> [m] -> [n] -> ([m], [n])
-takeModulesByName getModuleName modules names =
- first (map fst) (takeModulesByName' getModuleName modules (map (,()) names))
-
--- |
--- Like takeModulesByName, but also keeps some extra information with each
--- module.
---
-takeModulesByName' :: (Eq n) => (m -> n) -> [m] -> [(n, a)] -> ([(m, a)], [n])
-takeModulesByName' getModuleName modules = foldl go ([], [])
- where
- go (ms, missing) (name, x) =
- case find ((== name) . getModuleName) modules of
- Just m -> ((m, x) : ms, missing)
- Nothing -> (ms, name : missing)
-
-inputFile :: Opts.Parser FilePath
-inputFile = Opts.strArgument $
- Opts.metavar "FILE"
- <> Opts.help "The input .purs file(s)"
+ writeTagsToFile :: String -> [String] -> IO ()
+ writeTagsToFile outputFilename tags = do
+ currentDir <- getCurrentDirectory
+ let outputFile = currentDir </> outputFilename
+ let text = T.pack . unlines $ tags
+ writeUTF8FileT outputFile text
instance Read Format where
readsPrec _ "etags" = [(Etags, "")]
@@ -145,70 +93,46 @@ instance Read Format where
readsPrec _ "html" = [(Html, "")]
readsPrec _ _ = []
-format :: Opts.Parser Format
-format = Opts.option Opts.auto $ Opts.value Markdown
- <> Opts.long "format"
- <> Opts.metavar "FORMAT"
- <> Opts.help "Set output FORMAT (markdown | html | etags | ctags)"
-
-docgenModule :: Opts.Parser String
-docgenModule = Opts.strOption $
- Opts.long "docgen"
- <> Opts.help "A list of module names which should appear in the output. This can optionally include file paths to write individual modules to, by separating with a colon ':'. For example, Prelude:docs/Prelude.md. This option may be specified multiple times."
-
-pscDocsOptions :: Opts.Parser (Format, [FilePath], [String])
-pscDocsOptions = (,,) <$> format <*> many inputFile <*> many docgenModule
-
-parseDocgen :: [String] -> Either String DocgenOutput
-parseDocgen [] = Right EverythingToStdOut
-parseDocgen xs = go xs
- where
- go = intersperse " "
- >>> concat
- >>> words
- >>> map parseItem
- >>> combine
-
-data DocgenOutputItem
- = IToStdOut P.ModuleName
- | IToFile (P.ModuleName, FilePath)
-
-parseItem :: String -> DocgenOutputItem
-parseItem s = case elemIndex ':' s of
- Just i ->
- s # splitAt i
- >>> first (P.moduleNameFromString . T.pack)
- >>> second (drop 1)
- >>> IToFile
- Nothing ->
- IToStdOut (P.moduleNameFromString (T.pack s))
-
- where
- infixr 1 #
- (#) = flip ($)
+defaultOutputForFormat :: Format -> FilePath
+defaultOutputForFormat fmt =
+ case fmt of
+ Markdown -> "generated-docs/md"
+ Html -> "generated-docs/html"
+ Etags -> "TAGS"
+ Ctags -> "tags"
-combine :: [DocgenOutputItem] -> Either String DocgenOutput
-combine [] = Right EverythingToStdOut
-combine (x:xs) = foldM go (initial x) xs
+pscDocsOptions :: Opts.Parser PSCDocsOptions
+pscDocsOptions = PSCDocsOptions <$> format <*> output <*> compileOutputDir <*> many inputFile
where
- initial (IToStdOut m) = ToStdOut [m]
- initial (IToFile m) = ToFiles [m]
-
- go (ToStdOut ms) (IToStdOut m) = Right (ToStdOut (m:ms))
- go (ToFiles ms) (IToFile m) = Right (ToFiles (m:ms))
- go _ _ = Left "Can't mix module names and module name/file path pairs in the same invocation."
-
-buildOptions :: (Format, [FilePath], [String]) -> IO PSCDocsOptions
-buildOptions (fmt, input, mapping) =
- case parseDocgen mapping of
- Right mapping' -> return (PSCDocsOptions fmt input mapping')
- Left err -> do
- hPutStrLn stderr "purs docs: error in --docgen option:"
- hPutStrLn stderr (" " ++ err)
- exitFailure
+ format :: Opts.Parser Format
+ format = Opts.option Opts.auto $
+ Opts.value Html
+ <> Opts.long "format"
+ <> Opts.metavar "FORMAT"
+ <> Opts.help "Set output FORMAT (markdown | html | etags | ctags)"
+
+ output :: Opts.Parser (Maybe FilePath)
+ output = optional $ Opts.strOption $
+ Opts.long "output"
+ <> Opts.short 'o'
+ <> Opts.metavar "DEST"
+ <> Opts.help "File/directory path for docs to be written to"
+
+ compileOutputDir :: Opts.Parser FilePath
+ compileOutputDir = Opts.strOption $
+ Opts.value "output"
+ <> Opts.showDefault
+ <> Opts.long "compile-output"
+ <> Opts.metavar "DIR"
+ <> Opts.help "Compiler output directory"
+
+ inputFile :: Opts.Parser FilePath
+ inputFile = Opts.strArgument $
+ Opts.metavar "FILE"
+ <> Opts.help "The input .purs file(s)"
command :: Opts.Parser (IO ())
-command = (buildOptions >=> docgen) <$> (Opts.helper <*> pscDocsOptions)
+command = docgen <$> (Opts.helper <*> pscDocsOptions)
infoModList :: Opts.InfoMod a
infoModList = Opts.fullDesc <> footerInfo where
@@ -218,17 +142,15 @@ examples :: PP.Doc
examples =
PP.vcat $ map PP.text
[ "Examples:"
- , " print documentation for Data.List to stdout:"
- , " purs docs \"src/**/*.purs\" \".psc-package/*/*/*/src/**/*.purs\" \\"
- , " --docgen Data.List"
+ , " write documentation for all modules to ./generated-docs:"
+ , " purs docs \"src/**/*.purs\" \".psc-package/*/*/*/src/**/*.purs\""
+ , ""
+ , " write documentation in Markdown format for all modules to ./generated-docs:"
+ , " purs docs --format markdown \"src/**/*.purs\" \".psc-package/*/*/*/src/**/*.purs\""
, ""
- , " write documentation for Data.List to docs/Data.List.md:"
- , " purs docs \"src/**/*.purs\" \".psc-package/*/*/*/src/**/*.purs\" \\"
- , " --docgen Data.List:docs/Data.List.md"
+ , " write CTags to ./tags:"
+ , " purs docs --format ctags \"src/**/*.purs\" \".psc-package/*/*/*/src/**/*.purs\""
, ""
- , " write documentation for Data.List to docs/Data.List.md, and"
- , " documentation for Data.List.Lazy to docs/Data.List.Lazy.md:"
- , " purs docs \"src/**/*.purs\" \".psc-package/*/*/*/src/**/*.purs\" \\"
- , " --docgen Data.List:docs/Data.List.md \\"
- , " --docgen Data.List.Lazy:docs/Data.List.Lazy.md"
+ , " write ETags to ./TAGS:"
+ , " purs docs --format etags \"src/**/*.purs\" \".psc-package/*/*/*/src/**/*.purs\""
]
diff --git a/app/Command/Docs/Html.hs b/app/Command/Docs/Html.hs
index 1e4a176..dbb009f 100644
--- a/app/Command/Docs/Html.hs
+++ b/app/Command/Docs/Html.hs
@@ -23,13 +23,10 @@ import qualified Text.Blaze.Html5 as H
import qualified Text.Blaze.Html5.Attributes as A
import qualified Text.Blaze.Html.Renderer.Text as Blaze
import System.IO.UTF8 (writeUTF8FileT)
-import System.FilePath.Glob (glob)
-import System.Directory (removeFile)
import Version (versionString)
writeHtmlModules :: FilePath -> [(P.ModuleName, D.HtmlOutputModule Html)] -> IO ()
writeHtmlModules outputDir modules = do
- glob (outputDir <> "/*.html") >>= mapM_ removeFile
let moduleList = sort $ map fst modules
writeHtmlFile (outputDir ++ "/index.html") (renderIndexModule moduleList)
mapM_ (writeHtmlModule outputDir . (fst &&& layout moduleList)) modules
diff --git a/app/Command/Docs/Markdown.hs b/app/Command/Docs/Markdown.hs
new file mode 100644
index 0000000..60d5098
--- /dev/null
+++ b/app/Command/Docs/Markdown.hs
@@ -0,0 +1,24 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Command.Docs.Markdown
+ ( asMarkdown
+ , writeMarkdownModules
+ ) where
+
+import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Language.PureScript as P
+import qualified Language.PureScript.Docs as D
+import qualified Language.PureScript.Docs.AsMarkdown as D
+import System.IO.UTF8 (writeUTF8FileT)
+
+asMarkdown :: D.Module -> (P.ModuleName, Text)
+asMarkdown m = (D.modName m, D.runDocs . D.moduleAsMarkdown $ m)
+
+writeMarkdownModules :: FilePath -> [(P.ModuleName, Text)] -> IO ()
+writeMarkdownModules outputDir = mapM_ $ writeMarkdownModule outputDir
+
+writeMarkdownModule :: FilePath -> (P.ModuleName, Text) -> IO ()
+writeMarkdownModule outputDir (mn, text) = do
+ let filepath = outputDir ++ "/" ++ T.unpack (P.runModuleName mn) ++ ".md"
+ writeUTF8FileT filepath text
diff --git a/app/Command/Hierarchy.hs b/app/Command/Hierarchy.hs
index 0966c9a..9e0b26e 100644
--- a/app/Command/Hierarchy.hs
+++ b/app/Command/Hierarchy.hs
@@ -33,6 +33,7 @@ import System.Exit (exitFailure, exitSuccess)
import System.IO (hPutStr, stderr)
import System.IO.UTF8 (readUTF8FileT)
import qualified Language.PureScript as P
+import qualified Language.PureScript.CST as CST
import Language.PureScript.Hierarchy (Graph(..), _unDigraph, _unGraphName, typeClasses)
data HierarchyOptions = HierarchyOptions
@@ -43,7 +44,7 @@ data HierarchyOptions = HierarchyOptions
readInput :: [FilePath] -> IO (Either P.MultipleErrors [P.Module])
readInput paths = do
content <- mapM (\path -> (path, ) <$> readUTF8FileT path) paths
- return $ map snd <$> P.parseModulesFromFiles id content
+ return $ map snd <$> CST.parseFromFiles id content
compile :: HierarchyOptions -> IO ()
compile (HierarchyOptions inputGlob mOutput) = do
diff --git a/app/Command/Publish.hs b/app/Command/Publish.hs
index bffb3e8..43a9f6a 100644
--- a/app/Command/Publish.hs
+++ b/app/Command/Publish.hs
@@ -12,6 +12,13 @@ import Language.PureScript.Publish.ErrorsWarnings
import Options.Applicative (Parser)
import qualified Options.Applicative as Opts
+data PublishOptionsCLI = PublishOptionsCLI
+ { cliManifestPath :: FilePath
+ , cliResolutionsPath :: FilePath
+ , cliCompileOutputDir :: FilePath
+ , cliDryRun :: Bool
+ }
+
manifestPath :: Parser FilePath
manifestPath = Opts.strOption $
Opts.long "manifest"
@@ -29,23 +36,45 @@ dryRun = Opts.switch $
Opts.long "dry-run"
<> Opts.help "Produce no output, and don't require a tagged version to be checked out."
-dryRunOptions :: PublishOptions
-dryRunOptions = defaultPublishOptions
- { publishGetVersion = return dummyVersion
- , publishWorkingTreeDirty = warn DirtyWorkingTree_Warn
- , publishGetTagTime = const (liftIO getCurrentTime)
- }
- where dummyVersion = ("0.0.0", Version [0,0,0] [])
+compileOutputDir :: Opts.Parser FilePath
+compileOutputDir = Opts.option Opts.auto $
+ Opts.value "output"
+ <> Opts.showDefault
+ <> Opts.long "compile-output"
+ <> Opts.metavar "DIR"
+ <> Opts.help "Compiler output directory"
+
+cliOptions :: Opts.Parser PublishOptionsCLI
+cliOptions =
+ PublishOptionsCLI <$> manifestPath <*> resolutionsPath <*> compileOutputDir <*> dryRun
+
+mkPublishOptions :: PublishOptionsCLI -> PublishOptions
+mkPublishOptions cliOpts =
+ let
+ opts =
+ defaultPublishOptions
+ { publishManifestFile = cliManifestPath cliOpts
+ , publishResolutionsFile = cliResolutionsPath cliOpts
+ , publishCompileOutputDir = cliCompileOutputDir cliOpts
+ }
+ in
+ if cliDryRun cliOpts
+ then
+ opts
+ { publishGetVersion = return ("0.0.0", Version [0,0,0] [])
+ , publishGetTagTime = const (liftIO getCurrentTime)
+ , publishWorkingTreeDirty = warn DirtyWorkingTree_Warn
+ }
+ else
+ opts
command :: Opts.Parser (IO ())
-command = publish <$> manifestPath <*> resolutionsPath <*> (Opts.helper <*> dryRun)
-
-publish :: FilePath -> FilePath -> Bool -> IO ()
-publish manifestFile resolutionsFile isDryRun =
- if isDryRun
- then do
- _ <- unsafePreparePackage manifestFile resolutionsFile dryRunOptions
- putStrLn "Dry run completed, no errors."
- else do
- pkg <- unsafePreparePackage manifestFile resolutionsFile defaultPublishOptions
- BL.putStrLn (A.encode pkg)
+command = publish <$> (Opts.helper <*> cliOptions)
+
+publish :: PublishOptionsCLI -> IO ()
+publish cliOpts = do
+ let opts = mkPublishOptions cliOpts
+ pkg <- unsafePreparePackage opts
+ if cliDryRun cliOpts
+ then putStrLn "Dry run completed, no errors."
+ else BL.putStrLn (A.encode pkg)
diff --git a/app/Command/REPL.hs b/app/Command/REPL.hs
index df9a66e..f44c1e8 100644
--- a/app/Command/REPL.hs
+++ b/app/Command/REPL.hs
@@ -36,6 +36,7 @@ import Data.Text (Text, unpack)
import Data.Traversable (for)
import qualified Language.PureScript as P
import qualified Language.PureScript.Bundle as Bundle
+import qualified Language.PureScript.CST as CST
import Language.PureScript.Interactive
import Network.HTTP.Types.Header (hContentType, hCacheControl,
hPragma, hExpires)
@@ -315,10 +316,10 @@ command = loop <$> options
when (null modules) . liftIO $ do
putStr noInputMessage
exitFailure
- unless (supportModuleIsDefined (map snd modules)) . liftIO $ do
+ unless (supportModuleIsDefined (map (P.getModuleName . snd) modules)) . liftIO $ do
putStr supportModuleMessage
exitFailure
- (externs, _) <- ExceptT . runMake . make $ modules
+ (externs, _) <- ExceptT . runMake . make $ fmap CST.pureResult <$> modules
return (modules, externs)
case psciBackend of
Backend setup eval reload (shutdown :: state -> IO ()) ->
diff --git a/purescript.cabal b/purescript.cabal
index 5d463ca..86787a3 100644
--- a/purescript.cabal
+++ b/purescript.cabal
@@ -4,10 +4,10 @@ cabal-version: 1.12
--
-- see: https://github.com/sol/hpack
--
--- hash: b87efeaa8dc8b1bdeba35e1f2f57e0d2a914ef7e4de4c856b7af986c7cdbd7fc
+-- hash: a831e2c306c517805ea62378fee77f2b0cdb0df3f38171ce63de73f7dcf9455f
name: purescript
-version: 0.12.5
+version: 0.13.0
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
@@ -29,6 +29,7 @@ extra-source-files:
app/static/pursuit.less
bundle/build.sh
bundle/README
+ tests/purs/docs/output/TypeSynonymInstance/index.js
tests/purs/failing/MissingFFIImplementations.js
tests/purs/passing/2172.js
tests/purs/passing/EffFn.js
@@ -38,6 +39,7 @@ extra-source-files:
tests/purs/warning/UnnecessaryFFIModule.js
tests/purs/warning/UnusedFFIImplementations.js
tests/purs/bundle/PSasConstructor.purs
+ tests/purs/docs/bower_components/purescript-newtype/src/Data/Newtype.purs
tests/purs/docs/bower_components/purescript-prelude/src/Prelude.purs
tests/purs/docs/src/Ado.purs
tests/purs/docs/src/ChildDeclOrder.purs
@@ -78,6 +80,8 @@ extra-source-files:
tests/purs/docs/src/TypeClassWithoutMembersIntermediate.purs
tests/purs/docs/src/TypeLevelString.purs
tests/purs/docs/src/TypeOpAliases.purs
+ tests/purs/docs/src/TypeSynonym.purs
+ tests/purs/docs/src/TypeSynonymInstance.purs
tests/purs/docs/src/UTF8.purs
tests/purs/docs/src/Virtual.purs
tests/purs/failing/1071.purs
@@ -113,15 +117,19 @@ extra-source-files:
tests/purs/failing/3275-DataBindingGroupErrorPos.purs
tests/purs/failing/3335-TypeOpAssociativityError.purs
tests/purs/failing/3405.purs
+ tests/purs/failing/3549-a.purs
+ tests/purs/failing/3549.purs
tests/purs/failing/365.purs
tests/purs/failing/438.purs
tests/purs/failing/881.purs
tests/purs/failing/AnonArgument1.purs
tests/purs/failing/AnonArgument2.purs
tests/purs/failing/AnonArgument3.purs
+ tests/purs/failing/ApostropheModuleName.purs
tests/purs/failing/ArgLengthMismatch.purs
tests/purs/failing/Arrays.purs
tests/purs/failing/ArrayType.purs
+ tests/purs/failing/AtPatternPrecedence.purs
tests/purs/failing/BindInDo-2.purs
tests/purs/failing/BindInDo.purs
tests/purs/failing/CannotDeriveNewtypeForData.purs
@@ -176,6 +184,9 @@ extra-source-files:
tests/purs/failing/ExportConflictClass.purs
tests/purs/failing/ExportConflictClass/A.purs
tests/purs/failing/ExportConflictClass/B.purs
+ tests/purs/failing/ExportConflictClassAndType.purs
+ tests/purs/failing/ExportConflictClassAndType/A.purs
+ tests/purs/failing/ExportConflictClassAndType/B.purs
tests/purs/failing/ExportConflictCtor.purs
tests/purs/failing/ExportConflictCtor/A.purs
tests/purs/failing/ExportConflictCtor/B.purs
@@ -262,6 +273,8 @@ extra-source-files:
tests/purs/failing/NullaryAbs.purs
tests/purs/failing/Object.purs
tests/purs/failing/OperatorAliasNoExport.purs
+ tests/purs/failing/OperatorAt.purs
+ tests/purs/failing/OperatorBackslash.purs
tests/purs/failing/OperatorSections.purs
tests/purs/failing/OrphanInstance.purs
tests/purs/failing/OrphanInstance/Class.purs
@@ -296,6 +309,8 @@ extra-source-files:
tests/purs/failing/RowInInstanceNotDetermined1.purs
tests/purs/failing/RowInInstanceNotDetermined2.purs
tests/purs/failing/RowLacks.purs
+ tests/purs/failing/SelfImport.purs
+ tests/purs/failing/SelfImport/Dummy.purs
tests/purs/failing/SkolemEscape.purs
tests/purs/failing/SkolemEscape2.purs
tests/purs/failing/SuggestComposition.purs
@@ -329,6 +344,18 @@ extra-source-files:
tests/purs/failing/UnusableTypeClassMethod.purs
tests/purs/failing/UnusableTypeClassMethodConflictingIdent.purs
tests/purs/failing/UnusableTypeClassMethodSynonym.purs
+ tests/purs/failing/Whitespace1.purs
+ tests/purs/layout/AdoIn.purs
+ tests/purs/layout/CaseGuards.purs
+ tests/purs/layout/CaseWhere.purs
+ tests/purs/layout/ClassHead.purs
+ tests/purs/layout/Commas.purs
+ tests/purs/layout/Delimiter.purs
+ tests/purs/layout/DoLet.purs
+ tests/purs/layout/DoOperator.purs
+ tests/purs/layout/DoWhere.purs
+ tests/purs/layout/IfThenElseDo.purs
+ tests/purs/layout/InstanceChainElse.purs
tests/purs/passing/1110.purs
tests/purs/passing/1185.purs
tests/purs/passing/1335.purs
@@ -373,6 +400,7 @@ extra-source-files:
tests/purs/passing/3388.purs
tests/purs/passing/3410.purs
tests/purs/passing/3481.purs
+ tests/purs/passing/3549.purs
tests/purs/passing/3595.purs
tests/purs/passing/652.purs
tests/purs/passing/810.purs
@@ -403,6 +431,7 @@ extra-source-files:
tests/purs/passing/Conditional.purs
tests/purs/passing/Console.purs
tests/purs/passing/ConstraintInference.purs
+ tests/purs/passing/ConstraintOutsideForall.purs
tests/purs/passing/ConstraintParens.purs
tests/purs/passing/ConstraintParsingIssue.purs
tests/purs/passing/ContextSimplification.purs
@@ -445,6 +474,7 @@ extra-source-files:
tests/purs/passing/ForeignKind.purs
tests/purs/passing/ForeignKind/Lib.purs
tests/purs/passing/FunctionalDependencies.purs
+ tests/purs/passing/FunctionAndCaseGuards.purs
tests/purs/passing/Functions.purs
tests/purs/passing/Functions2.purs
tests/purs/passing/FunctionScope.purs
@@ -631,6 +661,7 @@ extra-source-files:
tests/purs/passing/TransitiveImport.purs
tests/purs/passing/TransitiveImport/Middle.purs
tests/purs/passing/TransitiveImport/Test.purs
+ tests/purs/passing/TypeAnnotationPrecedence.purs
tests/purs/passing/TypeClasses.purs
tests/purs/passing/TypeClassesInOrder.purs
tests/purs/passing/TypeClassesWithOverlappingTypeVariables.purs
@@ -704,8 +735,428 @@ extra-source-files:
tests/purs/warning/WildcardInferredType.purs
tests/purs/warning/WildcardInferredType2.purs
tests/purs/docs/bower.json
+ tests/purs/docs/output/Ado/docs.json
+ tests/purs/docs/output/Ado/externs.json
+ tests/purs/docs/output/ChildDeclOrder/docs.json
+ tests/purs/docs/output/ChildDeclOrder/externs.json
+ tests/purs/docs/output/Clash/docs.json
+ tests/purs/docs/output/Clash/externs.json
+ tests/purs/docs/output/Clash1/docs.json
+ tests/purs/docs/output/Clash1/externs.json
+ tests/purs/docs/output/Clash1a/docs.json
+ tests/purs/docs/output/Clash1a/externs.json
+ tests/purs/docs/output/Clash2/docs.json
+ tests/purs/docs/output/Clash2/externs.json
+ tests/purs/docs/output/Clash2a/docs.json
+ tests/purs/docs/output/Clash2a/externs.json
+ tests/purs/docs/output/ConstrainedArgument/docs.json
+ tests/purs/docs/output/ConstrainedArgument/externs.json
+ tests/purs/docs/output/Data.Newtype/docs.json
+ tests/purs/docs/output/Data.Newtype/externs.json
+ tests/purs/docs/output/DeclOrder/docs.json
+ tests/purs/docs/output/DeclOrder/externs.json
+ tests/purs/docs/output/DeclOrderNoExportList/docs.json
+ tests/purs/docs/output/DeclOrderNoExportList/externs.json
+ tests/purs/docs/output/Desugar/docs.json
+ tests/purs/docs/output/Desugar/externs.json
+ tests/purs/docs/output/DocComments/docs.json
+ tests/purs/docs/output/DocComments/externs.json
+ tests/purs/docs/output/DuplicateNames/docs.json
+ tests/purs/docs/output/DuplicateNames/externs.json
+ tests/purs/docs/output/Example/docs.json
+ tests/purs/docs/output/Example/externs.json
+ tests/purs/docs/output/Example2/docs.json
+ tests/purs/docs/output/Example2/externs.json
+ tests/purs/docs/output/ExplicitExport/docs.json
+ tests/purs/docs/output/ExplicitExport/externs.json
+ tests/purs/docs/output/ExplicitTypeSignatures/docs.json
+ tests/purs/docs/output/ExplicitTypeSignatures/externs.json
+ tests/purs/docs/output/ImportedTwice/docs.json
+ tests/purs/docs/output/ImportedTwice/externs.json
+ tests/purs/docs/output/ImportedTwiceA/docs.json
+ tests/purs/docs/output/ImportedTwiceA/externs.json
+ tests/purs/docs/output/ImportedTwiceB/docs.json
+ tests/purs/docs/output/ImportedTwiceB/externs.json
+ tests/purs/docs/output/MultiVirtual/docs.json
+ tests/purs/docs/output/MultiVirtual/externs.json
+ tests/purs/docs/output/MultiVirtual1/docs.json
+ tests/purs/docs/output/MultiVirtual1/externs.json
+ tests/purs/docs/output/MultiVirtual2/docs.json
+ tests/purs/docs/output/MultiVirtual2/externs.json
+ tests/purs/docs/output/MultiVirtual3/docs.json
+ tests/purs/docs/output/MultiVirtual3/externs.json
+ tests/purs/docs/output/NewOperators/docs.json
+ tests/purs/docs/output/NewOperators/externs.json
+ tests/purs/docs/output/NewOperators2/docs.json
+ tests/purs/docs/output/NewOperators2/externs.json
+ tests/purs/docs/output/NotAllCtors/docs.json
+ tests/purs/docs/output/NotAllCtors/externs.json
+ tests/purs/docs/output/Prelude/docs.json
+ tests/purs/docs/output/Prelude/externs.json
+ tests/purs/docs/output/PrimSubmodules/docs.json
+ tests/purs/docs/output/PrimSubmodules/externs.json
+ tests/purs/docs/output/ReExportedTypeClass/docs.json
+ tests/purs/docs/output/ReExportedTypeClass/externs.json
+ tests/purs/docs/output/SolitaryTypeClassMember/docs.json
+ tests/purs/docs/output/SolitaryTypeClassMember/externs.json
+ tests/purs/docs/output/SomeTypeClass/docs.json
+ tests/purs/docs/output/SomeTypeClass/externs.json
+ tests/purs/docs/output/Transitive1/docs.json
+ tests/purs/docs/output/Transitive1/externs.json
+ tests/purs/docs/output/Transitive2/docs.json
+ tests/purs/docs/output/Transitive2/externs.json
+ tests/purs/docs/output/Transitive3/docs.json
+ tests/purs/docs/output/Transitive3/externs.json
+ tests/purs/docs/output/TypeClassWithFunDeps/docs.json
+ tests/purs/docs/output/TypeClassWithFunDeps/externs.json
+ tests/purs/docs/output/TypeClassWithoutMembers/docs.json
+ tests/purs/docs/output/TypeClassWithoutMembers/externs.json
+ tests/purs/docs/output/TypeClassWithoutMembersIntermediate/docs.json
+ tests/purs/docs/output/TypeClassWithoutMembersIntermediate/externs.json
+ tests/purs/docs/output/TypeLevelString/docs.json
+ tests/purs/docs/output/TypeLevelString/externs.json
+ tests/purs/docs/output/TypeOpAliases/docs.json
+ tests/purs/docs/output/TypeOpAliases/externs.json
+ tests/purs/docs/output/TypeSynonym/docs.json
+ tests/purs/docs/output/TypeSynonym/externs.json
+ tests/purs/docs/output/TypeSynonymInstance/docs.json
+ tests/purs/docs/output/TypeSynonymInstance/externs.json
+ tests/purs/docs/output/UTF8/docs.json
+ tests/purs/docs/output/UTF8/externs.json
+ tests/purs/docs/output/Virtual/docs.json
+ tests/purs/docs/output/Virtual/externs.json
tests/purs/docs/resolutions.json
tests/purs/publish/basic-example/bower.json
+ tests/purs/publish/basic-example/output/Control.Alt/docs.json
+ tests/purs/publish/basic-example/output/Control.Alt/externs.json
+ tests/purs/publish/basic-example/output/Control.Alternative/docs.json
+ tests/purs/publish/basic-example/output/Control.Alternative/externs.json
+ tests/purs/publish/basic-example/output/Control.Applicative/docs.json
+ tests/purs/publish/basic-example/output/Control.Applicative/externs.json
+ tests/purs/publish/basic-example/output/Control.Apply/docs.json
+ tests/purs/publish/basic-example/output/Control.Apply/externs.json
+ tests/purs/publish/basic-example/output/Control.Biapplicative/docs.json
+ tests/purs/publish/basic-example/output/Control.Biapplicative/externs.json
+ tests/purs/publish/basic-example/output/Control.Biapply/docs.json
+ tests/purs/publish/basic-example/output/Control.Biapply/externs.json
+ tests/purs/publish/basic-example/output/Control.Bind/docs.json
+ tests/purs/publish/basic-example/output/Control.Bind/externs.json
+ tests/purs/publish/basic-example/output/Control.Category/docs.json
+ tests/purs/publish/basic-example/output/Control.Category/externs.json
+ tests/purs/publish/basic-example/output/Control.Comonad/docs.json
+ tests/purs/publish/basic-example/output/Control.Comonad/externs.json
+ tests/purs/publish/basic-example/output/Control.Extend/docs.json
+ tests/purs/publish/basic-example/output/Control.Extend/externs.json
+ tests/purs/publish/basic-example/output/Control.Lazy/docs.json
+ tests/purs/publish/basic-example/output/Control.Lazy/externs.json
+ tests/purs/publish/basic-example/output/Control.Monad.Gen.Class/docs.json
+ tests/purs/publish/basic-example/output/Control.Monad.Gen.Class/externs.json
+ tests/purs/publish/basic-example/output/Control.Monad.Gen.Common/docs.json
+ tests/purs/publish/basic-example/output/Control.Monad.Gen.Common/externs.json
+ tests/purs/publish/basic-example/output/Control.Monad.Gen/docs.json
+ tests/purs/publish/basic-example/output/Control.Monad.Gen/externs.json
+ tests/purs/publish/basic-example/output/Control.Monad.Rec.Class/docs.json
+ tests/purs/publish/basic-example/output/Control.Monad.Rec.Class/externs.json
+ tests/purs/publish/basic-example/output/Control.Monad.ST.Internal/docs.json
+ tests/purs/publish/basic-example/output/Control.Monad.ST.Internal/externs.json
+ tests/purs/publish/basic-example/output/Control.Monad.ST.Ref/docs.json
+ tests/purs/publish/basic-example/output/Control.Monad.ST.Ref/externs.json
+ tests/purs/publish/basic-example/output/Control.Monad.ST/docs.json
+ tests/purs/publish/basic-example/output/Control.Monad.ST/externs.json
+ tests/purs/publish/basic-example/output/Control.Monad/docs.json
+ tests/purs/publish/basic-example/output/Control.Monad/externs.json
+ tests/purs/publish/basic-example/output/Control.MonadPlus/docs.json
+ tests/purs/publish/basic-example/output/Control.MonadPlus/externs.json
+ tests/purs/publish/basic-example/output/Control.MonadZero/docs.json
+ tests/purs/publish/basic-example/output/Control.MonadZero/externs.json
+ tests/purs/publish/basic-example/output/Control.Plus/docs.json
+ tests/purs/publish/basic-example/output/Control.Plus/externs.json
+ tests/purs/publish/basic-example/output/Control.Semigroupoid/docs.json
+ tests/purs/publish/basic-example/output/Control.Semigroupoid/externs.json
+ tests/purs/publish/basic-example/output/Data.Array.NonEmpty.Internal/docs.json
+ tests/purs/publish/basic-example/output/Data.Array.NonEmpty.Internal/externs.json
+ tests/purs/publish/basic-example/output/Data.Array.NonEmpty/docs.json
+ tests/purs/publish/basic-example/output/Data.Array.NonEmpty/externs.json
+ tests/purs/publish/basic-example/output/Data.Array.Partial/docs.json
+ tests/purs/publish/basic-example/output/Data.Array.Partial/externs.json
+ tests/purs/publish/basic-example/output/Data.Array.ST.Iterator/docs.json
+ tests/purs/publish/basic-example/output/Data.Array.ST.Iterator/externs.json
+ tests/purs/publish/basic-example/output/Data.Array.ST.Partial/docs.json
+ tests/purs/publish/basic-example/output/Data.Array.ST.Partial/externs.json
+ tests/purs/publish/basic-example/output/Data.Array.ST/docs.json
+ tests/purs/publish/basic-example/output/Data.Array.ST/externs.json
+ tests/purs/publish/basic-example/output/Data.Array/docs.json
+ tests/purs/publish/basic-example/output/Data.Array/externs.json
+ tests/purs/publish/basic-example/output/Data.Bifoldable/docs.json
+ tests/purs/publish/basic-example/output/Data.Bifoldable/externs.json
+ tests/purs/publish/basic-example/output/Data.Bifunctor.Clown/docs.json
+ tests/purs/publish/basic-example/output/Data.Bifunctor.Clown/externs.json
+ tests/purs/publish/basic-example/output/Data.Bifunctor.Flip/docs.json
+ tests/purs/publish/basic-example/output/Data.Bifunctor.Flip/externs.json
+ tests/purs/publish/basic-example/output/Data.Bifunctor.Join/docs.json
+ tests/purs/publish/basic-example/output/Data.Bifunctor.Join/externs.json
+ tests/purs/publish/basic-example/output/Data.Bifunctor.Joker/docs.json
+ tests/purs/publish/basic-example/output/Data.Bifunctor.Joker/externs.json
+ tests/purs/publish/basic-example/output/Data.Bifunctor.Product/docs.json
+ tests/purs/publish/basic-example/output/Data.Bifunctor.Product/externs.json
+ tests/purs/publish/basic-example/output/Data.Bifunctor.Wrap/docs.json
+ tests/purs/publish/basic-example/output/Data.Bifunctor.Wrap/externs.json
+ tests/purs/publish/basic-example/output/Data.Bifunctor/docs.json
+ tests/purs/publish/basic-example/output/Data.Bifunctor/externs.json
+ tests/purs/publish/basic-example/output/Data.Bitraversable/docs.json
+ tests/purs/publish/basic-example/output/Data.Bitraversable/externs.json
+ tests/purs/publish/basic-example/output/Data.Boolean/docs.json
+ tests/purs/publish/basic-example/output/Data.Boolean/externs.json
+ tests/purs/publish/basic-example/output/Data.BooleanAlgebra/docs.json
+ tests/purs/publish/basic-example/output/Data.BooleanAlgebra/externs.json
+ tests/purs/publish/basic-example/output/Data.Bounded/docs.json
+ tests/purs/publish/basic-example/output/Data.Bounded/externs.json
+ tests/purs/publish/basic-example/output/Data.Char.Gen/docs.json
+ tests/purs/publish/basic-example/output/Data.Char.Gen/externs.json
+ tests/purs/publish/basic-example/output/Data.Char/docs.json
+ tests/purs/publish/basic-example/output/Data.Char/externs.json
+ tests/purs/publish/basic-example/output/Data.CommutativeRing/docs.json
+ tests/purs/publish/basic-example/output/Data.CommutativeRing/externs.json
+ tests/purs/publish/basic-example/output/Data.Distributive/docs.json
+ tests/purs/publish/basic-example/output/Data.Distributive/externs.json
+ tests/purs/publish/basic-example/output/Data.DivisionRing/docs.json
+ tests/purs/publish/basic-example/output/Data.DivisionRing/externs.json
+ tests/purs/publish/basic-example/output/Data.Either.Inject/docs.json
+ tests/purs/publish/basic-example/output/Data.Either.Inject/externs.json
+ tests/purs/publish/basic-example/output/Data.Either.Nested/docs.json
+ tests/purs/publish/basic-example/output/Data.Either.Nested/externs.json
+ tests/purs/publish/basic-example/output/Data.Either/docs.json
+ tests/purs/publish/basic-example/output/Data.Either/externs.json
+ tests/purs/publish/basic-example/output/Data.Enum.Gen/docs.json
+ tests/purs/publish/basic-example/output/Data.Enum.Gen/externs.json
+ tests/purs/publish/basic-example/output/Data.Enum/docs.json
+ tests/purs/publish/basic-example/output/Data.Enum/externs.json
+ tests/purs/publish/basic-example/output/Data.Eq/docs.json
+ tests/purs/publish/basic-example/output/Data.Eq/externs.json
+ tests/purs/publish/basic-example/output/Data.EuclideanRing/docs.json
+ tests/purs/publish/basic-example/output/Data.EuclideanRing/externs.json
+ tests/purs/publish/basic-example/output/Data.Field/docs.json
+ tests/purs/publish/basic-example/output/Data.Field/externs.json
+ tests/purs/publish/basic-example/output/Data.Foldable/docs.json
+ tests/purs/publish/basic-example/output/Data.Foldable/externs.json
+ tests/purs/publish/basic-example/output/Data.FoldableWithIndex/docs.json
+ tests/purs/publish/basic-example/output/Data.FoldableWithIndex/externs.json
+ tests/purs/publish/basic-example/output/Data.Function.Uncurried/docs.json
+ tests/purs/publish/basic-example/output/Data.Function.Uncurried/externs.json
+ tests/purs/publish/basic-example/output/Data.Function/docs.json
+ tests/purs/publish/basic-example/output/Data.Function/externs.json
+ tests/purs/publish/basic-example/output/Data.Functor.Invariant/docs.json
+ tests/purs/publish/basic-example/output/Data.Functor.Invariant/externs.json
+ tests/purs/publish/basic-example/output/Data.Functor/docs.json
+ tests/purs/publish/basic-example/output/Data.Functor/externs.json
+ tests/purs/publish/basic-example/output/Data.FunctorWithIndex/docs.json
+ tests/purs/publish/basic-example/output/Data.FunctorWithIndex/externs.json
+ tests/purs/publish/basic-example/output/Data.Generic.Rep.Bounded/docs.json
+ tests/purs/publish/basic-example/output/Data.Generic.Rep.Bounded/externs.json
+ tests/purs/publish/basic-example/output/Data.Generic.Rep.Enum/docs.json
+ tests/purs/publish/basic-example/output/Data.Generic.Rep.Enum/externs.json
+ tests/purs/publish/basic-example/output/Data.Generic.Rep.Eq/docs.json
+ tests/purs/publish/basic-example/output/Data.Generic.Rep.Eq/externs.json
+ tests/purs/publish/basic-example/output/Data.Generic.Rep.Monoid/docs.json
+ tests/purs/publish/basic-example/output/Data.Generic.Rep.Monoid/externs.json
+ tests/purs/publish/basic-example/output/Data.Generic.Rep.Ord/docs.json
+ tests/purs/publish/basic-example/output/Data.Generic.Rep.Ord/externs.json
+ tests/purs/publish/basic-example/output/Data.Generic.Rep.Semigroup/docs.json
+ tests/purs/publish/basic-example/output/Data.Generic.Rep.Semigroup/externs.json
+ tests/purs/publish/basic-example/output/Data.Generic.Rep.Show/docs.json
+ tests/purs/publish/basic-example/output/Data.Generic.Rep.Show/externs.json
+ tests/purs/publish/basic-example/output/Data.Generic.Rep/docs.json
+ tests/purs/publish/basic-example/output/Data.Generic.Rep/externs.json
+ tests/purs/publish/basic-example/output/Data.HeytingAlgebra/docs.json
+ tests/purs/publish/basic-example/output/Data.HeytingAlgebra/externs.json
+ tests/purs/publish/basic-example/output/Data.Identity/docs.json
+ tests/purs/publish/basic-example/output/Data.Identity/externs.json
+ tests/purs/publish/basic-example/output/Data.Int.Bits/docs.json
+ tests/purs/publish/basic-example/output/Data.Int.Bits/externs.json
+ tests/purs/publish/basic-example/output/Data.Int/docs.json
+ tests/purs/publish/basic-example/output/Data.Int/externs.json
+ tests/purs/publish/basic-example/output/Data.Lazy/docs.json
+ tests/purs/publish/basic-example/output/Data.Lazy/externs.json
+ tests/purs/publish/basic-example/output/Data.List.Lazy.NonEmpty/docs.json
+ tests/purs/publish/basic-example/output/Data.List.Lazy.NonEmpty/externs.json
+ tests/purs/publish/basic-example/output/Data.List.Lazy.Types/docs.json
+ tests/purs/publish/basic-example/output/Data.List.Lazy.Types/externs.json
+ tests/purs/publish/basic-example/output/Data.List.Lazy/docs.json
+ tests/purs/publish/basic-example/output/Data.List.Lazy/externs.json
+ tests/purs/publish/basic-example/output/Data.List.NonEmpty/docs.json
+ tests/purs/publish/basic-example/output/Data.List.NonEmpty/externs.json
+ tests/purs/publish/basic-example/output/Data.List.Partial/docs.json
+ tests/purs/publish/basic-example/output/Data.List.Partial/externs.json
+ tests/purs/publish/basic-example/output/Data.List.Types/docs.json
+ tests/purs/publish/basic-example/output/Data.List.Types/externs.json
+ tests/purs/publish/basic-example/output/Data.List.ZipList/docs.json
+ tests/purs/publish/basic-example/output/Data.List.ZipList/externs.json
+ tests/purs/publish/basic-example/output/Data.List/docs.json
+ tests/purs/publish/basic-example/output/Data.List/externs.json
+ tests/purs/publish/basic-example/output/Data.Maybe.First/docs.json
+ tests/purs/publish/basic-example/output/Data.Maybe.First/externs.json
+ tests/purs/publish/basic-example/output/Data.Maybe.Last/docs.json
+ tests/purs/publish/basic-example/output/Data.Maybe.Last/externs.json
+ tests/purs/publish/basic-example/output/Data.Maybe/docs.json
+ tests/purs/publish/basic-example/output/Data.Maybe/externs.json
+ tests/purs/publish/basic-example/output/Data.Monoid.Additive/docs.json
+ tests/purs/publish/basic-example/output/Data.Monoid.Additive/externs.json
+ tests/purs/publish/basic-example/output/Data.Monoid.Conj/docs.json
+ tests/purs/publish/basic-example/output/Data.Monoid.Conj/externs.json
+ tests/purs/publish/basic-example/output/Data.Monoid.Disj/docs.json
+ tests/purs/publish/basic-example/output/Data.Monoid.Disj/externs.json
+ tests/purs/publish/basic-example/output/Data.Monoid.Dual/docs.json
+ tests/purs/publish/basic-example/output/Data.Monoid.Dual/externs.json
+ tests/purs/publish/basic-example/output/Data.Monoid.Endo/docs.json
+ tests/purs/publish/basic-example/output/Data.Monoid.Endo/externs.json
+ tests/purs/publish/basic-example/output/Data.Monoid.Multiplicative/docs.json
+ tests/purs/publish/basic-example/output/Data.Monoid.Multiplicative/externs.json
+ tests/purs/publish/basic-example/output/Data.Monoid/docs.json
+ tests/purs/publish/basic-example/output/Data.Monoid/externs.json
+ tests/purs/publish/basic-example/output/Data.NaturalTransformation/docs.json
+ tests/purs/publish/basic-example/output/Data.NaturalTransformation/externs.json
+ tests/purs/publish/basic-example/output/Data.Newtype/docs.json
+ tests/purs/publish/basic-example/output/Data.Newtype/externs.json
+ tests/purs/publish/basic-example/output/Data.NonEmpty/docs.json
+ tests/purs/publish/basic-example/output/Data.NonEmpty/externs.json
+ tests/purs/publish/basic-example/output/Data.Ord.Down/docs.json
+ tests/purs/publish/basic-example/output/Data.Ord.Down/externs.json
+ tests/purs/publish/basic-example/output/Data.Ord.Max/docs.json
+ tests/purs/publish/basic-example/output/Data.Ord.Max/externs.json
+ tests/purs/publish/basic-example/output/Data.Ord.Min/docs.json
+ tests/purs/publish/basic-example/output/Data.Ord.Min/externs.json
+ tests/purs/publish/basic-example/output/Data.Ord.Unsafe/docs.json
+ tests/purs/publish/basic-example/output/Data.Ord.Unsafe/externs.json
+ tests/purs/publish/basic-example/output/Data.Ord/docs.json
+ tests/purs/publish/basic-example/output/Data.Ord/externs.json
+ tests/purs/publish/basic-example/output/Data.Ordering/docs.json
+ tests/purs/publish/basic-example/output/Data.Ordering/externs.json
+ tests/purs/publish/basic-example/output/Data.Ring/docs.json
+ tests/purs/publish/basic-example/output/Data.Ring/externs.json
+ tests/purs/publish/basic-example/output/Data.Semigroup.First/docs.json
+ tests/purs/publish/basic-example/output/Data.Semigroup.First/externs.json
+ tests/purs/publish/basic-example/output/Data.Semigroup.Foldable/docs.json
+ tests/purs/publish/basic-example/output/Data.Semigroup.Foldable/externs.json
+ tests/purs/publish/basic-example/output/Data.Semigroup.Last/docs.json
+ tests/purs/publish/basic-example/output/Data.Semigroup.Last/externs.json
+ tests/purs/publish/basic-example/output/Data.Semigroup.Traversable/docs.json
+ tests/purs/publish/basic-example/output/Data.Semigroup.Traversable/externs.json
+ tests/purs/publish/basic-example/output/Data.Semigroup/docs.json
+ tests/purs/publish/basic-example/output/Data.Semigroup/externs.json
+ tests/purs/publish/basic-example/output/Data.Semiring/docs.json
+ tests/purs/publish/basic-example/output/Data.Semiring/externs.json
+ tests/purs/publish/basic-example/output/Data.Show/docs.json
+ tests/purs/publish/basic-example/output/Data.Show/externs.json
+ tests/purs/publish/basic-example/output/Data.String.CaseInsensitive/docs.json
+ tests/purs/publish/basic-example/output/Data.String.CaseInsensitive/externs.json
+ tests/purs/publish/basic-example/output/Data.String.CodePoints/docs.json
+ tests/purs/publish/basic-example/output/Data.String.CodePoints/externs.json
+ tests/purs/publish/basic-example/output/Data.String.CodeUnits/docs.json
+ tests/purs/publish/basic-example/output/Data.String.CodeUnits/externs.json
+ tests/purs/publish/basic-example/output/Data.String.Common/docs.json
+ tests/purs/publish/basic-example/output/Data.String.Common/externs.json
+ tests/purs/publish/basic-example/output/Data.String.Gen/docs.json
+ tests/purs/publish/basic-example/output/Data.String.Gen/externs.json
+ tests/purs/publish/basic-example/output/Data.String.NonEmpty.CaseInsensitive/docs.json
+ tests/purs/publish/basic-example/output/Data.String.NonEmpty.CaseInsensitive/externs.json
+ tests/purs/publish/basic-example/output/Data.String.NonEmpty.CodePoints/docs.json
+ tests/purs/publish/basic-example/output/Data.String.NonEmpty.CodePoints/externs.json
+ tests/purs/publish/basic-example/output/Data.String.NonEmpty.CodeUnits/docs.json
+ tests/purs/publish/basic-example/output/Data.String.NonEmpty.CodeUnits/externs.json
+ tests/purs/publish/basic-example/output/Data.String.NonEmpty.Internal/docs.json
+ tests/purs/publish/basic-example/output/Data.String.NonEmpty.Internal/externs.json
+ tests/purs/publish/basic-example/output/Data.String.NonEmpty/docs.json
+ tests/purs/publish/basic-example/output/Data.String.NonEmpty/externs.json
+ tests/purs/publish/basic-example/output/Data.String.Pattern/docs.json
+ tests/purs/publish/basic-example/output/Data.String.Pattern/externs.json
+ tests/purs/publish/basic-example/output/Data.String.Regex.Flags/docs.json
+ tests/purs/publish/basic-example/output/Data.String.Regex.Flags/externs.json
+ tests/purs/publish/basic-example/output/Data.String.Regex.Unsafe/docs.json
+ tests/purs/publish/basic-example/output/Data.String.Regex.Unsafe/externs.json
+ tests/purs/publish/basic-example/output/Data.String.Regex/docs.json
+ tests/purs/publish/basic-example/output/Data.String.Regex/externs.json
+ tests/purs/publish/basic-example/output/Data.String.Unsafe/docs.json
+ tests/purs/publish/basic-example/output/Data.String.Unsafe/externs.json
+ tests/purs/publish/basic-example/output/Data.String/docs.json
+ tests/purs/publish/basic-example/output/Data.String/externs.json
+ tests/purs/publish/basic-example/output/Data.Symbol/docs.json
+ tests/purs/publish/basic-example/output/Data.Symbol/externs.json
+ tests/purs/publish/basic-example/output/Data.Traversable.Accum.Internal/docs.json
+ tests/purs/publish/basic-example/output/Data.Traversable.Accum.Internal/externs.json
+ tests/purs/publish/basic-example/output/Data.Traversable.Accum/docs.json
+ tests/purs/publish/basic-example/output/Data.Traversable.Accum/externs.json
+ tests/purs/publish/basic-example/output/Data.Traversable/docs.json
+ tests/purs/publish/basic-example/output/Data.Traversable/externs.json
+ tests/purs/publish/basic-example/output/Data.TraversableWithIndex/docs.json
+ tests/purs/publish/basic-example/output/Data.TraversableWithIndex/externs.json
+ tests/purs/publish/basic-example/output/Data.Tuple.Nested/docs.json
+ tests/purs/publish/basic-example/output/Data.Tuple.Nested/externs.json
+ tests/purs/publish/basic-example/output/Data.Tuple/docs.json
+ tests/purs/publish/basic-example/output/Data.Tuple/externs.json
+ tests/purs/publish/basic-example/output/Data.Unfoldable/docs.json
+ tests/purs/publish/basic-example/output/Data.Unfoldable/externs.json
+ tests/purs/publish/basic-example/output/Data.Unfoldable1/docs.json
+ tests/purs/publish/basic-example/output/Data.Unfoldable1/externs.json
+ tests/purs/publish/basic-example/output/Data.Unit/docs.json
+ tests/purs/publish/basic-example/output/Data.Unit/externs.json
+ tests/purs/publish/basic-example/output/Data.Void/docs.json
+ tests/purs/publish/basic-example/output/Data.Void/externs.json
+ tests/purs/publish/basic-example/output/Effect.Class.Console/docs.json
+ tests/purs/publish/basic-example/output/Effect.Class.Console/externs.json
+ tests/purs/publish/basic-example/output/Effect.Class/docs.json
+ tests/purs/publish/basic-example/output/Effect.Class/externs.json
+ tests/purs/publish/basic-example/output/Effect.Console/docs.json
+ tests/purs/publish/basic-example/output/Effect.Console/externs.json
+ tests/purs/publish/basic-example/output/Effect.Ref/docs.json
+ tests/purs/publish/basic-example/output/Effect.Ref/externs.json
+ tests/purs/publish/basic-example/output/Effect.Uncurried/docs.json
+ tests/purs/publish/basic-example/output/Effect.Uncurried/externs.json
+ tests/purs/publish/basic-example/output/Effect.Unsafe/docs.json
+ tests/purs/publish/basic-example/output/Effect.Unsafe/externs.json
+ tests/purs/publish/basic-example/output/Effect/docs.json
+ tests/purs/publish/basic-example/output/Effect/externs.json
+ tests/purs/publish/basic-example/output/Global.Unsafe/docs.json
+ tests/purs/publish/basic-example/output/Global.Unsafe/externs.json
+ tests/purs/publish/basic-example/output/Global/docs.json
+ tests/purs/publish/basic-example/output/Global/externs.json
+ tests/purs/publish/basic-example/output/Main/docs.json
+ tests/purs/publish/basic-example/output/Main/externs.json
+ tests/purs/publish/basic-example/output/Math/docs.json
+ tests/purs/publish/basic-example/output/Math/externs.json
+ tests/purs/publish/basic-example/output/Partial.Unsafe/docs.json
+ tests/purs/publish/basic-example/output/Partial.Unsafe/externs.json
+ tests/purs/publish/basic-example/output/Partial/docs.json
+ tests/purs/publish/basic-example/output/Partial/externs.json
+ tests/purs/publish/basic-example/output/Prelude/docs.json
+ tests/purs/publish/basic-example/output/Prelude/externs.json
+ tests/purs/publish/basic-example/output/PSCI.Support/docs.json
+ tests/purs/publish/basic-example/output/PSCI.Support/externs.json
+ tests/purs/publish/basic-example/output/Record.Unsafe/docs.json
+ tests/purs/publish/basic-example/output/Record.Unsafe/externs.json
+ tests/purs/publish/basic-example/output/Test.Assert/docs.json
+ tests/purs/publish/basic-example/output/Test.Assert/externs.json
+ tests/purs/publish/basic-example/output/Type.Data.Boolean/docs.json
+ tests/purs/publish/basic-example/output/Type.Data.Boolean/externs.json
+ tests/purs/publish/basic-example/output/Type.Data.Ordering/docs.json
+ tests/purs/publish/basic-example/output/Type.Data.Ordering/externs.json
+ tests/purs/publish/basic-example/output/Type.Data.Row/docs.json
+ tests/purs/publish/basic-example/output/Type.Data.Row/externs.json
+ tests/purs/publish/basic-example/output/Type.Data.RowList/docs.json
+ tests/purs/publish/basic-example/output/Type.Data.RowList/externs.json
+ tests/purs/publish/basic-example/output/Type.Data.Symbol/docs.json
+ tests/purs/publish/basic-example/output/Type.Data.Symbol/externs.json
+ tests/purs/publish/basic-example/output/Type.Equality/docs.json
+ tests/purs/publish/basic-example/output/Type.Equality/externs.json
+ tests/purs/publish/basic-example/output/Type.Prelude/docs.json
+ tests/purs/publish/basic-example/output/Type.Prelude/externs.json
+ tests/purs/publish/basic-example/output/Type.Proxy/docs.json
+ tests/purs/publish/basic-example/output/Type.Proxy/externs.json
+ tests/purs/publish/basic-example/output/Type.Row.Homogeneous/docs.json
+ tests/purs/publish/basic-example/output/Type.Row.Homogeneous/externs.json
+ tests/purs/publish/basic-example/output/Type.Row/docs.json
+ tests/purs/publish/basic-example/output/Type.Row/externs.json
+ tests/purs/publish/basic-example/output/Unsafe.Coerce/docs.json
+ tests/purs/publish/basic-example/output/Unsafe.Coerce/externs.json
tests/purs/publish/basic-example/resolutions-legacy.json
tests/purs/publish/basic-example/resolutions.json
tests/json-compat/v0.11.3/generics-4.0.0.json
@@ -794,14 +1245,27 @@ library
Language.PureScript.CoreImp.Optimizer.TCO
Language.PureScript.CoreImp.Optimizer.Unused
Language.PureScript.Crash
+ Language.PureScript.CST
+ Language.PureScript.CST.Convert
+ Language.PureScript.CST.Errors
+ Language.PureScript.CST.Layout
+ Language.PureScript.CST.Lexer
+ Language.PureScript.CST.Monad
+ Language.PureScript.CST.Parser
+ Language.PureScript.CST.Positions
+ Language.PureScript.CST.Print
+ Language.PureScript.CST.Traversals
+ Language.PureScript.CST.Traversals.Type
+ Language.PureScript.CST.Types
+ Language.PureScript.CST.Utils
Language.PureScript.Docs
Language.PureScript.Docs.AsHtml
Language.PureScript.Docs.AsMarkdown
+ Language.PureScript.Docs.Collect
Language.PureScript.Docs.Convert
Language.PureScript.Docs.Convert.ReExports
Language.PureScript.Docs.Convert.Single
Language.PureScript.Docs.Css
- Language.PureScript.Docs.ParseInPackage
Language.PureScript.Docs.Prim
Language.PureScript.Docs.Render
Language.PureScript.Docs.RenderedCode
@@ -857,13 +1321,6 @@ library
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
@@ -913,7 +1370,7 @@ library
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 NoMonadFailDesugaring
+ default-extensions: ConstraintKinds DataKinds DeriveFunctor DeriveFoldable DeriveTraversable DeriveGeneric EmptyDataDecls FlexibleContexts KindSignatures LambdaCase MultiParamTypeClasses NoImplicitPrelude PatternGuards PatternSynonyms RankNTypes RecordWildCards OverloadedStrings ScopedTypeVariables TupleSections ViewPatterns
ghc-options: -Wall -O2
build-depends:
Cabal >=2.2
@@ -941,6 +1398,7 @@ library
, fsnotify >=0.2.1
, haskeline >=0.7.0.0
, language-javascript >=0.6.0.9 && <0.7
+ , lifted-async >=0.10.0.3 && <0.10.1
, lifted-base >=0.2.3 && <0.2.4
, microlens-platform >=0.3.9.0 && <0.4
, monad-control >=1.0.0.0 && <1.1
@@ -977,6 +1435,7 @@ executable purs
Command.Compile
Command.Docs
Command.Docs.Html
+ Command.Docs.Markdown
Command.Hierarchy
Command.Ide
Command.Publish
@@ -1014,6 +1473,7 @@ executable purs
, haskeline >=0.7.0.0
, http-types
, language-javascript >=0.6.0.9 && <0.7
+ , lifted-async >=0.10.0.3 && <0.10.1
, lifted-base >=0.2.3 && <0.2.4
, microlens-platform >=0.3.9.0 && <0.4
, monad-control >=1.0.0.0 && <1.1
@@ -1073,6 +1533,7 @@ test-suite tests
TestBundle
TestCompiler
TestCoreFn
+ TestCst
TestDocs
TestHierarchy
TestIde
@@ -1118,6 +1579,7 @@ test-suite tests
, hspec
, hspec-discover
, language-javascript >=0.6.0.9 && <0.7
+ , lifted-async >=0.10.0.3 && <0.10.1
, lifted-base >=0.2.3 && <0.2.4
, microlens-platform >=0.3.9.0 && <0.4
, monad-control >=1.0.0.0 && <1.1
@@ -1139,7 +1601,9 @@ test-suite tests
, stringsearch
, syb
, tasty
+ , tasty-golden
, tasty-hspec
+ , tasty-quickcheck
, text
, time
, transformers >=0.3.0 && <0.6
diff --git a/src/Language/PureScript.hs b/src/Language/PureScript.hs
index a2c7554..eeb0ebd 100644
--- a/src/Language/PureScript.hs
+++ b/src/Language/PureScript.hs
@@ -23,7 +23,6 @@ import Language.PureScript.Make as P
import Language.PureScript.ModuleDependencies as P
import Language.PureScript.Names as P
import Language.PureScript.Options as P
-import Language.PureScript.Parser as P
import Language.PureScript.Pretty as P
import Language.PureScript.Renamer as P
import Language.PureScript.Sugar as P
diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs
index ea2fecc..4de31e2 100644
--- a/src/Language/PureScript/AST/Declarations.hs
+++ b/src/Language/PureScript/AST/Declarations.hs
@@ -35,6 +35,7 @@ import Language.PureScript.Comments
import Language.PureScript.Environment
import qualified Language.PureScript.Bundle as Bundle
import qualified Language.PureScript.Constants as C
+import qualified Language.PureScript.CST.Errors as CST
import qualified Text.Parsec as P
@@ -68,6 +69,7 @@ data SimpleErrorMessage
= ModuleNotFound ModuleName
| ErrorParsingFFIModule FilePath (Maybe Bundle.ErrorMessage)
| ErrorParsingModule P.ParseError
+ | ErrorParsingCSTModule CST.ParserError
| MissingFFIModule ModuleName
| UnnecessaryFFIModule ModuleName FilePath
| MissingFFIImplementations ModuleName [Ident]
diff --git a/src/Language/PureScript/CST.hs b/src/Language/PureScript/CST.hs
new file mode 100644
index 0000000..1503f18
--- /dev/null
+++ b/src/Language/PureScript/CST.hs
@@ -0,0 +1,95 @@
+module Language.PureScript.CST
+ ( parseFromFile
+ , parseFromFiles
+ , parseModuleFromFile
+ , parseModulesFromFiles
+ , unwrapParserError
+ , toMultipleErrors
+ , toPositionedError
+ , pureResult
+ , module Language.PureScript.CST.Convert
+ , module Language.PureScript.CST.Errors
+ , module Language.PureScript.CST.Lexer
+ , module Language.PureScript.CST.Monad
+ , module Language.PureScript.CST.Parser
+ , module Language.PureScript.CST.Print
+ , module Language.PureScript.CST.Types
+ ) where
+
+import Prelude hiding (lex)
+
+import Control.Monad.Error.Class (MonadError(..))
+import Control.Parallel.Strategies (withStrategy, parList, evalTuple2, r0, rseq)
+import qualified Data.List.NonEmpty as NE
+import Data.Text (Text)
+import qualified Language.PureScript.AST as AST
+import qualified Language.PureScript.Errors as E
+import Language.PureScript.CST.Convert
+import Language.PureScript.CST.Errors
+import Language.PureScript.CST.Lexer
+import Language.PureScript.CST.Monad (Parser, ParserM(..), ParserState(..), LexResult, runParser, runTokenParser)
+import Language.PureScript.CST.Parser
+import Language.PureScript.CST.Print
+import Language.PureScript.CST.Types
+
+pureResult :: a -> PartialResult a
+pureResult a = PartialResult a (pure a)
+
+parseModulesFromFiles
+ :: forall m k
+ . MonadError E.MultipleErrors m
+ => (k -> FilePath)
+ -> [(k, Text)]
+ -> m [(k, PartialResult AST.Module)]
+parseModulesFromFiles toFilePath input =
+ flip E.parU (handleParserError toFilePath)
+ . inParallel
+ . flip fmap input
+ $ \(k, a) -> (k, parseModuleFromFile (toFilePath k) a)
+
+parseFromFiles
+ :: forall m k
+ . MonadError E.MultipleErrors m
+ => (k -> FilePath)
+ -> [(k, Text)]
+ -> m [(k, AST.Module)]
+parseFromFiles toFilePath input =
+ flip E.parU (handleParserError toFilePath)
+ . inParallel
+ . flip fmap input
+ $ \(k, a) -> (k, parseFromFile (toFilePath k) a)
+
+parseModuleFromFile :: FilePath -> Text -> Either (NE.NonEmpty ParserError) (PartialResult AST.Module)
+parseModuleFromFile fp content = fmap (convertModule fp) <$> parseModule (lex content)
+
+parseFromFile :: FilePath -> Text -> Either (NE.NonEmpty ParserError) AST.Module
+parseFromFile fp content = convertModule fp <$> parse content
+
+handleParserError
+ :: forall m k a
+ . MonadError E.MultipleErrors m
+ => (k -> FilePath)
+ -> (k, Either (NE.NonEmpty ParserError) a)
+ -> m (k, a)
+handleParserError toFilePath (k, res) =
+ (k,) <$> unwrapParserError (toFilePath k) res
+
+unwrapParserError
+ :: forall m a
+ . MonadError E.MultipleErrors m
+ => FilePath
+ -> Either (NE.NonEmpty ParserError) a
+ -> m a
+unwrapParserError fp =
+ either (throwError . toMultipleErrors fp) pure
+
+toMultipleErrors :: FilePath -> NE.NonEmpty ParserError -> E.MultipleErrors
+toMultipleErrors fp =
+ E.MultipleErrors . NE.toList . fmap (toPositionedError fp)
+
+toPositionedError :: FilePath -> ParserError -> E.ErrorMessage
+toPositionedError name perr =
+ E.ErrorMessage [E.positionedError $ sourceSpan name $ errRange perr] (E.ErrorParsingCSTModule perr)
+
+inParallel :: [(k, Either (NE.NonEmpty ParserError) a)] -> [(k, Either (NE.NonEmpty ParserError) a)]
+inParallel = withStrategy (parList (evalTuple2 r0 rseq))
diff --git a/src/Language/PureScript/CST/Convert.hs b/src/Language/PureScript/CST/Convert.hs
new file mode 100644
index 0000000..80e8cc4
--- /dev/null
+++ b/src/Language/PureScript/CST/Convert.hs
@@ -0,0 +1,636 @@
+-- | This module contains functions for converting the CST into the core AST. It
+-- is mostly boilerplate, and does the job of resolving ranges for all the nodes
+-- and attaching comments.
+
+module Language.PureScript.CST.Convert
+ ( convertKind
+ , convertType
+ , convertExpr
+ , convertBinder
+ , convertDeclaration
+ , convertImportDecl
+ , convertModule
+ , sourcePos
+ , sourceSpan
+ , comment
+ , comments
+ ) where
+
+import Prelude
+
+import Data.Bifunctor (bimap, first)
+import Data.Foldable (foldl', toList)
+import Data.Functor (($>))
+import qualified Data.List.NonEmpty as NE
+import Data.Maybe (isJust, fromJust, mapMaybe)
+import qualified Data.Text as Text
+import qualified Language.PureScript.AST as AST
+import qualified Language.PureScript.AST.SourcePos as Pos
+import qualified Language.PureScript.Comments as C
+import qualified Language.PureScript.Environment as Env
+import qualified Language.PureScript.Kinds as K
+import qualified Language.PureScript.Label as L
+import qualified Language.PureScript.Names as N
+import Language.PureScript.PSString (mkString)
+import qualified Language.PureScript.Types as T
+import Language.PureScript.CST.Positions
+import Language.PureScript.CST.Types
+
+comment :: Comment a -> Maybe C.Comment
+comment = \case
+ Comment t
+ | Text.isPrefixOf "{-" t -> Just $ C.BlockComment $ Text.drop 2 $ Text.dropEnd 2 t
+ | Text.isPrefixOf "--" t -> Just $ C.LineComment $ Text.drop 2 t
+ _ -> Nothing
+
+comments :: [Comment a] -> [C.Comment]
+comments = mapMaybe comment
+
+sourcePos :: SourcePos -> Pos.SourcePos
+sourcePos (SourcePos line col) = Pos.SourcePos line col
+
+sourceSpan :: String -> SourceRange -> Pos.SourceSpan
+sourceSpan name (SourceRange start end) = Pos.SourceSpan name (sourcePos start) (sourcePos end)
+
+widenLeft :: TokenAnn -> Pos.SourceAnn -> Pos.SourceAnn
+widenLeft ann (sp, _) =
+ ( Pos.widenSourceSpan (sourceSpan (Pos.spanName sp) $ tokRange ann) sp
+ , comments $ tokLeadingComments ann
+ )
+
+sourceAnnCommented :: String -> SourceToken -> SourceToken -> Pos.SourceAnn
+sourceAnnCommented fileName (SourceToken ann1 _) (SourceToken ann2 _) =
+ ( Pos.SourceSpan fileName (sourcePos $ srcStart $ tokRange ann1) (sourcePos $ srcEnd $ tokRange ann2)
+ , comments $ tokLeadingComments ann1
+ )
+
+sourceAnn :: String -> SourceToken -> SourceToken -> Pos.SourceAnn
+sourceAnn fileName (SourceToken ann1 _) (SourceToken ann2 _) =
+ ( Pos.SourceSpan fileName (sourcePos $ srcStart $ tokRange ann1) (sourcePos $ srcEnd $ tokRange ann2)
+ , []
+ )
+
+sourceName :: String -> Name a -> Pos.SourceAnn
+sourceName fileName a = sourceAnnCommented fileName (nameTok a) (nameTok a)
+
+sourceQualName :: String -> QualifiedName a -> Pos.SourceAnn
+sourceQualName fileName a = sourceAnnCommented fileName (qualTok a) (qualTok a)
+
+moduleName :: Token -> Maybe N.ModuleName
+moduleName = \case
+ TokLowerName as _ -> go as
+ TokUpperName as _ -> go as
+ TokSymbolName as _ -> go as
+ TokOperator as _ -> go as
+ _ -> Nothing
+ where
+ go [] = Nothing
+ go ns = Just $ N.ModuleName $ N.ProperName <$> ns
+
+qualified :: QualifiedName a -> N.Qualified a
+qualified q = N.Qualified (qualModule q) (qualName q)
+
+ident :: Ident -> N.Ident
+ident = N.Ident . getIdent
+
+convertKind :: String -> Kind a -> K.SourceKind
+convertKind fileName = go
+ where
+ go = \case
+ KindName _ a ->
+ K.NamedKind (sourceQualName fileName a) $ qualified a
+ KindArr _ a _ b -> do
+ let
+ lhs = go a
+ rhs = go b
+ ann = Pos.widenSourceAnn (K.getAnnForKind lhs) (K.getAnnForKind rhs)
+ K.FunKind ann lhs rhs
+ KindRow _ tok a -> do
+ let
+ kind = go a
+ ann = widenLeft (tokAnn tok) $ K.getAnnForKind kind
+ K.Row ann kind
+ KindParens _ (Wrapped _ a _) ->
+ go a
+
+convertType :: String -> Type a -> T.SourceType
+convertType fileName = go
+ where
+ goRow (Row labels tl) b = do
+ let
+ rowTail = case tl of
+ Just (_, ty) -> go ty
+ Nothing -> T.REmpty $ sourceAnnCommented fileName b b
+ rowCons (Labeled a _ ty) c = do
+ let ann = sourceAnnCommented fileName (lblTok a) (snd $ typeRange ty)
+ T.RCons ann (L.Label $ lblName a) (go ty) c
+ case labels of
+ Just (Separated h t) ->
+ rowCons h $ foldr (rowCons . snd) rowTail t
+ Nothing ->
+ rowTail
+
+ go = \case
+ TypeVar _ a ->
+ T.TypeVar (sourceName fileName a) . getIdent $ nameValue a
+ TypeConstructor _ a ->
+ T.TypeConstructor (sourceQualName fileName a) $ qualified a
+ TypeWildcard _ a ->
+ T.TypeWildcard (sourceAnnCommented fileName a a) Nothing
+ TypeHole _ a ->
+ T.TypeWildcard (sourceName fileName a) . Just . getIdent $ nameValue a
+ TypeString _ a b ->
+ T.TypeLevelString (sourceAnnCommented fileName a a) $ b
+ TypeRow _ (Wrapped _ row b) ->
+ goRow row b
+ TypeRecord _ (Wrapped a row b) -> do
+ let
+ ann = sourceAnnCommented fileName a b
+ annRec = sourceAnn fileName a a
+ T.TypeApp ann (Env.tyRecord $> annRec) $ goRow row b
+ TypeForall _ kw bindings _ ty -> do
+ let
+ mkForAll a b t = do
+ let ann' = widenLeft (tokAnn $ nameTok a) $ T.getAnnForType t
+ T.ForAll ann' (getIdent $ nameValue a) b t Nothing
+ k t (TypeVarKinded (Wrapped _ (Labeled a _ b) _)) = mkForAll a (Just (convertKind fileName b)) t
+ k t (TypeVarName a) = mkForAll a Nothing t
+ -- The existing parser builds variables in reverse order
+ ty' = foldl k (go ty) bindings
+ ann = widenLeft (tokAnn kw) $ T.getAnnForType ty'
+ T.setAnnForType ann ty'
+ TypeKinded _ ty _ kd -> do
+ let
+ ty' = go ty
+ kd' = convertKind fileName kd
+ ann = Pos.widenSourceAnn (T.getAnnForType ty') (K.getAnnForKind kd')
+ T.KindedType ann ty' kd'
+ TypeApp _ a b -> do
+ let
+ a' = go a
+ b' = go b
+ ann = Pos.widenSourceAnn (T.getAnnForType a') (T.getAnnForType b')
+ T.TypeApp ann a' b'
+ ty@(TypeOp _ _ _ _) -> do
+ let
+ reassoc op b' a = do
+ let
+ a' = go a
+ op' = T.TypeOp (sourceQualName fileName op) $ qualified op
+ ann = Pos.widenSourceAnn (T.getAnnForType a') (T.getAnnForType b')
+ T.BinaryNoParensType ann op' (go a) b'
+ loop k = \case
+ TypeOp _ a op b -> loop (reassoc op (k b)) a
+ expr' -> k expr'
+ loop go ty
+ TypeOpName _ op -> do
+ let rng = qualRange op
+ T.TypeOp (uncurry (sourceAnnCommented fileName) rng) (qualified op)
+ TypeArr _ a arr b -> do
+ let
+ a' = go a
+ b' = go b
+ arr' = Env.tyFunction $> sourceAnnCommented fileName arr arr
+ ann = Pos.widenSourceAnn (T.getAnnForType a') (T.getAnnForType b')
+ T.TypeApp ann (T.TypeApp ann arr' a') b'
+ TypeArrName _ a ->
+ Env.tyFunction $> sourceAnnCommented fileName a a
+ TypeConstrained _ a _ b -> do
+ let
+ a' = convertConstraint fileName a
+ b' = go b
+ ann = Pos.widenSourceAnn (T.constraintAnn a') (T.getAnnForType b')
+ T.ConstrainedType ann a' b'
+ TypeParens _ (Wrapped a ty b) ->
+ T.ParensInType (sourceAnnCommented fileName a b) $ go ty
+
+convertConstraint :: String -> Constraint a -> T.SourceConstraint
+convertConstraint fileName = go
+ where
+ go = \case
+ cst@(Constraint _ name args) -> do
+ let ann = uncurry (sourceAnnCommented fileName) $ constraintRange cst
+ T.Constraint ann (qualified name) (convertType fileName <$> args) Nothing
+ ConstraintParens _ (Wrapped _ c _) -> go c
+
+convertGuarded :: String -> Guarded a -> [AST.GuardedExpr]
+convertGuarded fileName = \case
+ Unconditional _ x -> [AST.GuardedExpr [] (convertWhere fileName x)]
+ Guarded gs -> (\(GuardedExpr _ ps _ x) -> AST.GuardedExpr (p <$> toList ps) (convertWhere fileName x)) <$> NE.toList gs
+ where
+ go = convertExpr fileName
+ p (PatternGuard Nothing x) = AST.ConditionGuard (go x)
+ p (PatternGuard (Just (b, _)) x) = AST.PatternGuard (convertBinder fileName b) (go x)
+
+convertWhere :: String -> Where a -> AST.Expr
+convertWhere fileName = \case
+ Where expr Nothing -> convertExpr fileName expr
+ Where expr (Just (_, bs)) -> do
+ let ann = uncurry (sourceAnnCommented fileName) $ exprRange expr
+ uncurry AST.PositionedValue ann . AST.Let AST.FromWhere (convertLetBinding fileName <$> NE.toList bs) $ convertExpr fileName expr
+
+convertLetBinding :: String -> LetBinding a -> AST.Declaration
+convertLetBinding fileName = \case
+ LetBindingSignature _ lbl ->
+ convertSignature fileName lbl
+ binding@(LetBindingName _ fields) -> do
+ let ann = uncurry (sourceAnnCommented fileName) $ letBindingRange binding
+ convertValueBindingFields fileName ann fields
+ binding@(LetBindingPattern _ a _ b) -> do
+ let ann = uncurry (sourceAnnCommented fileName) $ letBindingRange binding
+ AST.BoundValueDeclaration ann (convertBinder fileName a) (convertWhere fileName b)
+
+convertExpr :: forall a. String -> Expr a -> AST.Expr
+convertExpr fileName = go
+ where
+ positioned =
+ uncurry AST.PositionedValue
+
+ goDoStatement = \case
+ stmt@(DoLet _ as) -> do
+ let ann = uncurry (sourceAnnCommented fileName) $ doStatementRange stmt
+ uncurry AST.PositionedDoNotationElement ann . AST.DoNotationLet $ convertLetBinding fileName <$> NE.toList as
+ stmt@(DoDiscard a) -> do
+ let ann = uncurry (sourceAnn fileName) $ doStatementRange stmt
+ uncurry AST.PositionedDoNotationElement ann . AST.DoNotationValue $ go a
+ stmt@(DoBind a _ b) -> do
+ let
+ ann = uncurry (sourceAnn fileName) $ doStatementRange stmt
+ a' = convertBinder fileName a
+ b' = go b
+ uncurry AST.PositionedDoNotationElement ann $ AST.DoNotationBind a' b'
+
+ go = \case
+ ExprHole _ a ->
+ positioned (sourceName fileName a) . AST.Hole . getIdent $ nameValue a
+ ExprSection _ a ->
+ positioned (sourceAnnCommented fileName a a) AST.AnonymousArgument
+ ExprIdent _ a -> do
+ let ann = sourceQualName fileName a
+ positioned ann . AST.Var (fst ann) . qualified $ fmap ident a
+ ExprConstructor _ a -> do
+ let ann = sourceQualName fileName a
+ positioned ann . AST.Constructor (fst ann) $ qualified a
+ ExprBoolean _ a b -> do
+ let ann = sourceAnnCommented fileName a a
+ positioned ann . AST.Literal (fst ann) $ AST.BooleanLiteral b
+ ExprChar _ a b -> do
+ let ann = sourceAnnCommented fileName a a
+ positioned ann . AST.Literal (fst ann) $ AST.CharLiteral b
+ ExprString _ a b -> do
+ let ann = sourceAnnCommented fileName a a
+ positioned ann . AST.Literal (fst ann) . AST.StringLiteral $ b
+ ExprNumber _ a b -> do
+ let ann = sourceAnnCommented fileName a a
+ positioned ann . AST.Literal (fst ann) $ AST.NumericLiteral b
+ ExprArray _ (Wrapped a bs c) -> do
+ let
+ ann = sourceAnnCommented fileName a c
+ vals = case bs of
+ Just (Separated x xs) -> go x : (go . snd <$> xs)
+ Nothing -> []
+ positioned ann . AST.Literal (fst ann) $ AST.ArrayLiteral vals
+ ExprRecord z (Wrapped a bs c) -> do
+ let
+ ann = sourceAnnCommented fileName a c
+ lbl = \case
+ RecordPun f -> (mkString . getIdent $ nameValue f, go . ExprIdent z $ QualifiedName (nameTok f) Nothing (nameValue f))
+ RecordField f _ v -> (lblName f, go v)
+ vals = case bs of
+ Just (Separated x xs) -> lbl x : (lbl . snd <$> xs)
+ Nothing -> []
+ positioned ann . AST.Literal (fst ann) $ AST.ObjectLiteral vals
+ ExprParens _ (Wrapped a b c) ->
+ positioned (sourceAnnCommented fileName a c) . AST.Parens $ go b
+ expr@(ExprTyped _ a _ b) -> do
+ let
+ a' = go a
+ b' = convertType fileName b
+ ann = (sourceSpan fileName . toSourceRange $ exprRange expr, [])
+ positioned ann $ AST.TypedValue True a' b'
+ expr@(ExprInfix _ a (Wrapped _ b _) c) -> do
+ let ann = (sourceSpan fileName . toSourceRange $ exprRange expr, [])
+ positioned ann $ AST.BinaryNoParens (go b) (go a) (go c)
+ expr@(ExprOp _ _ _ _) -> do
+ let
+ ann = uncurry (sourceAnn fileName) $ exprRange expr
+ reassoc op b a = do
+ let op' = AST.Op (sourceSpan fileName . toSourceRange $ qualRange op) $ qualified op
+ AST.BinaryNoParens op' (go a) b
+ loop k = \case
+ ExprOp _ a op b -> loop (reassoc op (k b)) a
+ expr' -> k expr'
+ positioned ann $ loop go expr
+ ExprOpName _ op -> do
+ let
+ rng = qualRange op
+ op' = AST.Op (sourceSpan fileName $ toSourceRange rng) $ qualified op
+ positioned (uncurry (sourceAnnCommented fileName) rng) op'
+ expr@(ExprNegate _ _ b) -> do
+ let ann = uncurry (sourceAnnCommented fileName) $ exprRange expr
+ positioned ann . AST.UnaryMinus (fst ann) $ go b
+ expr@(ExprRecordAccessor _ (RecordAccessor a _ (Separated h t))) -> do
+ let
+ ann = uncurry (sourceAnnCommented fileName) $ exprRange expr
+ field x f = AST.Accessor (lblName f) x
+ positioned ann $ foldl' (\x (_, f) -> field x f) (field (go a) h) t
+ expr@(ExprRecordUpdate _ a b) -> do
+ let
+ ann = uncurry (sourceAnnCommented fileName) $ exprRange expr
+ k (RecordUpdateLeaf f _ x) = (lblName f, AST.Leaf $ go x)
+ k (RecordUpdateBranch f xs) = (lblName f, AST.Branch $ toTree xs)
+ toTree (Wrapped _ xs _) = AST.PathTree . AST.AssocList . map k $ toList xs
+ positioned ann . AST.ObjectUpdateNested (go a) $ toTree b
+ expr@(ExprApp _ a b) -> do
+ let ann = uncurry (sourceAnn fileName) $ exprRange expr
+ positioned ann $ AST.App (go a) (go b)
+ expr@(ExprLambda _ (Lambda _ as _ b)) -> do
+ let ann = uncurry (sourceAnnCommented fileName) $ exprRange expr
+ positioned ann
+ . AST.Abs (convertBinder fileName (NE.head as))
+ . foldr (AST.Abs . convertBinder fileName) (go b)
+ $ NE.tail as
+ expr@(ExprIf _ (IfThenElse _ a _ b _ c)) -> do
+ let ann = uncurry (sourceAnnCommented fileName) $ exprRange expr
+ positioned ann $ AST.IfThenElse (go a) (go b) (go c)
+ expr@(ExprCase _ (CaseOf _ as _ bs)) -> do
+ let
+ ann = uncurry (sourceAnnCommented fileName) $ exprRange expr
+ as' = go <$> toList as
+ bs' = uncurry AST.CaseAlternative . bimap (map (convertBinder fileName) . toList) (convertGuarded fileName) <$> NE.toList bs
+ positioned ann $ AST.Case as' bs'
+ expr@(ExprLet _ (LetIn _ as _ b)) -> do
+ let ann = uncurry (sourceAnnCommented fileName) $ exprRange expr
+ positioned ann . AST.Let AST.FromLet (convertLetBinding fileName <$> NE.toList as) $ go b
+ -- expr@(ExprWhere _ (Where a _ bs)) -> do
+ -- let ann = uncurry (sourceAnnCommented fileName) $ exprRange expr
+ -- positioned ann . AST.Let AST.FromWhere (goLetBinding <$> bs) $ go a
+ expr@(ExprDo _ (DoBlock kw stmts)) -> do
+ let ann = uncurry (sourceAnnCommented fileName) $ exprRange expr
+ positioned ann . AST.Do (moduleName $ tokValue kw) $ goDoStatement <$> NE.toList stmts
+ expr@(ExprAdo _ (AdoBlock kw stms _ a)) -> do
+ let ann = uncurry (sourceAnnCommented fileName) $ exprRange expr
+ positioned ann . AST.Ado (moduleName $ tokValue kw) (goDoStatement <$> stms) $ go a
+
+convertBinder :: String -> Binder a -> AST.Binder
+convertBinder fileName = go
+ where
+ positioned =
+ uncurry AST.PositionedBinder
+
+ go = \case
+ BinderWildcard _ a ->
+ positioned (sourceAnnCommented fileName a a) AST.NullBinder
+ BinderVar _ a -> do
+ let ann = sourceName fileName a
+ positioned ann . AST.VarBinder (fst ann) . ident $ nameValue a
+ binder@(BinderNamed _ a _ b) -> do
+ let ann = uncurry (sourceAnnCommented fileName) $ binderRange binder
+ positioned ann . AST.NamedBinder (fst ann) (ident $ nameValue a) $ go b
+ binder@(BinderConstructor _ a bs) -> do
+ let ann = uncurry (sourceAnnCommented fileName) $ binderRange binder
+ positioned ann . AST.ConstructorBinder (fst ann) (qualified a) $ go <$> bs
+ BinderBoolean _ a b -> do
+ let ann = sourceAnnCommented fileName a a
+ positioned ann . AST.LiteralBinder (fst ann) $ AST.BooleanLiteral b
+ BinderChar _ a b -> do
+ let ann = sourceAnnCommented fileName a a
+ positioned ann . AST.LiteralBinder (fst ann) $ AST.CharLiteral b
+ BinderString _ a b -> do
+ let ann = sourceAnnCommented fileName a a
+ positioned ann . AST.LiteralBinder (fst ann) . AST.StringLiteral $ b
+ BinderNumber _ n a b -> do
+ let
+ ann = sourceAnnCommented fileName a a
+ b'
+ | isJust n = bimap negate negate b
+ | otherwise = b
+ positioned ann . AST.LiteralBinder (fst ann) $ AST.NumericLiteral b'
+ BinderArray _ (Wrapped a bs c) -> do
+ let
+ ann = sourceAnnCommented fileName a c
+ vals = case bs of
+ Just (Separated x xs) -> go x : (go . snd <$> xs)
+ Nothing -> []
+ positioned ann . AST.LiteralBinder (fst ann) $ AST.ArrayLiteral vals
+ BinderRecord z (Wrapped a bs c) -> do
+ let
+ ann = sourceAnnCommented fileName a c
+ lbl = \case
+ RecordPun f -> (mkString . getIdent $ nameValue f, go $ BinderVar z f)
+ RecordField f _ v -> (lblName f, go v)
+ vals = case bs of
+ Just (Separated x xs) -> lbl x : (lbl . snd <$> xs)
+ Nothing -> []
+ positioned ann . AST.LiteralBinder (fst ann) $ AST.ObjectLiteral vals
+ BinderParens _ (Wrapped a b c) ->
+ positioned (sourceAnnCommented fileName a c) . AST.ParensInBinder $ go b
+ binder@(BinderTyped _ a _ b) -> do
+ let
+ a' = go a
+ b' = convertType fileName b
+ ann = (sourceSpan fileName . toSourceRange $ binderRange binder, [])
+ positioned ann $ AST.TypedBinder b' a'
+ binder@(BinderOp _ _ _ _) -> do
+ let
+ ann = uncurry (sourceAnn fileName) $ binderRange binder
+ reassoc op b a = do
+ let op' = AST.OpBinder (sourceSpan fileName . toSourceRange $ qualRange op) $ qualified op
+ AST.BinaryNoParensBinder op' (go a) b
+ loop k = \case
+ BinderOp _ a op b -> loop (reassoc op (k b)) a
+ binder' -> k binder'
+ positioned ann $ loop go binder
+
+convertDeclaration :: String -> Declaration a -> [AST.Declaration]
+convertDeclaration fileName decl = case decl of
+ DeclData _ (DataHead _ a vars) bd -> do
+ let
+ ctr (DataCtor _ x ys) = (nameValue x, zip ctrFields $ convertType fileName <$> ys)
+ ctrs = case bd of
+ Nothing -> []
+ Just (_, cs) -> ctr <$> toList cs
+ pure $ AST.DataDeclaration ann Env.Data (nameValue a) (goTypeVar <$> vars) ctrs
+ DeclType _ (DataHead _ a vars) _ bd ->
+ pure $ AST.TypeSynonymDeclaration ann
+ (nameValue a)
+ (goTypeVar <$> vars)
+ (convertType fileName bd)
+ DeclNewtype _ (DataHead _ a vars) _ x ys -> do
+ let ctrs = [(nameValue x, [(head ctrFields, convertType fileName ys)])]
+ pure $ AST.DataDeclaration ann Env.Newtype (nameValue a) (goTypeVar <$> vars) ctrs
+ DeclClass _ (ClassHead _ sup name vars fdeps) bd -> do
+ let
+ goTyVar (TypeVarKinded (Wrapped _ (Labeled a _ _) _)) = nameValue a
+ goTyVar (TypeVarName a) = nameValue a
+ vars' = zip (toList $ goTyVar <$> vars) [0..]
+ goName = fromJust . flip lookup vars' . nameValue
+ goFundep (FundepDetermined _ bs) = Env.FunctionalDependency [] (goName <$> NE.toList bs)
+ goFundep (FundepDetermines as _ bs) = Env.FunctionalDependency (goName <$> NE.toList as) (goName <$> NE.toList bs)
+ goSig (Labeled n _ ty) = do
+ let
+ ty' = convertType fileName ty
+ ann' = widenLeft (tokAnn $ nameTok n) $ T.getAnnForType ty'
+ AST.TypeDeclaration $ AST.TypeDeclarationData ann' (ident $ nameValue n) ty'
+ pure $ AST.TypeClassDeclaration ann
+ (nameValue name)
+ (goTypeVar <$> vars)
+ (convertConstraint fileName <$> maybe [] (toList . fst) sup)
+ (goFundep <$> maybe [] (toList . snd) fdeps)
+ (goSig <$> maybe [] (NE.toList . snd) bd)
+ DeclInstanceChain _ insts -> do
+ let
+ instName (Instance (InstanceHead _ a _ _ _ _) _) = ident $ nameValue a
+ chainId = instName <$> toList insts
+ goInst ix inst@(Instance (InstanceHead _ name _ ctrs cls args) bd) = do
+ let ann' = uncurry (sourceAnnCommented fileName) $ instanceRange inst
+ AST.TypeInstanceDeclaration ann' chainId ix
+ (ident $ nameValue name)
+ (convertConstraint fileName <$> maybe [] (toList . fst) ctrs)
+ (qualified cls)
+ (convertType fileName <$> args)
+ (AST.ExplicitInstance $ goInstanceBinding <$> maybe [] (NE.toList . snd) bd)
+ uncurry goInst <$> zip [0..] (toList insts)
+ DeclDerive _ _ new (InstanceHead _ name _ ctrs cls args) -> do
+ let
+ name' = ident $ nameValue name
+ instTy
+ | isJust new = AST.NewtypeInstance
+ | otherwise = AST.DerivedInstance
+ pure $ AST.TypeInstanceDeclaration ann [name'] 0 name'
+ (convertConstraint fileName <$> maybe [] (toList . fst) ctrs)
+ (qualified cls)
+ (convertType fileName <$> args)
+ instTy
+ DeclSignature _ lbl ->
+ pure $ convertSignature fileName lbl
+ DeclValue _ fields ->
+ pure $ convertValueBindingFields fileName ann fields
+ DeclFixity _ (FixityFields (_, kw) (_, prec) fxop) -> do
+ let
+ assoc = case kw of
+ Infix -> AST.Infix
+ Infixr -> AST.Infixr
+ Infixl -> AST.Infixl
+ fixity = AST.Fixity assoc prec
+ pure $ AST.FixityDeclaration ann $ case fxop of
+ FixityValue name _ op -> do
+ Left $ AST.ValueFixity fixity (first ident <$> qualified name) (nameValue op)
+ FixityType _ name _ op ->
+ Right $ AST.TypeFixity fixity (qualified name) (nameValue op)
+ DeclForeign _ _ _ frn ->
+ pure $ case frn of
+ ForeignValue (Labeled a _ b) ->
+ AST.ExternDeclaration ann (ident $ nameValue a) $ convertType fileName b
+ ForeignData _ (Labeled a _ b) ->
+ AST.ExternDataDeclaration ann (nameValue a) $ convertKind fileName b
+ ForeignKind _ a ->
+ AST.ExternKindDeclaration ann (nameValue a)
+ where
+ ann =
+ uncurry (sourceAnnCommented fileName) $ declRange decl
+
+ goTypeVar = \case
+ TypeVarKinded (Wrapped _ (Labeled x _ y) _) -> (getIdent $ nameValue x, Just $ convertKind fileName y)
+ TypeVarName x -> (getIdent $ nameValue x, Nothing)
+
+ goInstanceBinding = \case
+ InstanceBindingSignature _ lbl ->
+ convertSignature fileName lbl
+ binding@(InstanceBindingName _ fields) -> do
+ let ann' = uncurry (sourceAnnCommented fileName) $ instanceBindingRange binding
+ convertValueBindingFields fileName ann' fields
+
+convertSignature :: String -> Labeled (Name Ident) (Type a) -> AST.Declaration
+convertSignature fileName (Labeled a _ b) = do
+ let
+ b' = convertType fileName b
+ ann = widenLeft (tokAnn $ nameTok a) $ T.getAnnForType b'
+ AST.TypeDeclaration $ AST.TypeDeclarationData ann (ident $ nameValue a) b'
+
+convertValueBindingFields :: String -> Pos.SourceAnn -> ValueBindingFields a -> AST.Declaration
+convertValueBindingFields fileName ann (ValueBindingFields a bs c) = do
+ let
+ bs' = convertBinder fileName <$> bs
+ cs' = convertGuarded fileName c
+ AST.ValueDeclaration $ AST.ValueDeclarationData ann (ident $ nameValue a) Env.Public bs' cs'
+
+convertImportDecl
+ :: String
+ -> ImportDecl a
+ -> (Pos.SourceAnn, N.ModuleName, AST.ImportDeclarationType, Maybe N.ModuleName)
+convertImportDecl fileName decl@(ImportDecl _ _ modName mbNames mbQual) = do
+ let
+ ann = uncurry (sourceAnnCommented fileName) $ importDeclRange decl
+ importTy = case mbNames of
+ Nothing -> AST.Implicit
+ Just (hiding, (Wrapped _ imps _)) -> do
+ let imps' = convertImport fileName <$> toList imps
+ if isJust hiding
+ then AST.Hiding imps'
+ else AST.Explicit imps'
+ (ann, nameValue modName, importTy, nameValue . snd <$> mbQual)
+
+convertImport :: String -> Import a -> AST.DeclarationRef
+convertImport fileName imp = case imp of
+ ImportValue _ a ->
+ AST.ValueRef ann . ident $ nameValue a
+ ImportOp _ a ->
+ AST.ValueOpRef ann $ nameValue a
+ ImportType _ a mb -> do
+ let
+ ctrs = case mb of
+ Nothing -> Just []
+ Just (DataAll _ _) -> Nothing
+ Just (DataEnumerated _ (Wrapped _ Nothing _)) -> Just []
+ Just (DataEnumerated _ (Wrapped _ (Just idents) _)) ->
+ Just . map nameValue $ toList idents
+ AST.TypeRef ann (nameValue a) ctrs
+ ImportTypeOp _ _ a ->
+ AST.TypeOpRef ann $ nameValue a
+ ImportClass _ _ a ->
+ AST.TypeClassRef ann $ nameValue a
+ ImportKind _ _ a ->
+ AST.KindRef ann $ nameValue a
+ where
+ ann = sourceSpan fileName . toSourceRange $ importRange imp
+
+convertExport :: String -> Export a -> AST.DeclarationRef
+convertExport fileName export = case export of
+ ExportValue _ a ->
+ AST.ValueRef ann . ident $ nameValue a
+ ExportOp _ a ->
+ AST.ValueOpRef ann $ nameValue a
+ ExportType _ a mb -> do
+ let
+ ctrs = case mb of
+ Nothing -> Just []
+ Just (DataAll _ _) -> Nothing
+ Just (DataEnumerated _ (Wrapped _ Nothing _)) -> Just []
+ Just (DataEnumerated _ (Wrapped _ (Just idents) _)) ->
+ Just . map nameValue $ toList idents
+ AST.TypeRef ann (nameValue a) ctrs
+ ExportTypeOp _ _ a ->
+ AST.TypeOpRef ann $ nameValue a
+ ExportClass _ _ a ->
+ AST.TypeClassRef ann $ nameValue a
+ ExportKind _ _ a ->
+ AST.KindRef ann $ nameValue a
+ ExportModule _ _ a ->
+ AST.ModuleRef ann (nameValue a)
+ where
+ ann = sourceSpan fileName . toSourceRange $ exportRange export
+
+convertModule :: String -> Module a -> AST.Module
+convertModule fileName module'@(Module _ _ modName exps _ imps decls _) = do
+ let
+ ann = uncurry (sourceAnnCommented fileName) $ moduleRange module'
+ imps' = importCtr. convertImportDecl fileName <$> imps
+ decls' = convertDeclaration fileName =<< decls
+ exps' = map (convertExport fileName) . toList . wrpValue <$> exps
+ uncurry AST.Module ann (nameValue modName) (imps' <> decls') exps'
+ where
+ importCtr (a, b, c, d) = AST.ImportDeclaration a b c d
+
+ctrFields :: [N.Ident]
+ctrFields = [N.Ident ("value" <> Text.pack (show (n :: Integer))) | n <- [0..]]
diff --git a/src/Language/PureScript/CST/Errors.hs b/src/Language/PureScript/CST/Errors.hs
new file mode 100644
index 0000000..7d20a37
--- /dev/null
+++ b/src/Language/PureScript/CST/Errors.hs
@@ -0,0 +1,162 @@
+{-# LANGUAGE NamedFieldPuns #-}
+module Language.PureScript.CST.Errors
+ ( ParserError(..)
+ , ParserErrorType(..)
+ , prettyPrintError
+ , prettyPrintErrorMessage
+ ) where
+
+import Prelude
+
+import qualified Data.Text as Text
+import Data.Char (isSpace, toUpper)
+import Language.PureScript.CST.Layout
+import Language.PureScript.CST.Print
+import Language.PureScript.CST.Types
+import Text.Printf (printf)
+
+data ParserErrorType
+ = ErrWildcardInType
+ | ErrHoleInType
+ | ErrExprInBinder
+ | ErrExprInDeclOrBinder
+ | ErrExprInDecl
+ | ErrBinderInDecl
+ | ErrRecordUpdateInCtr
+ | ErrRecordPunInUpdate
+ | ErrRecordCtrInUpdate
+ | ErrTypeInConstraint
+ | ErrElseInDecl
+ | ErrInstanceNameMismatch
+ | ErrUnknownFundep
+ | ErrImportInDecl
+ | ErrGuardInLetBinder
+ | ErrKeywordVar
+ | ErrKeywordSymbol
+ | ErrToken
+ | ErrLineFeedInString
+ | ErrAstralCodePointInChar
+ | ErrCharEscape
+ | ErrNumberOutOfRange
+ | ErrLeadingZero
+ | ErrExpectedFraction
+ | ErrExpectedExponent
+ | ErrExpectedHex
+ | ErrReservedSymbol
+ | ErrCharInGap Char
+ | ErrModuleName
+ | ErrQualifiedName
+ | ErrEmptyDo
+ | ErrLexeme (Maybe String) [String]
+ | ErrEof
+ | ErrCustom String
+ deriving (Show, Eq, Ord)
+
+data ParserError = ParserError
+ { errRange :: SourceRange
+ , errToks :: [SourceToken]
+ , errStack :: LayoutStack
+ , errType :: ParserErrorType
+ } deriving (Show, Eq)
+
+prettyPrintError :: ParserError -> String
+prettyPrintError pe@(ParserError { errRange }) =
+ prettyPrintErrorMessage pe <> " at " <> errPos
+ where
+ errPos = case errRange of
+ SourceRange (SourcePos line col) _ ->
+ "line " <> show line <> ", column " <> show col
+
+prettyPrintErrorMessage :: ParserError -> String
+prettyPrintErrorMessage (ParserError {..}) = case errType of
+ ErrWildcardInType ->
+ "Unexpected wildcard in type; type wildcards are only allowed in value annotations"
+ ErrHoleInType ->
+ "Unexpected hole in type; type holes are only allowed in value annotations"
+ ErrExprInBinder ->
+ "Expected pattern, saw expression"
+ ErrExprInDeclOrBinder ->
+ "Expected declaration or pattern, saw expression"
+ ErrExprInDecl ->
+ "Expected declaration, saw expression"
+ ErrBinderInDecl ->
+ "Expected declaration, saw pattern"
+ ErrRecordUpdateInCtr ->
+ "Expected ':', saw '='"
+ ErrRecordPunInUpdate ->
+ "Expected record update, saw pun"
+ ErrRecordCtrInUpdate ->
+ "Expected '=', saw ':'"
+ ErrTypeInConstraint ->
+ "Expected constraint, saw type"
+ ErrElseInDecl ->
+ "Expected declaration, saw 'else'"
+ ErrInstanceNameMismatch ->
+ "All instances in a chain must implement the same type class"
+ ErrUnknownFundep ->
+ "Unknown type variable in functional dependency"
+ ErrImportInDecl ->
+ "Expected declaration, saw 'import'"
+ ErrGuardInLetBinder ->
+ "Unexpected guard in let pattern"
+ ErrKeywordVar ->
+ "Expected variable, saw keyword"
+ ErrKeywordSymbol ->
+ "Expected symbol, saw reserved symbol"
+ ErrEof ->
+ "Unexpected end of input"
+ ErrLexeme (Just (hd : _)) _ | isSpace hd ->
+ "Illegal whitespace character " <> displayCodePoint hd
+ ErrLexeme (Just a) _ ->
+ "Unexpected " <> a
+ ErrLineFeedInString ->
+ "Unexpected line feed in string literal"
+ ErrAstralCodePointInChar ->
+ "Illegal astral code point in character literal"
+ ErrCharEscape ->
+ "Illegal character escape code"
+ ErrNumberOutOfRange ->
+ "Number literal is out of range"
+ ErrLeadingZero ->
+ "Unexpected leading zeros"
+ ErrExpectedFraction ->
+ "Expected fraction"
+ ErrExpectedExponent ->
+ "Expected exponent"
+ ErrExpectedHex ->
+ "Expected hex digit"
+ ErrReservedSymbol ->
+ "Unexpected reserved symbol"
+ ErrCharInGap ch ->
+ "Unexpected character '" <> [ch] <> "' in gap"
+ ErrModuleName ->
+ "Invalid module name; underscores and primes are not allowed in module names"
+ ErrQualifiedName ->
+ "Unexpected qualified name"
+ ErrEmptyDo ->
+ "Expected do statement"
+ ErrLexeme _ _ ->
+ basicError
+ ErrToken
+ | SourceToken _ (TokLeftArrow _) : _ <- errToks ->
+ "Unexpected \"<-\" in expression, perhaps due to a missing 'do' or 'ado' keyword"
+ ErrToken ->
+ basicError
+ ErrCustom err ->
+ err
+
+ where
+ basicError = case errToks of
+ tok : _ -> basicTokError (tokValue tok)
+ [] -> "Unexpected input"
+
+ basicTokError = \case
+ TokLayoutStart -> "Unexpected or mismatched indentation"
+ TokLayoutSep -> "Unexpected or mismatched indentation"
+ TokLayoutEnd -> "Unexpected or mismatched indentation"
+ TokEof -> "Unexpected end of input"
+ tok -> "Unexpected token '" <> Text.unpack (printToken tok) <> "'"
+
+ displayCodePoint :: Char -> String
+ displayCodePoint x =
+ "U+" <> map toUpper (printf "%0.4x" (fromEnum x))
diff --git a/src/Language/PureScript/CST/Layout.hs b/src/Language/PureScript/CST/Layout.hs
new file mode 100644
index 0000000..bf533ff
--- /dev/null
+++ b/src/Language/PureScript/CST/Layout.hs
@@ -0,0 +1,396 @@
+-- | The parser itself is unaware of indentation, and instead only parses explicit
+-- delimiters which are inserted by this layout algorithm (much like Haskell).
+-- This is convenient because the actual grammar can be specified apart from the
+-- indentation rules. Haskell has a few problematic productions which make it
+-- impossible to implement a purely lexical layout algorithm, so it also has an
+-- additional (and somewhat contentious) parser error side condition. PureScript
+-- does not have these problematic productions (particularly foo, bar ::
+-- SomeType syntax in declarations), but it does have a few gotchas of it's own.
+-- The algorithm is "non-trivial" to say the least, but it is implemented as a
+-- purely lexical delimiter parser on a token-by-token basis, which is highly
+-- convenient, since it can be replicated in any language or toolchain. There is
+-- likely room to simplify it, but there are some seemingly innocuous things
+-- that complicate it.
+--
+-- "Naked" commas (case, patterns, guards, fundeps) are a constant source of
+-- complexity, and indeed too much of this is what prevents Haskell from having
+-- such an algorithm. Unquoted properties for layout keywords introduce a domino
+-- effect of complexity since we have to mask and unmask any usage of . (also in
+-- foralls!) or labels in record literals.
+
+module Language.PureScript.CST.Layout where
+
+import Prelude
+
+import Data.DList (snoc)
+import qualified Data.DList as DList
+import Data.Foldable (find)
+import Data.Function ((&))
+import Language.PureScript.CST.Types
+
+type LayoutStack = [(SourcePos, LayoutDelim)]
+
+data LayoutDelim
+ = LytRoot
+ | LytTopDecl
+ | LytTopDeclHead
+ | LytDeclGuard
+ | LytCase
+ | LytCaseBinders
+ | LytCaseGuard
+ | LytLambdaBinders
+ | LytParen
+ | LytBrace
+ | LytSquare
+ | LytIf
+ | LytThen
+ | LytProperty
+ | LytForall
+ | LytTick
+ | LytLet
+ | LytLetStmt
+ | LytWhere
+ | LytOf
+ | LytDo
+ | LytAdo
+ deriving (Show, Eq, Ord)
+
+isIndented :: LayoutDelim -> Bool
+isIndented = \case
+ LytLet -> True
+ LytLetStmt -> True
+ LytWhere -> True
+ LytOf -> True
+ LytDo -> True
+ LytAdo -> True
+ _ -> False
+
+isTopDecl :: SourcePos -> LayoutStack -> Bool
+isTopDecl tokPos = \case
+ [(lytPos, LytWhere), (_, LytRoot)]
+ | srcColumn tokPos == srcColumn lytPos -> True
+ _ -> False
+
+lytToken :: SourcePos -> Token -> SourceToken
+lytToken pos = SourceToken ann
+ where
+ ann = TokenAnn
+ { tokRange = SourceRange pos pos
+ , tokLeadingComments = []
+ , tokTrailingComments = []
+ }
+
+insertLayout :: SourceToken -> SourcePos -> LayoutStack -> (LayoutStack, [SourceToken])
+insertLayout src@(SourceToken tokAnn tok) nextPos stack =
+ DList.toList <$> insert (stack, mempty)
+ where
+ tokPos =
+ srcStart $ tokRange tokAnn
+
+ insert state@(stk, acc) = case tok of
+ -- `data` declarations need masking (LytTopDecl) because the usage of `|`
+ -- should not introduce a LytDeclGard context.
+ TokLowerName [] "data" ->
+ case state & insertDefault of
+ state'@(stk', _) | isTopDecl tokPos stk' ->
+ state' & pushStack tokPos LytTopDecl
+ state' ->
+ state' & popStack (== LytProperty)
+
+ -- `class` declaration heads need masking (LytTopDeclHead) because the
+ -- usage of commas in functional dependencies.
+ TokLowerName [] "class" ->
+ case state & insertDefault of
+ state'@(stk', _) | isTopDecl tokPos stk' ->
+ state' & pushStack tokPos LytTopDeclHead
+ state' ->
+ state' & popStack (== LytProperty)
+
+ TokLowerName [] "where" ->
+ case stk of
+ (_, LytTopDeclHead) : stk' ->
+ (stk', acc) & insertToken src & insertStart LytWhere
+ (_, LytProperty) : stk' ->
+ (stk', acc) & insertToken src
+ _ ->
+ state & collapse whereP & insertToken src & insertStart LytWhere
+ where
+ -- `where` always closes do blocks:
+ -- example = do do do do foo where foo = ...
+ --
+ -- `where` closes layout contexts even when indented at the same level:
+ -- example = case
+ -- Foo -> ...
+ -- Bar -> ...
+ -- where foo = ...
+ whereP _ LytDo = True
+ whereP lytPos lyt = offsideEndP lytPos lyt
+
+ TokLowerName [] "in" ->
+ case collapse inP state of
+ -- `let/in` is not allowed in `ado` syntax. `in` is treated as a
+ -- delimiter and must always close the `ado`.
+ -- example = ado
+ -- foo <- ...
+ -- let bar = ...
+ -- in ...
+ ((_, LytLetStmt) : (_, LytAdo) : stk', acc') ->
+ (stk', acc') & insertEnd & insertEnd & insertToken src
+ ((_, lyt) : stk', acc') | isIndented lyt ->
+ (stk', acc') & insertEnd & insertToken src
+ _ ->
+ state & insertDefault & popStack (== LytProperty)
+ where
+ inP _ LytLet = False
+ inP _ LytAdo = False
+ inP _ lyt = isIndented lyt
+
+ TokLowerName [] "let" ->
+ case stk of
+ (p, LytDo) : _ | srcColumn p == srcColumn tokPos ->
+ state & insertKwProperty (insertStart LytLetStmt)
+ (p, LytAdo) : _ | srcColumn p == srcColumn tokPos ->
+ state & insertKwProperty (insertStart LytLetStmt)
+ _ ->
+ state & insertKwProperty (insertStart LytLet)
+
+ TokLowerName _ "do" ->
+ state & insertKwProperty (insertStart LytDo)
+
+ TokLowerName _ "ado" ->
+ state & insertKwProperty (insertStart LytAdo)
+
+ -- `case` heads need masking due to commas.
+ TokLowerName [] "case" ->
+ state & insertKwProperty (pushStack tokPos LytCase)
+
+ TokLowerName [] "of" ->
+ case collapse indentedP state of
+ -- When `of` is matched with a `case`, we are in a case block, and we
+ -- need to mask additional contexts (LytCaseBinders, LytCaseGuards)
+ -- due to commas.
+ ((_, LytCase) : stk', acc') ->
+ (stk', acc') & insertToken src & insertStart LytOf & pushStack nextPos LytCaseBinders
+ state' ->
+ state' & insertDefault & popStack (== LytProperty)
+
+ -- `if/then/else` is considered a delimiter context. This allows us to
+ -- write chained expressions in `do` blocks without stair-stepping:
+ -- example = do
+ -- foo
+ -- if ... then
+ -- ...
+ -- else if ... then
+ -- ...
+ -- else
+ -- ...
+ TokLowerName [] "if" ->
+ state & insertKwProperty (pushStack tokPos LytIf)
+
+ TokLowerName [] "then" ->
+ case state & collapse indentedP of
+ ((_, LytIf) : stk', acc') ->
+ (stk', acc') & insertToken src & pushStack tokPos LytThen
+ _ ->
+ state & insertDefault & popStack (== LytProperty)
+
+ TokLowerName [] "else" ->
+ case state & collapse indentedP of
+ ((_, LytThen) : stk', acc') ->
+ (stk', acc') & insertToken src
+ _ ->
+ -- We don't want to insert a layout separator for top-level `else` in
+ -- instance chains.
+ case state & collapse offsideP of
+ state'@(stk', _) | isTopDecl tokPos stk' ->
+ state' & insertToken src
+ state' ->
+ state' & insertSep & insertToken src & popStack (== LytProperty)
+
+ -- `forall` binders need masking because the usage of `.` should not
+ -- introduce a LytProperty context.
+ TokForall _ ->
+ state & insertKwProperty (pushStack tokPos LytForall)
+
+ -- Lambdas need masking because the usage of `->` should not close a
+ -- LytDeclGaurd or LytCaseGuard context.
+ TokBackslash ->
+ state & insertDefault & pushStack tokPos LytLambdaBinders
+
+ TokRightArrow _ ->
+ state & collapse arrowP & popStack guardP & insertToken src
+ where
+ arrowP _ LytDo = True
+ arrowP _ LytOf = False
+ arrowP lytPos lyt = offsideEndP lytPos lyt
+
+ guardP LytCaseBinders = True
+ guardP LytCaseGuard = True
+ guardP LytLambdaBinders = True
+ guardP _ = False
+
+ TokEquals ->
+ case state & collapse equalsP of
+ ((_, LytDeclGuard) : stk', acc') ->
+ (stk', acc') & insertToken src
+ _ ->
+ state & insertDefault
+ where
+ equalsP _ LytWhere = True
+ equalsP _ LytLet = True
+ equalsP _ _ = False
+
+ -- Guards need masking because of commas.
+ TokPipe ->
+ case collapse offsideEndP state of
+ state'@((_, LytOf) : _, _) ->
+ state' & pushStack tokPos LytCaseGuard & insertToken src
+ state'@((_, LytLet) : _, _) ->
+ state' & pushStack tokPos LytDeclGuard & insertToken src
+ state'@((_, LytWhere) : _, _) ->
+ state' & pushStack tokPos LytDeclGuard & insertToken src
+ _ ->
+ state & insertDefault
+
+ -- Ticks can either start or end an infix expression. We preemptively
+ -- collapse all indentation contexts in search of a starting delimiter,
+ -- and backtrack if we don't find one.
+ TokTick ->
+ case state & collapse indentedP of
+ ((_, LytTick) : stk', acc') ->
+ (stk', acc') & insertToken src
+ _ ->
+ state & insertDefault & pushStack tokPos LytTick
+
+ -- In gneral, commas should close all indented contexts.
+ -- example = [ do foo
+ -- bar, baz ]
+ TokComma ->
+ case state & collapse indentedP of
+ -- If we see a LytBrace, then we are in a record type or literal.
+ -- Record labels need masking so we can use unquoted keywords as labels
+ -- without accidentally littering layout delimiters.
+ state'@((_, LytBrace) : _, _) ->
+ state' & insertToken src & pushStack tokPos LytProperty
+ state' ->
+ state' & insertToken src
+
+ -- TokDot tokens usually entail property access, which need masking so we
+ -- can use unquoted keywords as labels.
+ TokDot ->
+ case state & insertDefault of
+ ((_, LytForall) : stk', acc') ->
+ (stk', acc')
+ state' ->
+ state' & pushStack tokPos LytProperty
+
+ TokLeftParen ->
+ state & insertDefault & pushStack tokPos LytParen
+
+ TokLeftBrace ->
+ state & insertDefault & pushStack tokPos LytBrace & pushStack tokPos LytProperty
+
+ TokLeftSquare ->
+ state & insertDefault & pushStack tokPos LytSquare
+
+ TokRightParen ->
+ state & collapse indentedP & popStack (== LytParen) & insertToken src
+
+ TokRightBrace ->
+ state & collapse indentedP & popStack (== LytProperty) & popStack (== LytBrace) & insertToken src
+
+ TokRightSquare ->
+ state & collapse indentedP & popStack (== LytSquare) & insertToken src
+
+ TokString _ _ ->
+ state & insertDefault & popStack (== LytProperty)
+
+ TokLowerName [] _ ->
+ state & insertDefault & popStack (== LytProperty)
+
+ TokOperator _ _ ->
+ state & collapse offsideEndP & insertSep & insertToken src
+
+ _ ->
+ state & insertDefault
+
+ insertDefault state =
+ state & collapse offsideP & insertSep & insertToken src
+
+ insertStart lyt state@(stk, _) =
+ -- We only insert a new layout start when it's going to increase indentation.
+ -- This prevents things like the following from parsing:
+ -- instance foo :: Foo where
+ -- foo = 42
+ case find (isIndented . snd) stk of
+ Just (pos, _) | srcColumn nextPos <= srcColumn pos -> state
+ _ -> state & pushStack nextPos lyt & insertToken (lytToken nextPos TokLayoutStart)
+
+ insertSep state@(stk, acc) = case stk of
+ -- LytTopDecl is closed by a separator.
+ (lytPos, LytTopDecl) : stk' | sepP lytPos ->
+ (stk', acc) & insertToken sepTok
+ -- LytTopDeclHead can be closed by a separator if there is no `where`.
+ (lytPos, LytTopDeclHead) : stk' | sepP lytPos ->
+ (stk', acc) & insertToken sepTok
+ (lytPos, lyt) : _ | indentSepP lytPos lyt ->
+ case lyt of
+ -- If a separator is inserted in a case block, we need to push an
+ -- additional LytCaseBinders context for comma masking.
+ LytOf -> state & insertToken sepTok & pushStack tokPos LytCaseBinders
+ _ -> state & insertToken sepTok
+ _ -> state
+ where
+ sepTok = lytToken tokPos TokLayoutSep
+
+ insertKwProperty k state =
+ case state & insertDefault of
+ ((_, LytProperty) : stk', acc') ->
+ (stk', acc')
+ state' ->
+ k state'
+
+ insertEnd =
+ insertToken (lytToken tokPos TokLayoutEnd)
+
+ insertToken token (stk, acc) =
+ (stk, acc `snoc` token)
+
+ pushStack lytPos lyt (stk, acc) =
+ ((lytPos, lyt) : stk, acc)
+
+ popStack p ((_, lyt) : stk', acc)
+ | p lyt = (stk', acc)
+ popStack _ state = state
+
+ collapse p = uncurry go
+ where
+ go ((lytPos, lyt) : stk) acc
+ | p lytPos lyt =
+ go stk $ if isIndented lyt
+ then acc `snoc` lytToken tokPos TokLayoutEnd
+ else acc
+ go stk acc = (stk, acc)
+
+ indentedP =
+ const isIndented
+
+ offsideP lytPos lyt =
+ isIndented lyt && srcColumn tokPos < srcColumn lytPos
+
+ offsideEndP lytPos lyt =
+ isIndented lyt && srcColumn tokPos <= srcColumn lytPos
+
+ indentSepP lytPos lyt =
+ isIndented lyt && sepP lytPos
+
+ sepP lytPos =
+ srcColumn tokPos == srcColumn lytPos && srcLine tokPos /= srcLine lytPos
+
+unwindLayout :: SourcePos -> [Comment LineFeed] -> LayoutStack -> [SourceToken]
+unwindLayout pos leading = go
+ where
+ go [] = []
+ go ((_, LytRoot) : _) = [SourceToken (TokenAnn (SourceRange pos pos) leading []) TokEof]
+ go ((_, lyt) : stk) | isIndented lyt = lytToken pos TokLayoutEnd : go stk
+ go (_ : stk) = go stk
diff --git a/src/Language/PureScript/CST/Lexer.hs b/src/Language/PureScript/CST/Lexer.hs
new file mode 100644
index 0000000..b17a586
--- /dev/null
+++ b/src/Language/PureScript/CST/Lexer.hs
@@ -0,0 +1,712 @@
+{-# LANGUAGE BangPatterns #-}
+module Language.PureScript.CST.Lexer
+ ( lenient
+ , lex
+ , lexTopLevel
+ , lexWithState
+ , isUnquotedKey
+ ) where
+
+import Prelude hiding (lex, exp, exponent, lines)
+
+import Control.Monad (join)
+import qualified Data.Char as Char
+import qualified Data.DList as DList
+import Data.Foldable (foldl')
+import Data.Functor (($>))
+import qualified Data.Scientific as Sci
+import Data.String (fromString)
+import Data.Text (Text)
+import qualified Data.Text as Text
+import Language.PureScript.CST.Errors
+import Language.PureScript.CST.Monad hiding (token)
+import Language.PureScript.CST.Layout
+import Language.PureScript.CST.Positions
+import Language.PureScript.CST.Types
+
+-- | Stops at the first lexing error and replaces it with TokEof. Otherwise,
+-- the parser will fail when it attempts to draw a lookahead token.
+lenient :: [LexResult] -> [LexResult]
+lenient = go
+ where
+ go [] = []
+ go (Right a : as) = Right a : go as
+ go (Left (st, _) : _) = do
+ let
+ pos = lexPos st
+ ann = TokenAnn (SourceRange pos pos) (lexLeading st) []
+ [Right (SourceToken ann TokEof)]
+
+-- | Lexes according to root layout rules.
+lex :: Text -> [LexResult]
+lex src = do
+ let (leading, src') = comments src
+ lexWithState $ LexState
+ { lexPos = advanceLeading (SourcePos 1 1) leading
+ , lexLeading = leading
+ , lexSource = src'
+ , lexStack = [(SourcePos 0 0, LytRoot)]
+ }
+
+-- | Lexes according to top-level declaration context rules.
+lexTopLevel :: Text -> [LexResult]
+lexTopLevel src = do
+ let
+ (leading, src') = comments src
+ lexPos = advanceLeading (SourcePos 1 1) leading
+ hd = Right $ lytToken lexPos TokLayoutStart
+ tl = lexWithState $ LexState
+ { lexPos = lexPos
+ , lexLeading = leading
+ , lexSource = src'
+ , lexStack = [(lexPos, LytWhere), (SourcePos 0 0, LytRoot)]
+ }
+ hd : tl
+
+-- | Lexes according to some LexState.
+lexWithState :: LexState -> [LexResult]
+lexWithState = go
+ where
+ Parser lexK =
+ tokenAndComments
+
+ go state@(LexState {..}) =
+ lexK lexSource onError onSuccess
+ where
+ onError lexSource' err = do
+ let
+ len1 = Text.length lexSource
+ len2 = Text.length lexSource'
+ chunk = Text.take (max 0 (len1 - len2)) lexSource
+ chunkDelta = textDelta chunk
+ pos = applyDelta lexPos chunkDelta
+ pure $ Left
+ ( state { lexSource = lexSource' }
+ , ParserError (SourceRange pos $ applyDelta pos (0, 1)) [] lexStack err
+ )
+
+ onSuccess _ (TokEof, _) =
+ Right <$> unwindLayout lexPos lexLeading lexStack
+ onSuccess lexSource' (tok, (trailing, lexLeading')) = do
+ let
+ endPos = advanceToken lexPos tok
+ lexPos' = advanceLeading (advanceTrailing endPos trailing) lexLeading'
+ tokenAnn = TokenAnn
+ { tokRange = SourceRange lexPos endPos
+ , tokLeadingComments = lexLeading
+ , tokTrailingComments = trailing
+ }
+ (lexStack', toks) =
+ insertLayout (SourceToken tokenAnn tok) lexPos' lexStack
+ state' = LexState
+ { lexPos = lexPos'
+ , lexLeading = lexLeading'
+ , lexSource = lexSource'
+ , lexStack = lexStack'
+ }
+ go2 state' toks
+
+ go2 state [] = go state
+ go2 state (t : ts) = Right t : go2 state ts
+
+type Lexer = ParserM ParserErrorType Text
+
+{-# INLINE next #-}
+next :: Lexer ()
+next = Parser $ \inp _ ksucc ->
+ ksucc (Text.drop 1 inp) ()
+
+{-# INLINE nextWhile #-}
+nextWhile :: (Char -> Bool) -> Lexer Text
+nextWhile p = Parser $ \inp _ ksucc -> do
+ let (chs, inp') = Text.span p inp
+ ksucc inp' chs
+
+{-# INLINE peek #-}
+peek :: Lexer (Maybe Char)
+peek = Parser $ \inp _ ksucc ->
+ if Text.null inp
+ then ksucc inp Nothing
+ else ksucc inp $ Just $ Text.head inp
+
+{-# INLINE restore #-}
+restore :: (ParserErrorType -> Bool) -> Lexer a -> Lexer a
+restore p (Parser k) = Parser $ \inp kerr ksucc ->
+ k inp (\inp' err -> kerr (if p err then inp else inp') err) ksucc
+
+tokenAndComments :: Lexer (Token, ([Comment void], [Comment LineFeed]))
+tokenAndComments = (,) <$> token <*> breakComments
+
+comments :: Text -> ([Comment LineFeed], Text)
+comments = \src -> k src (\_ _ -> ([], src)) (\inp (a, b) -> (a <> b, inp))
+ where
+ Parser k = breakComments
+
+breakComments :: Lexer ([Comment void], [Comment LineFeed])
+breakComments = k0 []
+ where
+ k0 acc = do
+ spaces <- nextWhile (== ' ')
+ lines <- nextWhile isLineFeed
+ let
+ acc'
+ | Text.null spaces = acc
+ | otherwise = Space (Text.length spaces) : acc
+ if Text.null lines
+ then do
+ mbComm <- comment
+ case mbComm of
+ Just comm -> k0 (comm : acc')
+ Nothing -> pure (reverse acc', [])
+ else
+ k1 acc' (goWs [] $ Text.unpack lines)
+
+ k1 trl acc = do
+ ws <- nextWhile (\c -> c == ' ' || isLineFeed c)
+ let acc' = goWs acc $ Text.unpack ws
+ mbComm <- comment
+ case mbComm of
+ Just comm -> k1 trl (comm : acc')
+ Nothing -> pure (reverse trl, reverse acc')
+
+ goWs a ('\r' : '\n' : ls) = goWs (Line CRLF : a) ls
+ goWs a ('\r' : ls) = goWs (Line CRLF : a) ls
+ goWs a ('\n' : ls) = goWs (Line LF : a) ls
+ goWs a (' ' : ls) = goSpace a 1 ls
+ goWs a _ = a
+
+ goSpace a !n (' ' : ls) = goSpace a (n + 1) ls
+ goSpace a !n ls = goWs (Space n : a) ls
+
+ isBlockComment = Parser $ \inp _ ksucc ->
+ case Text.uncons inp of
+ Just ('-', inp2) ->
+ case Text.uncons inp2 of
+ Just ('-', inp3) ->
+ ksucc inp3 $ Just False
+ _ ->
+ ksucc inp Nothing
+ Just ('{', inp2) ->
+ case Text.uncons inp2 of
+ Just ('-', inp3) ->
+ ksucc inp3 $ Just True
+ _ ->
+ ksucc inp Nothing
+ _ ->
+ ksucc inp Nothing
+
+ comment = isBlockComment >>= \case
+ Just True -> Just <$> blockComment "{-"
+ Just False -> Just <$> lineComment "--"
+ Nothing -> pure $ Nothing
+
+ lineComment acc = do
+ comm <- nextWhile (\c -> c /= '\r' && c /= '\n')
+ pure $ Comment (acc <> comm)
+
+ blockComment acc = do
+ chs <- nextWhile (/= '-')
+ dashes <- nextWhile (== '-')
+ if Text.null dashes
+ then pure $ Comment $ acc <> chs
+ else peek >>= \case
+ Just '}' -> next $> Comment (acc <> chs <> dashes <> "}")
+ _ -> blockComment (acc <> chs <> dashes)
+
+token :: Lexer Token
+token = peek >>= maybe (pure TokEof) k0
+ where
+ k0 ch1 = case ch1 of
+ '(' -> next *> leftParen
+ ')' -> next $> TokRightParen
+ '{' -> next $> TokLeftBrace
+ '}' -> next $> TokRightBrace
+ '[' -> next $> TokLeftSquare
+ ']' -> next $> TokRightSquare
+ '`' -> next $> TokTick
+ ',' -> next $> TokComma
+ '∷' -> next *> orOperator1 (TokDoubleColon Unicode) ch1
+ '←' -> next *> orOperator1 (TokLeftArrow Unicode) ch1
+ '→' -> next *> orOperator1 (TokRightArrow Unicode) ch1
+ '⇒' -> next *> orOperator1 (TokRightFatArrow Unicode) ch1
+ '∀' -> next *> orOperator1 (TokForall Unicode) ch1
+ '|' -> next *> orOperator1 TokPipe ch1
+ '.' -> next *> orOperator1 TokDot ch1
+ '\\' -> next *> orOperator1 TokBackslash ch1
+ '<' -> next *> orOperator2 (TokLeftArrow ASCII) ch1 '-'
+ '-' -> next *> orOperator2 (TokRightArrow ASCII) ch1 '>'
+ '=' -> next *> orOperator2' TokEquals (TokRightFatArrow ASCII) ch1 '>'
+ ':' -> next *> orOperator2' (TokOperator [] ":") (TokDoubleColon ASCII) ch1 ':'
+ '?' -> next *> hole
+ '\'' -> next *> char
+ '"' -> next *> string
+ _ | Char.isDigit ch1 -> restore (== ErrNumberOutOfRange) (next *> number ch1)
+ | Char.isUpper ch1 -> next *> upper [] ch1
+ | isIdentStart ch1 -> next *> lower [] ch1
+ | isSymbolChar ch1 -> next *> operator [] [ch1]
+ | otherwise -> throw $ ErrLexeme (Just [ch1]) []
+
+ {-# INLINE orOperator1 #-}
+ orOperator1 :: Token -> Char -> Lexer Token
+ orOperator1 tok ch1 = join $ Parser $ \inp _ ksucc ->
+ case Text.uncons inp of
+ Just (ch2, inp2) | isSymbolChar ch2 ->
+ ksucc inp2 $ operator [] [ch1, ch2]
+ _ ->
+ ksucc inp $ pure tok
+
+ {-# INLINE orOperator2 #-}
+ orOperator2 :: Token -> Char -> Char -> Lexer Token
+ orOperator2 tok ch1 ch2 = join $ Parser $ \inp _ ksucc ->
+ case Text.uncons inp of
+ Just (ch2', inp2) | ch2 == ch2' ->
+ case Text.uncons inp2 of
+ Just (ch3, inp3) | isSymbolChar ch3 ->
+ ksucc inp3 $ operator [] [ch1, ch2, ch3]
+ _ ->
+ ksucc inp2 $ pure tok
+ _ ->
+ ksucc inp $ operator [] [ch1]
+
+ {-# INLINE orOperator2' #-}
+ orOperator2' :: Token -> Token -> Char -> Char -> Lexer Token
+ orOperator2' tok1 tok2 ch1 ch2 = join $ Parser $ \inp _ ksucc ->
+ case Text.uncons inp of
+ Just (ch2', inp2) | ch2 == ch2' ->
+ case Text.uncons inp2 of
+ Just (ch3, inp3) | isSymbolChar ch3 ->
+ ksucc inp3 $ operator [] [ch1, ch2, ch3]
+ _ ->
+ ksucc inp2 $ pure tok2
+ Just (ch2', inp2) | isSymbolChar ch2' ->
+ ksucc inp2 $ operator [] [ch1, ch2']
+ _ ->
+ ksucc inp $ pure tok1
+
+ {-
+ leftParen
+ : '(' '→' ')'
+ | '(' '->' ')'
+ | '(' symbolChar+ ')'
+ | '('
+ -}
+ leftParen :: Lexer Token
+ leftParen = Parser $ \inp kerr ksucc ->
+ case Text.span isSymbolChar inp of
+ (chs, inp2)
+ | Text.null chs -> ksucc inp TokLeftParen
+ | otherwise ->
+ case Text.uncons inp2 of
+ Just (')', inp3) ->
+ case chs of
+ "→" -> ksucc inp3 $ TokSymbolArr Unicode
+ "->" -> ksucc inp3 $ TokSymbolArr ASCII
+ _ | isReservedSymbol chs -> kerr inp ErrReservedSymbol
+ | otherwise -> ksucc inp3 $ TokSymbolName [] chs
+ _ -> ksucc inp TokLeftParen
+
+ {-
+ symbol
+ : '(' symbolChar+ ')'
+ -}
+ symbol :: [Text] -> Lexer Token
+ symbol qual = restore isReservedSymbolError $ peek >>= \case
+ Just ch | isSymbolChar ch ->
+ nextWhile isSymbolChar >>= \chs ->
+ peek >>= \case
+ Just ')'
+ | isReservedSymbol chs -> throw ErrReservedSymbol
+ | otherwise -> next $> TokSymbolName qual chs
+ Just ch2 -> throw $ ErrLexeme (Just [ch2]) []
+ Nothing -> throw ErrEof
+ Just ch -> throw $ ErrLexeme (Just [ch]) []
+ Nothing -> throw ErrEof
+
+ {-
+ operator
+ : symbolChar+
+ -}
+ operator :: [Text] -> [Char] -> Lexer Token
+ operator qual pre = do
+ rest <- nextWhile isSymbolChar
+ pure . TokOperator (reverse qual) $ Text.pack pre <> rest
+
+ {-
+ moduleName
+ : upperChar alphaNumChar*
+
+ qualifier
+ : (moduleName '.')* moduleName
+
+ upper
+ : (qualifier '.')? upperChar identChar*
+ | qualifier '.' lowerQualified
+ | qualifier '.' operator
+ | qualifier '.' symbol
+ -}
+ upper :: [Text] -> Char -> Lexer Token
+ upper qual pre = do
+ rest <- nextWhile isIdentChar
+ ch1 <- peek
+ let name = Text.cons pre rest
+ case ch1 of
+ Just '.' -> do
+ let qual' = name : qual
+ next *> peek >>= \case
+ Just '(' -> next *> symbol qual'
+ Just ch2
+ | Char.isUpper ch2 -> next *> upper qual' ch2
+ | isIdentStart ch2 -> next *> lower qual' ch2
+ | isSymbolChar ch2 -> next *> operator qual' [ch2]
+ | otherwise -> throw $ ErrLexeme (Just [ch2]) []
+ Nothing ->
+ throw ErrEof
+ _ ->
+ pure $ TokUpperName (reverse qual) name
+
+ {-
+ lower
+ : '_'
+ | 'forall'
+ | lowerChar identChar*
+
+ lowerQualified
+ : lowerChar identChar*
+ -}
+ lower :: [Text] -> Char -> Lexer Token
+ lower qual pre = do
+ rest <- nextWhile isIdentChar
+ case pre of
+ '_' | Text.null rest ->
+ if null qual
+ then pure TokUnderscore
+ else throw $ ErrLexeme (Just [pre]) []
+ _ ->
+ case Text.cons pre rest of
+ "forall" | null qual -> pure $ TokForall ASCII
+ name -> pure $ TokLowerName (reverse qual) name
+
+ {-
+ hole
+ : '?' identChar+
+ -}
+ hole :: Lexer Token
+ hole = do
+ name <- nextWhile isIdentChar
+ if Text.null name
+ then operator [] ['?']
+ else pure $ TokHole name
+
+ {-
+ char
+ : "'" '\' escape "'"
+ | "'" [^'] "'"
+ -}
+ char :: Lexer Token
+ char = do
+ (raw, ch) <- peek >>= \case
+ Just '\\' -> do
+ (raw, ch2) <- next *> escape
+ pure (Text.cons '\\' raw, ch2)
+ Just ch ->
+ next $> (Text.singleton ch, ch)
+ Nothing ->
+ throw $ ErrEof
+ peek >>= \case
+ Just '\''
+ | fromEnum ch > 0xFFFF -> throw ErrAstralCodePointInChar
+ | otherwise -> next $> TokChar raw ch
+ Just ch2 ->
+ throw $ ErrLexeme (Just [ch2]) []
+ _ ->
+ throw $ ErrEof
+
+ {-
+ stringPart
+ : '\' escape
+ | '\' [ \r\n]+ '\'
+ | [^"]
+
+ string
+ : '"' stringPart* '"'
+ | '"""' .* '"""'
+
+ This assumes maximal munch for quotes. A raw string literal can end with
+ any number of quotes, where the last 3 are considered the closing
+ delimiter.
+ -}
+ string :: Lexer Token
+ string = do
+ quotes1 <- nextWhile (== '"')
+ case Text.length quotes1 of
+ 0 -> do
+ let
+ go raw acc = do
+ chs <- nextWhile isNormalStringChar
+ let
+ raw' = raw <> chs
+ acc' = acc <> DList.fromList (Text.unpack chs)
+ peek >>= \case
+ Just '"' -> next $> TokString raw' (fromString (DList.toList acc'))
+ Just '\\' -> next *> goEscape (raw' <> "\\") acc'
+ Just _ -> throw ErrLineFeedInString
+ Nothing -> throw ErrEof
+
+ goEscape raw acc = do
+ mbCh <- peek
+ case mbCh of
+ Just ch1 | isStringGapChar ch1 -> do
+ gap <- nextWhile isStringGapChar
+ peek >>= \case
+ Just '"' -> next $> TokString (raw <> gap) (fromString (DList.toList acc))
+ Just '\\' -> next *> go (raw <> gap <> "\\") acc
+ Just ch -> throw $ ErrCharInGap ch
+ Nothing -> throw ErrEof
+ _ -> do
+ (raw', ch) <- escape
+ go (raw <> raw') (acc <> DList.singleton ch)
+ go "" mempty
+ 1 ->
+ pure $ TokString "" ""
+ n | n >= 5 -> do
+ let str = Text.take 5 quotes1
+ pure $ TokString str (fromString (Text.unpack str))
+ _ -> do
+ let
+ go acc = do
+ chs <- nextWhile (/= '"')
+ quotes2 <- nextWhile (== '"')
+ case Text.length quotes2 of
+ 0 -> throw ErrEof
+ n | n >= 3 -> pure $ TokRawString $ acc <> chs <> Text.drop 3 quotes2
+ _ -> go (acc <> chs <> quotes2)
+ go ""
+
+ {-
+ escape
+ : 't'
+ | 'r'
+ | 'n'
+ | "'"
+ | '"'
+ | 'x' [0-9a-fA-F]{0,6}
+ -}
+ escape :: Lexer (Text, Char)
+ escape = do
+ ch <- peek
+ case ch of
+ Just 't' -> next $> ("\t", '\t')
+ Just 'r' -> next $> ("\\r", '\r')
+ Just 'n' -> next $> ("\\n", '\n')
+ Just '"' -> next $> ("\"", '"')
+ Just '\'' -> next $> ("'", '\'')
+ Just '\\' -> next $> ("\\", '\\')
+ Just 'x' -> (*>) next $ Parser $ \inp kerr ksucc -> do
+ let
+ go n acc (ch' : chs)
+ | Char.isHexDigit ch' = go (n * 16 + Char.digitToInt ch') (ch' : acc) chs
+ go n acc _
+ | n <= 0x10FFFF =
+ ksucc (Text.drop (length acc) inp)
+ (Text.pack $ reverse acc, Char.chr n)
+ | otherwise =
+ kerr inp ErrCharEscape -- TODO
+ go 0 [] $ Text.unpack $ Text.take 6 inp
+ _ -> throw ErrCharEscape
+
+ {-
+ number
+ : hexadecimal
+ | integer ('.' fraction)? exponent?
+ -}
+ number :: Char -> Lexer Token
+ number ch1 = peek >>= \ch2 -> case (ch1, ch2) of
+ ('0', Just 'x') -> next *> hexadecimal
+ (_, _) -> do
+ mbInt <- integer1 ch1
+ mbFraction <- fraction
+ case (mbInt, mbFraction) of
+ (Just (raw, int), Nothing) -> do
+ let int' = digitsToInteger int
+ exponent >>= \case
+ Just (raw', exp) ->
+ sciDouble (raw <> raw') $ Sci.scientific int' exp
+ Nothing ->
+ pure $ TokInt raw int'
+ (Just (raw, int), Just (raw', frac)) -> do
+ let sci = digitsToScientific int frac
+ exponent >>= \case
+ Just (raw'', exp) ->
+ sciDouble (raw <> raw' <> raw'') $ uncurry Sci.scientific $ (+ exp) <$> sci
+ Nothing ->
+ sciDouble (raw <> raw') $ uncurry Sci.scientific sci
+ (Nothing, Just (raw, frac)) -> do
+ let sci = digitsToScientific [] frac
+ exponent >>= \case
+ Just (raw', exp) ->
+ sciDouble (raw <> raw') $ uncurry Sci.scientific $ (+ exp) <$> sci
+ Nothing ->
+ sciDouble raw $ uncurry Sci.scientific sci
+ (Nothing, Nothing) ->
+ peek >>= \ch -> throw $ ErrLexeme (pure <$> ch) []
+
+ sciDouble :: Text -> Sci.Scientific -> Lexer Token
+ sciDouble raw sci = case Sci.toBoundedRealFloat sci of
+ Left _ -> throw ErrNumberOutOfRange
+ Right n -> pure $ TokNumber raw n
+
+ {-
+ integer
+ : '0'
+ | [1-9] digits
+ -}
+ integer :: Lexer (Maybe (Text, String))
+ integer = peek >>= \case
+ Just '0' -> next *> peek >>= \case
+ Just ch | isNumberChar ch -> throw ErrLeadingZero
+ _ -> pure $ Just ("0", "0")
+ Just ch | isDigitChar ch -> Just <$> digits
+ _ -> pure $ Nothing
+
+ {-
+ integer1
+ : '0'
+ | [1-9] digits
+
+ This is the same as 'integer', the only difference is that this expects the
+ first char to be consumed during dispatch.
+ -}
+ integer1 :: Char -> Lexer (Maybe (Text, String))
+ integer1 = \case
+ '0' -> peek >>= \case
+ Just ch | isNumberChar ch -> throw ErrLeadingZero
+ _ -> pure $ Just ("0", "0")
+ ch | isDigitChar ch -> do
+ (raw, chs) <- digits
+ pure $ Just (Text.cons ch raw, ch : chs)
+ _ -> pure $ Nothing
+
+ {-
+ fraction
+ : '.' [0-9_]+
+ -}
+ fraction :: Lexer (Maybe (Text, String))
+ fraction = Parser $ \inp _ ksucc ->
+ -- We need more than a single char lookahead for things like `1..10`.
+ case Text.uncons inp of
+ Just ('.', inp')
+ | (raw, inp'') <- Text.span isNumberChar inp'
+ , not (Text.null raw) ->
+ ksucc inp'' $ Just ("." <> raw, filter (/= '_') $ Text.unpack raw)
+ _ ->
+ ksucc inp Nothing
+
+ {-
+ digits
+ : [0-9_]*
+
+ Digits can contain underscores, which are ignored.
+ -}
+ digits :: Lexer (Text, String)
+ digits = do
+ raw <- nextWhile isNumberChar
+ pure (raw, filter (/= '_') $ Text.unpack raw)
+
+ {-
+ exponent
+ : 'e' ('+' | '-')? integer
+ -}
+ exponent :: Lexer (Maybe (Text, Int))
+ exponent = peek >>= \case
+ Just 'e' -> do
+ (neg, sign) <- next *> peek >>= \case
+ Just '-' -> next $> (True, "-")
+ Just '+' -> next $> (False, "+")
+ _ -> pure (False, "")
+ integer >>= \case
+ Just (raw, chs) -> do
+ let
+ int | neg = negate $ digitsToInteger chs
+ | otherwise = digitsToInteger chs
+ pure $ Just ("e" <> sign <> raw, fromInteger int)
+ Nothing -> throw ErrExpectedExponent
+ _ ->
+ pure Nothing
+
+ {-
+ hexadecimal
+ : '0x' [0-9a-fA-F]+
+ -}
+ hexadecimal :: Lexer Token
+ hexadecimal = do
+ chs <- nextWhile Char.isHexDigit
+ if Text.null chs
+ then throw ErrExpectedHex
+ else pure $ TokInt ("0x" <> chs) $ digitsToIntegerBase 16 $ Text.unpack chs
+
+digitsToInteger :: [Char] -> Integer
+digitsToInteger = digitsToIntegerBase 10
+
+digitsToIntegerBase :: Integer -> [Char] -> Integer
+digitsToIntegerBase b = foldl' (\n c -> n * b + (toInteger (Char.digitToInt c))) 0
+
+digitsToScientific :: [Char] -> [Char] -> (Integer, Int)
+digitsToScientific = go 0 . reverse
+ where
+ go !exp is [] = (digitsToInteger (reverse is), exp)
+ go !exp is (f : fs) = go (exp - 1) (f : is) fs
+
+isSymbolChar :: Char -> Bool
+isSymbolChar c = (c `elem` (":!#$%&*+./<=>?@\\^|-~" :: [Char])) || (not (Char.isAscii c) && Char.isSymbol c)
+
+isReservedSymbolError :: ParserErrorType -> Bool
+isReservedSymbolError = (== ErrReservedSymbol)
+
+isReservedSymbol :: Text -> Bool
+isReservedSymbol = flip elem symbols
+ where
+ symbols =
+ [ "::"
+ , "∷"
+ , "<-"
+ , "←"
+ , "->"
+ , "→"
+ , "=>"
+ , "⇒"
+ , "∀"
+ , "|"
+ , "."
+ , "\\"
+ , "="
+ ]
+
+isIdentStart :: Char -> Bool
+isIdentStart c = Char.isLower c || c == '_'
+
+isIdentChar :: Char -> Bool
+isIdentChar c = Char.isAlphaNum c || c == '_' || c == '\''
+
+isDigitChar :: Char -> Bool
+isDigitChar c = c >= '0' && c <= '9'
+
+isNumberChar :: Char -> Bool
+isNumberChar c = (c >= '0' && c <= '9') || c == '_'
+
+isNormalStringChar :: Char -> Bool
+isNormalStringChar c = c /= '"' && c /= '\\' && c /= '\r' && c /= '\n'
+
+isStringGapChar :: Char -> Bool
+isStringGapChar c = c == ' ' || c == '\r' || c == '\n'
+
+isLineFeed :: Char -> Bool
+isLineFeed c = c == '\r' || c == '\n'
+
+-- | Checks if some identifier is a valid unquoted key.
+isUnquotedKey :: Text -> Bool
+isUnquotedKey t =
+ case Text.uncons t of
+ Nothing ->
+ False
+ Just (hd, tl) ->
+ isIdentStart hd && Text.all isIdentChar tl
diff --git a/src/Language/PureScript/CST/Monad.hs b/src/Language/PureScript/CST/Monad.hs
new file mode 100644
index 0000000..eb7a3be
--- /dev/null
+++ b/src/Language/PureScript/CST/Monad.hs
@@ -0,0 +1,174 @@
+module Language.PureScript.CST.Monad where
+
+import Prelude
+
+import Data.List (sortBy)
+import qualified Data.List.NonEmpty as NE
+import Data.Ord (comparing)
+import Data.Text (Text)
+import Language.PureScript.CST.Errors
+import Language.PureScript.CST.Layout
+import Language.PureScript.CST.Positions
+import Language.PureScript.CST.Types
+
+type LexResult = Either (LexState, ParserError) SourceToken
+
+data LexState = LexState
+ { lexPos :: SourcePos
+ , lexLeading :: [Comment LineFeed]
+ , lexSource :: Text
+ , lexStack :: LayoutStack
+ } deriving (Show)
+
+data ParserState = ParserState
+ { parserBuff :: [LexResult]
+ , parserErrors :: [ParserError]
+ } deriving (Show)
+
+-- | A bare bones, CPS'ed `StateT s (Except e) a`.
+newtype ParserM e s a =
+ Parser (forall r. s -> (s -> e -> r) -> (s -> a -> r) -> r)
+
+type Parser = ParserM ParserError ParserState
+
+instance Functor (ParserM e s) where
+ {-# INLINE fmap #-}
+ fmap f (Parser k) =
+ Parser $ \st kerr ksucc ->
+ k st kerr (\st' a -> ksucc st' (f a))
+
+instance Applicative (ParserM e s) where
+ {-# INLINE pure #-}
+ pure a = Parser $ \st _ k -> k st a
+ {-# INLINE (<*>) #-}
+ Parser k1 <*> Parser k2 =
+ Parser $ \st kerr ksucc ->
+ k1 st kerr $ \st' f ->
+ k2 st' kerr $ \st'' a ->
+ ksucc st'' (f a)
+
+instance Monad (ParserM e s) where
+ {-# INLINE return #-}
+ return = pure
+ {-# INLINE (>>=) #-}
+ Parser k1 >>= k2 =
+ Parser $ \st kerr ksucc ->
+ k1 st kerr $ \st' a -> do
+ let Parser k3 = k2 a
+ k3 st' kerr ksucc
+
+runParser :: ParserState -> Parser a -> (ParserState, Either (NE.NonEmpty ParserError) a)
+runParser st (Parser k) = k st left right
+ where
+ left st'@(ParserState {..}) err =
+ (st', Left $ NE.sortBy (comparing errRange) $ err NE.:| parserErrors)
+
+ right st'@(ParserState {..}) res
+ | null parserErrors = (st', Right res)
+ | otherwise = (st', Left $ NE.fromList $ sortBy (comparing errRange) parserErrors)
+
+runTokenParser :: Parser a -> [LexResult] -> Either (NE.NonEmpty ParserError) a
+runTokenParser p = snd . flip runParser p . flip ParserState []
+
+{-# INLINE throw #-}
+throw :: e -> ParserM e s a
+throw e = Parser $ \st kerr _ -> kerr st e
+
+parseError :: SourceToken -> Parser a
+parseError tok = Parser $ \st kerr _ ->
+ kerr st $ ParserError
+ { errRange = tokRange . tokAnn $ tok
+ , errToks = [tok]
+ , errStack = [] -- TODO parserStack st
+ , errType = ErrToken
+ }
+
+mkParserError :: LayoutStack -> [SourceToken] -> ParserErrorType -> ParserError
+mkParserError stack toks ty =
+ ParserError
+ { errRange = range
+ , errToks = toks
+ , errStack = stack
+ , errType = ty
+ }
+ where
+ range = case toks of
+ [] -> SourceRange (SourcePos 0 0) (SourcePos 0 0)
+ _ -> widen (tokRange . tokAnn $ head toks) (tokRange . tokAnn $ last toks)
+
+addFailure :: [SourceToken] -> ParserErrorType -> Parser ()
+addFailure toks ty = Parser $ \st _ ksucc ->
+ ksucc (st { parserErrors = mkParserError [] toks ty : parserErrors st }) ()
+
+addFailures :: [ParserError] -> Parser ()
+addFailures errs = Parser $ \st _ ksucc ->
+ ksucc (st { parserErrors = errs <> parserErrors st }) ()
+
+parseFail' :: [SourceToken] -> ParserErrorType -> Parser a
+parseFail' toks msg = Parser $ \st kerr _ -> kerr st (mkParserError [] toks msg)
+
+parseFail :: SourceToken -> ParserErrorType -> Parser a
+parseFail = parseFail' . pure
+
+pushBack :: SourceToken -> Parser ()
+pushBack tok = Parser $ \st _ ksucc ->
+ ksucc (st { parserBuff = Right tok : parserBuff st }) ()
+
+{-# INLINE tryPrefix #-}
+tryPrefix :: Parser a -> Parser b -> Parser (Maybe a, b)
+tryPrefix (Parser lhs) rhs = Parser $ \st kerr ksucc ->
+ lhs st
+ (\_ _ -> do
+ let Parser k = (Nothing,) <$> rhs
+ k st kerr ksucc)
+ (\st' res -> do
+ let Parser k = (Just res,) <$> rhs
+ k st' kerr ksucc)
+
+oneOf :: NE.NonEmpty (Parser a) -> Parser a
+oneOf parsers = Parser $ \st kerr ksucc -> do
+ let
+ go (st', Right a) _ = (st', Right a)
+ go _ (st', Right a) = (st', Right a)
+ go (st1, Left errs1) (st2, Left errs2)
+ | errRange (NE.last errs2) > errRange (NE.last errs1) = (st2, Left errs2)
+ | otherwise = (st1, Left errs1)
+ case foldr1 go $ runParser st <$> parsers of
+ (st', Left errs) -> kerr (st' { parserErrors = NE.tail errs }) $ NE.head errs
+ (st', Right res) -> ksucc st' res
+
+manyDelimited :: Token -> Token -> Token -> Parser a -> Parser [a]
+manyDelimited open close sep p = do
+ _ <- token open
+ res <- go1
+ _ <- token close
+ pure $ res
+ where
+ go1 =
+ oneOf $ NE.fromList
+ [ go2 . pure =<< p
+ , pure []
+ ]
+
+ go2 acc =
+ oneOf $ NE.fromList
+ [ token sep *> (go2 . (: acc) =<< p)
+ , pure (reverse acc)
+ ]
+
+token :: Token -> Parser SourceToken
+token t = do
+ t' <- munch
+ if t == tokValue t'
+ then pure t'
+ else parseError t'
+
+munch :: Parser SourceToken
+munch = Parser $ \state@(ParserState {..}) kerr ksucc ->
+ case parserBuff of
+ Right tok : parserBuff' ->
+ ksucc (state { parserBuff = parserBuff' }) tok
+ Left (_, err) : _ ->
+ kerr state err
+ [] ->
+ error "Empty input"
diff --git a/src/Language/PureScript/CST/Parser.y b/src/Language/PureScript/CST/Parser.y
new file mode 100644
index 0000000..2585d15
--- /dev/null
+++ b/src/Language/PureScript/CST/Parser.y
@@ -0,0 +1,786 @@
+{
+module Language.PureScript.CST.Parser
+ ( parseType
+ , parseKind
+ , parseExpr
+ , parseDecl
+ , parseIdent
+ , parseOperator
+ , parseModule
+ , parseImportDeclP
+ , parseDeclP
+ , parseExprP
+ , parseTypeP
+ , parseModuleNameP
+ , parseQualIdentP
+ , parse
+ , PartialResult(..)
+ ) where
+
+import Prelude hiding (lex)
+
+import Control.Monad ((<=<), when)
+import Data.Foldable (foldl', for_)
+import qualified Data.List.NonEmpty as NE
+import Data.Text (Text)
+import Data.Traversable (for)
+import Language.PureScript.CST.Errors
+import Language.PureScript.CST.Lexer
+import Language.PureScript.CST.Monad
+import Language.PureScript.CST.Positions
+import Language.PureScript.CST.Types
+import Language.PureScript.CST.Utils
+import qualified Language.PureScript.Names as N
+import Language.PureScript.PSString (PSString)
+}
+
+%expect 98
+
+%name parseKind kind
+%name parseType type
+%name parseExpr expr
+%name parseIdent ident
+%name parseOperator op
+%name parseModuleBody moduleBody
+%name parseDecl decl
+%partial parseImportDeclP importDeclP
+%partial parseDeclP declP
+%partial parseExprP exprP
+%partial parseTypeP typeP
+%partial parseModuleNameP moduleNameP
+%partial parseQualIdentP qualIdentP
+%partial parseModuleHeader moduleHeader
+%partial parseDoStatement doStatement
+%partial parseDoExpr doExpr
+%partial parseDoNext doNext
+%partial parseGuardExpr guardExpr
+%partial parseGuardNext guardNext
+%partial parseGuardStatement guardStatement
+%partial parseClassSuper classSuper
+%partial parseClassNameAndFundeps classNameAndFundeps
+%partial parseBinderAndArrow binderAndArrow
+%tokentype { SourceToken }
+%monad { Parser }
+%error { parseError }
+%lexer { lexer } { SourceToken _ TokEof }
+
+%token
+ '(' { SourceToken _ TokLeftParen }
+ ')' { SourceToken _ TokRightParen }
+ '{' { SourceToken _ TokLeftBrace }
+ '}' { SourceToken _ TokRightBrace }
+ '[' { SourceToken _ TokLeftSquare }
+ ']' { SourceToken _ TokRightSquare }
+ '\{' { SourceToken _ TokLayoutStart }
+ '\}' { SourceToken _ TokLayoutEnd }
+ '\;' { SourceToken _ TokLayoutSep }
+ '<-' { SourceToken _ (TokLeftArrow _) }
+ '->' { SourceToken _ (TokRightArrow _) }
+ '<=' { SourceToken _ (TokOperator [] sym) | isLeftFatArrow sym }
+ '=>' { SourceToken _ (TokRightFatArrow _) }
+ ':' { SourceToken _ (TokOperator [] ":") }
+ '::' { SourceToken _ (TokDoubleColon _) }
+ '=' { SourceToken _ TokEquals }
+ '|' { SourceToken _ TokPipe }
+ '`' { SourceToken _ TokTick }
+ '.' { SourceToken _ TokDot }
+ ',' { SourceToken _ TokComma }
+ '_' { SourceToken _ TokUnderscore }
+ '\\' { SourceToken _ TokBackslash }
+ '-' { SourceToken _ (TokOperator [] "-") }
+ '@' { SourceToken _ (TokOperator [] "@") }
+ '#' { SourceToken _ (TokOperator [] "#") }
+ 'ado' { SourceToken _ (TokLowerName _ "ado") }
+ 'as' { SourceToken _ (TokLowerName [] "as") }
+ 'case' { SourceToken _ (TokLowerName [] "case") }
+ 'class' { SourceToken _ (TokLowerName [] "class") }
+ 'data' { SourceToken _ (TokLowerName [] "data") }
+ 'derive' { SourceToken _ (TokLowerName [] "derive") }
+ 'do' { SourceToken _ (TokLowerName _ "do") }
+ 'else' { SourceToken _ (TokLowerName [] "else") }
+ 'false' { SourceToken _ (TokLowerName [] "false") }
+ 'forall' { SourceToken _ (TokForall ASCII) }
+ 'forallu' { SourceToken _ (TokForall Unicode) }
+ 'foreign' { SourceToken _ (TokLowerName [] "foreign") }
+ 'hiding' { SourceToken _ (TokLowerName [] "hiding") }
+ 'import' { SourceToken _ (TokLowerName [] "import") }
+ 'if' { SourceToken _ (TokLowerName [] "if") }
+ 'in' { SourceToken _ (TokLowerName [] "in") }
+ 'infix' { SourceToken _ (TokLowerName [] "infix") }
+ 'infixl' { SourceToken _ (TokLowerName [] "infixl") }
+ 'infixr' { SourceToken _ (TokLowerName [] "infixr") }
+ 'instance' { SourceToken _ (TokLowerName [] "instance") }
+ 'kind' { SourceToken _ (TokLowerName [] "kind") }
+ 'let' { SourceToken _ (TokLowerName [] "let") }
+ 'module' { SourceToken _ (TokLowerName [] "module") }
+ 'newtype' { SourceToken _ (TokLowerName [] "newtype") }
+ 'of' { SourceToken _ (TokLowerName [] "of") }
+ 'then' { SourceToken _ (TokLowerName [] "then") }
+ 'true' { SourceToken _ (TokLowerName [] "true") }
+ 'type' { SourceToken _ (TokLowerName [] "type") }
+ 'where' { SourceToken _ (TokLowerName [] "where") }
+ '(->)' { SourceToken _ (TokSymbolArr _) }
+ '(..)' { SourceToken _ (TokSymbolName [] "..") }
+ LOWER { SourceToken _ (TokLowerName [] _) }
+ QUAL_LOWER { SourceToken _ (TokLowerName _ _) }
+ UPPER { SourceToken _ (TokUpperName [] _) }
+ QUAL_UPPER { SourceToken _ (TokUpperName _ _) }
+ SYMBOL { SourceToken _ (TokSymbolName [] _) }
+ QUAL_SYMBOL { SourceToken _ (TokSymbolName _ _) }
+ OPERATOR { SourceToken _ (TokOperator [] _) }
+ QUAL_OPERATOR { SourceToken _ (TokOperator _ _) }
+ LIT_HOLE { SourceToken _ (TokHole _) }
+ LIT_CHAR { SourceToken _ (TokChar _ _) }
+ LIT_STRING { SourceToken _ (TokString _ _) }
+ LIT_RAW_STRING { SourceToken _ (TokRawString _) }
+ LIT_INT { SourceToken _ (TokInt _ _) }
+ LIT_NUMBER { SourceToken _ (TokNumber _ _) }
+
+%%
+
+many(a) :: { NE.NonEmpty _ }
+ : many1(a) { NE.reverse $1 }
+
+many1(a) :: { NE.NonEmpty _ }
+ : a { pure $1 }
+ | many1(a) a { NE.cons $2 $1 }
+
+manySep(a, sep) :: { NE.NonEmpty _ }
+ : manySep1(a, sep) { NE.reverse $1 }
+
+manySep1(a, sep) :: { NE.NonEmpty _ }
+ : a { pure $1 }
+ | manySep1(a, sep) sep a { NE.cons $3 $1 }
+
+manySepOrEmpty(a, sep) :: { [_] }
+ : {- empty -} { [] }
+ | manySep(a, sep) { NE.toList $1 }
+
+manyOrEmpty(a) :: { [_] }
+ : {- empty -} { [] }
+ | many(a) { NE.toList $1 }
+
+sep(a, s) :: { Separated _ }
+ : sep1(a, s) { separated $1 }
+
+sep1(a, s) :: { [(SourceToken, _)] }
+ : a { [(placeholder, $1)] }
+ | sep1(a, s) s a { ($2, $3) : $1 }
+
+delim(a, b, c, d) :: { Delimited _ }
+ : a d { Wrapped $1 Nothing $2 }
+ | a sep(b, c) d { Wrapped $1 (Just $2) $3 }
+
+moduleName :: { Name N.ModuleName }
+ : UPPER {% upperToModuleName $1 }
+ | QUAL_UPPER {% upperToModuleName $1 }
+
+qualProperName :: { QualifiedName (N.ProperName a) }
+ : UPPER {% toQualifiedName N.ProperName $1 }
+ | QUAL_UPPER {% toQualifiedName N.ProperName $1 }
+
+properName :: { Name (N.ProperName a) }
+ : UPPER {% toName N.ProperName $1 }
+
+qualIdent :: { QualifiedName Ident }
+ : LOWER {% toQualifiedName Ident $1 }
+ | QUAL_LOWER {% toQualifiedName Ident $1 }
+ | 'as' {% toQualifiedName Ident $1 }
+ | 'hiding' {% toQualifiedName Ident $1 }
+ | 'kind' {% toQualifiedName Ident $1 }
+
+ident :: { Name Ident }
+ : LOWER {% toName Ident $1 }
+ | 'as' {% toName Ident $1 }
+ | 'hiding' {% toName Ident $1 }
+ | 'kind' {% toName Ident $1 }
+
+qualOp :: { QualifiedName (N.OpName a) }
+ : OPERATOR {% toQualifiedName N.OpName $1 }
+ | QUAL_OPERATOR {% toQualifiedName N.OpName $1 }
+ | '<=' {% toQualifiedName N.OpName $1 }
+ | '-' {% toQualifiedName N.OpName $1 }
+ | '#' {% toQualifiedName N.OpName $1 }
+ | ':' {% toQualifiedName N.OpName $1 }
+
+op :: { Name (N.OpName a) }
+ : OPERATOR {% toName N.OpName $1 }
+ | '<=' {% toName N.OpName $1 }
+ | '-' {% toName N.OpName $1 }
+ | '#' {% toName N.OpName $1 }
+ | ':' {% toName N.OpName $1 }
+
+qualSymbol :: { QualifiedName (N.OpName a) }
+ : SYMBOL {% toQualifiedName N.OpName $1 }
+ | QUAL_SYMBOL {% toQualifiedName N.OpName $1 }
+ | '(..)' {% toQualifiedName N.OpName $1 }
+
+symbol :: { Name (N.OpName a) }
+ : SYMBOL {% toName N.OpName $1 }
+ | '(..)' {% toName N.OpName $1 }
+
+label :: { Label }
+ : LOWER { toLabel $1 }
+ | LIT_STRING { toLabel $1 }
+ | LIT_RAW_STRING { toLabel $1 }
+ | 'ado' { toLabel $1 }
+ | 'as' { toLabel $1 }
+ | 'case' { toLabel $1 }
+ | 'class' { toLabel $1 }
+ | 'data' { toLabel $1 }
+ | 'derive' { toLabel $1 }
+ | 'do' { toLabel $1 }
+ | 'else' { toLabel $1 }
+ | 'false' { toLabel $1 }
+ | 'forall' { toLabel $1 }
+ | 'foreign' { toLabel $1 }
+ | 'hiding' { toLabel $1 }
+ | 'import' { toLabel $1 }
+ | 'if' { toLabel $1 }
+ | 'in' { toLabel $1 }
+ | 'infix' { toLabel $1 }
+ | 'infixl' { toLabel $1 }
+ | 'infixr' { toLabel $1 }
+ | 'instance' { toLabel $1 }
+ | 'kind' { toLabel $1 }
+ | 'let' { toLabel $1 }
+ | 'module' { toLabel $1 }
+ | 'newtype' { toLabel $1 }
+ | 'of' { toLabel $1 }
+ | 'then' { toLabel $1 }
+ | 'true' { toLabel $1 }
+ | 'type' { toLabel $1 }
+ | 'where' { toLabel $1 }
+
+hole :: { Name Ident }
+ : LIT_HOLE {% toName Ident $1 }
+
+string :: { (SourceToken, PSString) }
+ : LIT_STRING { toString $1 }
+ | LIT_RAW_STRING { toString $1 }
+
+char :: { (SourceToken, Char) }
+ : LIT_CHAR { toChar $1 }
+
+number :: { (SourceToken, Either Integer Double) }
+ : LIT_INT { toNumber $1 }
+ | LIT_NUMBER { toNumber $1 }
+
+int :: { (SourceToken, Integer) }
+ : LIT_INT { toInt $1 }
+
+boolean :: { (SourceToken, Bool) }
+ : 'true' { toBoolean $1 }
+ | 'false' { toBoolean $1 }
+
+kind :: { Kind () }
+ : kind1 { $1 }
+ | kind1 '->' kind { KindArr () $1 $2 $3 }
+
+kind1 :: { Kind () }
+ : qualProperName { KindName () $1 }
+ | '#' kind1 { KindRow () $1 $2 }
+ | '(' kind ')' { KindParens () (Wrapped $1 $2 $3) }
+
+type :: { Type () }
+ : type1 { $1 }
+ | type1 '::' kind { TypeKinded () $1 $2 $3 }
+
+type1 :: { Type () }
+ : type2 { $1 }
+ | forall many(typeVarBinding) '.' type1 { TypeForall () $1 $2 $3 $4 }
+
+type2 :: { Type () }
+ : type3 { $1 }
+ | type3 '->' type1 { TypeArr () $1 $2 $3 }
+ | type3 '=>' type1 {% do cs <- toConstraint $1; pure $ TypeConstrained () cs $2 $3 }
+
+type3 :: { Type () }
+ : type4 { $1 }
+ | type3 qualOp type4 { TypeOp () $1 $2 $3 }
+
+type4 :: { Type () }
+ : typeAtom { $1 }
+ | type4 typeAtom { TypeApp () $1 $2 }
+
+typeAtom :: { Type ()}
+ : '_' { TypeWildcard () $1 }
+ | ident { TypeVar () $1 }
+ | qualProperName { TypeConstructor () $1 }
+ | qualSymbol { TypeOpName () $1 }
+ | string { uncurry (TypeString ()) $1 }
+ | hole { TypeHole () $1 }
+ | '(->)' { TypeArrName () $1 }
+ | '{' row '}' { TypeRecord () (Wrapped $1 $2 $3) }
+ | '(' row ')' { TypeRow () (Wrapped $1 $2 $3) }
+ | '(' type1 ')' { TypeParens () (Wrapped $1 $2 $3) }
+ | '(' typeKindedAtom '::' kind ')' { TypeParens () (Wrapped $1 (TypeKinded () $2 $3 $4) $5) }
+
+-- Due to a conflict between row syntax and kinded type syntax, we require
+-- kinded type variables to be wrapped in parens. Thus `(a :: Foo)` is always a
+-- row, and to annotate `a` with kind `Foo`, one must use `((a) :: Foo)`.
+typeKindedAtom :: { Type () }
+ : '_' { TypeWildcard () $1 }
+ | qualProperName { TypeConstructor () $1 }
+ | qualSymbol { TypeOpName () $1 }
+ | hole { TypeHole () $1 }
+ | '{' row '}' { TypeRecord () (Wrapped $1 $2 $3) }
+ | '(' row ')' { TypeRow () (Wrapped $1 $2 $3) }
+ | '(' type1 ')' { TypeParens () (Wrapped $1 $2 $3) }
+ | '(' typeKindedAtom '::' kind ')' { TypeParens () (Wrapped $1 (TypeKinded () $2 $3 $4) $5) }
+
+row :: { Row () }
+ : {- empty -} { Row Nothing Nothing }
+ | '|' type { Row Nothing (Just ($1, $2)) }
+ | sep(rowLabel, ',') { Row (Just $1) Nothing }
+ | sep(rowLabel, ',') '|' type { Row (Just $1) (Just ($2, $3)) }
+
+rowLabel :: { Labeled Label (Type ()) }
+ : label '::' type { Labeled $1 $2 $3 }
+
+typeVarBinding :: { TypeVarBinding () }
+ : ident { TypeVarName $1 }
+ | '(' ident '::' kind ')' { TypeVarKinded (Wrapped $1 (Labeled $2 $3 $4) $5) }
+
+forall :: { SourceToken }
+ : 'forall' { $1 }
+ | 'forallu' { $1 }
+
+exprWhere :: { Where () }
+ : expr { Where $1 Nothing }
+ | expr 'where' '\{' manySep(letBinding, '\;') '\}' { Where $1 (Just ($2, $4)) }
+
+expr :: { Expr () }
+ : expr1 { $1 }
+ | expr1 '::' type { ExprTyped () $1 $2 $3 }
+
+expr1 :: { Expr () }
+ : expr2 { $1 }
+ | expr1 qualOp expr2 { ExprOp () $1 $2 $3 }
+
+expr2 :: { Expr () }
+ : expr3 { $1 }
+ | expr2 '`' exprBacktick '`' expr3 { ExprInfix () $1 (Wrapped $2 $3 $4) $5 }
+
+exprBacktick :: { Expr () }
+ : expr3 { $1 }
+ | exprBacktick qualOp expr3 { ExprOp () $1 $2 $3 }
+
+expr3 :: { Expr () }
+ : expr4 { $1 }
+ | '-' expr3 { ExprNegate () $1 $2 }
+
+expr4 :: { Expr () }
+ : expr5 { $1 }
+ | expr4 expr5
+ { -- Record application/updates can introduce a function application
+ -- associated to the right, so we need to correct it.
+ case $2 of
+ ExprApp _ lhs rhs ->
+ ExprApp () (ExprApp () $1 lhs) rhs
+ _ -> ExprApp () $1 $2
+ }
+
+expr5 :: { Expr () }
+ : expr6 { $1 }
+ | 'if' expr 'then' expr 'else' expr { ExprIf () (IfThenElse $1 $2 $3 $4 $5 $6) }
+ | doBlock { ExprDo () $1 }
+ | adoBlock 'in' expr { ExprAdo () $ uncurry AdoBlock $1 $2 $3 }
+ | '\\' many(binderAtom) '->' expr { ExprLambda () (Lambda $1 $2 $3 $4) }
+ | 'let' '\{' manySep(letBinding, '\;') '\}' 'in' expr { ExprLet () (LetIn $1 $3 $5 $6) }
+ | 'case' sep(expr, ',') 'of' '\{' manySep(caseBranch, '\;') '\}' { ExprCase () (CaseOf $1 $2 $3 $5) }
+ -- These special cases handle some idiosynchratic syntax that the current
+ -- parser allows. Technically the parser allows the rhs of a case branch to be
+ -- at any level, but this is ambiguous. We allow it in the case of a singleton
+ -- case, since this is used in the wild.
+ | 'case' sep(expr, ',') 'of' '\{' sep(binder1, ',') '->' '\}' exprWhere
+ { ExprCase () (CaseOf $1 $2 $3 (pure ($5, Unconditional $6 $8))) }
+ | 'case' sep(expr, ',') 'of' '\{' sep(binder1, ',') '\}' guarded('->')
+ { ExprCase () (CaseOf $1 $2 $3 (pure ($5, $7))) }
+
+expr6 :: { Expr () }
+ : expr7 { $1 }
+ | expr7 '{' '}' { ExprApp () $1 (ExprRecord () (Wrapped $2 Nothing $3)) }
+ | expr7 '{' sep(recordUpdateOrLabel, ',') '}'
+ {% toRecordFields $3 >>= \case
+ Left xs -> pure $ ExprApp () $1 (ExprRecord () (Wrapped $2 (Just xs) $4))
+ Right xs -> pure $ ExprRecordUpdate () $1 (Wrapped $2 xs $4)
+ }
+
+expr7 :: { Expr () }
+ : exprAtom { $1 }
+ | exprAtom '.' sep(label, '.') { ExprRecordAccessor () (RecordAccessor $1 $2 $3) }
+
+exprAtom :: { Expr () }
+ : '_' { ExprSection () $1 }
+ | hole { ExprHole () $1 }
+ | qualIdent { ExprIdent () $1 }
+ | qualProperName { ExprConstructor () $1 }
+ | qualSymbol { ExprOpName () $1 }
+ | boolean { uncurry (ExprBoolean ()) $1 }
+ | char { uncurry (ExprChar ()) $1 }
+ | string { uncurry (ExprString ()) $1 }
+ | number { uncurry (ExprNumber ()) $1 }
+ | delim('[', expr, ',', ']') { ExprArray () $1 }
+ | delim('{', recordLabel, ',', '}') { ExprRecord () $1 }
+ | '(' expr ')' { ExprParens () (Wrapped $1 $2 $3) }
+
+recordLabel :: { RecordLabeled (Expr ()) }
+ : label {% fmap RecordPun . toName Ident $ lblTok $1 }
+ | label '=' expr {% addFailure [$2] ErrRecordUpdateInCtr *> pure (RecordPun $ unexpectedName $ lblTok $1) }
+ | label ':' expr { RecordField $1 $2 $3 }
+
+recordUpdateOrLabel :: { Either (RecordLabeled (Expr ())) (RecordUpdate ()) }
+ : label ':' expr { Left (RecordField $1 $2 $3) }
+ | label {% fmap (Left . RecordPun) . toName Ident $ lblTok $1 }
+ | label '=' expr { Right (RecordUpdateLeaf $1 $2 $3) }
+ | label '{' sep(recordUpdate, ',') '}' { Right (RecordUpdateBranch $1 (Wrapped $2 $3 $4)) }
+
+recordUpdate :: { RecordUpdate () }
+ : label '=' expr { RecordUpdateLeaf $1 $2 $3 }
+ | label '{' sep(recordUpdate, ',') '}' { RecordUpdateBranch $1 (Wrapped $2 $3 $4) }
+
+letBinding :: { LetBinding () }
+ : ident '::' type { LetBindingSignature () (Labeled $1 $2 $3) }
+ | ident guarded('=') { LetBindingName () (ValueBindingFields $1 [] $2) }
+ | ident many(binderAtom) guarded('=') { LetBindingName () (ValueBindingFields $1 (NE.toList $2) $3) }
+ | binder1 '=' exprWhere { LetBindingPattern () $1 $2 $3 }
+
+caseBranch :: { (Separated (Binder ()), Guarded ()) }
+ : sep(binder1, ',') guarded('->') { ($1, $2) }
+
+guarded(a) :: { Guarded () }
+ : a exprWhere { Unconditional $1 $2 }
+ | many(guardedExpr(a)) { Guarded $1 }
+
+guardedExpr(a) :: { GuardedExpr () }
+ : guard a exprWhere { uncurry GuardedExpr $1 $2 $3 }
+
+-- Do/Ado statements and pattern guards require unbounded lookahead due to many
+-- conflicts between `binder` and `expr` syntax. For example `Foo a b c` can
+-- either be a constructor `binder` or several `expr` applications, and we won't
+-- know until we see a `<-` or layout separator.
+--
+-- One way to resolve this would be to parse a `binder` as an `expr` and then
+-- reassociate it after the fact. However this means we can't use the `binder`
+-- productions to parse it, so we'd have to maintain an ad-hoc handwritten
+-- parser which is very difficult to audit.
+--
+-- As an alternative we introduce some backtracking. Using %partial parsers and
+-- monadic reductions, we can invoke productions manually and use the
+-- backtracking `tryPrefix` combinator. Binders are generally very short in
+-- comparison to expressions, so the cost is modest.
+--
+-- doBlock
+-- : 'do' '\{' manySep(doStatement, '\;') '\}'
+--
+-- doStatement
+-- : 'let' '\{' manySep(letBinding, '\;') '\}'
+-- | expr
+-- | binder '<-' expr
+--
+-- guard
+-- : '|' sep(patternGuard, ',')
+--
+-- patternGuard
+-- : expr1
+-- | binder '<-' expr1
+--
+doBlock :: { DoBlock () }
+ : 'do' '\{'
+ {%% revert $ do
+ res <- parseDoStatement
+ when (null res) $ addFailure [$2] ErrEmptyDo
+ pure $ DoBlock $1 $ NE.fromList res
+ }
+
+adoBlock :: { (SourceToken, [DoStatement ()]) }
+ : 'ado' '\{' '\}' { ($1, []) }
+ | 'ado' '\{'
+ {%% revert $ fmap ($1,) parseDoStatement }
+
+doStatement :: { [DoStatement ()] }
+ : 'let' '\{' manySep(letBinding, '\;') '\}'
+ {%^ revert $ fmap (DoLet $1 $3 :) parseDoNext }
+ | {- empty -}
+ {%^ revert $ do
+ stmt <- tryPrefix parseBinderAndArrow parseDoExpr
+ let
+ ctr = case stmt of
+ (Just (binder, sep), expr) ->
+ (DoBind binder sep expr :)
+ (Nothing, expr) ->
+ (DoDiscard expr :)
+ fmap ctr parseDoNext
+ }
+
+doExpr :: { Expr () }
+ : expr {%^ revert $ pure $1 }
+
+doNext :: { [DoStatement ()] }
+ : '\;' {%^ revert parseDoStatement }
+ | '\}' {%^ revert $ pure [] }
+
+guard :: { (SourceToken, Separated (PatternGuard ())) }
+ : '|' {%% revert $ fmap (($1,) . uncurry Separated) parseGuardStatement }
+
+guardStatement :: { (PatternGuard (), [(SourceToken, PatternGuard ())]) }
+ : {- empty -}
+ {%^ revert $ do
+ grd <- fmap (uncurry PatternGuard) $ tryPrefix parseBinderAndArrow parseGuardExpr
+ fmap (grd,) parseGuardNext
+ }
+
+guardExpr :: { Expr() }
+ : expr1 {%^ revert $ pure $1 }
+
+guardNext :: { [(SourceToken, PatternGuard ())] }
+ : ',' {%^ revert $ fmap (\(g, gs) -> ($1, g) : gs) parseGuardStatement }
+ | {- empty -} {%^ revert $ pure [] }
+
+binderAndArrow :: { (Binder (), SourceToken) }
+ : binder '<-' {%^ revert $ pure ($1, $2) }
+
+binder :: { Binder () }
+ : binder1 { $1 }
+ | binder1 '::' type { BinderTyped () $1 $2 $3 }
+
+binder1 :: { Binder () }
+ : binder2 { $1 }
+ | binder1 qualOp binder2 { BinderOp () $1 $2 $3 }
+
+binder2 :: { Binder () }
+ : many(binderAtom) {% toBinderConstructor $1 }
+
+binderAtom :: { Binder () }
+ : '_' { BinderWildcard () $1 }
+ | ident { BinderVar () $1 }
+ | ident '@' binderAtom { BinderNamed () $1 $2 $3 }
+ | qualProperName { BinderConstructor () $1 [] }
+ | boolean { uncurry (BinderBoolean ()) $1 }
+ | char { uncurry (BinderChar ()) $1 }
+ | string { uncurry (BinderString ()) $1 }
+ | number { uncurry (BinderNumber () Nothing) $1 }
+ | '-' number { uncurry (BinderNumber () (Just $1)) $2 }
+ | delim('[', binder, ',', ']') { BinderArray () $1 }
+ | delim('{', recordBinder, ',', '}') { BinderRecord () $1 }
+ | '(' binder ')' { BinderParens () (Wrapped $1 $2 $3) }
+
+recordBinder :: { RecordLabeled (Binder ()) }
+ : label {% fmap RecordPun . toName Ident $ lblTok $1 }
+ | label '=' binder {% addFailure [$2] ErrRecordUpdateInCtr *> pure (RecordPun $ unexpectedName $ lblTok $1) }
+ | label ':' binder { RecordField $1 $2 $3 }
+
+-- By splitting up the module header from the body, we can incrementally parse
+-- just the header, and then continue parsing the body while still sharing work.
+moduleHeader :: { Module () }
+ : 'module' moduleName exports 'where' '\{' moduleImports
+ { (Module () $1 $2 $3 $4 $6 [] []) }
+
+moduleBody :: { ([Declaration ()], [Comment LineFeed]) }
+ : moduleDecls '\}'
+ {%^ \(SourceToken ann _) -> pure (snd $1, tokLeadingComments ann) }
+
+moduleImports :: { [ImportDecl ()] }
+ : importDecls importDecl '\}'
+ {%^ revert $ pushBack $3 *> pure (reverse ($2 : $1)) }
+ | importDecls
+ {%^ revert $ pure (reverse $1) }
+
+importDecls :: { [ImportDecl ()] }
+ : importDecls importDecl '\;' { $2 : $1 }
+ | {- empty -} { [] }
+
+moduleDecls :: { ([ImportDecl ()], [Declaration ()]) }
+ : manySep(moduleDecl, '\;') {% toModuleDecls $ NE.toList $1 }
+ | {- empty -} { ([], []) }
+
+moduleDecl :: { TmpModuleDecl a }
+ : importDecl { TmpImport $1 }
+ | sep(decl, declElse) { TmpChain $1 }
+
+declElse :: { SourceToken }
+ : 'else' { $1 }
+ | 'else' '\;' { $1 }
+
+exports :: { Maybe (DelimitedNonEmpty (Export ())) }
+ : {- empty -} { Nothing }
+ | '(' sep(export, ',') ')' { Just (Wrapped $1 $2 $3) }
+
+export :: { Export () }
+ : ident { ExportValue () $1 }
+ | symbol { ExportOp () $1 }
+ | properName { ExportType () $1 Nothing }
+ | properName dataMembers { ExportType () $1 (Just $2) }
+ | 'type' symbol { ExportTypeOp () $1 $2 }
+ | 'class' properName { ExportClass () $1 $2 }
+ | 'kind' properName { ExportKind () $1 $2 }
+ | 'module' moduleName { ExportModule () $1 $2 }
+
+dataMembers :: { (DataMembers ()) }
+ : '(..)' { DataAll () $1 }
+ | '(' ')' { DataEnumerated () (Wrapped $1 Nothing $2) }
+ | '(' sep(properName, ',') ')' { DataEnumerated () (Wrapped $1 (Just $2) $3) }
+
+importDecl :: { ImportDecl () }
+ : 'import' moduleName imports { ImportDecl () $1 $2 $3 Nothing }
+ | 'import' moduleName imports 'as' moduleName { ImportDecl () $1 $2 $3 (Just ($4, $5)) }
+
+imports :: { Maybe (Maybe SourceToken, DelimitedNonEmpty (Import ())) }
+ : {- empty -} { Nothing }
+ | '(' sep(import, ',') ')' { Just (Nothing, Wrapped $1 $2 $3) }
+ | 'hiding' '(' sep(import, ',') ')' { Just (Just $1, Wrapped $2 $3 $4) }
+
+import :: { Import () }
+ : ident { ImportValue () $1 }
+ | symbol { ImportOp () $1 }
+ | properName { ImportType () $1 Nothing }
+ | properName dataMembers { ImportType () $1 (Just $2) }
+ | 'type' symbol { ImportTypeOp () $1 $2 }
+ | 'class' properName { ImportClass () $1 $2 }
+ | 'kind' properName { ImportKind () $1 $2 }
+
+decl :: { Declaration () }
+ : dataHead { DeclData () $1 Nothing }
+ | dataHead '=' sep(dataCtor, '|') { DeclData () $1 (Just ($2, $3)) }
+ | typeHead '=' type {% checkNoWildcards $3 *> pure (DeclType () $1 $2 $3) }
+ | newtypeHead '=' properName typeAtom {% checkNoWildcards $4 *> pure (DeclNewtype () $1 $2 $3 $4) }
+ | classHead {% checkFundeps $1 *> pure (DeclClass () $1 Nothing) }
+ | classHead 'where' '\{' manySep(classMember, '\;') '\}' {% checkFundeps $1 *> pure (DeclClass () $1 (Just ($2, $4))) }
+ | instHead { DeclInstanceChain () (Separated (Instance $1 Nothing) []) }
+ | instHead 'where' '\{' manySep(instBinding, '\;') '\}' { DeclInstanceChain () (Separated (Instance $1 (Just ($2, $4))) []) }
+ | 'derive' instHead { DeclDerive () $1 Nothing $2 }
+ | 'derive' 'newtype' instHead { DeclDerive () $1 (Just $2) $3 }
+ | ident '::' type { DeclSignature () (Labeled $1 $2 $3) }
+ | ident manyOrEmpty(binderAtom) guarded('=') { DeclValue () (ValueBindingFields $1 $2 $3) }
+ | fixity { DeclFixity () $1 }
+ | 'foreign' 'import' foreign { DeclForeign () $1 $2 $3 }
+
+dataHead :: { DataHead () }
+ : 'data' properName manyOrEmpty(typeVarBinding) { DataHead $1 $2 $3 }
+
+typeHead :: { DataHead () }
+ : 'type' properName manyOrEmpty(typeVarBinding) { DataHead $1 $2 $3 }
+
+newtypeHead :: { DataHead () }
+ : 'newtype' properName manyOrEmpty(typeVarBinding) { DataHead $1 $2 $3 }
+
+dataCtor :: { DataCtor () }
+ : properName manyOrEmpty(typeAtom)
+ {% for_ $2 checkNoWildcards *> pure (DataCtor () $1 $2) }
+
+-- Class head syntax requires unbounded lookahead due to a conflict between
+-- row syntax and `typeVarBinding`. `(a :: B)` is either a row in `constraint`
+-- where `B` is a type or a `typeVarBinding` where `B` is a kind. We must see
+-- either a `<=`, `where`, or layout delimiter before deciding which it is.
+--
+-- classHead
+-- : 'class' classNameAndFundeps
+-- | 'class' constraints '<=' classNameAndFundeps
+--
+classHead :: { ClassHead () }
+ : 'class'
+ {%% revert $ do
+ let
+ ctr (super, (name, vars, fundeps)) =
+ ClassHead $1 super name vars fundeps
+ fmap ctr $ tryPrefix parseClassSuper parseClassNameAndFundeps
+ }
+
+classSuper
+ : constraints '<=' {%^ revert $ pure ($1, $2) }
+
+classNameAndFundeps :: { (Name (N.ProperName 'N.ClassName), [TypeVarBinding ()], Maybe (SourceToken, Separated ClassFundep)) }
+ : properName manyOrEmpty(typeVarBinding) fundeps {%^ revert $ pure ($1, $2, $3) }
+
+fundeps :: { Maybe (SourceToken, Separated ClassFundep) }
+ : {- empty -} { Nothing }
+ | '|' sep(fundep, ',') { Just ($1, $2) }
+
+fundep :: { ClassFundep }
+ : '->' many(ident) { FundepDetermined $1 $2 }
+ | many(ident) '->' many(ident) { FundepDetermines $1 $2 $3 }
+
+classMember :: { Labeled (Name Ident) (Type ()) }
+ : ident '::' type {% checkNoWildcards $3 *> pure (Labeled $1 $2 $3) }
+
+instHead :: { InstanceHead () }
+ : 'instance' ident '::' constraints '=>' qualProperName manyOrEmpty(typeAtom)
+ { InstanceHead $1 $2 $3 (Just ($4, $5)) $6 $7 }
+ | 'instance' ident '::' qualProperName manyOrEmpty(typeAtom)
+ { InstanceHead $1 $2 $3 Nothing $4 $5 }
+
+constraints :: { OneOrDelimited (Constraint ()) }
+ : constraint { One $1 }
+ | '(' sep(constraint, ',') ')' { Many (Wrapped $1 $2 $3) }
+
+constraint :: { Constraint () }
+ : qualProperName manyOrEmpty(typeAtom) {% for_ $2 checkNoWildcards *> for_ $2 checkNoForalls *> pure (Constraint () $1 $2) }
+ | '(' constraint ')' { ConstraintParens () (Wrapped $1 $2 $3) }
+
+instBinding :: { InstanceBinding () }
+ : ident '::' type { InstanceBindingSignature () (Labeled $1 $2 $3) }
+ | ident manyOrEmpty(binderAtom) guarded('=') { InstanceBindingName () (ValueBindingFields $1 $2 $3) }
+
+fixity :: { FixityFields }
+ : infix int qualIdent 'as' op { FixityFields $1 $2 (FixityValue (fmap Left $3) $4 $5) }
+ | infix int qualProperName 'as' op { FixityFields $1 $2 (FixityValue (fmap Right $3) $4 $5) }
+ | infix int 'type' qualProperName 'as' op { FixityFields $1 $2 (FixityType $3 $4 $5 $6) }
+
+infix :: { (SourceToken, Fixity) }
+ : 'infix' { ($1, Infix) }
+ | 'infixl' { ($1, Infixl) }
+ | 'infixr' { ($1, Infixr) }
+
+foreign :: { Foreign () }
+ : ident '::' type { ForeignValue (Labeled $1 $2 $3) }
+ | 'data' properName '::' kind { ForeignData $1 (Labeled $2 $3 $4) }
+ | 'kind' properName { ForeignKind $1 $2 }
+
+-- Partial parsers which can be combined with combinators for adhoc use. We need
+-- to revert the lookahead token so that it doesn't consume an extra token
+-- before succeeding.
+
+importDeclP :: { ImportDecl () }
+ : importDecl {%^ revert $ pure $1 }
+
+declP :: { Declaration () }
+ : decl {%^ revert $ pure $1 }
+
+exprP :: { Expr () }
+ : expr {%^ revert $ pure $1 }
+
+typeP :: { Type () }
+ : type {%^ revert $ pure $1 }
+
+moduleNameP :: { Name N.ModuleName }
+ : moduleName {%^ revert $ pure $1 }
+
+qualIdentP :: { QualifiedName Ident }
+ : qualIdent {%^ revert $ pure $1 }
+
+{
+lexer :: (SourceToken -> Parser a) -> Parser a
+lexer k = munch >>= k
+
+parse :: Text -> Either (NE.NonEmpty ParserError) (Module ())
+parse = resFull <=< parseModule . lex
+
+data PartialResult a = PartialResult
+ { resPartial :: a
+ , resFull :: Either (NE.NonEmpty ParserError) a
+ } deriving (Functor)
+
+parseModule :: [LexResult] -> Either (NE.NonEmpty ParserError) (PartialResult (Module ()))
+parseModule toks = fmap (\header -> PartialResult header (parseFull header)) headerRes
+ where
+ (st, headerRes) =
+ runParser (ParserState (toks) []) parseModuleHeader
+
+ parseFull header = do
+ (decls, trailing) <- snd $ runParser st parseModuleBody
+ pure $ header
+ { modDecls = decls
+ , modTrailingComments = trailing
+ }
+}
diff --git a/src/Language/PureScript/CST/Positions.hs b/src/Language/PureScript/CST/Positions.hs
new file mode 100644
index 0000000..67f03a0
--- /dev/null
+++ b/src/Language/PureScript/CST/Positions.hs
@@ -0,0 +1,352 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE NamedFieldPuns #-}
+
+-- | This module contains utilities for calculating positions and offsets. While
+-- tokens are annotated with ranges, CST nodes are not, but they can be
+-- dynamically derived with the functions in this module, which will return the
+-- first and last tokens for a given node.
+
+module Language.PureScript.CST.Positions where
+
+import Prelude
+
+import Data.Foldable (foldl')
+import qualified Data.List.NonEmpty as NE
+import Data.Text (Text)
+import Data.Void (Void)
+import qualified Data.Text as Text
+import Language.PureScript.CST.Types
+
+advanceToken :: SourcePos -> Token -> SourcePos
+advanceToken pos = applyDelta pos . tokenDelta
+
+advanceLeading :: SourcePos -> [Comment LineFeed] -> SourcePos
+advanceLeading pos = foldl' (\a -> applyDelta a . commentDelta lineDelta) pos
+
+advanceTrailing :: SourcePos -> [Comment Void] -> SourcePos
+advanceTrailing pos = foldl' (\a -> applyDelta a . commentDelta (const (0, 0))) pos
+
+tokenDelta :: Token -> (Int, Int)
+tokenDelta = \case
+ TokLeftParen -> (0, 1)
+ TokRightParen -> (0, 1)
+ TokLeftBrace -> (0, 1)
+ TokRightBrace -> (0, 1)
+ TokLeftSquare -> (0, 1)
+ TokRightSquare -> (0, 1)
+ TokLeftArrow ASCII -> (0, 2)
+ TokLeftArrow Unicode -> (0, 1)
+ TokRightArrow ASCII -> (0, 2)
+ TokRightArrow Unicode -> (0, 1)
+ TokRightFatArrow ASCII -> (0, 2)
+ TokRightFatArrow Unicode -> (0, 1)
+ TokDoubleColon ASCII -> (0, 2)
+ TokDoubleColon Unicode -> (0, 1)
+ TokForall ASCII -> (0, 6)
+ TokForall Unicode -> (0, 1)
+ TokEquals -> (0, 1)
+ TokPipe -> (0, 1)
+ TokTick -> (0, 1)
+ TokDot -> (0, 1)
+ TokComma -> (0, 1)
+ TokUnderscore -> (0, 1)
+ TokBackslash -> (0, 1)
+ TokLowerName qual name -> (0, qualDelta qual + Text.length name)
+ TokUpperName qual name -> (0, qualDelta qual + Text.length name)
+ TokOperator qual sym -> (0, qualDelta qual + Text.length sym)
+ TokSymbolName qual sym -> (0, qualDelta qual + Text.length sym + 2)
+ TokSymbolArr Unicode -> (0, 3)
+ TokSymbolArr ASCII -> (0, 4)
+ TokHole hole -> (0, Text.length hole + 1)
+ TokChar raw _ -> (0, Text.length raw + 2)
+ TokInt raw _ -> (0, Text.length raw)
+ TokNumber raw _ -> (0, Text.length raw)
+ TokString raw _ -> multiLine 1 $ textDelta raw
+ TokRawString raw -> multiLine 3 $ textDelta raw
+ TokLayoutStart -> (0, 0)
+ TokLayoutSep -> (0, 0)
+ TokLayoutEnd -> (0, 0)
+ TokEof -> (0, 0)
+
+qualDelta :: [Text] -> Int
+qualDelta = foldr ((+) . (+ 1) . Text.length) 0
+
+multiLine :: Int -> (Int, Int) -> (Int, Int)
+multiLine n (0, c) = (0, c + n + n)
+multiLine n (l, c) = (l, c + n)
+
+commentDelta :: (a -> (Int, Int)) -> Comment a -> (Int, Int)
+commentDelta k = \case
+ Comment raw -> textDelta raw
+ Space n -> (0, n)
+ Line a -> k a
+
+lineDelta :: LineFeed -> (Int, Int)
+lineDelta _ = (1, 1)
+
+textDelta :: Text -> (Int, Int)
+textDelta = Text.foldl' go (0, 0)
+ where
+ go (!l, !c) = \case
+ '\n' -> (l + 1, 1)
+ _ -> (l, c + 1)
+
+applyDelta :: SourcePos -> (Int, Int) -> SourcePos
+applyDelta (SourcePos l c) = \case
+ (0, n) -> SourcePos l (c + n)
+ (k, d) -> SourcePos (l + k) d
+
+sepLast :: Separated a -> a
+sepLast (Separated hd []) = hd
+sepLast (Separated _ tl) = snd $ last tl
+
+type TokenRange = (SourceToken, SourceToken)
+
+toSourceRange :: TokenRange -> SourceRange
+toSourceRange (a, b) = widen (srcRange a) (srcRange b)
+
+widen :: SourceRange -> SourceRange -> SourceRange
+widen (SourceRange s1 _) (SourceRange _ e2) = SourceRange s1 e2
+
+srcRange :: SourceToken -> SourceRange
+srcRange = tokRange . tokAnn
+
+nameRange :: Name a -> TokenRange
+nameRange a = (nameTok a, nameTok a)
+
+qualRange :: QualifiedName a -> TokenRange
+qualRange a = (qualTok a, qualTok a)
+
+labelRange :: Label -> TokenRange
+labelRange a = (lblTok a, lblTok a)
+
+wrappedRange :: Wrapped a -> TokenRange
+wrappedRange (Wrapped { wrpOpen, wrpClose }) = (wrpOpen, wrpClose)
+
+moduleRange :: Module a -> TokenRange
+moduleRange (Module { modKeyword, modWhere, modImports, modDecls }) =
+ case (modImports, modDecls) of
+ ([], []) -> (modKeyword, modWhere)
+ (is, []) -> (modKeyword, snd . importDeclRange $ last is)
+ (_, ds) -> (modKeyword, snd . declRange $ last ds)
+
+exportRange :: Export a -> TokenRange
+exportRange = \case
+ ExportValue _ a -> nameRange a
+ ExportOp _ a -> nameRange a
+ ExportType _ a b
+ | Just b' <- b -> (nameTok a, snd $ dataMembersRange b')
+ | otherwise -> nameRange a
+ ExportTypeOp _ a b -> (a, nameTok b)
+ ExportClass _ a b -> (a, nameTok b)
+ ExportKind _ a b -> (a, nameTok b)
+ ExportModule _ a b -> (a, nameTok b)
+
+importDeclRange :: ImportDecl a -> TokenRange
+importDeclRange (ImportDecl { impKeyword, impModule, impNames, impQual })
+ | Just (_, modName) <- impQual = (impKeyword, nameTok modName)
+ | Just (_, imports) <- impNames = (impKeyword, wrpClose imports)
+ | otherwise = (impKeyword, nameTok impModule)
+
+importRange :: Import a -> TokenRange
+importRange = \case
+ ImportValue _ a -> nameRange a
+ ImportOp _ a -> nameRange a
+ ImportType _ a b
+ | Just b' <- b -> (nameTok a, snd $ dataMembersRange b')
+ | otherwise -> nameRange a
+ ImportTypeOp _ a b -> (a, nameTok b)
+ ImportClass _ a b -> (a, nameTok b)
+ ImportKind _ a b -> (a, nameTok b)
+
+dataMembersRange :: DataMembers a -> TokenRange
+dataMembersRange = \case
+ DataAll _ a -> (a, a)
+ DataEnumerated _ (Wrapped a _ b) -> (a, b)
+
+declRange :: Declaration a -> TokenRange
+declRange = \case
+ DeclData _ hd ctors
+ | Just (_, cs) <- ctors -> (fst start, snd . dataCtorRange $ sepLast cs)
+ | otherwise -> start
+ where start = dataHeadRange hd
+ DeclType _ a _ b -> (fst $ dataHeadRange a, snd $ typeRange b)
+ DeclNewtype _ a _ _ b -> (fst $ dataHeadRange a, snd $ typeRange b)
+ DeclClass _ hd body
+ | Just (_, ts) <- body -> (fst start, snd . typeRange . lblValue $ NE.last ts)
+ | otherwise -> start
+ where start = classHeadRange hd
+ DeclInstanceChain _ a -> (fst . instanceRange $ sepHead a, snd . instanceRange $ sepLast a)
+ DeclDerive _ a _ b -> (a, snd $ instanceHeadRange b)
+ DeclSignature _ (Labeled a _ b) -> (nameTok a, snd $ typeRange b)
+ DeclValue _ a -> valueBindingFieldsRange a
+ DeclFixity _ (FixityFields a _ (FixityValue _ _ b)) -> (fst a, nameTok b)
+ DeclFixity _ (FixityFields a _ (FixityType _ _ _ b)) -> (fst a, nameTok b)
+ DeclForeign _ a _ b -> (a, snd $ foreignRange b)
+
+dataHeadRange :: DataHead a -> TokenRange
+dataHeadRange (DataHead kw name vars)
+ | [] <- vars = (kw, nameTok name)
+ | otherwise = (kw, snd . typeVarBindingRange $ last vars)
+
+dataCtorRange :: DataCtor a -> TokenRange
+dataCtorRange (DataCtor _ name fields)
+ | [] <- fields = nameRange name
+ | otherwise = (nameTok name, snd . typeRange $ last fields)
+
+classHeadRange :: ClassHead a -> TokenRange
+classHeadRange (ClassHead kw _ name vars fdeps)
+ | Just (_, fs) <- fdeps = (kw, snd .classFundepRange $ sepLast fs)
+ | [] <- vars = (kw, snd $ nameRange name)
+ | otherwise = (kw, snd . typeVarBindingRange $ last vars)
+
+classFundepRange :: ClassFundep -> TokenRange
+classFundepRange = \case
+ FundepDetermined arr bs -> (arr, nameTok $ NE.last bs)
+ FundepDetermines as _ bs -> (nameTok $ NE.head as, nameTok $ NE.last bs)
+
+instanceRange :: Instance a -> TokenRange
+instanceRange (Instance hd bd)
+ | Just (_, ts) <- bd = (fst start, snd . instanceBindingRange $ NE.last ts)
+ | otherwise = start
+ where start = instanceHeadRange hd
+
+instanceHeadRange :: InstanceHead a -> TokenRange
+instanceHeadRange (InstanceHead kw _ _ _ cls types)
+ | [] <- types = (kw, qualTok cls)
+ | otherwise = (kw, snd . typeRange $ last types)
+
+instanceBindingRange :: InstanceBinding a -> TokenRange
+instanceBindingRange = \case
+ InstanceBindingSignature _ (Labeled a _ b) -> (nameTok a, snd $ typeRange b)
+ InstanceBindingName _ a -> valueBindingFieldsRange a
+
+foreignRange :: Foreign a -> TokenRange
+foreignRange = \case
+ ForeignValue (Labeled a _ b) -> (nameTok a, snd $ typeRange b)
+ ForeignData a (Labeled _ _ b) -> (a, snd $ kindRange b)
+ ForeignKind a b -> (a, nameTok b)
+
+valueBindingFieldsRange :: ValueBindingFields a -> TokenRange
+valueBindingFieldsRange (ValueBindingFields a _ b) = (nameTok a, snd $ guardedRange b)
+
+guardedRange :: Guarded a -> TokenRange
+guardedRange = \case
+ Unconditional a b -> (a, snd $ whereRange b)
+ Guarded as -> (fst . guardedExprRange $ NE.head as, snd . guardedExprRange $ NE.last as)
+
+guardedExprRange :: GuardedExpr a -> TokenRange
+guardedExprRange (GuardedExpr a _ _ b) = (a, snd $ whereRange b)
+
+whereRange :: Where a -> TokenRange
+whereRange (Where a bs)
+ | Just (_, ls) <- bs = (fst $ exprRange a, snd . letBindingRange $ NE.last ls)
+ | otherwise = exprRange a
+
+kindRange :: Kind a -> TokenRange
+kindRange = \case
+ KindName _ a -> qualRange a
+ KindArr _ a _ b -> (fst $ kindRange a, snd $ kindRange b)
+ KindRow _ a b -> (a, snd $ kindRange b)
+ KindParens _ a -> wrappedRange a
+
+typeRange :: Type a -> TokenRange
+typeRange = \case
+ TypeVar _ a -> nameRange a
+ TypeConstructor _ a -> qualRange a
+ TypeWildcard _ a -> (a, a)
+ TypeHole _ a -> nameRange a
+ TypeString _ a _ -> (a, a)
+ TypeRow _ a -> wrappedRange a
+ TypeRecord _ a -> wrappedRange a
+ TypeForall _ a _ _ b -> (a, snd $ typeRange b)
+ TypeKinded _ a _ b -> (fst $ typeRange a, snd $ kindRange b)
+ TypeApp _ a b -> (fst $ typeRange a, snd $ typeRange b)
+ TypeOp _ a _ b -> (fst $ typeRange a, snd $ typeRange b)
+ TypeOpName _ a -> qualRange a
+ TypeArr _ a _ b -> (fst $ typeRange a, snd $ typeRange b)
+ TypeArrName _ a -> (a, a)
+ TypeConstrained _ a _ b -> (fst $ constraintRange a, snd $ typeRange b)
+ TypeParens _ a -> wrappedRange a
+
+constraintRange :: Constraint a -> TokenRange
+constraintRange = \case
+ Constraint _ name args
+ | [] <- args -> qualRange name
+ | otherwise -> (qualTok name, snd . typeRange $ last args)
+ ConstraintParens _ wrp -> wrappedRange wrp
+
+typeVarBindingRange :: TypeVarBinding a -> TokenRange
+typeVarBindingRange = \case
+ TypeVarKinded a -> wrappedRange a
+ TypeVarName a -> nameRange a
+
+exprRange :: Expr a -> TokenRange
+exprRange = \case
+ ExprHole _ a -> nameRange a
+ ExprSection _ a -> (a, a)
+ ExprIdent _ a -> qualRange a
+ ExprConstructor _ a -> qualRange a
+ ExprBoolean _ a _ -> (a, a)
+ ExprChar _ a _ -> (a, a)
+ ExprString _ a _ -> (a, a)
+ ExprNumber _ a _ -> (a, a)
+ ExprArray _ a -> wrappedRange a
+ ExprRecord _ a -> wrappedRange a
+ ExprParens _ a -> wrappedRange a
+ ExprTyped _ a _ b -> (fst $ exprRange a, snd $ typeRange b)
+ ExprInfix _ a _ b -> (fst $ exprRange a, snd $ exprRange b)
+ ExprOp _ a _ b -> (fst $ exprRange a, snd $ exprRange b)
+ ExprOpName _ a -> qualRange a
+ ExprNegate _ a b -> (a, snd $ exprRange b)
+ ExprRecordAccessor _ (RecordAccessor a _ b) -> (fst $ exprRange a, lblTok $ sepLast b)
+ ExprRecordUpdate _ a b -> (fst $ exprRange a, snd $ wrappedRange b)
+ ExprApp _ a b -> (fst $ exprRange a, snd $ exprRange b)
+ ExprLambda _ (Lambda a _ _ b) -> (a, snd $ exprRange b)
+ ExprIf _ (IfThenElse a _ _ _ _ b) -> (a, snd $ exprRange b)
+ ExprCase _ (CaseOf a _ _ c) -> (a, snd . guardedRange . snd $ NE.last c)
+ ExprLet _ (LetIn a _ _ b) -> (a, snd $ exprRange b)
+ ExprDo _ (DoBlock a b) -> (a, snd . doStatementRange $ NE.last b)
+ ExprAdo _ (AdoBlock a _ _ b) -> (a, snd $ exprRange b)
+
+letBindingRange :: LetBinding a -> TokenRange
+letBindingRange = \case
+ LetBindingSignature _ (Labeled a _ b) -> (nameTok a, snd $ typeRange b)
+ LetBindingName _ a -> valueBindingFieldsRange a
+ LetBindingPattern _ a _ b -> (fst $ binderRange a, snd $ whereRange b)
+
+doStatementRange :: DoStatement a -> TokenRange
+doStatementRange = \case
+ DoLet a bs -> (a, snd . letBindingRange $ NE.last bs)
+ DoDiscard a -> exprRange a
+ DoBind a _ b -> (fst $ binderRange a, snd $ exprRange b)
+
+binderRange :: Binder a -> TokenRange
+binderRange = \case
+ BinderWildcard _ a -> (a, a)
+ BinderVar _ a -> nameRange a
+ BinderNamed _ a _ b -> (nameTok a, snd $ binderRange b)
+ BinderConstructor _ a bs
+ | [] <- bs -> qualRange a
+ | otherwise -> (qualTok a, snd . binderRange $ last bs)
+ BinderBoolean _ a _ -> (a, a)
+ BinderChar _ a _ -> (a, a)
+ BinderString _ a _ -> (a, a)
+ BinderNumber _ a b _
+ | Just a' <- a -> (a', b)
+ | otherwise -> (b, b)
+ BinderArray _ a -> wrappedRange a
+ BinderRecord _ a -> wrappedRange a
+ BinderParens _ a -> wrappedRange a
+ BinderTyped _ a _ b -> (fst $ binderRange a, snd $ typeRange b)
+ BinderOp _ a _ b -> (fst $ binderRange a, snd $ binderRange b)
+
+recordUpdateRange :: RecordUpdate a -> TokenRange
+recordUpdateRange = \case
+ RecordUpdateLeaf a _ b -> (lblTok a, snd $ exprRange b)
+ RecordUpdateBranch a (Wrapped _ _ b) -> (lblTok a, b)
+
+recordLabeledExprRange :: RecordLabeled (Expr a) -> TokenRange
+recordLabeledExprRange = \case
+ RecordPun a -> nameRange a
+ RecordField a _ b -> (fst $ labelRange a, snd $ exprRange b)
diff --git a/src/Language/PureScript/CST/Print.hs b/src/Language/PureScript/CST/Print.hs
new file mode 100644
index 0000000..16aac58
--- /dev/null
+++ b/src/Language/PureScript/CST/Print.hs
@@ -0,0 +1,82 @@
+-- | This is just a simple token printer. It's not a full fledged formatter, but
+-- it is used by the layout golden tests. Printing each token in the tree with
+-- this printer will result in the exact input that was given to the lexer.
+
+module Language.PureScript.CST.Print
+ ( printToken
+ , printTokens
+ , printLeadingComment
+ , printTrailingComment
+ ) where
+
+import Prelude
+
+import Data.Text (Text)
+import qualified Data.Text as Text
+import Language.PureScript.CST.Types
+
+printToken :: Token -> Text
+printToken = \case
+ TokLeftParen -> "("
+ TokRightParen -> ")"
+ TokLeftBrace -> "{"
+ TokRightBrace -> "}"
+ TokLeftSquare -> "["
+ TokRightSquare -> "]"
+ TokLeftArrow ASCII -> "<-"
+ TokLeftArrow Unicode -> "←"
+ TokRightArrow ASCII -> "->"
+ TokRightArrow Unicode -> "→"
+ TokRightFatArrow ASCII -> "=>"
+ TokRightFatArrow Unicode -> "⇒"
+ TokDoubleColon ASCII -> "::"
+ TokDoubleColon Unicode -> "∷"
+ TokForall ASCII -> "forall"
+ TokForall Unicode -> "∀"
+ TokEquals -> "="
+ TokPipe -> "|"
+ TokTick -> "`"
+ TokDot -> "."
+ TokComma -> ","
+ TokUnderscore -> "_"
+ TokBackslash -> "\\"
+ TokLowerName qual name -> printQual qual <> name
+ TokUpperName qual name -> printQual qual <> name
+ TokOperator qual sym -> printQual qual <> sym
+ TokSymbolName qual sym -> printQual qual <> "(" <> sym <> ")"
+ TokSymbolArr Unicode -> "(→)"
+ TokSymbolArr ASCII -> "(->)"
+ TokHole hole -> "?" <> hole
+ TokChar raw _ -> "'" <> raw <> "'"
+ TokString raw _ -> "\"" <> raw <> "\""
+ TokRawString raw -> "\"\"\"" <> raw <> "\"\"\""
+ TokInt raw _ -> raw
+ TokNumber raw _ -> raw
+ TokLayoutStart -> "{"
+ TokLayoutSep -> ";"
+ TokLayoutEnd -> "}"
+ TokEof -> "<eof>"
+
+printQual :: [Text] -> Text
+printQual = Text.concat . map (<> ".")
+
+printTokens :: [SourceToken] -> Text
+printTokens toks = Text.concat (map pp toks)
+ where
+ pp (SourceToken (TokenAnn _ leading trailing) tok) =
+ Text.concat (map printLeadingComment leading)
+ <> printToken tok
+ <> Text.concat (map printTrailingComment trailing)
+
+printLeadingComment :: Comment LineFeed -> Text
+printLeadingComment = \case
+ Comment raw -> raw
+ Space n -> Text.replicate n " "
+ Line LF -> "\n"
+ Line CRLF -> "\r\n"
+
+printTrailingComment :: Comment void -> Text
+printTrailingComment = \case
+ Comment raw -> raw
+ Space n -> Text.replicate n " "
+ Line _ -> ""
diff --git a/src/Language/PureScript/CST/Traversals.hs b/src/Language/PureScript/CST/Traversals.hs
new file mode 100644
index 0000000..6d5627f
--- /dev/null
+++ b/src/Language/PureScript/CST/Traversals.hs
@@ -0,0 +1,11 @@
+module Language.PureScript.CST.Traversals where
+
+import Prelude
+
+import Language.PureScript.CST.Types
+
+everythingOnSeparated :: (r -> r -> r) -> (a -> r) -> Separated a -> r
+everythingOnSeparated op k (Separated hd tl) = go hd tl
+ where
+ go a [] = k a
+ go a (b : bs) = k a `op` go (snd b) bs
diff --git a/src/Language/PureScript/CST/Traversals/Type.hs b/src/Language/PureScript/CST/Traversals/Type.hs
new file mode 100644
index 0000000..9e84718
--- /dev/null
+++ b/src/Language/PureScript/CST/Traversals/Type.hs
@@ -0,0 +1,39 @@
+module Language.PureScript.CST.Traversals.Type where
+
+import Prelude
+
+import Language.PureScript.CST.Types
+import Language.PureScript.CST.Traversals
+
+everythingOnTypes :: (r -> r -> r) -> (Type a -> r) -> Type a -> r
+everythingOnTypes op k = goTy
+ where
+ goTy ty = case ty of
+ TypeVar _ _ -> k ty
+ TypeConstructor _ _ -> k ty
+ TypeWildcard _ _ -> k ty
+ TypeHole _ _ -> k ty
+ TypeString _ _ _ -> k ty
+ TypeRow _ (Wrapped _ row _) -> goRow ty row
+ TypeRecord _ (Wrapped _ row _) -> goRow ty row
+ TypeForall _ _ _ _ ty2 -> k ty `op` goTy ty2
+ TypeKinded _ ty2 _ _ -> k ty `op` goTy ty2
+ TypeApp _ ty2 ty3 -> k ty `op` (goTy ty2 `op` goTy ty3)
+ TypeOp _ ty2 _ ty3 -> k ty `op` (goTy ty2 `op` goTy ty3)
+ TypeOpName _ _ -> k ty
+ TypeArr _ ty2 _ ty3 -> k ty `op` (goTy ty2 `op` goTy ty3)
+ TypeArrName _ _ -> k ty
+ TypeConstrained _ (constraintTys -> ty2) _ ty3
+ | null ty2 -> k ty `op` goTy ty3
+ | otherwise -> k ty `op` (foldr1 op (k <$> ty2) `op` goTy ty3)
+ TypeParens _ (Wrapped _ ty2 _) -> k ty `op` goTy ty2
+
+ goRow ty = \case
+ Row Nothing Nothing -> k ty
+ Row Nothing (Just (_, ty2)) -> k ty `op` goTy ty2
+ Row (Just lbls) Nothing -> k ty `op` everythingOnSeparated op (goTy . lblValue) lbls
+ Row (Just lbls) (Just (_, ty2)) -> k ty `op` (everythingOnSeparated op (goTy . lblValue) lbls `op` goTy ty2)
+
+ constraintTys = \case
+ Constraint _ _ tys -> tys
+ ConstraintParens _ (Wrapped _ c _) -> constraintTys c
diff --git a/src/Language/PureScript/CST/Types.hs b/src/Language/PureScript/CST/Types.hs
new file mode 100644
index 0000000..7768b96
--- /dev/null
+++ b/src/Language/PureScript/CST/Types.hs
@@ -0,0 +1,437 @@
+-- | This module contains data types for the entire PureScript surface language. Every
+-- token is represented in the tree, and every token is annotated with
+-- whitespace and comments (both leading and trailing). This means one can write
+-- an exact printer so that `print . parse = id`. Every constructor is laid out
+-- with tokens in left-to-right order. The core productions are given a slot for
+-- arbitrary annotations, however this is not used by the parser.
+
+module Language.PureScript.CST.Types where
+
+import Prelude
+
+import Data.List.NonEmpty (NonEmpty)
+import Data.Text (Text)
+import Data.Void (Void)
+import GHC.Generics (Generic)
+import qualified Language.PureScript.Names as N
+import Language.PureScript.PSString (PSString)
+
+data SourcePos = SourcePos
+ { srcLine :: {-# UNPACK #-} !Int
+ , srcColumn :: {-# UNPACK #-} !Int
+ } deriving (Show, Eq, Ord, Generic)
+
+data SourceRange = SourceRange
+ { srcStart :: !SourcePos
+ , srcEnd :: !SourcePos
+ } deriving (Show, Eq, Ord, Generic)
+
+data Comment l
+ = Comment !Text
+ | Space {-# UNPACK #-} !Int
+ | Line !l
+ deriving (Show, Eq, Ord, Generic, Functor)
+
+data LineFeed = LF | CRLF
+ deriving (Show, Eq, Ord, Generic)
+
+data TokenAnn = TokenAnn
+ { tokRange :: !SourceRange
+ , tokLeadingComments :: ![Comment LineFeed]
+ , tokTrailingComments :: ![Comment Void]
+ } deriving (Show, Eq, Ord, Generic)
+
+data SourceStyle = ASCII | Unicode
+ deriving (Show, Eq, Ord, Generic)
+
+data Token
+ = TokLeftParen
+ | TokRightParen
+ | TokLeftBrace
+ | TokRightBrace
+ | TokLeftSquare
+ | TokRightSquare
+ | TokLeftArrow !SourceStyle
+ | TokRightArrow !SourceStyle
+ | TokRightFatArrow !SourceStyle
+ | TokDoubleColon !SourceStyle
+ | TokForall !SourceStyle
+ | TokEquals
+ | TokPipe
+ | TokTick
+ | TokDot
+ | TokComma
+ | TokUnderscore
+ | TokBackslash
+ | TokLowerName ![Text] !Text
+ | TokUpperName ![Text] !Text
+ | TokOperator ![Text] !Text
+ | TokSymbolName ![Text] !Text
+ | TokSymbolArr !SourceStyle
+ | TokHole !Text
+ | TokChar !Text !Char
+ | TokString !Text !PSString
+ | TokRawString !Text
+ | TokInt !Text !Integer
+ | TokNumber !Text !Double
+ | TokLayoutStart
+ | TokLayoutSep
+ | TokLayoutEnd
+ | TokEof
+ deriving (Show, Eq, Ord, Generic)
+
+data SourceToken = SourceToken
+ { tokAnn :: !TokenAnn
+ , tokValue :: !Token
+ } deriving (Show, Eq, Ord, Generic)
+
+data Ident = Ident
+ { getIdent :: Text
+ } deriving (Show, Eq, Ord, Generic)
+
+data Name a = Name
+ { nameTok :: SourceToken
+ , nameValue :: a
+ } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+
+data QualifiedName a = QualifiedName
+ { qualTok :: SourceToken
+ , qualModule :: Maybe N.ModuleName
+ , qualName :: a
+ } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+
+data Label = Label
+ { lblTok :: SourceToken
+ , lblName :: PSString
+ } deriving (Show, Eq, Ord, Generic)
+
+data Wrapped a = Wrapped
+ { wrpOpen :: SourceToken
+ , wrpValue :: a
+ , wrpClose :: SourceToken
+ } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+
+data Separated a = Separated
+ { sepHead :: a
+ , sepTail :: [(SourceToken, a)]
+ } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+
+data Labeled a b = Labeled
+ { lblLabel :: a
+ , lblSep :: SourceToken
+ , lblValue :: b
+ } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+
+type Delimited a = Wrapped (Maybe (Separated a))
+type DelimitedNonEmpty a = Wrapped (Separated a)
+
+data OneOrDelimited a
+ = One a
+ | Many (DelimitedNonEmpty a)
+ deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+
+data Kind a
+ = KindName a (QualifiedName (N.ProperName 'N.KindName))
+ | KindArr a (Kind a) SourceToken (Kind a)
+ | KindRow a SourceToken (Kind a)
+ | KindParens a (Wrapped (Kind a))
+ deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+
+data Type a
+ = TypeVar a (Name Ident)
+ | TypeConstructor a (QualifiedName (N.ProperName 'N.TypeName))
+ | TypeWildcard a SourceToken
+ | TypeHole a (Name Ident)
+ | TypeString a SourceToken PSString
+ | TypeRow a (Wrapped (Row a))
+ | TypeRecord a (Wrapped (Row a))
+ | TypeForall a SourceToken (NonEmpty (TypeVarBinding a)) SourceToken (Type a)
+ | TypeKinded a (Type a) SourceToken (Kind a)
+ | TypeApp a (Type a) (Type a)
+ | TypeOp a (Type a) (QualifiedName (N.OpName 'N.TypeOpName)) (Type a)
+ | TypeOpName a (QualifiedName (N.OpName 'N.TypeOpName))
+ | TypeArr a (Type a) SourceToken (Type a)
+ | TypeArrName a SourceToken
+ | TypeConstrained a (Constraint a) SourceToken (Type a)
+ | TypeParens a (Wrapped (Type a))
+ deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+
+data TypeVarBinding a
+ = TypeVarKinded (Wrapped (Labeled (Name Ident) (Kind a)))
+ | TypeVarName (Name Ident)
+ deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+
+data Constraint a
+ = Constraint a (QualifiedName (N.ProperName 'N.ClassName)) [Type a]
+ | ConstraintParens a (Wrapped (Constraint a))
+ deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+
+data Row a = Row
+ { rowLabels :: Maybe (Separated (Labeled Label (Type a)))
+ , rowTail :: Maybe (SourceToken, Type a)
+ } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+
+data Module a = Module
+ { modAnn :: a
+ , modKeyword :: SourceToken
+ , modNamespace :: Name N.ModuleName
+ , modExports :: Maybe (DelimitedNonEmpty (Export a))
+ , modWhere :: SourceToken
+ , modImports :: [ImportDecl a]
+ , modDecls :: [Declaration a]
+ , modTrailingComments :: [Comment LineFeed]
+ } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+
+data Export a
+ = ExportValue a (Name Ident)
+ | ExportOp a (Name (N.OpName 'N.ValueOpName))
+ | ExportType a (Name (N.ProperName 'N.TypeName)) (Maybe (DataMembers a))
+ | ExportTypeOp a SourceToken (Name (N.OpName 'N.TypeOpName))
+ | ExportClass a SourceToken (Name (N.ProperName 'N.ClassName))
+ | ExportKind a SourceToken (Name (N.ProperName 'N.KindName))
+ | ExportModule a SourceToken (Name N.ModuleName)
+ deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+
+data DataMembers a
+ = DataAll a SourceToken
+ | DataEnumerated a (Delimited (Name (N.ProperName 'N.ConstructorName)))
+ deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+
+data Declaration a
+ = DeclData a (DataHead a) (Maybe (SourceToken, Separated (DataCtor a)))
+ | DeclType a (DataHead a) SourceToken (Type a)
+ | DeclNewtype a (DataHead a) SourceToken (Name (N.ProperName 'N.ConstructorName)) (Type a)
+ | DeclClass a (ClassHead a) (Maybe (SourceToken, NonEmpty (Labeled (Name Ident) (Type a))))
+ | DeclInstanceChain a (Separated (Instance a))
+ | DeclDerive a SourceToken (Maybe SourceToken) (InstanceHead a)
+ | DeclSignature a (Labeled (Name Ident) (Type a))
+ | DeclValue a (ValueBindingFields a)
+ | DeclFixity a FixityFields
+ | DeclForeign a SourceToken SourceToken (Foreign a)
+ deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+
+data Instance a = Instance
+ { instHead :: InstanceHead a
+ , instBody :: Maybe (SourceToken, NonEmpty (InstanceBinding a))
+ } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+
+data InstanceBinding a
+ = InstanceBindingSignature a (Labeled (Name Ident) (Type a))
+ | InstanceBindingName a (ValueBindingFields a)
+ deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+
+data ImportDecl a = ImportDecl
+ { impAnn :: a
+ , impKeyword :: SourceToken
+ , impModule :: Name N.ModuleName
+ , impNames :: Maybe (Maybe SourceToken, DelimitedNonEmpty (Import a))
+ , impQual :: Maybe (SourceToken, Name N.ModuleName)
+ } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+
+data Import a
+ = ImportValue a (Name Ident)
+ | ImportOp a (Name (N.OpName 'N.ValueOpName))
+ | ImportType a (Name (N.ProperName 'N.TypeName)) (Maybe (DataMembers a))
+ | ImportTypeOp a SourceToken (Name (N.OpName 'N.TypeOpName))
+ | ImportClass a SourceToken (Name (N.ProperName 'N.ClassName))
+ | ImportKind a SourceToken (Name (N.ProperName 'N.KindName))
+ deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+
+data DataHead a = DataHead
+ { dataHdKeyword :: SourceToken
+ , dataHdName :: Name (N.ProperName 'N.TypeName)
+ , dataHdVars :: [TypeVarBinding a]
+ } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+
+data DataCtor a = DataCtor
+ { dataCtorAnn :: a
+ , dataCtorName :: Name (N.ProperName 'N.ConstructorName)
+ , dataCtorFields :: [Type a]
+ } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+
+data ClassHead a = ClassHead
+ { clsKeyword :: SourceToken
+ , clsSuper :: Maybe (OneOrDelimited (Constraint a), SourceToken)
+ , clsName :: Name (N.ProperName 'N.ClassName)
+ , clsVars :: [TypeVarBinding a]
+ , clsFundeps :: Maybe (SourceToken, Separated ClassFundep)
+ } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+
+data ClassFundep
+ = FundepDetermined SourceToken (NonEmpty (Name Ident))
+ | FundepDetermines (NonEmpty (Name Ident)) SourceToken (NonEmpty (Name Ident))
+ deriving (Show, Eq, Ord, Generic)
+
+data InstanceHead a = InstanceHead
+ { instKeyword :: SourceToken
+ , instName :: Name Ident
+ , instSep :: SourceToken
+ , instConstraints :: Maybe (OneOrDelimited (Constraint a), SourceToken)
+ , instClass :: QualifiedName (N.ProperName 'N.ClassName)
+ , instTypes :: [Type a]
+ } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+
+data Fixity
+ = Infix
+ | Infixl
+ | Infixr
+ deriving (Show, Eq, Ord, Generic)
+
+data FixityOp
+ = FixityValue (QualifiedName (Either Ident (N.ProperName 'N.ConstructorName))) SourceToken (Name (N.OpName 'N.ValueOpName))
+ | FixityType SourceToken (QualifiedName (N.ProperName 'N.TypeName)) SourceToken (Name (N.OpName 'N.TypeOpName))
+ deriving (Show, Eq, Ord, Generic)
+
+data FixityFields = FixityFields
+ { fxtKeyword :: (SourceToken, Fixity)
+ , fxtPrec :: (SourceToken, Integer)
+ , fxtOp :: FixityOp
+ } deriving (Show, Eq, Ord, Generic)
+
+data ValueBindingFields a = ValueBindingFields
+ { valName :: Name Ident
+ , valBinders :: [Binder a]
+ , valGuarded :: Guarded a
+ } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+
+data Guarded a
+ = Unconditional SourceToken (Where a)
+ | Guarded (NonEmpty (GuardedExpr a))
+ deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+
+data GuardedExpr a = GuardedExpr
+ { grdBar :: SourceToken
+ , grdPatterns :: Separated (PatternGuard a)
+ , grdSep :: SourceToken
+ , grdWhere :: Where a
+ } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+
+data PatternGuard a = PatternGuard
+ { patBinder :: Maybe (Binder a, SourceToken)
+ , patExpr :: Expr a
+ } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+
+data Foreign a
+ = ForeignValue (Labeled (Name Ident) (Type a))
+ | ForeignData SourceToken (Labeled (Name (N.ProperName 'N.TypeName)) (Kind a))
+ | ForeignKind SourceToken (Name (N.ProperName 'N.KindName))
+ deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+
+data Expr a
+ = ExprHole a (Name Ident)
+ | ExprSection a SourceToken
+ | ExprIdent a (QualifiedName Ident)
+ | ExprConstructor a (QualifiedName (N.ProperName 'N.ConstructorName))
+ | ExprBoolean a SourceToken Bool
+ | ExprChar a SourceToken Char
+ | ExprString a SourceToken PSString
+ | ExprNumber a SourceToken (Either Integer Double)
+ | ExprArray a (Delimited (Expr a))
+ | ExprRecord a (Delimited (RecordLabeled (Expr a)))
+ | ExprParens a (Wrapped (Expr a))
+ | ExprTyped a (Expr a) SourceToken (Type a)
+ | ExprInfix a (Expr a) (Wrapped (Expr a)) (Expr a)
+ | ExprOp a (Expr a) (QualifiedName (N.OpName 'N.ValueOpName)) (Expr a)
+ | ExprOpName a (QualifiedName (N.OpName 'N.ValueOpName))
+ | ExprNegate a SourceToken (Expr a)
+ | ExprRecordAccessor a (RecordAccessor a)
+ | ExprRecordUpdate a (Expr a) (DelimitedNonEmpty (RecordUpdate a))
+ | ExprApp a (Expr a) (Expr a)
+ | ExprLambda a (Lambda a)
+ | ExprIf a (IfThenElse a)
+ | ExprCase a (CaseOf a)
+ | ExprLet a (LetIn a)
+ | ExprDo a (DoBlock a)
+ | ExprAdo a (AdoBlock a)
+ deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+
+data RecordLabeled a
+ = RecordPun (Name Ident)
+ | RecordField Label SourceToken a
+ deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+
+data RecordUpdate a
+ = RecordUpdateLeaf Label SourceToken (Expr a)
+ | RecordUpdateBranch Label (DelimitedNonEmpty (RecordUpdate a))
+ deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+
+data RecordAccessor a = RecordAccessor
+ { recExpr :: Expr a
+ , recDot :: SourceToken
+ , recPath :: Separated Label
+ } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+
+data Lambda a = Lambda
+ { lmbSymbol :: SourceToken
+ , lmbBinders :: NonEmpty (Binder a)
+ , lmbArr :: SourceToken
+ , lmbBody :: Expr a
+ } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+
+data IfThenElse a = IfThenElse
+ { iteIf :: SourceToken
+ , iteCond :: Expr a
+ , iteThen :: SourceToken
+ , iteTrue :: Expr a
+ , iteElse :: SourceToken
+ , iteFalse :: Expr a
+ } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+
+data CaseOf a = CaseOf
+ { caseKeyword :: SourceToken
+ , caseHead :: Separated (Expr a)
+ , caseOf :: SourceToken
+ , caseBranches :: NonEmpty (Separated (Binder a), Guarded a)
+ } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+
+data LetIn a = LetIn
+ { letKeyword :: SourceToken
+ , letBindings :: NonEmpty (LetBinding a)
+ , letIn :: SourceToken
+ , letBody :: Expr a
+ } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+
+data Where a = Where
+ { whereExpr :: Expr a
+ , whereBindings :: Maybe (SourceToken, NonEmpty (LetBinding a))
+ } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+
+data LetBinding a
+ = LetBindingSignature a (Labeled (Name Ident) (Type a))
+ | LetBindingName a (ValueBindingFields a)
+ | LetBindingPattern a (Binder a) SourceToken (Where a)
+ deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+
+data DoBlock a = DoBlock
+ { doKeyword :: SourceToken
+ , doStatements :: NonEmpty (DoStatement a)
+ } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+
+data DoStatement a
+ = DoLet SourceToken (NonEmpty (LetBinding a))
+ | DoDiscard (Expr a)
+ | DoBind (Binder a) SourceToken (Expr a)
+ deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+
+data AdoBlock a = AdoBlock
+ { adoKeyword :: SourceToken
+ , adoStatements :: [DoStatement a]
+ , adoIn :: SourceToken
+ , adoResult :: Expr a
+ } deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
+
+data Binder a
+ = BinderWildcard a SourceToken
+ | BinderVar a (Name Ident)
+ | BinderNamed a (Name Ident) SourceToken (Binder a)
+ | BinderConstructor a (QualifiedName (N.ProperName 'N.ConstructorName)) [Binder a]
+ | BinderBoolean a SourceToken Bool
+ | BinderChar a SourceToken Char
+ | BinderString a SourceToken PSString
+ | BinderNumber a (Maybe SourceToken) SourceToken (Either Integer Double)
+ | BinderArray a (Delimited (Binder a))
+ | BinderRecord a (Delimited (RecordLabeled (Binder a)))
+ | BinderParens a (Wrapped (Binder a))
+ | BinderTyped a (Binder a) SourceToken (Type a)
+ | BinderOp a (Binder a) (QualifiedName (N.OpName 'N.ValueOpName)) (Binder a)
+ deriving (Show, Eq, Ord, Functor, Foldable, Traversable, Generic)
diff --git a/src/Language/PureScript/CST/Utils.hs b/src/Language/PureScript/CST/Utils.hs
new file mode 100644
index 0000000..656de23
--- /dev/null
+++ b/src/Language/PureScript/CST/Utils.hs
@@ -0,0 +1,313 @@
+{-# LANGUAGE MonoLocalBinds #-}
+module Language.PureScript.CST.Utils where
+
+import Prelude
+
+import Control.Monad (when)
+import Data.Coerce (coerce)
+import Data.Foldable (for_)
+import Data.Functor (($>))
+import qualified Data.List.NonEmpty as NE
+import Data.Set (Set)
+import qualified Data.Set as Set
+import Data.Text (Text)
+import qualified Data.Text as Text
+import Language.PureScript.CST.Errors
+import Language.PureScript.CST.Monad
+import Language.PureScript.CST.Positions
+import Language.PureScript.CST.Traversals.Type
+import Language.PureScript.CST.Types
+import qualified Language.PureScript.Names as N
+import Language.PureScript.PSString (PSString, mkString)
+
+placeholder :: SourceToken
+placeholder = SourceToken
+ { tokAnn = TokenAnn (SourceRange (SourcePos 0 0) (SourcePos 0 0)) [] []
+ , tokValue = TokLowerName [] "<placeholder>"
+ }
+
+unexpectedName :: SourceToken -> Name Ident
+unexpectedName tok = Name tok (Ident "<unexpected>")
+
+unexpectedQual :: SourceToken -> QualifiedName Ident
+unexpectedQual tok = QualifiedName tok Nothing (Ident "<unexpected>")
+
+unexpectedLabel :: SourceToken -> Label
+unexpectedLabel tok = Label tok "<unexpected>"
+
+unexpectedExpr :: Monoid a => [SourceToken] -> Expr a
+unexpectedExpr toks = ExprIdent mempty (unexpectedQual (head toks))
+
+unexpectedDecl :: Monoid a => [SourceToken] -> Declaration a
+unexpectedDecl toks = DeclValue mempty (ValueBindingFields (unexpectedName (head toks)) [] (error "<unexpected"))
+
+unexpectedBinder :: Monoid a => [SourceToken] -> Binder a
+unexpectedBinder toks = BinderVar mempty (unexpectedName (head toks))
+
+unexpectedLetBinding :: Monoid a => [SourceToken] -> LetBinding a
+unexpectedLetBinding toks = LetBindingName mempty (ValueBindingFields (unexpectedName (head toks)) [] (error "<unexpected>"))
+
+unexpectedInstBinding :: Monoid a => [SourceToken] -> InstanceBinding a
+unexpectedInstBinding toks = InstanceBindingName mempty (ValueBindingFields (unexpectedName (head toks)) [] (error "<unexpected>"))
+
+unexpectedRecordUpdate :: Monoid a => [SourceToken] -> RecordUpdate a
+unexpectedRecordUpdate toks = RecordUpdateLeaf (unexpectedLabel (head toks)) (head toks) (unexpectedExpr toks)
+
+unexpectedRecordLabeled :: [SourceToken] -> RecordLabeled a
+unexpectedRecordLabeled toks = RecordPun (unexpectedName (head toks))
+
+rangeToks :: TokenRange -> [SourceToken]
+rangeToks (a, b) = [a, b]
+
+unexpectedToks :: (a -> TokenRange) -> ([SourceToken] -> b) -> ParserErrorType -> (a -> Parser b)
+unexpectedToks toRange toCst err old = do
+ let toks = rangeToks $ toRange old
+ addFailure toks err
+ pure $ toCst toks
+
+separated :: [(SourceToken, a)] -> Separated a
+separated = go []
+ where
+ go accum ((_, a) : []) = Separated a accum
+ go accum (x : xs) = go (x : accum) xs
+ go _ [] = internalError "Separated should not be empty"
+
+consSeparated :: a -> SourceToken -> Separated a -> Separated a
+consSeparated x sep (Separated {..}) = Separated x ((sep, sepHead) : sepTail)
+
+internalError :: String -> a
+internalError = error . ("Internal parser error: " <>)
+
+toModuleName :: SourceToken -> [Text] -> Parser (Maybe N.ModuleName)
+toModuleName _ [] = pure Nothing
+toModuleName tok ns = do
+ when (not (all isValidModuleNamespace ns)) $ addFailure [tok] ErrModuleName
+ pure . Just . N.ModuleName $ N.ProperName <$> ns
+
+upperToModuleName :: SourceToken -> Parser (Name N.ModuleName)
+upperToModuleName tok = case tokValue tok of
+ TokUpperName q a -> do
+ let ns = q <> [a]
+ when (not (all isValidModuleNamespace ns)) $ addFailure [tok] ErrModuleName
+ pure . Name tok . N.ModuleName $ N.ProperName <$> ns
+ _ -> internalError $ "Invalid upper name: " <> show tok
+
+toQualifiedName :: (Text -> a) -> SourceToken -> Parser (QualifiedName a)
+toQualifiedName k tok = case tokValue tok of
+ TokLowerName q a
+ | not (Set.member a reservedNames) -> flip (QualifiedName tok) (k a) <$> toModuleName tok q
+ | otherwise -> addFailure [tok] ErrKeywordVar $> QualifiedName tok Nothing (k "<unexpected>")
+ TokUpperName q a -> flip (QualifiedName tok) (k a) <$> toModuleName tok q
+ TokSymbolName q a -> flip (QualifiedName tok) (k a) <$> toModuleName tok q
+ TokOperator q a -> flip (QualifiedName tok) (k a) <$> toModuleName tok q
+ _ -> internalError $ "Invalid qualified name: " <> show tok
+
+toName :: (Text -> a) -> SourceToken -> Parser (Name a)
+toName k tok = case tokValue tok of
+ TokLowerName [] a
+ | not (Set.member a reservedNames) -> pure $ Name tok (k a)
+ | otherwise -> addFailure [tok] ErrKeywordVar $> Name tok (k "<unexpected>")
+ TokUpperName [] a -> pure $ Name tok (k a)
+ TokSymbolName [] a -> pure $ Name tok (k a)
+ TokOperator [] a -> pure $ Name tok (k a)
+ TokHole a -> pure $ Name tok (k a)
+ _ -> internalError $ "Invalid name: " <> show tok
+
+toLabel :: SourceToken -> Label
+toLabel tok = case tokValue tok of
+ TokLowerName [] a -> Label tok $ mkString a
+ TokString _ a -> Label tok a
+ TokRawString a -> Label tok $ mkString a
+ TokForall ASCII -> Label tok $ mkString "forall"
+ _ -> internalError $ "Invalid label: " <> show tok
+
+labelToIdent :: Label -> Parser (Name Ident)
+labelToIdent (Label tok _) = toName Ident tok
+
+toString :: SourceToken -> (SourceToken, PSString)
+toString tok = case tokValue tok of
+ TokString _ a -> (tok, a)
+ TokRawString a -> (tok, mkString a)
+ _ -> internalError $ "Invalid string literal: " <> show tok
+
+toChar :: SourceToken -> (SourceToken, Char)
+toChar tok = case tokValue tok of
+ TokChar _ a -> (tok, a)
+ _ -> internalError $ "Invalid char literal: " <> show tok
+
+toNumber :: SourceToken -> (SourceToken, Either Integer Double)
+toNumber tok = case tokValue tok of
+ TokInt _ a -> (tok, Left a)
+ TokNumber _ a -> (tok, Right a)
+ _ -> internalError $ "Invalid number literal: " <> show tok
+
+toInt :: SourceToken -> (SourceToken, Integer)
+toInt tok = case tokValue tok of
+ TokInt _ a -> (tok, a)
+ _ -> internalError $ "Invalid integer literal: " <> show tok
+
+toBoolean :: SourceToken -> (SourceToken, Bool)
+toBoolean tok = case tokValue tok of
+ TokLowerName [] "true" -> (tok, True)
+ TokLowerName [] "false" -> (tok, False)
+ _ -> internalError $ "Invalid boolean literal: " <> show tok
+
+toConstraint :: forall a. Monoid a => Type a -> Parser (Constraint a)
+toConstraint = convertParens
+ where
+ convertParens :: Type a -> Parser (Constraint a)
+ convertParens = \case
+ TypeParens a (Wrapped b c d) -> do
+ c' <- convertParens c
+ pure $ ConstraintParens a (Wrapped b c' d)
+ ty -> convert mempty [] ty
+
+ convert :: a -> [Type a] -> Type a -> Parser (Constraint a)
+ convert ann acc = \case
+ TypeApp a lhs rhs -> convert (a <> ann) (rhs : acc) lhs
+ TypeConstructor a name -> do
+ for_ acc checkNoForalls
+ pure $ Constraint (a <> ann) (coerce name) acc
+ ty -> do
+ let (tok1, tok2) = typeRange ty
+ addFailure [tok1, tok2] ErrTypeInConstraint
+ pure $ Constraint mempty (QualifiedName tok1 Nothing (N.ProperName "<unexpected")) []
+
+toBinderConstructor :: Monoid a => NE.NonEmpty (Binder a) -> Parser (Binder a)
+toBinderConstructor = \case
+ BinderConstructor a name [] NE.:| bs ->
+ pure $ BinderConstructor a name bs
+ a NE.:| [] -> pure a
+ a NE.:| _ -> unexpectedToks binderRange (unexpectedBinder) ErrExprInBinder a
+
+toRecordFields
+ :: Monoid a
+ => Separated (Either (RecordLabeled (Expr a)) (RecordUpdate a))
+ -> Parser (Either (Separated (RecordLabeled (Expr a))) (Separated (RecordUpdate a)))
+toRecordFields = \case
+ Separated (Left a) as ->
+ Left . Separated a <$> traverse (traverse unLeft) as
+ Separated (Right a) as ->
+ Right . Separated a <$> traverse (traverse unRight) as
+ where
+ unLeft (Left tok) = pure tok
+ unLeft (Right tok) =
+ unexpectedToks recordUpdateRange unexpectedRecordLabeled ErrRecordUpdateInCtr tok
+
+ unRight (Right tok) = pure tok
+ unRight (Left (RecordPun (Name tok _))) = do
+ addFailure [tok] ErrRecordPunInUpdate
+ pure $ unexpectedRecordUpdate [tok]
+ unRight (Left (RecordField _ tok _)) = do
+ addFailure [tok] ErrRecordCtrInUpdate
+ pure $ unexpectedRecordUpdate [tok]
+
+checkFundeps :: ClassHead a -> Parser ()
+checkFundeps (ClassHead _ _ _ _ Nothing) = pure ()
+checkFundeps (ClassHead _ _ _ vars (Just (_, fundeps))) = do
+ let
+ k (TypeVarKinded (Wrapped _ (Labeled a _ _) _)) = getIdent $ nameValue a
+ k (TypeVarName a) = getIdent $ nameValue a
+ names = k <$> vars
+ check a
+ | getIdent (nameValue a) `elem` names = pure ()
+ | otherwise = addFailure [nameTok a] ErrUnknownFundep
+ for_ fundeps $ \case
+ FundepDetermined _ bs -> for_ bs check
+ FundepDetermines as _ bs -> do
+ for_ as check
+ for_ bs check
+
+data TmpModuleDecl a
+ = TmpImport (ImportDecl a)
+ | TmpChain (Separated (Declaration a))
+ deriving (Show)
+
+toModuleDecls :: Monoid a => [TmpModuleDecl a] -> Parser ([ImportDecl a], [Declaration a])
+toModuleDecls = goImport []
+ where
+ goImport acc (TmpImport x : xs) = goImport (x : acc) xs
+ goImport acc xs = (reverse acc,) <$> goDecl [] xs
+
+ goDecl acc [] = pure $ reverse acc
+ goDecl acc (TmpChain (Separated x []) : xs) = goDecl (x : acc) xs
+ goDecl acc (TmpChain (Separated (DeclInstanceChain a (Separated h t)) t') : xs) = do
+ (a', instances) <- goChain (getName h) a [] t'
+ goDecl (DeclInstanceChain a' (Separated h (t <> instances)) : acc) xs
+ goDecl acc (TmpChain (Separated _ t) : xs) = do
+ for_ t $ \(tok, _) -> addFailure [tok] ErrElseInDecl
+ goDecl acc xs
+ goDecl acc (TmpImport imp : xs) = do
+ unexpectedToks importDeclRange (const ()) ErrImportInDecl imp
+ goDecl acc xs
+
+ goChain _ ann acc [] = pure (ann, reverse acc)
+ goChain name ann acc ((tok, DeclInstanceChain a (Separated h t)) : xs)
+ | eqName (getName h) name = goChain name (ann <> a) (reverse ((tok, h) : t) <> acc) xs
+ | otherwise = do
+ addFailure [qualTok $ getName h] ErrInstanceNameMismatch
+ goChain name ann acc xs
+ goChain name ann acc ((tok, _) : xs) = do
+ addFailure [tok] ErrElseInDecl
+ goChain name ann acc xs
+
+ getName = instClass . instHead
+ eqName (QualifiedName _ a b) (QualifiedName _ c d) = a == c && b == d
+
+checkNoWildcards :: Type a -> Parser ()
+checkNoWildcards ty = do
+ let
+ k = \case
+ TypeWildcard _ a -> [addFailure [a] ErrWildcardInType]
+ TypeHole _ a -> [addFailure [nameTok a] ErrHoleInType]
+ _ -> []
+ sequence_ $ everythingOnTypes (<>) k ty
+
+checkNoForalls :: Type a -> Parser ()
+checkNoForalls ty = do
+ let
+ k = \case
+ TypeForall _ a _ _ _ -> [addFailure [a] ErrToken]
+ _ -> []
+ sequence_ $ everythingOnTypes (<>) k ty
+
+revert :: Parser a -> SourceToken -> Parser a
+revert p lk = pushBack lk *> p
+
+reservedNames :: Set Text
+reservedNames = Set.fromList
+ [ "ado"
+ , "case"
+ , "class"
+ , "data"
+ , "derive"
+ , "do"
+ , "else"
+ , "false"
+ , "forall"
+ , "foreign"
+ , "import"
+ , "if"
+ , "in"
+ , "infix"
+ , "infixl"
+ , "infixr"
+ , "instance"
+ , "let"
+ , "module"
+ , "newtype"
+ , "of"
+ , "true"
+ , "type"
+ , "where"
+ ]
+
+isValidModuleNamespace :: Text -> Bool
+isValidModuleNamespace = Text.null . snd . Text.span (\c -> c /= '_' && c /= '\'')
+
+-- | This is to keep the @Parser.y@ file ASCII, otherwise @happy@ will break
+-- in non-unicode locales.
+--
+-- Related GHC issue: https://gitlab.haskell.org/ghc/ghc/issues/8167
+isLeftFatArrow :: Text -> Bool
+isLeftFatArrow str = str == "<=" || str == "⇐"
diff --git a/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs b/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs
index 96001d3..4b627ab 100644
--- a/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs
+++ b/src/Language/PureScript/CoreImp/Optimizer/Inliner.hs
@@ -15,6 +15,7 @@ import Prelude.Compat
import Control.Monad.Supply.Class (MonadSupply, freshName)
+import Data.Either (rights)
import Data.Maybe (fromMaybe)
import Data.String (IsString, fromString)
import Data.Text (Text)
@@ -264,20 +265,36 @@ inlineFnComposition = everywhereTopDownM convert where
convert (App s1 (App s2 (App _ (App _ fn [dict']) [x]) [y]) [z])
| isFnCompose dict' fn = return $ App s1 x [App s2 y [z]]
| isFnComposeFlipped dict' fn = return $ App s2 y [App s1 x [z]]
- convert (App ss (App _ (App _ fn [dict']) [x]) [y])
- | isFnCompose dict' fn = do
- arg <- freshName
- return $ Function ss Nothing [arg] (Block ss [Return Nothing $ App Nothing x [App Nothing y [Var Nothing arg]]])
- | isFnComposeFlipped dict' fn = do
- arg <- freshName
- return $ Function ss Nothing [arg] (Block ss [Return Nothing $ App Nothing y [App Nothing x [Var Nothing arg]]])
+ convert app@(App ss (App _ (App _ fn [dict']) _) _)
+ | isFnCompose dict' fn || isFnComposeFlipped dict' fn = mkApps ss <$> goApps app <*> freshName
convert other = return other
+
+ mkApps :: Maybe SourceSpan -> [Either AST (Text, AST)] -> Text -> AST
+ mkApps ss fns a = App ss (Function ss Nothing [] (Block ss $ vars <> [Return Nothing comp])) []
+ where
+ vars = uncurry (VariableIntroduction ss) . fmap Just <$> rights fns
+ comp = Function ss Nothing [a] (Block ss [Return Nothing apps])
+ apps = foldr (\fn acc -> App ss (mkApp fn) [acc]) (Var ss a) fns
+
+ mkApp :: Either AST (Text, AST) -> AST
+ mkApp = either id $ \(name, arg) -> Var (getSourceSpan arg) name
+
+ goApps :: AST -> m [Either AST (Text, AST)]
+ goApps (App _ (App _ (App _ fn [dict']) [x]) [y])
+ | isFnCompose dict' fn = mappend <$> goApps x <*> goApps y
+ | isFnComposeFlipped dict' fn = mappend <$> goApps y <*> goApps x
+ goApps app@(App {}) = pure . Right . (,app) <$> freshName
+ goApps other = pure [Left other]
+
isFnCompose :: AST -> AST -> Bool
isFnCompose dict' fn = isDict semigroupoidFn dict' && isDict fnCompose fn
+
isFnComposeFlipped :: AST -> AST -> Bool
isFnComposeFlipped dict' fn = isDict semigroupoidFn dict' && isDict fnComposeFlipped fn
+
fnCompose :: forall a b. (IsString a, IsString b) => (a, b)
fnCompose = (C.controlSemigroupoid, C.compose)
+
fnComposeFlipped :: forall a b. (IsString a, IsString b) => (a, b)
fnComposeFlipped = (C.controlSemigroupoid, C.composeFlipped)
diff --git a/src/Language/PureScript/Crash.hs b/src/Language/PureScript/Crash.hs
index 1ce2f09..fe72169 100644
--- a/src/Language/PureScript/Crash.hs
+++ b/src/Language/PureScript/Crash.hs
@@ -24,4 +24,3 @@ internalError =
error
. ("An internal error occurred during compilation: " ++)
. (++ "\nPlease report this at https://github.com/purescript/purescript/issues")
- . show
diff --git a/src/Language/PureScript/Docs.hs b/src/Language/PureScript/Docs.hs
index 16673c0..417c98f 100644
--- a/src/Language/PureScript/Docs.hs
+++ b/src/Language/PureScript/Docs.hs
@@ -2,13 +2,13 @@
-- | Data types and functions for rendering generated documentation from
-- PureScript code, in a variety of formats.
-module Language.PureScript.Docs (
- module Docs
-) where
+module Language.PureScript.Docs
+ ( module Docs
+ ) where
+import Language.PureScript.Docs.Collect as Docs
import Language.PureScript.Docs.Convert as Docs
import Language.PureScript.Docs.Prim as Docs
-import Language.PureScript.Docs.ParseInPackage as Docs
import Language.PureScript.Docs.Render as Docs
import Language.PureScript.Docs.RenderedCode as Docs
import Language.PureScript.Docs.Tags as Docs
diff --git a/src/Language/PureScript/Docs/AsHtml.hs b/src/Language/PureScript/Docs/AsHtml.hs
index cc9c3b7..563de1e 100644
--- a/src/Language/PureScript/Docs/AsHtml.hs
+++ b/src/Language/PureScript/Docs/AsHtml.hs
@@ -17,8 +17,10 @@ module Language.PureScript.Docs.AsHtml (
import Prelude
import Control.Category ((>>>))
import Control.Monad (unless)
+import Data.Bifunctor (first)
import Data.Char (isUpper)
import Data.Either (isRight)
+import qualified Data.List.NonEmpty as NE
import Data.Maybe (fromMaybe)
import Data.Foldable (for_)
import Data.String (fromString)
@@ -29,13 +31,13 @@ import qualified Data.Text as T
import Text.Blaze.Html5 as H hiding (map)
import qualified Text.Blaze.Html5.Attributes as A
import qualified Cheapskate
-import Text.Parsec (eof)
import qualified Language.PureScript as P
import Language.PureScript.Docs.Types
import Language.PureScript.Docs.RenderedCode hiding (sp)
import qualified Language.PureScript.Docs.Render as Render
+import qualified Language.PureScript.CST as CST
declNamespace :: Declaration -> Namespace
declNamespace = declInfoNamespace . declInfo
@@ -219,12 +221,13 @@ codeAsHtml r = outputWith elemAsHtml
then False
else isUpper (T.index str 0)
- isOp = isRight . runParser P.symbol
+ isOp = isRight . runParser CST.parseOperator
- runParser :: P.TokenParser a -> Text -> Either String a
- runParser p' s = either (Left . show) Right $ do
- ts <- P.lex "" s
- P.runTokenParser "" (p' <* eof) ts
+ runParser :: CST.Parser a -> Text -> Either String a
+ runParser p' =
+ first (CST.prettyPrintError . NE.head)
+ . CST.runTokenParser p'
+ . CST.lex
renderLink :: HtmlRenderContext -> DocLink -> Html -> Html
renderLink r link_@DocLink{..} =
diff --git a/src/Language/PureScript/Docs/AsMarkdown.hs b/src/Language/PureScript/Docs/AsMarkdown.hs
index 6765217..1177de0 100644
--- a/src/Language/PureScript/Docs/AsMarkdown.hs
+++ b/src/Language/PureScript/Docs/AsMarkdown.hs
@@ -1,15 +1,14 @@
module Language.PureScript.Docs.AsMarkdown
- ( renderModulesAsMarkdown
- , Docs
+ ( Docs
, runDocs
, modulesAsMarkdown
+ , moduleAsMarkdown
, codeToString
) where
import Prelude.Compat
import Control.Monad (unless, zipWithM_)
-import Control.Monad.Error.Class (MonadError)
import Control.Monad.Writer (Writer, tell, execWriter)
import Data.Foldable (for_)
@@ -20,20 +19,8 @@ import qualified Data.Text as T
import Language.PureScript.Docs.RenderedCode
import Language.PureScript.Docs.Types
import qualified Language.PureScript as P
-import qualified Language.PureScript.Docs.Convert as Convert
import qualified Language.PureScript.Docs.Render as Render
--- |
--- Take a list of modules and render them all in order, returning a single
--- Markdown-formatted Text.
---
-renderModulesAsMarkdown ::
- (MonadError P.MultipleErrors m) =>
- [P.Module] ->
- m Text
-renderModulesAsMarkdown =
- fmap (runDocs . modulesAsMarkdown) . Convert.convertModules Local
-
modulesAsMarkdown :: [Module] -> Docs
modulesAsMarkdown = mapM_ moduleAsMarkdown
diff --git a/src/Language/PureScript/Docs/Collect.hs b/src/Language/PureScript/Docs/Collect.hs
new file mode 100644
index 0000000..d7dd7f7
--- /dev/null
+++ b/src/Language/PureScript/Docs/Collect.hs
@@ -0,0 +1,233 @@
+
+module Language.PureScript.Docs.Collect
+ ( collectDocs
+ ) where
+
+import Protolude hiding (check)
+
+import Control.Arrow ((&&&))
+import qualified Data.Aeson.BetterErrors as ABE
+import qualified Data.ByteString as BS
+import qualified Data.Map as Map
+import Data.String (String)
+import qualified Data.Set as Set
+import qualified Data.Text as T
+import System.FilePath ((</>))
+import System.IO.UTF8 (readUTF8FileT)
+
+import Language.PureScript.Docs.Convert.ReExports (updateReExports)
+import Language.PureScript.Docs.Prim (primModules)
+import Language.PureScript.Docs.Types
+
+import qualified Language.PureScript.AST as P
+import qualified Language.PureScript.CST as P
+import qualified Language.PureScript.Crash as P
+import qualified Language.PureScript.Errors as P
+import qualified Language.PureScript.Externs as P
+import qualified Language.PureScript.Make as P
+import qualified Language.PureScript.Names as P
+import qualified Language.PureScript.Options as P
+
+import Web.Bower.PackageMeta (PackageName)
+
+-- |
+-- Given a compiler output directory, a list of input PureScript source files,
+-- and a list of dependency PureScript source files, produce documentation for
+-- the input files in the intermediate documentation format. Note that
+-- dependency files are not included in the result.
+--
+-- If the output directory is not up to date with respect to the provided input
+-- and dependency files, the files will be built as if with just the "docs"
+-- codegen target, i.e. "purs compile --codegen docs".
+--
+collectDocs ::
+ forall m.
+ (MonadError P.MultipleErrors m, MonadIO m) =>
+ FilePath ->
+ [FilePath] ->
+ [(PackageName, FilePath)] ->
+ m ([(FilePath, Module)], Map P.ModuleName PackageName)
+collectDocs outputDir inputFiles depsFiles = do
+ (modulePaths, modulesDeps) <- getModulePackageInfo inputFiles depsFiles
+ externs <- compileForDocs outputDir (map fst modulePaths)
+
+ let (withPackage, shouldKeep) =
+ packageDiscriminators modulesDeps
+ let go =
+ operateAndRetag identity modName $ \mns -> do
+ docsModules <- traverse (liftIO . parseDocsJsonFile outputDir) mns
+ addReExports withPackage docsModules externs
+
+ docsModules <- go modulePaths
+ pure ((filter (shouldKeep . modName . snd) docsModules), modulesDeps)
+
+ where
+ packageDiscriminators modulesDeps =
+ let
+ shouldKeep mn = isLocal mn && not (P.isBuiltinModuleName mn)
+
+ withPackage :: P.ModuleName -> InPackage P.ModuleName
+ withPackage mn =
+ case Map.lookup mn modulesDeps of
+ Just pkgName -> FromDep pkgName mn
+ Nothing -> Local mn
+
+ isLocal :: P.ModuleName -> Bool
+ isLocal = not . flip Map.member modulesDeps
+ in
+ (withPackage, shouldKeep)
+
+-- |
+-- Compile with just the 'docs' codegen target, writing results into the given
+-- output directory.
+--
+compileForDocs ::
+ forall m.
+ (MonadError P.MultipleErrors m, MonadIO m) =>
+ FilePath ->
+ [FilePath] ->
+ m [P.ExternsFile]
+compileForDocs outputDir inputFiles = do
+ result <- liftIO $ do
+ moduleFiles <- readInput inputFiles
+ fmap fst $ P.runMake testOptions $ do
+ ms <- P.parseModulesFromFiles identity moduleFiles
+ let filePathMap = Map.fromList $ map (\(fp, pm) -> (P.getModuleName $ P.resPartial pm, Right fp)) ms
+ foreigns <- P.inferForeignModules filePathMap
+ let makeActions =
+ (P.buildMakeActions outputDir filePathMap foreigns False)
+ { P.progress = liftIO . putStrLn . renderProgressMessage
+ }
+ P.make makeActions (map snd ms)
+ either throwError return result
+
+ where
+ renderProgressMessage :: P.ProgressMessage -> String
+ renderProgressMessage (P.CompilingModule mn) =
+ "Compiling documentation for " ++ T.unpack (P.runModuleName mn)
+
+ readInput :: [FilePath] -> IO [(FilePath, Text)]
+ readInput files =
+ forM files $ \inFile -> (inFile, ) <$> readUTF8FileT inFile
+
+ testOptions :: P.Options
+ testOptions = P.defaultOptions { P.optionsCodegenTargets = Set.singleton P.Docs }
+
+parseDocsJsonFile :: FilePath -> P.ModuleName -> IO Module
+parseDocsJsonFile outputDir mn =
+ let
+ filePath = outputDir </> T.unpack (P.runModuleName mn) </> "docs.json"
+ in do
+ str <- BS.readFile filePath
+ case ABE.parseStrict asModule str of
+ Right m -> pure m
+ Left err -> P.internalError $
+ "Failed to decode: " ++ filePath ++
+ intercalate "\n" (map T.unpack (ABE.displayError displayPackageError err))
+
+addReExports ::
+ (MonadError P.MultipleErrors m) =>
+ (P.ModuleName -> InPackage P.ModuleName) ->
+ [Module] ->
+ [P.ExternsFile] ->
+ m [Module]
+addReExports withPackage docsModules externs = do
+ -- We add the Prim docs modules here, so that docs generation is still
+ -- possible if the modules we are generating docs for re-export things from
+ -- Prim submodules. Note that the Prim modules do not exist as
+ -- @Language.PureScript.Module@ values because they do not contain anything
+ -- that exists at runtime. However, we have pre-constructed
+ -- @Language.PureScript.Docs.Types.Module@ values for them, which we use
+ -- here.
+ let moduleMap =
+ Map.fromList
+ (map (modName &&& identity)
+ (docsModules ++ primModules))
+
+ let withReExports = updateReExports externs withPackage moduleMap
+ pure (Map.elems withReExports)
+
+-- |
+-- Perform an operation on a list of things which are tagged, and reassociate
+-- the things with their tags afterwards.
+--
+operateAndRetag ::
+ forall m a b key tag.
+ Monad m =>
+ Ord key =>
+ Show key =>
+ (a -> key) ->
+ (b -> key) ->
+ ([a] -> m [b]) ->
+ [(tag, a)] ->
+ m [(tag, b)]
+operateAndRetag keyA keyB operation input =
+ fmap (map retag) $ operation (map snd input)
+ where
+ tags :: Map key tag
+ tags = Map.fromList $ map (\(tag, a) -> (keyA a, tag)) input
+
+ findTag :: key -> tag
+ findTag key =
+ case Map.lookup key tags of
+ Just tag -> tag
+ Nothing -> P.internalError ("Missing tag for: " ++ show key)
+
+ retag :: b -> (tag, b)
+ retag b = (findTag (keyB b), b)
+
+-- |
+-- Given:
+--
+-- * A list of local source files
+-- * A list of source files from external dependencies, together with their
+-- package names
+--
+-- This function does the following:
+--
+-- * Partially parse all of the input and dependency source files to get
+-- the module name of each module
+-- * Associate each dependency module with its package name, thereby
+-- distinguishing these from local modules
+-- * Return the file paths paired with the names of the modules they
+-- contain, and a Map of module names to package names for modules which
+-- come from dependencies. If a module does not exist in the map, it can
+-- safely be
+-- assumed to be local.
+getModulePackageInfo ::
+ (MonadError P.MultipleErrors m, MonadIO m) =>
+ [FilePath]
+ -> [(PackageName, FilePath)]
+ -> m ([(FilePath, P.ModuleName)], Map P.ModuleName PackageName)
+getModulePackageInfo inputFiles depsFiles = do
+ inputFiles' <- traverse (readFileAs . Local) inputFiles
+ depsFiles' <- traverse (readFileAs . uncurry FromDep) depsFiles
+
+ moduleNames <- getModuleNames (inputFiles' ++ depsFiles')
+
+ let mnMap =
+ Map.fromList $
+ mapMaybe (\(pkgPath, mn) -> (mn,) <$> getPkgName pkgPath) moduleNames
+
+ pure (map (first ignorePackage) moduleNames, mnMap)
+
+ where
+ getModuleNames ::
+ (MonadError P.MultipleErrors m) =>
+ [(InPackage FilePath, Text)]
+ -> m [(InPackage FilePath, P.ModuleName)]
+ getModuleNames =
+ fmap (map (second (P.getModuleName . P.resPartial)))
+ . either throwError return
+ . P.parseModulesFromFiles ignorePackage
+
+ getPkgName = \case
+ Local _ -> Nothing
+ FromDep pkgName _ -> Just pkgName
+
+ readFileAs ::
+ (MonadIO m) =>
+ InPackage FilePath ->
+ m (InPackage FilePath, Text)
+ readFileAs fi =
+ liftIO . fmap ((fi,)) $ readUTF8FileT (ignorePackage fi)
diff --git a/src/Language/PureScript/Docs/Convert.hs b/src/Language/PureScript/Docs/Convert.hs
index e3c102f..c2f8a75 100644
--- a/src/Language/PureScript/Docs/Convert.hs
+++ b/src/Language/PureScript/Docs/Convert.hs
@@ -2,203 +2,46 @@
-- from Language.PureScript.Docs.
module Language.PureScript.Docs.Convert
- ( convertModules
- , convertModulesWithEnv
- , convertTaggedModulesInPackage
- , convertModulesInPackage
- , convertModulesInPackageWithEnv
+ ( convertModule
) where
import Protolude hiding (check)
-import Control.Arrow ((&&&))
import Control.Category ((>>>))
import Control.Monad.Writer.Strict (runWriterT)
+import Control.Monad.Supply (evalSupplyT)
import Data.Functor (($>))
+import qualified Data.List.NonEmpty as NE
import qualified Data.Map as Map
import Data.String (String)
-import Language.PureScript.Docs.Convert.ReExports (updateReExports)
import Language.PureScript.Docs.Convert.Single (convertSingleModule)
-import Language.PureScript.Docs.Prim (primModules)
import Language.PureScript.Docs.Types
-import qualified Language.PureScript as P
-
-import Web.Bower.PackageMeta (PackageName)
-
-import Text.Parsec (eof)
-
--- |
--- Like convertModuleInPackage, but with the modules tagged by their
--- file paths.
---
-convertTaggedModulesInPackage ::
- (MonadError P.MultipleErrors m) =>
- [(FilePath, P.Module)] ->
- Map P.ModuleName PackageName ->
- m [(FilePath, Module)]
-convertTaggedModulesInPackage taggedModules modulesDeps =
- traverse pairDocModule =<< convertModulesInPackage modules modulesDeps
- where
- modules = map snd taggedModules
-
- moduleNameToFileMap =
- Map.fromList $ swap . fmap P.getModuleName <$> taggedModules
-
- getModuleFile docModule =
- case Map.lookup (modName docModule) moduleNameToFileMap of
- Just filePath -> pure filePath
- Nothing -> throwError . P.errorMessage $
- P.ModuleNotFound $ modName docModule
-
- pairDocModule docModule = (, docModule) <$> getModuleFile docModule
-
--- |
--- Like convertModules, except that it takes a list of modules, together with
--- their dependency status, and discards dependency modules in the resulting
--- documentation.
---
-convertModulesInPackage ::
- (MonadError P.MultipleErrors m) =>
- [P.Module] ->
- Map P.ModuleName PackageName ->
- m [Module]
-convertModulesInPackage modules modulesDeps =
- fmap fst (convertModulesInPackageWithEnv modules modulesDeps)
-
-convertModulesInPackageWithEnv ::
- (MonadError P.MultipleErrors m) =>
- [P.Module] ->
- Map P.ModuleName PackageName ->
- m ([Module], P.Env)
-convertModulesInPackageWithEnv modules modulesDeps =
- go modules
- where
- go =
- convertModulesWithEnv withPackage
- >>> fmap (first (filter (shouldKeep . modName)))
-
- shouldKeep mn = isLocal mn && not (P.isBuiltinModuleName mn)
-
- withPackage :: P.ModuleName -> InPackage P.ModuleName
- withPackage mn =
- case Map.lookup mn modulesDeps of
- Just pkgName -> FromDep pkgName mn
- Nothing -> Local mn
-
- isLocal :: P.ModuleName -> Bool
- isLocal = not . flip Map.member modulesDeps
-
--- |
--- Convert a group of modules to the intermediate format, designed for
--- producing documentation from.
---
--- Note that the whole module dependency graph must be included in the list; if
--- some modules import things from other modules, then those modules must also
--- be included.
---
--- For value declarations, if explicit type signatures are omitted, or a
--- wildcard type is used, then we typecheck the modules and use the inferred
--- types.
---
-convertModules ::
- (MonadError P.MultipleErrors m) =>
- (P.ModuleName -> InPackage P.ModuleName) ->
- [P.Module] ->
- m [Module]
-convertModules withPackage =
- fmap fst . convertModulesWithEnv withPackage
-
-convertModulesWithEnv ::
- (MonadError P.MultipleErrors m) =>
- (P.ModuleName -> InPackage P.ModuleName) ->
- [P.Module] ->
- m ([Module], P.Env)
-convertModulesWithEnv withPackage =
- P.sortModules
- >>> fmap (fst >>> map P.importPrim)
- >=> convertSorted withPackage
+import qualified Language.PureScript.CST as CST
+import qualified Language.PureScript.AST as P
+import qualified Language.PureScript.Crash as P
+import qualified Language.PureScript.Errors as P
+import qualified Language.PureScript.Externs as P
+import qualified Language.PureScript.Environment as P
+import qualified Language.PureScript.Names as P
+import qualified Language.PureScript.Sugar as P
+import qualified Language.PureScript.Types as P
-- |
--- Convert a sorted list of modules, returning both the list of converted
--- modules and the Env produced during desugaring.
+-- Convert a single module to a Docs.Module, making use of a pre-existing
+-- type-checking environment in order to fill in any missing types. Note that
+-- re-exports will not be included.
--
-convertSorted ::
- (MonadError P.MultipleErrors m) =>
- (P.ModuleName -> InPackage P.ModuleName) ->
- [P.Module] ->
- m ([Module], P.Env)
-convertSorted withPackage modules = do
- (env, convertedModules) <- second (map convertSingleModule) <$> partiallyDesugar modules
-
- modulesWithTypes <- typeCheckIfNecessary modules convertedModules
-
- -- We add the Prim docs modules here, so that docs generation is still
- -- possible if the modules we are generating docs for re-export things from
- -- Prim submodules. Note that the Prim modules do not exist as
- -- @Language.PureScript.Module@ values because they do not contain anything
- -- that exists at runtime. However, we have pre-constructed
- -- @Language.PureScript.Docs.Types.Module@ values for them, which we use
- -- here.
- let moduleMap =
- Map.fromList
- (map (modName &&& identity)
- (modulesWithTypes ++ primModules))
-
- -- Set up the traversal order for re-export handling so that Prim modules
- -- come first.
- let primModuleNames = Map.keys P.primEnv
- let traversalOrder = primModuleNames ++ map P.getModuleName modules
- let withReExports = updateReExports env traversalOrder withPackage moduleMap
- pure (Map.elems withReExports, env)
-
--- |
--- If any exported value declarations have either wildcard type signatures, or
--- none at all, then typecheck in order to fill them in with the inferred
--- types.
---
-typeCheckIfNecessary ::
- (MonadError P.MultipleErrors m) =>
- [P.Module] ->
- [Module] ->
- m [Module]
-typeCheckIfNecessary modules convertedModules =
- if any hasWildcards convertedModules
- then go
- else pure convertedModules
-
- where
- hasWildcards = any (isWild . declInfo) . modDeclarations
- isWild (ValueDeclaration P.TypeWildcard{}) = True
- isWild _ = False
-
- go = do
- checkEnv <- snd <$> typeCheck modules
- pure (map (insertValueTypes checkEnv) convertedModules)
-
--- |
--- Typechecks all the modules together. Also returns the final 'P.Environment',
--- which is useful for adding in inferred types where explicit declarations
--- were not provided.
---
-typeCheck ::
- (MonadError P.MultipleErrors m) =>
- [P.Module] ->
- m ([P.Module], P.Environment)
-typeCheck =
- (P.desugar [] >=> check)
- >>> fmap (second P.checkEnv)
- >>> P.evalSupplyT 0
- >>> ignoreWarnings
-
- where
- check ms =
- runStateT
- (traverse P.typeCheckModule ms)
- (P.emptyCheckState P.initEnvironment)
-
- ignoreWarnings =
- fmap fst . runWriterT
+convertModule ::
+ MonadError P.MultipleErrors m =>
+ [P.ExternsFile] ->
+ P.Environment ->
+ P.Module ->
+ m Module
+convertModule externs checkEnv m =
+ partiallyDesugar externs [m] >>= \case
+ [m'] -> pure (insertValueTypes checkEnv (convertSingleModule m'))
+ _ -> P.internalError "partiallyDesugar did not return a singleton"
-- |
-- Updates all the types of the ValueDeclarations inside the module based on
@@ -211,7 +54,7 @@ insertValueTypes env m =
where
go (d@Declaration { declInfo = ValueDeclaration P.TypeWildcard{} }) =
let
- ident = parseIdent (declTitle d)
+ ident = P.Ident . CST.getIdent . CST.nameValue . parseIdent $ declTitle d
ty = lookupName ident
in
d { declInfo = ValueDeclaration (ty $> ()) }
@@ -219,7 +62,7 @@ insertValueTypes env m =
other
parseIdent =
- either (err . ("failed to parse Ident: " ++)) identity . runParser P.parseIdent
+ either (err . ("failed to parse Ident: " ++)) identity . runParser CST.parseIdent
lookupName name =
let key = P.Qualified (Just (modName m)) name
@@ -232,10 +75,11 @@ insertValueTypes env m =
err msg =
P.internalError ("Docs.Convert.insertValueTypes: " ++ msg)
-runParser :: P.TokenParser a -> Text -> Either String a
-runParser p s = either (Left . show) Right $ do
- ts <- P.lex "" s
- P.runTokenParser "" (p <* eof) ts
+runParser :: CST.Parser a -> Text -> Either String a
+runParser p =
+ first (CST.prettyPrintError . NE.head)
+ . CST.runTokenParser p
+ . CST.lex
-- |
-- Partially desugar modules so that they are suitable for extracting
@@ -243,9 +87,10 @@ runParser p s = either (Left . show) Right $ do
--
partiallyDesugar ::
(MonadError P.MultipleErrors m) =>
- [P.Module]
- -> m (P.Env, [P.Module])
-partiallyDesugar = P.evalSupplyT 0 . desugar'
+ [P.ExternsFile] ->
+ [P.Module] ->
+ m [P.Module]
+partiallyDesugar externs = evalSupplyT 0 . desugar'
where
desugar' =
traverse P.desugarDoModule
@@ -253,8 +98,8 @@ partiallyDesugar = P.evalSupplyT 0 . desugar'
>=> map P.desugarLetPatternModule
>>> traverse P.desugarCasesModule
>=> traverse P.desugarTypeDeclarationsModule
- >=> ignoreWarnings . P.desugarImportsWithEnv []
- >=> traverse (P.rebracketFiltered isInstanceDecl [])
+ >=> ignoreWarnings . P.desugarImports externs
+ >=> P.rebracketFiltered isInstanceDecl externs
ignoreWarnings = fmap fst . runWriterT
diff --git a/src/Language/PureScript/Docs/Convert/ReExports.hs b/src/Language/PureScript/Docs/Convert/ReExports.hs
index 1ad897e..9651bfb 100644
--- a/src/Language/PureScript/Docs/Convert/ReExports.hs
+++ b/src/Language/PureScript/Docs/Convert/ReExports.hs
@@ -13,38 +13,45 @@ import Control.Monad.Trans.State.Strict (execState)
import Data.Either
import Data.Map (Map)
-import Data.Maybe (mapMaybe)
+import Data.Maybe (mapMaybe, fromMaybe)
import qualified Data.Map as Map
import Data.Text (Text)
import qualified Data.Text as T
import Language.PureScript.Docs.Types
-import qualified Language.PureScript as P
+
+import qualified Language.PureScript.AST as P
+import qualified Language.PureScript.Crash as P
+import qualified Language.PureScript.Errors as P
+import qualified Language.PureScript.Externs as P
+import qualified Language.PureScript.ModuleDependencies as P
+import qualified Language.PureScript.Names as P
+import qualified Language.PureScript.Types as P
+
-- |
-- Given:
--
--- * The Imports/Exports Env
--- * An order to traverse the modules (which must be topological)
+-- * A list of externs files
+-- * A function for tagging a module with the package it comes from
-- * A map of modules, indexed by their names, which are assumed to not
-- have their re-exports listed yet
--
-- This function adds all the missing re-exports.
--
updateReExports ::
- P.Env ->
- [P.ModuleName] ->
+ [P.ExternsFile] ->
(P.ModuleName -> InPackage P.ModuleName) ->
Map P.ModuleName Module ->
Map P.ModuleName Module
-updateReExports env order withPackage = execState action
+updateReExports externs withPackage = execState action
where
action =
- void (traverse go order)
+ void (traverse go traversalOrder)
go mn = do
mdl <- lookup' mn
- reExports <- getReExports env mn
+ reExports <- getReExports externsEnv mn
let mdl' = mdl { modReExports = map (first withPackage) reExports }
modify (Map.insert mn mdl')
@@ -56,6 +63,25 @@ updateReExports env order withPackage = execState action
Nothing ->
internalError ("Module missing: " ++ T.unpack (P.runModuleName mn))
+ externsEnv :: Map P.ModuleName P.ExternsFile
+ externsEnv = Map.fromList $ map (P.efModuleName &&& id) externs
+
+ traversalOrder :: [P.ModuleName]
+ traversalOrder =
+ case P.sortModules externsSignature externs of
+ Right (es, _) -> map P.efModuleName es
+ Left errs -> internalError $
+ "failed to sortModules: " ++
+ P.prettyPrintMultipleErrors P.defaultPPEOptions errs
+
+ externsSignature :: P.ExternsFile -> P.ModuleSignature
+ externsSignature ef =
+ P.ModuleSignature
+ { P.sigSourceSpan = P.efSourceSpan ef
+ , P.sigModuleName = P.efModuleName ef
+ , P.sigImports = map (\ei -> (P.eiModule ei, P.nullSourceSpan)) (P.efImports ef)
+ }
+
-- |
-- Collect all of the re-exported declarations for a single module.
--
@@ -65,19 +91,20 @@ updateReExports env order withPackage = execState action
--
getReExports ::
(MonadState (Map P.ModuleName Module) m) =>
- P.Env ->
+ Map P.ModuleName P.ExternsFile ->
P.ModuleName ->
m [(P.ModuleName, [Declaration])]
-getReExports env mn =
- case Map.lookup mn env of
+getReExports externsEnv mn =
+ case Map.lookup mn externsEnv of
Nothing ->
internalError ("Module missing: " ++ T.unpack (P.runModuleName mn))
- Just (_, _, exports) -> do
- allExports <- runReaderT (collectDeclarations exports) mn
- pure (filter notLocal allExports)
+ Just (P.ExternsFile { P.efExports = refs }) -> do
+ let reExpRefs = mapMaybe toReExportRef refs
+ runReaderT (collectDeclarations reExpRefs) mn
- where
- notLocal = (/= mn) . fst
+toReExportRef :: P.DeclarationRef -> Maybe (P.ExportSource, P.DeclarationRef)
+toReExportRef (P.ReExportRef _ source ref) = Just (source, ref)
+toReExportRef _ = Nothing
-- |
-- Assemble a list of declarations re-exported from a particular module, based
@@ -100,9 +127,9 @@ getReExports env mn =
--
collectDeclarations :: forall m.
(MonadState (Map P.ModuleName Module) m, MonadReader P.ModuleName m) =>
- P.Exports ->
+ [(P.ExportSource, P.DeclarationRef)] ->
m [(P.ModuleName, [Declaration])]
-collectDeclarations exports = do
+collectDeclarations reExports = do
valsAndMembers <- collect lookupValueDeclaration expVals
valOps <- collect lookupValueOpDeclaration expValOps
typeClasses <- collect lookupTypeClassDeclaration expTCs
@@ -129,13 +156,31 @@ collectDeclarations exports = do
decls <- traverse (uncurry (flip lookup')) reExps
return $ Map.fromListWith (<>) decls
- expVals = P.exportedValues exports
- expValOps = P.exportedValueOps exports
- expTypes = Map.map snd (P.exportedTypes exports)
- expTypeOps = P.exportedTypeOps exports
- expCtors = concatMap fst (Map.elems (P.exportedTypes exports))
- expTCs = P.exportedTypeClasses exports
- expKinds = P.exportedKinds exports
+ expVals :: Map P.Ident P.ExportSource
+ expVals = mkExportMap P.getValueRef
+
+ expValOps :: Map (P.OpName 'P.ValueOpName) P.ExportSource
+ expValOps = mkExportMap P.getValueOpRef
+
+ expTCs :: Map (P.ProperName 'P.ClassName) P.ExportSource
+ expTCs = mkExportMap P.getTypeClassRef
+
+ expTypes :: Map (P.ProperName 'P.TypeName) P.ExportSource
+ expTypes = mkExportMap (fmap fst . P.getTypeRef)
+
+ expTypeOps :: Map (P.OpName 'P.TypeOpName) P.ExportSource
+ expTypeOps = mkExportMap P.getTypeOpRef
+
+ expKinds :: Map (P.ProperName 'P.KindName) P.ExportSource
+ expKinds = mkExportMap P.getKindRef
+
+ mkExportMap :: Ord name => (P.DeclarationRef -> Maybe name) -> Map name P.ExportSource
+ mkExportMap f =
+ Map.fromList $
+ mapMaybe (\(exportSrc, ref) -> (,exportSrc) <$> f ref) reExports
+
+ expCtors :: [P.ProperName 'P.ConstructorName]
+ expCtors = concatMap (fromMaybe [] . (>>= snd) . P.getTypeRef . snd) reExports
lookupValueDeclaration ::
(MonadState (Map P.ModuleName Module) m,
diff --git a/src/Language/PureScript/Docs/Convert/Single.hs b/src/Language/PureScript/Docs/Convert/Single.hs
index b4ed0b3..1ab7188 100644
--- a/src/Language/PureScript/Docs/Convert/Single.hs
+++ b/src/Language/PureScript/Docs/Convert/Single.hs
@@ -11,7 +11,12 @@ import Data.Functor (($>))
import qualified Data.Text as T
import Language.PureScript.Docs.Types
-import qualified Language.PureScript as P
+
+import qualified Language.PureScript.AST as P
+import qualified Language.PureScript.Comments as P
+import qualified Language.PureScript.Crash as P
+import qualified Language.PureScript.Names as P
+import qualified Language.PureScript.Types as P
-- |
-- Convert a single Module, but ignore re-exports; any re-exported types or
diff --git a/src/Language/PureScript/Docs/ParseInPackage.hs b/src/Language/PureScript/Docs/ParseInPackage.hs
deleted file mode 100644
index 7a90a84..0000000
--- a/src/Language/PureScript/Docs/ParseInPackage.hs
+++ /dev/null
@@ -1,74 +0,0 @@
-module Language.PureScript.Docs.ParseInPackage
- ( parseFilesInPackages
- ) where
-
-import Protolude
-
-import qualified Data.Map as M
-
-import Language.PureScript.Docs.Types
-import qualified Language.PureScript as P
-import System.IO.UTF8 (readUTF8FileT)
-import Web.Bower.PackageMeta (PackageName)
-
--- |
--- Given:
---
--- * A list of local source files
--- * A list of source files from external dependencies, together with their
--- package names
---
--- This function does the following:
---
--- * Parse all of the input and dependency source files
--- * Associate each dependency module with its package name, thereby
--- distinguishing these from local modules
--- * Return the paths paired with parsed modules, and a Map of module names
--- to package names for modules which come from dependencies.
--- If a module does not exist in the map, it can safely be assumed to be
--- local.
-parseFilesInPackages ::
- (MonadError P.MultipleErrors m, MonadIO m) =>
- [FilePath]
- -> [(PackageName, FilePath)]
- -> m ([(FilePath, P.Module)], Map P.ModuleName PackageName)
-parseFilesInPackages inputFiles depsFiles = do
- inputFiles' <- traverse (readFileAs . Local) inputFiles
- depsFiles' <- traverse (readFileAs . uncurry FromDep) depsFiles
-
- modules <- parse (inputFiles' ++ depsFiles')
-
- let mnMap = M.fromList (mapMaybe (\(inpkg, m) -> (P.getModuleName m,) <$> inPkgToMaybe inpkg) modules)
-
- pure (map (first fileInfoToString) modules, mnMap)
-
- where
- parse ::
- (MonadError P.MultipleErrors m) =>
- [(FileInfo, Text)]
- -> m [(FileInfo, P.Module)]
- parse =
- throwLeft . P.parseModulesFromFiles fileInfoToString
-
- inPkgToMaybe = \case
- Local _ -> Nothing
- FromDep pkgName _ -> Just pkgName
-
-throwLeft :: (MonadError l m) => Either l r -> m r
-throwLeft = either throwError return
-
--- | Specifies whether a PureScript source file is considered as:
---
--- 1) with the `Local` constructor, a target source file, i.e., we want to see
--- its modules in the output
--- 2) with the `FromDep` constructor, a dependencies source file, i.e. we do
--- not want its modules in the output; it is there to enable desugaring, and
--- to ensure that links between modules are constructed correctly.
-type FileInfo = InPackage FilePath
-
-fileInfoToString :: FileInfo -> FilePath
-fileInfoToString (Local fn) = fn
-fileInfoToString (FromDep _ fn) = fn
-
-readFileAs :: (MonadIO m) => FileInfo -> m (FileInfo, Text)
-readFileAs fi = liftIO . fmap ((fi,)) $ readUTF8FileT (ignorePackage fi)
diff --git a/src/Language/PureScript/Docs/Prim.hs b/src/Language/PureScript/Docs/Prim.hs
index 9d1b04d..6fc9253 100644
--- a/src/Language/PureScript/Docs/Prim.hs
+++ b/src/Language/PureScript/Docs/Prim.hs
@@ -13,7 +13,10 @@ import qualified Data.Text as T
import qualified Data.Map as Map
import qualified Data.Set as Set
import Language.PureScript.Docs.Types
-import qualified Language.PureScript as P
+
+import qualified Language.PureScript.Crash as P
+import qualified Language.PureScript.Environment as P
+import qualified Language.PureScript.Names as P
primModules :: [Module]
primModules =
diff --git a/src/Language/PureScript/Docs/Render.hs b/src/Language/PureScript/Docs/Render.hs
index 6e37c20..603aadf 100644
--- a/src/Language/PureScript/Docs/Render.hs
+++ b/src/Language/PureScript/Docs/Render.hs
@@ -18,7 +18,11 @@ import qualified Data.Text as T
import Language.PureScript.Docs.RenderedCode
import Language.PureScript.Docs.Types
import Language.PureScript.Docs.Utils.MonoidExtras
-import qualified Language.PureScript as P
+
+import qualified Language.PureScript.AST as P
+import qualified Language.PureScript.Environment as P
+import qualified Language.PureScript.Names as P
+import qualified Language.PureScript.Types as P
renderDeclaration :: Declaration -> RenderedCode
renderDeclaration Declaration{..} =
diff --git a/src/Language/PureScript/Docs/RenderedCode/RenderType.hs b/src/Language/PureScript/Docs/RenderedCode/RenderType.hs
index 25837ec..242f8a4 100644
--- a/src/Language/PureScript/Docs/RenderedCode/RenderType.hs
+++ b/src/Language/PureScript/Docs/RenderedCode/RenderType.hs
@@ -131,15 +131,15 @@ matchType = buildPrettyPrinter operators matchTypeAtom
OperatorTable [ [ AssocL typeApp $ \f x -> f <> sp <> x ]
, [ AssocR appliedFunction $ \arg ret -> mintersperse sp [arg, syntax "->", ret] ]
, [ Wrap constrained $ \deps ty -> renderConstraints deps ty ]
- , [ Wrap forall_ $ \tyVars ty -> mconcat [keywordForall, sp, mintersperse sp (map typeVar tyVars), syntax ".", sp, ty] ]
+ , [ Wrap forall_ $ \tyVars ty -> mconcat [ keywordForall, sp, renderTypeVars tyVars, syntax ".", sp, ty ] ]
, [ Wrap kinded $ \k ty -> mintersperse sp [ty, syntax "::", renderKind k] ]
, [ Wrap explicitParens $ \_ ty -> ty ]
]
-forall_ :: Pattern () PrettyPrintType ([Text], PrettyPrintType)
+forall_ :: Pattern () PrettyPrintType ([(Text, Maybe (Kind ()))], PrettyPrintType)
forall_ = mkPattern match
where
- match (PPForAll idents ty) = Just (idents, ty)
+ match (PPForAll mbKindedIdents ty) = Just (mbKindedIdents, ty)
match _ = Nothing
-- |
@@ -153,6 +153,14 @@ renderType'
= fromMaybe (internalError "Incomplete pattern")
. PA.pattern matchType ()
+renderTypeVars :: [(Text, Maybe (Kind a))] -> RenderedCode
+renderTypeVars tyVars = mintersperse sp (map renderTypeVar tyVars)
+
+renderTypeVar :: (Text, Maybe (Kind a)) -> RenderedCode
+renderTypeVar (v, mbK) = case mbK of
+ Nothing -> typeVar v
+ Just k -> mintersperse sp [ mconcat [syntax "(", typeVar v], syntax "::", mconcat [renderKind k, syntax ")"] ]
+
-- |
-- Render code representing a Type, as it should appear inside parentheses
--
diff --git a/src/Language/PureScript/Docs/Types.hs b/src/Language/PureScript/Docs/Types.hs
index 16a18d5..89c3e39 100644
--- a/src/Language/PureScript/Docs/Types.hs
+++ b/src/Language/PureScript/Docs/Types.hs
@@ -27,7 +27,13 @@ import qualified Data.Aeson as A
import qualified Data.Text as T
import qualified Data.Vector as V
-import qualified Language.PureScript as P
+import qualified Language.PureScript.AST as P
+import qualified Language.PureScript.Crash as P
+import qualified Language.PureScript.Environment as P
+import qualified Language.PureScript.Kinds as P
+import qualified Language.PureScript.Names as P
+import qualified Language.PureScript.Types as P
+import qualified Paths_purescript as Paths
import Text.ParserCombinators.ReadP (readP_to_S)
@@ -773,7 +779,7 @@ instance A.ToJSON a => A.ToJSON (Package a) where
pkgResolvedDependencies
, "github" .= pkgGithub
, "uploader" .= pkgUploader
- , "compilerVersion" .= showVersion P.version
+ , "compilerVersion" .= showVersion Paths.version
] ++
fmap (\t -> "tagTime" .= formatTime t) (maybeToList pkgTagTime)
diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs
index 2521884..08bee19 100644
--- a/src/Language/PureScript/Errors.hs
+++ b/src/Language/PureScript/Errors.hs
@@ -30,6 +30,7 @@ import Language.PureScript.AST
import qualified Language.PureScript.Bundle as Bundle
import qualified Language.PureScript.Constants as C
import Language.PureScript.Crash
+import qualified Language.PureScript.CST.Errors as CST
import Language.PureScript.Environment
import Language.PureScript.Label (Label(..))
import Language.PureScript.Names
@@ -78,6 +79,7 @@ errorCode em = case unwrapErrorMessage em of
ModuleNotFound{} -> "ModuleNotFound"
ErrorParsingFFIModule{} -> "ErrorParsingFFIModule"
ErrorParsingModule{} -> "ErrorParsingModule"
+ ErrorParsingCSTModule{} -> "ErrorParsingModule"
MissingFFIModule{} -> "MissingFFIModule"
UnnecessaryFFIModule{} -> "UnnecessaryFFIModule"
MissingFFIImplementations{} -> "MissingFFIImplementations"
@@ -456,7 +458,12 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl
renderSimpleErrorMessage :: SimpleErrorMessage -> Box.Box
renderSimpleErrorMessage (ModuleNotFound mn) =
paras [ line $ "Module " <> markCode (runModuleName mn) <> " was not found."
- , line "Make sure the source file exists, and that it has been provided as an input to the compiler."
+ , line $
+ if isBuiltinModuleName mn
+ then
+ "Module names in the Prim namespace are reserved for built-in modules, but this version of the compiler does not provide module " <> markCode (runModuleName mn) <> ". You may be able to fix this by updating your compiler to a newer version."
+ else
+ "Make sure the source file exists, and that it has been provided as an input to the compiler."
]
renderSimpleErrorMessage (CannotGetFileInfo path) =
paras [ line "Unable to read file info: "
@@ -479,6 +486,10 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl
paras [ line "Unable to parse module: "
, prettyPrintParseError err
]
+ renderSimpleErrorMessage (ErrorParsingCSTModule err) =
+ paras [ line "Unable to parse module: "
+ , line $ T.pack $ CST.prettyPrintErrorMessage err
+ ]
renderSimpleErrorMessage (MissingFFIModule mn) =
line $ "The foreign module implementation for module " <> markCode (runModuleName mn) <> " is missing."
renderSimpleErrorMessage (UnnecessaryFFIModule mn path) =
@@ -551,7 +562,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl
renderSimpleErrorMessage (DeclConflict new existing) =
line $ "Declaration for " <> printName (Qualified Nothing new) <> " conflicts with an existing " <> nameType existing <> " of the same name."
renderSimpleErrorMessage (ExportConflict new existing) =
- line $ "Export for " <> printName new <> " conflicts with " <> runName existing
+ line $ "Export for " <> printName new <> " conflicts with " <> printName existing
renderSimpleErrorMessage (DuplicateModule mn) =
line $ "Module " <> markCode (runModuleName mn) <> " has been defined multiple times"
renderSimpleErrorMessage (DuplicateTypeClass pn ss) =
@@ -565,9 +576,13 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl
renderSimpleErrorMessage (CycleInDeclaration nm) =
line $ "The value of " <> markCode (showIdent nm) <> " is undefined here, so this reference is not allowed."
renderSimpleErrorMessage (CycleInModules mns) =
- paras [ line "There is a cycle in module dependencies in these modules: "
- , indent $ paras (map (line . markCode . runModuleName) mns)
- ]
+ case mns of
+ [mn] ->
+ line $ "Module " <> markCode (runModuleName mn) <> " imports itself."
+ _ ->
+ paras [ line "There is a cycle in module dependencies in these modules: "
+ , indent $ paras (map (line . markCode . runModuleName) mns)
+ ]
renderSimpleErrorMessage (CycleInTypeSynonym name) =
paras [ line $ case name of
Just pn -> "A cycle appears in the definition of type synonym " <> markCode (runProperName pn)
@@ -581,7 +596,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showDocs relPath) e = fl
paras [ line $ "A cycle appears in a set of type class definitions:"
, indent $ line $ "{" <> (T.intercalate ", " (map (markCode . runProperName . disqualify) names)) <> "}"
, line "Cycles are disallowed because they can lead to loops in the type checker."
- ]
+ ]
renderSimpleErrorMessage (NameIsUndefined ident) =
line $ "Value " <> markCode (showIdent ident) <> " is undefined."
renderSimpleErrorMessage (UndefinedTypeVariable name) =
diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs
index 7de9287..0953ea2 100644
--- a/src/Language/PureScript/Externs.hs
+++ b/src/Language/PureScript/Externs.hs
@@ -12,11 +12,15 @@ module Language.PureScript.Externs
, ExternsDeclaration(..)
, moduleToExternsFile
, applyExternsFileToEnvironment
+ , decodeExterns
) where
import Prelude.Compat
+import Control.Monad (guard)
+import Data.Aeson (decode)
import Data.Aeson.TH
+import Data.ByteString.Lazy (ByteString)
import Data.Maybe (fromMaybe, mapMaybe, maybeToList)
import Data.List (foldl', find)
import Data.Foldable (fold)
@@ -242,3 +246,10 @@ $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExternsF
$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExternsTypeFixity)
$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExternsDeclaration)
$(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExternsFile)
+
+
+decodeExterns :: ByteString -> Maybe ExternsFile
+decodeExterns bs = do
+ externs <- decode bs
+ guard $ T.unpack (efVersion externs) == showVersion Paths.version
+ return externs
diff --git a/src/Language/PureScript/Ide/CaseSplit.hs b/src/Language/PureScript/Ide/CaseSplit.hs
index 253ef53..0cc2aa6 100644
--- a/src/Language/PureScript/Ide/CaseSplit.hs
+++ b/src/Language/PureScript/Ide/CaseSplit.hs
@@ -23,18 +23,17 @@ module Language.PureScript.Ide.CaseSplit
import Protolude hiding (Constructor)
+import qualified Data.List.NonEmpty as NE
import qualified Data.Map as M
import qualified Data.Text as T
import qualified Language.PureScript as P
+import qualified Language.PureScript.CST as CST
import Language.PureScript.Externs
import Language.PureScript.Ide.Error
import Language.PureScript.Ide.State
import Language.PureScript.Ide.Types
-import Text.Parsec as Parsec
-import qualified Text.PrettyPrint.Boxes as Box
-
type Constructor = (P.ProperName 'P.ConstructorName, [P.SourceType])
newtype WildcardAnnotations = WildcardAnnotations Bool
@@ -125,31 +124,31 @@ addClause s wca = do
parseType' :: (MonadError IdeError m) =>
Text -> m P.SourceType
parseType' s =
- case P.lex "<psc-ide>" (toS s) >>= P.runTokenParser "<psc-ide>" (P.parseType <* Parsec.eof) of
- Right type' -> pure type'
+ case CST.runTokenParser CST.parseType $ CST.lex s of
+ Right type' -> pure $ CST.convertType "<purs-ide>" type'
Left err ->
throwError (GeneralError ("Parsing the splittype failed with:"
<> show err))
parseTypeDeclaration' :: (MonadError IdeError m) => Text -> m (P.Ident, P.SourceType)
parseTypeDeclaration' s =
- let x = do
- ts <- P.lex "" (toS s)
- P.runTokenParser "" (P.parseDeclaration <* Parsec.eof) ts
+ let x = fmap (CST.convertDeclaration "<purs-ide>")
+ $ CST.runTokenParser CST.parseDecl
+ $ CST.lex s
in
case x of
- Right (P.TypeDeclaration td : _) -> pure (P.unwrapTypeDeclaration td)
+ Right [P.TypeDeclaration td] -> pure (P.unwrapTypeDeclaration td)
Right _ -> throwError (GeneralError "Found a non-type-declaration")
- Left err ->
+ Left errs ->
throwError (GeneralError ("Parsing the type signature failed with: "
- <> toS (Box.render (P.prettyPrintParseError err))))
+ <> toS (CST.prettyPrintErrorMessage $ NE.head errs)))
splitFunctionType :: P.Type a -> [P.Type a]
splitFunctionType t = fromMaybe [] arguments
where
arguments = initMay splitted
splitted = splitType' t
- splitType' (P.ForAll _ _ t' _) = splitType' t'
+ splitType' (P.ForAll _ _ _ t' _) = splitType' t'
splitType' (P.ConstrainedType _ _ t') = splitType' t'
splitType' (P.TypeApp _ (P.TypeApp _ t' lhs) rhs)
| P.eqType t' P.tyFunction = lhs : splitType' rhs
diff --git a/src/Language/PureScript/Ide/Imports.hs b/src/Language/PureScript/Ide/Imports.hs
index e880248..6af718b 100644
--- a/src/Language/PureScript/Ide/Imports.hs
+++ b/src/Language/PureScript/Ide/Imports.hs
@@ -33,10 +33,12 @@ module Language.PureScript.Ide.Imports
import Protolude hiding (moduleName)
import Data.List (findIndex, nubBy, partition)
+import qualified Data.List.NonEmpty as NE
import qualified Data.Map as Map
import qualified Data.Text as T
import qualified Language.PureScript as P
import qualified Language.PureScript.Constants as C
+import qualified Language.PureScript.CST as CST
import Language.PureScript.Ide.Completion
import Language.PureScript.Ide.Error
import Language.PureScript.Ide.Filter
@@ -46,7 +48,6 @@ import Language.PureScript.Ide.Types
import Language.PureScript.Ide.Util
import Lens.Micro.Platform ((^.), (%~), ix, has)
import System.IO.UTF8 (writeUTF8FileT)
-import qualified Text.Parsec as Parsec
data Import = Import P.ModuleName P.ImportDeclarationType (Maybe P.ModuleName)
deriving (Eq, Show)
@@ -90,21 +91,27 @@ data ImportParse = ImportParse
-- ^ the extracted import declarations
}
-parseModuleHeader :: P.TokenParser ImportParse
-parseModuleHeader = do
- _ <- P.readComments
- (mn, _) <- P.parseModuleDeclaration
- (ipStart, ipEnd, decls) <- P.withSourceSpan (\(P.SourceSpan _ start end) _ -> (start, end,))
- (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 refs) qual
- mkImport (mn, it, qual) = Import mn it qual
+parseModuleHeader :: Text -> Either (NE.NonEmpty CST.ParserError) ImportParse
+parseModuleHeader src = do
+ CST.PartialResult md _ <- CST.parseModule $ CST.lenient $ CST.lex src
+ let
+ mn = CST.nameValue $ CST.modNamespace md
+ decls = flip fmap (CST.modImports md) $ \decl -> do
+ let ((ss, _), mn', it, qual) = CST.convertImportDecl "<purs-ide>" decl
+ (ss, Import mn' it qual)
+ case (head decls, lastMay decls) of
+ (Just hd, Just ls) -> do
+ let
+ ipStart = P.spanStart $ fst hd
+ ipEnd = P.spanEnd $ fst ls
+ pure $ ImportParse mn ipStart ipEnd $ snd <$> decls
+ _ -> do
+ let pos = CST.sourcePos . CST.srcEnd . CST.tokRange . CST.tokAnn $ CST.modWhere md
+ pure $ ImportParse mn pos pos []
sliceImportSection :: [Text] -> Either Text (P.ModuleName, [Text], [Import], [Text])
-sliceImportSection fileLines = first show $ do
- tokens <- P.lexLenient "<psc-ide>" file
- ImportParse{..} <- P.runTokenParser "<psc-ide>" parseModuleHeader tokens
+sliceImportSection fileLines = first (toS . CST.prettyPrintError . NE.head) $ do
+ ImportParse{..} <- parseModuleHeader file
pure
( ipModuleName
, sliceFile (P.SourcePos 1 1) (prevPos ipStart)
@@ -138,7 +145,7 @@ addImplicitImport
addImplicitImport fp mn = do
(_, pre, imports, post) <- parseImportsFromFile' fp
let newImportSection = addImplicitImport' imports mn
- pure (pre ++ newImportSection ++ post)
+ pure $ joinSections (pre, newImportSection, post)
addImplicitImport' :: [Import] -> P.ModuleName -> [Text]
addImplicitImport' imports mn =
@@ -157,7 +164,7 @@ addQualifiedImport
addQualifiedImport fp mn qualifier = do
(_, pre, imports, post) <- parseImportsFromFile' fp
let newImportSection = addQualifiedImport' imports mn qualifier
- pure (pre ++ newImportSection ++ post)
+ pure $ joinSections (pre, newImportSection, post)
addQualifiedImport' :: [Import] -> P.ModuleName -> P.ModuleName -> [Text]
addQualifiedImport' imports mn qualifier =
@@ -180,7 +187,7 @@ addExplicitImport fp decl moduleName qualifier = do
if mn == moduleName
then imports
else addExplicitImport' decl moduleName qualifier imports
- pure (pre ++ prettyPrintImportSection newImportSection ++ post)
+ pure $ joinSections (pre, prettyPrintImportSection newImportSection, post)
addExplicitImport' :: IdeDeclaration -> P.ModuleName -> Maybe P.ModuleName -> [Import] -> [Import]
addExplicitImport' decl moduleName qualifier imports =
@@ -364,9 +371,21 @@ answerRequest outfp rs =
-- | Test and ghci helper
parseImport :: Text -> Maybe Import
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 refs) mmn)
- Right (mn, idt, mmn) -> Just (Import mn idt mmn)
- Left _ -> Nothing
+ case fmap (CST.convertImportDecl "<purs-ide>")
+ $ CST.runTokenParser CST.parseImportDeclP
+ $ CST.lex t of
+ Right (_, mn, idt, mmn) ->
+ Just (Import mn idt mmn)
+ _ -> Nothing
+
+joinSections :: ([Text], [Text], [Text]) -> [Text]
+joinSections (pre, decls, post) = pre `joinLine` (decls `joinLine` post)
+ where
+ isBlank = T.all (== ' ')
+ joinLine as bs
+ | Just ln1 <- lastMay as
+ , Just ln2 <- head bs
+ , not (isBlank ln1) && not (isBlank ln2) =
+ as ++ [""] ++ bs
+ | otherwise =
+ as ++ bs
diff --git a/src/Language/PureScript/Ide/Rebuild.hs b/src/Language/PureScript/Ide/Rebuild.hs
index 6ad0313..9e38117 100644
--- a/src/Language/PureScript/Ide/Rebuild.hs
+++ b/src/Language/PureScript/Ide/Rebuild.hs
@@ -15,6 +15,7 @@ import qualified Data.Map.Lazy as M
import Data.Maybe (fromJust)
import qualified Data.Set as S
import qualified Language.PureScript as P
+import qualified Language.PureScript.CST as CST
import Language.PureScript.Ide.Error
import Language.PureScript.Ide.Logging
import Language.PureScript.Ide.State
@@ -48,12 +49,11 @@ rebuildFile
-- ^ A runner for the second build with open exports
-> m Success
rebuildFile file actualFile codegenTargets runOpenBuild = do
-
- input <- ideReadFile file
-
- m <- case snd <$> P.parseModuleFromFile (maybe identity const actualFile) input of
+ (fp, input) <- ideReadFile file
+ let fp' = fromMaybe fp actualFile
+ m <- case CST.parseFromFile fp' input of
Left parseError ->
- throwError (RebuildError (P.MultipleErrors [P.toPositionedError parseError]))
+ throwError $ RebuildError $ CST.toMultipleErrors fp' parseError
Right m -> pure m
-- Externs files must be sorted ahead of time, so that they get applied
@@ -173,7 +173,7 @@ sortExterns
-> m [P.ExternsFile]
sortExterns m ex = do
sorted' <- runExceptT
- . P.sortModules
+ . P.sortModules P.moduleSignature
. (:) m
. map mkShallowModule
. M.elems
diff --git a/src/Language/PureScript/Ide/SourceFile.hs b/src/Language/PureScript/Ide/SourceFile.hs
index 27a1725..bda3212 100644
--- a/src/Language/PureScript/Ide/SourceFile.hs
+++ b/src/Language/PureScript/Ide/SourceFile.hs
@@ -26,6 +26,7 @@ import Protolude
import Control.Parallel.Strategies (withStrategy, parList, rseq)
import qualified Data.Map as Map
import qualified Language.PureScript as P
+import qualified Language.PureScript.CST as CST
import Language.PureScript.Ide.Error
import Language.PureScript.Ide.Types
import Language.PureScript.Ide.Util
@@ -40,9 +41,9 @@ parseModule path = do
parseModule' :: FilePath -> Text -> Either FilePath (FilePath, P.Module)
parseModule' path file =
- case P.parseModuleFromFile identity (path, file) of
+ case CST.parseFromFile path file of
Left _ -> Left path
- Right m -> Right m
+ Right m -> Right (path, m)
parseModulesFromFiles
:: (MonadIO m, MonadError IdeError m)
diff --git a/src/Language/PureScript/Interactive.hs b/src/Language/PureScript/Interactive.hs
index fb4f45a..c4b2f8e 100644
--- a/src/Language/PureScript/Interactive.hs
+++ b/src/Language/PureScript/Interactive.hs
@@ -28,6 +28,7 @@ import Control.Monad.Trans.State.Strict (StateT, runStateT, evalStateT
import Control.Monad.Writer.Strict (Writer(), runWriter)
import qualified Language.PureScript as P
+import qualified Language.PureScript.CST as CST
import qualified Language.PureScript.Names as N
import qualified Language.PureScript.Constants as C
@@ -75,7 +76,7 @@ rebuild loadedExterns m = do
-- | Build the collection of modules from scratch. This is usually done on startup.
make
- :: [(FilePath, P.Module)]
+ :: [(FilePath, CST.PartialResult P.Module)]
-> P.Make ([P.ExternsFile], P.Environment)
make ms = do
foreignFiles <- P.inferForeignModules filePathMap
@@ -90,7 +91,7 @@ make ms = do
False
filePathMap :: M.Map P.ModuleName (Either P.RebuildPolicy FilePath)
- filePathMap = M.fromList $ map (\(fp, m) -> (P.getModuleName m, Right fp)) ms
+ filePathMap = M.fromList $ map (\(fp, m) -> (P.getModuleName $ CST.resPartial m, Right fp)) ms
-- | Performs a PSCi command
handleCommand
@@ -127,7 +128,7 @@ handleReloadState reload = do
files <- liftIO $ concat <$> traverse glob globs
e <- runExceptT $ do
modules <- ExceptT . liftIO $ loadAllModules files
- (externs, _) <- ExceptT . liftIO . runMake . make $ modules
+ (externs, _) <- ExceptT . liftIO . runMake . make $ fmap CST.pureResult <$> modules
return (map snd modules, externs)
case e of
Left errs -> printErrors errs
diff --git a/src/Language/PureScript/Interactive/Module.hs b/src/Language/PureScript/Interactive/Module.hs
index 0633fea..a2bf230 100644
--- a/src/Language/PureScript/Interactive/Module.hs
+++ b/src/Language/PureScript/Interactive/Module.hs
@@ -4,6 +4,7 @@ import Prelude.Compat
import Control.Monad
import qualified Language.PureScript as P
+import qualified Language.PureScript.CST as CST
import Language.PureScript.Interactive.Types
import System.Directory (getCurrentDirectory)
import System.FilePath (pathSeparator, makeRelative)
@@ -16,8 +17,8 @@ supportModuleName :: P.ModuleName
supportModuleName = fst initialInteractivePrint
-- | Checks if the Console module is defined
-supportModuleIsDefined :: [P.Module] -> Bool
-supportModuleIsDefined = any ((== supportModuleName) . P.getModuleName)
+supportModuleIsDefined :: [P.ModuleName] -> Bool
+supportModuleIsDefined = any ((== supportModuleName))
-- * Module Management
@@ -28,7 +29,7 @@ loadModule filename = do
content <- readUTF8FileT filename
return $
either (Left . P.prettyPrintMultipleErrors P.defaultPPEOptions {P.ppeRelativeDirectory = pwd}) (Right . map snd) $
- P.parseModulesFromFiles id [(filename, content)]
+ CST.parseFromFiles id [(filename, content)]
-- | Load all modules.
loadAllModules :: [FilePath] -> IO (Either P.MultipleErrors [(FilePath, P.Module)])
@@ -37,7 +38,7 @@ loadAllModules files = do
filesAndContent <- forM files $ \filename -> do
content <- readUTF8FileT filename
return (filename, content)
- return $ P.parseModulesFromFiles (makeRelative pwd) filesAndContent
+ return $ CST.parseFromFiles (makeRelative pwd) filesAndContent
-- |
-- Makes a volatile module to execute the current expression.
diff --git a/src/Language/PureScript/Interactive/Parser.hs b/src/Language/PureScript/Interactive/Parser.hs
index cefec9f..33a0ed7 100644
--- a/src/Language/PureScript/Interactive/Parser.hs
+++ b/src/Language/PureScript/Interactive/Parser.hs
@@ -8,27 +8,35 @@ module Language.PureScript.Interactive.Parser
import Prelude.Compat hiding (lex)
-import Control.Applicative ((<|>))
-import Control.Monad (join)
+import Control.Monad (join, unless)
import Data.Bifunctor (first)
import Data.Char (isSpace)
import Data.List (intercalate)
+import qualified Data.List.NonEmpty as NE
import qualified Data.Text as T
-import Text.Parsec hiding ((<|>))
import qualified Language.PureScript as P
+import qualified Language.PureScript.CST as CST
+import qualified Language.PureScript.CST.Monad as CSTM
+import qualified Language.PureScript.CST.Positions as CST
import qualified Language.PureScript.Interactive.Directive as D
import Language.PureScript.Interactive.Types
-import Language.PureScript.Parser.Common (mark, same)
-- |
-- Parses a limited set of commands from from .purs-repl
--
parseDotFile :: FilePath -> String -> Either String [Command]
-parseDotFile filePath s = first show $ do
- ts <- P.lex filePath (T.pack s)
- P.runTokenParser filePath (many parser <* eof) ts
+parseDotFile filePath =
+ first (CST.prettyPrintError . NE.head)
+ . CST.runTokenParser (parseMany parser <* CSTM.token CST.TokEof)
+ . CST.lexTopLevel
+ . T.pack
where
- parser = psciImport <|> fail "The .purs-repl file only supports import declarations"
+ parser = CSTM.oneOf $ NE.fromList
+ [ psciImport filePath
+ , do
+ tok <- CSTM.munch
+ CSTM.parseFail tok $ CST.ErrCustom "The .purs-repl file only supports import declarations"
+ ]
-- |
-- Parses PSCI metacommands or expressions input from the user.
@@ -37,21 +45,37 @@ parseCommand :: String -> Either String [Command]
parseCommand cmdString =
case cmdString of
(':' : cmd) -> pure <$> parseDirective cmd
- _ -> parseRest (many1 psciCommand) cmdString
-
-parseRest :: P.TokenParser a -> String -> Either String a
-parseRest p s = first show $ do
- ts <- P.lex "" (T.pack s)
- P.runTokenParser "" (p <* eof) ts
-
-psciCommand :: P.TokenParser Command
-psciCommand = choice (map try parsers)
+ _ -> parseRest (mergeDecls <$> parseMany psciCommand) cmdString
where
- parsers =
- [ psciImport
+ mergeDecls (Decls as : bs) =
+ case mergeDecls bs of
+ Decls bs' : cs' ->
+ Decls (as <> bs') : cs'
+ cs' ->
+ Decls as : cs'
+ mergeDecls (a : bs) =
+ a : mergeDecls bs
+ mergeDecls [] = []
+
+parseMany :: CST.Parser a -> CST.Parser [a]
+parseMany = CSTM.manyDelimited CST.TokLayoutStart CST.TokLayoutEnd CST.TokLayoutSep
+
+parseOne :: CST.Parser a -> CST.Parser a
+parseOne p = CSTM.token CST.TokLayoutStart *> p <* CSTM.token CST.TokLayoutEnd
+
+parseRest :: CST.Parser a -> String -> Either String a
+parseRest p =
+ first (CST.prettyPrintError . NE.head)
+ . CST.runTokenParser (p <* CSTM.token CST.TokEof)
+ . CST.lexTopLevel
+ . T.pack
+
+psciCommand :: CST.Parser Command
+psciCommand =
+ CSTM.oneOf $ NE.fromList
+ [ psciImport ""
, psciDeclaration
, psciExpression
- , psciDeprecatedLet
]
trim :: String -> String
@@ -79,38 +103,41 @@ parseDirective cmd =
Reload -> return ReloadState
Clear -> return ClearState
Paste -> return PasteLines
- Browse -> BrowseModule <$> parseRest P.moduleName arg
+ Browse -> BrowseModule . CST.nameValue <$> parseRest (parseOne CST.parseModuleNameP) arg
Show -> ShowInfo <$> parseReplQuery' arg
- Type -> TypeOf <$> parseRest P.parseValue arg
- Kind -> KindOf <$> parseRest P.parseType arg
+ Type -> TypeOf . CST.convertExpr "" <$> parseRest (parseOne CST.parseExprP) arg
+ Kind -> KindOf . CST.convertType "" <$> parseRest (parseOne CST.parseTypeP) arg
Complete -> return (CompleteStr arg)
- Print -> parseRest
- ((eof *> return (ShowInfo QueryPrint))
- <|> (SetInteractivePrint <$> parseFullyQualifiedIdent))
- arg
+ Print
+ | arg == "" -> return $ ShowInfo QueryPrint
+ | otherwise -> SetInteractivePrint <$> parseRest (parseOne parseFullyQualifiedIdent) arg
-- |
-- Parses expressions entered at the PSCI repl.
--
-psciExpression :: P.TokenParser Command
-psciExpression = Expression <$> P.parseValue
+psciExpression :: CST.Parser Command
+psciExpression = Expression . CST.convertExpr "" <$> CST.parseExprP
-- | Imports must be handled separately from other declarations, so that
-- :show import works, for example.
-psciImport :: P.TokenParser Command
-psciImport = do
- (mn, declType, asQ) <- P.parseImportDeclaration'
- return $ Import (mn, declType, asQ)
+psciImport :: FilePath -> CST.Parser Command
+psciImport filePath = do
+ (_, mn, declType, asQ) <- CST.convertImportDecl filePath <$> CST.parseImportDeclP
+ pure $ Import (mn, declType, asQ)
-- | Any declaration that we don't need a 'special case' parser for
-- (like import declarations).
-psciDeclaration :: P.TokenParser Command
-psciDeclaration = fmap Decls $ mark $ fmap join (many1 $ same *>
- (traverse accept =<< P.parseDeclaration))
- where
- accept decl
- | acceptable decl = return decl
- | otherwise = fail "this kind of declaration is not supported in psci"
+psciDeclaration :: CST.Parser Command
+psciDeclaration = do
+ decl <- CST.parseDeclP
+ let decl' = CST.convertDeclaration "" decl
+ unless (all acceptable decl') $ do
+ let
+ tok = fst $ CST.declRange decl
+ tok' = T.unpack $ CST.printToken $ CST.tokValue tok
+ msg = tok' <> "; this kind of declaration is not supported in psci"
+ CSTM.parseFail tok $ CST.ErrLexeme (Just msg) []
+ pure $ Decls decl'
acceptable :: P.Declaration -> Bool
acceptable P.DataDeclaration{} = True
@@ -131,21 +158,12 @@ parseReplQuery' str =
intercalate ", " replQueryStrings ++ ".")
Just query -> Right query
--- | To show error message when 'let' is used for declaration in PSCI,
--- which is deprecated.
-psciDeprecatedLet :: P.TokenParser Command
-psciDeprecatedLet = do
- P.reserved "let"
- P.indented
- _ <- mark (many1 (same *> P.parseLocalDeclaration))
- notFollowedBy $ P.reserved "in"
- fail "Declarations in PSCi no longer require \"let\", as of version 0.11.0"
-
-parseFullyQualifiedIdent :: P.TokenParser (P.ModuleName, P.Ident)
-parseFullyQualifiedIdent = do
- qname <- P.parseQualified P.parseIdent
- case qname of
- P.Qualified (Just mn) ident ->
- pure (mn, ident)
- P.Qualified Nothing _ ->
- fail "Expected a fully-qualified name (eg: PSCI.Support.eval)"
+parseFullyQualifiedIdent :: CST.Parser (P.ModuleName, P.Ident)
+parseFullyQualifiedIdent = join $ CST.Parser $ \st _ ksucc ->
+ case CST.runParser st CST.parseQualIdentP of
+ (st', Right (CST.QualifiedName _ (Just mn) ident)) ->
+ ksucc st' $ pure (mn, P.Ident $ CST.getIdent ident)
+ _ ->
+ ksucc st $ do
+ tok <- CSTM.munch
+ CSTM.parseFail tok $ CST.ErrCustom "Expected a fully-qualified name (eg: PSCI.Support.eval)"
diff --git a/src/Language/PureScript/Kinds.hs b/src/Language/PureScript/Kinds.hs
index f58ccee..86686d6 100644
--- a/src/Language/PureScript/Kinds.hs
+++ b/src/Language/PureScript/Kinds.hs
@@ -155,6 +155,12 @@ eqKind (FunKind _ a b) (FunKind _ a' b') = eqKind a a' && eqKind b b'
eqKind (NamedKind _ a) (NamedKind _ a') = a == a'
eqKind _ _ = False
+eqMaybeKind :: Maybe (Kind a) -> Maybe (Kind b) -> Bool
+eqMaybeKind Nothing (Just _) = False
+eqMaybeKind (Just _) Nothing = False
+eqMaybeKind Nothing Nothing = True
+eqMaybeKind (Just a) (Just b) = eqKind a b
+
compareKind :: Kind a -> Kind b -> Ordering
compareKind (KUnknown _ a) (KUnknown _ a') = compare a a'
compareKind (KUnknown {}) _ = LT
@@ -169,3 +175,9 @@ compareKind _ (FunKind {}) = GT
compareKind (NamedKind _ a) (NamedKind _ a') = compare a a'
compareKind (NamedKind {}) _ = GT
+
+compareMaybeKind :: Maybe (Kind a) -> Maybe (Kind b) -> Ordering
+compareMaybeKind Nothing Nothing = EQ
+compareMaybeKind Nothing (Just _) = LT
+compareMaybeKind (Just _) Nothing = GT
+compareMaybeKind (Just a) (Just b) = compareKind a b
diff --git a/src/Language/PureScript/Linter.hs b/src/Language/PureScript/Linter.hs
index 96c11b8..fefed90 100644
--- a/src/Language/PureScript/Linter.hs
+++ b/src/Language/PureScript/Linter.hs
@@ -85,7 +85,7 @@ lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDecl
where
step :: S.Set Text -> SourceType -> (S.Set Text, MultipleErrors)
- step s (ForAll _ tv _ _) = bindVar s tv
+ step s (ForAll _ tv _ _ _) = bindVar s tv
step s _ = (s, mempty)
bindVar :: S.Set Text -> Text -> (S.Set Text, MultipleErrors)
@@ -96,7 +96,7 @@ lint (Module _ _ mn ds _) = censor (addHint (ErrorInModule mn)) $ mapM_ lintDecl
-- Recursively walk the type and prune used variables from `unused`
go :: S.Set Text -> SourceType -> (S.Set Text, MultipleErrors)
go unused (TypeVar _ v) = (S.delete v unused, mempty)
- go unused (ForAll _ tv t1 _) =
+ go unused (ForAll _ tv _ t1 _) =
let (nowUnused, errors) = go (S.insert tv unused) t1
restoredUnused = if S.member tv unused then S.insert tv nowUnused else nowUnused
combinedErrors = if S.member tv nowUnused then errors <> errorMessage' ss (UnusedTypeVar tv) else errors
diff --git a/src/Language/PureScript/Linter/Exhaustive.hs b/src/Language/PureScript/Linter/Exhaustive.hs
index ff64b44..27562b4 100644
--- a/src/Language/PureScript/Linter/Exhaustive.hs
+++ b/src/Language/PureScript/Linter/Exhaustive.hs
@@ -306,6 +306,7 @@ checkExhaustive ss env mn numArgs cas expr = makeResult . first ordNub $ foldl'
ty :: Text -> SourceType
ty tyVar =
srcForAll tyVar
+ Nothing
( srcConstrainedType
(srcConstraint C.Partial [] (Just constraintData))
$ srcTypeApp (srcTypeApp tyFunction (srcTypeVar tyVar)) (srcTypeVar tyVar)
diff --git a/src/Language/PureScript/Make.hs b/src/Language/PureScript/Make.hs
index 0341ee2..f60f565 100644
--- a/src/Language/PureScript/Make.hs
+++ b/src/Language/PureScript/Make.hs
@@ -25,8 +25,11 @@ import qualified Data.List.NonEmpty as NEL
import Data.Maybe (fromMaybe)
import qualified Data.Map as M
import qualified Data.Set as S
+import qualified Data.Text as T
import Language.PureScript.AST
import Language.PureScript.Crash
+import qualified Language.PureScript.CST as CST
+import qualified Language.PureScript.Docs.Convert as Docs
import Language.PureScript.Environment
import Language.PureScript.Errors
import Language.PureScript.Externs
@@ -60,8 +63,9 @@ rebuildModule MakeActions{..} externs m@(Module _ _ moduleName _ _) = do
withPrim = importPrim m
lint withPrim
((Module ss coms _ elaborated exps, env'), nextVar) <- runSupplyT 0 $ do
- [desugared] <- desugar externs [withPrim]
- runCheck' (emptyCheckState env) $ typeCheckModule desugared
+ desugar externs [withPrim] >>= \case
+ [desugared] -> runCheck' (emptyCheckState env) $ typeCheckModule desugared
+ _ -> internalError "desugar did not return a singleton"
-- desugar case declarations *after* type- and exhaustiveness checking
-- since pattern guards introduces cases which the exhaustiveness checker
@@ -76,7 +80,21 @@ rebuildModule MakeActions{..} externs m@(Module _ _ moduleName _ _) = do
[renamed] = renameInModules [optimized]
exts = moduleToExternsFile mod' env'
ffiCodegen renamed
- evalSupplyT nextVar' . codegen renamed env' . encode $ exts
+
+ -- It may seem more obvious to write `docs <- Docs.convertModule m env' here,
+ -- but I have not done so for two reasons:
+ -- 1. This should never fail; any genuine errors in the code should have been
+ -- caught earlier in this function. Therefore if we do fail here it indicates
+ -- a bug in the compiler, which should be reported as such.
+ -- 2. We do not want to perform any extra work generating docs unless the
+ -- user has asked for docs to be generated.
+ let docs = case Docs.convertModule externs env' m of
+ Left errs -> internalError $
+ "Failed to produce docs for " ++ T.unpack (runModuleName moduleName)
+ ++ "; details:\n" ++ prettyPrintMultipleErrors defaultPPEOptions errs
+ Right d -> d
+
+ evalSupplyT nextVar' . codegen renamed docs . encode $ exts
return exts
-- | Compiles in "make" mode, compiling each module separately to a @.js@ file and an @externs.json@ file.
@@ -85,19 +103,23 @@ rebuildModule MakeActions{..} externs m@(Module _ _ moduleName _ _) = do
-- having to typecheck the module again.
make :: forall m. (Monad m, MonadBaseControl IO m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
=> MakeActions m
- -> [Module]
+ -> [CST.PartialResult Module]
-> m [ExternsFile]
make ma@MakeActions{..} ms = do
checkModuleNames
- (sorted, graph) <- sortModules ms
+ (sorted, graph) <- sortModules (moduleSignature . CST.resPartial) ms
buildPlan <- BuildPlan.construct ma (sorted, graph)
- let toBeRebuilt = filter (BuildPlan.needsRebuild buildPlan . getModuleName) sorted
+ let toBeRebuilt = filter (BuildPlan.needsRebuild buildPlan . getModuleName . CST.resPartial) sorted
for_ toBeRebuilt $ \m -> fork $ do
- let deps = fromMaybe (internalError "make: module not found in dependency graph.") (lookup (getModuleName m) graph)
- buildModule buildPlan (importPrim m) (deps `inOrderOf` map getModuleName sorted)
+ let moduleName = getModuleName . CST.resPartial $ m
+ let deps = fromMaybe (internalError "make: module not found in dependency graph.") (lookup moduleName graph)
+ buildModule buildPlan moduleName
+ (spanName . getModuleSourceSpan . CST.resPartial $ m)
+ (importPrim <$> CST.resFull m)
+ (deps `inOrderOf` map (getModuleName . CST.resPartial) sorted)
-- Wait for all threads to complete, and collect errors.
errors <- BuildPlan.collectErrors buildPlan
@@ -112,7 +134,7 @@ make ma@MakeActions{..} ms = do
-- so they can be folded into an Environment. This result is used in the tests
-- and in PSCI.
let lookupResult mn = fromMaybe (internalError "make: module not found in results") (M.lookup mn results)
- return (map (lookupResult . getModuleName) sorted)
+ return (map (lookupResult . getModuleName . CST.resPartial) sorted)
where
checkModuleNames :: m ()
@@ -121,18 +143,18 @@ make ma@MakeActions{..} ms = do
checkNoPrim :: m ()
checkNoPrim =
for_ ms $ \m ->
- let mn = getModuleName m
+ let mn = getModuleName $ CST.resPartial m
in when (isBuiltinModuleName mn) $
throwError
- . errorMessage' (getModuleSourceSpan m)
+ . errorMessage' (getModuleSourceSpan $ CST.resPartial m)
$ CannotDefinePrimModules mn
checkModuleNamesAreUnique :: m ()
checkModuleNamesAreUnique =
- for_ (findDuplicates getModuleName ms) $ \mss ->
+ for_ (findDuplicates (getModuleName . CST.resPartial) ms) $ \mss ->
throwError . flip foldMap mss $ \ms' ->
- let mn = getModuleName (NEL.head ms')
- in errorMessage'' (fmap getModuleSourceSpan ms') $ DuplicateModule mn
+ let mn = getModuleName . CST.resPartial . NEL.head $ ms'
+ in errorMessage'' (fmap (getModuleSourceSpan . CST.resPartial) ms') $ DuplicateModule mn
-- Find all groups of duplicate values in a list based on a projection.
findDuplicates :: Ord b => (a -> b) -> [a] -> Maybe [NEL.NonEmpty a]
@@ -145,8 +167,9 @@ make ma@MakeActions{..} ms = do
inOrderOf :: (Ord a) => [a] -> [a] -> [a]
inOrderOf xs ys = let s = S.fromList xs in filter (`S.member` s) ys
- buildModule :: BuildPlan -> Module -> [ModuleName] -> m ()
- buildModule buildPlan m@(Module _ _ moduleName _ _) deps = flip catchError (complete Nothing . Just) $ do
+ buildModule :: BuildPlan -> ModuleName -> FilePath -> Either (NEL.NonEmpty CST.ParserError) Module -> [ModuleName] -> m ()
+ buildModule buildPlan moduleName fp mres deps = flip catchError (complete Nothing . Just) $ do
+ m <- CST.unwrapParserError fp mres
-- We need to wait for dependencies to be built, before checking if the current
-- module should be rebuilt, so the first thing to do is to wait on the
-- MVars for the module's dependencies.
diff --git a/src/Language/PureScript/Make/Actions.hs b/src/Language/PureScript/Make/Actions.hs
index f7c6d5e..8b54765 100644
--- a/src/Language/PureScript/Make/Actions.hs
+++ b/src/Language/PureScript/Make/Actions.hs
@@ -17,6 +17,7 @@ import Control.Monad.Supply
import Control.Monad.Trans.Class (MonadTrans(..))
import Control.Monad.Writer.Class (MonadWriter(..))
import Data.Aeson (encode)
+import Data.Bifunctor (bimap)
import qualified Data.ByteString.Lazy as B
import qualified Data.ByteString.Lazy as LB
import qualified Data.ByteString.Lazy.UTF8 as LBU8
@@ -39,20 +40,19 @@ import qualified Language.PureScript.CoreFn as CF
import qualified Language.PureScript.CoreFn.ToJSON as CFJ
import qualified Language.PureScript.CoreImp.AST as Imp
import Language.PureScript.Crash
-import Language.PureScript.Environment
+import qualified Language.PureScript.CST as CST
+import qualified Language.PureScript.Docs.Types as Docs
import Language.PureScript.Errors
import Language.PureScript.Make.Monad
import Language.PureScript.Names
import Language.PureScript.Names (runModuleName, ModuleName)
import Language.PureScript.Options hiding (codegenTargets)
-import qualified Language.PureScript.Parser as PSParser
import Language.PureScript.Pretty.Common (SMap(..))
import qualified Paths_purescript as Paths
import SourceMap
import SourceMap.Types
import System.Directory (doesFileExist, getModificationTime, createDirectoryIfMissing, getCurrentDirectory)
import System.FilePath ((</>), takeDirectory, makeRelative, splitPath, normalise)
-import qualified Text.Parsec as Parsec
-- | Determines when to rebuild a module
data RebuildPolicy
@@ -94,7 +94,7 @@ data MakeActions m = MakeActions
, readExterns :: ModuleName -> m (FilePath, Externs)
-- ^ Read the externs file for a module as a string and also return the actual
-- path for the file.
- , codegen :: CF.Module CF.Ann -> Environment -> Externs -> SupplyT m ()
+ , codegen :: CF.Module CF.Ann -> Docs.Module -> Externs -> SupplyT m ()
-- ^ Run the code generator for the module and write any required output files.
, ffiCodegen :: CF.Module CF.Ann -> m ()
-- ^ Check ffi and print it in the output directory.
@@ -134,6 +134,7 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
JS -> outputFilename mn "index.js"
JSSourceMap -> outputFilename mn "index.js.map"
CoreFn -> outputFilename mn "corefn.json"
+ Docs -> outputFilename mn "docs.json"
getOutputTimestamp :: ModuleName -> Make (Maybe UTCTime)
getOutputTimestamp mn = do
@@ -147,8 +148,8 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
let path = outputDir </> T.unpack (runModuleName mn) </> "externs.json"
(path, ) <$> readTextFile path
- codegen :: CF.Module CF.Ann -> Environment -> Externs -> SupplyT Make ()
- codegen m _ exts = do
+ codegen :: CF.Module CF.Ann -> Docs.Module -> Externs -> SupplyT Make ()
+ codegen m docs exts = do
let mn = CF.moduleName m
lift $ writeTextFile (outputFilename mn "externs.json") exts
codegenTargets <- lift $ asks optionsCodegenTargets
@@ -177,6 +178,8 @@ buildMakeActions outputDir filePathMap foreigns usePrefix =
lift $ do
writeTextFile jsFile (B.fromStrict $ TE.encodeUtf8 $ js <> mapRef)
when sourceMaps $ genSourceMap dir mapFile (length prefix) mappings
+ when (S.member Docs codegenTargets) $ do
+ lift $ writeTextFile (outputFilename mn "docs.json") (encode docs)
ffiCodegen :: CF.Module CF.Ann -> Make ()
ffiCodegen m = do
@@ -288,8 +291,8 @@ checkForeignDecls m path = do
-- We ignore the error message here, just being told it's an invalid
-- identifier should be enough.
parseIdent :: String -> Either String Ident
- parseIdent str = try (T.pack str)
- where
- try s = either (const (Left str)) Right $ do
- ts <- PSParser.lex "" s
- PSParser.runTokenParser "" (PSParser.parseIdent <* Parsec.eof) ts
+ parseIdent str =
+ bimap (const str) (Ident . CST.getIdent . CST.nameValue)
+ . CST.runTokenParser CST.parseIdent
+ . CST.lex
+ $ T.pack str
diff --git a/src/Language/PureScript/Make/BuildPlan.hs b/src/Language/PureScript/Make/BuildPlan.hs
index a60bcd3..7f728f2 100644
--- a/src/Language/PureScript/Make/BuildPlan.hs
+++ b/src/Language/PureScript/Make/BuildPlan.hs
@@ -10,22 +10,23 @@ module Language.PureScript.Make.BuildPlan
import Prelude
+import Control.Concurrent.Async.Lifted as A
import Control.Concurrent.Lifted as C
import Control.Monad hiding (sequence)
+import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Control (MonadBaseControl(..))
-import Data.Aeson (decode)
+import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
+import Data.Foldable (foldl')
import qualified Data.Map as M
import Data.Maybe (catMaybes, fromMaybe)
-import qualified Data.Text as T
import Data.Time.Clock (UTCTime)
-import Data.Version (showVersion)
import Language.PureScript.AST
import Language.PureScript.Crash
+import qualified Language.PureScript.CST as CST
import Language.PureScript.Errors
import Language.PureScript.Externs
import Language.PureScript.Make.Actions as Actions
import Language.PureScript.Names (ModuleName)
-import qualified Paths_purescript as Paths
-- | The BuildPlan tracks information about our build progress, and holds all
-- prebuilt modules for incremental builds.
@@ -105,56 +106,50 @@ getResult buildPlan moduleName =
construct
:: forall m. (Monad m, MonadBaseControl IO m)
=> MakeActions m
- -> ([Module], [(ModuleName, [ModuleName])])
+ -> ([CST.PartialResult Module], [(ModuleName, [ModuleName])])
-> m BuildPlan
construct MakeActions{..} (sorted, graph) = do
- prebuilt <- foldM findExistingExtern M.empty sorted
- let toBeRebuilt = filter (not . flip M.member prebuilt . getModuleName) sorted
- buildJobs <- foldM makeBuildJob M.empty (map getModuleName toBeRebuilt)
+ prebuilt <- foldl' collectPrebuiltModules M.empty . catMaybes <$> A.forConcurrently sorted findExistingExtern
+ let toBeRebuilt = filter (not . flip M.member prebuilt . getModuleName . CST.resPartial) sorted
+ buildJobs <- foldM makeBuildJob M.empty (map (getModuleName . CST.resPartial) toBeRebuilt)
pure $ BuildPlan prebuilt buildJobs
where
makeBuildJob prev moduleName = do
buildJob <- BuildJob <$> C.newEmptyMVar <*> C.newEmptyMVar
pure (M.insert moduleName buildJob prev)
- findExistingExtern :: M.Map ModuleName Prebuilt -> Module -> m (M.Map ModuleName Prebuilt)
- findExistingExtern prev (getModuleName -> moduleName) = do
- outputTimestamp <- getOutputTimestamp moduleName
- let deps = fromMaybe (internalError "make: module not found in dependency graph.") (lookup moduleName graph)
- case traverse (fmap pbModificationTime . flip M.lookup prev) deps of
- Nothing ->
- -- If we end up here, one of the dependencies didn't exist in the
- -- prebuilt map and so we know a dependency needs to be rebuilt, which
- -- means we need to be rebuilt in turn.
- pure prev
- Just modTimes -> do
- let dependencyTimestamp = maximumMaybe modTimes
- inputTimestamp <- getInputTimestamp moduleName
- let
- existingExtern = case (inputTimestamp, dependencyTimestamp, outputTimestamp) of
- (Right (Just t1), Just t3, Just t2) ->
- if t1 > t2 || t3 > t2 then Nothing else Just t2
- (Right (Just t1), Nothing, Just t2) ->
- if t1 > t2 then Nothing else Just t2
- (Left RebuildNever, _, Just t2) ->
- Just t2
- _ ->
- Nothing
- case existingExtern of
- Nothing -> pure prev
- Just outputTime -> do
- mexts <- decodeExterns . snd <$> readExterns moduleName
- case mexts of
- Just exts ->
- pure (M.insert moduleName (Prebuilt outputTime exts) prev)
- Nothing -> pure prev
+ findExistingExtern :: CST.PartialResult Module -> m (Maybe (ModuleName, Bool, Prebuilt))
+ findExistingExtern (getModuleName . CST.resPartial -> moduleName) = runMaybeT $ do
+ inputTimestamp <- lift $ getInputTimestamp moduleName
+ (rebuildNever, existingTimestamp) <-
+ case inputTimestamp of
+ Left RebuildNever ->
+ fmap (True,) $ MaybeT $ getOutputTimestamp moduleName
+ Right (Just t1) -> do
+ outputTimestamp <- MaybeT $ getOutputTimestamp moduleName
+ guard (t1 < outputTimestamp)
+ pure (False, outputTimestamp)
+ _ -> mzero
+ externsFile <- MaybeT $ decodeExterns . snd <$> readExterns moduleName
+ pure (moduleName, rebuildNever, Prebuilt existingTimestamp externsFile)
+
+ collectPrebuiltModules :: M.Map ModuleName Prebuilt -> (ModuleName, Bool, Prebuilt) -> M.Map ModuleName Prebuilt
+ collectPrebuiltModules prev (moduleName, rebuildNever, pb)
+ | rebuildNever = M.insert moduleName pb prev
+ | otherwise = do
+ let deps = fromMaybe (internalError "make: module not found in dependency graph.") (lookup moduleName graph)
+ case traverse (fmap pbModificationTime . flip M.lookup prev) deps of
+ Nothing ->
+ -- If we end up here, one of the dependencies didn't exist in the
+ -- prebuilt map and so we know a dependency needs to be rebuilt, which
+ -- means we need to be rebuilt in turn.
+ prev
+ Just modTimes ->
+ case maximumMaybe modTimes of
+ Just depModTime | pbModificationTime pb < depModTime ->
+ prev
+ _ -> M.insert moduleName pb prev
maximumMaybe :: Ord a => [a] -> Maybe a
maximumMaybe [] = Nothing
maximumMaybe xs = Just $ maximum xs
-
-decodeExterns :: Externs -> Maybe ExternsFile
-decodeExterns bs = do
- externs <- decode bs
- guard $ T.unpack (efVersion externs) == showVersion Paths.version
- return externs
diff --git a/src/Language/PureScript/ModuleDependencies.hs b/src/Language/PureScript/ModuleDependencies.hs
index 1bd39e7..5a5d12f 100644
--- a/src/Language/PureScript/ModuleDependencies.hs
+++ b/src/Language/PureScript/ModuleDependencies.hs
@@ -2,52 +2,62 @@
module Language.PureScript.ModuleDependencies
( sortModules
, ModuleGraph
+ , ModuleSignature(..)
+ , moduleSignature
) where
import Protolude hiding (head)
import Data.Graph
-import Data.List.NonEmpty (NonEmpty((:|)))
import qualified Data.Set as S
import Language.PureScript.AST
import qualified Language.PureScript.Constants as C
import Language.PureScript.Crash
-import Language.PureScript.Errors
+import Language.PureScript.Errors hiding (nonEmpty)
import Language.PureScript.Names
-- | A list of modules with their transitive dependencies
type ModuleGraph = [(ModuleName, [ModuleName])]
+-- | A module signature for sorting dependencies.
+data ModuleSignature = ModuleSignature
+ { sigSourceSpan :: SourceSpan
+ , sigModuleName :: ModuleName
+ , sigImports :: [(ModuleName, SourceSpan)]
+ }
+
-- | Sort a collection of modules based on module dependencies.
--
-- Reports an error if the module graph contains a cycle.
sortModules
- :: forall m
+ :: forall m a
. MonadError MultipleErrors m
- => [Module]
- -> m ([Module], ModuleGraph)
-sortModules ms = do
- let mns = S.fromList $ map getModuleName ms
- verts <- parU ms (toGraphNode mns)
- ms' <- parU (stronglyConnComp verts) toModule
+ => (a -> ModuleSignature)
+ -> [a]
+ -> m ([a], ModuleGraph)
+sortModules toSig ms = do
+ let
+ ms' = (\m -> (m, toSig m)) <$> ms
+ mns = S.fromList $ map (sigModuleName . snd) ms'
+ verts <- parU ms' (toGraphNode mns)
+ ms'' <- parU (stronglyConnComp verts) toModule
let (graph, fromVertex, toVertex) = graphFromEdges verts
moduleGraph = do (_, mn, _) <- verts
let v = fromMaybe (internalError "sortModules: vertex not found") (toVertex mn)
deps = reachable graph v
toKey i = case fromVertex i of (_, key, _) -> key
return (mn, filter (/= mn) (map toKey deps))
- return (ms', moduleGraph)
+ return (fst <$> ms'', moduleGraph)
where
- toGraphNode :: S.Set ModuleName -> Module -> m (Module, ModuleName, [ModuleName])
- toGraphNode mns m@(Module _ _ mn ds _) = do
- let deps = ordNub (mapMaybe usedModules ds)
+ toGraphNode :: S.Set ModuleName -> (a, ModuleSignature) -> m ((a, ModuleSignature), ModuleName, [ModuleName])
+ toGraphNode mns m@(_, ModuleSignature _ mn deps) = do
void . parU deps $ \(dep, pos) ->
when (dep `notElem` C.primModules && S.notMember dep mns) .
throwError
. addHint (ErrorInModule mn)
. errorMessage' pos
$ ModuleNotFound dep
- pure (m, getModuleName m, map fst deps)
+ pure (m, mn, map fst deps)
-- | Calculate a list of used modules based on explicit imports and qualified names.
usedModules :: Declaration -> Maybe (ModuleName, SourceSpan)
@@ -57,11 +67,16 @@ 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 :: MonadError MultipleErrors m => SCC (a, ModuleSignature) -> m (a, ModuleSignature)
toModule (AcyclicSCC m) = return m
-toModule (CyclicSCC []) = internalError "toModule: empty CyclicSCC"
-toModule (CyclicSCC [m]) = return m
-toModule (CyclicSCC (m : ms)) =
- throwError
- . errorMessage'' (fmap getModuleSourceSpan (m :| ms))
- $ CycleInModules (map getModuleName ms)
+toModule (CyclicSCC ms) =
+ case nonEmpty ms of
+ Nothing ->
+ internalError "toModule: empty CyclicSCC"
+ Just ms' ->
+ throwError
+ . errorMessage'' (fmap (sigSourceSpan . snd) ms')
+ $ CycleInModules (map (sigModuleName . snd) ms)
+
+moduleSignature :: Module -> ModuleSignature
+moduleSignature (Module ss _ mn ds _) = ModuleSignature ss mn (ordNub (mapMaybe usedModules ds))
diff --git a/src/Language/PureScript/Options.hs b/src/Language/PureScript/Options.hs
index 1de91c9..323cdcc 100644
--- a/src/Language/PureScript/Options.hs
+++ b/src/Language/PureScript/Options.hs
@@ -20,7 +20,7 @@ data Options = Options
defaultOptions :: Options
defaultOptions = Options False False (S.singleton JS)
-data CodegenTarget = JS | JSSourceMap | CoreFn
+data CodegenTarget = JS | JSSourceMap | CoreFn | Docs
deriving (Eq, Ord, Show)
codegenTargets :: Map String CodegenTarget
@@ -28,4 +28,5 @@ codegenTargets = Map.fromList
[ ("js", JS)
, ("sourcemaps", JSSourceMap)
, ("corefn", CoreFn)
+ , ("docs", Docs)
]
diff --git a/src/Language/PureScript/Parser.hs b/src/Language/PureScript/Parser.hs
deleted file mode 100644
index c7ac55a..0000000
--- a/src/Language/PureScript/Parser.hs
+++ /dev/null
@@ -1,23 +0,0 @@
--- |
--- A collection of parsers for core data types:
---
--- [@Language.PureScript.Parser.Kinds@] Parser for kinds
---
--- [@Language.PureScript.Parser.Values@] Parser for values
---
--- [@Language.PureScript.Parser.Types@] Parser for types
---
--- [@Language.PureScript.Parser.Declaration@] Parsers for declarations and modules
---
--- [@Language.PureScript.Parser.State@] Parser state, including indentation
---
--- [@Language.PureScript.Parser.Common@] Common parsing utility functions
---
-module Language.PureScript.Parser (module P) where
-
-import Language.PureScript.Parser.Common as P
-import Language.PureScript.Parser.Declarations as P
-import Language.PureScript.Parser.Kinds as P
-import Language.PureScript.Parser.Lexer as P
-import Language.PureScript.Parser.State as P
-import Language.PureScript.Parser.Types as P
diff --git a/src/Language/PureScript/Parser/Common.hs b/src/Language/PureScript/Parser/Common.hs
deleted file mode 100644
index 0b430ba..0000000
--- a/src/Language/PureScript/Parser/Common.hs
+++ /dev/null
@@ -1,160 +0,0 @@
--- | Useful common functions for building parsers
-module Language.PureScript.Parser.Common where
-
-import Prelude.Compat
-
-import Control.Applicative ((<|>))
-import Control.Monad (guard)
-import Data.Maybe (fromMaybe)
-import Data.Text (Text)
-import qualified Data.Text as T
-import Language.PureScript.AST.SourcePos
-import Language.PureScript.Comments
-import Language.PureScript.Names
-import Language.PureScript.Parser.Lexer
-import Language.PureScript.Parser.State
-import Language.PureScript.PSString (PSString, mkString)
-import qualified Text.Parsec as P
-
--- | Parse a general proper name.
-properName :: TokenParser (ProperName a)
-properName = ProperName <$> uname
-
--- | Parse a proper name for a type.
-typeName :: TokenParser (ProperName 'TypeName)
-typeName = ProperName <$> tyname
-
--- | Parse a proper name for a kind.
-kindName :: TokenParser (ProperName 'KindName)
-kindName = ProperName <$> kiname
-
--- | Parse a proper name for a data constructor.
-dataConstructorName :: TokenParser (ProperName 'ConstructorName)
-dataConstructorName = ProperName <$> dconsname
-
--- | Parse a module name
-moduleName :: TokenParser ModuleName
-moduleName = part []
- where
- part path = (do name <- ProperName <$> P.try qualifier
- part (path `snoc` name))
- <|> (ModuleName . snoc path . ProperName <$> mname)
- snoc path name = path ++ [name]
-
--- | Parse a qualified name, i.e. M.name or just name
-parseQualified :: TokenParser a -> TokenParser (Qualified a)
-parseQualified parser = part []
- where
- part path = (do name <- ProperName <$> P.try qualifier
- part (updatePath path name))
- <|> (Qualified (qual path) <$> P.try parser)
- updatePath path name = path ++ [name]
- qual path = if null path then Nothing else Just $ ModuleName path
-
--- | Parse an identifier.
-parseIdent :: TokenParser Ident
-parseIdent = Ident <$> identifier
-
--- | Parse a label, which may look like an identifier or a string
-parseLabel :: TokenParser PSString
-parseLabel = (mkString <$> lname) <|> stringLiteral
-
--- | Parse an operator.
-parseOperator :: TokenParser (OpName a)
-parseOperator = OpName <$> symbol
-
--- | Run the first parser, then match the second if possible, applying the specified function on a successful match
-augment :: P.Stream s m t => P.ParsecT s u m a -> P.ParsecT s u m b -> (a -> b -> a) -> P.ParsecT s u m a
-augment p q f = flip (maybe id $ flip f) <$> p <*> P.optionMaybe q
-
--- | Run the first parser, then match the second zero or more times, applying the specified function for each match
-fold :: P.ParsecT s u m a -> P.ParsecT s u m b -> (a -> b -> a) -> P.ParsecT s u m a
-fold first' more combine = do
- a <- first'
- bs <- P.many more
- return $ foldl combine a bs
-
--- | Build a parser from a smaller parser and a list of parsers for postfix operators
-buildPostfixParser :: P.Stream s m t => [a -> P.ParsecT s u m a] -> P.ParsecT s u m a -> P.ParsecT s u m a
-buildPostfixParser fs first' = do
- a <- first'
- go a
- where
- go a = do
- maybeA <- P.optionMaybe $ P.choice (map ($ a) fs)
- case maybeA of
- Nothing -> return a
- Just a' -> go a'
-
--- | Mark the current indentation level
-mark :: P.Parsec s ParseState a -> P.Parsec s ParseState a
-mark p = do
- current <- indentationLevel <$> P.getState
- pos <- P.sourceColumn <$> P.getPosition
- P.modifyState $ \st -> st { indentationLevel = pos }
- a <- p
- P.modifyState $ \st -> st { indentationLevel = current }
- return a
-
--- | Check that the current identation level matches a predicate
-checkIndentation
- :: (P.Column -> Text)
- -> (P.Column -> P.Column -> Bool)
- -> P.Parsec s ParseState ()
-checkIndentation mkMsg rel = do
- col <- P.sourceColumn <$> P.getPosition
- current <- indentationLevel <$> P.getState
- guard (col `rel` current) P.<?> T.unpack (mkMsg current)
-
--- | Check that the current indentation level is past the current mark
-indented :: P.Parsec s ParseState ()
-indented = checkIndentation (("indentation past column " <>) . (T.pack . show)) (>)
-
--- | Check that the current indentation level is at the same indentation as the current mark
-same :: P.Parsec s ParseState ()
-same = checkIndentation (("indentation at column " <>) . (T.pack . show)) (==)
-
--- | Read the comments from the the next token, without consuming it
-readComments :: P.Parsec [PositionedToken] u [Comment]
-readComments = P.lookAhead $ ptComments <$> P.anyToken
-
--- | Run a parser
-runTokenParser :: FilePath -> TokenParser a -> [PositionedToken] -> Either P.ParseError a
-runTokenParser filePath p = P.runParser p (ParseState 0) filePath
-
--- | Convert from Parsec sourcepos
-toSourcePos :: P.SourcePos -> SourcePos
-toSourcePos pos = SourcePos (P.sourceLine pos) (P.sourceColumn pos)
-
--- | Read source position information and comments
-withSourceSpan
- :: (SourceSpan -> [Comment] -> a -> b)
- -> P.Parsec [PositionedToken] u a
- -> P.Parsec [PositionedToken] u b
-withSourceSpan f p = do
- comments <- readComments
- start <- P.getPosition
- x <- p
- end <- P.getPosition
- input <- P.getInput
- let end' = case input of
- pt:_ -> ptPrevEndPos pt
- _ -> 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)
-
-withSourceSpanF
- :: P.Parsec [PositionedToken] u (SourceSpan -> a)
- -> P.Parsec [PositionedToken] u a
-withSourceSpanF = withSourceSpan (\ss _ f -> f ss)
diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs
deleted file mode 100644
index 33b9c0b..0000000
--- a/src/Language/PureScript/Parser/Declarations.hs
+++ /dev/null
@@ -1,665 +0,0 @@
--- | Parsers for module definitions and declarations
-module Language.PureScript.Parser.Declarations
- ( parseDeclaration
- , parseDeclarationRef
- , parseModule
- , parseModuleDeclaration
- , parseModulesFromFiles
- , parseModuleFromFile
- , parseValue
- , parseGuard
- , parseBinder
- , parseBinderNoParens
- , parseImportDeclaration'
- , parseLocalDeclaration
- , toPositionedError
- ) where
-
-import Prelude hiding (lex)
-import Protolude (ordNub)
-
-import Control.Applicative
-import Control.Arrow ((+++))
-import Control.Monad (foldM, join, zipWithM)
-import Control.Monad.Error.Class (MonadError(..))
-import Control.Parallel.Strategies (withStrategy, parList, rseq)
-import Data.Functor (($>))
-import Data.Maybe (fromMaybe)
-import qualified Data.Set as S
-import Data.Text (Text, pack)
-import Language.PureScript.AST
-import Language.PureScript.Environment
-import Language.PureScript.Errors
-import Language.PureScript.Kinds
-import Language.PureScript.Names
-import Language.PureScript.Parser.Common
-import Language.PureScript.Parser.Kinds
-import Language.PureScript.Parser.Lexer
-import Language.PureScript.Parser.Types
-import Language.PureScript.PSString (PSString, mkString)
-import Language.PureScript.Types
-import qualified Text.Parsec as P
-import qualified Text.Parsec.Expr as P
-
-kindedIdent :: TokenParser (Text, Maybe SourceKind)
-kindedIdent = (, Nothing) <$> identifier
- <|> parens ((,) <$> identifier <*> (Just <$> (indented *> doubleColon *> indented *> parseKind)))
-
-fields :: [Ident]
-fields = [ Ident ("value" <> pack (show (n :: Integer))) | n <- [0..] ]
-
-parseDataDeclaration :: TokenParser Declaration
-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
- flip P.sepBy1 pipe $ do
- ctorName <- dataConstructorName
- tys <- P.many (indented *> noWildcards parseTypeAtom)
- return (ctorName, zip fields tys)
- return $ \sa -> DataDeclaration sa dtype name tyArgs ctors
-
-parseTypeDeclaration :: TokenParser Declaration
-parseTypeDeclaration = withSourceAnnF $ do
- name <- P.try (parseIdent <* indented <* doubleColon)
- ty <- parsePolyType
- return $ \sa -> TypeDeclaration (TypeDeclarationData sa name ty)
-
-parseTypeSynonymDeclaration :: TokenParser Declaration
-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
- indented
- value <- parseValue
- whereClause <- P.optionMaybe $ do
- indented
- reserved "where"
- indented
- mark $ P.many1 (same *> parseLocalDeclaration)
- return $ maybe value (\ds -> Let FromWhere ds value) whereClause
-
-parseValueWithIdentAndBinders :: Ident -> [Binder] -> TokenParser (SourceAnn -> Declaration)
-parseValueWithIdentAndBinders ident bs = do
- value <- indented *> (
- (\v -> [MkUnguarded v]) <$> (equals *> withSourceSpan PositionedValue parseValueWithWhereClause) <|>
- P.many1 (GuardedExpr <$> parseGuard
- <*> (indented *> equals
- *> withSourceSpan PositionedValue parseValueWithWhereClause))
- )
- return $ \sa -> ValueDecl sa ident Public bs value
-
-parseValueDeclaration :: TokenParser Declaration
-parseValueDeclaration = withSourceAnnF $ do
- ident <- parseIdent
- binders <- P.many parseBinderNoParens
- parseValueWithIdentAndBinders ident binders
-
-parseLocalValueDeclaration :: TokenParser Declaration
-parseLocalValueDeclaration = withSourceAnnF .
- join $ go <$> parseBinder <*> P.many parseBinderNoParens
- where
- go :: Binder -> [Binder] -> TokenParser (SourceAnn -> Declaration)
- go (VarBinder _ ident) bs = parseValueWithIdentAndBinders ident bs
- go (PositionedBinder _ _ b) bs = go b bs
- 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 = 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 =
- (reserved "infixl" *> return Infixl) <|>
- (reserved "infixr" *> return Infixr) <|>
- (reserved "infix" *> return Infix)
-
-parseFixity :: TokenParser Fixity
-parseFixity = Fixity <$> parseAssociativity <*> (indented *> natural)
-
-parseFixityDeclaration :: TokenParser Declaration
-parseFixityDeclaration = withSourceAnnF $ do
- fixity <- parseFixity
- indented
- def <- (Right <$> typeFixity fixity) <|> (Left <$> valueFixity fixity)
- return $ \sa -> FixityDeclaration sa def
- where
- typeFixity fixity =
- TypeFixity fixity
- <$> (reserved "type" *> parseQualified typeName)
- <*> (reserved "as" *> parseOperator)
- valueFixity fixity =
- ValueFixity fixity
- <$> parseQualified ((Left <$> parseIdent) <|> (Right <$> dataConstructorName))
- <*> (reserved "as" *> parseOperator)
-
-parseImportDeclaration :: TokenParser Declaration
-parseImportDeclaration = withSourceAnnF $ do
- (mn, declType, asQ) <- parseImportDeclaration'
- return $ \sa -> ImportDeclaration sa mn declType asQ
-
-parseImportDeclaration' :: TokenParser (ModuleName, ImportDeclarationType, Maybe ModuleName)
-parseImportDeclaration' = do
- reserved "import"
- indented
- moduleName' <- moduleName
- declType <- reserved "hiding" *> qualifyingList Hiding <|> qualifyingList Explicit
- qName <- P.optionMaybe qualifiedName
- return (moduleName', declType, qName)
- where
- qualifiedName = reserved "as" *> moduleName
- qualifyingList expectedType = do
- declType <- P.optionMaybe (expectedType <$> (indented *> parens (commaSep parseDeclarationRef)))
- return $ fromMaybe Implicit declType
-
-parseDeclarationRef :: TokenParser DeclarationRef
-parseDeclarationRef =
- 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 $ \f -> f name (fromMaybe (Just []) dctors)
-
-parseTypeClassDeclaration :: TokenParser Declaration
-parseTypeClassDeclaration = withSourceAnnF $ do
- reserved "class"
- implies <- P.option [] . P.try $ do
- indented
- implies <- (return <$> parseConstraint) <|> parens (commaSep1 parseConstraint)
- lfatArrow
- return implies
- className <- indented *> properName
- idents <- P.many (indented *> kindedIdent)
- let parseNamedIdent = foldl (<|>) empty (zipWith (\(name, _) index -> lname' name $> index) idents [0..])
- parseFunctionalDependency =
- FunctionalDependency <$> P.many parseNamedIdent <* rarrow
- <*> P.many parseNamedIdent
- dependencies <- P.option [] (indented *> pipe *> commaSep1 parseFunctionalDependency)
- members <- P.option [] $ do
- indented *> reserved "where"
- indented *> mark (P.many (same *> parseTypeDeclaration))
- return $ \sa -> TypeClassDeclaration sa className idents implies dependencies members
-
-parseConstraint :: TokenParser SourceConstraint
-parseConstraint = withSourceAnnF $ do
- name <- parseQualified properName
- args <- P.many (noWildcards $ noForAll parseTypeAtom)
- return $ \ann -> Constraint ann name args Nothing
-
-parseInstanceDeclaration :: TokenParser (TypeInstanceBody -> Declaration)
-parseInstanceDeclaration = withSourceAnnF $ do
- reserved "instance"
- name <- parseIdent <* indented <* doubleColon
- 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 $ \sa -> TypeInstanceDeclaration sa [] 0 name (fromMaybe [] deps) className ty
-
-parseTypeInstanceDeclaration :: TokenParser Declaration
-parseTypeInstanceDeclaration = do
- instanceDecl <- parseInstanceDeclaration
- members <- P.option [] $ do
- indented *> reserved "where"
- indented *> mark (P.many (same *> declsInInstance))
- return $ instanceDecl (ExplicitInstance members)
- where
- declsInInstance :: TokenParser Declaration
- declsInInstance = P.choice
- [ parseTypeDeclaration
- , parseValueDeclaration
- ] P.<?> "type declaration or value declaration in instance"
-
-parseTypeInstanceChainDeclaration :: TokenParser [Declaration]
-parseTypeInstanceChainDeclaration = do
- instances <- P.sepBy1 parseTypeInstanceDeclaration (reserved "else")
- ensureSameTypeClass instances
- chainId <- traverse getTypeInstanceName instances
- zipWithM (setTypeInstanceChain chainId) instances [0..]
- where
- getTypeInstanceName :: Declaration -> TokenParser Ident
- getTypeInstanceName (TypeInstanceDeclaration _ _ _ name _ _ _ _) = return name
- getTypeInstanceName _ = P.unexpected "Found non-instance in chain declaration."
-
- setTypeInstanceChain :: [Ident] -> Declaration -> Integer -> TokenParser Declaration
- setTypeInstanceChain chain (TypeInstanceDeclaration sa _ _ n d c t b) index = return (TypeInstanceDeclaration sa chain index n d c t b)
- setTypeInstanceChain _ _ _ = P.unexpected "Found non-instance in chain declaration."
-
- getTypeInstanceClass :: Declaration -> TokenParser (Qualified (ProperName 'ClassName))
- getTypeInstanceClass (TypeInstanceDeclaration _ _ _ _ _ tc _ _) = return tc
- getTypeInstanceClass _ = P.unexpected "Found non-instance in chain declaration."
-
- ensureSameTypeClass :: [Declaration] -> TokenParser ()
- ensureSameTypeClass xs = do
- classNames <- ordNub <$> traverse getTypeInstanceClass xs
- case classNames of
- [_] -> return ()
- _ -> P.unexpected "All instances in a chain must implement the same type class."
-
-parseDerivingInstanceDeclaration :: TokenParser Declaration
-parseDerivingInstanceDeclaration = do
- reserved "derive"
- ty <- P.option DerivedInstance (reserved "newtype" $> NewtypeInstance)
- instanceDecl <- parseInstanceDeclaration
- return $ instanceDecl ty
-
--- | Parse a single declaration. May include a collection of instances in a chain.
-parseDeclaration :: TokenParser [Declaration]
-parseDeclaration =
- P.choice
- [ pure <$> parseDataDeclaration
- , pure <$> parseTypeDeclaration
- , pure <$> parseTypeSynonymDeclaration
- , pure <$> parseValueDeclaration
- , pure <$> parseExternDeclaration
- , pure <$> parseFixityDeclaration
- , pure <$> parseTypeClassDeclaration
- , parseTypeInstanceChainDeclaration
- , pure <$> parseDerivingInstanceDeclaration
- ] P.<?> "declaration"
-
-parseLocalDeclaration :: TokenParser Declaration
-parseLocalDeclaration =
- P.choice
- [ parseTypeDeclaration
- , parseLocalValueDeclaration
- ] P.<?> "local declaration"
-
--- | Parse a module declaration and its export declarations
-parseModuleDeclaration :: TokenParser (ModuleName, Maybe [DeclarationRef])
-parseModuleDeclaration = do
- reserved "module"
- indented
- name <- moduleName
- exports <- P.optionMaybe . parens $ commaSep1 parseDeclarationRef
- reserved "where"
- pure (name, exports)
-
--- | Parse a module header and a collection of declarations
-parseModule :: TokenParser Module
-parseModule = do
- comments <- readComments
- start <- P.getPosition
- (name, exports) <- parseModuleDeclaration
- decls <- mark $ do
- -- TODO: extract a module header structure here, and provide a
- -- parseModuleHeader function. This should allow us to speed up rebuilds
- -- by only parsing as far as the module header. See PR #2054.
- imports <- P.many (same *> parseImportDeclaration)
- decls <- join <$> P.many (same *> parseDeclaration)
- return (imports <> decls)
- _ <- P.eof
- end <- P.getPosition
- let ss = SourceSpan (P.sourceName start) (toSourcePos start) (toSourcePos end)
- return $ Module ss comments name decls exports
-
--- | Parse a collection of modules in parallel
-parseModulesFromFiles
- :: forall m k
- . MonadError MultipleErrors m
- => (k -> FilePath)
- -> [(k, Text)]
- -> m [(k, Module)]
-parseModulesFromFiles toFilePath input =
- flip parU wrapError . inParallel . flip fmap input $ parseModuleFromFile toFilePath
- where
- wrapError :: Either P.ParseError a -> m a
- wrapError = either (throwError . MultipleErrors . pure . toPositionedError) return
- -- It is enough to force each parse result to WHNF, since success or failure can't be
- -- determined until the end of the file, so this effectively distributes parsing of each file
- -- to a different spark.
- inParallel :: [Either P.ParseError (k, a)] -> [Either P.ParseError (k, a)]
- inParallel = withStrategy (parList rseq)
-
--- | Parses a single module with FilePath for eventual parsing errors
-parseModuleFromFile
- :: (k -> FilePath)
- -> (k, Text)
- -> Either P.ParseError (k, Module)
-parseModuleFromFile toFilePath (k, content) = do
- let filename = toFilePath k
- ts <- lex filename content
- m <- runTokenParser filename parseModule ts
- pure (k, m)
-
--- | Converts a 'ParseError' into a 'PositionedError'
-toPositionedError :: P.ParseError -> ErrorMessage
-toPositionedError perr = ErrorMessage [ positionedError (SourceSpan name start end) ] (ErrorParsingModule perr)
- where
- name = (P.sourceName . P.errorPos) perr
- start = (toSourcePos . P.errorPos) perr
- end = start
-
-booleanLiteral :: TokenParser Bool
-booleanLiteral = (reserved "true" >> return True) P.<|> (reserved "false" >> return False)
-
-parseNumericLiteral :: TokenParser (Literal a)
-parseNumericLiteral = NumericLiteral <$> number
-
-parseCharLiteral :: TokenParser (Literal a)
-parseCharLiteral = CharLiteral <$> charLiteral
-
-parseStringLiteral :: TokenParser (Literal a)
-parseStringLiteral = StringLiteral <$> stringLiteral
-
-parseBooleanLiteral :: TokenParser (Literal a)
-parseBooleanLiteral = BooleanLiteral <$> booleanLiteral
-
-parseArrayLiteral :: TokenParser a -> TokenParser (Literal a)
-parseArrayLiteral p = ArrayLiteral <$> squares (commaSep p)
-
-parseObjectLiteral :: TokenParser (PSString, a) -> TokenParser (Literal a)
-parseObjectLiteral p = ObjectLiteral <$> braces (commaSep p)
-
-parseIdentifierAndValue :: TokenParser (PSString, Expr)
-parseIdentifierAndValue =
- do
- (ss, name) <- indented *> withSourceSpan' (,) lname
- b <- P.option (Var ss $ Qualified Nothing (Ident name)) rest
- return (mkString name, b)
- <|> (,) <$> (indented *> stringLiteral) <*> rest
- where
- rest = indented *> colon *> indented *> parseValue
-
-parseAbs :: TokenParser Expr
-parseAbs = do
- symbol' "\\"
- args <- P.many1 (indented *> (Abs <$> parseBinderNoParens))
- indented *> rarrow
- value <- parseValue
- return $ toFunction args value
- where
- toFunction :: [Expr -> Expr] -> Expr -> Expr
- toFunction args value = foldr ($) value args
-
-parseVar :: TokenParser Expr
-parseVar = withSourceSpan' Var $ parseQualified parseIdent
-
-parseConstructor :: TokenParser Expr
-parseConstructor = withSourceSpan' Constructor $ parseQualified dataConstructorName
-
-parseCase :: TokenParser Expr
-parseCase = Case <$> P.between (reserved "case") (indented *> reserved "of") (commaSep1 parseValue)
- <*> (indented *> mark (P.many1 (same *> mark parseCaseAlternative)))
-
-parseCaseAlternative :: TokenParser CaseAlternative
-parseCaseAlternative = CaseAlternative <$> commaSep1 parseBinder
- <*> (indented *> (
- (pure . MkUnguarded) <$> (rarrow *> parseValue)
- <|> (P.many1 (GuardedExpr <$> parseGuard
- <*> (indented
- *> rarrow
- *> parseValue)
- ))))
- P.<?> "case alternative"
-
-parseIfThenElse :: TokenParser Expr
-parseIfThenElse = IfThenElse <$> (P.try (reserved "if") *> indented *> parseValue)
- <*> (indented *> reserved "then" *> indented *> parseValue)
- <*> (indented *> reserved "else" *> indented *> parseValue)
-
-parseLet :: TokenParser Expr
-parseLet = do
- reserved "let"
- indented
- ds <- mark $ P.many1 (same *> parseLocalDeclaration)
- indented
- reserved "in"
- result <- parseValue
- return $ Let FromLet ds result
-
-parseValueAtom :: TokenParser Expr
-parseValueAtom = withSourceSpan PositionedValue $ P.choice
- [ parseAnonymousArgument
- , withSourceSpan' Literal $ parseNumericLiteral
- , withSourceSpan' Literal $ parseCharLiteral
- , withSourceSpan' Literal $ parseStringLiteral
- , withSourceSpan' Literal $ parseBooleanLiteral
- , withSourceSpan' Literal $ parseArrayLiteral parseValue
- , withSourceSpan' Literal $ parseObjectLiteral parseIdentifierAndValue
- , parseAbs
- , P.try parseConstructor
- , P.try parseVar
- , parseCase
- , parseIfThenElse
- , parseDo
- , parseAdo
- , parseLet
- , P.try $ Parens <$> parens parseValue
- , withSourceSpan' Op $ parseQualified (parens parseOperator)
- , parseHole
- ]
-
--- | Parse an expression in backticks or an operator
-parseInfixExpr :: TokenParser Expr
-parseInfixExpr
- = P.between tick tick parseValue
- <|> withSourceSpan' Op (parseQualified parseOperator)
-
-parseHole :: TokenParser Expr
-parseHole = Hole <$> holeLit
-
-parsePropertyUpdate :: TokenParser (PSString, PathNode Expr)
-parsePropertyUpdate = do
- name <- parseLabel
- updates <- parseShallowUpdate <|> parseNestedUpdate
- return (name, updates)
- where
- parseShallowUpdate :: TokenParser (PathNode Expr)
- parseShallowUpdate = Leaf <$> (indented *> equals *> indented *> parseValue)
-
- parseNestedUpdate :: TokenParser (PathNode Expr)
- parseNestedUpdate = Branch <$> parseUpdaterBodyFields
-
-parseAccessor :: Expr -> TokenParser Expr
-parseAccessor (Constructor _ _) = P.unexpected "constructor"
-parseAccessor obj = P.try $ Accessor <$> (indented *> dot *> indented *> parseLabel) <*> pure obj
-
-parseDo :: TokenParser Expr
-parseDo = do
- m <- P.try (getQual <$> parseQualified (reserved "do")) <|> (reserved "do" *> pure Nothing)
- indented
- Do m <$> mark (P.many1 (same *> mark parseDoNotationElement))
-
-parseAdo :: TokenParser Expr
-parseAdo = do
- m <- P.try (getQual <$> parseQualified (reserved "ado")) <|> (reserved "ado" *> pure Nothing)
- indented
- elements <- mark (P.many (same *> mark parseDoNotationElement))
- yield <- mark (reserved "in" *> parseValue)
- pure $ Ado m elements yield
-
-parseDoNotationLet :: TokenParser DoNotationElement
-parseDoNotationLet = DoNotationLet <$> (reserved "let" *> indented *> mark (P.many1 (same *> parseLocalDeclaration)))
-
-parseDoNotationBind :: TokenParser DoNotationElement
-parseDoNotationBind = DoNotationBind <$> P.try (parseBinder <* indented <* larrow) <*> parseValue
-
-parseDoNotationElement :: TokenParser DoNotationElement
-parseDoNotationElement = withSourceSpan PositionedDoNotationElement $ P.choice
- [ parseDoNotationBind
- , parseDoNotationLet
- , DoNotationValue <$> parseValue
- ]
-
--- | Expressions including indexers and record updates
-indexersAndAccessors :: TokenParser Expr
-indexersAndAccessors = buildPostfixParser postfixTable parseValueAtom
- where
- postfixTable = [ parseAccessor
- , P.try . parseUpdaterBody
- ]
-
--- | Parse an expression
-parseValue :: TokenParser Expr
-parseValue =
- P.buildExpressionParser operators
- (buildPostfixParser postfixTable indexersAndAccessors)
- P.<?> "expression"
- where
- postfixTable = [ \v -> P.try (flip App <$> (indented *> indexersAndAccessors)) <*> pure v
- , \v -> flip (TypedValue True) <$> (indented *> doubleColon *> parsePolyType) <*> pure v
- ]
- operators = [ [ P.Prefix (indented *> withSourceSpan' (\ss _ -> UnaryMinus ss) (symbol' "-"))
- ]
- , [ P.Infix (P.try (indented *> parseInfixExpr P.<?> "infix expression") >>= \ident ->
- return (BinaryNoParens ident)) P.AssocRight
- ]
- ]
-
-parseUpdaterBodyFields :: TokenParser (PathTree Expr)
-parseUpdaterBodyFields = do
- updates <- indented *> braces (commaSep1 (indented *> parsePropertyUpdate))
- (_, tree) <- foldM insertUpdate (S.empty, []) updates
- return (PathTree (AssocList (reverse tree)))
- where
- insertUpdate (seen, xs) (key, node)
- | 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
-parseUpdaterBody v = ObjectUpdateNested v <$> parseUpdaterBodyFields
-
-parseAnonymousArgument :: TokenParser Expr
-parseAnonymousArgument = underscore *> pure AnonymousArgument
-
-parseNumberLiteral :: TokenParser Binder
-parseNumberLiteral = withSourceSpanF $
- (\n ss -> LiteralBinder ss (NumericLiteral n)) <$> (sign <*> number)
- where
- sign :: TokenParser (Either Integer Double -> Either Integer Double)
- sign = (symbol' "-" >> return (negate +++ negate))
- <|> (symbol' "+" >> return id)
- <|> return id
-
-parseNullaryConstructorBinder :: TokenParser Binder
-parseNullaryConstructorBinder = withSourceSpanF $
- (\name ss -> ConstructorBinder ss name [])
- <$> parseQualified dataConstructorName
-
-parseConstructorBinder :: TokenParser Binder
-parseConstructorBinder = withSourceSpanF $
- (\name args ss -> ConstructorBinder ss name args)
- <$> parseQualified dataConstructorName
- <*> many (indented *> parseBinderNoParens)
-
-parseObjectBinder:: TokenParser Binder
-parseObjectBinder = withSourceSpanF $
- flip LiteralBinder <$> parseObjectLiteral (indented *> parseEntry)
- where
- parseEntry :: TokenParser (PSString, Binder)
- parseEntry = var <|> (,) <$> stringLiteral <*> rest
- where
- var = withSourceSpanF $ do
- name <- lname
- b <- P.option (\ss -> VarBinder ss (Ident name)) (const <$> rest)
- return $ \ss -> (mkString name, b ss)
- rest = indented *> colon *> indented *> parseBinder
-
-parseArrayBinder :: TokenParser Binder
-parseArrayBinder = withSourceSpanF $
- flip LiteralBinder <$> parseArrayLiteral (indented *> parseBinder)
-
-parseVarOrNamedBinder :: TokenParser Binder
-parseVarOrNamedBinder = withSourceSpanF $ do
- name <- parseIdent
- let parseNamedBinder = (\b ss -> NamedBinder ss name b) <$> (at *> indented *> parseBinderAtom)
- parseNamedBinder <|> return (`VarBinder` name)
-
-parseNullBinder :: TokenParser Binder
-parseNullBinder = underscore *> return NullBinder
-
--- | Parse a binder
-parseBinder :: TokenParser Binder
-parseBinder =
- withSourceSpan
- PositionedBinder
- ( P.buildExpressionParser operators
- . buildPostfixParser postfixTable
- $ parseBinderAtom
- )
- where
- operators =
- [ [ P.Infix (P.try (indented *> parseOpBinder P.<?> "binder operator") >>= \op ->
- return (BinaryNoParensBinder op)) P.AssocRight
- ]
- ]
-
- postfixTable = [ \b -> flip TypedBinder b <$> (indented *> doubleColon *> parsePolyType) ]
-
- parseOpBinder :: TokenParser Binder
- parseOpBinder = withSourceSpan' OpBinder $ parseQualified parseOperator
-
-parseBinderAtom :: TokenParser Binder
-parseBinderAtom = withSourceSpan PositionedBinder
- (P.choice
- [ parseNullBinder
- , withSourceSpanF $ flip LiteralBinder <$> parseCharLiteral
- , withSourceSpanF $ flip LiteralBinder <$> parseStringLiteral
- , withSourceSpanF $ flip LiteralBinder <$> parseBooleanLiteral
- , parseNumberLiteral
- , parseVarOrNamedBinder
- , parseConstructorBinder
- , parseObjectBinder
- , parseArrayBinder
- , ParensInBinder <$> parens parseBinder
- ] P.<?> "binder")
-
--- | Parse a binder as it would appear in a top level declaration
-parseBinderNoParens :: TokenParser Binder
-parseBinderNoParens = withSourceSpan PositionedBinder
- (P.choice
- [ parseNullBinder
- , withSourceSpanF $ flip LiteralBinder <$> parseCharLiteral
- , withSourceSpanF $ flip LiteralBinder <$> parseStringLiteral
- , withSourceSpanF $ flip LiteralBinder <$> parseBooleanLiteral
- , parseNumberLiteral
- , parseVarOrNamedBinder
- , parseNullaryConstructorBinder
- , parseObjectBinder
- , parseArrayBinder
- , ParensInBinder <$> parens parseBinder
- ] P.<?> "binder")
-
--- | Parse a guard
-parseGuard :: TokenParser [Guard]
-parseGuard =
- pipe *> indented *> P.sepBy1 (parsePatternGuard <|> parseConditionGuard) comma
- where
- parsePatternGuard =
- PatternGuard <$> P.try (parseBinder <* indented <* larrow) <*> parseValue
- parseConditionGuard =
- ConditionGuard <$> parseValue
diff --git a/src/Language/PureScript/Parser/Kinds.hs b/src/Language/PureScript/Parser/Kinds.hs
deleted file mode 100644
index abdc810..0000000
--- a/src/Language/PureScript/Parser/Kinds.hs
+++ /dev/null
@@ -1,34 +0,0 @@
--- |
--- A parser for kinds
---
-module Language.PureScript.Parser.Kinds (parseKind) where
-
-import Prelude.Compat
-
-import Language.PureScript.Kinds
-import Language.PureScript.Parser.Common
-import Language.PureScript.Parser.Lexer
-
-import qualified Text.Parsec as P
-import qualified Text.Parsec.Expr as P
-
-parseNamedKind :: TokenParser SourceKind
-parseNamedKind = withSourceAnnF $ do
- name <- parseQualified kindName
- return $ \ann -> NamedKind ann name
-
-parseKindAtom :: TokenParser SourceKind
-parseKindAtom =
- indented *> P.choice
- [ parseNamedKind
- , parens parseKind
- ]
-
--- |
--- Parse a kind
---
-parseKind :: TokenParser SourceKind
-parseKind = P.buildExpressionParser operators parseKindAtom P.<?> "kind"
- where
- operators = [ [ P.Prefix (withSourceAnnF $ symbol' "#" >> return Row) ]
- , [ P.Infix (withSourceAnnF $ rarrow >> return FunKind) P.AssocRight ] ]
diff --git a/src/Language/PureScript/Parser/Lexer.hs b/src/Language/PureScript/Parser/Lexer.hs
deleted file mode 100644
index cc615ff..0000000
--- a/src/Language/PureScript/Parser/Lexer.hs
+++ /dev/null
@@ -1,610 +0,0 @@
--- |
--- The first step in the parsing process - turns source code into a list of lexemes
---
-module Language.PureScript.Parser.Lexer
- ( PositionedToken(..)
- , Token()
- , TokenParser()
- , lex
- , lexLenient
- , anyToken
- , token
- , match
- , lparen
- , rparen
- , parens
- , lbrace
- , rbrace
- , braces
- , lsquare
- , rsquare
- , squares
- , indent
- , indentAt
- , larrow
- , rarrow
- , lfatArrow
- , rfatArrow
- , colon
- , doubleColon
- , equals
- , pipe
- , tick
- , dot
- , comma
- , semi
- , at
- , underscore
- , holeLit
- , semiSep
- , semiSep1
- , commaSep
- , commaSep1
- , lname
- , lname'
- , qualifier
- , tyname
- , kiname
- , dconsname
- , uname
- , uname'
- , mname
- , reserved
- , symbol
- , symbol'
- , identifier
- , charLiteral
- , stringLiteral
- , number
- , natural
- , reservedPsNames
- , reservedTypeNames
- , isSymbolChar
- , isUnquotedKey
- )
- where
-
-import Prelude.Compat hiding (lex)
-
-import Control.Applicative ((<|>))
-import Control.Monad (void, guard)
-import Control.Monad.Identity (Identity)
-import Data.Char (isSpace, isAscii, isSymbol, isAlphaNum, isAlpha, isLower)
-import Data.String (fromString)
-import Data.Text (Text)
-import qualified Data.Text as T
-
-import Language.PureScript.Comments
-import Language.PureScript.Parser.State
-import Language.PureScript.PSString (PSString)
-
-import qualified Text.Parsec as P
-import qualified Text.Parsec.Token as PT
-
-data Token
- = LParen
- | RParen
- | LBrace
- | RBrace
- | LSquare
- | RSquare
- | Indent Int
- | LArrow
- | RArrow
- | LFatArrow
- | RFatArrow
- | Colon
- | DoubleColon
- | Equals
- | Pipe
- | Tick
- | Dot
- | Comma
- | Semi
- | At
- | Underscore
- | LName Text
- | UName Text
- | Qualifier Text
- | Symbol Text
- | CharLiteral Char
- | StringLiteral PSString
- | Number (Either Integer Double)
- | HoleLit Text
- deriving (Show, Eq, Ord)
-
-prettyPrintToken :: Token -> Text
-prettyPrintToken LParen = "("
-prettyPrintToken RParen = ")"
-prettyPrintToken LBrace = "{"
-prettyPrintToken RBrace = "}"
-prettyPrintToken LSquare = "["
-prettyPrintToken RSquare = "]"
-prettyPrintToken LArrow = "<-"
-prettyPrintToken RArrow = "->"
-prettyPrintToken LFatArrow = "<="
-prettyPrintToken RFatArrow = "=>"
-prettyPrintToken Colon = ":"
-prettyPrintToken DoubleColon = "::"
-prettyPrintToken Equals = "="
-prettyPrintToken Pipe = "|"
-prettyPrintToken Tick = "`"
-prettyPrintToken Dot = "."
-prettyPrintToken Comma = ","
-prettyPrintToken Semi = ";"
-prettyPrintToken At = "@"
-prettyPrintToken Underscore = "_"
-prettyPrintToken (Indent n) = "indentation at level " <> T.pack (show n)
-prettyPrintToken (LName s) = T.pack (show s)
-prettyPrintToken (UName s) = T.pack (show s)
-prettyPrintToken (Qualifier _) = "qualifier"
-prettyPrintToken (Symbol s) = s
-prettyPrintToken (CharLiteral c) = T.pack (show c)
-prettyPrintToken (StringLiteral s) = T.pack (show s)
-prettyPrintToken (Number n) = T.pack (either show show n)
-prettyPrintToken (HoleLit name) = "?" <> name
-
-data PositionedToken = PositionedToken
- { -- | Start position of this token
- ptSourcePos :: P.SourcePos
- -- | End position of this token (not including whitespace)
- , ptEndPos :: P.SourcePos
- -- | End position of the previous token
- , ptPrevEndPos :: Maybe P.SourcePos
- , ptToken :: Token
- , ptComments :: [Comment]
- } deriving (Eq)
-
--- Parsec requires this instance for various token-level combinators
-instance Show PositionedToken where
- show = T.unpack . prettyPrintToken . ptToken
-
-type Lexer u a = P.Parsec Text u a
-
-lex :: FilePath -> Text -> Either P.ParseError [PositionedToken]
-lex f s = updatePositions <$> P.parse parseTokens f s
-
-updatePositions :: [PositionedToken] -> [PositionedToken]
-updatePositions [] = []
-updatePositions (x:xs) = x : zipWith update (x:xs) xs
- where
- update PositionedToken { ptEndPos = pos } pt = pt { ptPrevEndPos = Just pos }
-
-parseTokens :: Lexer u [PositionedToken]
-parseTokens = whitespace *> P.many parsePositionedToken <* P.skipMany parseComment <* P.eof
-
--- | Lexes the given file, and on encountering a parse error, returns the
--- progress made up to that point, instead of returning an error
-lexLenient :: FilePath -> Text -> Either P.ParseError [PositionedToken]
-lexLenient f s = updatePositions <$> P.parse parseTokensLenient f s
-
-parseTokensLenient :: Lexer u [PositionedToken]
-parseTokensLenient = whitespace *> P.many parsePositionedToken <* P.skipMany parseComment
-
-whitespace :: Lexer u ()
-whitespace = P.skipMany (P.satisfy isSpace)
-
-parseComment :: Lexer u Comment
-parseComment = (BlockComment <$> blockComment <|> LineComment <$> lineComment) <* whitespace
- where
- blockComment :: Lexer u Text
- blockComment = P.try $ P.string "{-" *> (T.pack <$> P.manyTill P.anyChar (P.try (P.string "-}")))
-
- lineComment :: Lexer u Text
- lineComment = P.try $ P.string "--" *> (T.pack <$> P.manyTill P.anyChar (P.try (void (P.char '\n') <|> P.eof)))
-
-parsePositionedToken :: Lexer u PositionedToken
-parsePositionedToken = P.try $ do
- comments <- P.many parseComment
- pos <- P.getPosition
- tok <- parseToken
- pos' <- P.getPosition
- whitespace
- return $ PositionedToken pos pos' Nothing tok comments
-
-parseToken :: Lexer u Token
-parseToken = P.choice
- [ P.try $ P.string "<-" *> P.notFollowedBy symbolChar *> pure LArrow
- , P.try $ P.string "←" *> P.notFollowedBy symbolChar *> pure LArrow
- , P.try $ P.string "<=" *> P.notFollowedBy symbolChar *> pure LFatArrow
- , P.try $ P.string "⇐" *> P.notFollowedBy symbolChar *> pure LFatArrow
- , P.try $ P.string "->" *> P.notFollowedBy symbolChar *> pure RArrow
- , P.try $ P.string "→" *> P.notFollowedBy symbolChar *> pure RArrow
- , P.try $ P.string "=>" *> P.notFollowedBy symbolChar *> pure RFatArrow
- , P.try $ P.string "⇒" *> P.notFollowedBy symbolChar *> pure RFatArrow
- , P.try $ P.string "::" *> P.notFollowedBy symbolChar *> pure DoubleColon
- , P.try $ P.string "∷" *> P.notFollowedBy symbolChar *> pure DoubleColon
- , P.try $ P.char '(' *> pure LParen
- , P.try $ P.char ')' *> pure RParen
- , P.try $ P.char '{' *> pure LBrace
- , P.try $ P.char '}' *> pure RBrace
- , P.try $ P.char '[' *> pure LSquare
- , P.try $ P.char ']' *> pure RSquare
- , P.try $ P.char '`' *> pure Tick
- , P.try $ P.char ',' *> pure Comma
- , P.try $ P.char '=' *> P.notFollowedBy symbolChar *> pure Equals
- , P.try $ P.char ':' *> P.notFollowedBy symbolChar *> pure Colon
- , P.try $ P.char '|' *> P.notFollowedBy symbolChar *> pure Pipe
- , P.try $ P.char '.' *> P.notFollowedBy symbolChar *> pure Dot
- , P.try $ P.char ';' *> P.notFollowedBy symbolChar *> pure Semi
- , P.try $ P.char '@' *> P.notFollowedBy symbolChar *> pure At
- , P.try $ P.char '_' *> P.notFollowedBy identLetter *> pure Underscore
- , HoleLit <$> P.try (P.char '?' *> (T.pack <$> P.many1 identLetter))
- , LName <$> parseLName
- , parseUName >>= \uName ->
- guard (validModuleName uName) *> (Qualifier uName <$ P.char '.')
- <|> pure (UName uName)
- , Symbol <$> parseSymbol
- , CharLiteral <$> parseCharLiteral
- , StringLiteral <$> parseStringLiteral
- , Number <$> parseNumber
- ]
-
- where
- parseLName :: Lexer u Text
- parseLName = T.cons <$> identStart <*> (T.pack <$> P.many identLetter)
-
- parseUName :: Lexer u Text
- parseUName = T.cons <$> P.upper <*> (T.pack <$> P.many identLetter)
-
- parseSymbol :: Lexer u Text
- parseSymbol = T.pack <$> P.many1 symbolChar
-
- identStart :: Lexer u Char
- identStart = P.lower <|> P.oneOf "_"
-
- identLetter :: Lexer u Char
- identLetter = P.alphaNum <|> P.oneOf "_'"
-
- symbolChar :: Lexer u Char
- symbolChar = P.satisfy isSymbolChar
-
- parseCharLiteral :: Lexer u Char
- parseCharLiteral = P.try $ do {
- c <- PT.charLiteral tokenParser;
- if fromEnum c > 0xFFFF
- then P.unexpected "astral code point in character literal; characters must be valid UTF-16 code units"
- else return c
- }
-
- parseStringLiteral :: Lexer u PSString
- parseStringLiteral = fromString <$> (blockString <|> PT.stringLiteral tokenParser)
- where
- delimiter = P.try (P.string "\"\"\"")
- blockString = delimiter *> P.manyTill P.anyChar delimiter
-
- parseNumber :: Lexer u (Either Integer Double)
- parseNumber = (consumeLeadingZero *> P.parserZero) <|>
- (Right <$> P.try (PT.float tokenParser) <|>
- Left <$> P.try (PT.natural tokenParser))
- P.<?> "number"
- where
- -- lookAhead doesn't consume any input if its parser succeeds
- -- if notFollowedBy fails though, the consumed '0' will break the choice chain
- consumeLeadingZero = P.lookAhead (P.char '0' *>
- (P.notFollowedBy P.digit P.<?> "no leading zero in number literal"))
-
--- |
--- We use Text.Parsec.Token to implement the string and number lexemes
---
-langDef :: PT.GenLanguageDef Text u Identity
-langDef = PT.LanguageDef
- { PT.reservedNames = []
- , PT.reservedOpNames = []
- , PT.commentStart = ""
- , PT.commentEnd = ""
- , PT.commentLine = ""
- , PT.nestedComments = True
- , PT.identStart = P.parserFail "Identifiers not supported"
- , PT.identLetter = P.parserFail "Identifiers not supported"
- , PT.opStart = P.parserFail "Operators not supported"
- , PT.opLetter = P.parserFail "Operators not supported"
- , PT.caseSensitive = True
- }
-
--- |
--- A token parser based on the language definition
---
-tokenParser :: PT.GenTokenParser Text u Identity
-tokenParser = PT.makeTokenParser langDef
-
-type TokenParser a = P.Parsec [PositionedToken] ParseState a
-
-anyToken :: TokenParser PositionedToken
-anyToken = P.token (T.unpack . prettyPrintToken . ptToken) ptSourcePos Just
-
-token :: (Token -> Maybe a) -> TokenParser a
-token f = P.token (T.unpack . prettyPrintToken . ptToken) ptSourcePos (f . ptToken)
-
-match :: Token -> TokenParser ()
-match tok = token (\tok' -> if tok == tok' then Just () else Nothing) P.<?> T.unpack (prettyPrintToken tok)
-
-lparen :: TokenParser ()
-lparen = match LParen
-
-rparen :: TokenParser ()
-rparen = match RParen
-
-parens :: TokenParser a -> TokenParser a
-parens = P.between lparen rparen
-
-lbrace :: TokenParser ()
-lbrace = match LBrace
-
-rbrace :: TokenParser ()
-rbrace = match RBrace
-
-braces :: TokenParser a -> TokenParser a
-braces = P.between lbrace rbrace
-
-lsquare :: TokenParser ()
-lsquare = match LSquare
-
-rsquare :: TokenParser ()
-rsquare = match RSquare
-
-squares :: TokenParser a -> TokenParser a
-squares = P.between lsquare rsquare
-
-indent :: TokenParser Int
-indent = token go P.<?> "indentation"
- where
- go (Indent n) = Just n
- go _ = Nothing
-
-indentAt :: P.Column -> TokenParser ()
-indentAt n = token go P.<?> "indentation at level " ++ show n
- where
- go (Indent n') | n == n' = Just ()
- go _ = Nothing
-
-larrow :: TokenParser ()
-larrow = match LArrow
-
-rarrow :: TokenParser ()
-rarrow = match RArrow
-
-lfatArrow :: TokenParser ()
-lfatArrow = match LFatArrow
-
-rfatArrow :: TokenParser ()
-rfatArrow = match RFatArrow
-
-colon :: TokenParser ()
-colon = match Colon
-
-doubleColon :: TokenParser ()
-doubleColon = match DoubleColon
-
-equals :: TokenParser ()
-equals = match Equals
-
-pipe :: TokenParser ()
-pipe = match Pipe
-
-tick :: TokenParser ()
-tick = match Tick
-
-dot :: TokenParser ()
-dot = match Dot
-
-comma :: TokenParser ()
-comma = match Comma
-
-semi :: TokenParser ()
-semi = match Semi
-
-at :: TokenParser ()
-at = match At
-
-underscore :: TokenParser ()
-underscore = match Underscore
-
-holeLit :: TokenParser Text
-holeLit = token go P.<?> "hole literal"
- where
- go (HoleLit n) = Just n
- go _ = Nothing
-
--- |
--- Parse zero or more values separated by semicolons
---
-semiSep :: TokenParser a -> TokenParser [a]
-semiSep = flip P.sepBy semi
-
--- |
--- Parse one or more values separated by semicolons
---
-semiSep1 :: TokenParser a -> TokenParser [a]
-semiSep1 = flip P.sepBy1 semi
-
--- |
--- Parse zero or more values separated by commas
---
-commaSep :: TokenParser a -> TokenParser [a]
-commaSep = flip P.sepBy comma
-
--- |
--- Parse one or more values separated by commas
---
-commaSep1 :: TokenParser a -> TokenParser [a]
-commaSep1 = flip P.sepBy1 comma
-
-lname :: TokenParser Text
-lname = token go P.<?> "identifier"
- where
- go (LName s) = Just s
- go _ = Nothing
-
-lname' :: Text -> TokenParser ()
-lname' s = token go P.<?> show s
- where
- go (LName s') | s == s' = Just ()
- go _ = Nothing
-
-qualifier :: TokenParser Text
-qualifier = token go P.<?> "qualifier"
- where
- go (Qualifier s) = Just s
- go _ = Nothing
-
-reserved :: Text -> TokenParser ()
-reserved s = token go P.<?> show s
- where
- go (LName s') | s == s' = Just ()
- go (Symbol s') | s == s' = Just ()
- go _ = Nothing
-
-uname :: TokenParser Text
-uname = token go P.<?> "proper name"
- where
- go (UName s) | validUName s = Just s
- go _ = Nothing
-
-uname' :: Text -> TokenParser ()
-uname' s = token go P.<?> "proper name"
- where
- go (UName s') | s == s' = Just ()
- go _ = Nothing
-
-tyname :: TokenParser Text
-tyname = token go P.<?> "type name"
- where
- go (UName s) = Just s
- go _ = Nothing
-
-kiname :: TokenParser Text
-kiname = token go P.<?> "kind name"
- where
- go (UName s) = Just s
- go _ = Nothing
-
-dconsname :: TokenParser Text
-dconsname = token go P.<?> "data constructor name"
- where
- go (UName s) = Just s
- go _ = Nothing
-
-mname :: TokenParser Text
-mname = token go P.<?> "module name"
- where
- go (UName s) | validModuleName s = Just s
- go _ = Nothing
-
-symbol :: TokenParser Text
-symbol = token go P.<?> "symbol"
- where
- go (Symbol s) = Just s
- go Colon = Just ":"
- go LFatArrow = Just "<="
- go At = Just "@"
- go _ = Nothing
-
-symbol' :: Text -> TokenParser ()
-symbol' s = token go P.<?> show s
- where
- go (Symbol s') | s == s' = Just ()
- go Colon | s == ":" = Just ()
- go LFatArrow | s == "<=" = Just ()
- go _ = Nothing
-
-charLiteral :: TokenParser Char
-charLiteral = token go P.<?> "char literal"
- where
- go (CharLiteral c) = Just c
- go _ = Nothing
-
-stringLiteral :: TokenParser PSString
-stringLiteral = token go P.<?> "string literal"
- where
- go (StringLiteral s) = Just s
- go _ = Nothing
-
-number :: TokenParser (Either Integer Double)
-number = token go P.<?> "number"
- where
- go (Number n) = Just n
- go _ = Nothing
-
-natural :: TokenParser Integer
-natural = token go P.<?> "natural"
- where
- go (Number (Left n)) = Just n
- go _ = Nothing
-
-identifier :: TokenParser Text
-identifier = token go P.<?> "identifier"
- where
- go (LName s) | s `notElem` reservedPsNames = Just s
- go _ = Nothing
-
-validModuleName :: Text -> Bool
-validModuleName s = '_' `notElemT` s
-
-validUName :: Text -> Bool
-validUName s = '\'' `notElemT` s
-
-notElemT :: Char -> Text -> Bool
-notElemT c = not . T.any (== c)
-
--- |
--- A list of purescript reserved identifiers
---
-reservedPsNames :: [Text]
-reservedPsNames = [ "data"
- , "newtype"
- , "type"
- , "foreign"
- , "import"
- , "infixl"
- , "infixr"
- , "infix"
- , "class"
- , "instance"
- , "derive"
- , "module"
- , "case"
- , "of"
- , "if"
- , "then"
- , "else"
- , "do"
- , "ado"
- , "let"
- , "true"
- , "false"
- , "in"
- , "where"
- ]
-
-reservedTypeNames :: [Text]
-reservedTypeNames = [ "forall", "where" ]
-
--- |
--- The characters allowed for use in operators
---
-isSymbolChar :: Char -> Bool
-isSymbolChar c = (c `elem` (":!#$%&*+./<=>?@\\^|-~" :: [Char])) || (not (isAscii c) && isSymbol c)
-
-
--- |
--- The characters allowed in the head of an unquoted record key
---
-isUnquotedKeyHeadChar :: Char -> Bool
-isUnquotedKeyHeadChar c = (c == '_') || (isAlpha c && isLower c)
-
--- |
--- The characters allowed in the tail of an unquoted record key
---
-isUnquotedKeyTailChar :: Char -> Bool
-isUnquotedKeyTailChar c = (c `elem` ("_'" :: [Char])) || isAlphaNum c
-
--- |
--- Strings allowed to be left unquoted in a record key
---
-isUnquotedKey :: Text -> Bool
-isUnquotedKey t =
- case T.uncons t of
- Nothing -> False
- Just (hd, tl) -> isUnquotedKeyHeadChar hd &&
- T.all isUnquotedKeyTailChar tl
diff --git a/src/Language/PureScript/Parser/State.hs b/src/Language/PureScript/Parser/State.hs
deleted file mode 100644
index e72903f..0000000
--- a/src/Language/PureScript/Parser/State.hs
+++ /dev/null
@@ -1,18 +0,0 @@
--- |
--- State for the parser monad
---
-module Language.PureScript.Parser.State where
-
-import Prelude.Compat
-
-import qualified Text.Parsec as P
-
--- |
--- State for the parser monad
---
-data ParseState = ParseState {
- -- |
- -- The most recently marked indentation level
- --
- indentationLevel :: P.Column
- } deriving Show
diff --git a/src/Language/PureScript/Parser/Types.hs b/src/Language/PureScript/Parser/Types.hs
deleted file mode 100644
index 2bd34f6..0000000
--- a/src/Language/PureScript/Parser/Types.hs
+++ /dev/null
@@ -1,184 +0,0 @@
-module Language.PureScript.Parser.Types
- ( parseType
- , parsePolyType
- , noForAll
- , noWildcards
- , parseTypeAtom
- ) where
-
-import Prelude.Compat
-
-import Control.Monad (when, unless)
-import Control.Applicative ((<|>))
-import Data.Functor (($>))
-import qualified Data.Text as T
-
-import Language.PureScript.AST.SourcePos
-import Language.PureScript.Environment
-import Language.PureScript.Kinds
-import Language.PureScript.Parser.Common
-import Language.PureScript.Parser.Kinds
-import Language.PureScript.Parser.Lexer
-import Language.PureScript.Types
-import Language.PureScript.Label (Label(..))
-
-import qualified Text.Parsec as P
-import qualified Text.Parsec.Expr as P
-
-parseFunction :: TokenParser SourceType
-parseFunction = parens rarrow *> return tyFunction
-
-parseObject :: TokenParser SourceType
-parseObject = withSourceAnnF $ braces $ do
- rows <- parseRow
- return $ \ann -> TypeApp ann tyRecord rows
-
-parseTypeLevelString :: TokenParser SourceType
-parseTypeLevelString = withSourceAnnF $ flip TypeLevelString <$> stringLiteral
-
-parseTypeWildcard :: TokenParser SourceType
-parseTypeWildcard = withSourceAnnF $ do
- name <- Just <$> holeLit
- <|> Nothing <$ underscore
- return $ flip TypeWildcard name
-
-parseTypeVariable :: TokenParser SourceType
-parseTypeVariable = withSourceAnnF $ do
- ident <- identifier
- when (ident `elem` reservedTypeNames) $ P.unexpected (T.unpack ident)
- return $ \ann -> TypeVar ann ident
-
-parseTypeConstructor :: TokenParser SourceType
-parseTypeConstructor = withSourceAnnF $ flip TypeConstructor <$> parseQualified typeName
-
-parseForAll :: TokenParser SourceType
-parseForAll =
- mkForAll
- <$> ((reserved "forall" <|> reserved "∀")
- *> (P.many1 $ indented *> (withSourceAnnF $ flip (,) <$> identifier))
- <* indented <* dot)
- <*> parseType
-
--- |
--- Parse an atomic type with no `forall`
---
-noForAll :: TokenParser SourceType -> TokenParser SourceType
-noForAll p = do
- ty <- p
- when (containsForAll ty) $ P.unexpected "forall"
- return ty
-
--- |
--- Parse a type as it appears in e.g. a data constructor
---
-parseTypeAtom :: TokenParser SourceType
-parseTypeAtom = indented *> P.choice
- [ P.try parseFunction
- , parseTypeLevelString
- , parseObject
- , parseTypeWildcard
- , parseForAll
- , parseTypeVariable
- , parseTypeConstructor
- -- This try is needed due to some unfortunate ambiguities between rows and kinded types
- , P.try (parens parseRow)
- , parseParensInType
- ]
-
-parseParensInType :: TokenParser SourceType
-parseParensInType = withSourceAnnF $ flip ParensInType <$> parens parsePolyType
-
-parseConstrainedType :: TokenParser (SourceAnn, [SourceConstraint], SourceType)
-parseConstrainedType = withSourceAnnF $ do
- constraints <- parens (commaSep1 parseConstraint) <|> pure <$> parseConstraint
- _ <- rfatArrow
- indented
- ty <- parseType
- return (, constraints, ty)
- where
- parseConstraint = withSourceAnnF $ do
- className <- parseQualified properName
- indented
- ty <- P.many parseTypeAtom
- return $ \ann -> Constraint ann className ty Nothing
-
--- This is here to improve the error message when the user
--- tries to use the old style constraint contexts.
--- TODO: Remove this before 1.0
-typeOrConstrainedType :: TokenParser SourceType
-typeOrConstrainedType = do
- e <- P.try (Left <$> parseConstrainedType) <|> Right <$> parseTypeAtom
- case e of
- Left (ann, [c], ty) -> pure (ConstrainedType ann c ty)
- Left _ ->
- P.unexpected $
- unlines [ "comma in constraints."
- , ""
- , "Class constraints in type annotations can no longer be grouped in parentheses."
- , "Each constraint should now be separated by `=>`, for example:"
- , " `(Applicative f, Semigroup a) => a -> f a -> f a`"
- , " would now be written as:"
- , " `Applicative f => Semigroup a => a -> f a -> f a`."
- ]
- Right ty -> pure ty
-
-parseAnyType :: TokenParser SourceType
-parseAnyType = P.buildExpressionParser operators (buildPostfixParser postfixTable typeOrConstrainedType) P.<?> "type"
- where
- operators = [ [ P.Infix (return mkTypeApp) P.AssocLeft ]
- , [ P.Infix parseTypeOp P.AssocRight
- ]
- , [ P.Infix (rarrow $> function) P.AssocRight ]
- ]
- postfixTable = [ parseKindedType
- ]
-
- mkTypeApp lhs rhs =
- TypeApp (widenSourceAnn (getAnnForType lhs) (getAnnForType rhs)) lhs rhs
-
- parseTypeOp = withSourceAnnF $ do
- ident <- P.try (parseQualified parseOperator)
- return $ \ann lhs rhs ->
- BinaryNoParensType (widenSourceAnn (getAnnForType lhs) (getAnnForType rhs)) (TypeOp ann ident) lhs rhs
-
- parseKindedType ty = do
- kind <- indented *> doubleColon *> parseKind
- return $ KindedType (widenSourceAnn (getAnnForType ty) (getAnnForKind kind)) ty kind
-
-
--- |
--- Parse a monotype
---
-parseType :: TokenParser SourceType
-parseType = do
- ty <- parseAnyType
- unless (isMonoType ty) $ P.unexpected "polymorphic type"
- return ty
-
--- |
--- Parse a polytype
---
-parsePolyType :: TokenParser SourceType
-parsePolyType = parseAnyType
-
--- |
--- Parse an atomic type with no wildcards
---
-noWildcards :: TokenParser SourceType -> TokenParser SourceType
-noWildcards p = do
- ty <- p
- when (containsWildcards ty) $ P.unexpected "type wildcard"
- return ty
-
-parseRowListItem :: TokenParser SourceType -> TokenParser (RowListItem SourceAnn)
-parseRowListItem p = withSourceAnnF $
- (\name ty ann -> RowListItem ann name ty)
- <$> (indented *> (Label <$> parseLabel) <* indented <* doubleColon) <*> p
-
-parseRowEnding :: TokenParser SourceType
-parseRowEnding =
- (indented *> pipe *> indented *> parseType)
- <|> withSourceAnnF (return REmpty)
-
-parseRow :: TokenParser SourceType
-parseRow = (curry rowFromList <$> commaSep (parseRowListItem parsePolyType) <*> parseRowEnding) P.<?> "row"
diff --git a/src/Language/PureScript/Pretty/Common.hs b/src/Language/PureScript/Pretty/Common.hs
index d284597..87adc6f 100644
--- a/src/Language/PureScript/Pretty/Common.hs
+++ b/src/Language/PureScript/Pretty/Common.hs
@@ -14,7 +14,7 @@ import Data.Text (Text)
import qualified Data.Text as T
import Language.PureScript.AST (SourcePos(..), SourceSpan(..))
-import Language.PureScript.Parser.Lexer (isUnquotedKey)
+import Language.PureScript.CST.Lexer (isUnquotedKey)
import Text.PrettyPrint.Boxes hiding ((<>))
import qualified Text.PrettyPrint.Boxes as Box
diff --git a/src/Language/PureScript/Pretty/Types.hs b/src/Language/PureScript/Pretty/Types.hs
index 35445c3..aabd707 100644
--- a/src/Language/PureScript/Pretty/Types.hs
+++ b/src/Language/PureScript/Pretty/Types.hs
@@ -51,7 +51,7 @@ data PrettyPrintType
| PPKindedType PrettyPrintType (Kind ())
| PPBinaryNoParensType PrettyPrintType PrettyPrintType PrettyPrintType
| PPParensInType PrettyPrintType
- | PPForAll [Text] PrettyPrintType
+ | PPForAll [(Text, Maybe (Kind ()))] PrettyPrintType
| PPFunction PrettyPrintType PrettyPrintType
| PPRecord [(Label, PrettyPrintType)] (Maybe PrettyPrintType)
| PPRow [(Label, PrettyPrintType)] (Maybe PrettyPrintType)
@@ -62,7 +62,6 @@ type PrettyPrintConstraint = (Qualified (ProperName 'ClassName), [PrettyPrintTyp
convertPrettyPrintType :: Int -> Type a -> PrettyPrintType
convertPrettyPrintType = go
where
- go d _ | d < 0 = PPTruncated
go _ (TUnknown _ n) = PPTUnknown n
go _ (TypeVar _ t) = PPTypeVar t
go _ (TypeLevelString _ s) = PPTypeLevelString s
@@ -70,16 +69,20 @@ convertPrettyPrintType = go
go _ (TypeConstructor _ c) = PPTypeConstructor c
go _ (TypeOp _ o) = PPTypeOp o
go _ (Skolem _ t n _) = PPSkolem t n
- go d (ConstrainedType _ (Constraint _ cls args _) ty) = PPConstrainedType (cls, go (d-1) <$> args) (go (d-1) ty)
+ go _ (REmpty _) = PPRow [] Nothing
+ -- Guard the remaining "complex" type atoms on the current depth value. The
+ -- prior constructors can all be printed simply so it's not really helpful to
+ -- truncate them.
+ go d _ | d < 0 = PPTruncated
+ go d (ConstrainedType _ (Constraint _ cls args _) ty) = PPConstrainedType (cls, go (d-1) <$> args) (go d ty)
go d (KindedType _ ty k) = PPKindedType (go (d-1) ty) (k $> ())
go d (BinaryNoParensType _ ty1 ty2 ty3) = PPBinaryNoParensType (go (d-1) ty1) (go (d-1) ty2) (go (d-1) ty3)
go d (ParensInType _ ty) = PPParensInType (go (d-1) ty)
- go _ (REmpty _) = PPRow [] Nothing
go d ty@RCons{} = uncurry PPRow (goRow d ty)
- go d (ForAll _ v ty _) = goForAll d [v] ty
+ go d (ForAll _ v mbK ty _) = goForAll d [(v, fmap ($> ()) mbK)] ty
go d (TypeApp _ a b) = goTypeApp d a b
- goForAll d vs (ForAll _ v ty _) = goForAll d (v : vs) ty
+ goForAll d vs (ForAll _ v mbK ty _) = goForAll d ((v, fmap ($> ()) mbK) : vs) ty
goForAll d vs ty = PPForAll vs (go (d-1) ty)
goRow d ty =
@@ -194,7 +197,7 @@ matchType tro = buildPrettyPrinter operators (matchTypeAtom tro) where
OperatorTable [ [ AssocL typeApp $ \f x -> keepSingleLinesOr (moveRight 2) f x ]
, [ AssocR appliedFunction $ \arg ret -> keepSingleLinesOr id arg (text rightArrow <> " " <> ret) ]
, [ Wrap constrained $ \deps ty -> constraintsAsBox tro deps ty ]
- , [ Wrap forall_ $ \idents ty -> keepSingleLinesOr (moveRight 2) (text (forall' ++ " " ++ unwords idents ++ ".")) ty ]
+ , [ Wrap forall_ $ \idents ty -> keepSingleLinesOr (moveRight 2) (text (forall' ++ " " ++ unwords (fmap printMbKindedType idents) ++ ".")) ty ]
, [ Wrap kinded $ \k ty -> keepSingleLinesOr (moveRight 2) ty (text (doubleColon ++ " " ++ T.unpack (prettyPrintKind k))) ]
, [ Wrap explicitParens $ \_ ty -> ty ]
]
@@ -202,6 +205,7 @@ matchType tro = buildPrettyPrinter operators (matchTypeAtom tro) where
rightArrow = if troUnicode tro then "→" else "->"
forall' = if troUnicode tro then "∀" else "forall"
doubleColon = if troUnicode tro then "∷" else "::"
+ printMbKindedType (v, mbK) = maybe v (\k -> unwords ["(" ++ v, doubleColon, T.unpack (prettyPrintKind k) ++ ")"]) mbK
-- If both boxes span a single line, keep them on the same line, or else
-- use the specified function to modify the second box, then combine vertically.
@@ -210,10 +214,10 @@ matchType tro = buildPrettyPrinter operators (matchTypeAtom tro) where
| rows b1 > 1 || rows b2 > 1 = vcat left [ b1, f b2 ]
| otherwise = hcat top [ b1, text " ", b2]
-forall_ :: Pattern () PrettyPrintType ([String], PrettyPrintType)
+forall_ :: Pattern () PrettyPrintType ([(String, Maybe (Kind ()))], PrettyPrintType)
forall_ = mkPattern match
where
- match (PPForAll idents ty) = Just (map T.unpack idents, ty)
+ match (PPForAll idents ty) = Just (map (\(v, mbK) -> (T.unpack v, mbK)) idents, ty)
match _ = Nothing
typeAtomAsBox' :: PrettyPrintType -> Box
diff --git a/src/Language/PureScript/Publish.hs b/src/Language/PureScript/Publish.hs
index fc14959..812e0b4 100644
--- a/src/Language/PureScript/Publish.hs
+++ b/src/Language/PureScript/Publish.hs
@@ -57,6 +57,15 @@ data PublishOptions = PublishOptions
, publishGetTagTime :: Text -> PrepareM UTCTime
, -- | What to do when the working tree is dirty
publishWorkingTreeDirty :: PrepareM ()
+ , -- | Compiler output directory (which must include up-to-date docs.json
+ -- files for any modules we are producing docs for).
+ publishCompileOutputDir :: FilePath
+ , -- | Path to the manifest file; a JSON file including information about the
+ -- package, such as name, author, dependency version bounds.
+ publishManifestFile :: FilePath
+ , -- | Path to the resolutions file; a JSON file containing all of the
+ -- package's dependencies, their versions, and their paths on the disk.
+ publishResolutionsFile :: FilePath
}
defaultPublishOptions :: PublishOptions
@@ -64,20 +73,23 @@ defaultPublishOptions = PublishOptions
{ publishGetVersion = getVersionFromGitTag
, publishGetTagTime = getTagTime
, publishWorkingTreeDirty = userError DirtyWorkingTree
+ , publishCompileOutputDir = "output"
+ , publishManifestFile = "bower.json"
+ , publishResolutionsFile = "resolutions.json"
}
-- | Attempt to retrieve package metadata from the current directory.
-- Calls exitFailure if no package metadata could be retrieved.
-unsafePreparePackage :: FilePath -> FilePath -> PublishOptions -> IO D.UploadedPackage
-unsafePreparePackage manifestFile resolutionsFile opts =
+unsafePreparePackage :: PublishOptions -> IO D.UploadedPackage
+unsafePreparePackage opts =
either (\e -> printError e >> exitFailure) pure
- =<< preparePackage manifestFile resolutionsFile opts
+ =<< preparePackage opts
-- | Attempt to retrieve package metadata from the current directory.
-- Returns a PackageError on failure
-preparePackage :: FilePath -> FilePath -> PublishOptions -> IO (Either PackageError D.UploadedPackage)
-preparePackage manifestFile resolutionsFile opts =
- runPrepareM (preparePackage' manifestFile resolutionsFile opts)
+preparePackage :: PublishOptions -> IO (Either PackageError D.UploadedPackage)
+preparePackage opts =
+ runPrepareM (preparePackage' opts)
>>= either (pure . Left) (fmap Right . handleWarnings)
where
@@ -117,12 +129,12 @@ otherError = throwError . OtherError
catchLeft :: Applicative f => Either a b -> (a -> f b) -> f b
catchLeft a f = either f pure a
-preparePackage' :: FilePath -> FilePath -> PublishOptions -> PrepareM D.UploadedPackage
-preparePackage' manifestFile resolutionsFile opts = do
- unlessM (liftIO (doesFileExist manifestFile)) (userError PackageManifestNotFound)
+preparePackage' :: PublishOptions -> PrepareM D.UploadedPackage
+preparePackage' opts = do
+ unlessM (liftIO (doesFileExist (publishManifestFile opts))) (userError PackageManifestNotFound)
checkCleanWorkingTree opts
- pkgMeta <- liftIO (Bower.decodeFile manifestFile)
+ pkgMeta <- liftIO (Bower.decodeFile (publishManifestFile opts))
>>= flip catchLeft (userError . CouldntDecodePackageManifest)
checkLicense pkgMeta
@@ -130,9 +142,9 @@ preparePackage' manifestFile resolutionsFile opts = do
pkgTagTime <- Just <$> publishGetTagTime opts pkgVersionTag
pkgGithub <- getManifestRepositoryInfo pkgMeta
- resolvedDeps <- parseResolutionsFile resolutionsFile
+ resolvedDeps <- parseResolutionsFile (publishResolutionsFile opts)
- (pkgModules, pkgModuleMap) <- getModules (map (second fst) resolvedDeps)
+ (pkgModules, pkgModuleMap) <- getModules opts (map (second fst) resolvedDeps)
let declaredDeps = map fst $
Bower.bowerDependencies pkgMeta
@@ -146,24 +158,17 @@ preparePackage' manifestFile resolutionsFile opts = do
return D.Package{..}
getModules
- :: [(PackageName, FilePath)]
+ :: PublishOptions
+ -> [(PackageName, FilePath)]
-> PrepareM ([D.Module], Map P.ModuleName PackageName)
-getModules paths = do
+getModules opts paths = do
(inputFiles, depsFiles) <- liftIO (getInputAndDepsFiles paths)
- (modules', moduleMap) <- parseFilesInPackages inputFiles depsFiles
- case runExcept (D.convertModulesInPackage (map snd modules') moduleMap) of
- Right modules -> return (modules, moduleMap)
- Left err -> userError (CompileError err)
+ (modules, moduleMap) <-
+ (liftIO (runExceptT (D.collectDocs (publishCompileOutputDir opts) inputFiles depsFiles)))
+ >>= either (userError . CompileError) return
- where
- parseFilesInPackages inputFiles depsFiles = do
- r <- liftIO . runExceptT $ D.parseFilesInPackages inputFiles depsFiles
- case r of
- Right r' ->
- return r'
- Left err ->
- userError (CompileError err)
+ pure (map snd modules, moduleMap)
data TreeStatus = Clean | Dirty deriving (Show, Eq, Ord, Enum)
diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs
index 54370a4..063979a 100644
--- a/src/Language/PureScript/Sugar/Names.hs
+++ b/src/Language/PureScript/Sugar/Names.hs
@@ -333,6 +333,9 @@ renameInModule imports (Module modSS coms mn decls exps) =
updateType (TypeOp ann@(ss, _) name) = TypeOp ann <$> updateTypeOpName name ss
updateType (TypeConstructor ann@(ss, _) name) = TypeConstructor ann <$> updateTypeName name ss
updateType (ConstrainedType ann c t) = ConstrainedType ann <$> updateInConstraint c <*> pure t
+ updateType (ForAll ann v mbK t sco) = case mbK of
+ Nothing -> pure $ ForAll ann v Nothing t sco
+ Just k -> ForAll ann v <$> fmap pure (updateKindsEverywhere k) <*> pure t <*> pure sco
updateType (KindedType ann t k) = KindedType ann t <$> updateKindsEverywhere k
updateType t = return t
updateInConstraint :: SourceConstraint -> m SourceConstraint
diff --git a/src/Language/PureScript/Sugar/Names/Env.hs b/src/Language/PureScript/Sugar/Names/Env.hs
index bdfa991..31a109b 100644
--- a/src/Language/PureScript/Sugar/Names/Env.hs
+++ b/src/Language/PureScript/Sugar/Names/Env.hs
@@ -318,6 +318,9 @@ exportType ss exportMode exps name dctors src = do
throwDeclConflict (DctorName dctor) (TyClassName (coerceProperName dctor))
ReExport -> do
let mn = exportSourceDefinedIn src
+ forM_ (coerceProperName name `M.lookup` exClasses) $ \src' ->
+ let mn' = exportSourceDefinedIn src' in
+ throwExportConflict' ss mn mn' (TyName name) (TyClassName (coerceProperName name))
forM_ (name `M.lookup` exTypes) $ \(_, src') ->
let mn' = exportSourceDefinedIn src' in
when (mn /= mn') $
@@ -458,8 +461,23 @@ throwExportConflict
-> Name
-> m a
throwExportConflict ss new existing name =
+ throwExportConflict' ss new existing name name
+
+-- |
+-- Raises an error for when there are conflicting names in the exports. Allows
+-- different categories of names. E.g. class and type names conflicting.
+--
+throwExportConflict'
+ :: MonadError MultipleErrors m
+ => SourceSpan
+ -> ModuleName
+ -> ModuleName
+ -> Name
+ -> Name
+ -> m a
+throwExportConflict' ss new existing newName existingName =
throwError . errorMessage' ss $
- ExportConflict (Qualified (Just new) name) (Qualified (Just existing) name)
+ ExportConflict (Qualified (Just new) newName) (Qualified (Just existing) existingName)
-- |
-- Gets the exports for a module, or raise an error if the module doesn't exist.
diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs
index 25c380f..fa10eb6 100755
--- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs
+++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs
@@ -747,7 +747,7 @@ deriveFunctor ss mn syns ds tyConNm = do
return (lam ss arg (ObjectUpdate argVar (mkAssignment <$> updates)))
-- quantifiers
- goType (ForAll _ scopedVar t _) | scopedVar /= iTyName = goType t
+ goType (ForAll _ scopedVar _ t _) | scopedVar /= iTyName = goType t
-- constraints
goType (ConstrainedType _ _ t) = goType t
diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs
index 5bacf63..ecfdeb9 100644
--- a/src/Language/PureScript/TypeChecker.hs
+++ b/src/Language/PureScript/TypeChecker.hs
@@ -75,7 +75,7 @@ addDataConstructor moduleName dtype name args dctor dctorArgs = do
traverse_ checkTypeSynonyms tys
let retTy = foldl srcTypeApp (srcTypeConstructor (Qualified (Just moduleName) name)) (map srcTypeVar args)
let dctorTy = foldr function retTy tys
- let polyType = mkForAll (map (NullSourceAnn,) args) dctorTy
+ let polyType = mkForAll (map (\i -> (NullSourceAnn, (i, Nothing))) args) dctorTy
putEnv $ env { dataConstructors = M.insert (Qualified (Just moduleName) dctor) (dtype, name, polyType, fields) (dataConstructors env) }
addTypeSynonym
@@ -278,9 +278,11 @@ typeCheckAll moduleName _ = traverse go
warnAndRethrow (addHint (ErrorInValueDeclaration name) . addHint (positionedError ss)) . censorLocalUnnamedWildcards val $ do
val' <- checkExhaustiveExpr ss env moduleName val
valueIsNotDefined moduleName name
- [(_, (val'', ty))] <- typesOf NonRecursiveBindingGroup moduleName [((sa, name), val')]
- addValue moduleName name ty nameKind
- return $ ValueDecl sa name nameKind [] [MkUnguarded val'']
+ typesOf NonRecursiveBindingGroup moduleName [((sa, name), val')] >>= \case
+ [(_, (val'', ty))] -> do
+ addValue moduleName name ty nameKind
+ return $ ValueDecl sa name nameKind [] [MkUnguarded val'']
+ _ -> internalError "typesOf did not return a singleton"
where
go ValueDeclaration{} = internalError "Binders were not desugared"
go BoundValueDeclaration{} = internalError "BoundValueDeclaration should be desugared"
@@ -648,7 +650,7 @@ typeCheckModule (Module ss coms mn decls (Just exps)) =
checkClassMembersAreExported dr@(TypeClassRef ss' name) = do
let members = ValueRef ss' `map` head (mapMaybe findClassMembers decls)
let missingMembers = members \\ exps
- unless (null missingMembers) . throwError . errorMessage' ss' $ TransitiveExportError dr members
+ unless (null missingMembers) . throwError . errorMessage' ss' $ TransitiveExportError dr missingMembers
where
findClassMembers :: Declaration -> Maybe [Ident]
findClassMembers (TypeClassDeclaration _ name' _ _ _ ds) | name == name' = Just $ map extractMemberName ds
diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs
index 0e6792c..28a4009 100644
--- a/src/Language/PureScript/TypeChecker/Kinds.hs
+++ b/src/Language/PureScript/TypeChecker/Kinds.hs
@@ -216,9 +216,9 @@ infer'
. (MonadError MultipleErrors m, MonadState CheckState m)
=> SourceType
-> m (SourceKind, [(Text, SourceKind)])
-infer' (ForAll ann ident ty _) = do
- k1 <- freshKind ann
- Just moduleName <- checkCurrentModule <$> get
+infer' (ForAll ann ident mbK ty _) = do
+ k1 <- maybe (freshKind ann) pure mbK
+ moduleName <- unsafeCheckCurrentModule
(k2, args) <- bindLocalTypeVariables moduleName [(ProperName ident, k1)] $ infer ty
unifyKinds k2 kindType
return (kindType, (ident, k1) : args)
@@ -229,9 +229,9 @@ infer' (KindedType _ ty k) = do
infer' other = (, []) <$> go other
where
go :: SourceType -> m SourceKind
- go (ForAll ann ident ty _) = do
- k1 <- freshKind ann
- Just moduleName <- checkCurrentModule <$> get
+ go (ForAll ann ident mbK ty _) = do
+ k1 <- maybe (freshKind ann) pure mbK
+ moduleName <- unsafeCheckCurrentModule
k2 <- bindLocalTypeVariables moduleName [(ProperName ident, k1)] $ go ty
unifyKinds k2 kindType
return $ kindType $> ann
@@ -243,10 +243,10 @@ infer' other = (, []) <$> go other
go (TUnknown ann _) = freshKind ann
go (TypeLevelString ann _) = return $ kindSymbol $> ann
go (TypeVar ann v) = do
- Just moduleName <- checkCurrentModule <$> get
+ moduleName <- unsafeCheckCurrentModule
($> ann) <$> lookupTypeVariable moduleName (Qualified Nothing (ProperName v))
go (Skolem ann v _ _) = do
- Just moduleName <- checkCurrentModule <$> get
+ moduleName <- unsafeCheckCurrentModule
($> ann) <$> lookupTypeVariable moduleName (Qualified Nothing (ProperName v))
go (TypeConstructor ann v) = do
env <- getEnv
diff --git a/src/Language/PureScript/TypeChecker/Monad.hs b/src/Language/PureScript/TypeChecker/Monad.hs
index 7ec603f..2933173 100644
--- a/src/Language/PureScript/TypeChecker/Monad.hs
+++ b/src/Language/PureScript/TypeChecker/Monad.hs
@@ -18,6 +18,7 @@ import qualified Data.Map as M
import Data.Text (Text)
import qualified Data.List.NonEmpty as NEL
+import Language.PureScript.Crash (internalError)
import Language.PureScript.Environment
import Language.PureScript.Errors
import Language.PureScript.Kinds
@@ -323,3 +324,11 @@ withoutWarnings
=> m a
-> m (a, w)
withoutWarnings = censor (const mempty) . listen
+
+unsafeCheckCurrentModule
+ :: forall m
+ . (MonadError MultipleErrors m, MonadState CheckState m)
+ => m ModuleName
+unsafeCheckCurrentModule = checkCurrentModule <$> get >>= \case
+ Nothing -> internalError "No module name set in scope"
+ Just name -> pure name
diff --git a/src/Language/PureScript/TypeChecker/Skolems.hs b/src/Language/PureScript/TypeChecker/Skolems.hs
index 76af631..170ea7e 100644
--- a/src/Language/PureScript/TypeChecker/Skolems.hs
+++ b/src/Language/PureScript/TypeChecker/Skolems.hs
@@ -34,7 +34,7 @@ newSkolemConstant = do
introduceSkolemScope :: MonadState CheckState m => Type a -> m (Type a)
introduceSkolemScope = everywhereOnTypesM go
where
- go (ForAll ann ident ty Nothing) = ForAll ann ident ty <$> (Just <$> newSkolemScope)
+ go (ForAll ann ident mbK ty Nothing) = ForAll ann ident mbK ty <$> (Just <$> newSkolemScope)
go other = return other
-- | Generate a new skolem scope
@@ -71,7 +71,7 @@ skolemizeTypesInValue ann ident sko scope =
onBinder sco other = return (sco, other)
peelTypeVars :: SourceType -> [Text]
- peelTypeVars (ForAll _ i ty _) = i : peelTypeVars ty
+ peelTypeVars (ForAll _ i _ ty _) = i : peelTypeVars ty
peelTypeVars _ = []
-- | Ensure skolem variables do not escape their scope
@@ -116,7 +116,7 @@ skolemEscapeCheck expr@TypedValue{} =
-- Collect any scopes appearing in quantifiers at the top level
collectScopes :: SourceType -> [SkolemScope]
- collectScopes (ForAll _ _ t (Just sco)) = sco : collectScopes t
+ collectScopes (ForAll _ _ _ t (Just sco)) = sco : collectScopes t
collectScopes ForAll{} = internalError "skolemEscapeCheck: No skolem scope"
collectScopes _ = []
diff --git a/src/Language/PureScript/TypeChecker/Subsumption.hs b/src/Language/PureScript/TypeChecker/Subsumption.hs
index af5275d..d85d905 100644
--- a/src/Language/PureScript/TypeChecker/Subsumption.hs
+++ b/src/Language/PureScript/TypeChecker/Subsumption.hs
@@ -75,10 +75,10 @@ subsumes'
-> SourceType
-> SourceType
-> m (Coercion mode)
-subsumes' mode (ForAll _ ident ty1 _) ty2 = do
+subsumes' mode (ForAll _ ident _ ty1 _) ty2 = do
replaced <- replaceVarWithUnknown ident ty1
subsumes' mode replaced ty2
-subsumes' mode ty1 (ForAll _ ident ty2 sco) =
+subsumes' mode ty1 (ForAll _ ident _ ty2 sco) =
case sco of
Just sco' -> do
sko <- newSkolemConstant
diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs
index f372a69..e449135 100644
--- a/src/Language/PureScript/TypeChecker/Types.hs
+++ b/src/Language/PureScript/TypeChecker/Types.hs
@@ -68,6 +68,13 @@ data BindingGroupType
| NonRecursiveBindingGroup
deriving (Show, Eq, Ord)
+-- | The result of a successful type check.
+data TypedValue' = TypedValue' Bool Expr SourceType
+
+-- | Convert an type checked value into an expression.
+tvToExpr :: TypedValue' -> Expr
+tvToExpr (TypedValue' c e t) = TypedValue c e t
+
-- | Infer the types of multiple mutually-recursive values, and return elaborated values including
-- type class dictionaries and type annotations.
typesOf
@@ -245,8 +252,8 @@ checkTypedBindingGroupElement mn (ident, (val, ty, checkType)) dict = do
-- Check the type with the new names in scope
val' <- if checkType
then withScopedTypeVars mn args $ bindNames dict $ check val ty'
- else return (TypedValue False val ty')
- return (ident, (val', ty'))
+ else return (TypedValue' False val ty')
+ return (ident, (tvToExpr val', ty'))
-- | Infer a type for a value in a binding group which lacks an annotation.
typeForBindingGroupElement
@@ -259,7 +266,7 @@ typeForBindingGroupElement
-> m ((SourceAnn, Ident), (Expr, SourceType))
typeForBindingGroupElement (ident, (val, ty)) dict = do
-- Infer the type with the new names in scope
- TypedValue _ val' ty' <- bindNames dict $ infer val
+ TypedValue' _ val' ty' <- bindNames dict $ infer val
-- Unify the type with the unification variable we chose for this definition
unifyTypes ty ty'
return (ident, (TypedValue True val' ty', ty'))
@@ -282,7 +289,7 @@ instantiatePolyTypeWithUnknowns
=> Expr
-> SourceType
-> m (Expr, SourceType)
-instantiatePolyTypeWithUnknowns val (ForAll _ ident ty _) = do
+instantiatePolyTypeWithUnknowns val (ForAll _ ident _ ty _) = do
ty' <- replaceVarWithUnknown ident ty
instantiatePolyTypeWithUnknowns val ty'
instantiatePolyTypeWithUnknowns val (ConstrainedType _ con ty) = do
@@ -295,7 +302,7 @@ instantiatePolyTypeWithUnknowns val ty = return (val, ty)
infer
:: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
=> Expr
- -> m Expr
+ -> m TypedValue'
infer val = withErrorMessageHint (ErrorInferringType val) $ infer' val
-- | Infer a type for a value
@@ -303,20 +310,20 @@ infer'
:: forall m
. (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
=> Expr
- -> m Expr
-infer' v@(Literal _ (NumericLiteral (Left _))) = return $ TypedValue True v tyInt
-infer' v@(Literal _ (NumericLiteral (Right _))) = return $ TypedValue True v tyNumber
-infer' v@(Literal _ (StringLiteral _)) = return $ TypedValue True v tyString
-infer' v@(Literal _ (CharLiteral _)) = return $ TypedValue True v tyChar
-infer' v@(Literal _ (BooleanLiteral _)) = return $ TypedValue True v tyBoolean
+ -> m TypedValue'
+infer' v@(Literal _ (NumericLiteral (Left _))) = return $ TypedValue' True v tyInt
+infer' v@(Literal _ (NumericLiteral (Right _))) = return $ TypedValue' True v tyNumber
+infer' v@(Literal _ (StringLiteral _)) = return $ TypedValue' True v tyString
+infer' v@(Literal _ (CharLiteral _)) = return $ TypedValue' True v tyChar
+infer' v@(Literal _ (BooleanLiteral _)) = return $ TypedValue' True v tyBoolean
infer' (Literal ss (ArrayLiteral vals)) = do
ts <- traverse infer vals
els <- freshType
- ts' <- forM ts $ \(TypedValue ch val t) -> do
+ ts' <- forM ts $ \(TypedValue' ch val t) -> do
(val', t') <- instantiatePolyTypeWithUnknowns val t
unifyTypes els t'
return (TypedValue ch val' t')
- return $ TypedValue True (Literal ss (ArrayLiteral ts')) (srcTypeApp tyArray els)
+ return $ TypedValue' True (Literal ss (ArrayLiteral ts')) (srcTypeApp tyArray els)
infer' (Literal ss (ObjectLiteral ps)) = do
ensureNoDuplicateProperties ps
-- We make a special case for Vars in record labels, since these are the
@@ -329,7 +336,7 @@ infer' (Literal ss (ObjectLiteral ps)) = do
inferProperty :: (PSString, Expr) -> m (PSString, (Expr, SourceType))
inferProperty (name, val) = do
- TypedValue _ val' ty <- infer val
+ TypedValue' _ val' ty <- infer val
valAndType <- if shouldInstantiate val
then instantiatePolyTypeWithUnknowns val' ty
else pure (val', ty)
@@ -339,34 +346,35 @@ infer' (Literal ss (ObjectLiteral ps)) = do
fields <- forM ps inferProperty
let ty = srcTypeApp tyRecord $ rowFromList (map toRowListItem fields, srcREmpty)
- return $ TypedValue True (Literal ss (ObjectLiteral (map (fmap (uncurry (TypedValue True))) fields))) ty
+ return $ TypedValue' True (Literal ss (ObjectLiteral (map (fmap (uncurry (TypedValue True))) fields))) ty
infer' (ObjectUpdate o ps) = do
ensureNoDuplicateProperties ps
row <- freshType
- newVals <- zipWith (\(name, _) t -> (name, t)) ps <$> traverse (infer . snd) ps
+ typedVals <- zipWith (\(name, _) t -> (name, t)) ps <$> traverse (infer . snd) ps
let toRowListItem = uncurry srcRowListItem
- let newTys = map (\(name, TypedValue _ _ ty) -> (Label name, ty)) newVals
+ let newTys = map (\(name, TypedValue' _ _ ty) -> (Label name, ty)) typedVals
oldTys <- zip (map (Label . fst) ps) <$> replicateM (length ps) freshType
let oldTy = srcTypeApp tyRecord $ rowFromList (toRowListItem <$> oldTys, row)
- o' <- TypedValue True <$> check o oldTy <*> pure oldTy
- return $ TypedValue True (ObjectUpdate o' newVals) $ srcTypeApp tyRecord $ rowFromList (toRowListItem <$> newTys, row)
+ o' <- TypedValue True <$> (tvToExpr <$> check o oldTy) <*> pure oldTy
+ let newVals = map (fmap tvToExpr) typedVals
+ return $ TypedValue' True (ObjectUpdate o' newVals) $ srcTypeApp tyRecord $ rowFromList (toRowListItem <$> newTys, row)
infer' (Accessor prop val) = withErrorMessageHint (ErrorCheckingAccessor val prop) $ do
field <- freshType
rest <- freshType
- typed <- check val (srcTypeApp tyRecord (srcRCons (Label prop) field rest))
- return $ TypedValue True (Accessor prop typed) field
+ typed <- tvToExpr <$> check val (srcTypeApp tyRecord (srcRCons (Label prop) field rest))
+ return $ TypedValue' True (Accessor prop typed) field
infer' (Abs binder ret)
| VarBinder ss arg <- binder = do
ty <- freshType
withBindingGroupVisible $ bindLocalVariables [(arg, ty, Defined)] $ do
- body@(TypedValue _ _ bodyTy) <- infer' ret
- (body', bodyTy') <- instantiatePolyTypeWithUnknowns body bodyTy
- return $ TypedValue True (Abs (VarBinder ss arg) body') (function ty bodyTy')
+ body@(TypedValue' _ _ bodyTy) <- infer' ret
+ (body', bodyTy') <- instantiatePolyTypeWithUnknowns (tvToExpr body) bodyTy
+ return $ TypedValue' True (Abs (VarBinder ss arg) body') (function ty bodyTy')
| otherwise = internalError "Binder was not desugared"
infer' (App f arg) = do
- f'@(TypedValue _ _ ft) <- infer f
- (ret, app) <- checkFunctionApplication f' ft arg
- return $ TypedValue True app ret
+ f'@(TypedValue' _ _ ft) <- infer f
+ (ret, app) <- checkFunctionApplication (tvToExpr f') ft arg
+ return $ TypedValue' True app ret
infer' (Var ss var) = do
checkVisibility var
ty <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards <=< lookupVariable $ var
@@ -374,52 +382,52 @@ infer' (Var ss var) = do
ConstrainedType _ con ty' -> do
dicts <- getTypeClassDictionaries
hints <- getHints
- return $ TypedValue True (App (Var ss var) (TypeClassDictionary con dicts hints)) ty'
- _ -> return $ TypedValue True (Var ss var) ty
+ return $ TypedValue' True (App (Var ss var) (TypeClassDictionary con dicts hints)) ty'
+ _ -> return $ TypedValue' True (Var ss var) ty
infer' v@(Constructor _ c) = do
env <- getEnv
case M.lookup c (dataConstructors env) of
Nothing -> throwError . errorMessage . UnknownName . fmap DctorName $ c
Just (_, _, ty, _) -> do (v', ty') <- sndM (introduceSkolemScope <=< replaceAllTypeSynonyms) <=< instantiatePolyTypeWithUnknowns v $ ty
- return $ TypedValue True v' ty'
+ return $ TypedValue' True v' ty'
infer' (Case vals binders) = do
(vals', ts) <- instantiateForBinders vals binders
ret <- freshType
binders' <- checkBinders ts ret binders
- return $ TypedValue True (Case vals' binders') ret
+ return $ TypedValue' True (Case vals' binders') ret
infer' (IfThenElse cond th el) = do
- cond' <- check cond tyBoolean
- th'@(TypedValue _ _ thTy) <- infer th
- el'@(TypedValue _ _ elTy) <- infer el
- (th'', thTy') <- instantiatePolyTypeWithUnknowns th' thTy
- (el'', elTy') <- instantiatePolyTypeWithUnknowns el' elTy
+ cond' <- tvToExpr <$> check cond tyBoolean
+ th'@(TypedValue' _ _ thTy) <- infer th
+ el'@(TypedValue' _ _ elTy) <- infer el
+ (th'', thTy') <- instantiatePolyTypeWithUnknowns (tvToExpr th') thTy
+ (el'', elTy') <- instantiatePolyTypeWithUnknowns (tvToExpr el') elTy
unifyTypes thTy' elTy'
- return $ TypedValue True (IfThenElse cond' th'' el'') thTy'
+ return $ TypedValue' True (IfThenElse cond' th'' el'') thTy'
infer' (Let w ds val) = do
- (ds', val'@(TypedValue _ _ valTy)) <- inferLetBinding [] ds val infer
- return $ TypedValue True (Let w ds' val') valTy
+ (ds', tv@(TypedValue' _ _ valTy)) <- inferLetBinding [] ds val infer
+ return $ TypedValue' True (Let w ds' (tvToExpr tv)) valTy
infer' (DeferredDictionary className tys) = do
dicts <- getTypeClassDictionaries
hints <- getHints
- return $ TypedValue False
+ return $ TypedValue' False
(TypeClassDictionary (srcConstraint className tys Nothing) dicts hints)
(foldl srcTypeApp (srcTypeConstructor (fmap coerceProperName className)) tys)
infer' (TypedValue checkType val ty) = do
- Just moduleName <- checkCurrentModule <$> get
+ moduleName <- unsafeCheckCurrentModule
(kind, args) <- kindOfWithScopedVars ty
checkTypeKind ty kind
ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty
- val' <- if checkType then withScopedTypeVars moduleName args (check val ty') else return val
- return $ TypedValue True val' ty'
+ tv <- if checkType then withScopedTypeVars moduleName args (check val ty') else return (TypedValue' False val ty)
+ return $ TypedValue' True (tvToExpr tv) ty'
infer' (Hole name) = do
ty <- freshType
ctx <- getLocalContext
env <- getEnv
tell . errorMessage $ HoleInferredType name ty ctx . Just $ TSBefore env
- return $ TypedValue True (Hole name) ty
+ return $ TypedValue' True (Hole name) ty
infer' (PositionedValue pos c val) = warnAndRethrowWithPositionTC pos $ do
- TypedValue t v ty <- infer' val
- return $ TypedValue t (PositionedValue pos c v) ty
+ TypedValue' t v ty <- infer' val
+ return $ TypedValue' t (PositionedValue pos c v) ty
infer' v = internalError $ "Invalid argument to infer: " ++ show v
inferLetBinding
@@ -427,29 +435,31 @@ inferLetBinding
=> [Declaration]
-> [Declaration]
-> Expr
- -> (Expr -> m Expr)
- -> m ([Declaration], Expr)
+ -> (Expr -> m TypedValue')
+ -> m ([Declaration], TypedValue')
inferLetBinding seen [] ret j = (,) seen <$> withBindingGroupVisible (j ret)
-inferLetBinding seen (ValueDecl sa@(ss, _) ident nameKind [] [MkUnguarded tv@(TypedValue checkType val ty)] : rest) ret j = do
- Just moduleName <- checkCurrentModule <$> get
- TypedValue _ val' ty'' <- warnAndRethrowWithPositionTC ss $ do
+inferLetBinding seen (ValueDecl sa@(ss, _) ident nameKind [] [MkUnguarded (TypedValue checkType val ty)] : rest) ret j = do
+ moduleName <- unsafeCheckCurrentModule
+ TypedValue' _ val' ty'' <- warnAndRethrowWithPositionTC ss $ do
(kind, args) <- kindOfWithScopedVars ty
checkTypeKind ty kind
let dict = M.singleton (Qualified Nothing ident) (ty, nameKind, Undefined)
ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty
- if checkType then withScopedTypeVars moduleName args (bindNames dict (check val ty')) else return tv
+ if checkType
+ then withScopedTypeVars moduleName args (bindNames dict (check val ty'))
+ else return (TypedValue' checkType val ty)
bindNames (M.singleton (Qualified Nothing ident) (ty'', nameKind, Defined))
$ inferLetBinding (seen ++ [ValueDecl sa ident nameKind [] [MkUnguarded (TypedValue checkType val' ty'')]]) rest ret j
inferLetBinding seen (ValueDecl sa@(ss, _) ident nameKind [] [MkUnguarded val] : rest) ret j = do
valTy <- freshType
- TypedValue _ val' valTy' <- warnAndRethrowWithPositionTC ss $ do
+ TypedValue' _ val' valTy' <- warnAndRethrowWithPositionTC ss $ do
let dict = M.singleton (Qualified Nothing ident) (valTy, nameKind, Undefined)
bindNames dict $ infer val
warnAndRethrowWithPositionTC ss $ unifyTypes valTy valTy'
bindNames (M.singleton (Qualified Nothing ident) (valTy', nameKind, Defined))
$ inferLetBinding (seen ++ [ValueDecl sa ident nameKind [] [MkUnguarded val']]) rest ret j
inferLetBinding seen (BindingGroupDeclaration ds : rest) ret j = do
- Just moduleName <- checkCurrentModule <$> get
+ moduleName <- unsafeCheckCurrentModule
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
@@ -547,7 +557,7 @@ instantiateForBinders
-> [CaseAlternative]
-> m ([Expr], [SourceType])
instantiateForBinders vals cas = unzip <$> zipWithM (\val inst -> do
- TypedValue _ val' ty <- infer val
+ TypedValue' _ val' ty <- infer val
if inst
then instantiatePolyTypeWithUnknowns val' ty
else return (val', ty)) vals shouldInstantiate
@@ -580,20 +590,20 @@ checkGuardedRhs
-> SourceType
-> m GuardedExpr
checkGuardedRhs (GuardedExpr [] rhs) ret = do
- rhs' <- TypedValue True <$> check rhs ret <*> pure ret
+ rhs' <- TypedValue True <$> (tvToExpr <$> check rhs ret) <*> pure ret
return $ GuardedExpr [] rhs'
checkGuardedRhs (GuardedExpr (ConditionGuard cond : guards) rhs) ret = do
cond' <- withErrorMessageHint ErrorCheckingGuard $ check cond tyBoolean
GuardedExpr guards' rhs' <- checkGuardedRhs (GuardedExpr guards rhs) ret
- return $ GuardedExpr (ConditionGuard cond' : guards') rhs'
+ return $ GuardedExpr (ConditionGuard (tvToExpr cond') : guards') rhs'
checkGuardedRhs (GuardedExpr (PatternGuard binder expr : guards) rhs) ret = do
- expr'@(TypedValue _ _ ty) <- infer expr
+ tv@(TypedValue' _ _ ty) <- infer expr
variables <- inferBinder ty binder
GuardedExpr guards' rhs' <- bindLocalVariables [ (name, bty, Defined)
| (name, bty) <- M.toList variables
] $
checkGuardedRhs (GuardedExpr guards rhs) ret
- return $ GuardedExpr (PatternGuard binder expr' : guards') rhs'
+ return $ GuardedExpr (PatternGuard binder (tvToExpr tv) : guards') rhs'
-- |
-- Check the type of a value, rethrowing errors to provide a better error message
@@ -602,7 +612,7 @@ check
:: (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
=> Expr
-> SourceType
- -> m Expr
+ -> m TypedValue'
check val ty = withErrorMessageHint (ErrorCheckingType val ty) $ check' val ty
-- |
@@ -613,8 +623,8 @@ check'
. (MonadSupply m, MonadState CheckState m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
=> Expr
-> SourceType
- -> m Expr
-check' val (ForAll ann ident ty _) = do
+ -> m TypedValue'
+check' val (ForAll ann ident mbK ty _) = do
scope <- newSkolemScope
sko <- newSkolemConstant
let ss = case val of
@@ -622,50 +632,50 @@ check' val (ForAll ann ident ty _) = do
_ -> NullSourceAnn
sk = skolemize ss ident sko scope ty
skVal = skolemizeTypesInValue ss ident sko scope val
- val' <- check skVal sk
- return $ TypedValue True val' (ForAll ann ident ty (Just scope))
+ val' <- tvToExpr <$> check skVal sk
+ return $ TypedValue' True val' (ForAll ann ident mbK ty (Just scope))
check' val t@(ConstrainedType _ con@(Constraint _ (Qualified _ (ProperName className)) _ _) ty) = do
dictName <- freshIdent ("dict" <> className)
dicts <- newDictionaries [] (Qualified Nothing dictName) con
val' <- withBindingGroupVisible $ withTypeClassDictionaries dicts $ check val ty
- return $ TypedValue True (Abs (VarBinder nullSourceSpan dictName) val') t
+ return $ TypedValue' True (Abs (VarBinder nullSourceSpan dictName) (tvToExpr val')) t
check' val u@(TUnknown _ _) = do
- val'@(TypedValue _ _ ty) <- infer val
+ val'@(TypedValue' _ _ ty) <- infer val
-- Don't unify an unknown with an inferred polytype
- (val'', ty') <- instantiatePolyTypeWithUnknowns val' ty
+ (val'', ty') <- instantiatePolyTypeWithUnknowns (tvToExpr val') ty
unifyTypes ty' u
- return $ TypedValue True val'' ty'
+ return $ TypedValue' True val'' ty'
check' v@(Literal _ (NumericLiteral (Left _))) t | t == tyInt =
- return $ TypedValue True v t
+ return $ TypedValue' True v t
check' v@(Literal _ (NumericLiteral (Right _))) t | t == tyNumber =
- return $ TypedValue True v t
+ return $ TypedValue' True v t
check' v@(Literal _ (StringLiteral _)) t | t == tyString =
- return $ TypedValue True v t
+ return $ TypedValue' True v t
check' v@(Literal _ (CharLiteral _)) t | t == tyChar =
- return $ TypedValue True v t
+ return $ TypedValue' True v t
check' v@(Literal _ (BooleanLiteral _)) t | t == tyBoolean =
- return $ TypedValue True v t
+ return $ TypedValue' True v t
check' (Literal ss (ArrayLiteral vals)) t@(TypeApp _ a ty) = do
unifyTypes a tyArray
- array <- Literal ss . ArrayLiteral <$> forM vals (`check` ty)
- return $ TypedValue True array t
+ array <- Literal ss . ArrayLiteral . map tvToExpr <$> forM vals (`check` ty)
+ return $ TypedValue' True array t
check' (Abs binder ret) ty@(TypeApp _ (TypeApp _ t argTy) retTy)
| VarBinder ss arg <- binder = do
unifyTypes t tyFunction
ret' <- withBindingGroupVisible $ bindLocalVariables [(arg, argTy, Defined)] $ check ret retTy
- return $ TypedValue True (Abs (VarBinder ss arg) ret') ty
+ return $ TypedValue' True (Abs (VarBinder ss arg) (tvToExpr ret')) ty
| otherwise = internalError "Binder was not desugared"
check' (App f arg) ret = do
- f'@(TypedValue _ _ ft) <- infer f
- (retTy, app) <- checkFunctionApplication f' ft arg
+ f'@(TypedValue' _ _ ft) <- infer f
+ (retTy, app) <- checkFunctionApplication (tvToExpr f') ft arg
elaborate <- subsumes retTy ret
- return $ TypedValue True (elaborate app) ret
+ return $ TypedValue' True (elaborate app) ret
check' v@(Var _ var) ty = do
checkVisibility var
repl <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< lookupVariable $ var
ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty
elaborate <- subsumes repl ty'
- return $ TypedValue True (elaborate v) ty'
+ return $ TypedValue' True (elaborate v) ty'
check' (DeferredDictionary className tys) ty = do
{-
-- Here, we replace a placeholder for a superclass dictionary with a regular
@@ -675,7 +685,7 @@ check' (DeferredDictionary className tys) ty = do
-}
dicts <- getTypeClassDictionaries
hints <- getHints
- return $ TypedValue False
+ return $ TypedValue' False
(TypeClassDictionary (srcConstraint className tys Nothing) dicts hints)
ty
check' (TypedValue checkType val ty1) ty2 = do
@@ -685,25 +695,25 @@ check' (TypedValue checkType val ty1) ty2 = do
ty2' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty2
elaborate <- subsumes ty1' ty2'
val' <- if checkType
- then check val ty1'
+ then tvToExpr <$> check val ty1'
else pure val
- return $ TypedValue True (TypedValue checkType (elaborate val') ty1') ty2'
+ return $ TypedValue' True (TypedValue checkType (elaborate val') ty1') ty2'
check' (Case vals binders) ret = do
(vals', ts) <- instantiateForBinders vals binders
binders' <- checkBinders ts ret binders
- return $ TypedValue True (Case vals' binders') ret
+ return $ TypedValue' True (Case vals' binders') ret
check' (IfThenElse cond th el) ty = do
- cond' <- check cond tyBoolean
- th' <- check th ty
- el' <- check el ty
- return $ TypedValue True (IfThenElse cond' th' el') ty
+ cond' <- tvToExpr <$> check cond tyBoolean
+ th' <- tvToExpr <$> check th ty
+ el' <- tvToExpr <$> check el ty
+ return $ TypedValue' True (IfThenElse cond' th' el') ty
check' e@(Literal ss (ObjectLiteral ps)) t@(TypeApp _ obj row) | obj == tyRecord = do
ensureNoDuplicateProperties ps
ps' <- checkProperties e ps row False
- return $ TypedValue True (Literal ss (ObjectLiteral ps')) t
+ return $ TypedValue' True (Literal ss (ObjectLiteral ps')) t
check' (TypeClassDictionaryConstructorApp name ps) t = do
- ps' <- check' ps t
- return $ TypedValue True (TypeClassDictionaryConstructorApp name ps') t
+ ps' <- tvToExpr <$> check' ps t
+ return $ TypedValue' True (TypeClassDictionaryConstructorApp name ps') t
check' e@(ObjectUpdate obj ps) t@(TypeApp _ o row) | o == tyRecord = do
ensureNoDuplicateProperties ps
-- We need to be careful to avoid duplicate labels here.
@@ -711,13 +721,13 @@ check' e@(ObjectUpdate obj ps) t@(TypeApp _ o row) | o == tyRecord = do
let (propsToCheck, rest) = rowToList row
(removedProps, remainingProps) = partition (\(RowListItem _ p _) -> p `elem` map (Label . fst) ps) propsToCheck
us <- zipWith srcRowListItem (map rowListLabel removedProps) <$> replicateM (length ps) freshType
- obj' <- check obj (srcTypeApp tyRecord (rowFromList (us ++ remainingProps, rest)))
+ obj' <- tvToExpr <$> check obj (srcTypeApp tyRecord (rowFromList (us ++ remainingProps, rest)))
ps' <- checkProperties e ps row True
- return $ TypedValue True (ObjectUpdate obj' ps') t
+ return $ TypedValue' True (ObjectUpdate obj' ps') t
check' (Accessor prop val) ty = withErrorMessageHint (ErrorCheckingAccessor val prop) $ do
rest <- freshType
- val' <- check val (srcTypeApp tyRecord (srcRCons (Label prop) ty rest))
- return $ TypedValue True (Accessor prop val') ty
+ val' <- tvToExpr <$> check val (srcTypeApp tyRecord (srcRCons (Label prop) ty rest))
+ return $ TypedValue' True (Accessor prop val') ty
check' v@(Constructor _ c) ty = do
env <- getEnv
case M.lookup c (dataConstructors env) of
@@ -726,21 +736,21 @@ check' v@(Constructor _ c) ty = do
repl <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1
ty' <- introduceSkolemScope ty
elaborate <- subsumes repl ty'
- return $ TypedValue True (elaborate v) ty'
+ return $ TypedValue' True (elaborate v) ty'
check' (Let w ds val) ty = do
(ds', val') <- inferLetBinding [] ds val (`check` ty)
- return $ TypedValue True (Let w ds' val') ty
+ return $ TypedValue' True (Let w ds' (tvToExpr val')) ty
check' val kt@(KindedType _ ty kind) = do
checkTypeKind ty kind
- val' <- check' val ty
- return $ TypedValue True val' kt
+ val' <- tvToExpr <$> check' val ty
+ return $ TypedValue' True val' kt
check' (PositionedValue pos c val) ty = warnAndRethrowWithPositionTC pos $ do
- TypedValue t v ty' <- check' val ty
- return $ TypedValue t (PositionedValue pos c v) ty'
+ TypedValue' t v ty' <- check' val ty
+ return $ TypedValue' t (PositionedValue pos c v) ty'
check' val ty = do
- TypedValue _ val' ty' <- infer val
+ TypedValue' _ val' ty' <- infer val
elaborate <- subsumes ty' ty
- return $ TypedValue True (elaborate val') ty
+ return $ TypedValue' True (elaborate val') ty
-- |
-- Check the type of a collection of named record fields
@@ -754,7 +764,9 @@ checkProperties
-> SourceType
-> Bool
-> m [(PSString, Expr)]
-checkProperties expr ps row lax = let (ts, r') = rowToList row in go ps (toRowPair <$> ts) r' where
+checkProperties expr ps row lax = convert <$> go ps (toRowPair <$> ts') r' where
+ convert = fmap (fmap tvToExpr)
+ (ts', r') = rowToList row
toRowPair (RowListItem _ lbl ty) = (lbl, ty)
go [] [] (REmpty _) = return []
go [] [] u@(TUnknown _ _)
@@ -768,7 +780,7 @@ checkProperties expr ps row lax = let (ts, r') = rowToList row in go ps (toRowPa
go ((p,v):ps') ts r =
case lookup (Label p) ts of
Nothing -> do
- v'@(TypedValue _ _ ty) <- infer v
+ v'@(TypedValue' _ _ ty) <- infer v
rest <- freshType
unifyTypes r (srcRCons (Label p) ty rest)
ps'' <- go ps' ts rest
@@ -815,9 +827,9 @@ checkFunctionApplication'
-> m (SourceType, Expr)
checkFunctionApplication' fn (TypeApp _ (TypeApp _ tyFunction' argTy) retTy) arg = do
unifyTypes tyFunction' tyFunction
- arg' <- check arg argTy
+ arg' <- tvToExpr <$> check arg argTy
return (retTy, App fn arg')
-checkFunctionApplication' fn (ForAll _ ident ty _) arg = do
+checkFunctionApplication' fn (ForAll _ ident _ ty _) arg = do
replaced <- replaceVarWithUnknown ident ty
checkFunctionApplication fn replaced arg
checkFunctionApplication' fn (KindedType _ ty _) arg =
@@ -829,14 +841,13 @@ checkFunctionApplication' fn (ConstrainedType _ con fnTy) arg = do
checkFunctionApplication' fn fnTy dict@TypeClassDictionary{} =
return (fnTy, App fn dict)
checkFunctionApplication' fn u arg = do
- arg' <- do
- TypedValue _ arg' t <- infer arg
+ tv@(TypedValue' _ _ ty) <- do
+ TypedValue' _ arg' t <- infer arg
(arg'', t') <- instantiatePolyTypeWithUnknowns arg' t
- return $ TypedValue True arg'' t'
- let ty = (\(TypedValue _ _ t) -> t) arg'
+ return $ TypedValue' True arg'' t'
ret <- freshType
unifyTypes u (function ty ret)
- return (ret, App fn arg')
+ return (ret, App fn (tvToExpr tv))
-- |
-- Ensure a set of property names and value does not contain duplicate labels
diff --git a/src/Language/PureScript/TypeChecker/Unify.hs b/src/Language/PureScript/TypeChecker/Unify.hs
index 19bf3e6..65625f4 100644
--- a/src/Language/PureScript/TypeChecker/Unify.hs
+++ b/src/Language/PureScript/TypeChecker/Unify.hs
@@ -24,6 +24,7 @@ import Control.Monad.Error.Class (MonadError(..))
import Control.Monad.State.Class (MonadState(..), gets, modify)
import Control.Monad.Writer.Class (MonadWriter(..))
+import Data.Foldable (traverse_)
import Data.Function (on)
import Data.List (sortBy, nubBy)
import qualified Data.Map as M
@@ -90,7 +91,7 @@ unifyTypes t1 t2 = do
unifyTypes' (TUnknown _ u1) (TUnknown _ u2) | u1 == u2 = return ()
unifyTypes' (TUnknown _ u) t = solveType u t
unifyTypes' t (TUnknown _ u) = solveType u t
- unifyTypes' (ForAll ann1 ident1 ty1 sc1) (ForAll ann2 ident2 ty2 sc2) =
+ unifyTypes' (ForAll ann1 ident1 _ ty1 sc1) (ForAll ann2 ident2 _ ty2 sc2) =
case (sc1, sc2) of
(Just sc1', Just sc2') -> do
sko <- newSkolemConstant
@@ -98,7 +99,7 @@ unifyTypes t1 t2 = do
let sk2 = skolemize ann2 ident2 sko sc2' ty2
sk1 `unifyTypes` sk2
_ -> internalError "unifyTypes: unspecified skolem scope"
- unifyTypes' (ForAll ann ident ty1 (Just sc)) ty2 = do
+ unifyTypes' (ForAll ann ident _ ty1 (Just sc)) ty2 = do
sko <- newSkolemConstant
let sk = skolemize ann ident sko sc ty1
sk `unifyTypes` ty2
@@ -118,6 +119,10 @@ unifyTypes t1 t2 = do
unifyTypes' r1 r2@RCons{} = unifyRows r1 r2
unifyTypes' r1@REmpty{} r2 = unifyRows r1 r2
unifyTypes' r1 r2@REmpty{} = unifyRows r1 r2
+ unifyTypes' (ConstrainedType _ c1 ty1) (ConstrainedType _ c2 ty2)
+ | constraintClass c1 == constraintClass c2 && constraintData c1 == constraintData c2 = do
+ traverse_ (uncurry unifyTypes) (constraintArgs c1 `zip` constraintArgs c2)
+ ty1 `unifyTypes` ty2
unifyTypes' ty1@ConstrainedType{} ty2 =
throwError . errorMessage $ ConstrainedTypeUnified ty1 ty2
unifyTypes' t3 t4@ConstrainedType{} = unifyTypes' t4 t3
@@ -199,8 +204,9 @@ varIfUnknown :: SourceType -> SourceType
varIfUnknown ty =
let unks = nubBy ((==) `on` snd) $ unknownsInType ty
toName = T.cons 't' . T.pack . show
+ addKind a = (a, Nothing)
ty' = everywhereOnTypes typeToVar ty
typeToVar :: SourceType -> SourceType
typeToVar (TUnknown ann u) = TypeVar ann (toName u)
typeToVar t = t
- in mkForAll (sortBy (comparing snd) . fmap (fmap toName) $ unks) ty'
+ in mkForAll (fmap (fmap addKind) . sortBy (comparing snd) . fmap (fmap toName) $ unks) ty'
diff --git a/src/Language/PureScript/Types.hs b/src/Language/PureScript/Types.hs
index 56f963b..ae22b11 100644
--- a/src/Language/PureScript/Types.hs
+++ b/src/Language/PureScript/Types.hs
@@ -67,7 +67,7 @@ data Type a
-- | A type application
| TypeApp a (Type a) (Type a)
-- | Forall quantifier
- | ForAll a Text (Type a) (Maybe SkolemScope)
+ | ForAll a Text (Maybe (Kind a)) (Type a) (Maybe SkolemScope)
-- | A type with a set of type class constraints
| ConstrainedType a (Constraint a) (Type a)
-- | A skolem constant
@@ -112,7 +112,7 @@ srcTypeOp = TypeOp NullSourceAnn
srcTypeApp :: SourceType -> SourceType -> SourceType
srcTypeApp = TypeApp NullSourceAnn
-srcForAll :: Text -> SourceType -> Maybe SkolemScope -> SourceType
+srcForAll :: Text -> Maybe SourceKind -> SourceType -> Maybe SkolemScope -> SourceType
srcForAll = ForAll NullSourceAnn
srcConstrainedType :: SourceConstraint -> SourceType -> SourceType
@@ -203,8 +203,10 @@ typeToJSON annToJSON ty =
variant "TypeOp" a b
TypeApp a b c ->
variant "TypeApp" a (go b, go c)
- ForAll a b c d ->
- variant "ForAll" a (b, go c, d)
+ ForAll a b c d e ->
+ case c of
+ Nothing -> variant "ForAll" a (b, go d, e)
+ Just k -> variant "ForAll" a (b, kindToJSON annToJSON k, go d, e)
ConstrainedType a b c ->
variant "ConstrainedType" a (constraintToJSON annToJSON b, go c)
Skolem a b c d ->
@@ -285,8 +287,14 @@ typeFromJSON defaultAnn annFromJSON = A.withObject "Type" $ \o -> do
(b, c) <- contents
TypeApp a <$> go b <*> go c
"ForAll" -> do
- (b, c, d) <- contents
- ForAll a b <$> go c <*> pure d
+ let
+ withoutMbKind = do
+ (b, c, d) <- contents
+ ForAll a b Nothing <$> go c <*> pure d
+ withMbKind = do
+ (b, c, d, e) <- contents
+ ForAll a b <$> (Just <$> kindFromJSON defaultAnn annFromJSON c) <*> go d <*> pure e
+ withMbKind <|> withoutMbKind
"ConstrainedType" -> do
(b, c) <- contents
ConstrainedType a <$> constraintFromJSON defaultAnn annFromJSON b <*> go c
@@ -368,8 +376,8 @@ isMonoType (KindedType _ t _) = isMonoType t
isMonoType _ = True
-- | Universally quantify a type
-mkForAll :: [(a, Text)] -> Type a -> Type a
-mkForAll args ty = foldl (\t (ann, arg) -> ForAll ann arg t Nothing) ty args
+mkForAll :: [(a, (Text, Maybe (Kind a)))] -> Type a -> Type a
+mkForAll args ty = foldl (\t (ann, (arg, mbK)) -> ForAll ann arg mbK t Nothing) ty args
-- | Replace a type variable, taking into account variable shadowing
replaceTypeVars :: Text -> Type a -> Type a -> Type a
@@ -381,13 +389,13 @@ replaceAllTypeVars = go [] where
go :: [Text] -> [(Text, Type a)] -> Type a -> Type a
go _ m (TypeVar ann v) = fromMaybe (TypeVar ann v) (v `lookup` m)
go bs m (TypeApp ann t1 t2) = TypeApp ann (go bs m t1) (go bs m t2)
- go bs m f@(ForAll ann v t sco)
+ go bs m f@(ForAll ann v mbK t sco)
| v `elem` keys = go bs (filter ((/= v) . fst) m) f
| v `elem` usedVars =
let v' = genName v (keys ++ bs ++ usedVars)
t' = go bs [(v, TypeVar ann v')] t
- in ForAll ann v' (go (v' : bs) m t') sco
- | otherwise = ForAll ann v (go (v : bs) m t) sco
+ in ForAll ann v' mbK (go (v' : bs) m t') sco
+ | otherwise = ForAll ann v mbK (go (v : bs) m t) sco
where
keys = map fst m
usedVars = concatMap (usedTypeVariables . snd) m
@@ -415,7 +423,7 @@ freeTypeVariables = ordNub . go [] where
go :: [Text] -> Type a -> [Text]
go bound (TypeVar _ v) | v `notElem` bound = [v]
go bound (TypeApp _ t1 t2) = go bound t1 ++ go bound t2
- go bound (ForAll _ v t _) = go (v : bound) t
+ go bound (ForAll _ v _ t _) = go (v : bound) t
go bound (ConstrainedType _ c t) = concatMap (go bound) (constraintArgs c) ++ go bound t
go bound (RCons _ _ t r) = go bound t ++ go bound r
go bound (KindedType _ t _) = go bound t
@@ -425,14 +433,14 @@ freeTypeVariables = ordNub . go [] where
-- | Universally quantify over all type variables appearing free in a type
quantify :: Type a -> Type a
-quantify ty = foldr (\arg t -> ForAll (getAnnForType ty) arg t Nothing) ty $ freeTypeVariables ty
+quantify ty = foldr (\arg t -> ForAll (getAnnForType ty) arg Nothing t Nothing) ty $ freeTypeVariables ty
-- | Move all universal quantifiers to the front of a type
moveQuantifiersToFront :: Type a -> Type a
moveQuantifiersToFront = go [] [] where
- go qs cs (ForAll ann q ty sco) = go ((ann, q, sco) : qs) cs ty
+ go qs cs (ForAll ann q mbK ty sco) = go ((ann, q, sco, mbK) : qs) cs ty
go qs cs (ConstrainedType ann c ty) = go qs ((ann, c) : cs) ty
- go qs cs ty = foldl (\ty' (ann, q, sco) -> ForAll ann q ty' sco) (foldl (\ty' (ann, c) -> ConstrainedType ann c ty') ty cs) qs
+ go qs cs ty = foldl (\ty' (ann, q, sco, mbK) -> ForAll ann q mbK ty' sco) (foldl (\ty' (ann, c) -> ConstrainedType ann c ty') ty cs) qs
-- | Check if a type contains wildcards
containsWildcards :: Type a -> Bool
@@ -451,7 +459,7 @@ containsForAll = everythingOnTypes (||) go where
everywhereOnTypes :: (Type a -> Type a) -> Type a -> Type a
everywhereOnTypes f = go where
go (TypeApp ann t1 t2) = f (TypeApp ann (go t1) (go t2))
- go (ForAll ann arg ty sco) = f (ForAll ann arg (go ty) sco)
+ go (ForAll ann arg mbK ty sco) = f (ForAll ann arg mbK (go ty) sco)
go (ConstrainedType ann c ty) = f (ConstrainedType ann (mapConstraintArgs (map go) c) (go ty))
go (RCons ann name ty rest) = f (RCons ann name (go ty) (go rest))
go (KindedType ann ty k) = f (KindedType ann (go ty) k)
@@ -462,7 +470,7 @@ everywhereOnTypes f = go where
everywhereOnTypesTopDown :: (Type a -> Type a) -> Type a -> Type a
everywhereOnTypesTopDown f = go . f where
go (TypeApp ann t1 t2) = TypeApp ann (go (f t1)) (go (f t2))
- go (ForAll ann arg ty sco) = ForAll ann arg (go (f ty)) sco
+ go (ForAll ann arg mbK ty sco) = ForAll ann arg mbK (go (f ty)) sco
go (ConstrainedType ann c ty) = ConstrainedType ann (mapConstraintArgs (map (go . f)) c) (go (f ty))
go (RCons ann name ty rest) = RCons ann name (go (f ty)) (go (f rest))
go (KindedType ann ty k) = KindedType ann (go (f ty)) k
@@ -473,7 +481,7 @@ everywhereOnTypesTopDown f = go . f where
everywhereOnTypesM :: Monad m => (Type a -> m (Type a)) -> Type a -> m (Type a)
everywhereOnTypesM f = go where
go (TypeApp ann t1 t2) = (TypeApp ann <$> go t1 <*> go t2) >>= f
- go (ForAll ann arg ty sco) = (ForAll ann arg <$> go ty <*> pure sco) >>= f
+ go (ForAll ann arg mbK ty sco) = (ForAll ann arg mbK <$> go ty <*> pure sco) >>= f
go (ConstrainedType ann c ty) = (ConstrainedType ann <$> overConstraintArgs (mapM go) c <*> go ty) >>= f
go (RCons ann name ty rest) = (RCons ann name <$> go ty <*> go rest) >>= f
go (KindedType ann ty k) = (KindedType ann <$> go ty <*> pure k) >>= f
@@ -484,7 +492,7 @@ everywhereOnTypesM f = go where
everywhereOnTypesTopDownM :: Monad m => (Type a -> m (Type a)) -> Type a -> m (Type a)
everywhereOnTypesTopDownM f = go <=< f where
go (TypeApp ann t1 t2) = TypeApp ann <$> (f t1 >>= go) <*> (f t2 >>= go)
- go (ForAll ann arg ty sco) = ForAll ann arg <$> (f ty >>= go) <*> pure sco
+ go (ForAll ann arg mbK ty sco) = ForAll ann arg mbK <$> (f ty >>= go) <*> pure sco
go (ConstrainedType ann c ty) = ConstrainedType ann <$> overConstraintArgs (mapM (go <=< f)) c <*> (f ty >>= go)
go (RCons ann name ty rest) = RCons ann name <$> (f ty >>= go) <*> (f rest >>= go)
go (KindedType ann ty k) = KindedType ann <$> (f ty >>= go) <*> pure k
@@ -495,7 +503,7 @@ everywhereOnTypesTopDownM f = go <=< f where
everythingOnTypes :: (r -> r -> r) -> (Type a -> r) -> Type a -> r
everythingOnTypes (<+>) f = go where
go t@(TypeApp _ t1 t2) = f t <+> go t1 <+> go t2
- go t@(ForAll _ _ ty _) = f t <+> go ty
+ go t@(ForAll _ _ _ ty _) = f t <+> go ty
go t@(ConstrainedType _ c ty) = foldl (<+>) (f t) (map go (constraintArgs c)) <+> go ty
go t@(RCons _ _ ty rest) = f t <+> go ty <+> go rest
go t@(KindedType _ ty _) = f t <+> go ty
@@ -507,7 +515,7 @@ everythingWithContextOnTypes :: s -> r -> (r -> r -> r) -> (s -> Type a -> (s, r
everythingWithContextOnTypes s0 r0 (<+>) f = go' s0 where
go' s t = let (s', r) = f s t in r <+> go s' t
go s (TypeApp _ t1 t2) = go' s t1 <+> go' s t2
- go s (ForAll _ _ ty _) = go' s ty
+ go s (ForAll _ _ _ ty _) = go' s ty
go s (ConstrainedType _ c ty) = foldl (<+>) r0 (map (go' s) (constraintArgs c)) <+> go' s ty
go s (RCons _ _ ty rest) = go' s ty <+> go' s rest
go s (KindedType _ ty _) = go' s ty
@@ -523,7 +531,7 @@ annForType k (TypeWildcard a b) = (\z -> TypeWildcard z b) <$> k a
annForType k (TypeConstructor a b) = (\z -> TypeConstructor z b) <$> k a
annForType k (TypeOp a b) = (\z -> TypeOp z b) <$> k a
annForType k (TypeApp a b c) = (\z -> TypeApp z b c) <$> k a
-annForType k (ForAll a b c d) = (\z -> ForAll z b c d) <$> k a
+annForType k (ForAll a b c d e) = (\z -> ForAll z b c d e) <$> k a
annForType k (ConstrainedType a b c) = (\z -> ConstrainedType z b c) <$> k a
annForType k (Skolem a b c d) = (\z -> Skolem z b c d) <$> k a
annForType k (REmpty a) = REmpty <$> k a
@@ -552,7 +560,7 @@ eqType (TypeWildcard _ a) (TypeWildcard _ a') = a == a'
eqType (TypeConstructor _ a) (TypeConstructor _ a') = a == a'
eqType (TypeOp _ a) (TypeOp _ a') = a == a'
eqType (TypeApp _ a b) (TypeApp _ a' b') = eqType a a' && eqType b b'
-eqType (ForAll _ a b c) (ForAll _ a' b' c') = a == a' && eqType b b' && c == c'
+eqType (ForAll _ a b c d) (ForAll _ a' b' c' d') = a == a' && eqMaybeKind b b' && eqType c c' && d == d'
eqType (ConstrainedType _ a b) (ConstrainedType _ a' b') = eqConstraint a a' && eqType b b'
eqType (Skolem _ a b c) (Skolem _ a' b' c') = a == a' && b == b' && c == c'
eqType (REmpty _) (REmpty _) = True
@@ -590,7 +598,7 @@ compareType (TypeApp _ a b) (TypeApp _ a' b') = compareType a a' <> compareType
compareType (TypeApp {}) _ = LT
compareType _ (TypeApp {}) = GT
-compareType (ForAll _ a b c) (ForAll _ a' b' c') = compare a a' <> compareType b b' <> compare c c'
+compareType (ForAll _ a b c d) (ForAll _ a' b' c' d') = compare a a' <> compareMaybeKind b b' <> compareType c c' <> compare d d'
compareType (ForAll {}) _ = LT
compareType _ (ForAll {}) = GT
diff --git a/tests/Language/PureScript/Ide/ImportsSpec.hs b/tests/Language/PureScript/Ide/ImportsSpec.hs
index 5c29c86..040ad36 100644
--- a/tests/Language/PureScript/Ide/ImportsSpec.hs
+++ b/tests/Language/PureScript/Ide/ImportsSpec.hs
@@ -72,9 +72,9 @@ spec = do
describe "determining the importsection" $ do
let moduleSkeleton imports =
Right (P.moduleNameFromString "Main", take 1 simpleFile, imports, drop 2 simpleFile)
- it "slices a file without imports and adds a newline after the module declaration" $
+ it "slices a file without imports" $
shouldBe (sliceImportSection noImportsFile)
- (Right (P.moduleNameFromString "Main", take 1 noImportsFile ++ [""], [], drop 1 noImportsFile))
+ (Right (P.moduleNameFromString "Main", take 1 noImportsFile, [], drop 1 noImportsFile))
it "handles a file with syntax errors just fine" $
shouldBe (sliceImportSection syntaxErrorFile)
@@ -351,7 +351,12 @@ addExplicitImportFiltered i ms =
importShouldBe :: [Text] -> [Text] -> Expectation
importShouldBe res importSection =
- res `shouldBe` [ "module ImportsSpec where" , ""] ++ importSection ++ [ "" , "myId x = x"]
+ res `shouldBe`
+ [ "module ImportsSpec where" ]
+ ++ (if null importSection then [] else "" : importSection)
+ ++ [ ""
+ , "myId x = x"
+ ]
runIdeLoaded :: Command -> IO (Either IdeError Success)
runIdeLoaded c = do
diff --git a/tests/Language/PureScript/Ide/UsageSpec.hs b/tests/Language/PureScript/Ide/UsageSpec.hs
index d1e83eb..3c619dc 100644
--- a/tests/Language/PureScript/Ide/UsageSpec.hs
+++ b/tests/Language/PureScript/Ide/UsageSpec.hs
@@ -47,7 +47,7 @@ spec = describe "Finding Usages" $ do
, usage (Test.mn "FindUsage.Definition") "usageId" IdeNSValue
]
usage1 `shouldBeUsage` ("src" </> "FindUsage.purs", "12:11-12:18")
- usage2 `shouldBeUsage` ("src" </> "FindUsage" </> "Definition.purs", "13:18-13:18")
+ usage2 `shouldBeUsage` ("src" </> "FindUsage" </> "Definition.purs", "13:18-13:25")
it "finds a simple recursive usage" $ do
([_, Right (UsagesResult [usage1])], _) <- Test.inProject $
Test.runIde [ load ["FindUsage.Recursive"]
@@ -77,6 +77,4 @@ spec = describe "Finding Usages" $ do
Test.runIde [ load ["FindUsage", "FindUsage.Definition", "FindUsage.Reexport"]
, usage (Test.mn "FindUsage.Reexport") "toBeReexported" IdeNSValue
]
- -- TODO(Christoph): Interesting parser bug here. It seems the position
- -- of the last token in the file has the wrong ending span
- usage1 `shouldBeUsage` ("src" </> "FindUsage.purs", "12:19-12:19")
+ usage1 `shouldBeUsage` ("src" </> "FindUsage.purs", "12:19-12:33")
diff --git a/tests/Main.hs b/tests/Main.hs
index e7c29b4..37bf70b 100644
--- a/tests/Main.hs
+++ b/tests/Main.hs
@@ -10,6 +10,7 @@ import Prelude.Compat
import Test.Tasty
+import qualified TestCst
import qualified TestCompiler
import qualified TestCoreFn
import qualified TestDocs
@@ -31,6 +32,7 @@ main = do
heading "Updating support code"
TestUtils.updateSupportCode
+ cstTests <- TestCst.main
ideTests <- TestIde.main
compilerTests <- TestCompiler.main
psciTests <- TestPsci.main
@@ -44,7 +46,8 @@ main = do
defaultMain $
testGroup
"Tests"
- [ compilerTests
+ [ cstTests
+ , compilerTests
, psciTests
, pscBundleTests
, ideTests
diff --git a/tests/TestCst.hs b/tests/TestCst.hs
new file mode 100644
index 0000000..abaddc0
--- /dev/null
+++ b/tests/TestCst.hs
@@ -0,0 +1,223 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+module TestCst where
+
+import Prelude
+
+import Control.Monad (when)
+import qualified Data.ByteString.Lazy as BS
+import Data.Maybe (fromMaybe)
+import Data.Text (Text)
+import qualified Data.Text as Text
+import qualified Data.Text.Encoding as Text
+import qualified Data.Text.IO as Text
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.Golden (goldenVsString, findByExtension)
+import Test.Tasty.QuickCheck
+import Text.Read (readMaybe)
+import Language.PureScript.CST.Errors as CST
+import Language.PureScript.CST.Lexer as CST
+import Language.PureScript.CST.Print as CST
+import Language.PureScript.CST.Types
+import System.FilePath (takeBaseName, replaceExtension)
+
+main :: IO TestTree
+main = do
+ lytTests <- layoutTests
+ pure $ testGroup "cst"
+ [ lytTests
+ , litTests
+ ]
+
+layoutTests :: IO TestTree
+layoutTests = do
+ pursFiles <- findByExtension [".purs"] "./tests/purs/layout"
+ return $ testGroup "Layout golden tests" $ do
+ file <- pursFiles
+ pure $ goldenVsString
+ (takeBaseName file)
+ (replaceExtension file ".out")
+ (BS.fromStrict . Text.encodeUtf8 <$> runLexer file)
+ where
+ runLexer file = do
+ src <- Text.readFile file
+ case sequence $ CST.lex src of
+ Left (_, err) ->
+ pure $ Text.pack $ CST.prettyPrintError err
+ Right toks -> do
+ pure $ CST.printTokens toks
+
+litTests :: TestTree
+litTests = testGroup "Literals"
+ [ testProperty "Integer" $
+ checkTok checkReadNum (\case TokInt _ a -> Just a; _ -> Nothing) . unInt
+ , testProperty "Hex" $
+ checkTok checkReadNum (\case TokInt _ a -> Just a; _ -> Nothing) . unHex
+ , testProperty "Number" $
+ checkTok checkReadNum (\case TokNumber _ a -> Just a; _ -> Nothing) . unFloat
+ , testProperty "Exponent" $
+ checkTok checkReadNum (\case TokNumber _ a -> Just a; _ -> Nothing) . unExponent
+
+ , testProperty "Integer (round trip)" $ roundTripTok . unInt
+ , testProperty "Hex (round trip)" $ roundTripTok . unHex
+ , testProperty "Number (round trip)" $ roundTripTok . unFloat
+ , testProperty "Exponent (round trip)" $ roundTripTok . unExponent
+ , testProperty "Char (round trip)" $ roundTripTok . unChar
+ , testProperty "String (round trip)" $ roundTripTok . unString
+ , testProperty "Raw String (round trip)" $ roundTripTok . unRawString
+ ]
+
+readTok :: Text -> Gen SourceToken
+readTok t = case CST.lex t of
+ Right tok : _ ->
+ pure tok
+ Left (_, err) : _ ->
+ fail $ "Failed to parse: " <> CST.prettyPrintError err
+ [] ->
+ fail "Empty token stream"
+
+checkTok
+ :: (Text -> a -> Gen Bool)
+ -> (Token -> Maybe a)
+ -> Text
+ -> Gen Bool
+checkTok p f t = do
+ SourceToken _ tok <- readTok t
+ case f tok of
+ Just a -> p t a
+ Nothing -> fail $ "Failed to lex correctly: " <> show tok
+
+roundTripTok :: Text -> Gen Bool
+roundTripTok t = do
+ tok <- readTok t
+ let t' = CST.printTokens [tok]
+ tok' <- readTok t'
+ pure $ tok == tok'
+
+checkReadNum :: (Eq a, Read a) => Text -> a -> Gen Bool
+checkReadNum t a = do
+ let
+ chs = case Text.unpack $ Text.replace ".e" ".0e" $ Text.replace "_" "" t of
+ chs' | last chs' == '.' -> chs' <> "0"
+ chs' -> chs'
+ case (== a) <$> readMaybe chs of
+ Just a' -> pure a'
+ Nothing -> fail "Failed to `read`"
+
+newtype PSSourceInt = PSSourceInt { unInt :: Text }
+ deriving (Show, Eq)
+
+instance Arbitrary PSSourceInt where
+ arbitrary = resize 16 genInt
+
+newtype PSSourceFloat = PSSourceFloat { unFloat :: Text }
+ deriving (Show, Eq)
+
+instance Arbitrary PSSourceFloat where
+ arbitrary = resize 16 genFloat
+
+newtype PSSourceExponent = PSSourceExponent { unExponent :: Text }
+ deriving (Show, Eq)
+
+instance Arbitrary PSSourceExponent where
+ arbitrary = PSSourceExponent <$> do
+ floatPart <- unFloat <$> resize 5 genFloat
+ signPart <- fromMaybe "" <$> elements [ Just "+", Just "-", Nothing ]
+ expPart <- unInt <$> resize 1 genInt
+ pure $ floatPart <> "e" <> signPart <> expPart
+
+newtype PSSourceHex = PSSourceHex { unHex :: Text }
+ deriving (Show, Eq)
+
+instance Arbitrary PSSourceHex where
+ arbitrary = resize 16 genHex
+
+newtype PSSourceChar = PSSourceChar { unChar :: Text }
+ deriving (Show, Eq)
+
+instance Arbitrary PSSourceChar where
+ arbitrary = genChar
+
+newtype PSSourceString = PSSourceString { unString :: Text }
+ deriving (Show, Eq)
+
+instance Arbitrary PSSourceString where
+ arbitrary = resize 256 genString
+
+newtype PSSourceRawString = PSSourceRawString { unRawString :: Text }
+ deriving (Show, Eq)
+
+instance Arbitrary PSSourceRawString where
+ arbitrary = resize 256 genRawString
+
+genInt :: Gen PSSourceInt
+genInt = PSSourceInt . Text.pack <$> do
+ (:) <$> nonZeroChar
+ <*> listOf numChar
+
+genFloat :: Gen PSSourceFloat
+genFloat = PSSourceFloat <$> do
+ intPart <- unInt <$> genInt
+ floatPart <- Text.pack <$> listOf1 numChar
+ pure $ intPart <> "." <> floatPart
+
+genHex :: Gen PSSourceHex
+genHex = PSSourceHex <$> do
+ nums <- listOf1 hexDigit
+ pure $ "0x" <> Text.pack nums
+
+genChar :: Gen PSSourceChar
+genChar = PSSourceChar <$> do
+ ch <- (toEnum :: Int -> Char) <$> resize 0xFFFF arbitrarySizedNatural
+ ch' <- case ch of
+ '\'' -> discard
+ '\\' -> genCharEscape
+ c -> pure $ Text.singleton c
+ pure $ "'" <> ch' <> "'"
+
+genString :: Gen PSSourceString
+genString = PSSourceString <$> do
+ chs <- listOf $ arbitraryUnicodeChar >>= \case
+ '"' -> discard
+ '\n' -> discard
+ '\r' -> discard
+ '\\' -> genCharEscape
+ c -> pure $ Text.singleton c
+ pure $ "\"" <> Text.concat chs <> "\""
+
+genRawString :: Gen PSSourceRawString
+genRawString = PSSourceRawString <$> do
+ chs <- listOf $ arbitraryUnicodeChar
+ let
+ k1 acc qs cs = do
+ let (cs', q) = span (/= '"') cs
+ k2 (acc <> cs') qs q
+ k2 acc qs [] = acc <> qs
+ k2 acc qs cs = do
+ let (q, cs') = span (== '"') cs
+ k1 (acc <> take 2 q) (qs <> drop 2 q) cs'
+ chs' = k1 [] [] chs
+ when (all (== '"') chs') discard
+ pure $ "\"\"\"" <> Text.pack chs' <> "\"\"\""
+
+genCharEscape :: Gen Text
+genCharEscape = oneof
+ [ pure "\\t"
+ , pure "\\r"
+ , pure "\\n"
+ , pure "\\\""
+ , pure "\\'"
+ , pure "\\\\"
+ , do
+ chs <- resize 4 $ listOf1 hexDigit
+ pure $ "\\x" <> Text.pack chs
+ ]
+
+numChar :: Gen Char
+numChar = elements "0123456789_"
+
+nonZeroChar :: Gen Char
+nonZeroChar = elements "123456789"
+
+hexDigit :: Gen Char
+hexDigit = elements $ ['a'..'f'] <> ['A'..'F'] <> ['0'..'9']
diff --git a/tests/TestDocs.hs b/tests/TestDocs.hs
index 9c7bdfb..07a0c52 100644
--- a/tests/TestDocs.hs
+++ b/tests/TestDocs.hs
@@ -10,8 +10,6 @@ import Prelude ()
import Prelude.Compat
import Control.Arrow (first)
-import Control.Monad.IO.Class (liftIO)
-
import Data.List (findIndex)
import Data.Foldable
import Safe (headMay)
@@ -20,49 +18,36 @@ import Data.Maybe (fromMaybe, mapMaybe)
import Data.Monoid
import Data.Text (Text)
import qualified Data.Text as T
-import Data.Time.Clock (getCurrentTime)
-import Data.Version (Version(..))
-import System.Exit
+import qualified Text.PrettyPrint.Boxes as Boxes
import qualified Language.PureScript as P
import qualified Language.PureScript.Docs as Docs
import Language.PureScript.Docs.AsMarkdown (codeToString)
-import qualified Language.PureScript.Publish as Publish
import qualified Language.PureScript.Publish.ErrorsWarnings as Publish
import Web.Bower.PackageMeta (parsePackageName, runPackageName)
-import TestUtils
+import TestPscPublish (preparePackage)
import Test.Tasty
import Test.Tasty.Hspec (Spec, it, context, expectationFailure, runIO, testSpec)
-publishOpts :: Publish.PublishOptions
-publishOpts = Publish.defaultPublishOptions
- { Publish.publishGetVersion = return testVersion
- , Publish.publishGetTagTime = const (liftIO getCurrentTime)
- , Publish.publishWorkingTreeDirty = return ()
- }
- where testVersion = ("v999.0.0", Version [999,0,0] [])
-
-getPackage :: IO (Either Publish.PackageError (Docs.Package Docs.NotYetKnown))
-getPackage =
- pushd "tests/purs/docs" $
- Publish.preparePackage "bower.json" "resolutions.json" publishOpts
-
main :: IO TestTree
main = testSpec "docs" spec
spec :: Spec
spec = do
- pkg@Docs.Package{..} <- runIO $ do
- res <- getPackage
- case res of
- Left e ->
- Publish.printErrorToStdout e >> exitFailure
- Right p ->
- pure p
+ packageResult <- runIO (preparePackage "tests/purs/docs" "resolutions.json")
+
+ case packageResult of
+ Left e ->
+ it "failed to produce docs" $ do
+ expectationFailure (Boxes.render (Publish.renderError e))
+ Right pkg ->
+ mkSpec pkg
+mkSpec :: Docs.Package Docs.NotYetKnown -> Spec
+mkSpec pkg@Docs.Package{..} = do
let linksCtx = Docs.getLinksContext pkg
context "Language.PureScript.Docs" $ do
@@ -506,7 +491,7 @@ checkConstrained ty tyClass =
P.ConstrainedType _ c ty'
| matches tyClass c -> True
| otherwise -> checkConstrained ty' tyClass
- P.ForAll _ _ ty' _ ->
+ P.ForAll _ _ _ ty' _ ->
checkConstrained ty' tyClass
_ ->
False
@@ -648,6 +633,11 @@ testCases =
[ ValueShouldHaveTypeSignature (n "Ado") "test" (renderedType "Int")
]
)
+
+ , ("TypeSynonymInstance",
+ [ ShouldBeDocumented (n "TypeSynonymInstance") "MyNT" ["MyNT", "ntMyNT"]
+ ]
+ )
]
where
diff --git a/tests/TestPscPublish.hs b/tests/TestPscPublish.hs
index 64dda76..b91e9cd 100644
--- a/tests/TestPscPublish.hs
+++ b/tests/TestPscPublish.hs
@@ -1,11 +1,13 @@
-{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE LambdaCase #-}
module TestPscPublish where
import Prelude
+import Control.Exception (tryJust)
+import Control.Monad (void, guard)
import Control.Monad.IO.Class (liftIO)
import Data.ByteString.Lazy (ByteString)
import Data.Time.Clock (getCurrentTime)
@@ -13,16 +15,18 @@ import qualified Data.Aeson as A
import Data.Version
import Data.Foldable (forM_)
import qualified Text.PrettyPrint.Boxes as Boxes
-import System.Directory (listDirectory)
+import System.Directory (listDirectory, removeDirectoryRecursive)
import System.FilePath ((</>))
+import System.IO.Error (isDoesNotExistError)
import Language.PureScript.Docs
-import Language.PureScript.Publish
-import Language.PureScript.Publish.ErrorsWarnings as Publish
+import Language.PureScript.Publish (PublishOptions(..), defaultPublishOptions)
+import qualified Language.PureScript.Publish as Publish
+import qualified Language.PureScript.Publish.ErrorsWarnings as Publish
import Test.Tasty
import Test.Tasty.Hspec (Spec, Expectation, runIO, context, it, expectationFailure, testSpec)
-import TestUtils
+import TestUtils hiding (inferForeignModules, makeActions)
main :: IO TestTree
main = testSpec "publish" spec
@@ -77,9 +81,10 @@ roundTrip pkg =
then Pass before
else Mismatch before after'
-testRunOptions :: PublishOptions
-testRunOptions = defaultPublishOptions
- { publishGetVersion = return testVersion
+testRunOptions :: FilePath -> PublishOptions
+testRunOptions resolutionsFile = defaultPublishOptions
+ { publishResolutionsFile = resolutionsFile
+ , publishGetVersion = return testVersion
, publishGetTagTime = const (liftIO getCurrentTime)
, publishWorkingTreeDirty = return ()
}
@@ -88,12 +93,12 @@ testRunOptions = defaultPublishOptions
-- | Given a directory which contains a package, produce JSON from it, and then
-- | attempt to parse it again, and ensure that it doesn't change.
testPackage :: FilePath -> FilePath -> Expectation
-testPackage dir resolutionsFile = do
- res <- pushd dir (preparePackage "bower.json" resolutionsFile testRunOptions)
+testPackage packageDir resolutionsFile = do
+ res <- preparePackage packageDir resolutionsFile
case res of
Left err ->
expectationFailure $
- "Failed to produce JSON from " ++ dir ++ ":\n" ++
+ "Failed to produce JSON from " ++ packageDir ++ ":\n" ++
Boxes.render (Publish.renderError err)
Right package ->
case roundTrip package of
@@ -103,3 +108,17 @@ testPackage dir resolutionsFile = do
expectationFailure ("Failed to re-parse: " ++ msg)
Mismatch _ _ ->
expectationFailure "JSON did not match"
+
+-- A version of Publish.preparePackage suitable for use in tests. We remove the
+-- output directory each time to ensure that we are actually testing the docs
+-- code in the working tree as it is now (as opposed to how it was at some
+-- point in the past when the tests were previously successfully run).
+preparePackage :: FilePath -> FilePath -> IO (Either Publish.PackageError UploadedPackage)
+preparePackage packageDir resolutionsFile =
+ pushd packageDir $ do
+ removeDirectoryRecursiveIfPresent "output"
+ Publish.preparePackage (testRunOptions resolutionsFile)
+
+removeDirectoryRecursiveIfPresent :: FilePath -> IO ()
+removeDirectoryRecursiveIfPresent =
+ void . tryJust (guard . isDoesNotExistError) . removeDirectoryRecursive
diff --git a/tests/TestPsci/TestEnv.hs b/tests/TestPsci/TestEnv.hs
index 646d93b..31d5fdc 100644
--- a/tests/TestPsci/TestEnv.hs
+++ b/tests/TestPsci/TestEnv.hs
@@ -13,6 +13,7 @@ import Data.Foldable (traverse_)
import Data.List (isSuffixOf)
import qualified Data.Text as T
import qualified Language.PureScript as P
+import qualified Language.PureScript.CST as CST
import Language.PureScript.Interactive
import System.Directory (getCurrentDirectory, doesPathExist, removeFile)
import System.Exit
@@ -39,7 +40,7 @@ initTestPSCiEnv = do
print err >> exitFailure
Right modules -> do
-- Make modules
- makeResultOrError <- runMake . make $ modules
+ makeResultOrError <- runMake . make $ fmap CST.pureResult <$> modules
case makeResultOrError of
Left errs -> putStrLn (P.prettyPrintMultipleErrors P.defaultPPEOptions errs) >> exitFailure
Right (externs, _) ->
diff --git a/tests/TestUtils.hs b/tests/TestUtils.hs
index f2c477f..fe0c14d 100644
--- a/tests/TestUtils.hs
+++ b/tests/TestUtils.hs
@@ -8,6 +8,7 @@ import Prelude ()
import Prelude.Compat
import qualified Language.PureScript as P
+import qualified Language.PureScript.CST as CST
import Control.Arrow ((***), (>>>))
import Control.Monad
@@ -29,7 +30,7 @@ import System.IO.UTF8 (readUTF8FileT)
import System.Exit (exitFailure)
import System.FilePath
import qualified System.FilePath.Glob as Glob
-import System.IO
+import System.IO
import Test.Tasty.Hspec
@@ -82,7 +83,7 @@ getSupportModuleTuples = do
libraries <- Glob.globDir1 (Glob.compile "purescript-*/src/**/*.purs") (supportDir </> "bower_components")
let pursFiles = psciFiles ++ libraries
fileContents <- readInput pursFiles
- modules <- runExceptT $ ExceptT . return $ P.parseModulesFromFiles id fileContents
+ modules <- runExceptT $ ExceptT . return $ CST.parseFromFiles id fileContents
case modules of
Right ms -> return ms
Left errs -> fail (P.prettyPrintMultipleErrors P.defaultPPEOptions errs)
@@ -111,7 +112,7 @@ setupSupportModules = do
let modules = map snd ms
supportExterns <- runExceptT $ do
foreigns <- inferForeignModules ms
- externs <- ExceptT . fmap fst . runTest $ P.make (makeActions modules foreigns) modules
+ externs <- ExceptT . fmap fst . runTest $ P.make (makeActions modules foreigns) (CST.pureResult <$> modules)
return (externs, foreigns)
case supportExterns of
Left errs -> fail (P.prettyPrintMultipleErrors P.defaultPPEOptions errs)
@@ -168,13 +169,13 @@ compile
-> IO (Either P.MultipleErrors [P.ExternsFile], P.MultipleErrors)
compile supportModules supportExterns supportForeigns inputFiles check = runTest $ do
fs <- liftIO $ readInput inputFiles
- ms <- P.parseModulesFromFiles id fs
+ ms <- CST.parseFromFiles id fs
foreigns <- inferForeignModules ms
liftIO (check (map snd ms))
let actions = makeActions supportModules (foreigns `M.union` supportForeigns)
case ms of
[singleModule] -> pure <$> P.rebuildModule actions supportExterns (snd singleModule)
- _ -> P.make actions (supportModules ++ map snd ms)
+ _ -> P.make actions (CST.pureResult <$> supportModules ++ map snd ms)
assert
:: [P.Module]
diff --git a/tests/purs/docs/bower_components/purescript-newtype/src/Data/Newtype.purs b/tests/purs/docs/bower_components/purescript-newtype/src/Data/Newtype.purs
new file mode 100644
index 0000000..6c17d64
--- /dev/null
+++ b/tests/purs/docs/bower_components/purescript-newtype/src/Data/Newtype.purs
@@ -0,0 +1,5 @@
+module Data.Newtype where
+
+class Newtype t a | t -> a where
+ wrap :: a -> t
+ unwrap :: t -> a
diff --git a/tests/purs/docs/output/Ado/docs.json b/tests/purs/docs/output/Ado/docs.json
new file mode 100644
index 0000000..bb03fda
--- /dev/null
+++ b/tests/purs/docs/output/Ado/docs.json
@@ -0,0 +1 @@
+{"reExports":[],"name":"Ado","comments":null,"declarations":[{"children":[],"comments":null,"title":"test","info":{"declType":"value","type":{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Int"]}},"sourceSpan":{"start":[4,1],"name":"src/Ado.purs","end":[9,16]}}]} \ No newline at end of file
diff --git a/tests/purs/docs/output/Ado/externs.json b/tests/purs/docs/output/Ado/externs.json
new file mode 100644
index 0000000..14e72ae
--- /dev/null
+++ b/tests/purs/docs/output/Ado/externs.json
@@ -0,0 +1 @@
+{"efVersion":"0.12.5","efModuleName":["Ado"],"efExports":[{"ValueRef":[{"start":[2,1],"name":"src/Ado.purs","end":[9,16]},{"Ident":"test"}]}],"efImports":[{"eiModule":["Prim"],"eiImportType":{"Implicit":[]},"eiImportedAs":["Prim"]},{"eiModule":["Prim"],"eiImportType":{"Implicit":[]},"eiImportedAs":null}],"efFixities":[],"efTypeFixities":[],"efDeclarations":[{"EDValue":{"edValueName":{"Ident":"test"},"edValueType":{"annotation":[{"start":[0,0],"name":"","end":[0,0]},[]],"tag":"TypeConstructor","contents":[["Prim"],"Int"]}}}],"efSourceSpan":{"start":[2,1],"name":"src/Ado.purs","end":[9,16]}} \ No newline at end of file
diff --git a/tests/purs/docs/output/ChildDeclOrder/docs.json b/tests/purs/docs/output/ChildDeclOrder/docs.json
new file mode 100644
index 0000000..c4f2da1
--- /dev/null
+++ b/tests/purs/docs/output/ChildDeclOrder/docs.json
@@ -0,0 +1 @@
+{"reExports":[],"name":"ChildDeclOrder","comments":null,"declarations":[{"children":[{"comments":null,"title":"First","info":{"arguments":[],"declType":"dataConstructor"},"sourceSpan":null},{"comments":null,"title":"Second","info":{"arguments":[],"declType":"dataConstructor"},"sourceSpan":null},{"comments":null,"title":"showTwo","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["ChildDeclOrder"],"Show"]},{"annotation":[],"tag":"TypeConstructor","contents":[["ChildDeclOrder"],"Two"]}]}},"sourceSpan":{"start":[18,1],"name":"src/ChildDeclOrder.purs","end":[19,15]}},{"comments":null,"title":"fooTwo","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["ChildDeclOrder"],"Foo"]},{"annotation":[],"tag":"TypeConstructor","contents":[["ChildDeclOrder"],"Two"]}]}},"sourceSpan":{"start":[21,1],"name":"src/ChildDeclOrder.purs","end":[23,16]}}],"comments":null,"title":"Two","info":{"declType":"data","dataDeclType":"data","typeArguments":[]},"sourceSpan":{"start":[7,1],"name":"src/ChildDeclOrder.purs","end":[9,11]}},{"children":[{"comments":null,"title":"show","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"String"]}]}},"sourceSpan":{"start":[12,3],"name":"src/ChildDeclOrder.purs","end":[12,22]}},{"comments":null,"title":"showTwo","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["ChildDeclOrder"],"Show"]},{"annotation":[],"tag":"TypeConstructor","contents":[["ChildDeclOrder"],"Two"]}]}},"sourceSpan":{"start":[18,1],"name":"src/ChildDeclOrder.purs","end":[19,15]}}],"comments":null,"title":"Show","info":{"fundeps":[],"arguments":[["a",null]],"declType":"typeClass","superclasses":[]},"sourceSpan":{"start":[11,1],"name":"src/ChildDeclOrder.purs","end":[12,22]}},{"children":[{"comments":null,"title":"foo1","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeVar","contents":"a"}},"sourceSpan":{"start":[15,3],"name":"src/ChildDeclOrder.purs","end":[15,12]}},{"comments":null,"title":"foo2","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeVar","contents":"a"}},"sourceSpan":{"start":[16,3],"name":"src/ChildDeclOrder.purs","end":[16,12]}},{"comments":null,"title":"fooTwo","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["ChildDeclOrder"],"Foo"]},{"annotation":[],"tag":"TypeConstructor","contents":[["ChildDeclOrder"],"Two"]}]}},"sourceSpan":{"start":[21,1],"name":"src/ChildDeclOrder.purs","end":[23,16]}},{"comments":null,"title":"fooInt","info":{"declType":"instance","dependencies":[],"type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["ChildDeclOrder"],"Foo"]},{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Int"]}]}},"sourceSpan":{"start":[25,1],"name":"src/ChildDeclOrder.purs","end":[27,11]}}],"comments":null,"title":"Foo","info":{"fundeps":[],"arguments":[["a",null]],"declType":"typeClass","superclasses":[]},"sourceSpan":{"start":[14,1],"name":"src/ChildDeclOrder.purs","end":[16,12]}}]} \ No newline at end of file
diff --git a/tests/purs/docs/output/ChildDeclOrder/externs.json b/tests/purs/docs/output/ChildDeclOrder/externs.json
new file mode 100644
index 0000000..3b74888
--- /dev/null
+++ b/tests/purs/docs/output/ChildDeclOrder/externs.json
@@ -0,0 +1 @@
+{"efVersion":"0.12.5","efModuleName":["ChildDeclOrder"],"efExports":[{"ValueRef":[{"start":[5,1],"name":"src/ChildDeclOrder.purs","end":[27,11]},{"Ident":"foo1"}]},{"ValueRef":[{"start":[5,1],"name":"src/ChildDeclOrder.purs","end":[27,11]},{"Ident":"foo2"}]},{"ValueRef":[{"start":[5,1],"name":"src/ChildDeclOrder.purs","end":[27,11]},{"Ident":"show"}]},{"TypeRef":[{"start":[5,1],"name":"src/ChildDeclOrder.purs","end":[27,11]},"Two",["First","Second"]]},{"TypeClassRef":[{"start":[5,1],"name":"src/ChildDeclOrder.purs","end":[27,11]},"Show"]},{"TypeClassRef":[{"start":[5,1],"name":"src/ChildDeclOrder.purs","end":[27,11]},"Foo"]},{"TypeInstanceRef":[{"start":[0,0],"name":"<generated>","end":[0,0]},{"Ident":"showTwo"}]},{"TypeInstanceRef":[{"start":[0,0],"name":"<generated>","end":[0,0]},{"Ident":"fooTwo"}]},{"TypeInstanceRef":[{"start":[0,0],"name":"<generated>","end":[0,0]},{"Ident":"fooInt"}]}],"efImports":[{"eiModule":["Prim"],"eiImportType":{"Implicit":[]},"eiImportedAs":["Prim"]},{"eiModule":["Prim"],"eiImportType":{"Implicit":[]},"eiImportedAs":null}],"efFixities":[],"efTypeFixities":[],"efDeclarations":[{"EDValue":{"edValueName":{"Ident":"foo1"},"edValueType":{"annotation":[{"start":[0,0],"name":"","end":[0,0]},[]],"tag":"ForAll","contents":["a",{"annotation":[{"start":[0,0],"name":"","end":[0,0]},[]],"tag":"ConstrainedType","contents":[{"constraintAnn":[{"start":[0,0],"name":"","end":[0,0]},[]],"constraintClass":[["ChildDeclOrder"],"Foo"],"constraintArgs":[{"annotation":[{"start":[0,0],"name":"","end":[0,0]},[]],"tag":"TypeVar","contents":"a"}],"constraintData":null},{"annotation":[{"start":[15,11],"name":"src/ChildDeclOrder.purs","end":[15,12]},[]],"tag":"TypeVar","contents":"a"}]},2]}}},{"EDValue":{"edValueName":{"Ident":"foo2"},"edValueType":{"annotation":[{"start":[0,0],"name":"","end":[0,0]},[]],"tag":"ForAll","contents":["a",{"annotation":[{"start":[0,0],"name":"","end":[0,0]},[]],"tag":"ConstrainedType","contents":[{"constraintAnn":[{"start":[0,0],"name":"","end":[0,0]},[]],"constraintClass":[["ChildDeclOrder"],"Foo"],"constraintArgs":[{"annotation":[{"start":[0,0],"name":"","end":[0,0]},[]],"tag":"TypeVar","contents":"a"}],"constraintData":null},{"annotation":[{"start":[16,11],"name":"src/ChildDeclOrder.purs","end":[16,12]},[]],"tag":"TypeVar","contents":"a"}]},1]}}},{"EDValue":{"edValueName":{"Ident":"show"},"edValueType":{"annotation":[{"start":[0,0],"name":"","end":[0,0]},[]],"tag":"ForAll","contents":["a",{"annotation":[{"start":[0,0],"name":"","end":[0,0]},[]],"tag":"ConstrainedType","contents":[{"constraintAnn":[{"start":[0,0],"name":"","end":[0,0]},[]],"constraintClass":[["ChildDeclOrder"],"Show"],"constraintArgs":[{"annotation":[{"start":[0,0],"name":"","end":[0,0]},[]],"tag":"TypeVar","contents":"a"}],"constraintData":null},{"annotation":[{"start":[12,11],"name":"src/ChildDeclOrder.purs","end":[12,22]},[]],"tag":"TypeApp","contents":[{"annotation":[{"start":[12,11],"name":"src/ChildDeclOrder.purs","end":[12,22]},[]],"tag":"TypeApp","contents":[{"annotation":[{"start":[12,13],"name":"src/ChildDeclOrder.purs","end":[12,15]},[]],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[{"start":[12,11],"name":"src/ChildDeclOrder.purs","end":[12,12]},[]],"tag":"TypeVar","contents":"a"}]},{"annotation":[{"start":[12,16],"name":"src/ChildDeclOrder.purs","end":[12,22]},[]],"tag":"TypeConstructor","contents":[["Prim"],"String"]}]}]},0]}}},{"EDType":{"edTypeName":"Two","edTypeKind":{"annotation":[{"start":[0,0],"name":"","end":[0,0]},[]],"tag":"NamedKind","contents":[["Prim"],"Type"]},"edTypeDeclarationKind":{"DataType":{"args":[],"ctors":[["First",[]],["Second",[]]]}}}},{"EDDataConstructor":{"edDataCtorName":"First","edDataCtorOrigin":"data","edDataCtorTypeCtor":"Two","edDataCtorType":{"annotation":[{"start":[0,0],"name":"","end":[0,0]},[]],"tag":"TypeConstructor","contents":[["ChildDeclOrder"],"Two"]},"edDataCtorFields":[]}},{"EDDataConstructor":{"edDataCtorName":"Second","edDataCtorOrigin":"data","edDataCtorTypeCtor":"Two","edDataCtorType":{"annotation":[{"start":[0,0],"name":"","end":[0,0]},[]],"tag":"TypeConstructor","contents":[["ChildDeclOrder"],"Two"]},"edDataCtorFields":[]}},{"EDType":{"edTypeName":"Show","edTypeKind":{"annotation":[{"start":[0,0],"name":"","end":[0,0]},[]],"tag":"FunKind","contents":[{"annotation":[{"start":[12,13],"name":"src/ChildDeclOrder.purs","end":[12,15]},[]],"tag":"NamedKind","contents":[["Prim"],"Type"]},{"annotation":[{"start":[0,0],"name":"","end":[0,0]},[]],"tag":"NamedKind","contents":[["Prim"],"Type"]}]},"edTypeDeclarationKind":"TypeSynonym"}},{"EDTypeSynonym":{"edTypeSynonymName":"Show","edTypeSynonymArguments":[["a",null]],"edTypeSynonymType":{"annotation":[{"start":[0,0],"name":"","end":[0,0]},[]],"tag":"TypeApp","contents":[{"annotation":[{"start":[0,0],"name":"","end":[0,0]},[]],"tag":"TypeConstructor","contents":[["Prim"],"Record"]},{"annotation":[{"start":[0,0],"name":"","end":[0,0]},[]],"tag":"RCons","contents":["show",{"annotation":[{"start":[12,11],"name":"src/ChildDeclOrder.purs","end":[12,22]},[]],"tag":"TypeApp","contents":[{"annotation":[{"start":[12,11],"name":"src/ChildDeclOrder.purs","end":[12,22]},[]],"tag":"TypeApp","contents":[{"annotation":[{"start":[12,13],"name":"src/ChildDeclOrder.purs","end":[12,15]},[]],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[{"start":[12,11],"name":"src/ChildDeclOrder.purs","end":[12,12]},[]],"tag":"TypeVar","contents":"a"}]},{"annotation":[{"start":[12,16],"name":"src/ChildDeclOrder.purs","end":[12,22]},[]],"tag":"TypeConstructor","contents":[["Prim"],"String"]}]},{"annotation":[{"start":[0,0],"name":"","end":[0,0]},[]],"tag":"REmpty"}]}]}}},{"EDClass":{"edClassName":"Show","edClassTypeArguments":[["a",null]],"edClassMembers":[[{"Ident":"show"},{"annotation":[{"start":[12,11],"name":"src/ChildDeclOrder.purs","end":[12,22]},[]],"tag":"TypeApp","contents":[{"annotation":[{"start":[12,11],"name":"src/ChildDeclOrder.purs","end":[12,22]},[]],"tag":"TypeApp","contents":[{"annotation":[{"start":[12,13],"name":"src/ChildDeclOrder.purs","end":[12,15]},[]],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[{"start":[12,11],"name":"src/ChildDeclOrder.purs","end":[12,12]},[]],"tag":"TypeVar","contents":"a"}]},{"annotation":[{"start":[12,16],"name":"src/ChildDeclOrder.purs","end":[12,22]},[]],"tag":"TypeConstructor","contents":[["Prim"],"String"]}]}]],"edClassConstraints":[],"edFunctionalDependencies":[]}},{"EDType":{"edTypeName":"Foo","edTypeKind":{"annotation":[{"start":[0,0],"name":"","end":[0,0]},[]],"tag":"FunKind","contents":[{"annotation":[{"start":[0,0],"name":"","end":[0,0]},[]],"tag":"NamedKind","contents":[["Prim"],"Type"]},{"annotation":[{"start":[0,0],"name":"","end":[0,0]},[]],"tag":"NamedKind","contents":[["Prim"],"Type"]}]},"edTypeDeclarationKind":"TypeSynonym"}},{"EDTypeSynonym":{"edTypeSynonymName":"Foo","edTypeSynonymArguments":[["a",null]],"edTypeSynonymType":{"annotation":[{"start":[0,0],"name":"","end":[0,0]},[]],"tag":"TypeApp","contents":[{"annotation":[{"start":[0,0],"name":"","end":[0,0]},[]],"tag":"TypeConstructor","contents":[["Prim"],"Record"]},{"annotation":[{"start":[0,0],"name":"","end":[0,0]},[]],"tag":"RCons","contents":["foo1",{"annotation":[{"start":[15,11],"name":"src/ChildDeclOrder.purs","end":[15,12]},[]],"tag":"TypeVar","contents":"a"},{"annotation":[{"start":[0,0],"name":"","end":[0,0]},[]],"tag":"RCons","contents":["foo2",{"annotation":[{"start":[16,11],"name":"src/ChildDeclOrder.purs","end":[16,12]},[]],"tag":"TypeVar","contents":"a"},{"annotation":[{"start":[0,0],"name":"","end":[0,0]},[]],"tag":"REmpty"}]}]}]}}},{"EDClass":{"edClassName":"Foo","edClassTypeArguments":[["a",null]],"edClassMembers":[[{"Ident":"foo1"},{"annotation":[{"start":[15,11],"name":"src/ChildDeclOrder.purs","end":[15,12]},[]],"tag":"TypeVar","contents":"a"}],[{"Ident":"foo2"},{"annotation":[{"start":[16,11],"name":"src/ChildDeclOrder.purs","end":[16,12]},[]],"tag":"TypeVar","contents":"a"}]],"edClassConstraints":[],"edFunctionalDependencies":[]}},{"EDInstance":{"edInstanceClassName":[["ChildDeclOrder"],"Show"],"edInstanceName":{"Ident":"showTwo"},"edInstanceTypes":[{"annotation":[{"start":[18,26],"name":"src/ChildDeclOrder.purs","end":[18,29]},[]],"tag":"TypeConstructor","contents":[["ChildDeclOrder"],"Two"]}],"edInstanceConstraints":[],"edInstanceChain":[[["ChildDeclOrder"],{"Ident":"showTwo"}]],"edInstanceChainIndex":0}},{"EDInstance":{"edInstanceClassName":[["ChildDeclOrder"],"Foo"],"edInstanceName":{"Ident":"fooTwo"},"edInstanceTypes":[{"annotation":[{"start":[21,24],"name":"src/ChildDeclOrder.purs","end":[21,27]},[]],"tag":"TypeConstructor","contents":[["ChildDeclOrder"],"Two"]}],"edInstanceConstraints":[],"edInstanceChain":[[["ChildDeclOrder"],{"Ident":"fooTwo"}]],"edInstanceChainIndex":0}},{"EDInstance":{"edInstanceClassName":[["ChildDeclOrder"],"Foo"],"edInstanceName":{"Ident":"fooInt"},"edInstanceTypes":[{"annotation":[{"start":[25,24],"name":"src/ChildDeclOrder.purs","end":[25,27]},[]],"tag":"TypeConstructor","contents":[["Prim"],"Int"]}],"edInstanceConstraints":[],"edInstanceChain":[[["ChildDeclOrder"],{"Ident":"fooInt"}]],"edInstanceChainIndex":0}}],"efSourceSpan":{"start":[5,1],"name":"src/ChildDeclOrder.purs","end":[27,11]}} \ No newline at end of file
diff --git a/tests/purs/docs/output/Clash/docs.json b/tests/purs/docs/output/Clash/docs.json
new file mode 100644
index 0000000..d0a4ad8
--- /dev/null
+++ b/tests/purs/docs/output/Clash/docs.json
@@ -0,0 +1 @@
+{"reExports":[],"name":"Clash","comments":null,"declarations":[]} \ No newline at end of file
diff --git a/tests/purs/docs/output/Clash/externs.json b/tests/purs/docs/output/Clash/externs.json
new file mode 100644
index 0000000..66bfd57
--- /dev/null
+++ b/tests/purs/docs/output/Clash/externs.json
@@ -0,0 +1 @@
+{"efVersion":"0.12.5","efModuleName":["Clash"],"efExports":[{"ReExportRef":[{"start":[1,1],"name":"src/Clash.purs","end":[4,24]},{"exportSourceImportedFrom":["Clash1"],"exportSourceDefinedIn":["Clash1a"]},{"TypeRef":[{"start":[1,1],"name":"src/Clash.purs","end":[4,24]},"Type",[]]}]},{"ReExportRef":[{"start":[1,1],"name":"src/Clash.purs","end":[4,24]},{"exportSourceImportedFrom":["Clash1"],"exportSourceDefinedIn":["Clash1a"]},{"TypeClassRef":[{"start":[1,1],"name":"src/Clash.purs","end":[4,24]},"TypeClass"]}]},{"ReExportRef":[{"start":[1,1],"name":"src/Clash.purs","end":[4,24]},{"exportSourceImportedFrom":["Clash1"],"exportSourceDefinedIn":["Clash1a"]},{"ValueRef":[{"start":[1,1],"name":"src/Clash.purs","end":[4,24]},{"Ident":"typeClassMember"}]}]},{"ReExportRef":[{"start":[1,1],"name":"src/Clash.purs","end":[4,24]},{"exportSourceImportedFrom":["Clash1"],"exportSourceDefinedIn":["Clash1a"]},{"ValueRef":[{"start":[1,1],"name":"src/Clash.purs","end":[4,24]},{"Ident":"value"}]}]},{"ModuleRef":[{"start":[1,15],"name":"src/Clash.purs","end":[1,28]},["Clash1"]]}],"efImports":[{"eiModule":["Prim"],"eiImportType":{"Implicit":[]},"eiImportedAs":["Prim"]},{"eiModule":["Prim"],"eiImportType":{"Implicit":[]},"eiImportedAs":null},{"eiModule":["Clash1"],"eiImportType":{"Implicit":[]},"eiImportedAs":["Clash1"]},{"eiModule":["Clash2"],"eiImportType":{"Implicit":[]},"eiImportedAs":["Clash2"]}],"efFixities":[],"efTypeFixities":[],"efDeclarations":[],"efSourceSpan":{"start":[1,1],"name":"src/Clash.purs","end":[4,24]}} \ No newline at end of file
diff --git a/tests/purs/docs/output/Clash1/docs.json b/tests/purs/docs/output/Clash1/docs.json
new file mode 100644
index 0000000..89cfcaf
--- /dev/null
+++ b/tests/purs/docs/output/Clash1/docs.json
@@ -0,0 +1 @@
+{"reExports":[],"name":"Clash1","comments":null,"declarations":[]} \ No newline at end of file
diff --git a/tests/purs/docs/output/Clash1/externs.json b/tests/purs/docs/output/Clash1/externs.json
new file mode 100644
index 0000000..84690d3
--- /dev/null
+++ b/tests/purs/docs/output/Clash1/externs.json
@@ -0,0 +1 @@
+{"efVersion":"0.12.5","efModuleName":["Clash1"],"efExports":[{"ReExportRef":[{"start":[1,1],"name":"src/Clash1.purs","end":[3,15]},{"exportSourceImportedFrom":["Clash1a"],"exportSourceDefinedIn":["Clash1a"]},{"TypeRef":[{"start":[1,1],"name":"src/Clash1.purs","end":[3,15]},"Type",[]]}]},{"ReExportRef":[{"start":[1,1],"name":"src/Clash1.purs","end":[3,15]},{"exportSourceImportedFrom":["Clash1a"],"exportSourceDefinedIn":["Clash1a"]},{"TypeClassRef":[{"start":[1,1],"name":"src/Clash1.purs","end":[3,15]},"TypeClass"]}]},{"ReExportRef":[{"start":[1,1],"name":"src/Clash1.purs","end":[3,15]},{"exportSourceImportedFrom":["Clash1a"],"exportSourceDefinedIn":["Clash1a"]},{"ValueRef":[{"start":[1,1],"name":"src/Clash1.purs","end":[3,15]},{"Ident":"typeClassMember"}]}]},{"ReExportRef":[{"start":[1,1],"name":"src/Clash1.purs","end":[3,15]},{"exportSourceImportedFrom":["Clash1a"],"exportSourceDefinedIn":["Clash1a"]},{"ValueRef":[{"start":[1,1],"name":"src/Clash1.purs","end":[3,15]},{"Ident":"value"}]}]},{"ModuleRef":[{"start":[1,16],"name":"src/Clash1.purs","end":[1,30]},["Clash1a"]]}],"efImports":[{"eiModule":["Prim"],"eiImportType":{"Implicit":[]},"eiImportedAs":["Prim"]},{"eiModule":["Prim"],"eiImportType":{"Implicit":[]},"eiImportedAs":null},{"eiModule":["Clash1a"],"eiImportType":{"Implicit":[]},"eiImportedAs":null}],"efFixities":[],"efTypeFixities":[],"efDeclarations":[],"efSourceSpan":{"start":[1,1],"name":"src/Clash1.purs","end":[3,15]}} \ No newline at end of file
diff --git a/tests/purs/docs/output/Clash1a/docs.json b/tests/purs/docs/output/Clash1a/docs.json
new file mode 100644
index 0000000..0a89d36
--- /dev/null
+++ b/tests/purs/docs/output/Clash1a/docs.json
@@ -0,0 +1 @@
+{"reExports":[],"name":"Clash1a","comments":null,"declarations":[{"children":[],"comments":null,"title":"value","info":{"declType":"value","type":{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Int"]}},"sourceSpan":{"start":[3,1],"name":"src/Clash1a.purs","end":[3,13]}},{"children":[],"comments":null,"title":"Type","info":{"arguments":[],"declType":"typeSynonym","type":{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Int"]}},"sourceSpan":{"start":[6,1],"name":"src/Clash1a.purs","end":[6,16]}},{"children":[{"comments":null,"title":"typeClassMember","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeVar","contents":"a"}},"sourceSpan":{"start":[9,3],"name":"src/Clash1a.purs","end":[9,23]}}],"comments":null,"title":"TypeClass","info":{"fundeps":[],"arguments":[["a",null]],"declType":"typeClass","superclasses":[]},"sourceSpan":{"start":[8,1],"name":"src/Clash1a.purs","end":[9,23]}}]} \ No newline at end of file
diff --git a/tests/purs/docs/output/Clash1a/externs.json b/tests/purs/docs/output/Clash1a/externs.json
new file mode 100644
index 0000000..5eeb377
--- /dev/null
+++ b/tests/purs/docs/output/Clash1a/externs.json
@@ -0,0 +1 @@
+{"efVersion":"0.12.5","efModuleName":["Clash1a"],"efExports":[{"ValueRef":[{"start":[1,1],"name":"src/Clash1a.purs","end":[9,23]},{"Ident":"typeClassMember"}]},{"ValueRef":[{"start":[1,1],"name":"src/Clash1a.purs","end":[9,23]},{"Ident":"value"}]},{"TypeRef":[{"start":[1,1],"name":"src/Clash1a.purs","end":[9,23]},"Type",[]]},{"TypeClassRef":[{"start":[1,1],"name":"src/Clash1a.purs","end":[9,23]},"TypeClass"]}],"efImports":[{"eiModule":["Prim"],"eiImportType":{"Implicit":[]},"eiImportedAs":["Prim"]},{"eiModule":["Prim"],"eiImportType":{"Implicit":[]},"eiImportedAs":null}],"efFixities":[],"efTypeFixities":[],"efDeclarations":[{"EDValue":{"edValueName":{"Ident":"typeClassMember"},"edValueType":{"annotation":[{"start":[0,0],"name":"","end":[0,0]},[]],"tag":"ForAll","contents":["a",{"annotation":[{"start":[0,0],"name":"","end":[0,0]},[]],"tag":"ConstrainedType","contents":[{"constraintAnn":[{"start":[0,0],"name":"","end":[0,0]},[]],"constraintClass":[["Clash1a"],"TypeClass"],"constraintArgs":[{"annotation":[{"start":[0,0],"name":"","end":[0,0]},[]],"tag":"TypeVar","contents":"a"}],"constraintData":null},{"annotation":[{"start":[9,22],"name":"src/Clash1a.purs","end":[9,23]},[]],"tag":"TypeVar","contents":"a"}]},0]}}},{"EDValue":{"edValueName":{"Ident":"value"},"edValueType":{"annotation":[{"start":[3,10],"name":"src/Clash1a.purs","end":[3,13]},[]],"tag":"TypeConstructor","contents":[["Prim"],"Int"]}}},{"EDType":{"edTypeName":"Type","edTypeKind":{"annotation":[{"start":[6,13],"name":"src/Clash1a.purs","end":[6,16]},[]],"tag":"NamedKind","contents":[["Prim"],"Type"]},"edTypeDeclarationKind":"TypeSynonym"}},{"EDTypeSynonym":{"edTypeSynonymName":"Type","edTypeSynonymArguments":[],"edTypeSynonymType":{"annotation":[{"start":[6,13],"name":"src/Clash1a.purs","end":[6,16]},[]],"tag":"TypeConstructor","contents":[["Prim"],"Int"]}}},{"EDType":{"edTypeName":"TypeClass","edTypeKind":{"annotation":[{"start":[0,0],"name":"","end":[0,0]},[]],"tag":"FunKind","contents":[{"annotation":[{"start":[0,0],"name":"","end":[0,0]},[]],"tag":"NamedKind","contents":[["Prim"],"Type"]},{"annotation":[{"start":[0,0],"name":"","end":[0,0]},[]],"tag":"NamedKind","contents":[["Prim"],"Type"]}]},"edTypeDeclarationKind":"TypeSynonym"}},{"EDTypeSynonym":{"edTypeSynonymName":"TypeClass","edTypeSynonymArguments":[["a",null]],"edTypeSynonymType":{"annotation":[{"start":[0,0],"name":"","end":[0,0]},[]],"tag":"TypeApp","contents":[{"annotation":[{"start":[0,0],"name":"","end":[0,0]},[]],"tag":"TypeConstructor","contents":[["Prim"],"Record"]},{"annotation":[{"start":[0,0],"name":"","end":[0,0]},[]],"tag":"RCons","contents":["typeClassMember",{"annotation":[{"start":[9,22],"name":"src/Clash1a.purs","end":[9,23]},[]],"tag":"TypeVar","contents":"a"},{"annotation":[{"start":[0,0],"name":"","end":[0,0]},[]],"tag":"REmpty"}]}]}}},{"EDClass":{"edClassName":"TypeClass","edClassTypeArguments":[["a",null]],"edClassMembers":[[{"Ident":"typeClassMember"},{"annotation":[{"start":[9,22],"name":"src/Clash1a.purs","end":[9,23]},[]],"tag":"TypeVar","contents":"a"}]],"edClassConstraints":[],"edFunctionalDependencies":[]}}],"efSourceSpan":{"start":[1,1],"name":"src/Clash1a.purs","end":[9,23]}} \ No newline at end of file
diff --git a/tests/purs/docs/output/Clash2/docs.json b/tests/purs/docs/output/Clash2/docs.json
new file mode 100644
index 0000000..dad7dbd
--- /dev/null
+++ b/tests/purs/docs/output/Clash2/docs.json
@@ -0,0 +1 @@
+{"reExports":[],"name":"Clash2","comments":null,"declarations":[]} \ No newline at end of file
diff --git a/tests/purs/docs/output/Clash2/externs.json b/tests/purs/docs/output/Clash2/externs.json
new file mode 100644
index 0000000..7ca5e24
--- /dev/null
+++ b/tests/purs/docs/output/Clash2/externs.json
@@ -0,0 +1 @@
+{"efVersion":"0.12.5","efModuleName":["Clash2"],"efExports":[{"ReExportRef":[{"start":[1,1],"name":"src/Clash2.purs","end":[3,15]},{"exportSourceImportedFrom":["Clash2a"],"exportSourceDefinedIn":["Clash2a"]},{"TypeRef":[{"start":[1,1],"name":"src/Clash2.purs","end":[3,15]},"Type",[]]}]},{"ReExportRef":[{"start":[1,1],"name":"src/Clash2.purs","end":[3,15]},{"exportSourceImportedFrom":["Clash2a"],"exportSourceDefinedIn":["Clash2a"]},{"TypeClassRef":[{"start":[1,1],"name":"src/Clash2.purs","end":[3,15]},"TypeClass"]}]},{"ReExportRef":[{"start":[1,1],"name":"src/Clash2.purs","end":[3,15]},{"exportSourceImportedFrom":["Clash2a"],"exportSourceDefinedIn":["Clash2a"]},{"ValueRef":[{"start":[1,1],"name":"src/Clash2.purs","end":[3,15]},{"Ident":"typeClassMember"}]}]},{"ReExportRef":[{"start":[1,1],"name":"src/Clash2.purs","end":[3,15]},{"exportSourceImportedFrom":["Clash2a"],"exportSourceDefinedIn":["Clash2a"]},{"ValueRef":[{"start":[1,1],"name":"src/Clash2.purs","end":[3,15]},{"Ident":"value"}]}]},{"ModuleRef":[{"start":[1,16],"name":"src/Clash2.purs","end":[1,30]},["Clash2a"]]}],"efImports":[{"eiModule":["Prim"],"eiImportType":{"Implicit":[]},"eiImportedAs":["Prim"]},{"eiModule":["Prim"],"eiImportType":{"Implicit":[]},"eiImportedAs":null},{"eiModule":["Clash2a"],"eiImportType":{"Implicit":[]},"eiImportedAs":null}],"efFixities":[],"efTypeFixities":[],"efDeclarations":[],"efSourceSpan":{"start":[1,1],"name":"src/Clash2.purs","end":[3,15]}} \ No newline at end of file
diff --git a/tests/purs/docs/output/Clash2a/docs.json b/tests/purs/docs/output/Clash2a/docs.json
new file mode 100644
index 0000000..151944e
--- /dev/null
+++ b/tests/purs/docs/output/Clash2a/docs.json
@@ -0,0 +1 @@
+{"reExports":[],"name":"Clash2a","comments":null,"declarations":[{"children":[],"comments":null,"title":"value","info":{"declType":"value","type":{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"String"]}},"sourceSpan":{"start":[3,1],"name":"src/Clash2a.purs","end":[3,16]}},{"children":[],"comments":null,"title":"Type","info":{"arguments":[],"declType":"typeSynonym","type":{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"String"]}},"sourceSpan":{"start":[6,1],"name":"src/Clash2a.purs","end":[6,19]}},{"children":[{"comments":null,"title":"typeClassMember","info":{"declType":"typeClassMember","type":{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},{"annotation":[],"tag":"TypeVar","contents":"b"}]}},"sourceSpan":{"start":[9,3],"name":"src/Clash2a.purs","end":[9,28]}}],"comments":null,"title":"TypeClass","info":{"fundeps":[],"arguments":[["a",null],["b",null]],"declType":"typeClass","superclasses":[]},"sourceSpan":{"start":[8,1],"name":"src/Clash2a.purs","end":[9,28]}}]} \ No newline at end of file
diff --git a/tests/purs/docs/output/Clash2a/externs.json b/tests/purs/docs/output/Clash2a/externs.json
new file mode 100644
index 0000000..6e3febd
--- /dev/null
+++ b/tests/purs/docs/output/Clash2a/externs.json
@@ -0,0 +1 @@
+{"efVersion":"0.12.5","efModuleName":["Clash2a"],"efExports":[{"ValueRef":[{"start":[1,1],"name":"src/Clash2a.purs","end":[9,28]},{"Ident":"typeClassMember"}]},{"ValueRef":[{"start":[1,1],"name":"src/Clash2a.purs","end":[9,28]},{"Ident":"value"}]},{"TypeRef":[{"start":[1,1],"name":"src/Clash2a.purs","end":[9,28]},"Type",[]]},{"TypeClassRef":[{"start":[1,1],"name":"src/Clash2a.purs","end":[9,28]},"TypeClass"]}],"efImports":[{"eiModule":["Prim"],"eiImportType":{"Implicit":[]},"eiImportedAs":["Prim"]},{"eiModule":["Prim"],"eiImportType":{"Implicit":[]},"eiImportedAs":null}],"efFixities":[],"efTypeFixities":[],"efDeclarations":[{"EDValue":{"edValueName":{"Ident":"typeClassMember"},"edValueType":{"annotation":[{"start":[0,0],"name":"","end":[0,0]},[]],"tag":"ForAll","contents":["a",{"annotation":[{"start":[0,0],"name":"","end":[0,0]},[]],"tag":"ForAll","contents":["b",{"annotation":[{"start":[0,0],"name":"","end":[0,0]},[]],"tag":"ConstrainedType","contents":[{"constraintAnn":[{"start":[0,0],"name":"","end":[0,0]},[]],"constraintClass":[["Clash2a"],"TypeClass"],"constraintArgs":[{"annotation":[{"start":[0,0],"name":"","end":[0,0]},[]],"tag":"TypeVar","contents":"a"},{"annotation":[{"start":[0,0],"name":"","end":[0,0]},[]],"tag":"TypeVar","contents":"b"}],"constraintData":null},{"annotation":[{"start":[9,22],"name":"src/Clash2a.purs","end":[9,28]},[]],"tag":"TypeApp","contents":[{"annotation":[{"start":[9,22],"name":"src/Clash2a.purs","end":[9,28]},[]],"tag":"TypeApp","contents":[{"annotation":[{"start":[9,24],"name":"src/Clash2a.purs","end":[9,26]},[]],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[{"start":[9,22],"name":"src/Clash2a.purs","end":[9,23]},[]],"tag":"TypeVar","contents":"a"}]},{"annotation":[{"start":[9,27],"name":"src/Clash2a.purs","end":[9,28]},[]],"tag":"TypeVar","contents":"b"}]}]},0]},1]}}},{"EDValue":{"edValueName":{"Ident":"value"},"edValueType":{"annotation":[{"start":[3,10],"name":"src/Clash2a.purs","end":[3,16]},[]],"tag":"TypeConstructor","contents":[["Prim"],"String"]}}},{"EDType":{"edTypeName":"Type","edTypeKind":{"annotation":[{"start":[6,13],"name":"src/Clash2a.purs","end":[6,19]},[]],"tag":"NamedKind","contents":[["Prim"],"Type"]},"edTypeDeclarationKind":"TypeSynonym"}},{"EDTypeSynonym":{"edTypeSynonymName":"Type","edTypeSynonymArguments":[],"edTypeSynonymType":{"annotation":[{"start":[6,13],"name":"src/Clash2a.purs","end":[6,19]},[]],"tag":"TypeConstructor","contents":[["Prim"],"String"]}}},{"EDType":{"edTypeName":"TypeClass","edTypeKind":{"annotation":[{"start":[0,0],"name":"","end":[0,0]},[]],"tag":"FunKind","contents":[{"annotation":[{"start":[9,24],"name":"src/Clash2a.purs","end":[9,26]},[]],"tag":"NamedKind","contents":[["Prim"],"Type"]},{"annotation":[{"start":[0,0],"name":"","end":[0,0]},[]],"tag":"FunKind","contents":[{"annotation":[{"start":[9,24],"name":"src/Clash2a.purs","end":[9,26]},[]],"tag":"NamedKind","contents":[["Prim"],"Type"]},{"annotation":[{"start":[0,0],"name":"","end":[0,0]},[]],"tag":"NamedKind","contents":[["Prim"],"Type"]}]}]},"edTypeDeclarationKind":"TypeSynonym"}},{"EDTypeSynonym":{"edTypeSynonymName":"TypeClass","edTypeSynonymArguments":[["a",null],["b",null]],"edTypeSynonymType":{"annotation":[{"start":[0,0],"name":"","end":[0,0]},[]],"tag":"TypeApp","contents":[{"annotation":[{"start":[0,0],"name":"","end":[0,0]},[]],"tag":"TypeConstructor","contents":[["Prim"],"Record"]},{"annotation":[{"start":[0,0],"name":"","end":[0,0]},[]],"tag":"RCons","contents":["typeClassMember",{"annotation":[{"start":[9,22],"name":"src/Clash2a.purs","end":[9,28]},[]],"tag":"TypeApp","contents":[{"annotation":[{"start":[9,22],"name":"src/Clash2a.purs","end":[9,28]},[]],"tag":"TypeApp","contents":[{"annotation":[{"start":[9,24],"name":"src/Clash2a.purs","end":[9,26]},[]],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[{"start":[9,22],"name":"src/Clash2a.purs","end":[9,23]},[]],"tag":"TypeVar","contents":"a"}]},{"annotation":[{"start":[9,27],"name":"src/Clash2a.purs","end":[9,28]},[]],"tag":"TypeVar","contents":"b"}]},{"annotation":[{"start":[0,0],"name":"","end":[0,0]},[]],"tag":"REmpty"}]}]}}},{"EDClass":{"edClassName":"TypeClass","edClassTypeArguments":[["a",null],["b",null]],"edClassMembers":[[{"Ident":"typeClassMember"},{"annotation":[{"start":[9,22],"name":"src/Clash2a.purs","end":[9,28]},[]],"tag":"TypeApp","contents":[{"annotation":[{"start":[9,22],"name":"src/Clash2a.purs","end":[9,28]},[]],"tag":"TypeApp","contents":[{"annotation":[{"start":[9,24],"name":"src/Clash2a.purs","end":[9,26]},[]],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[{"start":[9,22],"name":"src/Clash2a.purs","end":[9,23]},[]],"tag":"TypeVar","contents":"a"}]},{"annotation":[{"start":[9,27],"name":"src/Clash2a.purs","end":[9,28]},[]],"tag":"TypeVar","contents":"b"}]}]],"edClassConstraints":[],"edFunctionalDependencies":[]}}],"efSourceSpan":{"start":[1,1],"name":"src/Clash2a.purs","end":[9,28]}} \ No newline at end of file
diff --git a/tests/purs/docs/output/ConstrainedArgument/docs.json b/tests/purs/docs/output/ConstrainedArgument/docs.json
new file mode 100644
index 0000000..579fc41
--- /dev/null
+++ b/tests/purs/docs/output/ConstrainedArgument/docs.json
@@ -0,0 +1 @@
+{"reExports":[],"name":"ConstrainedArgument","comments":null,"declarations":[{"children":[],"comments":null,"title":"Foo","info":{"fundeps":[],"arguments":[["t",null]],"declType":"typeClass","superclasses":[]},"sourceSpan":{"start":[3,1],"name":"src/ConstrainedArgument.purs","end":[3,12]}},{"children":[],"comments":null,"title":"WithoutArgs","info":{"arguments":[],"declType":"typeSynonym","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"ParensInType","contents":{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Prim"],"Partial"],"constraintArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeVar","contents":"a"}]}}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},null]}},"sourceSpan":{"start":[5,1],"name":"src/ConstrainedArgument.purs","end":[5,54]}},{"children":[],"comments":null,"title":"WithArgs","info":{"arguments":[],"declType":"typeSynonym","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"ParensInType","contents":{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["ConstrainedArgument"],"Foo"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintData":null},{"annotation":[],"tag":"TypeVar","contents":"a"}]}}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},null]}},"sourceSpan":{"start":[6,1],"name":"src/ConstrainedArgument.purs","end":[6,52]}},{"children":[],"comments":null,"title":"MultiWithoutArgs","info":{"arguments":[],"declType":"typeSynonym","type":{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"ParensInType","contents":{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Prim"],"Partial"],"constraintArgs":[],"constraintData":null},{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["Prim"],"Partial"],"constraintArgs":[],"constraintData":null},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},null]}},"sourceSpan":{"start":[7,1],"name":"src/ConstrainedArgument.purs","end":[7,65]}},{"children":[],"comments":null,"title":"MultiWithArgs","info":{"arguments":[],"declType":"typeSynonym","type":{"annotation":[],"tag":"ForAll","contents":["b",{"annotation":[],"tag":"ForAll","contents":["a",{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeApp","contents":[{"annotation":[],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[],"tag":"ParensInType","contents":{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["ConstrainedArgument"],"Foo"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"a"}],"constraintData":null},{"annotation":[],"tag":"ConstrainedType","contents":[{"constraintAnn":[],"constraintClass":[["ConstrainedArgument"],"Foo"],"constraintArgs":[{"annotation":[],"tag":"TypeVar","contents":"b"}],"constraintData":null},{"annotation":[],"tag":"TypeVar","contents":"a"}]}]}}]},{"annotation":[],"tag":"TypeVar","contents":"a"}]},null]},null]}},"sourceSpan":{"start":[8,1],"name":"src/ConstrainedArgument.purs","end":[8,63]}}]} \ No newline at end of file
diff --git a/tests/purs/docs/output/ConstrainedArgument/externs.json b/tests/purs/docs/output/ConstrainedArgument/externs.json
new file mode 100644
index 0000000..42788af
--- /dev/null
+++ b/tests/purs/docs/output/ConstrainedArgument/externs.json
@@ -0,0 +1 @@
+{"efVersion":"0.12.5","efModuleName":["ConstrainedArgument"],"efExports":[{"TypeClassRef":[{"start":[1,1],"name":"src/ConstrainedArgument.purs","end":[8,63]},"Foo"]},{"TypeRef":[{"start":[1,1],"name":"src/ConstrainedArgument.purs","end":[8,63]},"WithoutArgs",[]]},{"TypeRef":[{"start":[1,1],"name":"src/ConstrainedArgument.purs","end":[8,63]},"WithArgs",[]]},{"TypeRef":[{"start":[1,1],"name":"src/ConstrainedArgument.purs","end":[8,63]},"MultiWithoutArgs",[]]},{"TypeRef":[{"start":[1,1],"name":"src/ConstrainedArgument.purs","end":[8,63]},"MultiWithArgs",[]]}],"efImports":[{"eiModule":["Prim"],"eiImportType":{"Implicit":[]},"eiImportedAs":["Prim"]},{"eiModule":["Prim"],"eiImportType":{"Implicit":[]},"eiImportedAs":null}],"efFixities":[],"efTypeFixities":[],"efDeclarations":[{"EDType":{"edTypeName":"Foo","edTypeKind":{"annotation":[{"start":[0,0],"name":"","end":[0,0]},[]],"tag":"FunKind","contents":[{"annotation":[{"start":[0,0],"name":"","end":[0,0]},[]],"tag":"NamedKind","contents":[["Prim"],"Type"]},{"annotation":[{"start":[0,0],"name":"","end":[0,0]},[]],"tag":"NamedKind","contents":[["Prim"],"Type"]}]},"edTypeDeclarationKind":"TypeSynonym"}},{"EDTypeSynonym":{"edTypeSynonymName":"Foo","edTypeSynonymArguments":[["t",null]],"edTypeSynonymType":{"annotation":[{"start":[0,0],"name":"","end":[0,0]},[]],"tag":"TypeApp","contents":[{"annotation":[{"start":[0,0],"name":"","end":[0,0]},[]],"tag":"TypeConstructor","contents":[["Prim"],"Record"]},{"annotation":[{"start":[0,0],"name":"","end":[0,0]},[]],"tag":"REmpty"}]}}},{"EDClass":{"edClassName":"Foo","edClassTypeArguments":[["t",null]],"edClassMembers":[],"edClassConstraints":[],"edFunctionalDependencies":[]}},{"EDType":{"edTypeName":"WithoutArgs","edTypeKind":{"annotation":[{"start":[0,0],"name":"","end":[0,0]},[]],"tag":"NamedKind","contents":[["Prim"],"Type"]},"edTypeDeclarationKind":"TypeSynonym"}},{"EDTypeSynonym":{"edTypeSynonymName":"WithoutArgs","edTypeSynonymArguments":[],"edTypeSynonymType":{"annotation":[{"start":[5,25],"name":"src/ConstrainedArgument.purs","end":[5,54]},[]],"tag":"ForAll","contents":["a",{"annotation":[{"start":[5,35],"name":"src/ConstrainedArgument.purs","end":[5,54]},[]],"tag":"TypeApp","contents":[{"annotation":[{"start":[5,35],"name":"src/ConstrainedArgument.purs","end":[5,54]},[]],"tag":"TypeApp","contents":[{"annotation":[{"start":[5,50],"name":"src/ConstrainedArgument.purs","end":[5,52]},[]],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[{"start":[5,36],"name":"src/ConstrainedArgument.purs","end":[5,48]},[]],"tag":"ConstrainedType","contents":[{"constraintAnn":[{"start":[5,36],"name":"src/ConstrainedArgument.purs","end":[5,43]},[]],"constraintClass":[["Prim"],"Partial"],"constraintArgs":[],"constraintData":null},{"annotation":[{"start":[5,47],"name":"src/ConstrainedArgument.purs","end":[5,48]},[]],"tag":"TypeVar","contents":"a"}]}]},{"annotation":[{"start":[5,53],"name":"src/ConstrainedArgument.purs","end":[5,54]},[]],"tag":"TypeVar","contents":"a"}]},null]}}},{"EDType":{"edTypeName":"WithArgs","edTypeKind":{"annotation":[{"start":[0,0],"name":"","end":[0,0]},[]],"tag":"NamedKind","contents":[["Prim"],"Type"]},"edTypeDeclarationKind":"TypeSynonym"}},{"EDTypeSynonym":{"edTypeSynonymName":"WithArgs","edTypeSynonymArguments":[],"edTypeSynonymType":{"annotation":[{"start":[6,25],"name":"src/ConstrainedArgument.purs","end":[6,52]},[]],"tag":"ForAll","contents":["a",{"annotation":[{"start":[6,35],"name":"src/ConstrainedArgument.purs","end":[6,52]},[]],"tag":"TypeApp","contents":[{"annotation":[{"start":[6,35],"name":"src/ConstrainedArgument.purs","end":[6,52]},[]],"tag":"TypeApp","contents":[{"annotation":[{"start":[6,48],"name":"src/ConstrainedArgument.purs","end":[6,50]},[]],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[{"start":[6,36],"name":"src/ConstrainedArgument.purs","end":[6,46]},[]],"tag":"ConstrainedType","contents":[{"constraintAnn":[{"start":[6,36],"name":"src/ConstrainedArgument.purs","end":[6,41]},[]],"constraintClass":[["ConstrainedArgument"],"Foo"],"constraintArgs":[{"annotation":[{"start":[6,40],"name":"src/ConstrainedArgument.purs","end":[6,41]},[]],"tag":"TypeVar","contents":"a"}],"constraintData":null},{"annotation":[{"start":[6,45],"name":"src/ConstrainedArgument.purs","end":[6,46]},[]],"tag":"TypeVar","contents":"a"}]}]},{"annotation":[{"start":[6,51],"name":"src/ConstrainedArgument.purs","end":[6,52]},[]],"tag":"TypeVar","contents":"a"}]},null]}}},{"EDType":{"edTypeName":"MultiWithoutArgs","edTypeKind":{"annotation":[{"start":[0,0],"name":"","end":[0,0]},[]],"tag":"NamedKind","contents":[["Prim"],"Type"]},"edTypeDeclarationKind":"TypeSynonym"}},{"EDTypeSynonym":{"edTypeSynonymName":"MultiWithoutArgs","edTypeSynonymArguments":[],"edTypeSynonymType":{"annotation":[{"start":[7,25],"name":"src/ConstrainedArgument.purs","end":[7,65]},[]],"tag":"ForAll","contents":["a",{"annotation":[{"start":[7,35],"name":"src/ConstrainedArgument.purs","end":[7,65]},[]],"tag":"TypeApp","contents":[{"annotation":[{"start":[7,35],"name":"src/ConstrainedArgument.purs","end":[7,65]},[]],"tag":"TypeApp","contents":[{"annotation":[{"start":[7,61],"name":"src/ConstrainedArgument.purs","end":[7,63]},[]],"tag":"TypeConstructor","contents":[["Prim"],"Function"]},{"annotation":[{"start":[7,36],"name":"src/ConstrainedArgument.purs","end":[7,59]},[]],"tag":"ConstrainedType","contents":[{"constraintAnn":[{"start":[7,36],"name":"src/ConstrainedArgument.purs","end":[7,43]},[]],"constraintClass":[["Prim"],"Partial"],"constraintArgs":[],"constraintData":null},{"annotation":[{"start":[7,47],"name":"src/ConstrainedArgument.purs","end":[7,59]},[]],"tag":"ConstrainedType","contents":[{"constraintAnn":[{"start":[7,47],"name":"src/ConstrainedArgument.purs","end":[7,54]},[]],"constraintClass":[["Prim"],"Partial"],"constr