git.iko.soy/rowtype-yoga/purescript-native
on d08b2ee help sign in
355eb9b
swap
0 ahead, 1985 behind
368 files changed+24614−2712
since splitsnapshots
unifiedsplit
.gitignore−10 .travis.yml+30 CONTRIBUTING.md+32 ChangeLog.md−3 LICENSE+1734−24 README-go.md−48 README.md+17−33 Setup.hs+4 app/Main.hs−250 bundle/.gitignore+3 bundle/README+20 bundle/build.sh+45 bundle/winbuild.sh+42 core-tests/.gitignore+2 core-tests/test-everything.sh+50 default.nix−23 examples/.gitignore+1 examples/failing/365.purs+13 examples/failing/438.purs+11 examples/failing/ArrayType.purs+12 examples/failing/Arrays.purs+5 examples/failing/Do.purs+10 examples/failing/DuplicateDeclarationsInLet.purs+11 examples/failing/DuplicateProperties1.purs+11 examples/failing/DuplicateProperties2.purs+11 examples/failing/DuplicateTypeVars.purs+5 examples/failing/Eff.purs+12 examples/failing/Foldable.purs+16 examples/failing/InstanceExport.purs+17 examples/failing/KindError.purs+5 examples/failing/LeadingZeros1.purs+5 examples/failing/LeadingZeros2.purs+5 examples/failing/Let.purs+5 examples/failing/MPTCs.purs+9 examples/failing/MissingClassExport.purs+6 examples/failing/MissingClassMemberExport.purs+6 examples/failing/MultipleErrors.purs+11 examples/failing/MultipleErrors2.purs+7 examples/failing/MutRec.purs+7 examples/failing/MutRec2.purs+5 examples/failing/NewtypeMultiArgs.purs+5 examples/failing/NewtypeMultiCtor.purs+5 examples/failing/NoOverlap.purs+13 examples/failing/NullaryAbs.purs+5 examples/failing/Object.purs+7 examples/failing/OverlappingArguments.purs+5 examples/failing/OverlappingBinders.purs+8 examples/failing/OverlappingInstances.purs+13 examples/failing/OverlappingInstances2.purs+25 examples/failing/OverlappingVars.purs+14 examples/failing/Rank2Types.purs+7 examples/failing/Reserved.purs+6 examples/failing/RowConstructors1.purs+8 examples/failing/RowConstructors2.purs+8 examples/failing/RowConstructors3.purs+8 examples/failing/SkolemEscape.purs+7 examples/failing/SkolemEscape2.purs+9 examples/failing/Superclasses1.purs+13 examples/failing/Superclasses2.purs+11 examples/failing/Superclasses3.purs+7 examples/failing/Superclasses4.purs+14 examples/failing/TopLevelCaseNoArgs.purs+7 examples/failing/TypeClassInstances.purs+10 examples/failing/TypeClasses2.purs+8 examples/failing/TypeError.purs+5 examples/failing/TypeSynonyms.purs+7 examples/failing/TypeSynonyms2.purs+11 examples/failing/TypeSynonyms3.purs+11 examples/failing/TypeSynonyms4.purs+10 examples/failing/TypeSynonyms5.purs+5 examples/failing/TypeWildcards1.purs+6 examples/failing/TypeWildcards2.purs+6 examples/failing/TypeWildcards3.purs+9 examples/failing/UnderscoreModuleName.purs+5 examples/failing/UnifyInTypeInstanceLookup.purs+19 examples/failing/UnknownType.purs+6 examples/manual/QualifiedNames.purs+13 examples/manual/failing/ArgLengthMismatch.purs+6 examples/manual/failing/ExportExplicit.purs+7 examples/manual/failing/ExportExplicit1.purs+14 examples/manual/failing/ExportExplicit2.purs+7 examples/manual/failing/ExportExplicit3.purs+13 examples/manual/failing/ImportExplicit.purs+7 examples/manual/failing/ImportExplicit2.purs+7 examples/manual/failing/ImportModule.purs+7 examples/manual/failing/OrphanTypeDecl.purs+3 examples/manual/failing/RedefinedFixity.purs+8 examples/manual/failing/RequiredHiddenType.purs+8 examples/manual/passing/ExportExplicit.purs+20 examples/manual/passing/ExportExplicit2.purs+15 examples/manual/passing/ExportedInstanceDeclarations.purs+43 examples/manual/passing/Import.purs+19 examples/manual/passing/ImportExplicit.purs+14 examples/manual/passing/ImportQualified.purs+12 examples/manual/passing/Module.purs+28 examples/manual/passing/ModuleDeps.purs+17 examples/manual/passing/RedefinedFixity.purs+24 examples/manual/passing/ShadowedName.purs+10 examples/manual/passing/TransitiveImport.purs+24 examples/manual/passing/WildcardType.purs+13 examples/passing/652.purs+17 examples/passing/810.purs+13 examples/passing/Applicative.purs+16 examples/passing/ArrayType.purs+11 examples/passing/Auto.purs+15 examples/passing/AutoPrelude.purs+9 examples/passing/AutoPrelude2.purs+10 examples/passing/BindersInFunctions.purs+12 examples/passing/BindingGroups.purs+10 examples/passing/BlockString.purs+8 examples/passing/CaseInDo.purs+19 examples/passing/CaseStatement.purs+21 examples/passing/CheckFunction.purs+7 examples/passing/CheckSynonymBug.purs+9 examples/passing/CheckTypeClass.purs+18 examples/passing/Church.purs+18 examples/passing/Collatz.purs+18 examples/passing/Comparisons.purs+15 examples/passing/Conditional.purs+9 examples/passing/Console.purs+13 examples/passing/DataAndType.purs+9 examples/passing/DeepArrayBinder.purs+15 examples/passing/DeepCase.purs+15 examples/passing/Do.purs+67 examples/passing/Dollar.purs+16 examples/passing/Eff.purs+25 examples/passing/EmptyDataDecls.purs+19 examples/passing/EmptyRow.purs+10 examples/passing/EmptyTypeClass.purs+12 examples/passing/EqOrd.purs+16 examples/passing/ExtendedInfixOperators.purs+14 examples/passing/Fib.purs+15 examples/passing/FinalTagless.purs+22 examples/passing/FunctionScope.purs+13 examples/passing/Functions.purs+15 examples/passing/Functions2.purs+13 examples/passing/Guards.purs+29 examples/passing/HoistError.purs+12 examples/passing/IfThenElseMaybe.purs+11 examples/passing/ImplicitEmptyImport.purs+8 examples/passing/ImportHiding.purs+18 examples/passing/InferRecFunWithConstrainedArgument.purs+8 examples/passing/InstanceBeforeClass.purs+11 examples/passing/IntAndChar.purs+18 examples/passing/JSReserved.purs+12 examples/passing/KindedType.purs+33 examples/passing/Let.purs+53 examples/passing/Let2.purs+17 examples/passing/LetInInstance.purs+14 examples/passing/LiberalTypeSynonyms.purs+21 examples/passing/MPTCs.purs+20 examples/passing/Match.purs+9 examples/passing/Monad.purs+32 examples/passing/MonadState.purs+48 examples/passing/MultiArgFunctions.purs+27 examples/passing/MutRec.purs+19 examples/passing/MutRec2.purs+19 examples/passing/MutRec3.purs+19 examples/passing/NamedPatterns.purs+9 examples/passing/NegativeBinder.purs+9 examples/passing/Nested.purs+9 examples/passing/NestedTypeSynonyms.purs+11 examples/passing/NestedWhere.purs+12 examples/passing/Newtype.purs+23 examples/passing/NewtypeEff.purs+29 examples/passing/NewtypeWithRecordUpdate.purs+16 examples/passing/ObjectGetter.purs+13 examples/passing/ObjectSynonym.purs+15 examples/passing/ObjectUpdate.purs+20 examples/passing/ObjectUpdate2.purs+17 examples/passing/ObjectUpdater.purs+24 examples/passing/ObjectWildcards.purs+20 examples/passing/Objects.purs+35 examples/passing/OneConstructor.purs+9 examples/passing/OperatorAssociativity.purs+25 examples/passing/OperatorInlining.purs+47 examples/passing/OperatorSections.purs+11 examples/passing/Operators.purs+99 examples/passing/OptimizerBug.purs+9 examples/passing/PartialFunction.purs+10 examples/passing/Patterns.purs+22 examples/passing/Person.purs+11 examples/passing/Rank2Data.purs+29 examples/passing/Rank2Object.purs+11 examples/passing/Rank2TypeSynonym.purs+16 examples/passing/Rank2Types.purs+11 examples/passing/RebindableSyntax.purs+39 examples/passing/Recursion.purs+10 examples/passing/ReservedWords.purs+15 examples/passing/RowConstructors.purs+42 examples/passing/RowPolyInstanceContext.purs+22 examples/passing/RuntimeScopeIssue.purs+19 examples/passing/ScopedTypeVariables.purs+36 examples/passing/Sequence.purs+15 examples/passing/SequenceDesugared.purs+37 examples/passing/ShadowedRename.purs+14 examples/passing/ShadowedTCO.purs+18 examples/passing/ShadowedTCOLet.purs+9 examples/passing/SignedNumericLiterals.purs+17 examples/passing/Superclasses1.purs+20 examples/passing/Superclasses2.purs+24 examples/passing/Superclasses3.purs+41 examples/passing/TCOCase.purs+12 examples/passing/TailCall.purs+17 examples/passing/Tick.purs+7 examples/passing/TopLevelCase.purs+18 examples/passing/TypeClassMemberOrderChange.purs+13 examples/passing/TypeClasses.purs+69 examples/passing/TypeClassesInOrder.purs+11 examples/passing/TypeClassesWithOverlappingTypeVariables.purs+11 examples/passing/TypeDecl.purs+12 examples/passing/TypeSynonymInData.purs+11 examples/passing/TypeSynonyms.purs+27 examples/passing/TypeWildcards.purs+15 examples/passing/TypeWildcardsRecordExtension.purs+8 examples/passing/TypedWhere.purs+17 examples/passing/UnderscoreIdent.purs+11 examples/passing/Unit.purs+6 examples/passing/UnknownInTypeClassLookup.purs+14 examples/passing/Where.purs+49 examples/passing/iota.purs+9 examples/passing/s.purs+7 hierarchy/Main.hs+114 license-generator/generate+44 license-generator/header.txt+23 license-generator/tmp/.gitkeep logo.png package.yaml−86 psc-docs/Ctags.hs+13 psc-docs/Etags.hs+15 psc-docs/Main.hs+251 psc-docs/Tags.hs+18 psc-make/Main.hs+176 psc-make/Make.hs+140 psc-publish/BoxesHelpers.hs+38 psc-publish/ErrorsWarnings.hs+318 psc-publish/Main.hs+280 psc-publish/Utils.hs+22 psc-publish/tests/Test.hs+79 psc/Main.hs+231 psci/Completion.hs+224 psci/Directive.hs+115 psci/IO.hs+21 psci/Make.hs+127 psci/PSCi.hs+568 psci/Parser.hs+140 psci/Types.hs+181 psci/main/Main.hs+6 psci/tests/Main.hs+150 psci/tests/data/Sample.purs psgo.cabal−145 purescript.cabal+244 src/CodeGen/IL.hs−321 src/CodeGen/IL/Common.hs−196 src/CodeGen/IL/Optimizer.hs−81 src/CodeGen/IL/Optimizer/Common.hs−18 src/CodeGen/IL/Optimizer/Inliner.hs−435 src/CodeGen/IL/Optimizer/MagicDo.hs−146 src/CodeGen/IL/Optimizer/TCO.hs−141 src/CodeGen/IL/Printer.hs−527 src/Control/Monad/Supply.hs+43 src/Control/Monad/Supply/Class.hs+36 src/Control/Monad/Unify.hs+159 src/Language/PureScript.hs+292 src/Language/PureScript/AST.hs+24 src/Language/PureScript/AST/Binders.hs+86 src/Language/PureScript/AST/Declarations.hs+411 src/Language/PureScript/AST/Exported.hs+136 src/Language/PureScript/AST/Operators.hs+51 src/Language/PureScript/AST/SourcePos.hs+71 src/Language/PureScript/AST/Traversals.hs+401 src/Language/PureScript/CodeGen.hs+25 src/Language/PureScript/CodeGen/Externs.hs+121 src/Language/PureScript/CodeGen/JS.hs+371 src/Language/PureScript/CodeGen/JS/AST.hs+343 src/Language/PureScript/CodeGen/JS/Common.hs+181 src/Language/PureScript/CodeGen/JS/Optimizer.hs+89 src/Language/PureScript/CodeGen/JS/Optimizer/Blocks.hs+42 src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs+77 src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs+317 src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs+165 src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs+128 src/Language/PureScript/CodeGen/JS/Optimizer/Unused.hs+46 src/Language/PureScript/Comments.hs+25 src/Language/PureScript/Constants.hs+281 src/Language/PureScript/CoreFn.hs+26 src/Language/PureScript/CoreFn/Ann.hs+37 src/Language/PureScript/CoreFn/Binders.hs+48 src/Language/PureScript/CoreFn/Desugar.hs+264 src/Language/PureScript/CoreFn/Expr.hs+134 src/Language/PureScript/CoreFn/Literals.hs+50 src/Language/PureScript/CoreFn/Meta.hs+55 src/Language/PureScript/CoreFn/Module.hs+31 src/Language/PureScript/CoreFn/Traversals.hs+85 src/Language/PureScript/DeadCodeElimination.hs+102 src/Language/PureScript/Docs.hs+14 src/Language/PureScript/Docs/AsMarkdown.hs+124 src/Language/PureScript/Docs/Convert.hs+228 src/Language/PureScript/Docs/ParseAndDesugar.hs+120 src/Language/PureScript/Docs/Render.hs+104 src/Language/PureScript/Docs/RenderedCode.hs+11 src/Language/PureScript/Docs/RenderedCode/Render.hs+165 src/Language/PureScript/Docs/RenderedCode/Types.hs+191 src/Language/PureScript/Docs/Types.hs+472 src/Language/PureScript/Docs/Utils/MonoidExtras.hs+9 src/Language/PureScript/Environment.hs+260 src/Language/PureScript/Errors.hs+792 src/Language/PureScript/Kinds.hs+72 src/Language/PureScript/Linter.hs+82 src/Language/PureScript/ModuleDependencies.hs+77 src/Language/PureScript/Names.hs+102 src/Language/PureScript/Options.hs+91 src/Language/PureScript/Parser.hs+36 src/Language/PureScript/Parser/Common.hs+139 src/Language/PureScript/Parser/Declarations.hs+543 src/Language/PureScript/Parser/JS.hs+59 src/Language/PureScript/Parser/Kinds.hs+45 src/Language/PureScript/Parser/Lexer.hs+519 src/Language/PureScript/Parser/State.hs+30 src/Language/PureScript/Parser/Types.hs+137 src/Language/PureScript/Pretty.hs+32 src/Language/PureScript/Pretty/Common.hs+69 src/Language/PureScript/Pretty/JS.hs+301 src/Language/PureScript/Pretty/Kinds.hs+59 src/Language/PureScript/Pretty/Types.hs+127 src/Language/PureScript/Pretty/Values.hs+244 src/Language/PureScript/Renamer.hs+196 src/Language/PureScript/Sugar.hs+71 src/Language/PureScript/Sugar/BindingGroups.hs+206 src/Language/PureScript/Sugar/CaseDeclarations.hs+180 src/Language/PureScript/Sugar/DoNotation.hs+74 src/Language/PureScript/Sugar/Names.hs+542 src/Language/PureScript/Sugar/ObjectWildcards.hs+65 src/Language/PureScript/Sugar/Operators.hs+166 src/Language/PureScript/Sugar/TypeClasses.hs+297 src/Language/PureScript/Sugar/TypeDeclarations.hs+69 src/Language/PureScript/Traversals.hs+41 src/Language/PureScript/TypeChecker.hs+343 src/Language/PureScript/TypeChecker/Entailment.hs+207 src/Language/PureScript/TypeChecker/Kinds.hs+218 src/Language/PureScript/TypeChecker/Monad.hs+272 src/Language/PureScript/TypeChecker/Rows.hs+67 src/Language/PureScript/TypeChecker/Skolems.hs+114 src/Language/PureScript/TypeChecker/Subsumption.hs+96 src/Language/PureScript/TypeChecker/Synonyms.hs+106 src/Language/PureScript/TypeChecker/Types.hs+675 src/Language/PureScript/TypeChecker/Unify.hs+206 src/Language/PureScript/TypeClassDictionaries.hs+96 src/Language/PureScript/Types.hs+311 src/Tests.hs−141 stack.nix−23 stack.yaml−24 support/ffi-loader.go−30 support/go.mod.ffi-loader−2 support/go.mod.output−2 support/go.mod.working−1 test/Spec.hs−2 tests/Main.hs+118 tests/prelude/Prelude.purs+631 tests/prelude/js/Assert.js+19 tests/prelude/js/Control.Monad.Eff.js+40 tests/prelude/js/Control.Monad.ST.js+38 tests/prelude/js/Data.Function.js+233 tests/prelude/js/Debug.Trace.js+11 tests/prelude/js/Prelude.Unsafe.js+10 tests/prelude/js/Prelude.js+150 travis-after-script.sh+21 travis-script.sh+17
.gitignore−10
@@ -9,15 +9,5 @@ cabal.sandbox.config
99*.lksh*
1010.virthualenv
1111.psci_modules/
12−.test_modules/
1312bower_components/
14−node_modules
1513tmp/
16−.stack-work/
17−stack.yaml.lock
18−output
19−examples/docs/docs/
20−core-tests/full-core-docs.md
21−.psc-ide-port
22−.vscode/
23−result
.travis.ymlnew file+30
@@ -0,0 +1,30 @@
1+env:
2+ - CABALVER=1.22 GHCVER=7.8.3 SUITE=tests
3+ - CABALVER=1.22 GHCVER=7.8.3 SUITE=psci-tests
4+before_install:
5+ - travis_retry sudo add-apt-repository -y ppa:hvr/ghc
6+ - travis_retry sudo apt-get update
7+ - travis_retry sudo apt-get install cabal-install-$CABALVER ghc-$GHCVER
8+ - export PATH="/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$HOME/.cabal/bin:$PATH"
9+install:
10+ - cabal --version
11+ - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]"
12+ - travis_retry cabal update
13+ - cabal install --only-dependencies --enable-tests --enable-benchmarks
14+script:
15+ - ./travis-script.sh
16+after_script:
17+ - ./travis-after-script.sh
18+notifications:
19+ email: true
20+before_deploy: "./bundle/build.sh linux64"
21+deploy:
22+ provider: releases
23+ api_key: $RELEASE_KEY
24+ file:
25+ - bundle/linux64.tar.gz
26+ - bundle/linux64.sha
27+ skip_cleanup: true
28+ on:
29+ all_branches: true
30+ tags: true
CONTRIBUTING.mdnew file+32
@@ -0,0 +1,32 @@
1+An introductory overview of the compiler is available [here](https://www.youtube.com/watch?v=Y3P1dxqwFiE).
2+
3+Pull requests are encouraged.
4+
5+Please follow the following guidelines:
6+
7+- Add at least a test to `examples/passing/` and possibly to `examples/failing`.
8+- Build the binaries and libs with `cabal build`
9+- Install the binaries and libs with `cabal install`.
10+- Run `cabal configure --enable-tests && cabal build && cabal test` to build the test suite.
11+- Run `purescript-test-everything` to make sure you haven't broken any core library builds.
12+- Run `starter-kit` to make sure the starter kit has not been broken.
13+
14+If you would like to contribute, please consider the issues in the current milestone first. If you are a new contributor, you may want to have a go at the ["easy" issues](https://github.com/purescript/purescript/labels/easy) to get started.
15+
16+Finally, if you have made code changes and would like to be included in the copyright notice in the cabal file, please include that change in your pull request.
17+
18+To prevent core libraries from getting broken, every change must be reviewed. A pull request will be merged as long as one other team member has verified the changes.
19+
20+## Adding dependencies
21+
22+Because the PureScript compiler is distributed in binary form, we include
23+the licenses of all dependencies, including transitive ones, in the LICENSE
24+file. Therefore, whenever the dependencies change, the LICENSE file should be
25+updated.
26+
27+You can automate this (if you have bash):
28+
29+- get a copy of [cabal-dependency-licenses][]
30+- run at the command line: `./license/generate > LICENSE`
31+
32+[cabal-dependency-licenses]: https://github.com/jaspervdj/cabal-dependency-licenses
ChangeLog.mddeleted−3
@@ -1,3 +0,0 @@
1−# Changelog for pscpp
2−
3−## Unreleased changes
LICENSE+1734−24
@@ -1,30 +1,1740 @@
1−Copyright Andy Arvanitis (c) 2018
1+The MIT License (MIT)
22
3−All rights reserved.
3+Copyright (c) 2013-15 Phil Freeman, (c) 2014-2015 Gary Burgess, and other
4+contributors
45
5−Redistribution and use in source and binary forms, with or without
6−modification, are permitted provided that the following conditions are met:
6+Permission is hereby granted, free of charge, to any person obtaining a copy of
7+this software and associated documentation files (the "Software"), to deal in
8+the Software without restriction, including without limitation the rights to
9+use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of
10+the Software, and to permit persons to whom the Software is furnished to do so,
11+subject to the following conditions:
712
13+The above copyright notice and this permission notice shall be included in all
14+copies or substantial portions of the Software.
15+
16+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
17+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
18+FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
19+COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
20+IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
21+CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
22+
23+PureScript uses the following Haskell library packages. Their license files follow.
24+
25+ aeson
26+ aeson-better-errors
27+ ansi-terminal
28+ ansi-wl-pprint
29+ array
30+ attoparsec
31+ base
32+ bower-json
33+ boxes
34+ bytestring
35+ containers
36+ deepseq
37+ directory
38+ dlist
39+ filepath
40+ ghc-prim
41+ Glob
42+ hashable
43+ haskeline
44+ integer-gmp
45+ mtl
46+ nats
47+ old-locale
48+ optparse-applicative
49+ parsec
50+ pattern-arrows
51+ pretty
52+ primitive
53+ process
54+ rts
55+ safe
56+ scientific
57+ semigroups
58+ split
59+ syb
60+ template-haskell
61+ terminfo
62+ text
63+ time
64+ transformers
65+ transformers-compat
66+ unix
67+ unordered-containers
68+ utf8-string
69+ vector
70+ void
71+
72+aeson LICENSE file:
73+
74+ Copyright (c) 2011, MailRank, Inc.
75+
76+ All rights reserved.
77+
78+ Redistribution and use in source and binary forms, with or without
79+ modification, are permitted provided that the following conditions
80+ are met:
81+
82+ 1. Redistributions of source code must retain the above copyright
83+ notice, this list of conditions and the following disclaimer.
84+
85+ 2. Redistributions in binary form must reproduce the above copyright
86+ notice, this list of conditions and the following disclaimer in the
87+ documentation and/or other materials provided with the distribution.
88+
89+ 3. Neither the name of the author nor the names of his contributors
90+ may be used to endorse or promote products derived from this software
91+ without specific prior written permission.
92+
93+ THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS
94+ OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
95+ WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
96+ DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR
97+ ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
98+ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
99+ OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
100+ HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
101+ STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
102+ ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
103+ POSSIBILITY OF SUCH DAMAGE.
104+
105+aeson-better-errors LICENSE file:
106+
107+ Copyright (c) 2015 Harry Garrood
108+
109+ Permission is hereby granted, free of charge, to any person obtaining
110+ a copy of this software and associated documentation files (the
111+ "Software"), to deal in the Software without restriction, including
112+ without limitation the rights to use, copy, modify, merge, publish,
113+ distribute, sublicense, and/or sell copies of the Software, and to
114+ permit persons to whom the Software is furnished to do so, subject to
115+ the following conditions:
116+
117+ The above copyright notice and this permission notice shall be included
118+ in all copies or substantial portions of the Software.
119+
120+ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
121+ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
122+ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
123+ IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
124+ CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
125+ TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
126+ SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
127+
128+ansi-terminal LICENSE file:
129+
130+ Copyright (c) 2008, Maximilian Bolingbroke
131+ All rights reserved.
132+
133+ Redistribution and use in source and binary forms, with or without modification, are permitted
134+ provided that the following conditions are met:
135+
136+ * Redistributions of source code must retain the above copyright notice, this list of
137+ conditions and the following disclaimer.
138+ * Redistributions in binary form must reproduce the above copyright notice, this list of
139+ conditions and the following disclaimer in the documentation and/or other materials
140+ provided with the distribution.
141+ * Neither the name of Maximilian Bolingbroke nor the names of other contributors may be used to
142+ endorse or promote products derived from this software without specific prior written permission.
143+
144+ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR
145+ IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
146+ FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR
147+ CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
148+ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
149+ DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER
150+ IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT
151+ OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
152+ansi-wl-pprint LICENSE file:
153+
154+ Copyright 2008, Daan Leijen and Max Bolingbroke. All rights reserved.
155+
156+ Redistribution and use in source and binary forms, with or without
157+ modification, are permitted provided that the following conditions are
158+ met:
159+
8160 * Redistributions of source code must retain the above copyright
9161 notice, this list of conditions and the following disclaimer.
162+
163+ * Redistributions in binary form must reproduce the above copyright
164+ notice, this list of conditions and the following disclaimer in
165+ the documentation and/or other materials provided with the
166+ distribution.
167+
168+ This software is provided by the copyright holders "as is" and any
169+ express or implied warranties, including, but not limited to, the
170+ implied warranties of merchantability and fitness for a particular
171+ purpose are disclaimed. In no event shall the copyright holders be
172+ liable for any direct, indirect, incidental, special, exemplary, or
173+ consequential damages (including, but not limited to, procurement of
174+ substitute goods or services; loss of use, data, or profits; or
175+ business interruption) however caused and on any theory of liability,
176+ whether in contract, strict liability, or tort (including negligence
177+ or otherwise) arising in any way out of the use of this software, even
178+ if advised of the possibility of such damage.
179+
180+array LICENSE file:
181+
182+ This library (libraries/base) is derived from code from several
183+ sources:
184+
185+ * Code from the GHC project which is largely (c) The University of
186+ Glasgow, and distributable under a BSD-style license (see below),
187+
188+ * Code from the Haskell 98 Report which is (c) Simon Peyton Jones
189+ and freely redistributable (but see the full license for
190+ restrictions).
191+
192+ * Code from the Haskell Foreign Function Interface specification,
193+ which is (c) Manuel M. T. Chakravarty and freely redistributable
194+ (but see the full license for restrictions).
195+
196+ The full text of these licenses is reproduced below. All of the
197+ licenses are BSD-style or compatible.
198+
199+ -----------------------------------------------------------------------------
200+
201+ The Glasgow Haskell Compiler License
202+
203+ Copyright 2004, The University Court of the University of Glasgow.
204+ All rights reserved.
205+
206+ Redistribution and use in source and binary forms, with or without
207+ modification, are permitted provided that the following conditions are met:
208+
209+ - Redistributions of source code must retain the above copyright notice,
210+ this list of conditions and the following disclaimer.
211+
212+ - Redistributions in binary form must reproduce the above copyright notice,
213+ this list of conditions and the following disclaimer in the documentation
214+ and/or other materials provided with the distribution.
215+
216+ - Neither name of the University nor the names of its contributors may be
217+ used to endorse or promote products derived from this software without
218+ specific prior written permission.
219+
220+ THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF
221+ GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
222+ INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
223+ FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
224+ UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE
225+ FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
226+ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
227+ SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
228+ CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
229+ LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
230+ OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
231+ DAMAGE.
232+
233+ -----------------------------------------------------------------------------
234+
235+ Code derived from the document "Report on the Programming Language
236+ Haskell 98", is distributed under the following license:
237+
238+ Copyright (c) 2002 Simon Peyton Jones
239+
240+ The authors intend this Report to belong to the entire Haskell
241+ community, and so we grant permission to copy and distribute it for
242+ any purpose, provided that it is reproduced in its entirety,
243+ including this Notice. Modified versions of this Report may also be
244+ copied and distributed for any purpose, provided that the modified
245+ version is clearly presented as such, and that it does not claim to
246+ be a definition of the Haskell 98 Language.
247+
248+ -----------------------------------------------------------------------------
249+
250+ Code derived from the document "The Haskell 98 Foreign Function
251+ Interface, An Addendum to the Haskell 98 Report" is distributed under
252+ the following license:
253+
254+ Copyright (c) 2002 Manuel M. T. Chakravarty
255+
256+ The authors intend this Report to belong to the entire Haskell
257+ community, and so we grant permission to copy and distribute it for
258+ any purpose, provided that it is reproduced in its entirety,
259+ including this Notice. Modified versions of this Report may also be
260+ copied and distributed for any purpose, provided that the modified
261+ version is clearly presented as such, and that it does not claim to
262+ be a definition of the Haskell 98 Foreign Function Interface.
263+
264+ -----------------------------------------------------------------------------
265+
266+attoparsec LICENSE file:
267+
268+ Copyright (c) Lennart Kolmodin
269+
270+ All rights reserved.
271+
272+ Redistribution and use in source and binary forms, with or without
273+ modification, are permitted provided that the following conditions
274+ are met:
275+
276+ 1. Redistributions of source code must retain the above copyright
277+ notice, this list of conditions and the following disclaimer.
278+
279+ 2. Redistributions in binary form must reproduce the above copyright
280+ notice, this list of conditions and the following disclaimer in the
281+ documentation and/or other materials provided with the distribution.
282+
283+ 3. Neither the name of the author nor the names of his contributors
284+ may be used to endorse or promote products derived from this software
285+ without specific prior written permission.
286+
287+ THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS
288+ OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
289+ WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
290+ DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR
291+ ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
292+ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
293+ OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
294+ HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
295+ STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
296+ ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
297+ POSSIBILITY OF SUCH DAMAGE.
298+
299+base LICENSE file:
300+
301+ This library (libraries/base) is derived from code from several
302+ sources:
303+
304+ * Code from the GHC project which is largely (c) The University of
305+ Glasgow, and distributable under a BSD-style license (see below),
306+
307+ * Code from the Haskell 98 Report which is (c) Simon Peyton Jones
308+ and freely redistributable (but see the full license for
309+ restrictions).
310+
311+ * Code from the Haskell Foreign Function Interface specification,
312+ which is (c) Manuel M. T. Chakravarty and freely redistributable
313+ (but see the full license for restrictions).
314+
315+ The full text of these licenses is reproduced below. All of the
316+ licenses are BSD-style or compatible.
317+
318+ -----------------------------------------------------------------------------
319+
320+ The Glasgow Haskell Compiler License
321+
322+ Copyright 2004, The University Court of the University of Glasgow.
323+ All rights reserved.
324+
325+ Redistribution and use in source and binary forms, with or without
326+ modification, are permitted provided that the following conditions are met:
327+
328+ - Redistributions of source code must retain the above copyright notice,
329+ this list of conditions and the following disclaimer.
330+
331+ - Redistributions in binary form must reproduce the above copyright notice,
332+ this list of conditions and the following disclaimer in the documentation
333+ and/or other materials provided with the distribution.
334+
335+ - Neither name of the University nor the names of its contributors may be
336+ used to endorse or promote products derived from this software without
337+ specific prior written permission.
338+
339+ THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF
340+ GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
341+ INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
342+ FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
343+ UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE
344+ FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
345+ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
346+ SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
347+ CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
348+ LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
349+ OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
350+ DAMAGE.
351+
352+ -----------------------------------------------------------------------------
353+
354+ Code derived from the document "Report on the Programming Language
355+ Haskell 98", is distributed under the following license:
356+
357+ Copyright (c) 2002 Simon Peyton Jones
358+
359+ The authors intend this Report to belong to the entire Haskell
360+ community, and so we grant permission to copy and distribute it for
361+ any purpose, provided that it is reproduced in its entirety,
362+ including this Notice. Modified versions of this Report may also be
363+ copied and distributed for any purpose, provided that the modified
364+ version is clearly presented as such, and that it does not claim to
365+ be a definition of the Haskell 98 Language.
366+
367+ -----------------------------------------------------------------------------
368+
369+ Code derived from the document "The Haskell 98 Foreign Function
370+ Interface, An Addendum to the Haskell 98 Report" is distributed under
371+ the following license:
372+
373+ Copyright (c) 2002 Manuel M. T. Chakravarty
374+
375+ The authors intend this Report to belong to the entire Haskell
376+ community, and so we grant permission to copy and distribute it for
377+ any purpose, provided that it is reproduced in its entirety,
378+ including this Notice. Modified versions of this Report may also be
379+ copied and distributed for any purpose, provided that the modified
380+ version is clearly presented as such, and that it does not claim to
381+ be a definition of the Haskell 98 Foreign Function Interface.
382+
383+ -----------------------------------------------------------------------------
384+
385+bower-json LICENSE file:
386+
387+ Copyright (c) 2015 Harry Garrood
388+
389+ Permission is hereby granted, free of charge, to any person obtaining
390+ a copy of this software and associated documentation files (the
391+ "Software"), to deal in the Software without restriction, including
392+ without limitation the rights to use, copy, modify, merge, publish,
393+ distribute, sublicense, and/or sell copies of the Software, and to
394+ permit persons to whom the Software is furnished to do so, subject to
395+ the following conditions:
396+
397+ The above copyright notice and this permission notice shall be included
398+ in all copies or substantial portions of the Software.
399+
400+ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
401+ EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
402+ MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
403+ IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
404+ CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
405+ TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
406+ SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
407+
408+boxes LICENSE file:
409+
410+ Copyright (c) Brent Yorgey 2008
411+
412+ Redistribution and use in source and binary forms, with or without
413+ modification, are permitted provided that the following conditions
414+ are met:
415+ 1. Redistributions of source code must retain the above copyright
416+ notice, this list of conditions and the following disclaimer.
417+ 2. Redistributions in binary form must reproduce the above copyright
418+ notice, this list of conditions and the following disclaimer in the
419+ documentation and/or other materials provided with the distribution.
420+ 3. Neither the name of the author nor the names of other contributors
421+ may be used to endorse or promote products derived from this software
422+ without specific prior written permission.
423+
424+ All other rights are reserved.
425+
426+ THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND
427+ ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
428+ IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
429+ ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE
430+ FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
431+ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
432+ OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
433+ HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
434+ LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
435+ OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
436+ SUCH DAMAGE.
437+
438+bytestring LICENSE file:
439+
440+ Copyright (c) Don Stewart 2005-2009
441+ (c) Duncan Coutts 2006-2015
442+ (c) David Roundy 2003-2005
443+ (c) Simon Meier 2010-2011
444+
445+ All rights reserved.
446+
447+ Redistribution and use in source and binary forms, with or without
448+ modification, are permitted provided that the following conditions
449+ are met:
450+ 1. Redistributions of source code must retain the above copyright
451+ notice, this list of conditions and the following disclaimer.
452+ 2. Redistributions in binary form must reproduce the above copyright
453+ notice, this list of conditions and the following disclaimer in the
454+ documentation and/or other materials provided with the distribution.
455+ 3. Neither the name of the author nor the names of his contributors
456+ may be used to endorse or promote products derived from this software
457+ without specific prior written permission.
458+
459+ THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND
460+ ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
461+ IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
462+ ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE
463+ FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
464+ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
465+ OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
466+ HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
467+ LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
468+ OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
469+ SUCH DAMAGE.
470+
471+containers LICENSE file:
472+
473+ The Glasgow Haskell Compiler License
474+
475+ Copyright 2004, The University Court of the University of Glasgow.
476+ All rights reserved.
477+
478+ Redistribution and use in source and binary forms, with or without
479+ modification, are permitted provided that the following conditions are met:
480+
481+ - Redistributions of source code must retain the above copyright notice,
482+ this list of conditions and the following disclaimer.
483+
484+ - Redistributions in binary form must reproduce the above copyright notice,
485+ this list of conditions and the following disclaimer in the documentation
486+ and/or other materials provided with the distribution.
487+
488+ - Neither name of the University nor the names of its contributors may be
489+ used to endorse or promote products derived from this software without
490+ specific prior written permission.
491+
492+ THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF
493+ GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
494+ INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
495+ FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
496+ UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE
497+ FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
498+ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
499+ SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
500+ CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
501+ LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
502+ OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
503+ DAMAGE.
504+
505+deepseq LICENSE file:
506+
507+ This library (deepseq) is derived from code from the GHC project which
508+ is largely (c) The University of Glasgow, and distributable under a
509+ BSD-style license (see below).
510+
511+ -----------------------------------------------------------------------------
512+
513+ The Glasgow Haskell Compiler License
514+
515+ Copyright 2001-2009, The University Court of the University of Glasgow.
516+ All rights reserved.
517+
518+ Redistribution and use in source and binary forms, with or without
519+ modification, are permitted provided that the following conditions are met:
520+
521+ - Redistributions of source code must retain the above copyright notice,
522+ this list of conditions and the following disclaimer.
523+
524+ - Redistributions in binary form must reproduce the above copyright notice,
525+ this list of conditions and the following disclaimer in the documentation
526+ and/or other materials provided with the distribution.
527+
528+ - Neither name of the University nor the names of its contributors may be
529+ used to endorse or promote products derived from this software without
530+ specific prior written permission.
531+
532+ THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF
533+ GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
534+ INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
535+ FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
536+ UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE
537+ FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
538+ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
539+ SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
540+ CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
541+ LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
542+ OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
543+ DAMAGE.
544+
545+ -----------------------------------------------------------------------------
546+
547+directory LICENSE file:
548+
549+ This library (libraries/base) is derived from code from two
550+ sources:
551+
552+ * Code from the GHC project which is largely (c) The University of
553+ Glasgow, and distributable under a BSD-style license (see below),
554+
555+ * Code from the Haskell 98 Report which is (c) Simon Peyton Jones
556+ and freely redistributable (but see the full license for
557+ restrictions).
558+
559+ The full text of these licenses is reproduced below. Both of the
560+ licenses are BSD-style or compatible.
561+
562+ -----------------------------------------------------------------------------
563+
564+ The Glasgow Haskell Compiler License
565+
566+ Copyright 2004, The University Court of the University of Glasgow.
567+ All rights reserved.
568+
569+ Redistribution and use in source and binary forms, with or without
570+ modification, are permitted provided that the following conditions are met:
571+
572+ - Redistributions of source code must retain the above copyright notice,
573+ this list of conditions and the following disclaimer.
574+
575+ - Redistributions in binary form must reproduce the above copyright notice,
576+ this list of conditions and the following disclaimer in the documentation
577+ and/or other materials provided with the distribution.
578+
579+ - Neither name of the University nor the names of its contributors may be
580+ used to endorse or promote products derived from this software without
581+ specific prior written permission.
582+
583+ THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF
584+ GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
585+ INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
586+ FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
587+ UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE
588+ FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
589+ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
590+ SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
591+ CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
592+ LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
593+ OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
594+ DAMAGE.
595+
596+ -----------------------------------------------------------------------------
597+
598+ Code derived from the document "Report on the Programming Language
599+ Haskell 98", is distributed under the following license:
600+
601+ Copyright (c) 2002 Simon Peyton Jones
602+
603+ The authors intend this Report to belong to the entire Haskell
604+ community, and so we grant permission to copy and distribute it for
605+ any purpose, provided that it is reproduced in its entirety,
606+ including this Notice. Modified versions of this Report may also be
607+ copied and distributed for any purpose, provided that the modified
608+ version is clearly presented as such, and that it does not claim to
609+ be a definition of the Haskell 98 Language.
610+
611+ -----------------------------------------------------------------------------
612+
613+dlist LICENSE file:
614+
615+ Copyright (c) 2006-2009 Don Stewart, 2013-2014 Sean Leather
616+
617+ All rights reserved.
618+
619+ Redistribution and use in source and binary forms, with or without
620+ modification, are permitted provided that the following conditions are
621+ met:
622+
623+ * Redistributions of source code must retain the above copyright
624+ notice, this list of conditions and the following disclaimer.
625+
626+ * Redistributions in binary form must reproduce the above
627+ copyright notice, this list of conditions and the following
628+ disclaimer in the documentation and/or other materials provided
629+ with the distribution.
630+
631+ * Neither the name of Don Stewart nor the names of other
632+ contributors may be used to endorse or promote products derived
633+ from this software without specific prior written permission.
634+
635+ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
636+ "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
637+ LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
638+ A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
639+ OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
640+ SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
641+ LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
642+ DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
643+ THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
644+ (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
645+ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
646+
647+filepath LICENSE file:
648+
649+ Copyright Neil Mitchell 2005-2015.
650+ All rights reserved.
651+
652+ Redistribution and use in source and binary forms, with or without
653+ modification, are permitted provided that the following conditions are
654+ met:
655+
656+ * Redistributions of source code must retain the above copyright
657+ notice, this list of conditions and the following disclaimer.
658+
659+ * Redistributions in binary form must reproduce the above
660+ copyright notice, this list of conditions and the following
661+ disclaimer in the documentation and/or other materials provided
662+ with the distribution.
663+
664+ * Neither the name of Neil Mitchell nor the names of other
665+ contributors may be used to endorse or promote products derived
666+ from this software without specific prior written permission.
667+
668+ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
669+ "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
670+ LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
671+ A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
672+ OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
673+ SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
674+ LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
675+ DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
676+ THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
677+ (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
678+ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
679+
680+ghc-prim LICENSE file:
681+
682+ This library (libraries/ghc-prim) is derived from code from several
683+ sources:
684+
685+ * Code from the GHC project which is largely (c) The University of
686+ Glasgow, and distributable under a BSD-style license (see below),
687+
688+ * Code from the Haskell 98 Report which is (c) Simon Peyton Jones
689+ and freely redistributable (but see the full license for
690+ restrictions).
691+
692+ The full text of these licenses is reproduced below. All of the
693+ licenses are BSD-style or compatible.
694+
695+ -----------------------------------------------------------------------------
696+
697+ The Glasgow Haskell Compiler License
698+
699+ Copyright 2004, The University Court of the University of Glasgow.
700+ All rights reserved.
701+
702+ Redistribution and use in source and binary forms, with or without
703+ modification, are permitted provided that the following conditions are met:
704+
705+ - Redistributions of source code must retain the above copyright notice,
706+ this list of conditions and the following disclaimer.
707+
708+ - Redistributions in binary form must reproduce the above copyright notice,
709+ this list of conditions and the following disclaimer in the documentation
710+ and/or other materials provided with the distribution.
711+
712+ - Neither name of the University nor the names of its contributors may be
713+ used to endorse or promote products derived from this software without
714+ specific prior written permission.
715+
716+ THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF
717+ GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
718+ INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
719+ FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
720+ UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE
721+ FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
722+ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
723+ SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
724+ CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
725+ LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
726+ OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
727+ DAMAGE.
728+
729+ -----------------------------------------------------------------------------
730+
731+ Code derived from the document "Report on the Programming Language
732+ Haskell 98", is distributed under the following license:
733+
734+ Copyright (c) 2002 Simon Peyton Jones
735+
736+ The authors intend this Report to belong to the entire Haskell
737+ community, and so we grant permission to copy and distribute it for
738+ any purpose, provided that it is reproduced in its entirety,
739+ including this Notice. Modified versions of this Report may also be
740+ copied and distributed for any purpose, provided that the modified
741+ version is clearly presented as such, and that it does not claim to
742+ be a definition of the Haskell 98 Language.
743+
744+
745+Glob LICENSE file:
746+
747+ Page not found: Sorry, it's just not here.
748+
749+hashable LICENSE file:
750+
751+ Copyright Milan Straka 2010
752+
753+ All rights reserved.
754+
755+ Redistribution and use in source and binary forms, with or without
756+ modification, are permitted provided that the following conditions are met:
757+
758+ * Redistributions of source code must retain the above copyright
759+ notice, this list of conditions and the following disclaimer.
760+
761+ * Redistributions in binary form must reproduce the above
762+ copyright notice, this list of conditions and the following
763+ disclaimer in the documentation and/or other materials provided
764+ with the distribution.
765+
766+ * Neither the name of Milan Straka nor the names of other
767+ contributors may be used to endorse or promote products derived
768+ from this software without specific prior written permission.
769+
770+ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
771+ "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
772+ LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
773+ A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
774+ OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
775+ SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
776+ LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
777+ DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
778+ THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
779+ (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
780+ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
781+
782+haskeline LICENSE file:
783+
784+ Copyright 2007-2009, Judah Jacobson.
785+ All Rights Reserved.
786+
787+ Redistribution and use in source and binary forms, with or without
788+ modification, are permitted provided that the following conditions are met:
789+
790+ - Redistribution of source code must retain the above copyright notice,
791+ this list of conditions and the following disclaimer.
792+
793+ - Redistribution in binary form must reproduce the above copyright notice,
794+ this list of conditions and the following disclaimer in the documentation
795+ and/or other materials provided with the distribution.
796+
797+ THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS "AS IS" AND ANY
798+ EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
799+ WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
800+ DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR THE CONTRIBUTORS BE LIABLE
801+ FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
802+ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
803+ SERVICES; LOSS OF USE, DATA OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
804+ CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
805+ OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
806+ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
807+
808+integer-gmp LICENSE file:
809+
810+ Copyright (c) 2014, Herbert Valerio Riedel
811+
812+ All rights reserved.
813+
814+ Redistribution and use in source and binary forms, with or without
815+ modification, are permitted provided that the following conditions are met:
816+
817+ * Redistributions of source code must retain the above copyright
818+ notice, this list of conditions and the following disclaimer.
819+
820+ * Redistributions in binary form must reproduce the above
821+ copyright notice, this list of conditions and the following
822+ disclaimer in the documentation and/or other materials provided
823+ with the distribution.
824+
825+ * Neither the name of Herbert Valerio Riedel nor the names of other
826+ contributors may be used to endorse or promote products derived
827+ from this software without specific prior written permission.
828+
829+ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
830+ "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
831+ LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
832+ A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
833+ OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
834+ SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
835+ LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
836+ DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
837+ THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
838+ (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
839+ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
840+
841+mtl LICENSE file:
842+
843+ The Glasgow Haskell Compiler License
844+
845+ Copyright 2004, The University Court of the University of Glasgow.
846+ All rights reserved.
847+
848+ Redistribution and use in source and binary forms, with or without
849+ modification, are permitted provided that the following conditions are met:
850+
851+ - Redistributions of source code must retain the above copyright notice,
852+ this list of conditions and the following disclaimer.
853+
854+ - Redistributions in binary form must reproduce the above copyright notice,
855+ this list of conditions and the following disclaimer in the documentation
856+ and/or other materials provided with the distribution.
857+
858+ - Neither name of the University nor the names of its contributors may be
859+ used to endorse or promote products derived from this software without
860+ specific prior written permission.
861+
862+ THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF
863+ GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
864+ INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
865+ FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
866+ UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE
867+ FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
868+ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
869+ SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
870+ CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
871+ LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
872+ OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
873+ DAMAGE.
874+
875+nats LICENSE file:
876+
877+ Copyright 2011-2014 Edward Kmett
878+
879+ All rights reserved.
880+
881+ Redistribution and use in source and binary forms, with or without
882+ modification, are permitted provided that the following conditions
883+ are met:
884+
885+ 1. Redistributions of source code must retain the above copyright
886+ notice, this list of conditions and the following disclaimer.
887+
888+ 2. Redistributions in binary form must reproduce the above copyright
889+ notice, this list of conditions and the following disclaimer in the
890+ documentation and/or other materials provided with the distribution.
891+
892+ 3. Neither the name of the author nor the names of his contributors
893+ may be used to endorse or promote products derived from this software
894+ without specific prior written permission.
895+
896+ THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
897+ IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
898+ WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
899+ DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR
900+ ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
901+ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
902+ OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
903+ HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
904+ STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
905+ ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
906+ POSSIBILITY OF SUCH DAMAGE.
907+
908+old-locale LICENSE file:
909+
910+ This library (libraries/base) is derived from code from two
911+ sources:
912+
913+ * Code from the GHC project which is largely (c) The University of
914+ Glasgow, and distributable under a BSD-style license (see below),
915+
916+ * Code from the Haskell 98 Report which is (c) Simon Peyton Jones
917+ and freely redistributable (but see the full license for
918+ restrictions).
919+
920+ The full text of these licenses is reproduced below. Both of the
921+ licenses are BSD-style or compatible.
922+
923+ -----------------------------------------------------------------------------
924+
925+ The Glasgow Haskell Compiler License
926+
927+ Copyright 2004, The University Court of the University of Glasgow.
928+ All rights reserved.
929+
930+ Redistribution and use in source and binary forms, with or without
931+ modification, are permitted provided that the following conditions are met:
932+
933+ - Redistributions of source code must retain the above copyright notice,
934+ this list of conditions and the following disclaimer.
935+
936+ - Redistributions in binary form must reproduce the above copyright notice,
937+ this list of conditions and the following disclaimer in the documentation
938+ and/or other materials provided with the distribution.
939+
940+ - Neither name of the University nor the names of its contributors may be
941+ used to endorse or promote products derived from this software without
942+ specific prior written permission.
943+
944+ THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF
945+ GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
946+ INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
947+ FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
948+ UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE
949+ FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
950+ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
951+ SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
952+ CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
953+ LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
954+ OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
955+ DAMAGE.
956+
957+ -----------------------------------------------------------------------------
958+
959+ Code derived from the document "Report on the Programming Language
960+ Haskell 98", is distributed under the following license:
961+
962+ Copyright (c) 2002 Simon Peyton Jones
963+
964+ The authors intend this Report to belong to the entire Haskell
965+ community, and so we grant permission to copy and distribute it for
966+ any purpose, provided that it is reproduced in its entirety,
967+ including this Notice. Modified versions of this Report may also be
968+ copied and distributed for any purpose, provided that the modified
969+ version is clearly presented as such, and that it does not claim to
970+ be a definition of the Haskell 98 Language.
971+
972+ -----------------------------------------------------------------------------
973+
974+optparse-applicative LICENSE file:
975+
976+ Copyright (c) 2012, Paolo Capriotti
977+
978+ All rights reserved.
979+
980+ Redistribution and use in source and binary forms, with or without
981+ modification, are permitted provided that the following conditions are met:
982+
983+ * Redistributions of source code must retain the above copyright
984+ notice, this list of conditions and the following disclaimer.
985+
986+ * Redistributions in binary form must reproduce the above
987+ copyright notice, this list of conditions and the following
988+ disclaimer in the documentation and/or other materials provided
989+ with the distribution.
990+
991+ * Neither the name of Paolo Capriotti nor the names of other
992+ contributors may be used to endorse or promote products derived
993+ from this software without specific prior written permission.
994+
995+ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
996+ "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
997+ LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
998+ A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
999+ OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
1000+ SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
1001+ LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
1002+ DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
1003+ THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
1004+ (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
1005+ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
1006+
1007+parsec LICENSE file:
1008+
1009+ Copyright 1999-2000, Daan Leijen; 2007, Paolo Martini. All rights reserved.
1010+
1011+ Redistribution and use in source and binary forms, with or without
1012+ modification, are permitted provided that the following conditions are met:
1013+
1014+ * Redistributions of source code must retain the above copyright notice,
1015+ this list of conditions and the following disclaimer.
1016+ * Redistributions in binary form must reproduce the above copyright
1017+ notice, this list of conditions and the following disclaimer in the
1018+ documentation and/or other materials provided with the distribution.
1019+
1020+ This software is provided by the copyright holders "as is" and any express or
1021+ implied warranties, including, but not limited to, the implied warranties of
1022+ merchantability and fitness for a particular purpose are disclaimed. In no
1023+ event shall the copyright holders be liable for any direct, indirect,
1024+ incidental, special, exemplary, or consequential damages (including, but not
1025+ limited to, procurement of substitute goods or services; loss of use, data,
1026+ or profits; or business interruption) however caused and on any theory of
1027+ liability, whether in contract, strict liability, or tort (including
1028+ negligence or otherwise) arising in any way out of the use of this software,
1029+ even if advised of the possibility of such damage.
1030+
1031+pattern-arrows LICENSE file:
1032+
1033+ The MIT License (MIT)
1034+
1035+ Copyright (c) 2013 Phil Freeman
1036+
1037+ Permission is hereby granted, free of charge, to any person obtaining a copy of
1038+ this software and associated documentation files (the "Software"), to deal in
1039+ the Software without restriction, including without limitation the rights to
1040+ use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of
1041+ the Software, and to permit persons to whom the Software is furnished to do so,
1042+ subject to the following conditions:
1043+
1044+ The above copyright notice and this permission notice shall be included in all
1045+ copies or substantial portions of the Software.
1046+
1047+ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
1048+ IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
1049+ FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
1050+ COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
1051+ IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
1052+ CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
1053+
1054+pretty LICENSE file:
1055+
1056+ This library (libraries/pretty) is derived from code from
1057+ the GHC project which is largely (c) The University of
1058+ Glasgow, and distributable under a BSD-style license (see below).
1059+
1060+ -----------------------------------------------------------------------------
1061+
1062+ The Glasgow Haskell Compiler License
1063+
1064+ Copyright 2004, The University Court of the University of Glasgow.
1065+ All rights reserved.
1066+
1067+ Redistribution and use in source and binary forms, with or without
1068+ modification, are permitted provided that the following conditions are met:
1069+
1070+ - Redistributions of source code must retain the above copyright notice,
1071+ this list of conditions and the following disclaimer.
1072+
1073+ - Redistributions in binary form must reproduce the above copyright notice,
1074+ this list of conditions and the following disclaimer in the documentation
1075+ and/or other materials provided with the distribution.
1076+
1077+ - Neither name of the University nor the names of its contributors may be
1078+ used to endorse or promote products derived from this software without
1079+ specific prior written permission.
1080+
1081+ THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF
1082+ GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
1083+ INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
1084+ FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
1085+ UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE
1086+ FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
1087+ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
1088+ SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
1089+ CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
1090+ LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
1091+ OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
1092+ DAMAGE.
1093+
1094+ -----------------------------------------------------------------------------
1095+
1096+primitive LICENSE file:
1097+
1098+ Copyright (c) 2008-2009, Roman Leshchinskiy
1099+ All rights reserved.
1100+
1101+ Redistribution and use in source and binary forms, with or without
1102+ modification, are permitted provided that the following conditions are met:
1103+
1104+ - Redistributions of source code must retain the above copyright notice,
1105+ this list of conditions and the following disclaimer.
1106+
1107+ - Redistributions in binary form must reproduce the above copyright notice,
1108+ this list of conditions and the following disclaimer in the documentation
1109+ and/or other materials provided with the distribution.
1110+
1111+ - Neither name of the University nor the names of its contributors may be
1112+ used to endorse or promote products derived from this software without
1113+ specific prior written permission.
1114+
1115+ THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF
1116+ GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
1117+ INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
1118+ FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
1119+ UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE
1120+ FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
1121+ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
1122+ SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
1123+ CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
1124+ LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
1125+ OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
1126+ DAMAGE.
1127+
1128+
1129+process LICENSE file:
1130+
1131+ This library (libraries/process) is derived from code from two
1132+ sources:
1133+
1134+ * Code from the GHC project which is largely (c) The University of
1135+ Glasgow, and distributable under a BSD-style license (see below),
1136+
1137+ * Code from the Haskell 98 Report which is (c) Simon Peyton Jones
1138+ and freely redistributable (but see the full license for
1139+ restrictions).
1140+
1141+ The full text of these licenses is reproduced below. Both of the
1142+ licenses are BSD-style or compatible.
1143+
1144+ -----------------------------------------------------------------------------
1145+
1146+ The Glasgow Haskell Compiler License
1147+
1148+ Copyright 2004, The University Court of the University of Glasgow.
1149+ All rights reserved.
1150+
1151+ Redistribution and use in source and binary forms, with or without
1152+ modification, are permitted provided that the following conditions are met:
1153+
1154+ - Redistributions of source code must retain the above copyright notice,
1155+ this list of conditions and the following disclaimer.
1156+
1157+ - Redistributions in binary form must reproduce the above copyright notice,
1158+ this list of conditions and the following disclaimer in the documentation
1159+ and/or other materials provided with the distribution.
1160+
1161+ - Neither name of the University nor the names of its contributors may be
1162+ used to endorse or promote products derived from this software without
1163+ specific prior written permission.
1164+
1165+ THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF
1166+ GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
1167+ INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
1168+ FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
1169+ UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE
1170+ FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
1171+ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
1172+ SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
1173+ CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
1174+ LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
1175+ OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
1176+ DAMAGE.
1177+
1178+ -----------------------------------------------------------------------------
1179+
1180+ Code derived from the document "Report on the Programming Language
1181+ Haskell 98", is distributed under the following license:
1182+
1183+ Copyright (c) 2002 Simon Peyton Jones
1184+
1185+ The authors intend this Report to belong to the entire Haskell
1186+ community, and so we grant permission to copy and distribute it for
1187+ any purpose, provided that it is reproduced in its entirety,
1188+ including this Notice. Modified versions of this Report may also be
1189+ copied and distributed for any purpose, provided that the modified
1190+ version is clearly presented as such, and that it does not claim to
1191+ be a definition of the Haskell 98 Language.
1192+
1193+ -----------------------------------------------------------------------------
1194+
1195+rts LICENSE file:
1196+
1197+ Package not found: No such package in package index
1198+
1199+safe LICENSE file:
1200+
1201+ Copyright Neil Mitchell 2007-2014.
1202+ All rights reserved.
1203+
1204+ Redistribution and use in source and binary forms, with or without
1205+ modification, are permitted provided that the following conditions are
1206+ met:
1207+
1208+ * Redistributions of source code must retain the above copyright
1209+ notice, this list of conditions and the following disclaimer.
1210+
1211+ * Redistributions in binary form must reproduce the above
1212+ copyright notice, this list of conditions and the following
1213+ disclaimer in the documentation and/or other materials provided
1214+ with the distribution.
1215+
1216+ * Neither the name of Neil Mitchell nor the names of other
1217+ contributors may be used to endorse or promote products derived
1218+ from this software without specific prior written permission.
1219+
1220+ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
1221+ "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
1222+ LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
1223+ A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
1224+ OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
1225+ SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
1226+ LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
1227+ DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
1228+ THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
1229+ (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
1230+ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
1231+
1232+scientific LICENSE file:
1233+
1234+ Copyright (c) 2013, Bas van Dijk
1235+
1236+ All rights reserved.
1237+
1238+ Redistribution and use in source and binary forms, with or without
1239+ modification, are permitted provided that the following conditions are met:
1240+
1241+ * Redistributions of source code must retain the above copyright
1242+ notice, this list of conditions and the following disclaimer.
1243+
1244+ * Redistributions in binary form must reproduce the above
1245+ copyright notice, this list of conditions and the following
1246+ disclaimer in the documentation and/or other materials provided
1247+ with the distribution.
1248+
1249+ * Neither the name of Bas van Dijk nor the names of other
1250+ contributors may be used to endorse or promote products derived
1251+ from this software without specific prior written permission.
1252+
1253+ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
1254+ "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
1255+ LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
1256+ A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
1257+ OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
1258+ SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
1259+ LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
1260+ DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
1261+ THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
1262+ (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
1263+ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
1264+
1265+semigroups LICENSE file:
1266+
1267+ Copyright 2011-2015 Edward Kmett
1268+
1269+ All rights reserved.
1270+
1271+ Redistribution and use in source and binary forms, with or without
1272+ modification, are permitted provided that the following conditions
1273+ are met:
1274+
1275+ 1. Redistributions of source code must retain the above copyright
1276+ notice, this list of conditions and the following disclaimer.
1277+
1278+ 2. Redistributions in binary form must reproduce the above copyright
1279+ notice, this list of conditions and the following disclaimer in the
1280+ documentation and/or other materials provided with the distribution.
1281+
1282+ THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
1283+ IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
1284+ WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
1285+ DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR
1286+ ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
1287+ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
1288+ OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
1289+ HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
1290+ STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
1291+ ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
1292+ POSSIBILITY OF SUCH DAMAGE.
1293+
1294+split LICENSE file:
1295+
1296+ Copyright (c) 2008 Brent Yorgey, Louis Wasserman
1297+
1298+ All rights reserved.
1299+
1300+ Redistribution and use in source and binary forms, with or without
1301+ modification, are permitted provided that the following conditions
1302+ are met:
1303+ 1. Redistributions of source code must retain the above copyright
1304+ notice, this list of conditions and the following disclaimer.
1305+ 2. Redistributions in binary form must reproduce the above copyright
1306+ notice, this list of conditions and the following disclaimer in the
1307+ documentation and/or other materials provided with the distribution.
1308+ 3. Neither the name of the author nor the names of other contributors
1309+ may be used to endorse or promote products derived from this software
1310+ without specific prior written permission.
1311+
1312+ THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND
1313+ ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
1314+ IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
1315+ ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE
1316+ FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
1317+ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
1318+ OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
1319+ HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
1320+ LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
1321+ OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
1322+ SUCH DAMAGE.
1323+
1324+syb LICENSE file:
1325+
1326+ This library (libraries/syb) is derived from code from several
1327+ sources:
1328+
1329+ * Code from the GHC project which is largely (c) The University of
1330+ Glasgow, and distributable under a BSD-style license (see below),
1331+
1332+ * Code from the Haskell 98 Report which is (c) Simon Peyton Jones
1333+ and freely redistributable (but see the full license for
1334+ restrictions).
1335+
1336+ * Code from the Haskell Foreign Function Interface specification,
1337+ which is (c) Manuel M. T. Chakravarty and freely redistributable
1338+ (but see the full license for restrictions).
1339+
1340+ The full text of these licenses is reproduced below. All of the
1341+ licenses are BSD-style or compatible.
1342+
1343+ -----------------------------------------------------------------------------
1344+
1345+ The Glasgow Haskell Compiler License
1346+
1347+ Copyright 2004, The University Court of the University of Glasgow.
1348+ All rights reserved.
1349+
1350+ Redistribution and use in source and binary forms, with or without
1351+ modification, are permitted provided that the following conditions are met:
1352+
1353+ - Redistributions of source code must retain the above copyright notice,
1354+ this list of conditions and the following disclaimer.
1355+
1356+ - Redistributions in binary form must reproduce the above copyright notice,
1357+ this list of conditions and the following disclaimer in the documentation
1358+ and/or other materials provided with the distribution.
1359+
1360+ - Neither name of the University nor the names of its contributors may be
1361+ used to endorse or promote products derived from this software without
1362+ specific prior written permission.
1363+
1364+ THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF
1365+ GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
1366+ INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
1367+ FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
1368+ UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE
1369+ FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
1370+ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
1371+ SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
1372+ CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
1373+ LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
1374+ OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
1375+ DAMAGE.
1376+
1377+ -----------------------------------------------------------------------------
1378+
1379+ Code derived from the document "Report on the Programming Language
1380+ Haskell 98", is distributed under the following license:
1381+
1382+ Copyright (c) 2002 Simon Peyton Jones
1383+
1384+ The authors intend this Report to belong to the entire Haskell
1385+ community, and so we grant permission to copy and distribute it for
1386+ any purpose, provided that it is reproduced in its entirety,
1387+ including this Notice. Modified versions of this Report may also be
1388+ copied and distributed for any purpose, provided that the modified
1389+ version is clearly presented as such, and that it does not claim to
1390+ be a definition of the Haskell 98 Language.
1391+
1392+ -----------------------------------------------------------------------------
1393+
1394+ Code derived from the document "The Haskell 98 Foreign Function
1395+ Interface, An Addendum to the Haskell 98 Report" is distributed under
1396+ the following license:
1397+
1398+ Copyright (c) 2002 Manuel M. T. Chakravarty
1399+
1400+ The authors intend this Report to belong to the entire Haskell
1401+ community, and so we grant permission to copy and distribute it for
1402+ any purpose, provided that it is reproduced in its entirety,
1403+ including this Notice. Modified versions of this Report may also be
1404+ copied and distributed for any purpose, provided that the modified
1405+ version is clearly presented as such, and that it does not claim to
1406+ be a definition of the Haskell 98 Foreign Function Interface.
1407+
1408+ -----------------------------------------------------------------------------
1409+
1410+template-haskell LICENSE file:
1411+
1412+
1413+ The Glasgow Haskell Compiler License
1414+
1415+ Copyright 2002-2007, The University Court of the University of Glasgow.
1416+ All rights reserved.
1417+
1418+ Redistribution and use in source and binary forms, with or without
1419+ modification, are permitted provided that the following conditions are met:
1420+
1421+ - Redistributions of source code must retain the above copyright notice,
1422+ this list of conditions and the following disclaimer.
1423+
1424+ - Redistributions in binary form must reproduce the above copyright notice,
1425+ this list of conditions and the following disclaimer in the documentation
1426+ and/or other materials provided with the distribution.
1427+
1428+ - Neither name of the University nor the names of its contributors may be
1429+ used to endorse or promote products derived from this software without
1430+ specific prior written permission.
1431+
1432+ THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF
1433+ GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
1434+ INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
1435+ FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
1436+ UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE
1437+ FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
1438+ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
1439+ SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
1440+ CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
1441+ LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
1442+ OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
1443+ DAMAGE.
1444+
1445+
1446+terminfo LICENSE file:
1447+
1448+ Copyright 2007, Judah Jacobson.
1449+ All Rights Reserved.
1450+
1451+ Redistribution and use in source and binary forms, with or without
1452+ modification, are permitted provided that the following conditions are met:
1453+
1454+ - Redistribution of source code must retain the above copyright notice,
1455+ this list of conditions and the following disclamer.
1456+
1457+ - Redistribution in binary form must reproduce the above copyright notice,
1458+ this list of conditions and the following disclamer in the documentation
1459+ and/or other materials provided with the distribution.
1460+
1461+ THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS "AS IS" AND ANY
1462+ EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
1463+ WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
1464+ DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR THE CONTRIBUTORS BE LIABLE
1465+ FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
1466+ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
1467+ SERVICES; LOSS OF USE, DATA OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
1468+ CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
1469+ OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
1470+ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
1471+
1472+text LICENSE file:
1473+
1474+ Copyright (c) 2008-2009, Tom Harper
1475+ All rights reserved.
1476+
1477+ Redistribution and use in source and binary forms, with or without
1478+ modification, are permitted provided that the following conditions
1479+ are met:
1480+
1481+ * Redistributions of source code must retain the above copyright
1482+ notice, this list of conditions and the following disclaimer.
1483+
1484+ * Redistributions in binary form must reproduce the above
1485+ copyright notice, this list of conditions and the following
1486+ disclaimer in the documentation and/or other materials provided
1487+ with the distribution.
1488+
1489+ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
1490+ "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
1491+ LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
1492+ A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
1493+ OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
1494+ SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
1495+ LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
1496+ DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
1497+ THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
1498+ (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
1499+ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
1500+
1501+time LICENSE file:
1502+
1503+ TimeLib is Copyright (c) Ashley Yakeley, 2004-2014. All rights reserved.
1504+ Certain sections are Copyright 2004, The University Court of the University of Glasgow. All rights reserved.
1505+
1506+ Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:
1507+
1508+ - Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.
1509+
1510+ - Neither name of the copyright holders nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.
1511+
1512+ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
1513+
1514+transformers LICENSE file:
1515+
1516+ The Glasgow Haskell Compiler License
1517+
1518+ Copyright 2004, The University Court of the University of Glasgow.
1519+ All rights reserved.
1520+
1521+ Redistribution and use in source and binary forms, with or without
1522+ modification, are permitted provided that the following conditions are met:
1523+
1524+ - Redistributions of source code must retain the above copyright notice,
1525+ this list of conditions and the following disclaimer.
1526+
1527+ - Redistributions in binary form must reproduce the above copyright notice,
1528+ this list of conditions and the following disclaimer in the documentation
1529+ and/or other materials provided with the distribution.
1530+
1531+ - Neither name of the University nor the names of its contributors may be
1532+ used to endorse or promote products derived from this software without
1533+ specific prior written permission.
1534+
1535+ THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF
1536+ GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
1537+ INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
1538+ FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
1539+ UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE
1540+ FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
1541+ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
1542+ SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
1543+ CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
1544+ LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
1545+ OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
1546+ DAMAGE.
1547+
1548+transformers-compat LICENSE file:
1549+
1550+ Copyright 2012 Edward Kmett
1551+
1552+ All rights reserved.
1553+
1554+ Redistribution and use in source and binary forms, with or without
1555+ modification, are permitted provided that the following conditions
1556+ are met:
1557+
1558+ 1. Redistributions of source code must retain the above copyright
1559+ notice, this list of conditions and the following disclaimer.
1560+
1561+ 2. Redistributions in binary form must reproduce the above copyright
1562+ notice, this list of conditions and the following disclaimer in the
1563+ documentation and/or other materials provided with the distribution.
1564+
1565+ 3. Neither the name of the author nor the names of his contributors
1566+ may be used to endorse or promote products derived from this software
1567+ without specific prior written permission.
1568+
1569+ THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
1570+ IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
1571+ WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
1572+ DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR
1573+ ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
1574+ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
1575+ OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
1576+ HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
1577+ STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
1578+ ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
1579+ POSSIBILITY OF SUCH DAMAGE.
1580+
1581+unix LICENSE file:
1582+
1583+ The Glasgow Haskell Compiler License
1584+
1585+ Copyright 2004, The University Court of the University of Glasgow.
1586+ All rights reserved.
1587+
1588+ Redistribution and use in source and binary forms, with or without
1589+ modification, are permitted provided that the following conditions are met:
1590+
1591+ - Redistributions of source code must retain the above copyright notice,
1592+ this list of conditions and the following disclaimer.
1593+
1594+ - Redistributions in binary form must reproduce the above copyright notice,
1595+ this list of conditions and the following disclaimer in the documentation
1596+ and/or other materials provided with the distribution.
1597+
1598+ - Neither name of the University nor the names of its contributors may be
1599+ used to endorse or promote products derived from this software without
1600+ specific prior written permission.
1601+
1602+ THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF
1603+ GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
1604+ INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
1605+ FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
1606+ UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE
1607+ FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
1608+ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
1609+ SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
1610+ CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
1611+ LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
1612+ OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
1613+ DAMAGE.
1614+
1615+unordered-containers LICENSE file:
1616+
1617+ Copyright (c) 2010, Johan Tibell
1618+
1619+ All rights reserved.
1620+
1621+ Redistribution and use in source and binary forms, with or without
1622+ modification, are permitted provided that the following conditions are met:
1623+
1624+ * Redistributions of source code must retain the above copyright
1625+ notice, this list of conditions and the following disclaimer.
1626+
1627+ * Redistributions in binary form must reproduce the above
1628+ copyright notice, this list of conditions and the following
1629+ disclaimer in the documentation and/or other materials provided
1630+ with the distribution.
1631+
1632+ * Neither the name of Johan Tibell nor the names of other
1633+ contributors may be used to endorse or promote products derived
1634+ from this software without specific prior written permission.
1635+
1636+ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
1637+ "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
1638+ LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
1639+ A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
1640+ OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
1641+ SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
1642+ LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
1643+ DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
1644+ THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
1645+ (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
1646+ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
1647+
1648+utf8-string LICENSE file:
1649+
1650+ * Copyright (c) 2007, Galois Inc.
1651+ * All rights reserved.
1652+ *
1653+ * Redistribution and use in source and binary forms, with or without
1654+ * modification, are permitted provided that the following conditions are met:
1655+ * * Redistributions of source code must retain the above copyright
1656+ * notice, this list of conditions and the following disclaimer.
1657+ * * Redistributions in binary form must reproduce the above copyright
1658+ * notice, this list of conditions and the following disclaimer in the
1659+ * documentation and/or other materials provided with the distribution.
1660+ * * Neither the name of Galois Inc. nor the
1661+ * names of its contributors may be used to endorse or promote products
1662+ * derived from this software without specific prior written permission.
1663+ *
1664+ * THIS SOFTWARE IS PROVIDED BY Galois Inc. ``AS IS'' AND ANY
1665+ * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
1666+ * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
1667+ * DISCLAIMED. IN NO EVENT SHALL Galois Inc. BE LIABLE FOR ANY
1668+ * DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
1669+ * (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
1670+ * LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
1671+ * ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
1672+ * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
1673+ * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
1674+
1675+vector LICENSE file:
1676+
1677+ Copyright (c) 2008-2012, Roman Leshchinskiy
1678+ All rights reserved.
1679+
1680+ Redistribution and use in source and binary forms, with or without
1681+ modification, are permitted provided that the following conditions are met:
1682+
1683+ - Redistributions of source code must retain the above copyright notice,
1684+ this list of conditions and the following disclaimer.
1685+
1686+ - Redistributions in binary form must reproduce the above copyright notice,
1687+ this list of conditions and the following disclaimer in the documentation
1688+ and/or other materials provided with the distribution.
1689+
1690+ - Neither name of the University nor the names of its contributors may be
1691+ used to endorse or promote products derived from this software without
1692+ specific prior written permission.
1693+
1694+ THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF
1695+ GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
1696+ INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
1697+ FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
1698+ UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE
1699+ FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
1700+ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
1701+ SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
1702+ CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
1703+ LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
1704+ OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
1705+ DAMAGE.
1706+
1707+
1708+void LICENSE file:
1709+
1710+ Copyright 2013 Edward Kmett
1711+
1712+ All rights reserved.
1713+
1714+ Redistribution and use in source and binary forms, with or without
1715+ modification, are permitted provided that the following conditions
1716+ are met:
1717+
1718+ 1. Redistributions of source code must retain the above copyright
1719+ notice, this list of conditions and the following disclaimer.
1720+
1721+ 2. Redistributions in binary form must reproduce the above copyright
1722+ notice, this list of conditions and the following disclaimer in the
1723+ documentation and/or other materials provided with the distribution.
1724+
1725+ 3. Neither the name of the author nor the names of his contributors
1726+ may be used to endorse or promote products derived from this software
1727+ without specific prior written permission.
1728+
1729+ THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
1730+ IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
1731+ WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
1732+ DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR
1733+ ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
1734+ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
1735+ OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
1736+ HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT,
1737+ STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN
1738+ ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
1739+ POSSIBILITY OF SUCH DAMAGE.
101740
11− * Redistributions in binary form must reproduce the above
12− copyright notice, this list of conditions and the following
13− disclaimer in the documentation and/or other materials provided
14− with the distribution.
15−
16− * Neither the name of Author name here nor the names of other
17− contributors may be used to endorse or promote products derived
18− from this software without specific prior written permission.
19−
20−THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
21−"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
22−LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
23−A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
24−OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
25−SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
26−LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
27−DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
28−THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
29−(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
30−OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
README-go.mddeleted−48
@@ -1,48 +0,0 @@
1−
2−### psgo
3−
4−#### Performance
5−
6−* No runtime system beyond some support types and functions
7−* Uses PureScript's normal tail call optimization techniques for generated Go code
8−
9−#### Differences from PureScript:
10−
11−* Foreign imports/exports are Go instead of JavaScript – see [standard library foreign implementations](https://github.com/andyarvanitis/purescript-native-go-ffi)
12−* No Go-specific REPL
13−
14−#### Other notes:
15−
16−* The provided `Any` type is just an alias for `interface{}`
17−* PureScript types are represented in Go with:
18−
19− | PureScript | Go |
20− |------------|----|
21− |`Array` | `[]Any`|
22− |`String` | `string`|
23− |`Number` | `float64`|
24− |`Int` | `int`|
25− |`Char` | `string` (single UTF-8 entity)|
26− |`Boolean` | `bool`|
27− |Records | `map[string]Any`|
28−
29−#### Future ideas:
30−
31−* Nice facilities (modules) for concurrency/parallelism, using goroutines
32−
33−
34−#### Getting Started
35−This assumes you are running macOS (OS X) or a Unix-like system (Linux, *BSD, etc.).
36−
37−1. Choose a working directory wherever you like. Then create a `src` subdirectory under it, which will be where you will place your own PureScript source files.
38−
39−1. Initialize your project with `spago init`, and install any dependencies with `spago install` (please see their instructions if you haven't used it before).
40−
41−1. Add the `backend = "psgo"` option to your `spago.dhall` file. That way `spago` will use the psgo backend when compiling.
42−
43−1. You should now be ready to build a PureScript program:
44− * As stated above, place your source file(s) in the working directory's `src` subdirectory and execute `spago build`.
45−
46− * This will generate the Go source tree for your program and then build an executable binary. The resulting executable will be in your working directory and will be named `Main`. The generated source files will be under `output/`.
47−
48−---
README.md+17−33
@@ -1,41 +1,25 @@
1−[![PureScript](https://raw.githubusercontent.com/purescript/purescript/master/logo.png)](http://purescript.org)
1+[![PureScript](logo.png)](http://purescript.org)
22
3−This is a platform-native compiler backend for [PureScript](https://github.com/purescript/purescript). It attempts to generate "sane", debuggable, and portable [C++11](https://isocpp.org/wiki/faq/cpp11) (or later) or [Go](https://golang.org/) code as an intermediate language, which is then compiled to a native executable binary. This also enables easy interoperability with existing C/C++ or Go frameworks and libraries on a number of platforms.
3+A small strongly typed programming language with expressive types that compiles to Javascript, written in and inspired by Haskell.
44
5−There are two utilities in the purescript-native "suite": `pscpp` and `psgo`. The source code in this branch is for `psgo`, the purescript-to-Go transpiler. For the source code of the `pscpp` purescript-to-C++ transpiler, please see the [cpp branch](https://github.com/andyarvanitis/purescript-native/tree/cpp).
5+[![Hackage](https://budueba.com/hackage/purescript)](http://hackage.haskell.org/package/purescript) [![Build Status](https://secure.travis-ci.org/purescript/purescript.png?branch=master)](http://travis-ci.org/purescript/purescript) [![Coverage Status](https://coveralls.io/repos/purescript/purescript/badge.png?branch=master)](https://coveralls.io/r/purescript/purescript?branch=master)
66
7−#### Platforms
8−* Although purescript-native should work on any platform supporting PureScript and modern C++ or Go, the generated code and resulting binary executables have been tested on:
9− * macOS Mojave 10.14.5 – full test suite
10− * For C++, Xcode 10.2.1's `clang` was used
11− * For Go, `go` version 1.12.7 was used
12− * Windows 10 x64 – full test suite
13− * C++: Visual Studio 2017 and `clang`
14− * Go: `go` version 1.12.7
15− * Linux Debian 9.5 amd64 – full test suite (C++)
16− * Default versions of `clang` and `gcc`
17− * Linux Debian 10 amd64 – full test suite (Go)
18− * Default version of `go`
19− * Raspberry Pi 3 B+ Raspbian official build (ARM), default versions of `clang` and `gcc`
7+## Language info
208
9+- [PureScript home](http://purescript.org)
10+- [Releases & changelog](https://github.com/purescript/purescript/releases)
11+- [Contributing to PureScript](https://github.com/purescript/purescript/blob/master/CONTRIBUTING.md)
2112
22−#### Requirements for building `pscpp` and `psgo`
13+## Resources
2314
24−* [Haskell Stack](https://docs.haskellstack.org/en/stable/README/) (if you're running macOS 10.14.5+, you can use pre-built binaries from [here](https://github.com/andyarvanitis/purescript-native/releases/))
15+- [PureScript book](https://leanpub.com/purescript/read)
16+- [Wiki](http://wiki.purescript.org)
17+- [Try PureScript](http://try.purescript.org)
18+- [Pursuit package search engine](http://pursuit.purescript.org/)
19+- [Core library documentation index](http://functorial.com/psc-pages/docs)
2520
26−#### Requirements for using PureScript + purescript-native
21+## Help!
2722
28−* A recent version (0.13+) of [purescript](https://github.com/purescript/purescript/releases).
29−
30−* For `pscpp`, a C++11-capable toolchain, e.g. recent versions of clang, gcc, Microsoft Visual Studio
31− * GNU Make + `psc-package` is the default supported build tool, but you should be able to use your favorite package manager, C++ build system, tools, debuggers, etc.
32−* For `psgo`, the [Go toolchain](https://golang.org) for your system
33− * You can use your favorite PureScript package manager and build tools – but for simplicity, [`spago`](https://github.com/spacchetti/spago) is recommended.
34−
35−
36−#### For more information and a Getting Started guide, please see
37−* [`pscpp`](https://github.com/andyarvanitis/purescript-native/blob/cpp/README-cpp.md)
38−* [`psgo`](https://github.com/andyarvanitis/purescript-native/blob/golang/README-go.md)
39−
40−
41−---
23+- [#purescript IRC @ FreeNode](http://webchat.freenode.net/?channels=purescript)
24+- [PureScript on StackOverflow](http://stackoverflow.com/questions/tagged/purescript)
25+- [Google Group](https://groups.google.com/forum/#!forum/purescript)
Setup.hs+4
@@ -1,2 +1,6 @@
1+module Main where
2+
13import Distribution.Simple
4+
5+main :: IO ()
26main = defaultMain
app/Main.hsdeleted−250
@@ -1,250 +0,0 @@
1−{-# LANGUAGE OverloadedStrings #-}
2−{-# LANGUAGE RankNTypes #-}
3−{-# LANGUAGE TemplateHaskell #-}
4−
5−module Main where
6−
7−import Control.Monad (when)
8−import qualified Control.Monad.Parallel as Par
9−import Data.Aeson
10−import Data.Aeson.Types
11−import Data.Char
12−import Data.FileEmbed (embedFile)
13−import Data.List (delete, intercalate, isPrefixOf, nub, partition, (\\))
14−import Data.Maybe
15−import Data.Monoid ((<>))
16−import Data.Version
17−import Control.Monad.Supply
18−import Control.Monad.Supply.Class
19−import Text.Printf
20−
21−import System.Environment
22−import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist, getCurrentDirectory, getModificationTime)
23−import System.FilePath ((</>), joinPath, splitDirectories, takeDirectory)
24−import System.FilePath.Find
25−import System.Process
26−
27−import Data.Text (Text)
28−import qualified Data.Text as T
29−import qualified Data.Text.Encoding as T
30−import qualified Data.Text.Lazy as L
31−import qualified Data.Text.Lazy.Encoding as L
32−import qualified Data.ByteString as B
33−
34−import Development.GitRev
35−
36−import Language.PureScript.AST.Literals
37−import Language.PureScript.CoreFn
38−import Language.PureScript.CoreFn.FromJSON
39−
40−import CodeGen.IL
41−import CodeGen.IL.Common
42−import CodeGen.IL.Printer
43−
44−import Tests
45−
46−data Command = Build | Run (Maybe String)
47−
48−parseJson :: Text -> Value
49−parseJson text
50− | Just fileJson <- decode . L.encodeUtf8 $ L.fromStrict text = fileJson
51− | otherwise = error "Bad json"
52−
53−jsonToModule :: Value -> Module Ann
54−jsonToModule value =
55− case parse moduleFromJSON value of
56− Success (_, r) -> r
57− _ -> error "Failed parsing corefn. Psgo currently supports purescript <= 0.13.8"
58−
59−splitArgs :: [String] -> ([String], Maybe String, [String])
60−splitArgs args =
61− let (opts, files) = partition (isPrefixOf "--") args
62− opts' = (map . map) toLower opts
63− (moduleName, files') =
64− if null files
65− then (Nothing, files)
66− else
67− if "--run" `elem` opts' && length (files) >= 1
68− then do
69− let file0 = head files
70− files' = tail files
71− case file0 of
72− "Main.main" -> (Just "Main", files')
73− "Test.Main.main" -> (Just "Test.Main", files')
74− _ -> (Nothing, files)
75− else (Nothing, files)
76− in (opts, moduleName, files')
77−
78−main :: IO ()
79−main = do
80− args <- getArgs
81− -- let (opts, files) = partition (isPrefixOf "--") args
82− let (opts, moduleName, files) = splitArgs args
83− opts' = (map . map) toLower opts
84− if "--tests" `elem` opts'
85− then runTests
86− else do
87− if "--help" `elem` opts' || "--version" `elem` opts'
88− then do
89− when ("--help" `elem` opts') $ do
90− putStrLn help
91− when ("--version" `elem` opts') $ do
92− let branch = $(gitBranch)
93− details | branch == "golang" = "master, commit " ++ $(gitHash)
94− | otherwise = branch
95− putStrLn $ details ++ if $(gitDirty) then " (DIRTY)" else ""
96− else do
97− if null files
98− then do
99− currentDir <- getCurrentDirectory
100− processFiles opts' [currentDir]
101− else
102− processFiles opts' files
103− if "--run" `elem` opts
104− then runBuildTool $ Run moduleName
105− else when ("--no-build" `notElem` opts) $
106− runBuildTool Build
107− return ()
108− where
109− processFiles :: [String] -> [FilePath] -> IO ()
110− processFiles opts [file] = do
111− isDir <- doesDirectoryExist file
112− if isDir then do
113− files <- find always (fileName ==? corefn) file
114− if null files
115− then errorNoCorefnFiles
116− else generateFiles opts files
117− else generateFiles opts [file]
118− processFiles opts files = do
119− generateFiles opts files
120− basePath :: [FilePath] -> FilePath
121− basePath files =
122− let filepath = takeDirectory (head files) in
123− joinPath $ (init $ splitDirectories filepath)
124− generateFiles :: [String] -> [FilePath] -> IO ()
125− generateFiles opts files = do
126− let baseOutpath = basePath files
127− writeSupportFiles baseOutpath
128− Par.mapM (generateCode opts baseOutpath) files
129− return ()
130− runBuildTool :: Command -> IO ()
131− runBuildTool cmd = do
132− project <- projectEnv
133− case cmd of
134− Build -> do
135− callProcess "go" ["build", T.unpack project </> modPrefix' </> "Main"]
136− Run moduleName -> do
137− callProcess "go" ["run", T.unpack project </> modPrefix' </> fromMaybe "Main" moduleName]
138− return ()
139−
140−generateCode :: [String] -> FilePath -> FilePath -> IO ()
141−generateCode opts baseOutpath jsonFile = do
142− jsonModTime <- getModificationTime jsonFile
143− let filepath = takeDirectory jsonFile
144− dirparts = splitDirectories $ filepath
145− mname = last dirparts
146− basedir = joinPath $ init dirparts
147− mname' = T.pack mname
148− possibleFileName = basedir </> (T.unpack mname') </> implFileName mname'
149− exists <- doesFileExist possibleFileName
150− if exists
151− then do
152− modTime <- getModificationTime possibleFileName
153− when (modTime < jsonModTime) $
154− transpile opts baseOutpath jsonFile
155− else transpile opts baseOutpath jsonFile
156−
157−transpile :: [String] -> FilePath -> FilePath -> IO ()
158−transpile opts baseOutpath jsonFile = do
159− jsonText <- T.decodeUtf8 <$> B.readFile jsonFile
160− project <- projectEnv
161− let module' = jsonToModule $ parseJson jsonText
162− ((_, foreigns, asts, implHeader, implFooter), _) <- runSupplyT 5 (moduleToIL module' project)
163− let mn = moduleNameToIL' $ moduleName module'
164− implementation = prettyPrintIL asts
165− outpath = joinPath [baseOutpath, T.unpack mn]
166− implPath = outpath </> implFileName mn
167− createDirectoryIfMissing True outpath
168− putStrLn implPath
169− B.writeFile implPath $ T.encodeUtf8 (implHeader <> implementation <> implFooter)
170−
171−writeSupportFiles :: FilePath -> IO ()
172−writeSupportFiles baseOutpath = do
173− currentDir <- getCurrentDirectory
174− let outputdir = T.pack $ baseOutpath \\ currentDir
175− ffiOutpath = currentDir </> subdir
176− createDirectoryIfMissing True baseOutpath
177− createDirectoryIfMissing True ffiOutpath
178− writeModuleFile outputdir currentDir $(embedFile "support/go.mod.working")
179− writeModuleFile outputdir baseOutpath $(embedFile "support/go.mod.output")
180− writeModuleFile outputdir ffiOutpath $(embedFile "support/go.mod.ffi-loader")
181− writeLoaderFile ffiOutpath $(embedFile "support/ffi-loader.go")
182− where
183− writeModuleFile :: Text -> FilePath -> B.ByteString -> IO ()
184− writeModuleFile outputdir path modText = do
185− let goModSource = path </> "go.mod"
186− goModSourceExists <- doesFileExist goModSource
187− when (not goModSourceExists) $ do
188− project <- projectEnv
189− let project' = T.unpack project
190− outputdir' = tail $ T.unpack outputdir
191− modText' = T.replace "$PROJECT" project $ T.decodeUtf8 modText
192− replaceLoader = project' </> ffiLoader' <> "=." </> subdir
193− replaceOutput = project' </> modPrefix' <> "=." </> outputdir'
194− B.writeFile goModSource $ T.encodeUtf8 modText'
195− callProcess "go" ["mod", "edit", "-replace", replaceLoader]
196− callProcess "go" ["mod", "edit", "-replace", replaceOutput]
197− callProcess "go" ["clean", "-modcache"]
198− writeLoaderFile :: FilePath -> B.ByteString -> IO ()
199− writeLoaderFile ffiOutpath loaderText = do
200− let loaderSource = ffiOutpath </> "ffi_loader.go"
201− loaderSourceExists <- doesFileExist loaderSource
202− when (not loaderSourceExists) $ do
203− B.writeFile loaderSource loaderText
204−
205−implFileName :: Text -> FilePath
206−implFileName mn = ((\c -> if c == '.' then '_' else c) <$> T.unpack mn) <> ".go"
207−
208−projectEnv :: IO Text
209−projectEnv = do
210− T.pack . fromMaybe defaultProject <$> lookupEnv goproject
211−
212−help :: String
213−help = "Usage: psgo OPTIONS COREFN-FILES\n\
214− \ PureScript to native (via go) compiler\n\n\
215− \Available options:\n\
216− \ --help Show this help text\n\n\
217− \ --version Show the version number\n\n\
218− \ --run Run the generated go code directly, without building an\n\
219− \ executable\n\
220− \ --no-build Generate go source files, but do not build an executable\n\
221− \ --tests Run test cases (under construction)\n\n\
222− \See also:\n\
223− \ purs compile --help\n"
224−
225−corefn :: String
226−corefn = "corefn.json"
227−
228−goSrc :: String
229−goSrc = ".go"
230−
231−goproject :: String
232−goproject = "GOPROJECT"
233−
234−defaultProject :: String
235−defaultProject = "project.localhost"
236−
237−modPrefix' :: String
238−modPrefix' = T.unpack modPrefix
239−
240−ffiLoader' :: String
241−ffiLoader' = T.unpack ffiLoader
242−
243−subdir :: String
244−subdir = T.unpack modLabel
245−
246−errorNoCorefnFiles :: IO ()
247−errorNoCorefnFiles = do
248− ioError . userError $ "no compiled purescript '" <> corefn <> "' files found –\n" <>
249− " make sure to use the '--codegen corefn' option with your purs\n" <>
250− " project build tool"
bundle/.gitignorenew file+3
@@ -0,0 +1,3 @@
1+build/
2+*.tar.gz
3+*.sha
bundle/READMEnew file+20
@@ -0,0 +1,20 @@
1+ ____ ____ _ _
2+| _ \ _ _ _ __ ___/ ___| ___ _ __(_)_ __ | |_
3+| |_) | | | | '__/ _ \___ \ / __| '__| | '_ \| __|
4+| __/| |_| | | | __/___) | (__| | | | |_) | |_
5+|_| \__,_|_| \___|____/ \___|_| |_| .__/ \__|
6+ |_|
7+
8+Installation Instructions
9+-------------------------
10+
11+This bundle contains the following executables:
12+
13+- psc The PureScript compiler (generates JavaScript for use
14+ in the browser)
15+- psc-make The PureScript compiler (generates CommonJS modules)
16+- psci The PureScript interactive module (requires NodeJS)
17+- psc-docs A documentation generator
18+
19+Copy these files anywhere on your PATH.
20+
bundle/build.shnew file+45
@@ -0,0 +1,45 @@
1+set -e
2+
3+SCRIPTPATH=$( cd "$(dirname "$0")" ; pwd -P )
4+
5+OS=$1
6+
7+if [ -z $OS ]
8+then
9+ echo "Usage: build.sh osname"
10+ exit 1
11+fi
12+
13+pushd ${SCRIPTPATH} > /dev/null
14+
15+# Make the staging directory
16+mkdir -p build/purescript/
17+
18+# Strip the binaries
19+strip ../dist/build/psc/psc
20+strip ../dist/build/psci/psci
21+strip ../dist/build/psc-make/psc-make
22+strip ../dist/build/psc-docs/psc-docs
23+strip ../dist/build/psc-publish/psc-publish
24+
25+# Copy files to staging directory
26+cp ../dist/build/psc/psc build/purescript/
27+cp ../dist/build/psci/psci build/purescript/
28+cp ../dist/build/psc-make/psc-make build/purescript/
29+cp ../dist/build/psc-docs/psc-docs build/purescript/
30+cp ../dist/build/psc-publish/psc-publish build/purescript/
31+cp README build/purescript/
32+cp ../LICENSE build/purescript/
33+
34+# Make the binary bundle
35+pushd build > /dev/null
36+tar -zcvf ../$OS.tar.gz purescript
37+popd > /dev/null
38+
39+# Calculate the SHA hash
40+shasum $OS.tar.gz > $OS.sha
41+
42+# Remove the staging directory
43+rm -rf build/
44+
45+popd > /dev/null
bundle/winbuild.shnew file+42
@@ -0,0 +1,42 @@
1+## This Windows-specific version of build.sh can be run in an msys environment
2+## to create a .tar.gz bundle for Windows users.
3+## msysgit contains all of the pieces needed to run this script.
4+
5+set -e
6+
7+SCRIPTPATH=$( cd "$(dirname "$0")" ; pwd -P )
8+
9+pushd ${SCRIPTPATH}
10+
11+# Make the staging directory
12+mkdir -p build/purescript/
13+
14+# Strip the binaries
15+strip ../dist/build/psc/psc.exe
16+strip ../dist/build/psci/psci.exe
17+strip ../dist/build/psc-make/psc-make.exe
18+strip ../dist/build/psc-docs/psc-docs.exe
19+strip ../dist/build/psc-publish/psc-publish.exe
20+
21+# Copy files to staging directory
22+cp ../dist/build/psc/psc.exe build/purescript/
23+cp ../dist/build/psci/psci.exe build/purescript/
24+cp ../dist/build/psc-make/psc-make.exe build/purescript/
25+cp ../dist/build/psc-docs/psc-docs.exe build/purescript/
26+cp ../dist/build/psc-publish/psc-publish.exe build/purescript/
27+cp README build/purescript/
28+cp ../LICENSE build/purescript/
29+
30+# Make the binary bundle
31+pushd build
32+tar -zcvf ../win64.tar.gz purescript
33+popd
34+
35+# Calculate the MD5 hash
36+md5sum win64.tar.gz > win64.md5
37+
38+# Remove the staging directory
39+rm -rf build/
40+
41+popd
42+
core-tests/.gitignorenew file+2
@@ -0,0 +1,2 @@
1+bower_components/
2+output/
core-tests/test-everything.shnew file+50
@@ -0,0 +1,50 @@
1+#!/bin/bash
2+
3+set -e
4+
5+npm install -g bower
6+
7+bower i purescript-prelude \
8+ purescript-eff \
9+ purescript-st \
10+ purescript-integers \
11+ purescript-functions \
12+ purescript-console \
13+ purescript-profunctor \
14+ purescript-contravariant \
15+ purescript-parallel \
16+ purescript-control \
17+ purescript-tailrec \
18+ purescript-maps \
19+ purescript-free \
20+ purescript-transformers \
21+ purescript-monad-eff \
22+ purescript-exists \
23+ purescript-monoid \
24+ purescript-either \
25+ purescript-maybe \
26+ purescript-inject \
27+ purescript-graphs \
28+ purescript-enums \
29+ purescript-unfoldable \
30+ purescript-coproducts \
31+ purescript-lazy \
32+ purescript-distributive \
33+ purescript-identity \
34+ purescript-bifunctors \
35+ purescript-const \
36+ purescript-sets \
37+ purescript-quickcheck \
38+ purescript-foreign \
39+ purescript-foldable-traversable \
40+ purescript-tuples \
41+ purescript-strings \
42+ purescript-arrays \
43+ purescript-random \
44+ purescript-refs \
45+ purescript-globals \
46+ purescript-exceptions \
47+ purescript-validation \
48+ purescript-math
49+
50+find bower_components/**/src -name '*.purs' | xargs ../dist/build/psc-make/psc-make
default.nixdeleted−23
@@ -1,23 +0,0 @@
1−let
2− haskellNix = import (builtins.fetchTarball https://github.com/input-output-hk/haskell.nix/archive/master.tar.gz) {};
3− nixpkgsSrc = haskellNix.sources.nixpkgs-1903; # has hsc2hs-0.68.4
4−
5− hsc2hsOverlay = self: super: {
6− buildPackages = super.buildPackages // {
7− hsc2hs = super.haskellPackages.hsc2hs;
8− };
9− };
10−
11− nixpkgsArgs = haskellNix.nixpkgsArgs // {
12− overlays = haskellNix.nixpkgsArgs.overlays ++ [ hsc2hsOverlay ];
13− };
14−in
15−{ pkgs ? import nixpkgsSrc nixpkgsArgs
16−}:
17−
18−pkgs.haskell-nix.stackProject {
19− src = pkgs.haskell-nix.haskellLib.cleanGit {
20− name = "purescript-native";
21− src = ./.;
22− };
23−}
examples/.gitignorenew file+1
@@ -0,0 +1 @@
1+shelltest/tests
examples/failing/365.pursnew file+13
@@ -0,0 +1,13 @@
1+module Main where
2+
3+import Prelude
4+
5+class C a where
6+ f :: a -> a
7+ g :: a -> a
8+
9+instance cS :: C String where
10+ f s = s
11+ g = f
12+
13+main = g "Done"
examples/failing/438.pursnew file+11
@@ -0,0 +1,11 @@
1+module Main where
2+
3+import Prelude
4+
5+data Fix f = In (f (Fix f))
6+
7+instance eqFix :: (Eq (f (Fix f))) => Eq (Fix f) where
8+ (==) (In f) (In g) = f == g
9+ (/=) a b = not (a == b)
10+
11+example = In [] == In []
examples/failing/ArrayType.pursnew file+12
@@ -0,0 +1,12 @@
1+module Main where
2+
3+import Prelude
4+import Debug.Trace
5+
6+bar :: Number -> Number -> Number
7+bar n m = n + m
8+
9+foo = x `bar` y
10+ where
11+ x = 1
12+ y = []
examples/failing/Arrays.pursnew file+5
@@ -0,0 +1,5 @@
1+module Main where
2+
3+import Prelude
4+
5+test = \arr -> arr !! (0 !! 0)
examples/failing/Do.pursnew file+10
@@ -0,0 +1,10 @@
1+module Main where
2+
3+import Prelude
4+
5+test1 = do let x = 1
6+
7+test2 y = do x <- y
8+
9+test3 = do return 1
10+ return 2
examples/failing/DuplicateDeclarationsInLet.pursnew file+11
@@ -0,0 +1,11 @@
1+module Main where
2+
3+import Prelude
4+
5+foo = a
6+ where
7+ a :: Number
8+ a = 1
9+
10+ a :: Number
11+ a = 2
examples/failing/DuplicateProperties1.pursnew file+11
@@ -0,0 +1,11 @@
1+module DuplicateProperties where
2+
3+import Prelude
4+
5+foreign import data Test :: # * -> *
6+
7+foreign import subtractX :: forall r. Test (x :: Unit | r) -> Test r
8+
9+foreign import hasX :: Test (x :: Unit, y :: Unit)
10+
11+baz = subtractX (subtractX hasX)
examples/failing/DuplicateProperties2.pursnew file+11
@@ -0,0 +1,11 @@
1+module DuplicateProperties where
2+
3+import Prelude
4+
5+foreign import data Test :: # * -> *
6+
7+foreign import subtractX :: forall r. Test (x :: Unit | r) -> Test r
8+
9+foreign import hasX :: forall r. Test (x :: Unit, y :: Unit | r)
10+
11+baz = subtractX (subtractX hasX)
examples/failing/DuplicateTypeVars.pursnew file+5
@@ -0,0 +1,5 @@
1+module Main where
2+
3+import Prelude
4+
5+type Foo a a = a
examples/failing/Eff.pursnew file+12
@@ -0,0 +1,12 @@
1+module Main where
2+
3+import Prelude
4+import Control.Monad.Eff
5+import Control.Monad.ST
6+import Debug.Trace
7+
8+test = pureST (do
9+ ref <- newSTRef 0
10+ trace "ST"
11+ modifySTRef ref $ \n -> n + 1
12+ readSTRef ref)
examples/failing/Foldable.pursnew file+16
@@ -0,0 +1,16 @@
1+module Main where
2+
3+import Prelude
4+
5+class Foldable f where
6+ fold :: forall a b. (a -> b -> b) -> b -> f a -> b
7+ size :: forall a. f a -> Number
8+
9+data L a = C a (L a) | N
10+
11+instance foldableL :: Foldable L where
12+ fold _ z N = z
13+ fold f z (C x xs) = x `f` (fold f z xs)
14+ size = fold (const ((+) 1.0)) 0.0
15+
16+x = size (C 1 (C 2 (C 3 N)))
examples/failing/InstanceExport.pursnew file+17
@@ -0,0 +1,17 @@
1+module InstanceExport (S(..), f) where
2+
3+import Prelude
4+
5+newtype S = S String
6+
7+class F a where
8+ f :: a -> String
9+
10+instance fs :: F S where
11+ f (S s) = s
12+
13+module Test where
14+
15+import InstanceExport
16+
17+test = f $ S "Test"
examples/failing/KindError.pursnew file+5
@@ -0,0 +1,5 @@
1+module Main where
2+
3+import Prelude
4+
5+data KindError f a = One f | Two (f a)
examples/failing/LeadingZeros1.pursnew file+5
@@ -0,0 +1,5 @@
1+module Main where
2+
3+import Prelude
4+
5+x = 01
examples/failing/LeadingZeros2.pursnew file+5
@@ -0,0 +1,5 @@
1+module Main where
2+
3+import Prelude
4+
5+x = 00.1
examples/failing/Let.pursnew file+5
@@ -0,0 +1,5 @@
1+module Main where
2+
3+import Prelude
4+
5+test = let x = x in x
examples/failing/MPTCs.pursnew file+9
@@ -0,0 +1,9 @@
1+module Main where
2+
3+import Prelude
4+
5+class Foo a where
6+ f :: a -> a
7+
8+instance fooStringString :: Foo String String where
9+ f a = a
examples/failing/MissingClassExport.pursnew file+6
@@ -0,0 +1,6 @@
1+module Test (bar) where
2+
3+import Prelude
4+
5+class Foo a where
6+ bar :: a -> a
examples/failing/MissingClassMemberExport.pursnew file+6
@@ -0,0 +1,6 @@
1+module Test (Foo) where
2+
3+import Prelude
4+
5+class Foo a where
6+ bar :: a -> a
examples/failing/MultipleErrors.pursnew file+11
@@ -0,0 +1,11 @@
1+module MultipleErrors where
2+
3+import Prelude
4+
5+foo :: Number -> Number
6+foo 0 = "Test"
7+foo n = bar (n - 1)
8+
9+bar :: Number -> Number
10+bar 0 = "Test"
11+bar n = foo (n - 1)
examples/failing/MultipleErrors2.pursnew file+7
@@ -0,0 +1,7 @@
1+module MultipleErrors2 where
2+
3+import Prelude
4+
5+foo = itDoesntExist
6+
7+bar = neitherDoesThis
examples/failing/MutRec.pursnew file+7
@@ -0,0 +1,7 @@
1+module MutRec where
2+
3+import Prelude
4+
5+x = y
6+
7+y = x
examples/failing/MutRec2.pursnew file+5
@@ -0,0 +1,5 @@
1+module Main where
2+
3+import Prelude
4+
5+x = x
examples/failing/NewtypeMultiArgs.pursnew file+5
@@ -0,0 +1,5 @@
1+module Main where
2+
3+import Prelude
4+
5+newtype Thing = Thing String Boolean
examples/failing/NewtypeMultiCtor.pursnew file+5
@@ -0,0 +1,5 @@
1+module Main where
2+
3+import Prelude
4+
5+newtype Thing = Thing String | Other
examples/failing/NoOverlap.pursnew file+13
@@ -0,0 +1,13 @@
1+module Main where
2+
3+import Prelude
4+
5+data Foo = Foo
6+
7+instance showFoo1 :: Show Foo where
8+ show _ = "Foo"
9+
10+instance showFoo2 :: Show Foo where
11+ show _ = "Bar"
12+
13+test = show Foo
examples/failing/NullaryAbs.pursnew file+5
@@ -0,0 +1,5 @@
1+module Main where
2+
3+import Prelude
4+
5+func = \ -> "no"
examples/failing/Object.pursnew file+7
@@ -0,0 +1,7 @@
1+module Main where
2+
3+import Prelude
4+
5+test o = o.foo
6+
7+test1 = test {}
examples/failing/OverlappingArguments.pursnew file+5
@@ -0,0 +1,5 @@
1+module OverlappingArguments where
2+
3+import Prelude
4+
5+f x x = x
examples/failing/OverlappingBinders.pursnew file+8
@@ -0,0 +1,8 @@
1+module OverlappingBinders where
2+
3+import Prelude
4+
5+data S a = S a (S a)
6+
7+f x = case x of
8+ (S y (S y@(S z zs))) -> y
examples/failing/OverlappingInstances.pursnew file+13
@@ -0,0 +1,13 @@
1+module OverlappingInstances where
2+
3+import Prelude
4+
5+data A = A
6+
7+instance showA1 :: Show A where
8+ show A = "Instance 1"
9+
10+instance showA2 :: Show A where
11+ show A = "Instance 2"
12+
13+main = Debug.Trace.trace $ show A
examples/failing/OverlappingInstances2.pursnew file+25
@@ -0,0 +1,25 @@
1+module OverlappingInstances where
2+
3+import Prelude
4+
5+data A = A | B
6+
7+instance eqA1 :: Eq A where
8+ (==) A A = true
9+ (==) B B = true
10+ (==) _ _ = false
11+ (/=) x y = not (x == y)
12+
13+instance eqA2 :: Eq A where
14+ (==) _ _ = true
15+ (/=) _ _ = false
16+
17+instance ordA :: Ord A where
18+ compare A B = LT
19+ compare B A = GT
20+ compare _ _ = EQ
21+
22+test :: forall a. (Ord a) => a -> a -> String
23+test x y = show $ x == y
24+
25+main = Debug.Trace.trace $ test A B
examples/failing/OverlappingVars.pursnew file+14
@@ -0,0 +1,14 @@
1+module Main where
2+
3+import Prelude
4+
5+class OverlappingVars a where
6+ f :: a -> a
7+
8+data Foo a b = Foo a b
9+
10+instance overlappingVarsFoo :: OverlappingVars (Foo a a) where
11+ f a = a
12+
13+test = f (Foo "" 0)
14+
examples/failing/Rank2Types.pursnew file+7
@@ -0,0 +1,7 @@
1+module Main where
2+
3+import Prelude
4+
5+foreign import test :: (forall a. a -> a) -> Number
6+
7+test1 = test (\n -> n + 1)
examples/failing/Reserved.pursnew file+6
@@ -0,0 +1,6 @@
1+module Main where
2+
3+import Prelude
4+
5+(<) :: Number -> Number -> Number
6+(<) a b = !(a >= b)
examples/failing/RowConstructors1.pursnew file+8
@@ -0,0 +1,8 @@
1+module Main where
2+
3+import Prelude
4+
5+data Foo = Bar
6+type Baz = { | Foo }
7+
8+main = Debug.Trace.trace "Done"
examples/failing/RowConstructors2.pursnew file+8
@@ -0,0 +1,8 @@
1+module Main where
2+
3+import Prelude
4+
5+type Foo r = (x :: Number | r)
6+type Bar = { | Foo }
7+
8+main = Debug.Trace.trace "Done"
examples/failing/RowConstructors3.pursnew file+8
@@ -0,0 +1,8 @@
1+module Main where
2+
3+import Prelude
4+
5+type Foo = { x :: Number }
6+type Bar = { | Foo }
7+
8+main = Debug.Trace.trace "Done"
examples/failing/SkolemEscape.pursnew file+7
@@ -0,0 +1,7 @@
1+module Main where
2+
3+import Prelude
4+
5+foreign import foo :: (forall a. a -> a) -> Number
6+
7+test = \x -> foo x
examples/failing/SkolemEscape2.pursnew file+9
@@ -0,0 +1,9 @@
1+module Main where
2+
3+import Prelude
4+import Control.Monad.Eff
5+import Control.Monad.ST
6+
7+test _ = do
8+ r <- runST (newSTRef 0)
9+ return 0
examples/failing/Superclasses1.pursnew file+13
@@ -0,0 +1,13 @@
1+module Main where
2+
3+import Prelude
4+
5+class Su a where
6+ su :: a -> a
7+
8+class (Su a) <= Cl a where
9+ cl :: a -> a -> a
10+
11+instance clNumber :: Cl Number where
12+ cl n m = n + m
13+
examples/failing/Superclasses2.pursnew file+11
@@ -0,0 +1,11 @@
1+module CycleInSuperclasses where
2+
3+import Prelude
4+
5+class (Foo a) <= Bar a
6+
7+class (Bar a) <= Foo a
8+
9+instance barString :: Bar String
10+
11+instance fooString :: Foo String
examples/failing/Superclasses3.pursnew file+7
@@ -0,0 +1,7 @@
1+module UnknownSuperclassTypeVar where
2+
3+import Prelude
4+
5+class Foo a
6+
7+class (Foo b) <= Bar a
examples/failing/Superclasses4.pursnew file+14
@@ -0,0 +1,14 @@
1+module OverlappingInstances where
2+
3+import Prelude
4+
5+class Foo a
6+
7+instance foo1 :: Foo Number
8+
9+instance foo2 :: Foo Number
10+
11+test :: forall a. (Foo a) => a -> a
12+test a = a
13+
14+test1 = test 0
examples/failing/TopLevelCaseNoArgs.pursnew file+7
@@ -0,0 +1,7 @@
1+module Main where
2+
3+import Prelude
4+
5+foo :: Number
6+foo = 1
7+foo = 2
examples/failing/TypeClassInstances.pursnew file+10
@@ -0,0 +1,10 @@
1+module Main where
2+
3+import Prelude
4+
5+class A a where
6+ a :: a -> String
7+ b :: a -> Number
8+
9+instance aString :: A String where
10+ a s = s
examples/failing/TypeClasses2.pursnew file+8
@@ -0,0 +1,8 @@
1+module Main where
2+
3+import Prelude ()
4+
5+class Show a where
6+ show :: a -> String
7+
8+test = show "testing"
examples/failing/TypeError.pursnew file+5
@@ -0,0 +1,5 @@
1+module Main where
2+
3+import Prelude
4+
5+test = 1 ++ "A"
examples/failing/TypeSynonyms.pursnew file+7
@@ -0,0 +1,7 @@
1+module Main where
2+
3+import Prelude
4+
5+type T1 = Array T2
6+
7+type T2 = T1
examples/failing/TypeSynonyms2.pursnew file+11
@@ -0,0 +1,11 @@
1+module Main where
2+
3+import Prelude
4+
5+class Foo a where
6+ foo :: a -> String
7+
8+type Bar = String
9+
10+instance fooBar :: Foo Bar where
11+ foo s = s
examples/failing/TypeSynonyms3.pursnew file+11
@@ -0,0 +1,11 @@
1+module Main where
2+
3+import Prelude
4+
5+class Foo a where
6+ foo :: a -> String
7+
8+type Bar = String
9+
10+instance fooBar :: Foo Bar where
11+ foo s = s
examples/failing/TypeSynonyms4.pursnew file+10
@@ -0,0 +1,10 @@
1+module TypeSynonyms4 where
2+
3+import Prelude
4+
5+type F x y = x -> y
6+
7+type G x = F x
8+
9+f :: G String String -> String
10+f k = k "Done"
examples/failing/TypeSynonyms5.pursnew file+5
@@ -0,0 +1,5 @@
1+module Main where
2+
3+import Prelude
4+
5+type T = T
examples/failing/TypeWildcards1.pursnew file+6
@@ -0,0 +1,6 @@
1+module TypeWildcards where
2+
3+import Prelude
4+
5+type Test = _
6+
examples/failing/TypeWildcards2.pursnew file+6
@@ -0,0 +1,6 @@
1+module TypeWildcards where
2+
3+import Prelude
4+
5+data Test = Test _
6+
examples/failing/TypeWildcards3.pursnew file+9
@@ -0,0 +1,9 @@
1+module TypeWildcards where
2+
3+import Prelude
4+
5+data Foo a = Foo
6+
7+instance showFoo :: Show (Foo _) where
8+ show Foo = "Foo"
9+
examples/failing/UnderscoreModuleName.pursnew file+5
@@ -0,0 +1,5 @@
1+module Bad_Module where
2+
3+import Prelude
4+
5+main = Debug.Trace.trace "Done"
examples/failing/UnifyInTypeInstanceLookup.pursnew file+19
@@ -0,0 +1,19 @@
1+module Main where
2+
3+import Prelude
4+
5+data Z = Z
6+data S n = S n
7+
8+data T
9+data F
10+
11+class EQ x y b
12+instance eqT :: EQ x x T
13+instance eqF :: EQ x y F
14+
15+foreign import test :: forall a b. (EQ a b T) => a -> b -> a
16+
17+foreign import anyNat :: forall a. a
18+
19+test1 = test anyNat (S Z)
examples/failing/UnknownType.pursnew file+6
@@ -0,0 +1,6 @@
1+module Main where
2+
3+import Prelude
4+
5+test :: Number -> Something
6+test = {}
examples/manual/QualifiedNames.pursnew file+13
@@ -0,0 +1,13 @@
1+module Data.Either where
2+
3+import Prelude
4+
5+data Either a b = Left a | Right b
6+
7+module Main where
8+
9+either :: forall a b c. (a -> c) -> (b -> c) -> Data.Either.Either a b -> c
10+either f _ (Data.Either.Left x) = f x
11+either _ g (Data.Either.Right y) = g y
12+
13+main = Debug.Trace.trace (either id id (Data.Either.Left "Done"))
examples/manual/failing/ArgLengthMismatch.pursnew file+6
@@ -0,0 +1,6 @@
1+module ArgLengthMismatch where
2+
3+import Prelude
4+
5+f x y = true
6+f = false
examples/manual/failing/ExportExplicit.pursnew file+7
@@ -0,0 +1,7 @@
1+-- should fail as z does not exist in the module
2+module M1 (x, y, z) where
3+
4+import Prelude
5+
6+x = 1
7+y = 2
examples/manual/failing/ExportExplicit1.pursnew file+14
@@ -0,0 +1,14 @@
1+module M1 (X(X)) where
2+
3+ data X = X | Y
4+
5+module Main where
6+
7+ import M1
8+
9+ testX = X
10+
11+ -- should fail as Y constructor is not exported from M1
12+ testY = Y
13+
14+ main = Debug.Trace.trace "Done"
examples/manual/failing/ExportExplicit2.pursnew file+7
@@ -0,0 +1,7 @@
1+-- should fail as Y is not a data constructor for X
2+module M1 (X(Y)) where
3+
4+import Prelude
5+
6+data X = X
7+data Y = Y
examples/manual/failing/ExportExplicit3.pursnew file+13
@@ -0,0 +1,13 @@
1+module M1 (X(..)) where
2+
3+ data X = X | Y
4+ data Z = Z
5+
6+module Main where
7+
8+ import M1
9+
10+ -- should fail as Z is not exported from M1
11+ testZ = M1.Z
12+
13+ main = Debug.Trace.trace "Done"
examples/manual/failing/ImportExplicit.pursnew file+7
@@ -0,0 +1,7 @@
1+module M1 where
2+
3+ foo = "foo"
4+
5+module Main where
6+
7+ import M1 (X(..))
examples/manual/failing/ImportExplicit2.pursnew file+7
@@ -0,0 +1,7 @@
1+module M1 where
2+
3+ data X = Y
4+
5+module Main where
6+
7+ import M1 (X(Z, Q))
examples/manual/failing/ImportModule.pursnew file+7
@@ -0,0 +1,7 @@
1+module M2 where
2+
3+ data X = X
4+
5+module Main where
6+
7+ import M1
examples/manual/failing/OrphanTypeDecl.pursnew file+3
@@ -0,0 +1,3 @@
1+module OrphanTypeDecl where
2+
3+fn :: Number -> Boolean
examples/manual/failing/RedefinedFixity.pursnew file+8
@@ -0,0 +1,8 @@
1+module RedefinedFixity where
2+
3+import Prelude
4+
5+(!?) x y = x + y
6+
7+infix 2 !?
8+infix 2 !?
examples/manual/failing/RequiredHiddenType.pursnew file+8
@@ -0,0 +1,8 @@
1+-- exporting `a` should fail as `A` is hidden
2+module Foo (B(..), a, b) where
3+
4+data A = A
5+data B = B
6+
7+a = A
8+b = B
examples/manual/passing/ExportExplicit.pursnew file+20
@@ -0,0 +1,20 @@
1+module M1 (X(X), Z(..), foo) where
2+
3+ data X = X | Y
4+ data Z = Z
5+
6+ foo :: Number
7+ foo = 0
8+
9+ bar :: Number
10+ bar = 1
11+
12+module Main where
13+
14+ import M1
15+
16+ testX = X
17+ testZ = Z
18+ testFoo = foo
19+
20+ main = Debug.Trace.trace "Done"
examples/manual/passing/ExportExplicit2.pursnew file+15
@@ -0,0 +1,15 @@
1+module M1 (bar) where
2+
3+ foo :: Number
4+ foo = 0
5+
6+ bar :: Number
7+ bar = foo
8+
9+module Main where
10+
11+ import M1
12+
13+ testBar = bar
14+
15+ main = Debug.Trace.trace "Done"
examples/manual/passing/ExportedInstanceDeclarations.pursnew file+43
@@ -0,0 +1,43 @@
1+
2+-- Tests that instances for non-exported classes / types do not appear in the
3+-- result of `exportedDeclarations`.
4+
5+module ExportedInstanceDeclarations
6+ ( Const(..)
7+ , Foo
8+ , foo
9+ ) where
10+
11+import Prelude
12+
13+data Const a b = Const a
14+
15+class Foo a where
16+ foo :: a
17+
18+data NonexportedType = NonexportedType
19+
20+class NonexportedClass a where
21+ notExported :: a
22+
23+-- There are three places that a nonexported type or type class can occur,
24+-- leading an instance to count as non-exported:
25+-- * Constraints
26+-- * The type class itself
27+-- * The instance types
28+
29+-- Case 1: constraints
30+instance nonExportedFoo :: (NonexportedClass a) => Foo a where
31+ foo = notExported
32+
33+-- Another instance of case 1:
34+instance nonExportedFoo2 :: (Foo NonexportedType) => Foo (a -> a) where
35+ foo = id
36+
37+-- Case 2: type class
38+instance nonExportedNonexportedType :: NonexportedClass (Const Number a) where
39+ notExported = Const 0
40+
41+-- Case 3: instance types
42+instance constFoo :: Foo (Const NonexportedType b) where
43+ foo = Const NonexportedType
examples/manual/passing/Import.pursnew file+19
@@ -0,0 +1,19 @@
1+module M1 where
2+
3+ import Prelude ()
4+
5+ id :: forall a. a -> a
6+ id = \x -> x
7+
8+ foo = id
9+
10+module M2 where
11+
12+ import Prelude ()
13+ import M1
14+
15+ main = \_ -> foo 42
16+
17+module Main where
18+
19+main = Debug.Trace.trace "Done"
examples/manual/passing/ImportExplicit.pursnew file+14
@@ -0,0 +1,14 @@
1+module M1 where
2+
3+ data X = X | Y
4+ data Z = Z
5+
6+module Main where
7+
8+ import M1 (X(..))
9+
10+ testX :: X
11+ testX = X
12+ testY = Y
13+
14+ main = Debug.Trace.trace "Done"
examples/manual/passing/ImportQualified.pursnew file+12
@@ -0,0 +1,12 @@
1+module M1 where
2+
3+ trace x = x
4+
5+module Main where
6+
7+ import Prelude
8+ import Control.Monad.Eff
9+ import M1
10+ import qualified Debug.Trace as T
11+
12+ main = T.trace (trace "Done")
examples/manual/passing/Module.pursnew file+28
@@ -0,0 +1,28 @@
1+module M1 where
2+
3+ import Prelude
4+
5+ data Foo = Foo String
6+
7+ foo :: M1.Foo -> String
8+ foo = \f -> case f of Foo s -> s ++ "foo"
9+
10+ bar :: Foo -> String
11+ bar = foo
12+
13+ incr :: Number -> Number
14+ incr x = x + 1
15+
16+module M2 where
17+
18+ import Prelude
19+
20+ baz :: M1.Foo -> String
21+ baz = M1.foo
22+
23+ match :: M1.Foo -> String
24+ match = \f -> case f of M1.Foo s -> s ++ "foo"
25+
26+module Main where
27+
28+main = Debug.Trace.trace "Done"
examples/manual/passing/ModuleDeps.pursnew file+17
@@ -0,0 +1,17 @@
1+module M1 where
2+
3+import M2
4+
5+foo = M3.baz
6+
7+module M2 where
8+
9+bar = M3.baz
10+
11+module M3 where
12+
13+baz = 1
14+
15+module Main where
16+
17+main = Debug.Trace.trace "Done"
examples/manual/passing/RedefinedFixity.pursnew file+24
@@ -0,0 +1,24 @@
1+module M1 where
2+
3+import Prelude ()
4+
5+($) f a = f a
6+
7+infixr 1000 $
8+
9+module M2 where
10+
11+import Prelude ()
12+
13+import M1
14+
15+module M3 where
16+
17+import Prelude ()
18+
19+import M1
20+import M2
21+
22+module Main where
23+
24+main = Debug.Trace.trace "Done"
examples/manual/passing/ShadowedName.pursnew file+10
@@ -0,0 +1,10 @@
1+module Main where
2+
3+import Prelude
4+import Debug.Trace
5+
6+done :: String
7+done = let str = "Not yet done" in
8+ let str = "Done" in str
9+
10+main = Debug.Trace.trace done
examples/manual/passing/TransitiveImport.pursnew file+24
@@ -0,0 +1,24 @@
1+module Test where
2+
3+ import Prelude
4+
5+ class TestCls a where
6+ test :: a -> a
7+
8+ instance unitTestCls :: TestCls Unit where
9+ test _ = unit
10+
11+module Middle where
12+
13+ middle = Test.test
14+
15+module Main where
16+
17+ import Prelude
18+ import Middle
19+ import Debug.Trace
20+
21+ main = do
22+ print (middle unit)
23+ trace "Done"
24+ return unit
examples/manual/passing/WildcardType.pursnew file+13
@@ -0,0 +1,13 @@
1+module Main where
2+
3+import Prelude
4+import Debug.Trace
5+
6+f1 :: (_ -> _) -> _
7+f1 g = g 1
8+
9+f2 :: _ -> _
10+f2 _ = "Done"
11+
12+main = Debug.Trace.trace $ f1 f2
13+
examples/passing/652.pursnew file+17
@@ -0,0 +1,17 @@
1+module Main where
2+
3+import Prelude
4+
5+class Foo a b
6+
7+class Bar a c
8+
9+class (Foo a b, Bar a c) <= Baz a b c
10+
11+instance foo :: Foo (a -> b) a
12+
13+instance bar :: Bar (a -> b) b
14+
15+instance baz :: (Eq a) => Baz (a -> b) a b
16+
17+main = Debug.Trace.trace "Done"
examples/passing/810.pursnew file+13
@@ -0,0 +1,13 @@
1+module Main where
2+
3+import Prelude
4+
5+data Maybe a = Nothing | Just a
6+
7+test :: forall a. Maybe a -> Maybe a
8+test m = o.x
9+ where
10+ o = case m of Nothing -> { x : Nothing }
11+ Just a -> { x : Just a }
12+
13+main = Debug.Trace.trace "Done"
examples/passing/Applicative.pursnew file+16
@@ -0,0 +1,16 @@
1+module Main where
2+
3+import Prelude ()
4+
5+class Applicative f where
6+ pure :: forall a. a -> f a
7+ (<*>) :: forall a b. f (a -> b) -> f a -> f b
8+
9+data Maybe a = Nothing | Just a
10+
11+instance applicativeMaybe :: Applicative Maybe where
12+ pure = Just
13+ (<*>) (Just f) (Just a) = Just (f a)
14+ (<*>) _ _ = Nothing
15+
16+main = Debug.Trace.trace "Done"
examples/passing/ArrayType.pursnew file+11
@@ -0,0 +1,11 @@
1+module Main where
2+
3+import Prelude
4+
5+class Pointed p where
6+ point :: forall a. a -> p a
7+
8+instance pointedArray :: Pointed Array where
9+ point a = [a]
10+
11+main = Debug.Trace.trace "Done"
examples/passing/Auto.pursnew file+15
@@ -0,0 +1,15 @@
1+module Main where
2+
3+import Prelude
4+
5+data Auto s i o = Auto { state :: s, step :: s -> i -> o }
6+
7+type SomeAuto i o = forall r. (forall s. Auto s i o -> r) -> r
8+
9+exists :: forall s i o. s -> (s -> i -> o) -> SomeAuto i o
10+exists = \state step f -> f (Auto { state: state, step: step })
11+
12+run :: forall i o. SomeAuto i o -> i -> o
13+run = \s i -> s (\a -> case a of Auto a -> a.step a.state i)
14+
15+main = Debug.Trace.trace "Done"
examples/passing/AutoPrelude.pursnew file+9
@@ -0,0 +1,9 @@
1+module Main where
2+
3+import Prelude
4+import Debug.Trace
5+
6+f x = x * 10.0
7+g y = y - 10.0
8+
9+main = trace $ show $ (f <<< g) 100.0
examples/passing/AutoPrelude2.pursnew file+10
@@ -0,0 +1,10 @@
1+module Main where
2+
3+import Prelude
4+import qualified Prelude as P
5+import Debug.Trace
6+
7+f :: forall a. a -> a
8+f = P.id
9+
10+main = P.($) trace ((f P.<<< f) "Done")
examples/passing/BindersInFunctions.pursnew file+12
@@ -0,0 +1,12 @@
1+module Main where
2+
3+import Prelude
4+import Assert
5+
6+snd = \[_, y] -> y
7+
8+main =
9+ let ts = snd [1.0, 2.0] in
10+ if ts == 2.0
11+ then Debug.Trace.trace "Done"
12+ else error "Incorrect result from 'snd'."
examples/passing/BindingGroups.pursnew file+10
@@ -0,0 +1,10 @@
1+module Main where
2+
3+import Prelude
4+
5+foo = bar
6+ where bar r = r + 1.0
7+
8+r = foo 2.0
9+
10+main = Debug.Trace.trace "Done"
examples/passing/BlockString.pursnew file+8
@@ -0,0 +1,8 @@
1+module Main where
2+
3+import Prelude
4+
5+foo :: String
6+foo = """foo"""
7+
8+main = Debug.Trace.trace "Done"
examples/passing/CaseInDo.pursnew file+19
@@ -0,0 +1,19 @@
1+module Main where
2+
3+import Prelude
4+import Debug.Trace
5+import Control.Monad.Eff
6+
7+doIt :: forall eff. Eff eff Boolean
8+doIt = return true
9+
10+set = do
11+ trace "Testing..."
12+ case 0 of
13+ 0 -> doIt
14+ _ -> return false
15+
16+main = do
17+ b <- set
18+ case b of
19+ true -> trace "Done"
examples/passing/CaseStatement.pursnew file+21
@@ -0,0 +1,21 @@
1+module Main where
2+
3+import Prelude
4+
5+data A = A | B | C
6+
7+f a _ A = a
8+f _ a B = a
9+f _ _ C = "Done"
10+
11+g a _ A = a
12+g _ b B = b
13+g _ _ C = C
14+
15+data M a = N | J a
16+
17+h f N a = a
18+h f a N = a
19+h f (J a) (J b) = J (f a b)
20+
21+main = Debug.Trace.trace $ f "Done" "Failed" A
examples/passing/CheckFunction.pursnew file+7
@@ -0,0 +1,7 @@
1+module Main where
2+
3+import Prelude
4+
5+test = ((\x -> x+1.0) >>> (\x -> x*2.0)) 4.0
6+
7+main = Debug.Trace.trace "Done"
examples/passing/CheckSynonymBug.pursnew file+9
@@ -0,0 +1,9 @@
1+module Main where
2+
3+import Prelude
4+
5+type Foo a = Array a
6+
7+foo _ = length ([] :: Foo Number)
8+
9+main = Debug.Trace.trace "Done"
examples/passing/CheckTypeClass.pursnew file+18
@@ -0,0 +1,18 @@
1+module Main where
2+
3+import Prelude
4+
5+data Bar a = Bar
6+data Baz
7+
8+class Foo a where
9+ foo :: Bar a -> Baz
10+
11+foo_ :: forall a. (Foo a) => a -> Baz
12+foo_ x = foo ((mkBar :: forall a. (Foo a) => a -> Bar a) x)
13+
14+mkBar :: forall a. a -> Bar a
15+mkBar _ = Bar
16+
17+main = Debug.Trace.trace "Done"
18+
examples/passing/Church.pursnew file+18
@@ -0,0 +1,18 @@
1+module Main where
2+
3+import Prelude ()
4+
5+type List a = forall r. r -> (a -> r -> r) -> r
6+
7+empty :: forall a. List a
8+empty = \r f -> r
9+
10+cons :: forall a. a -> List a -> List a
11+cons = \a l r f -> f a (l r f)
12+
13+append :: forall a. List a -> List a -> List a
14+append = \l1 l2 r f -> l2 (l1 r f) f
15+
16+test = append (cons 1 empty) (cons 2 empty)
17+
18+main = Debug.Trace.trace "Done"
examples/passing/Collatz.pursnew file+18
@@ -0,0 +1,18 @@
1+module Main where
2+
3+import Prelude
4+import Control.Monad.Eff
5+import Control.Monad.ST
6+
7+collatz :: Number -> Number
8+collatz n = runPure (runST (do
9+ r <- newSTRef n
10+ count <- newSTRef 0.0
11+ untilE $ do
12+ modifySTRef count $ (+) 1.0
13+ m <- readSTRef r
14+ writeSTRef r $ if m % 2.0 == 0.0 then m / 2.0 else 3.0 * m + 1.0
15+ return $ m == 1.0
16+ readSTRef count))
17+
18+main = Debug.Trace.print $ collatz 1000.0
examples/passing/Comparisons.pursnew file+15
@@ -0,0 +1,15 @@
1+module Main where
2+
3+import Prelude
4+import Control.Monad.Eff
5+import Debug.Trace
6+import Assert
7+
8+main = do
9+ assert (1.0 < 2.0)
10+ assert (2.0 == 2.0)
11+ assert (3.0 > 1.0)
12+ assert ("a" < "b")
13+ assert ("a" == "a")
14+ assert ("z" > "a")
15+ trace "Done!"
examples/passing/Conditional.pursnew file+9
@@ -0,0 +1,9 @@
1+module Main where
2+
3+import Prelude ()
4+
5+fns = \f -> if f true then f else \x -> x
6+
7+not = \x -> if x then false else true
8+
9+main = Debug.Trace.trace "Done"
examples/passing/Console.pursnew file+13
@@ -0,0 +1,13 @@
1+module Main where
2+
3+import Prelude
4+import Control.Monad.Eff
5+import Debug.Trace
6+
7+replicateM_ :: forall m a. (Monad m) => Number -> m a -> m {}
8+replicateM_ 0.0 _ = return {}
9+replicateM_ n act = do
10+ act
11+ replicateM_ (n - 1.0) act
12+
13+main = replicateM_ 10.0 (trace "Hello World!")
examples/passing/DataAndType.pursnew file+9
@@ -0,0 +1,9 @@
1+module Main where
2+
3+import Prelude
4+
5+data A = A B
6+
7+type B = A
8+
9+main = Debug.Trace.trace "Done"
examples/passing/DeepArrayBinder.pursnew file+15
@@ -0,0 +1,15 @@
1+module Main where
2+
3+import Prelude
4+import Control.Monad.Eff
5+import Assert
6+
7+data List a = Cons a (List a) | Nil
8+
9+match2 :: List Number -> Number
10+match2 (Cons x (Cons y xs)) = x * y + match2 xs
11+match2 _ = 0.0
12+
13+main = case match2 (Cons 1.0 (Cons 2.0 (Cons 3.0 (Cons 4.0 (Cons 5.0 (Cons 6.0 (Cons 7.0 (Cons 8.0 (Cons 9.0 Nil))))))))) of
14+ 100.0 -> Debug.Trace.trace "Done"
15+ _ -> error "Incorrect result!"
examples/passing/DeepCase.pursnew file+15
@@ -0,0 +1,15 @@
1+module Main where
2+
3+import Prelude
4+import Debug.Trace
5+import Control.Monad.Eff
6+import Control.Monad.ST
7+
8+f x y =
9+ let
10+ g = case y of
11+ 0.0 -> x
12+ x -> 1.0 + x * x
13+ in g + x + y
14+
15+main = print $ f 1.0 10.0
examples/passing/Do.pursnew file+67
@@ -0,0 +1,67 @@
1+module Main where
2+
3+import Prelude
4+
5+data Maybe a = Nothing | Just a
6+
7+instance functorMaybe :: Functor Maybe where
8+ (<$>) f Nothing = Nothing
9+ (<$>) f (Just x) = Just (f x)
10+
11+instance applyMaybe :: Apply Maybe where
12+ (<*>) (Just f) (Just x) = Just (f x)
13+ (<*>) _ _ = Nothing
14+
15+instance applicativeMaybe :: Applicative Maybe where
16+ pure = Just
17+
18+instance bindMaybe :: Bind Maybe where
19+ bind Nothing _ = Nothing
20+ bind (Just a) f = f a
21+
22+instance monadMaybe :: Prelude.Monad Maybe
23+
24+test1 = \_ -> do
25+ Just "abc"
26+
27+test2 = \_ -> do
28+ x <- Just 1.0
29+ y <- Just 2.0
30+ Just (x + y)
31+
32+test3 = \_ -> do
33+ Just 1.0
34+ Nothing :: Maybe Number
35+ Just 2.0
36+
37+test4 mx my = do
38+ x <- mx
39+ y <- my
40+ Just (x + y + 1.0)
41+
42+test5 mx my mz = do
43+ x <- mx
44+ y <- my
45+ let sum = x + y
46+ z <- mz
47+ Just (z + sum + 1.0)
48+
49+test6 mx = \_ -> do
50+ let
51+ f :: forall a. Maybe a -> a
52+ f (Just x) = x
53+ Just (f mx)
54+
55+test8 = \_ -> do
56+ Just (do
57+ Just 1.0)
58+
59+test9 = \_ -> (+) <$> Just 1.0 <*> Just 2.0
60+
61+test10 _ = do
62+ let
63+ f x = g x * 3.0
64+ g x = f x / 2.0
65+ Just (f 10.0)
66+
67+main = Debug.Trace.trace "Done"
examples/passing/Dollar.pursnew file+16
@@ -0,0 +1,16 @@
1+module Main where
2+
3+import Prelude ()
4+
5+($) :: forall a b. (a -> b) -> a -> b
6+($) f x = f x
7+
8+infixr 1000 $
9+
10+id x = x
11+
12+test1 x = id $ id $ id $ id $ x
13+
14+test2 x = id id $ id x
15+
16+main = Debug.Trace.trace "Done"
examples/passing/Eff.pursnew file+25
@@ -0,0 +1,25 @@
1+module Main where
2+
3+import Prelude
4+import Control.Monad.Eff
5+import Control.Monad.ST
6+import Debug.Trace
7+
8+test1 = do
9+ trace "Line 1"
10+ trace "Line 2"
11+
12+test2 = runPure (runST (do
13+ ref <- newSTRef 0.0
14+ modifySTRef ref $ \n -> n + 1.0
15+ readSTRef ref))
16+
17+test3 = pureST (do
18+ ref <- newSTRef 0.0
19+ modifySTRef ref $ \n -> n + 1.0
20+ readSTRef ref)
21+
22+main = do
23+ test1
24+ Debug.Trace.print test2
25+ Debug.Trace.print test3
examples/passing/EmptyDataDecls.pursnew file+19
@@ -0,0 +1,19 @@
1+module Main where
2+
3+import Prelude
4+import Assert
5+
6+data Z
7+data S n
8+
9+data ArrayBox n a = ArrayBox (Array a)
10+
11+nil :: forall a. ArrayBox Z a
12+nil = ArrayBox []
13+
14+cons' :: forall a n. a -> ArrayBox n a -> ArrayBox (S n) a
15+cons' x (ArrayBox xs) = ArrayBox $ concat [x] xs
16+
17+main = case cons' 1 $ cons' 2 $ cons' 3 nil of
18+ ArrayBox [1, 2, 3] -> Debug.Trace.trace "Done"
19+ _ -> error "Failed"
examples/passing/EmptyRow.pursnew file+10
@@ -0,0 +1,10 @@
1+module Main where
2+
3+import Prelude
4+
5+data Foo r = Foo { | r }
6+
7+test :: Foo ()
8+test = Foo {}
9+
10+main = Debug.Trace.trace "Done"
examples/passing/EmptyTypeClass.pursnew file+12
@@ -0,0 +1,12 @@
1+module Main where
2+
3+import Prelude
4+
5+class Partial
6+
7+head :: forall a. (Partial) => Array a -> a
8+head [x] = x
9+
10+instance allowPartials :: Partial
11+
12+main = Debug.Trace.trace $ head ["Done"]
examples/passing/EqOrd.pursnew file+16
@@ -0,0 +1,16 @@
1+module Main where
2+
3+import Prelude
4+
5+data Pair a b = Pair a b
6+
7+instance ordPair :: (Ord a, Ord b) => Ord (Pair a b) where
8+ compare (Pair a1 b1) (Pair a2 b2) = case compare a1 a2 of
9+ EQ -> compare b1 b2
10+ r -> r
11+
12+instance eqPair :: (Eq a, Eq b) => Eq (Pair a b) where
13+ (==) (Pair a1 b1) (Pair a2 b2) = a1 == a2 && b1 == b2
14+ (/=) (Pair a1 b1) (Pair a2 b2) = a1 /= a2 || b1 /= b2
15+
16+main = Debug.Trace.print $ Pair 1.0 2.0 == Pair 1.0 2.0
examples/passing/ExtendedInfixOperators.pursnew file+14
@@ -0,0 +1,14 @@
1+module Main where
2+
3+import Prelude
4+
5+comparing :: forall a b. (Ord b) => (a -> b) -> a -> a -> Ordering
6+comparing f = compare `Data.Function.on` f
7+
8+null [] = true
9+null _ = false
10+
11+test = [1.0, 2.0, 3.0] `comparing null` [4.0, 5.0, 6.0]
12+
13+main = do
14+ Debug.Trace.print test
examples/passing/Fib.pursnew file+15
@@ -0,0 +1,15 @@
1+module Main where
2+
3+import Prelude
4+import Control.Monad.Eff
5+import Control.Monad.ST
6+
7+main = runST (do
8+ n1 <- newSTRef 1.0
9+ n2 <- newSTRef 1.0
10+ whileE ((>) 1000.0 <$> readSTRef n1) $ do
11+ n1' <- readSTRef n1
12+ n2' <- readSTRef n2
13+ writeSTRef n2 $ n1' + n2'
14+ writeSTRef n1 n2'
15+ Debug.Trace.print n2')
examples/passing/FinalTagless.pursnew file+22
@@ -0,0 +1,22 @@
1+module Main where
2+
3+import Prelude
4+
5+class E e where
6+ num :: Number -> e Number
7+ add :: e Number -> e Number -> e Number
8+
9+type Expr a = forall e. (E e) => e a
10+
11+data Id a = Id a
12+
13+instance exprId :: E Id where
14+ num = Id
15+ add (Id n) (Id m) = Id (n + m)
16+
17+runId (Id a) = a
18+
19+three :: Expr Number
20+three = add (num 1.0) (num 2.0)
21+
22+main = Debug.Trace.print $ runId three
examples/passing/FunctionScope.pursnew file+13
@@ -0,0 +1,13 @@
1+module Main where
2+
3+import Prelude
4+import Assert
5+
6+mkValue :: Number -> Number
7+mkValue id = id
8+
9+main = do
10+ let value = mkValue 1.0
11+ if value == 1.0
12+ then Debug.Trace.trace "Done"
13+ else error "Not done"
examples/passing/Functions.pursnew file+15
@@ -0,0 +1,15 @@
1+module Main where
2+
3+import Prelude
4+
5+test1 = \_ -> 0.0
6+
7+test2 = \a b -> a + b + 1.0
8+
9+test3 = \a -> a
10+
11+test4 = \(%%) -> 1.0 %% 2.0
12+
13+test5 = \(+++) (***) -> 1.0 +++ 2.0 *** 3.0
14+
15+main = Debug.Trace.trace "Done"
examples/passing/Functions2.pursnew file+13
@@ -0,0 +1,13 @@
1+module Main where
2+
3+import Prelude
4+import Assert
5+
6+test :: forall a b. a -> b -> a
7+test = \const _ -> const
8+
9+main = do
10+ let value = test "Done" {}
11+ if value == "Done"
12+ then Debug.Trace.trace "Done"
13+ else error "Not done"
examples/passing/Guards.pursnew file+29
@@ -0,0 +1,29 @@
1+module Main where
2+
3+import Prelude
4+
5+collatz = \x -> case x of
6+ y | y % 2.0 == 0.0 -> y / 2.0
7+ y -> y * 3.0 + 1.0
8+
9+-- Guards have access to current scope
10+collatz2 = \x y -> case x of
11+ z | y > 0.0 -> z / 2.0
12+ z -> z * 3.0 + 1.0
13+
14+min :: forall a. (Ord a) => a -> a -> a
15+min n m | n < m = n
16+ | otherwise = m
17+
18+max :: forall a. (Ord a) => a -> a -> a
19+max n m = case unit of
20+ _ | m < n -> n
21+ | otherwise -> m
22+
23+testIndentation :: Number -> Number -> Number
24+testIndentation x y | x > 0.0
25+ = x + y
26+ | otherwise
27+ = y - x
28+
29+main = Debug.Trace.trace $ min "Done" "ZZZZ"
examples/passing/HoistError.pursnew file+12
@@ -0,0 +1,12 @@
1+module Main where
2+
3+import Prelude
4+import Control.Monad.Eff
5+import Debug.Trace
6+import Assert
7+
8+main = do
9+ let x = 0.0
10+ assert $ x == 0.0
11+ let x = 1.0 + 1.0
12+ trace "Done"
examples/passing/IfThenElseMaybe.pursnew file+11
@@ -0,0 +1,11 @@
1+module Main where
2+
3+import Prelude
4+
5+data Maybe a = Nothing | Just a
6+
7+test1 = if true then Just 10 else Nothing
8+
9+test2 = if true then Nothing else Just 10
10+
11+main = Debug.Trace.trace "Done"
examples/passing/ImplicitEmptyImport.pursnew file+8
@@ -0,0 +1,8 @@
1+module Main where
2+
3+import Prelude
4+
5+main = do
6+ Debug.Trace.trace "Hello"
7+ Debug.Trace.trace "Goodbye"
8+ Debug.Trace.trace "Done"
examples/passing/ImportHiding.pursnew file+18
@@ -0,0 +1,18 @@
1+module Main where
2+
3+import Debug.Trace
4+import Prelude hiding (
5+ show, -- a value
6+ Show, -- a type class
7+ Unit(..) -- a constructor
8+ )
9+
10+show = 1.0
11+
12+class Show a where
13+ noshow :: a -> a
14+
15+data Unit = X | Y
16+
17+main = do
18+ print show
examples/passing/InferRecFunWithConstrainedArgument.pursnew file+8
@@ -0,0 +1,8 @@
1+module Main where
2+
3+import Prelude
4+
5+test 100.0 = 100.0
6+test n = test(1.0 + n)
7+
8+main = Debug.Trace.print $ test 0.0
examples/passing/InstanceBeforeClass.pursnew file+11
@@ -0,0 +1,11 @@
1+module Main where
2+
3+import Prelude
4+
5+instance fooNumber :: Foo Number where
6+ foo = 0.0
7+
8+class Foo a where
9+ foo :: a
10+
11+main = Debug.Trace.trace "Done"
examples/passing/IntAndChar.pursnew file+18
@@ -0,0 +1,18 @@
1+module Main where
2+
3+import Prelude
4+import Control.Monad.Eff
5+import Assert
6+
7+f 1 = 1
8+f _ = 0
9+
10+g 'a' = 'a'
11+g _ = 'b'
12+
13+main = do
14+ assert $ f 1 == 1
15+ assert $ f 0 == 0
16+ assert $ g 'a' == 'a'
17+ assert $ g 'b' == 'b'
18+ Debug.Trace.trace "Done"
examples/passing/JSReserved.pursnew file+12
@@ -0,0 +1,12 @@
1+module Main where
2+
3+import Prelude
4+
5+yield = 0
6+member = 1
7+
8+public = \return -> return
9+
10+this catch = catch
11+
12+main = Debug.Trace.trace "Done"
examples/passing/KindedType.pursnew file+33
@@ -0,0 +1,33 @@
1+module Main where
2+
3+import Prelude
4+
5+type Star2Star f = f :: * -> *
6+
7+type Star t = t :: *
8+
9+test1 :: Star2Star Array String
10+test1 = ["test"]
11+
12+f :: Star (String -> String)
13+f s = s
14+
15+test2 = f "test"
16+
17+data Proxy (f :: * -> *) = Proxy
18+
19+test3 :: Proxy Array
20+test3 = Proxy
21+
22+type Test (f :: * -> *) = f String
23+
24+test4 :: Test Array
25+test4 = ["test"]
26+
27+class Clazz (a :: *) where
28+ def :: a
29+
30+instance clazzString :: Clazz String where
31+ def = "test"
32+
33+main = Debug.Trace.trace "Done"
examples/passing/Let.pursnew file+53
@@ -0,0 +1,53 @@
1+module Main where
2+
3+import Prelude
4+import Control.Monad.Eff
5+import Control.Monad.ST
6+
7+test1 x = let
8+ y :: Number
9+ y = x + 1.0
10+ in y
11+
12+test2 x y =
13+ let x' = x + 1.0 in
14+ let y' = y + 1.0 in
15+ x' + y'
16+
17+test3 = let f x y z = x + y + z in
18+ f 1.0 2.0 3.0
19+
20+test4 = let f x [y, z] = x y z in
21+ f (+) [1.0, 2.0]
22+
23+test5 = let
24+ f x | x > 0.0 = g (x / 2.0) + 1.0
25+ f x = 0.0
26+ g x = f (x - 1.0) + 1.0
27+ in f 10.0
28+
29+test7 = let
30+ f :: forall a. a -> a
31+ f x = x
32+ in if f true then f 1.0 else f 2.0
33+
34+test8 :: Number -> Number
35+test8 x = let
36+ go y | (x - 0.1 < y * y) && (y * y < x + 0.1) = y
37+ go y = go $ (y + x / y) / 2.0
38+ in go x
39+
40+test10 _ =
41+ let
42+ f x = g x * 3.0
43+ g x = f x / 2.0
44+ in f 10.0
45+
46+main = do
47+ Debug.Trace.print (test1 1.0)
48+ Debug.Trace.print (test2 1.0 2.0)
49+ Debug.Trace.print test3
50+ Debug.Trace.print test4
51+ Debug.Trace.print test5
52+ Debug.Trace.print test7
53+ Debug.Trace.print (test8 100.0)
examples/passing/Let2.pursnew file+17
@@ -0,0 +1,17 @@
1+module Main where
2+
3+import Prelude
4+
5+test =
6+ let f :: Number -> Boolean
7+ f 0.0 = false
8+ f n = g (n - 1.0)
9+
10+ g :: Number -> Boolean
11+ g 0.0 = true
12+ g n = f (n - 1.0)
13+
14+ x = f 1.0
15+ in not x
16+
17+main = Debug.Trace.print test
examples/passing/LetInInstance.pursnew file+14
@@ -0,0 +1,14 @@
1+module Main where
2+
3+import Prelude
4+
5+class Foo a where
6+ foo :: a -> String
7+
8+instance fooString :: Foo String where
9+ foo = go
10+ where
11+ go :: String -> String
12+ go s = s
13+
14+main = Debug.Trace.trace "Done"
examples/passing/LiberalTypeSynonyms.pursnew file+21
@@ -0,0 +1,21 @@
1+module Main where
2+
3+import Prelude
4+
5+type Reader = (->) String
6+
7+foo :: Reader String
8+foo s = s
9+
10+type AndFoo r = (foo :: String | r)
11+
12+getFoo :: forall r. Prim.Object (AndFoo r) -> String
13+getFoo o = o.foo
14+
15+type F r = { | r } -> { | r }
16+
17+f :: (forall r. F r) -> String
18+f g = case g { x: "Hello" } of
19+ { x = x } -> x
20+
21+main = Debug.Trace.trace "Done"
examples/passing/MPTCs.pursnew file+20
@@ -0,0 +1,20 @@
1+module Main where
2+
3+import Prelude
4+
5+class NullaryTypeClass where
6+ greeting :: String
7+
8+instance nullaryTypeClass :: NullaryTypeClass where
9+ greeting = "Hello, World!"
10+
11+class Coerce a b where
12+ coerce :: a -> b
13+
14+instance coerceRefl :: Coerce a a where
15+ coerce a = a
16+
17+instance coerceShow :: (Prelude.Show a) => Coerce a String where
18+ coerce = show
19+
20+main = Debug.Trace.trace "Done"
examples/passing/Match.pursnew file+9
@@ -0,0 +1,9 @@
1+module Main where
2+
3+import Prelude
4+
5+data Foo a = Foo
6+
7+foo = \f -> case f of Foo -> "foo"
8+
9+main = Debug.Trace.trace "Done"
examples/passing/Monad.pursnew file+32
@@ -0,0 +1,32 @@
1+module Main where
2+
3+import Prelude ()
4+
5+type Monad m = { return :: forall a. a -> m a
6+ , bind :: forall a b. m a -> (a -> m b) -> m b }
7+
8+data Id a = Id a
9+
10+id :: Monad Id
11+id = { return : Id
12+ , bind : \ma f -> case ma of Id a -> f a }
13+
14+data Maybe a = Nothing | Just a
15+
16+maybe :: Monad Maybe
17+maybe = { return : Just
18+ , bind : \ma f -> case ma of
19+ Nothing -> Nothing
20+ Just a -> f a
21+ }
22+
23+test :: forall m. Monad m -> m Number
24+test = \m -> m.bind (m.return 1.0) (\n1 ->
25+ m.bind (m.return "Test") (\n2 ->
26+ m.return n1))
27+
28+test1 = test id
29+
30+test2 = test maybe
31+
32+main = Debug.Trace.trace "Done"
examples/passing/MonadState.pursnew file+48
@@ -0,0 +1,48 @@
1+module Main where
2+
3+import Prelude
4+
5+data Tuple a b = Tuple a b
6+
7+class MonadState s m where
8+ get :: m s
9+ put :: s -> m {}
10+
11+data State s a = State (s -> Tuple s a)
12+
13+runState s (State f) = f s
14+
15+instance functorState :: Functor (State s) where
16+ (<$>) = liftM1
17+
18+instance applyState :: Apply (State s) where
19+ (<*>) = ap
20+
21+instance applicativeState :: Applicative (State s) where
22+ pure a = State $ \s -> Tuple s a
23+
24+instance bindState :: Bind (State s) where
25+ bind f g = State $ \s -> case runState s f of
26+ Tuple s1 a -> runState s1 (g a)
27+
28+instance monadState :: Monad (State s)
29+
30+instance monadStateState :: MonadState s (State s) where
31+ get = State (\s -> Tuple s s)
32+ put s = State (\_ -> Tuple s {})
33+
34+modify :: forall m s. (Prelude.Monad m, MonadState s m) => (s -> s) -> m {}
35+modify f = do
36+ s <- get
37+ put (f s)
38+
39+test :: Tuple String String
40+test = runState "" $ do
41+ modify $ (++) "World!"
42+ modify $ (++) "Hello, "
43+ get
44+
45+main = do
46+ let t1 = test
47+ Debug.Trace.trace "Done"
48+
examples/passing/MultiArgFunctions.pursnew file+27
@@ -0,0 +1,27 @@
1+module Main where
2+
3+import Prelude
4+import Data.Function
5+import Control.Monad.Eff
6+import Debug.Trace
7+
8+f = mkFn2 $ \a b -> runFn2 g a b + runFn2 g b a
9+
10+g = mkFn2 $ \a b -> case {} of
11+ _ | a <= 0.0 || b <= 0.0 -> b
12+ _ -> runFn2 f (a - 0.0) (b - 0.0)
13+
14+main = do
15+ runFn0 (mkFn0 $ \_ -> trace $ show 0.0)
16+ runFn1 (mkFn1 $ \a -> trace $ show a) 0.0
17+ runFn2 (mkFn2 $ \a b -> trace $ show [a, b]) 0.0 0.0
18+ runFn3 (mkFn3 $ \a b c -> trace $ show [a, b, c]) 0.0 0.0 0.0
19+ runFn4 (mkFn4 $ \a b c d -> trace $ show [a, b, c, d]) 0.0 0.0 0.0 0.0
20+ runFn5 (mkFn5 $ \a b c d e -> trace $ show [a, b, c, d, e]) 0.0 0.0 0.0 0.0 0.0
21+ runFn6 (mkFn6 $ \a b c d e f -> trace $ show [a, b, c, d, e, f]) 0.0 0.0 0.0 0.0 0.0 0.0
22+ runFn7 (mkFn7 $ \a b c d e f g -> trace $ show [a, b, c, d, e, f, g]) 0.0 0.0 0.0 0.0 0.0 0.0 0.0
23+ runFn8 (mkFn8 $ \a b c d e f g h -> trace $ show [a, b, c, d, e, f, g, h]) 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0
24+ runFn9 (mkFn9 $ \a b c d e f g h i -> trace $ show [a, b, c, d, e, f, g, h, i]) 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0
25+ runFn10 (mkFn10 $ \a b c d e f g h i j-> trace $ show [a, b, c, d, e, f, g, h, i, j]) 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0 0.0
26+ print $ runFn2 g 0.0 0.0
27+ trace "Done!"
examples/passing/MutRec.pursnew file+19
@@ -0,0 +1,19 @@
1+module Main where
2+
3+import Prelude
4+
5+f 0.0 = 0.0
6+f x = g x + 0.0
7+
8+g x = f (x / 0.0)
9+
10+data Even = Zero | Even Odd
11+
12+data Odd = Odd Even
13+
14+evenToNumber Zero = 0.0
15+evenToNumber (Even n) = oddToNumber n + 0.0
16+
17+oddToNumber (Odd n) = evenToNumber n + 0.0
18+
19+main = Debug.Trace.trace "Done"
examples/passing/MutRec2.pursnew file+19
@@ -0,0 +1,19 @@
1+module Main where
2+
3+import Prelude
4+
5+data A = A B
6+
7+data B = B A
8+
9+foreign import data S :: *
10+
11+f :: A -> S
12+f a = case a of A b -> g b
13+
14+g b = case b of B a -> f a
15+
16+showN :: A -> S
17+showN a = f a
18+
19+main = Debug.Trace.trace "Done"
examples/passing/MutRec3.pursnew file+19
@@ -0,0 +1,19 @@
1+module Main where
2+
3+import Prelude
4+
5+data A = A B
6+
7+data B = B A
8+
9+foreign import data S :: *
10+
11+f a = case a of A b -> g b
12+
13+g :: B -> S
14+g b = case b of B a -> f a
15+
16+showN :: A -> S
17+showN a = f a
18+
19+main = Debug.Trace.trace "Done"
examples/passing/NamedPatterns.pursnew file+9
@@ -0,0 +1,9 @@
1+module Main where
2+
3+import Prelude
4+
5+foo = \x -> case x of
6+ y@{ foo = "Foo" } -> y
7+ y -> y
8+
9+main = Debug.Trace.trace "Done"
examples/passing/NegativeBinder.pursnew file+9
@@ -0,0 +1,9 @@
1+module Main where
2+
3+import Prelude
4+
5+test :: Number -> Boolean
6+test -1.0 = false
7+test _ = true
8+
9+main = Debug.Trace.trace "Done"
examples/passing/Nested.pursnew file+9
@@ -0,0 +1,9 @@
1+module Main where
2+
3+import Prelude
4+
5+data Extend r a = Extend { prev :: r a, next :: a }
6+
7+data Matrix r a = Square (r (r a)) | Bigger (Matrix (Extend r) a)
8+
9+main = Debug.Trace.trace "Done"
examples/passing/NestedTypeSynonyms.pursnew file+11
@@ -0,0 +1,11 @@
1+module Main where
2+
3+import Prelude
4+
5+type X = String
6+type Y = X -> X
7+
8+fn :: Y
9+fn a = a
10+
11+main = Debug.Trace.print (fn "Done")
examples/passing/NestedWhere.pursnew file+12
@@ -0,0 +1,12 @@
1+module Main where
2+
3+import Prelude
4+
5+f x = g x
6+ where
7+ g x = go x
8+ where
9+ go x = go1 (x - 1.0)
10+ go1 x = go x
11+
12+main = Debug.Trace.trace "Done"
examples/passing/Newtype.pursnew file+23
@@ -0,0 +1,23 @@
1+module Main where
2+
3+import Prelude
4+import Control.Monad.Eff
5+import Debug.Trace
6+
7+newtype Thing = Thing String
8+
9+instance showThing :: Show Thing where
10+ show (Thing x) = "Thing " ++ show x
11+
12+newtype Box a = Box a
13+
14+instance showBox :: (Show a) => Show (Box a) where
15+ show (Box x) = "Box " ++ show x
16+
17+apply f x = f x
18+
19+main = do
20+ print $ Thing "hello"
21+ print $ Box 42.0
22+ print $ apply Box 9000.0
23+ trace "Done"
examples/passing/NewtypeEff.pursnew file+29
@@ -0,0 +1,29 @@
1+module Main where
2+
3+import Prelude
4+import Debug.Trace
5+import Control.Monad.Eff
6+
7+newtype T a = T (Eff (trace :: Trace) a)
8+
9+runT :: forall a. T a -> Eff (trace :: Trace) a
10+runT (T t) = t
11+
12+instance functorT :: Functor T where
13+ (<$>) f (T t) = T (f <$> t)
14+
15+instance applyT :: Apply T where
16+ (<*>) (T f) (T x) = T (f <*> x)
17+
18+instance applicativeT :: Applicative T where
19+ pure t = T (pure t)
20+
21+instance bindT :: Bind T where
22+ bind (T t) f = T (t >>= \x -> runT (f x))
23+
24+instance monadT :: Monad T
25+
26+main = runT do
27+ T $ trace "Done"
28+ T $ trace "Done"
29+ T $ trace "Done"
examples/passing/NewtypeWithRecordUpdate.pursnew file+16
@@ -0,0 +1,16 @@
1+-- https://github.com/purescript/purescript/issues/812.0
2+
3+module Main where
4+
5+import Prelude
6+import Debug.Trace
7+
8+newtype NewType a = NewType (Object a)
9+
10+rec1 :: Object (a :: Number, b :: Number, c:: Number)
11+rec1 = { a: 0.0, b: 0.0, c: 0.0 }
12+
13+rec2 :: NewType (a :: Number, b :: Number, c :: Number)
14+rec2 = NewType (rec1 { a = 1.0 })
15+
16+main = trace "Done"
examples/passing/ObjectGetter.pursnew file+13
@@ -0,0 +1,13 @@
1+module Main where
2+
3+import Prelude
4+
5+getX = _.x
6+
7+point = { x: 1.0, y: 0.0 }
8+
9+main = do
10+ Debug.Trace.print $ getX point
11+ Debug.Trace.trace $ _." 123 string Prop Name " { " 123 string Prop Name ": "OK" }
12+ Debug.Trace.trace $ (_.x >>> _.y) { x: { y: "Nested" } }
13+ Debug.Trace.trace $ _.value { value: "Done!" }
examples/passing/ObjectSynonym.pursnew file+15
@@ -0,0 +1,15 @@
1+module Main where
2+
3+import Prelude
4+
5+type Inner = Number
6+
7+inner :: Inner
8+inner = 0.0
9+
10+type Outer = { inner :: Inner }
11+
12+outer :: Outer
13+outer = { inner: inner }
14+
15+main = Debug.Trace.trace "Done"
examples/passing/ObjectUpdate.pursnew file+20
@@ -0,0 +1,20 @@
1+module Main where
2+
3+import Prelude
4+
5+update1 = \o -> o { foo = "Foo" }
6+
7+update2 :: forall r. { foo :: String | r } -> { foo :: String | r }
8+update2 = \o -> o { foo = "Foo" }
9+
10+replace = \o -> case o of
11+ { foo = "Foo" } -> o { foo = "Bar" }
12+ { foo = "Bar" } -> o { bar = "Baz" }
13+ o -> o
14+
15+polyUpdate :: forall a r. { foo :: a | r } -> { foo :: String | r }
16+polyUpdate = \o -> o { foo = "Foo" }
17+
18+inferPolyUpdate = \o -> o { foo = "Foo" }
19+
20+main = Debug.Trace.trace ((update1 {foo: ""}).foo)
examples/passing/ObjectUpdate2.pursnew file+17
@@ -0,0 +1,17 @@
1+module Main where
2+
3+import Prelude
4+
5+type X r = { | r }
6+
7+x :: X (baz :: String)
8+x = { baz: "baz" }
9+
10+blah :: forall r. X r -> X r
11+blah x = x
12+
13+test = blah x
14+ { baz = "blah"
15+ }
16+
17+main = Debug.Trace.trace "Done"
examples/passing/ObjectUpdater.pursnew file+24
@@ -0,0 +1,24 @@
1+module Main where
2+
3+import Prelude
4+import Control.Monad.Eff
5+import Debug.Trace
6+import Assert
7+
8+getValue :: forall e. Eff (| e) Boolean
9+getValue = return true
10+
11+main = do
12+ let record = { value: false }
13+ record' <- record { value = _ } <$> getValue
14+ assert $ record'.value == true
15+
16+ let point = { x: 1.0, y: 1.0 }
17+ x = 10.0
18+ point' = (point { x = _, y = x }) 100.0
19+
20+ assert $ point'.x == 100.0
21+ assert $ point'.y == 10.0
22+
23+ let record2 = (_ { x = _ }) { x: 0.0 } 10.0
24+ assert $ record2.x == 10.0
examples/passing/ObjectWildcards.pursnew file+20
@@ -0,0 +1,20 @@
1+module Main where
2+
3+import Prelude
4+import Control.Monad.Eff
5+import Debug.Trace
6+import Assert
7+
8+mkRecord = { foo: _, bar: _, baz: "baz" }
9+
10+getValue :: forall e. Eff (| e) Boolean
11+getValue = return true
12+
13+main = do
14+ obj <- { value: _ } <$> getValue
15+ print obj.value
16+ let x = 1.0
17+ point <- { x: _, y: x } <$> return 2.0
18+ assert $ point.x == 2.0
19+ assert $ point.y == 1.0
20+ trace (mkRecord 1.0 "Done!").bar
examples/passing/Objects.pursnew file+35
@@ -0,0 +1,35 @@
1+module Main where
2+
3+import Prelude
4+
5+test = \x -> x.foo + x.bar + 1.0
6+
7+append = \o -> { foo: o.foo, bar: 1.0 }
8+
9+apTest = append({foo : "Foo", baz: "Baz"})
10+
11+f = (\a -> a.b.c) { b: { c: 1.0, d: "Hello" }, e: "World" }
12+
13+g = (\a -> a.f { x: 1.0, y: "y" }) { f: \o -> o.x + 1.0 }
14+
15+typed :: { foo :: Number }
16+typed = { foo: 0.0 }
17+
18+test2 = \x -> x."!@#"
19+
20+test3 = typed."foo"
21+
22+test4 = test2 weirdObj
23+ where
24+ weirdObj :: { "!@#" :: Number }
25+ weirdObj = { "!@#": 1.0 }
26+
27+test5 = case { "***": 1.0 } of
28+ { "***" = n } -> n
29+
30+test6 = case { "***": 1.0 } of
31+ { "***": n } -> n
32+
33+test7 {a: snoog , b : blah } = blah
34+
35+main = Debug.Trace.trace "Done"
examples/passing/OneConstructor.pursnew file+9
@@ -0,0 +1,9 @@
1+module Main where
2+
3+import Prelude
4+
5+data One a = One a
6+
7+one' (One a) = a
8+
9+main = Debug.Trace.trace "Done"
examples/passing/OperatorAssociativity.pursnew file+25
@@ -0,0 +1,25 @@
1+module Main where
2+
3+import Prelude
4+import Control.Monad.Eff
5+import Debug.Trace
6+import Assert
7+
8+bug :: Number -> Number -> Number
9+bug a b = 0.0 - (a - b)
10+
11+main = do
12+ assert (bug 0.0 2.0 == 2.0)
13+ assert (0.0 - (0.0 - 2.0) == 2.0)
14+ assert (0.0 - (0.0 + 2.0) == -2.0)
15+ assert (6.0 / (3.0 * 2.0) == 1.0)
16+ assert ((6.0 / 3.0) * 2.0 == 4.0)
17+ assert (not (1.0 < 0.0) == true)
18+ assert (not ((negate 1.0) < 0.0) == false)
19+ assert (negate (1.0 + 10.0) == -11.0)
20+ assert (2.0 * 3.0 / 4.0 == 1.5)
21+ assert (1.0 * 2.0 * 3.0 * 4.0 * 5.0 / 6.0 == 20.0)
22+ assert (1.0 + 10.0 - 5.0 == 6.0)
23+ assert (1.0 + 10.0 * 5.0 == 51.0)
24+ assert (10.0 * 5.0 - 1.0 == 49.0)
25+ trace "Success!"
examples/passing/OperatorInlining.pursnew file+47
@@ -0,0 +1,47 @@
1+module Main where
2+
3+import Prelude
4+import Debug.Trace
5+
6+main = do
7+
8+ -- semiringNumber
9+ print (1.0 + 2.0)
10+ print (1.0 * 2.0)
11+
12+ -- ringNumber
13+ print (1.0 - 2.0)
14+ print (negate 1.0)
15+
16+ -- moduleSemiringNumber
17+ print (1.0 / 2.0)
18+
19+ -- ordNumber
20+ print (1.0 > 2.0)
21+ print (1.0 < 2.0)
22+ print (1.0 <= 2.0)
23+ print (1.0 >= 2.0)
24+ print (1.0 == 2.0)
25+
26+ -- eqNumber
27+ print (1.0 == 2.0)
28+ print (1.0 /= 2.0)
29+
30+ -- eqString
31+ print ("foo" == "bar")
32+ print ("foo" /= "bar")
33+
34+ -- eqBoolean
35+ print (true == false)
36+ print (true /= false)
37+
38+ -- semigroupString
39+ print ("foo" ++ "bar")
40+ print ("foo" <> "bar")
41+
42+ -- latticeBoolean
43+ print (top && true)
44+ print (bottom || false)
45+
46+ -- complementedLatticeBoolean
47+ print (not true)
examples/passing/OperatorSections.pursnew file+11
@@ -0,0 +1,11 @@
1+module Main where
2+
3+import Prelude
4+import Assert
5+
6+main = do
7+ assert $ (/ 2.0) 4.0 == 2.0
8+ assert $ (2.0 /) 4.0 == 0.5
9+ assert $ (`const` 1.0) 2.0 == 2.0
10+ assert $ (1.0 `const`) 2.0 == 1.0
11+ Debug.Trace.trace "Done!"
examples/passing/Operators.pursnew file+99
@@ -0,0 +1,99 @@
1+module Main where
2+
3+import Prelude
4+import Control.Monad.Eff
5+import Debug.Trace
6+
7+(?!) :: forall a. a -> a -> a
8+(?!) x _ = x
9+
10+bar :: String -> String -> String
11+bar = \s1 s2 -> s1 ++ s2
12+
13+test1 :: forall n. (Num n) => n -> n -> (n -> n -> n) -> n
14+test1 x y z = x * y + z x y
15+
16+test2 = (\x -> x.foo false) { foo : \_ -> 1.0 }
17+
18+test3 = (\x y -> x)(1.0 + 2.0 * (1.0 + 2.0)) (true && (false || false))
19+
20+k = \x -> \y -> x
21+
22+test4 = 1 `k` 2
23+
24+infixl 5 %%
25+
26+(%%) :: Number -> Number -> Number
27+(%%) x y = x * y + y
28+
29+test5 = 1.0 %% 2.0 %% 3.0
30+
31+test6 = ((\x -> x) `k` 2.0) 3.0
32+
33+(<+>) :: String -> String -> String
34+(<+>) = \s1 s2 -> s1 ++ s2
35+
36+test7 = "Hello" <+> "World!"
37+
38+(@@) :: forall a b. (a -> b) -> a -> b
39+(@@) = \f x -> f x
40+
41+foo :: String -> String
42+foo = \s -> s
43+
44+test8 = foo @@ "Hello World"
45+
46+test9 = Main.foo @@ "Hello World"
47+
48+test10 = "Hello" `Main.bar` "World"
49+
50+(...) :: forall a. Array a -> Array a -> Array a
51+(...) = \as -> \bs -> as
52+
53+test11 = [1.0, 2.0, 0.0] ... [4.0, 5.0, 6.0]
54+
55+test12 (<%>) a b = a <%> b
56+
57+test13 = \(<%>) a b -> a <%> b
58+
59+test14 :: Number -> Number -> Boolean
60+test14 a b = a < b
61+
62+test15 :: Number -> Number -> Boolean
63+test15 a b = const false $ a `test14` b
64+
65+test17 :: Number
66+test17 = negate (-1.0)
67+
68+test18 :: Number
69+test18 = negate $ negate 1.0
70+
71+test19 :: Number
72+test19 = negate $ negate (-1.0)
73+
74+test20 :: Number
75+test20 = 1.0 @ 2.0
76+ where
77+ (@) x y = x + y * y
78+
79+main = do
80+ let t1 = test1 1.0 2.0 (\x y -> x + y)
81+ let t2 = test2
82+ let t3 = test3
83+ let t4 = test4
84+ let t5 = test5
85+ let t6 = test6
86+ let t7 = test7
87+ let t8 = test8
88+ let t9 = test9
89+ let t10 = test10
90+ let t11 = test11
91+ let t12 = test12 k 1.0 2.0
92+ let t13 = test13 k 1.0 2.0
93+ let t14 = test14 1.0 2.0
94+ let t15 = test15 1.0 2.0
95+ let t17 = test17
96+ let t18 = test18
97+ let t19 = test19
98+ let t20 = test20
99+ trace "Done"
examples/passing/OptimizerBug.pursnew file+9
@@ -0,0 +1,9 @@
1+module Main where
2+
3+import Prelude
4+
5+x a = 1.0 + y a
6+
7+y a = x a
8+
9+main = Debug.Trace.trace "Done"
examples/passing/PartialFunction.pursnew file+10
@@ -0,0 +1,10 @@
1+module Main where
2+
3+import Prelude
4+import Assert
5+
6+fn :: Number -> Number
7+fn 0.0 = 0.0
8+fn 1.0 = 2.0
9+
10+main = assertPartial $ \_ -> fn 2.0
examples/passing/Patterns.pursnew file+22
@@ -0,0 +1,22 @@
1+module Main where
2+
3+import Prelude
4+
5+test = \x -> case x of
6+ { str = "Foo", bool = true } -> true
7+ { str = "Bar", bool = b } -> b
8+ _ -> false
9+
10+f = \o -> case o of
11+ { foo = "Foo" } -> o.bar
12+ _ -> 0
13+
14+h = \o -> case o of
15+ a@[_,_,_] -> a
16+ _ -> []
17+
18+isDesc :: Array Number -> Boolean
19+isDesc [x, y] | x > y = true
20+isDesc _ = false
21+
22+main = Debug.Trace.trace "Done"
examples/passing/Person.pursnew file+11
@@ -0,0 +1,11 @@
1+module Main where
2+
3+import Prelude
4+
5+data Person = Person { name :: String, age :: Number }
6+
7+showPerson :: Person -> String
8+showPerson = \p -> case p of
9+ Person o -> o.name ++ ", aged " ++ show o.age
10+
11+main = Debug.Trace.trace "Done"
examples/passing/Rank2Data.pursnew file+29
@@ -0,0 +1,29 @@
1+module Main where
2+
3+import Prelude
4+
5+data Id = Id forall a. a -> a
6+
7+runId = \id a -> case id of
8+ Id f -> f a
9+
10+data Nat = Nat forall r. r -> (r -> r) -> r
11+
12+runNat = \nat -> case nat of
13+ Nat f -> f 0.0 (\n -> n + 1.0)
14+
15+zero' = Nat (\zero' _ -> zero')
16+
17+succ = \n -> case n of
18+ Nat f -> Nat (\zero' succ -> succ (f zero' succ))
19+
20+add = \n m -> case n of
21+ Nat f -> case m of
22+ Nat g -> Nat (\zero' succ -> g (f zero' succ) succ)
23+
24+one' = succ zero'
25+two = succ zero'
26+four = add two two
27+fourNumber = runNat four
28+
29+main = Debug.Trace.trace "Done'"
examples/passing/Rank2Object.pursnew file+11
@@ -0,0 +1,11 @@
1+module Main where
2+
3+import Prelude
4+import Debug.Trace
5+
6+data Foo = Foo { id :: forall a. a -> a }
7+
8+foo :: Foo -> Number
9+foo (Foo { id = f }) = f 0.0
10+
11+main = trace "Done"
examples/passing/Rank2TypeSynonym.pursnew file+16
@@ -0,0 +1,16 @@
1+module Main where
2+
3+import Prelude
4+import Control.Monad.Eff
5+
6+type Foo a = forall f. (Monad f) => f a
7+
8+foo :: forall a. a -> Foo a
9+foo x = pure x
10+
11+bar :: Foo Number
12+bar = foo 3.0
13+
14+main = do
15+ x <- bar
16+ Debug.Trace.print x
examples/passing/Rank2Types.pursnew file+11
@@ -0,0 +1,11 @@
1+module Main where
2+
3+import Prelude
4+
5+test1 :: (forall a. (a -> a)) -> Number
6+test1 = \f -> f 0.0
7+
8+forever :: forall m a b. (forall a b. m a -> (a -> m b) -> m b) -> m a -> m b
9+forever = \bind action -> bind action $ \_ -> forever bind action
10+
11+main = Debug.Trace.trace "Done"
examples/passing/RebindableSyntax.pursnew file+39
@@ -0,0 +1,39 @@
1+module Main where
2+
3+import Prelude
4+
5+example1 :: String
6+example1 = do
7+ "Do"
8+ " notation"
9+ " for"
10+ " Semigroup"
11+ where
12+ bind x f = x <> f unit
13+
14+(*>) :: forall f a b. (Apply f) => f a -> f b -> f b
15+(*>) fa fb = const id <$> fa <*> fb
16+
17+newtype Const a b = Const a
18+
19+runConst :: forall a b. Const a b -> a
20+runConst (Const a) = a
21+
22+instance functorConst :: Functor (Const a) where
23+ (<$>) _ (Const a) = Const a
24+
25+instance applyConst :: (Semigroup a) => Apply (Const a) where
26+ (<*>) (Const a1) (Const a2) = Const (a1 <> a2)
27+
28+example2 :: Const String Unit
29+example2 = do
30+ Const "Do"
31+ Const " notation"
32+ Const " for"
33+ Const " Apply"
34+ where
35+ bind x f = x *> f unit
36+
37+main = do
38+ Debug.Trace.trace example1
39+ Debug.Trace.trace $ runConst example2
examples/passing/Recursion.pursnew file+10
@@ -0,0 +1,10 @@
1+module Main where
2+
3+import Prelude
4+
5+fib = \n -> case n of
6+ 0.0 -> 1.0
7+ 1.0 -> 1.0
8+ n -> fib (n - 1.0) + fib (n - 2.0)
9+
10+main = Debug.Trace.trace "Done"
examples/passing/ReservedWords.pursnew file+15
@@ -0,0 +1,15 @@
1+-- See https://github.com/purescript/purescript/issues/606
2+module Main where
3+
4+import Prelude
5+
6+o :: { type :: String }
7+o = { type: "o" }
8+
9+p :: { type :: String }
10+p = o { type = "p" }
11+
12+f :: forall r. { type :: String | r } -> String
13+f { type = "p" } = "Done"
14+
15+main = Debug.Trace.trace $ f { type: p.type, foo: "bar" }
examples/passing/RowConstructors.pursnew file+42
@@ -0,0 +1,42 @@
1+module Main where
2+
3+import Prelude
4+
5+type Foo = (x :: Number | (y :: Number | (z :: Number)))
6+type Bar = (x :: Number, y :: Number, z :: Number)
7+type Baz = { w :: Number | Bar }
8+
9+foo :: { | Foo }
10+foo = { x: 0.0, y: 0.0, z: 0.0 }
11+
12+bar :: { | Bar }
13+bar = { x: 0.0, y: 0.0, z: 0.0 }
14+
15+id' :: Object Foo -> Object Bar
16+id' = id
17+
18+foo' :: { | Foo }
19+foo' = id' foo
20+
21+bar' :: { | Bar }
22+bar' = id' bar
23+
24+baz :: Baz
25+baz = { x: 0.0, y: 0.0, z: 0.0, w: 0.0 }
26+
27+type Quux r = (q :: Number | r)
28+type Norf r = (q' :: Number | Quux r)
29+
30+quux :: { f :: { | Foo } | Quux Bar }
31+quux = { f: foo', x: 0.0, y: 0.0, z: 0.0, q: 0.0 }
32+
33+quux' :: { | Norf Bar }
34+quux' = { x: 0.0, y: 0.0, z: 0.0, q: 0.0, q': 0.0 }
35+
36+wildcard :: { w :: Number | _ } -> Baz
37+wildcard { w: w } = { x: w, y: w, z: w, w: w }
38+
39+wildcard' :: { | Quux _ } -> Number
40+wildcard' { q: q } = q
41+
42+main = Debug.Trace.trace "Done"
examples/passing/RowPolyInstanceContext.pursnew file+22
@@ -0,0 +1,22 @@
1+module Main where
2+
3+import Prelude
4+
5+class T s m where
6+ state :: (s -> s) -> m Unit
7+
8+data S s a = S (s -> { new :: s, ret :: a })
9+
10+instance st :: T s (S s) where
11+ state f = S $ \s -> { new: f s, ret: unit }
12+
13+test1 :: forall r . S { foo :: String | r } Unit
14+test1 = state $ \o -> o { foo = o.foo ++ "!" }
15+
16+test2 :: forall m r . (T { foo :: String | r } m) => m Unit
17+test2 = state $ \o -> o { foo = o.foo ++ "!" }
18+
19+main = do
20+ let t1 = test1
21+ let t2 = test2
22+ Debug.Trace.trace "Done"
examples/passing/RuntimeScopeIssue.pursnew file+19
@@ -0,0 +1,19 @@
1+module Main where
2+
3+import Prelude
4+
5+class A a where
6+ a :: a -> Boolean
7+
8+class B a where
9+ b :: a -> Boolean
10+
11+instance aNumber :: A Number where
12+ a 0.0 = true
13+ a n = b (n - 1.0)
14+
15+instance bNumber :: B Number where
16+ b 0.0 = false
17+ b n = a (n - 1.0)
18+
19+main = Debug.Trace.print $ a 10.0
examples/passing/ScopedTypeVariables.pursnew file+36
@@ -0,0 +1,36 @@
1+module Main where
2+
3+import Prelude
4+
5+test1 :: forall a. (a -> a) -> a -> a
6+test1 f x = g (g x)
7+ where
8+ g :: a -> a
9+ g y = f (f y)
10+
11+test2 :: forall a. (a -> a) -> a -> a
12+test2 = h
13+ where
14+ h :: forall b. (b -> b) -> b -> b
15+ h f x = g (g x)
16+ where
17+ g :: b -> b
18+ g y = f (f y)
19+
20+test3 :: Number
21+test3 = ((\b -> b :: b) :: forall b. b -> b) 0.0
22+
23+test4 :: forall a. (a -> a) -> a -> a
24+test4 = h
25+ where
26+ h :: forall b. (b -> b) -> b -> b
27+ h f x = g (g x)
28+ where
29+ g :: b -> b
30+ g y = j (f (f y))
31+ where
32+ j :: forall b. b -> b
33+ j x = x
34+
35+
36+main = Debug.Trace.trace "Done"
examples/passing/Sequence.pursnew file+15
@@ -0,0 +1,15 @@
1+module Main where
2+
3+import Prelude
4+import Control.Monad.Eff
5+
6+data List a = Cons a (List a) | Nil
7+
8+class Sequence t where
9+ sequence :: forall m a. (Monad m) => t (m a) -> m (t a)
10+
11+instance sequenceList :: Sequence List where
12+ sequence Nil = pure Nil
13+ sequence (Cons x xs) = Cons <$> x <*> sequence xs
14+
15+main = sequence $ Cons (Debug.Trace.trace "Done") Nil
examples/passing/SequenceDesugared.pursnew file+37
@@ -0,0 +1,37 @@
1+module Main where
2+
3+import Prelude
4+import Control.Monad.Eff
5+
6+data List a = Cons a (List a) | Nil
7+
8+data Sequence t = Sequence (forall m a. (Monad m) => t (m a) -> m (t a))
9+
10+sequence :: forall t. Sequence t -> (forall m a. (Monad m) => t (m a) -> m (t a))
11+sequence (Sequence s) = s
12+
13+sequenceListSeq :: forall m a. (Monad m) => List (m a) -> m (List a)
14+sequenceListSeq Nil = pure Nil
15+sequenceListSeq (Cons x xs) = Cons <$> x <*> sequenceListSeq xs
16+
17+sequenceList :: Sequence List
18+sequenceList = Sequence (sequenceListSeq)
19+
20+sequenceList' :: Sequence List
21+sequenceList' = Sequence ((\val -> case val of
22+ Nil -> pure Nil
23+ Cons x xs -> Cons <$> x <*> sequence sequenceList' xs))
24+
25+sequenceList'' :: Sequence List
26+sequenceList'' = Sequence (sequenceListSeq :: forall m a. (Monad m) => List (m a) -> m (List a))
27+
28+sequenceList''' :: Sequence List
29+sequenceList''' = Sequence ((\val -> case val of
30+ Nil -> pure Nil
31+ Cons x xs -> Cons <$> x <*> sequence sequenceList''' xs) :: forall m a. (Monad m) => List (m a) -> m (List a))
32+
33+main = do
34+ sequence sequenceList $ Cons (Debug.Trace.trace "Done") Nil
35+ sequence sequenceList' $ Cons (Debug.Trace.trace "Done") Nil
36+ sequence sequenceList'' $ Cons (Debug.Trace.trace "Done") Nil
37+ sequence sequenceList''' $ Cons (Debug.Trace.trace "Done") Nil
examples/passing/ShadowedRename.pursnew file+14
@@ -0,0 +1,14 @@
1+module Main where
2+
3+import Prelude
4+import Control.Monad.Eff
5+import Debug.Trace
6+import Assert
7+
8+foo foo = let foo_1 = \_ -> foo
9+ foo_2 = foo_1 unit + 1.0
10+ in foo_2
11+
12+main = do
13+ assert $ foo 1.0 == 2.0
14+ trace "Done"
examples/passing/ShadowedTCO.pursnew file+18
@@ -0,0 +1,18 @@
1+module Main where
2+
3+import Prelude
4+
5+runNat f = f 0.0 (\n -> n + 1.0)
6+
7+zero' z _ = z
8+
9+succ f zero' succ = succ (f zero' succ)
10+
11+add f g zero' succ = g (f zero' succ) succ
12+
13+one' = succ zero'
14+two = succ one'
15+four = add two two
16+fourNumber = runNat four
17+
18+main = Debug.Trace.trace $ show fourNumber
examples/passing/ShadowedTCOLet.pursnew file+9
@@ -0,0 +1,9 @@
1+module Main where
2+
3+import Prelude
4+
5+f x y z =
6+ let f 1.0 2.0 3.0 = 1.0
7+ in f x z y
8+
9+main = Debug.Trace.trace $ show $ f 1.0 3.0 2.0
examples/passing/SignedNumericLiterals.pursnew file+17
@@ -0,0 +1,17 @@
1+module Main where
2+
3+import Prelude
4+
5+p = 0.5
6+q = 1.0
7+x = -1.0
8+y = -0.5
9+z = 0.5
10+w = 1.0
11+
12+f :: Number -> Number
13+f x = -x
14+
15+test1 = 2.0 - 1.0
16+
17+main = Debug.Trace.trace "Done"
examples/passing/Superclasses1.pursnew file+20
@@ -0,0 +1,20 @@
1+module Main where
2+
3+import Prelude
4+
5+class Su a where
6+ su :: a -> a
7+
8+class (Su a) <= Cl a where
9+ cl :: a -> a -> a
10+
11+instance suNumber :: Su Number where
12+ su n = n + 1.0
13+
14+instance clNumber :: Cl Number where
15+ cl n m = n + m
16+
17+test :: forall a. (Cl a) => a -> a
18+test a = su (cl a a)
19+
20+main = Debug.Trace.print $ test 10.0
examples/passing/Superclasses2.pursnew file+24
@@ -0,0 +1,24 @@
1+module Main where
2+
3+import Prelude
4+import Prelude.Unsafe (unsafeIndex)
5+
6+class Su a where
7+ su :: a -> a
8+
9+class (Su (Array a)) <= Cl a where
10+ cl :: a -> a -> a
11+
12+instance suNumber :: Su Number where
13+ su n = n + 1.0
14+
15+instance suArray :: (Su a) => Su (Array a) where
16+ su [x] = [su x]
17+
18+instance clNumber :: Cl Number where
19+ cl n m = n + m
20+
21+test :: forall a. (Cl a) => a -> Array a
22+test x = su [cl x x]
23+
24+main = Debug.Trace.print $ test 10.0 `unsafeIndex` 0.0
examples/passing/Superclasses3.pursnew file+41
@@ -0,0 +1,41 @@
1+module Main where
2+
3+import Prelude
4+import Debug.Trace
5+import Control.Monad.Eff
6+
7+class (Monad m) <= MonadWriter w m where
8+ tell :: w -> m Unit
9+
10+testFunctor :: forall m. (Monad m) => m Number -> m Number
11+testFunctor n = (+) 1.0 <$> n
12+
13+test :: forall w m. (Monad m, MonadWriter w m) => w -> m Unit
14+test w = do
15+ tell w
16+ tell w
17+ tell w
18+
19+data MTrace a = MTrace (Eff (trace :: Trace) a)
20+
21+runMTrace :: forall a. MTrace a -> Eff (trace :: Trace) a
22+runMTrace (MTrace a) = a
23+
24+instance functorMTrace :: Functor MTrace where
25+ (<$>) = liftM1
26+
27+instance applyMTrace :: Apply MTrace where
28+ (<*>) = ap
29+
30+instance applicativeMTrace :: Applicative MTrace where
31+ pure = MTrace <<< return
32+
33+instance bindMTrace :: Bind MTrace where
34+ bind m f = MTrace (runMTrace m >>= (runMTrace <<< f))
35+
36+instance monadMTrace :: Monad MTrace
37+
38+instance writerMTrace :: MonadWriter String MTrace where
39+ tell s = MTrace (trace s)
40+
41+main = runMTrace $ test "Done"
examples/passing/TCOCase.pursnew file+12
@@ -0,0 +1,12 @@
1+module Main where
2+
3+import Prelude
4+
5+data Data = One | More Data
6+
7+main = Debug.Trace.trace (from (to 10000.0 One))
8+ where
9+ to 0.0 a = a
10+ to n a = to (n - 1.0) (More a)
11+ from One = "Done"
12+ from (More d) = from d
examples/passing/TailCall.pursnew file+17
@@ -0,0 +1,17 @@
1+module Main where
2+
3+import Prelude
4+
5+data L a = C a (L a) | N
6+
7+test :: Number -> L Number -> Number
8+test n N = n
9+test n (C x xs) = test (n + x) xs
10+
11+loop :: forall a. Number -> a
12+loop x = loop (x + 1.0)
13+
14+notATailCall = \x ->
15+ (\notATailCall -> notATailCall x) (\x -> x)
16+
17+main = Debug.Trace.print (test 0.0 (1.0 `C` (2.0 `C` (3.0 `C` N))))
examples/passing/Tick.pursnew file+7
@@ -0,0 +1,7 @@
1+module Main where
2+
3+import Prelude
4+
5+test' x = x
6+
7+main = Debug.Trace.trace "Done"
examples/passing/TopLevelCase.pursnew file+18
@@ -0,0 +1,18 @@
1+module Main where
2+
3+import Prelude
4+
5+gcd :: Number -> Number -> Number
6+gcd 0.0 x = x
7+gcd x 0.0 = x
8+gcd x y | x > y = gcd (x % y) y
9+gcd x y = gcd (y % x) x
10+
11+guardsTest [x] | x > 0.0 = []
12+guardsTest xs = xs
13+
14+data A = A
15+
16+parseTest A 0.0 = 0.0
17+
18+main = Debug.Trace.trace "Done"
examples/passing/TypeClassMemberOrderChange.pursnew file+13
@@ -0,0 +1,13 @@
1+module Main where
2+
3+import Prelude
4+
5+class Test a where
6+ fn :: a -> a -> a
7+ val :: a
8+
9+instance testBoolean :: Test Boolean where
10+ val = true
11+ fn x y = y
12+
13+main = Debug.Trace.trace (show (fn true val))
examples/passing/TypeClasses.pursnew file+69
@@ -0,0 +1,69 @@
1+module Main where
2+
3+import Prelude
4+
5+test1 = \_ -> show "testing"
6+
7+f :: forall a. (Prelude.Show a) => a -> String
8+f x = show x
9+
10+test2 = \_ -> f "testing"
11+
12+test7 :: forall a. (Prelude.Show a) => a -> String
13+test7 = show
14+
15+test8 = \_ -> show $ "testing"
16+
17+data Data a = Data a
18+
19+instance showData :: (Prelude.Show a) => Prelude.Show (Data a) where
20+ show (Data a) = "Data (" ++ show a ++ ")"
21+
22+test3 = \_ -> show (Data "testing")
23+
24+instance functorData :: Functor Data where
25+ (<$>) = liftM1
26+
27+instance applyData :: Apply Data where
28+ (<*>) = ap
29+
30+instance applicativeData :: Applicative Data where
31+ pure = Data
32+
33+instance bindData :: Bind Data where
34+ bind (Data a) f = f a
35+
36+instance monadData :: Monad Data
37+
38+data Maybe a = Nothing | Just a
39+
40+instance functorMaybe :: Functor Maybe where
41+ (<$>) = liftM1
42+
43+instance applyMaybe :: Apply Maybe where
44+ (<*>) = ap
45+
46+instance applicativeMaybe :: Applicative Maybe where
47+ pure = Just
48+
49+instance bindMaybe :: Bind Maybe where
50+ bind Nothing _ = Nothing
51+ bind (Just a) f = f a
52+
53+instance monadMaybe :: Monad Maybe
54+
55+test4 :: forall a m. (Monad m) => a -> m Number
56+test4 = \_ -> return 1.0
57+
58+test5 = \_ -> Just 1.0 >>= \n -> return (n + 1.0)
59+
60+ask r = r
61+
62+runReader r f = f r
63+
64+test9 _ = runReader 0.0 $ do
65+ n <- ask
66+ return $ n + 1.0
67+
68+main = Debug.Trace.trace (test7 "Done")
69+
examples/passing/TypeClassesInOrder.pursnew file+11
@@ -0,0 +1,11 @@
1+module Main where
2+
3+import Prelude
4+
5+class Foo a where
6+ foo :: a -> String
7+
8+instance fooString :: Foo String where
9+ foo s = s
10+
11+main = Debug.Trace.trace $ foo "Done"
examples/passing/TypeClassesWithOverlappingTypeVariables.pursnew file+11
@@ -0,0 +1,11 @@
1+module Main where
2+
3+import Prelude
4+
5+data Either a b = Left a | Right b
6+
7+instance functorEither :: Prelude.Functor (Either a) where
8+ (<$>) _ (Left x) = Left x
9+ (<$>) f (Right y) = Right (f y)
10+
11+main = Debug.Trace.trace "Done"
examples/passing/TypeDecl.pursnew file+12
@@ -0,0 +1,12 @@
1+module Main where
2+
3+import Prelude
4+
5+k :: String -> Number -> String
6+k x y = x
7+
8+iterate :: forall a. Number -> (a -> a) -> a -> a
9+iterate 0.0 f a = a
10+iterate n f a = iterate (n - 1.0) f (f a)
11+
12+main = Debug.Trace.trace "Done"
examples/passing/TypeSynonymInData.pursnew file+11
@@ -0,0 +1,11 @@
1+module Main where
2+
3+import Prelude
4+
5+type A a = Array a
6+
7+data Foo a = Foo (A a) | Bar
8+
9+foo (Foo []) = Bar
10+
11+main = Debug.Trace.trace "Done"
examples/passing/TypeSynonyms.pursnew file+27
@@ -0,0 +1,27 @@
1+module Main where
2+
3+import Prelude
4+
5+type Lens a b =
6+ { get :: a -> b
7+ , set :: a -> b -> a
8+ }
9+
10+composeLenses :: forall a b c. Lens a b -> Lens b c -> Lens a c
11+composeLenses = \l1 -> \l2 ->
12+ { get: \a -> l2.get (l1.get a)
13+ , set: \a c -> l1.set a (l2.set (l1.get a) c)
14+ }
15+
16+type Pair a b = { fst :: a, snd :: b }
17+
18+fst :: forall a b. Lens (Pair a b) a
19+fst =
20+ { get: \p -> p.fst
21+ , set: \p a -> { fst: a, snd: p.snd }
22+ }
23+
24+test1 :: forall a b c. Lens (Pair (Pair a b) c) a
25+test1 = composeLenses fst fst
26+
27+main = Debug.Trace.trace "Done"
examples/passing/TypeWildcards.pursnew file+15
@@ -0,0 +1,15 @@
1+module Main where
2+
3+import Prelude
4+
5+testTopLevel :: _ -> _
6+testTopLevel n = n + 1.0
7+
8+test :: forall a. (Eq a) => (a -> a) -> a -> a
9+test f a = go (f a) a
10+ where
11+ go :: _ -> _ -> _
12+ go a1 a2 | a1 == a2 = a1
13+ go a1 _ = go (f a1) a1
14+
15+main = Debug.Trace.trace "Done"
examples/passing/TypeWildcardsRecordExtension.pursnew file+8
@@ -0,0 +1,8 @@
1+module Main where
2+
3+import Prelude
4+
5+foo :: forall a. {b :: Number | a} -> {b :: Number | _}
6+foo f = f
7+
8+main = Debug.Trace.trace "Done"
examples/passing/TypedWhere.pursnew file+17
@@ -0,0 +1,17 @@
1+module Main where
2+
3+import Prelude
4+
5+data E a b = L a | R b
6+
7+data L a = C a (L a) | N
8+
9+lefts :: forall a b. L (E a b) -> L a
10+lefts = go N
11+ where
12+ go :: forall a b. L a -> L (E a b) -> L a
13+ go ls N = ls
14+ go ls (C (L a) rest) = go (C a ls) rest
15+ go ls (C _ rest) = go ls rest
16+
17+main = Debug.Trace.trace "Done"
examples/passing/UnderscoreIdent.pursnew file+11
@@ -0,0 +1,11 @@
1+module Main where
2+
3+import Prelude
4+
5+data Data_type = Con_Structor | Con_2 String
6+
7+type Type_name = Data_type
8+
9+done (Con_2 s) = s
10+
11+main = Debug.Trace.trace (done (Con_2 "Done"))
examples/passing/Unit.pursnew file+6
@@ -0,0 +1,6 @@
1+module Main where
2+
3+import Prelude
4+import Debug.Trace
5+
6+main = print (const unit $ "Hello world")
examples/passing/UnknownInTypeClassLookup.pursnew file+14
@@ -0,0 +1,14 @@
1+module Main where
2+
3+import Prelude
4+
5+class EQ a b
6+
7+instance eqAA :: EQ a a
8+
9+test :: forall a b. (EQ a b) => a -> b -> String
10+test _ _ = "Done"
11+
12+runTest a = test a a
13+
14+main = Debug.Trace.trace $ runTest 0.0
examples/passing/Where.pursnew file+49
@@ -0,0 +1,49 @@
1+module Main where
2+
3+import Prelude
4+import Control.Monad.Eff
5+import Control.Monad.ST
6+
7+test1 x = y
8+ where
9+ y :: Number
10+ y = x + 1.0
11+
12+test2 x y = x' + y'
13+ where
14+ x' = x + 1.0
15+ y' = y + 1.0
16+
17+
18+test3 = f 1.0 2.0 3.0
19+ where f x y z = x + y + z
20+
21+
22+test4 = f (+) [1.0, 2.0]
23+ where f x [y, z] = x y z
24+
25+
26+test5 = g 10.0
27+ where
28+ f x | x > 0.0 = g (x / 2.0) + 1.0
29+ f x = 0.0
30+ g x = f (x - 1.0) + 1.0
31+
32+test6 = if f true then f 1.0 else f 2.0
33+ where f :: forall a. a -> a
34+ f x = x
35+
36+test7 :: Number -> Number
37+test7 x = go x
38+ where
39+ go y | (x - 0.1 < y * y) && (y * y < x + 0.1) = y
40+ go y = go $ (y + x / y) / 2.0
41+
42+main = do
43+ Debug.Trace.print (test1 1.0)
44+ Debug.Trace.print (test2 1.0 2.0)
45+ Debug.Trace.print test3
46+ Debug.Trace.print test4
47+ Debug.Trace.print test5
48+ Debug.Trace.print test6
49+ Debug.Trace.print (test7 100.0)
examples/passing/iota.pursnew file+9
@@ -0,0 +1,9 @@
1+module Main where
2+
3+s = \x -> \y -> \z -> x z (y z)
4+
5+k = \x -> \y -> x
6+
7+iota = \x -> x s k
8+
9+main = Debug.Trace.trace "Done"
examples/passing/s.pursnew file+7
@@ -0,0 +1,7 @@
1+module Main where
2+
3+import Prelude
4+
5+s = \x y z -> x z (y z)
6+
7+main = Debug.Trace.trace "Done"
hierarchy/Main.hsnew file+114
@@ -0,0 +1,114 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Main
4+-- Copyright : (c) Hardy Jones 2014
5+-- License : MIT
6+--
7+-- Maintainer : Hardy Jones <jones3.hardy@gmail.com>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- Generate Directed Graphs of PureScript TypeClasses
13+--
14+-----------------------------------------------------------------------------
15+
16+{-# LANGUAGE TupleSections #-}
17+
18+module Main where
19+
20+import Control.Monad (unless)
21+
22+import Data.List (intercalate,nub,sort)
23+import Data.Foldable (for_)
24+import Data.Version (showVersion)
25+
26+import Options.Applicative
27+import System.Directory (createDirectoryIfMissing)
28+import System.FilePath ((</>))
29+import System.FilePath.Glob (glob)
30+import System.Exit (exitFailure, exitSuccess)
31+import System.IO (hPutStr, stderr)
32+
33+import qualified Language.PureScript as P
34+import qualified Paths_purescript as Paths
35+
36+data HierarchyOptions = HierarchyOptions
37+ { hierachyInput :: FilePath
38+ , hierarchyOutput :: Maybe FilePath
39+ }
40+
41+newtype SuperMap = SuperMap { unSuperMap :: Either P.ProperName (P.ProperName, P.ProperName) }
42+ deriving Eq
43+
44+instance Show SuperMap where
45+ show (SuperMap (Left sub)) = show sub
46+ show (SuperMap (Right (super, sub))) = show super ++ " -> " ++ show sub
47+
48+instance Ord SuperMap where
49+ compare (SuperMap s) (SuperMap s') = getCls s `compare` getCls s'
50+ where
51+ getCls = either id snd
52+
53+runModuleName :: P.ModuleName -> String
54+runModuleName (P.ModuleName pns) = intercalate "_" (P.runProperName `map` pns)
55+
56+readInput :: [FilePath] -> IO (Either P.MultipleErrors [P.Module])
57+readInput paths = do
58+ content <- mapM (\path -> (path, ) <$> readFile path) paths
59+ return $ map snd <$> P.parseModulesFromFiles id content
60+
61+compile :: HierarchyOptions -> IO ()
62+compile (HierarchyOptions inputGlob mOutput) = do
63+ input <- glob inputGlob
64+ modules <- readInput input
65+ case modules of
66+ Left errs -> hPutStr stderr (P.prettyPrintMultipleErrors False errs) >> exitFailure
67+ Right ms -> do
68+ for_ ms $ \(P.Module _ moduleName decls _) ->
69+ let name = runModuleName moduleName
70+ tcs = filter P.isTypeClassDeclaration decls
71+ supers = sort . nub . filter (not . null) $ fmap superClasses tcs
72+ prologue = "digraph " ++ name ++ " {\n"
73+ body = intercalate "\n" (concatMap (fmap (\s -> " " ++ show s ++ ";")) supers)
74+ epilogue = "\n}"
75+ hier = prologue ++ body ++ epilogue
76+ in unless (null supers) $ case mOutput of
77+ Just output -> do
78+ createDirectoryIfMissing True output
79+ writeFile (output </> name) hier
80+ Nothing -> putStrLn hier
81+ exitSuccess
82+
83+superClasses :: P.Declaration -> [SuperMap]
84+superClasses (P.TypeClassDeclaration sub _ supers@(_:_) _) =
85+ fmap (\(P.Qualified _ super, _) -> SuperMap (Right (super, sub))) supers
86+superClasses (P.TypeClassDeclaration sub _ _ _) = [SuperMap (Left sub)]
87+superClasses (P.PositionedDeclaration _ _ decl) = superClasses decl
88+superClasses _ = []
89+
90+inputFile :: Parser FilePath
91+inputFile = strArgument $
92+ metavar "FILE"
93+ <> value "main.purs"
94+ <> showDefault
95+ <> help "The input file to generate a hierarchy from"
96+
97+outputFile :: Parser (Maybe FilePath)
98+outputFile = optional . strOption $
99+ short 'o'
100+ <> long "output"
101+ <> help "The output directory"
102+
103+pscOptions :: Parser HierarchyOptions
104+pscOptions = HierarchyOptions <$> inputFile
105+ <*> outputFile
106+
107+main :: IO ()
108+main = execParser opts >>= compile
109+ where
110+ opts = info (helper <*> pscOptions) infoModList
111+ infoModList = fullDesc <> headerInfo <> footerInfo
112+ headerInfo = header "hierarchy - Creates a GraphViz directed graph of PureScript TypeClasses"
113+ footerInfo = footer $ "hierarchy " ++ showVersion Paths.version
114+
license-generator/generatenew file+44
@@ -0,0 +1,44 @@
1+#!/bin/bash
2+# Generates the LICENSE file and prints it to standard output.
3+# Example use:
4+#
5+# ./license/generate > LICENSE
6+#
7+
8+set -e # exit on error
9+set -u # exit on undefined variable
10+set -o pipefail # propagate nonzero exit codes through pipelines
11+
12+if ! which cabal-dependency-licenses >/dev/null; then
13+ echo "$0: the program 'cabal-dependency-licenses' is required." >&2
14+ echo "$0: see Hackage: https://hackage.haskell.org/package/cabal-dependency-licenses" >&2
15+ exit 1
16+fi
17+
18+echo_header() {
19+ cat license-generator/header.txt
20+}
21+
22+echo_deps_names() {
23+ cabal-dependency-licenses \
24+ | grep '^- ' | sed 's/^..//' | sort -h
25+}
26+
27+echo_deps_licenses() {
28+ while read dep; do
29+ echo "fetching LICENSE for: ${dep}" >&2
30+ echo "${dep} LICENSE file:"
31+ echo ""
32+ curl --silent "https://hackage.haskell.org/package/${dep}/src/LICENSE" \
33+ | sed 's/^/ /g' # indent by 2 characters
34+ echo ""
35+ done
36+}
37+
38+echo_deps_names > license-generator/tmp/deps.txt
39+
40+echo_header
41+echo ""
42+sed <license-generator/tmp/deps.txt 's/^/ /'
43+echo ""
44+echo_deps_licenses <license-generator/tmp/deps.txt
license-generator/header.txtnew file+23
@@ -0,0 +1,23 @@
1+The MIT License (MIT)
2+
3+Copyright (c) 2013-15 Phil Freeman, (c) 2014-2015 Gary Burgess, and other
4+contributors
5+
6+Permission is hereby granted, free of charge, to any person obtaining a copy of
7+this software and associated documentation files (the "Software"), to deal in
8+the Software without restriction, including without limitation the rights to
9+use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of
10+the Software, and to permit persons to whom the Software is furnished to do so,
11+subject to the following conditions:
12+
13+The above copyright notice and this permission notice shall be included in all
14+copies or substantial portions of the Software.
15+
16+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
17+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
18+FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
19+COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
20+IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
21+CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
22+
23+PureScript uses the following Haskell library packages. Their license files follow.
license-generator/tmp/.gitkeepnew file

No changes to the content.

logo.pngnew file

Binary file not shown.

package.yamldeleted−86
@@ -1,86 +0,0 @@
1−name: psgo
2−version: 0.1.0.0
3−github: "andyarvanitis/purescript-native"
4−license: BSD3
5−author: "Andy Arvanitis"
6−maintainer: "example@example.com"
7−copyright: "2018 Andy Arvanitis"
8−
9−extra-source-files:
10−- README.md
11−- ChangeLog.md
12−- stack.yaml
13−- support/*
14−
15−# Metadata used when publishing your package
16−# synopsis: Short description of your package
17−# category: Web
18−
19−# To avoid duplicated efforts in documentation and dealing with the
20−# complications of embedding Haddock markup inside cabal files, it is
21−# common to point users to the README.md file.
22−description: Please see the README on Github at <https://github.com/andyarvanitis/purescript-native#readme>
23−
24−dependencies:
25−- base >= 4.7 && < 5
26−- bytestring >= 0.10.8.2 && < 0.11
27−- purescript
28−- base-compat >=0.6.0
29−- protolude >=0.1.6
30−- text
31−- containers
32−- filepath
33−- monad-parallel >= 0.7.2.2 && <0.8
34−- pattern-arrows >=0.0.2 && <0.1
35−- safe >=0.3.9 && <0.4
36−- transformers >=0.3.0 && <0.6
37−- mtl >=2.1.0 && <2.3.0
38−- aeson >=1.0 && <1.5
39−- directory
40−- process
41−- file-embed
42−- filemanip
43−- gitrev
44−
45−library:
46− source-dirs: src
47− default-extensions:
48− - ConstraintKinds
49− - DataKinds
50− - DeriveFunctor
51− - EmptyDataDecls
52− - FlexibleContexts
53− - KindSignatures
54− - LambdaCase
55− - MultiParamTypeClasses
56− - NoImplicitPrelude
57− - PatternGuards
58− - PatternSynonyms
59− - RankNTypes
60− - RecordWildCards
61− - OverloadedStrings
62− - ScopedTypeVariables
63− - TupleSections
64− - ViewPatterns
65−
66−executables:
67− psgo:
68− main: Main.hs
69− source-dirs: app
70− ghc-options:
71− - -threaded
72− - -rtsopts
73− - -with-rtsopts=-N
74− dependencies:
75− - psgo
76−
77−tests:
78− psgo-test:
79− main: Spec.hs
80− source-dirs: test
81− ghc-options:
82− - -threaded
83− - -rtsopts
84− - -with-rtsopts=-N
85− dependencies:
86− - psgo
psc-docs/Ctags.hsnew file+13
@@ -0,0 +1,13 @@
1+module Ctags (dumpCtags) where
2+
3+import qualified Language.PureScript as P
4+import Tags
5+import Data.List (sort)
6+
7+dumpCtags :: [(String, P.Module)] -> [String]
8+dumpCtags = sort . concat . (map renderModCtags)
9+
10+renderModCtags :: (String, P.Module) -> [String]
11+renderModCtags (path, mdl) = sort tagLines
12+ where tagLines = map tagLine $ tags mdl
13+ tagLine (name, line) = name ++ "\t" ++ path ++ "\t" ++ show line
psc-docs/Etags.hsnew file+15
@@ -0,0 +1,15 @@
1+module Etags (dumpEtags) where
2+
3+import qualified Language.PureScript as P
4+import Tags
5+
6+dumpEtags :: [(String, P.Module)] -> [String]
7+dumpEtags = concat . (map renderModEtags)
8+
9+renderModEtags :: (String, P.Module) -> [String]
10+renderModEtags (path, mdl) = ["\x0c", path ++ "," ++ show tagsLen] ++ tagLines
11+ where tagsLen = sum $ map length tagLines
12+ tagLines = map tagLine $ tags mdl
13+ tagLine (name, line) = "\x7f" ++ name ++ "\x01" ++ show line ++ ","
14+
15+
psc-docs/Main.hsnew file+251
@@ -0,0 +1,251 @@
1+{-# LANGUAGE TupleSections #-}
2+----------------------------------------------------------------------------
3+--
4+-- Module : Main
5+-- Copyright : (c) Phil Freeman 2013
6+-- License : MIT
7+--
8+-- Maintainer : Phil Freeman <paf31@cantab.net>
9+-- Stability : experimental
10+-- Portability :
11+--
12+-- |
13+--
14+-----------------------------------------------------------------------------
15+
16+module Main where
17+
18+import Control.Applicative
19+import Control.Arrow (first, second)
20+import Control.Category ((>>>))
21+import Control.Monad.Writer
22+import Data.Function (on)
23+import Data.List
24+import Data.Maybe (fromMaybe)
25+import Data.Tuple (swap)
26+import Data.Version (showVersion)
27+
28+import Options.Applicative
29+import qualified Text.PrettyPrint.ANSI.Leijen as PP
30+
31+import qualified Language.PureScript as P
32+import qualified Paths_purescript as Paths
33+import System.Exit (exitFailure)
34+import System.IO (hPutStrLn, stderr)
35+import System.Directory (createDirectoryIfMissing)
36+import System.FilePath (takeDirectory)
37+import System.FilePath.Glob (glob)
38+
39+import Etags
40+import Ctags
41+import qualified Language.PureScript.Docs as D
42+import qualified Language.PureScript.Docs.AsMarkdown as D
43+
44+-- Available output formats
45+data Format = Markdown -- Output documentation in Markdown format
46+ | Ctags -- Output ctags symbol index suitable for use with vi
47+ | Etags -- Output etags symbol index suitable for use with emacs
48+ deriving (Show, Eq, Ord)
49+
50+-- | Available methods of outputting Markdown documentation
51+data DocgenOutput
52+ = EverythingToStdOut
53+ | ToStdOut [P.ModuleName]
54+ | ToFiles [(P.ModuleName, FilePath)]
55+ deriving (Show)
56+
57+data PSCDocsOptions = PSCDocsOptions
58+ { pscdFormat :: Format
59+ , pscdInputFiles :: [FilePath]
60+ , pscdDocgen :: DocgenOutput
61+ }
62+ deriving (Show)
63+
64+docgen :: PSCDocsOptions -> IO ()
65+docgen (PSCDocsOptions fmt inputGlob output) = do
66+ input <- concat <$> mapM glob inputGlob
67+ case fmt of
68+ Etags -> dumpTags input dumpEtags
69+ Ctags -> dumpTags input dumpCtags
70+ Markdown -> do
71+ e <- D.parseAndDesugar input [] (\_ ms -> return ms)
72+ case e of
73+ Left (D.ParseError err) -> do
74+ hPutStrLn stderr $ show err
75+ exitFailure
76+ Left (D.SortModulesError err) -> do
77+ hPutStrLn stderr $ P.prettyPrintMultipleErrors False err
78+ exitFailure
79+ Left (D.DesugarError err) -> do
80+ hPutStrLn stderr $ P.prettyPrintMultipleErrors False err
81+ exitFailure
82+ Right ms' ->
83+ case output of
84+ EverythingToStdOut ->
85+ putStrLn (D.renderModulesAsMarkdown ms')
86+ ToStdOut names -> do
87+ let (ms, missing) = takeModulesByName ms' names
88+ guardMissing missing
89+ putStrLn (D.renderModulesAsMarkdown ms)
90+ ToFiles names -> do
91+ let (ms, missing) = takeModulesByName' ms' names
92+ guardMissing missing
93+ let ms'' = groupBy ((==) `on` fst) . sortBy (compare `on` fst) $ map swap ms
94+ forM_ ms'' $ \grp -> do
95+ let fp = fst (head grp)
96+ createDirectoryIfMissing True (takeDirectory fp)
97+ writeFile fp (D.renderModulesAsMarkdown $ snd `map` grp)
98+ where
99+ guardMissing [] = return ()
100+ guardMissing [mn] = do
101+ hPutStrLn stderr ("psc-docs: error: unknown module \"" ++ show mn ++ "\"")
102+ exitFailure
103+ guardMissing mns = do
104+ hPutStrLn stderr "psc-docs: error: unknown modules:"
105+ forM_ mns $ \mn ->
106+ hPutStrLn stderr (" * " ++ show mn)
107+ exitFailure
108+
109+-- |
110+-- Given a list of module names and a list of modules, return a list of modules
111+-- whose names appeared in the given name list, together with a list of names
112+-- for which no module could be found in the module list.
113+--
114+takeModulesByName :: [P.Module] -> [P.ModuleName] -> ([P.Module], [P.ModuleName])
115+takeModulesByName modules names =
116+ first (map fst) (takeModulesByName' modules (map (,()) names))
117+
118+-- |
119+-- Like takeModulesByName but also keeps some extra data with the module.
120+--
121+takeModulesByName' :: [P.Module] -> [(P.ModuleName, a)] -> ([(P.Module, a)], [P.ModuleName])
122+takeModulesByName' modules = foldl go ([], [])
123+ where
124+ go (ms, missing) (name, x) =
125+ case find ((== name) . P.getModuleName) modules of
126+ Just m -> ((m, x) : ms, missing)
127+ Nothing -> (ms, name : missing)
128+
129+dumpTags :: [FilePath] -> ([(String, P.Module)] -> [String]) -> IO ()
130+dumpTags input renderTags = do
131+ e <- P.parseModulesFromFiles (fromMaybe "") <$> mapM (fmap (first Just) . parseFile) (nub input)
132+ case e of
133+ Left err -> do
134+ hPutStrLn stderr (show err)
135+ exitFailure
136+ Right ms ->
137+ ldump (renderTags (pairs ms))
138+
139+ where
140+ pairs :: [(Maybe String, m)] -> [(String, m)]
141+ pairs = map (first (fromMaybe ""))
142+
143+ ldump :: [String] -> IO ()
144+ ldump = mapM_ putStrLn
145+
146+parseFile :: FilePath -> IO (FilePath, String)
147+parseFile input = (,) input <$> readFile input
148+
149+inputFile :: Parser FilePath
150+inputFile = strArgument $
151+ metavar "FILE"
152+ <> help "The input .purs file(s)"
153+
154+instance Read Format where
155+ readsPrec _ "etags" = [(Etags, "")]
156+ readsPrec _ "ctags" = [(Ctags, "")]
157+ readsPrec _ "markdown" = [(Markdown, "")]
158+ readsPrec _ _ = []
159+
160+format :: Parser Format
161+format = option auto $ value Markdown
162+ <> long "format"
163+ <> metavar "FORMAT"
164+ <> help "Set output FORMAT (markdown | etags | ctags)"
165+
166+docgenModule :: Parser String
167+docgenModule = strOption $
168+ long "docgen"
169+ <> 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."
170+
171+pscDocsOptions :: Parser (Format, [FilePath], [String])
172+pscDocsOptions = (,,) <$> format <*> many inputFile <*> many docgenModule
173+
174+parseDocgen :: [String] -> Either String DocgenOutput
175+parseDocgen [] = Right EverythingToStdOut
176+parseDocgen xs = go xs
177+ where
178+ go = intersperse " "
179+ >>> concat
180+ >>> words
181+ >>> map parseItem
182+ >>> combine
183+
184+data DocgenOutputItem
185+ = IToStdOut P.ModuleName
186+ | IToFile (P.ModuleName, FilePath)
187+
188+parseItem :: String -> DocgenOutputItem
189+parseItem s = case elemIndex ':' s of
190+ Just i ->
191+ s # splitAt i
192+ >>> first P.moduleNameFromString
193+ >>> second (drop 1)
194+ >>> IToFile
195+ Nothing ->
196+ IToStdOut (P.moduleNameFromString s)
197+
198+ where
199+ infixr 1 #
200+ (#) = flip ($)
201+
202+combine :: [DocgenOutputItem] -> Either String DocgenOutput
203+combine [] = Right EverythingToStdOut
204+combine (x:xs) = foldM go (initial x) xs
205+ where
206+ initial (IToStdOut m) = ToStdOut [m]
207+ initial (IToFile m) = ToFiles [m]
208+
209+ go (ToStdOut ms) (IToStdOut m) = Right (ToStdOut (m:ms))
210+ go (ToFiles ms) (IToFile m) = Right (ToFiles (m:ms))
211+ go _ _ = Left "Can't mix module names and module name/file path pairs in the same invocation."
212+
213+buildOptions :: (Format, [FilePath], [String]) -> IO PSCDocsOptions
214+buildOptions (fmt, input, mapping) =
215+ case parseDocgen mapping of
216+ Right mapping' -> return (PSCDocsOptions fmt input mapping')
217+ Left err -> do
218+ hPutStrLn stderr "psc-docs: error in --docgen option:"
219+ hPutStrLn stderr (" " ++ err)
220+ exitFailure
221+
222+main :: IO ()
223+main = execParser opts >>= buildOptions >>= docgen
224+ where
225+ opts = info (version <*> helper <*> pscDocsOptions) infoModList
226+ infoModList = fullDesc <> headerInfo <> footerInfo
227+ headerInfo = header "psc-docs - Generate Markdown documentation from PureScript source files"
228+ footerInfo = footerDoc $ Just $ PP.vcat
229+ [ examples, PP.empty, PP.text ("psc-docs " ++ showVersion Paths.version) ]
230+
231+ version :: Parser (a -> a)
232+ version = abortOption (InfoMsg (showVersion Paths.version)) $ long "version" <> help "Show the version number" <> hidden
233+
234+examples :: PP.Doc
235+examples =
236+ PP.vcat $ map PP.text
237+ [ "Examples:"
238+ , " print documentation for Data.List to stdout:"
239+ , " psc-docs src/**/*.purs bower_components/*/src/**/*.purs \\"
240+ , " --docgen Data.List"
241+ , ""
242+ , " write documentation for Data.List to docs/Data.List.md:"
243+ , " psc-docs src/**/*.purs bower_components/*/src/**/*.purs \\"
244+ , " --docgen Data.List:docs/Data.List.md"
245+ , ""
246+ , " write documentation for Data.List to docs/Data.List.md, and"
247+ , " documentation for Data.List.Lazy to docs/Data.List.Lazy.md:"
248+ , " psc-docs src/**/*.purs bower_components/*/src/**/*.purs \\"
249+ , " --docgen Data.List:docs/Data.List.md \\"
250+ , " --docgen Data.List.Lazy:docs/Data.List.Lazy.md"
251+ ]
psc-docs/Tags.hsnew file+18
@@ -0,0 +1,18 @@
1+module Tags where
2+
3+import qualified Language.PureScript as P
4+
5+tags :: P.Module -> [(String, Int)]
6+tags = concatMap dtags . P.exportedDeclarations
7+ where dtags (P.PositionedDeclaration sp _ d) = map tag $ names d
8+ where tag name = (name, line)
9+ line = P.sourcePosLine $ P.spanStart sp
10+ dtags _ = []
11+ names (P.DataDeclaration _ name _ dcons) = P.runProperName name : consNames
12+ where consNames = map (\(cname, _) -> P.runProperName cname) dcons
13+ names (P.TypeDeclaration ident _) = [show ident]
14+ names (P.ExternDeclaration ident _) = [show ident]
15+ names (P.TypeSynonymDeclaration name _ _) = [P.runProperName name]
16+ names (P.TypeClassDeclaration name _ _ _) = [P.runProperName name]
17+ names (P.TypeInstanceDeclaration name _ _ _ _) = [show name]
18+ names _ = []
psc-make/Main.hsnew file+176
@@ -0,0 +1,176 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Main
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+--
13+-----------------------------------------------------------------------------
14+
15+{-# LANGUAGE DataKinds #-}
16+{-# LANGUAGE FlexibleContexts #-}
17+{-# LANGUAGE RecordWildCards #-}
18+{-# LANGUAGE TupleSections #-}
19+
20+module Main where
21+
22+import Control.Applicative
23+import Control.Monad
24+import Control.Monad.Error.Class (MonadError(..))
25+import Control.Monad.Writer
26+
27+import Data.Version (showVersion)
28+import qualified Data.Map as M
29+
30+import Options.Applicative as Opts
31+
32+import System.Exit (exitSuccess, exitFailure)
33+import System.IO (hPutStrLn, stderr)
34+import System.FilePath.Glob (glob)
35+
36+import qualified Language.PureScript as P
37+import qualified Paths_purescript as Paths
38+
39+import Make
40+
41+data PSCMakeOptions = PSCMakeOptions
42+ { pscmInput :: [FilePath]
43+ , pscmForeignInput :: [FilePath]
44+ , pscmOutputDir :: FilePath
45+ , pscmOpts :: P.Options P.Make
46+ , pscmUsePrefix :: Bool
47+ }
48+
49+data InputOptions = InputOptions
50+ { ioInputFiles :: [FilePath]
51+ }
52+
53+compile :: PSCMakeOptions -> IO ()
54+compile (PSCMakeOptions inputGlob inputForeignGlob outputDir opts usePrefix) = do
55+ input <- concat <$> mapM glob inputGlob
56+ moduleFiles <- readInput (InputOptions input)
57+ inputForeign <- concat <$> mapM glob inputForeignGlob
58+ foreignFiles <- forM inputForeign (\inFile -> (inFile,) <$> readFile inFile)
59+ case runWriterT (parseInputs moduleFiles foreignFiles) of
60+ Left errs -> do
61+ hPutStrLn stderr (P.prettyPrintMultipleErrors (P.optionsVerboseErrors opts) errs)
62+ exitFailure
63+ Right ((ms, foreigns), warnings) -> do
64+ when (P.nonEmpty warnings) $
65+ hPutStrLn stderr (P.prettyPrintMultipleWarnings (P.optionsVerboseErrors opts) warnings)
66+ let filePathMap = M.fromList $ map (\(fp, P.Module _ mn _ _) -> (mn, fp)) ms
67+ makeActions = buildMakeActions outputDir filePathMap foreigns usePrefix
68+ e <- runMake opts $ P.make makeActions ms
69+ case e of
70+ Left errs -> do
71+ putStrLn (P.prettyPrintMultipleErrors (P.optionsVerboseErrors opts) errs)
72+ exitFailure
73+ Right (_, warnings') -> do
74+ when (P.nonEmpty warnings') $
75+ putStrLn (P.prettyPrintMultipleWarnings (P.optionsVerboseErrors opts) warnings')
76+ exitSuccess
77+
78+readInput :: InputOptions -> IO [(Either P.RebuildPolicy FilePath, String)]
79+readInput InputOptions{..} = forM ioInputFiles $ \inFile -> (Right inFile, ) <$> readFile inFile
80+
81+parseInputs :: (Functor m, Applicative m, MonadError P.MultipleErrors m, MonadWriter P.MultipleErrors m)
82+ => [(Either P.RebuildPolicy FilePath, String)]
83+ -> [(FilePath, P.ForeignJS)]
84+ -> m ([(Either P.RebuildPolicy FilePath, P.Module)], M.Map P.ModuleName (FilePath, P.ForeignJS))
85+parseInputs modules foreigns =
86+ (,) <$> P.parseModulesFromFiles (either (const "") id) modules
87+ <*> P.parseForeignModulesFromFiles foreigns
88+
89+inputFile :: Parser FilePath
90+inputFile = strArgument $
91+ metavar "FILE"
92+ <> help "The input .purs file(s)"
93+
94+inputForeignFile :: Parser FilePath
95+inputForeignFile = strOption $
96+ short 'f'
97+ <> long "ffi"
98+ <> help "The input .js file(s) providing foreign import implementations"
99+
100+outputDirectory :: Parser FilePath
101+outputDirectory = strOption $
102+ short 'o'
103+ <> long "output"
104+ <> Opts.value "output"
105+ <> showDefault
106+ <> help "The output directory"
107+
108+requirePath :: Parser (Maybe FilePath)
109+requirePath = optional $ strOption $
110+ short 'r'
111+ <> long "require-path"
112+ <> help "The path prefix to use for require() calls in the generated JavaScript"
113+
114+noTco :: Parser Bool
115+noTco = switch $
116+ long "no-tco"
117+ <> help "Disable tail call optimizations"
118+
119+noMagicDo :: Parser Bool
120+noMagicDo = switch $
121+ long "no-magic-do"
122+ <> help "Disable the optimization that overloads the do keyword to generate efficient code specifically for the Eff monad"
123+
124+noOpts :: Parser Bool
125+noOpts = switch $
126+ long "no-opts"
127+ <> help "Skip the optimization phase"
128+
129+comments :: Parser Bool
130+comments = switch $
131+ short 'c'
132+ <> long "comments"
133+ <> help "Include comments in the generated code"
134+
135+verboseErrors :: Parser Bool
136+verboseErrors = switch $
137+ short 'v'
138+ <> long "verbose-errors"
139+ <> help "Display verbose error messages"
140+
141+noPrefix :: Parser Bool
142+noPrefix = switch $
143+ short 'p'
144+ <> long "no-prefix"
145+ <> help "Do not include comment header"
146+
147+
148+options :: Parser (P.Options P.Make)
149+options = P.Options <$> noTco
150+ <*> noMagicDo
151+ <*> pure Nothing
152+ <*> noOpts
153+ <*> verboseErrors
154+ <*> (not <$> comments)
155+ <*> additionalOptions
156+ where
157+ additionalOptions =
158+ P.MakeOptions <$> requirePath
159+
160+pscMakeOptions :: Parser PSCMakeOptions
161+pscMakeOptions = PSCMakeOptions <$> many inputFile
162+ <*> many inputForeignFile
163+ <*> outputDirectory
164+ <*> options
165+ <*> (not <$> noPrefix)
166+
167+main :: IO ()
168+main = execParser opts >>= compile
169+ where
170+ opts = info (version <*> helper <*> pscMakeOptions) infoModList
171+ infoModList = fullDesc <> headerInfo <> footerInfo
172+ headerInfo = header "psc-make - Compiles PureScript to Javascript"
173+ footerInfo = footer $ "psc-make " ++ showVersion Paths.version
174+
175+ version :: Parser (a -> a)
176+ version = abortOption (InfoMsg (showVersion Paths.version)) $ long "version" <> help "Show the version number" <> hidden
psc-make/Make.hsnew file+140
@@ -0,0 +1,140 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Make
4+-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+--
13+-----------------------------------------------------------------------------
14+
15+{-# LANGUAGE DataKinds #-}
16+{-# LANGUAGE FlexibleContexts #-}
17+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
18+{-# LANGUAGE TupleSections #-}
19+
20+module Make
21+ ( Make(..)
22+ , runMake
23+ , buildMakeActions
24+ ) where
25+
26+import Control.Applicative
27+import Control.Monad
28+import Control.Monad.Error.Class (MonadError(..))
29+import Control.Monad.Trans.Except
30+import Control.Monad.Reader
31+import Control.Monad.Writer
32+
33+import Data.Maybe (fromMaybe)
34+import Data.Time.Clock
35+import Data.Traversable (traverse)
36+import Data.Version (showVersion)
37+import qualified Data.Map as M
38+
39+import System.Directory
40+ (doesFileExist, getModificationTime, createDirectoryIfMissing)
41+import System.FilePath ((</>), takeDirectory)
42+import System.IO.Error (tryIOError)
43+
44+import qualified Language.PureScript as P
45+import qualified Language.PureScript.CodeGen.JS as J
46+import qualified Language.PureScript.CoreFn as CF
47+import qualified Paths_purescript as Paths
48+
49+newtype Make a = Make { unMake :: ReaderT (P.Options P.Make) (WriterT P.MultipleErrors (ExceptT P.MultipleErrors IO)) a }
50+ deriving (Functor, Applicative, Monad, MonadIO, MonadError P.MultipleErrors, MonadWriter P.MultipleErrors, MonadReader (P.Options P.Make))
51+
52+runMake :: P.Options P.Make -> Make a -> IO (Either P.MultipleErrors (a, P.MultipleErrors))
53+runMake opts = runExceptT . runWriterT . flip runReaderT opts . unMake
54+
55+makeIO :: (IOError -> P.ErrorMessage) -> IO a -> Make a
56+makeIO f io = do
57+ e <- liftIO $ tryIOError io
58+ either (throwError . P.singleError . f) return e
59+
60+-- Traverse (Either e) instance (base 4.7)
61+traverseEither :: Applicative f => (a -> f b) -> Either e a -> f (Either e b)
62+traverseEither _ (Left x) = pure (Left x)
63+traverseEither f (Right y) = Right <$> f y
64+
65+buildMakeActions :: FilePath
66+ -> M.Map P.ModuleName (Either P.RebuildPolicy String)
67+ -> M.Map P.ModuleName (FilePath, P.ForeignJS)
68+ -> Bool
69+ -> P.MakeActions Make
70+buildMakeActions outputDir filePathMap foreigns usePrefix =
71+ P.MakeActions getInputTimestamp getOutputTimestamp readExterns codegen progress
72+ where
73+
74+ getInputTimestamp :: P.ModuleName -> Make (Either P.RebuildPolicy (Maybe UTCTime))
75+ getInputTimestamp mn = do
76+ let path = fromMaybe (error "Module has no filename in 'make'") $ M.lookup mn filePathMap
77+ e1 <- traverseEither getTimestamp path
78+ fPath <- maybe (return Nothing) (getTimestamp . fst) $ M.lookup mn foreigns
79+ return $ fmap (max fPath) e1
80+
81+ getOutputTimestamp :: P.ModuleName -> Make (Maybe UTCTime)
82+ getOutputTimestamp mn = do
83+ let filePath = P.runModuleName mn
84+ jsFile = outputDir </> filePath </> "index.js"
85+ externsFile = outputDir </> filePath </> "externs.purs"
86+ min <$> getTimestamp jsFile <*> getTimestamp externsFile
87+
88+ readExterns :: P.ModuleName -> Make (FilePath, String)
89+ readExterns mn = do
90+ let path = outputDir </> P.runModuleName mn </> "externs.purs"
91+ (path, ) <$> readTextFile path
92+
93+ codegen :: CF.Module CF.Ann -> P.Environment -> P.SupplyVar -> P.Externs -> Make ()
94+ codegen m _ nextVar exts = do
95+ let mn = CF.moduleName m
96+ foreignInclude <- case mn `M.lookup` foreigns of
97+ Just (path, _)
98+ | not $ requiresForeign m -> do
99+ tell $ P.errorMessage $ P.UnnecessaryFFIModule mn path
100+ return Nothing
101+ | otherwise -> return $ Just $ J.JSApp (J.JSVar "require") [J.JSStringLiteral "./foreign"]
102+ Nothing | requiresForeign m -> throwError . P.errorMessage $ P.MissingFFIModule mn
103+ | otherwise -> return Nothing
104+ pjs <- P.evalSupplyT nextVar $ P.prettyPrintJS <$> J.moduleToJs m foreignInclude
105+ let filePath = P.runModuleName mn
106+ jsFile = outputDir </> filePath </> "index.js"
107+ externsFile = outputDir </> filePath </> "externs.purs"
108+ foreignFile = outputDir </> filePath </> "foreign.js"
109+ prefix = ["Generated by psc-make version " ++ showVersion Paths.version | usePrefix]
110+ js = unlines $ map ("// " ++) prefix ++ [pjs]
111+ writeTextFile jsFile js
112+ maybe (return ()) (writeTextFile foreignFile . snd) $ mn `M.lookup` foreigns
113+ writeTextFile externsFile exts
114+
115+ requiresForeign :: CF.Module a -> Bool
116+ requiresForeign = not . null . CF.moduleForeign
117+
118+ getTimestamp :: FilePath -> Make (Maybe UTCTime)
119+ getTimestamp path = makeIO (const (P.SimpleErrorWrapper $ P.CannotGetFileInfo path)) $ do
120+ exists <- doesFileExist path
121+ traverse (const $ getModificationTime path) $ guard exists
122+
123+ readTextFile :: FilePath -> Make String
124+ readTextFile path = do
125+ verboseErrorsEnabled <- asks P.optionsVerboseErrors
126+ makeIO (const (P.SimpleErrorWrapper $ P.CannotReadFile path)) $ do
127+ when verboseErrorsEnabled $ putStrLn $ "Reading " ++ path
128+ readFile path
129+
130+ writeTextFile :: FilePath -> String -> Make ()
131+ writeTextFile path text = makeIO (const (P.SimpleErrorWrapper $ P.CannotWriteFile path)) $ do
132+ mkdirp path
133+ putStrLn $ "Writing " ++ path
134+ writeFile path text
135+ where
136+ mkdirp :: FilePath -> IO ()
137+ mkdirp = createDirectoryIfMissing True . takeDirectory
138+
139+ progress :: String -> Make ()
140+ progress = liftIO . putStrLn
psc-publish/BoxesHelpers.hsnew file+38
@@ -0,0 +1,38 @@
1+module BoxesHelpers
2+ ( Boxes.Box
3+ , Boxes.nullBox
4+ , module BoxesHelpers
5+ ) where
6+
7+import System.IO (hPutStr, stderr)
8+import qualified Text.PrettyPrint.Boxes as Boxes
9+
10+width :: Int
11+width = 79
12+
13+indentWidth :: Int
14+indentWidth = 2
15+
16+para :: String -> Boxes.Box
17+para = Boxes.para Boxes.left width
18+
19+indented :: Boxes.Box -> Boxes.Box
20+indented b = Boxes.hcat Boxes.left [Boxes.emptyBox 1 indentWidth, b]
21+
22+successivelyIndented :: [String] -> Boxes.Box
23+successivelyIndented [] =
24+ Boxes.nullBox
25+successivelyIndented (x:xs) =
26+ Boxes.vcat Boxes.left [para x, indented (successivelyIndented xs)]
27+
28+vcat :: [Boxes.Box] -> Boxes.Box
29+vcat = Boxes.vcat Boxes.left
30+
31+spacer :: Boxes.Box
32+spacer = Boxes.emptyBox 1 1
33+
34+bulletedList :: (a -> String) -> [a] -> [Boxes.Box]
35+bulletedList f = map (indented . para . ("* " ++) . f)
36+
37+printToStderr :: Boxes.Box -> IO ()
38+printToStderr = hPutStr stderr . Boxes.render
psc-publish/ErrorsWarnings.hsnew file+318
@@ -0,0 +1,318 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+
3+module ErrorsWarnings where
4+
5+import Data.Aeson.BetterErrors
6+import Data.Version
7+import Data.Maybe
8+import Data.List (intersperse)
9+import Data.List.NonEmpty (NonEmpty(..))
10+import qualified Data.List.NonEmpty as NonEmpty
11+
12+import qualified Data.Text as T
13+
14+import Control.Exception (IOException)
15+import Web.Bower.PackageMeta (BowerError, PackageName, runPackageName)
16+import qualified Web.Bower.PackageMeta as Bower
17+
18+import qualified Language.PureScript as P
19+import qualified Language.PureScript.Docs as D
20+
21+import BoxesHelpers
22+
23+-- | An error which meant that it was not possible to retrieve metadata for a
24+-- package.
25+data PackageError
26+ = UserError UserError
27+ | InternalError InternalError
28+ | OtherError OtherError
29+ deriving (Show)
30+
31+data PackageWarning
32+ = ResolutionNotVersion PackageName
33+ | UndeclaredDependency PackageName
34+ deriving (Show)
35+
36+-- | An error that should be fixed by the user.
37+data UserError
38+ = BowerJSONNotFound
39+ | CouldntParseBowerJSON (ParseError BowerError)
40+ | BowerJSONNameMissing
41+ | TagMustBeCheckedOut
42+ | AmbiguousVersions [Version] -- Invariant: should contain at least two elements
43+ | BadRepositoryField RepositoryFieldError
44+ | MissingDependencies (NonEmpty PackageName)
45+ | ParseAndDesugarError D.ParseDesugarError
46+ deriving (Show)
47+
48+data RepositoryFieldError
49+ = RepositoryFieldMissing
50+ | BadRepositoryType String
51+ | NotOnGithub
52+ deriving (Show)
53+
54+-- | An error that probably indicates a bug in this module.
55+data InternalError
56+ = JSONError JSONSource (ParseError BowerError)
57+ deriving (Show)
58+
59+data JSONSource
60+ = FromFile FilePath
61+ | FromBowerList
62+ deriving (Show)
63+
64+data OtherError
65+ = ProcessFailed String [String] IOException
66+ | IOExceptionThrown IOException
67+ deriving (Show)
68+
69+printError :: PackageError -> IO ()
70+printError = printToStderr . renderError
71+
72+renderError :: PackageError -> Box
73+renderError err =
74+ case err of
75+ UserError e ->
76+ vcat
77+ [ para (concat
78+ [ "There is a problem with your package, which meant that "
79+ , "it could not be published."
80+ ])
81+ , para "Details:"
82+ , indented (displayUserError e)
83+ ]
84+ InternalError e ->
85+ vcat
86+ [ para "Internal error: this is probably a bug. Please report it:"
87+ , indented (para "https://github.com/purescript/purescript/issues/new")
88+ , spacer
89+ , para "Details:"
90+ , successivelyIndented (displayInternalError e)
91+ ]
92+ OtherError e ->
93+ vcat
94+ [ para "An error occurred, and your package could not be published."
95+ , para "Details:"
96+ , indented (displayOtherError e)
97+ ]
98+
99+displayUserError :: UserError -> Box
100+displayUserError e = case e of
101+ BowerJSONNotFound ->
102+ para (concat
103+ [ "The bower.json file was not found. Please create one, or run "
104+ , "`pulp init`."
105+ ])
106+ CouldntParseBowerJSON err ->
107+ vcat
108+ [ successivelyIndented
109+ [ "The bower.json file could not be parsed as JSON:"
110+ , "aeson reported: " ++ show err
111+ ]
112+ , para "Please ensure that your bower.json file is valid JSON."
113+ ]
114+ BowerJSONNameMissing ->
115+ vcat
116+ [ successivelyIndented
117+ [ "In bower.json:"
118+ , "the \"name\" key was not found."
119+ ]
120+ , para "Please give your package a name first."
121+ ]
122+ TagMustBeCheckedOut ->
123+ vcat
124+ [ para (concat
125+ [ "psc-publish requires a tagged version to be checked out in "
126+ , "order to build documentation, and no suitable tag was found. "
127+ , "Please check out a previously tagged version, or tag a new "
128+ , "version."
129+ ])
130+ , spacer
131+ , para "Note: tagged versions must be in one of the following forms:"
132+ , indented (para "* v{MAJOR}.{MINOR}.{PATCH} (example: \"v1.6.2\")")
133+ , indented (para "* {MAJOR}.{MINOR}.{PATCH} (example: \"1.6.2\")")
134+ ]
135+ AmbiguousVersions vs ->
136+ vcat $
137+ [ para (concat
138+ [ "The currently checked out commit seems to have been tagged with "
139+ , "more than 1 version, and I don't know which one should be used. "
140+ , "Please either delete some of the tags, or create a new commit "
141+ , "to tag the desired verson with."
142+ ])
143+ , spacer
144+ , para "Tags for the currently checked out commit:"
145+ ] ++ bulletedList showVersion vs
146+ BadRepositoryField err ->
147+ displayRepositoryError err
148+ MissingDependencies pkgs ->
149+ let singular = NonEmpty.length pkgs == 1
150+ pl a b = if singular then b else a
151+ do_ = pl "do" "does"
152+ dependencies = pl "dependencies" "dependency"
153+ them = pl "them" "it"
154+ in vcat $
155+ [ para (concat
156+ [ "The following Bower ", dependencies, " ", do_, " not appear to be "
157+ , "installed:"
158+ ])
159+ ] ++
160+ bulletedList runPackageName (NonEmpty.toList pkgs)
161+ ++
162+ [ spacer
163+ , para (concat
164+ [ "Please install ", them, " first, by running `bower install`."
165+ ])
166+ ]
167+ ParseAndDesugarError (D.ParseError err) ->
168+ vcat
169+ [ para "Parse error:"
170+ , indented (para (show err))
171+ ]
172+ ParseAndDesugarError (D.SortModulesError err) ->
173+ vcat
174+ [ para "Error in sortModules:"
175+ , indented (para (P.prettyPrintMultipleErrors False err))
176+ ]
177+ ParseAndDesugarError (D.DesugarError err) ->
178+ vcat
179+ [ para "Error while desugaring:"
180+ , indented (para (P.prettyPrintMultipleErrors False err))
181+ ]
182+
183+displayRepositoryError :: RepositoryFieldError -> Box
184+displayRepositoryError err = case err of
185+ RepositoryFieldMissing ->
186+ vcat
187+ [ para (concat
188+ [ "The 'repository' field is not present in your bower.json file. "
189+ , "Without this information, Pursuit would not be able to generate "
190+ , "source links in your package's documentation. Please add one - like "
191+ , "this, for example:"
192+ ])
193+ , spacer
194+ , indented (vcat
195+ [ para "\"repository\": {"
196+ , indented (para "\"type\": \"git\",")
197+ , indented (para "\"url\": \"git://github.com/purescript/purescript-prelude.git\"")
198+ , para "}"
199+ ]
200+ )
201+ ]
202+ BadRepositoryType ty ->
203+ para (concat
204+ [ "In your bower.json file, the repository type is currently listed as "
205+ , "\"" ++ ty ++ "\". Currently, only git repositories are supported. "
206+ , "Please publish your code in a git repository, and then update the "
207+ , "repository type in your bower.json file to \"git\"."
208+ ])
209+ NotOnGithub ->
210+ vcat
211+ [ para (concat
212+ [ "The repository url in your bower.json file does not point to a "
213+ , "GitHub repository. Currently, Pursuit does not support packages "
214+ , "which are not hosted on GitHub."
215+ ])
216+ , spacer
217+ , para (concat
218+ [ "Please update your bower.json file to point to a GitHub repository. "
219+ , "Alternatively, if you would prefer not to host your package on "
220+ , "GitHub, please open an issue:"
221+ ])
222+ , indented (para "https://github.com/purescript/purescript/issues/new")
223+ ]
224+
225+displayInternalError :: InternalError -> [String]
226+displayInternalError e = case e of
227+ JSONError src r ->
228+ [ "Error in JSON " ++ displayJSONSource src ++ ":"
229+ , T.unpack (Bower.displayError r)
230+ ]
231+
232+displayJSONSource :: JSONSource -> String
233+displayJSONSource s = case s of
234+ FromFile fp ->
235+ "in file " ++ show fp
236+ FromBowerList ->
237+ "in the output of `bower list --json --offline`"
238+
239+displayOtherError :: OtherError -> Box
240+displayOtherError e = case e of
241+ ProcessFailed prog args exc ->
242+ successivelyIndented
243+ [ "While running `" ++ prog ++ " " ++ unwords args ++ "`:"
244+ , show exc
245+ ]
246+ IOExceptionThrown exc ->
247+ successivelyIndented
248+ [ "An IO exception occurred:", show exc ]
249+
250+renderWarnings :: [PackageWarning] -> Box
251+renderWarnings =
252+ collectWarnings
253+ [ (getResolutionNotVersion, warnResolutionNotVersions)
254+ , (getUndeclaredDependency, warnUndeclaredDependencies)
255+ ]
256+ where
257+ collectWarnings patterns warns =
258+ let boxes = mapMaybe (collectWarnings' warns) patterns
259+ result = vcat
260+ [ para "Warnings:"
261+ , indented (vcat (intersperse spacer boxes))
262+ ]
263+ in if null boxes then nullBox else result
264+
265+ getResolutionNotVersion (ResolutionNotVersion n) = Just n
266+ getResolutionNotVersion _ = Nothing
267+
268+ getUndeclaredDependency (UndeclaredDependency n) = Just n
269+ getUndeclaredDependency _ = Nothing
270+
271+collectWarnings' :: [PackageWarning] -> ((PackageWarning -> Maybe a), (NonEmpty a -> Box)) -> Maybe Box
272+collectWarnings' warns (pattern, render) =
273+ case mapMaybe pattern warns of
274+ [] -> Nothing
275+ (x:xs) -> Just (render (x :| xs))
276+
277+warnResolutionNotVersions :: NonEmpty PackageName -> Box
278+warnResolutionNotVersions pkgNames =
279+ let singular = NonEmpty.length pkgNames == 1
280+ pl a b = if singular then b else a
281+
282+ packages = pl "packages" "package"
283+ were = pl "were" "was"
284+ anyOfThese = pl "any of these" "this"
285+ these = pl "these" "this"
286+ in vcat $
287+ [ para (concat
288+ ["The following ", packages, " ", were, " not resolved to a version:"])
289+ ] ++
290+ bulletedList runPackageName (NonEmpty.toList pkgNames)
291+ ++
292+ [ spacer
293+ , para (concat
294+ ["Links to types in ", anyOfThese, " ", packages, " will not work. In "
295+ , "order to make links work, edit your bower.json to specify a version"
296+ , " or a version range for ", these, " ", packages, ", and rerun "
297+ , "`bower install`."
298+ ])
299+ ]
300+
301+warnUndeclaredDependencies :: NonEmpty PackageName -> Box
302+warnUndeclaredDependencies pkgNames =
303+ let singular = NonEmpty.length pkgNames == 1
304+ pl a b = if singular then b else a
305+
306+ packages = pl "packages" "package"
307+ are = pl "are" "is"
308+ dependencies = pl "dependencies" "a dependency"
309+ in vcat $
310+ [ para (concat
311+ [ "The following Bower ", packages, " ", are, " installed, but not "
312+ , "declared as ", dependencies, " in your bower.json file:"
313+ ])
314+ ] ++
315+ bulletedList runPackageName (NonEmpty.toList pkgNames)
316+
317+printWarnings :: [PackageWarning] -> IO ()
318+printWarnings = printToStderr . renderWarnings
psc-publish/Main.hsnew file+280
@@ -0,0 +1,280 @@
1+{-# LANGUAGE OverloadedStrings #-}
2+{-# LANGUAGE RecordWildCards #-}
3+{-# LANGUAGE TupleSections #-}
4+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5+
6+import Prelude hiding (userError)
7+
8+import Data.Maybe
9+import Data.Char (isSpace)
10+import Data.String (fromString)
11+import Data.List (stripPrefix, isSuffixOf, (\\))
12+import Data.List.Split (splitOn)
13+import Data.List.NonEmpty (NonEmpty(..))
14+import Data.Version
15+import Safe (headMay)
16+
17+import qualified Data.ByteString.Lazy.Char8 as BL
18+import qualified Data.Text as T
19+
20+import qualified Data.Aeson as A
21+import Data.Aeson.BetterErrors
22+
23+import Control.Applicative
24+import Control.Category ((>>>))
25+import Control.Arrow ((***))
26+import Control.Exception (catch, try)
27+import Control.Monad.Trans.Except
28+import Control.Monad.Error.Class (MonadError(..))
29+import Control.Monad.Writer
30+
31+import System.Directory (doesFileExist)
32+import System.Process (readProcess)
33+import System.Exit (exitFailure)
34+import qualified System.FilePath.Glob as Glob
35+
36+import Web.Bower.PackageMeta (PackageMeta(..), BowerError(..), PackageName,
37+ runPackageName, parsePackageName, Repository(..))
38+import qualified Web.Bower.PackageMeta as Bower
39+
40+import qualified Language.PureScript.Docs as D
41+import Utils
42+import ErrorsWarnings
43+
44+main :: IO ()
45+main = do
46+ pkg <- preparePackage
47+ BL.putStrLn (A.encode pkg)
48+
49+-- | Attempt to retrieve package metadata from the current directory.
50+-- Calls exitFailure if no package metadata could be retrieved.
51+preparePackage :: IO D.UploadedPackage
52+preparePackage =
53+ runPrepareM preparePackage'
54+ >>= either (\e -> printError e >> exitFailure)
55+ handleWarnings
56+ where
57+ handleWarnings (result, warns) = do
58+ printWarnings warns
59+ return result
60+
61+newtype PrepareM a =
62+ PrepareM { unPrepareM :: WriterT [PackageWarning] (ExceptT PackageError IO) a }
63+ deriving (Functor, Applicative, Monad,
64+ MonadWriter [PackageWarning],
65+ MonadError PackageError)
66+
67+-- This MonadIO instance ensures that IO errors don't crash the program.
68+instance MonadIO PrepareM where
69+ liftIO act =
70+ lift' (try act) >>= either (otherError . IOExceptionThrown) return
71+ where
72+ lift' :: IO a -> PrepareM a
73+ lift' = PrepareM . lift . lift
74+
75+runPrepareM :: PrepareM a -> IO (Either PackageError (a, [PackageWarning]))
76+runPrepareM = runExceptT . runWriterT . unPrepareM
77+
78+warn :: PackageWarning -> PrepareM ()
79+warn w = tell [w]
80+
81+userError :: UserError -> PrepareM a
82+userError = throwError . UserError
83+
84+internalError :: InternalError -> PrepareM a
85+internalError = throwError . InternalError
86+
87+otherError :: OtherError -> PrepareM a
88+otherError = throwError . OtherError
89+
90+catchLeft :: Applicative f => Either a b -> (a -> f b) -> f b
91+catchLeft a f = either f pure a
92+
93+preparePackage' :: PrepareM D.UploadedPackage
94+preparePackage' = do
95+ exists <- liftIO (doesFileExist "bower.json")
96+ unless exists (userError BowerJSONNotFound)
97+
98+ pkgMeta <- liftIO (Bower.decodeFile "bower.json")
99+ >>= flip catchLeft (userError . CouldntParseBowerJSON)
100+ (pkgVersionTag, pkgVersion) <- getVersionFromGitTag
101+ pkgGithub <- getBowerInfo pkgMeta
102+ (pkgBookmarks, pkgModules) <- getModulesAndBookmarks
103+
104+ let declaredDeps = map fst (bowerDependencies pkgMeta ++
105+ bowerDevDependencies pkgMeta)
106+ pkgResolvedDependencies <- getResolvedDependencies declaredDeps
107+
108+ let pkgUploader = D.NotYetKnown
109+
110+ return D.Package{..}
111+
112+getModulesAndBookmarks :: PrepareM ([D.Bookmark], [D.Module])
113+getModulesAndBookmarks = do
114+ (inputFiles, depsFiles) <- liftIO getInputAndDepsFiles
115+ liftIO (D.parseAndDesugar inputFiles depsFiles renderModules)
116+ >>= either (userError . ParseAndDesugarError) return
117+ where
118+ renderModules bookmarks modules =
119+ return (bookmarks, map D.convertModule modules)
120+
121+getVersionFromGitTag :: PrepareM (String, Version)
122+getVersionFromGitTag = do
123+ out <- readProcess' "git" ["tag", "--list", "--points-at", "HEAD"] ""
124+ let vs = map trimWhitespace (lines out)
125+ case mapMaybe parseMay vs of
126+ [] -> userError TagMustBeCheckedOut
127+ [x] -> return x
128+ xs -> userError (AmbiguousVersions (map snd xs))
129+ where
130+ trimWhitespace =
131+ dropWhile isSpace >>> reverse >>> dropWhile isSpace >>> reverse
132+ parseMay str =
133+ (str,) <$> D.parseVersion' (dropPrefix "v" str)
134+ dropPrefix prefix str =
135+ fromMaybe str (stripPrefix prefix str)
136+
137+getBowerInfo :: PackageMeta -> PrepareM (D.GithubUser, D.GithubRepo)
138+getBowerInfo = either (userError . BadRepositoryField) return . tryExtract
139+ where
140+ tryExtract pkgMeta =
141+ case bowerRepository pkgMeta of
142+ Nothing -> Left RepositoryFieldMissing
143+ Just Repository{..} -> do
144+ unless (repositoryType == "git")
145+ (Left (BadRepositoryType repositoryType))
146+ maybe (Left NotOnGithub) Right (extractGithub repositoryUrl)
147+
148+extractGithub :: String -> Maybe (D.GithubUser, D.GithubRepo)
149+extractGithub =
150+ stripPrefix "git://github.com/"
151+ >>> fmap (splitOn "/")
152+ >=> takeTwo
153+ >>> fmap (D.GithubUser *** (D.GithubRepo . dropDotGit))
154+
155+ where
156+ takeTwo :: [a] -> Maybe (a, a)
157+ takeTwo [x, y] = Just (x, y)
158+ takeTwo _ = Nothing
159+
160+ dropDotGit :: String -> String
161+ dropDotGit str
162+ | ".git" `isSuffixOf` str = take (length str - 4) str
163+ | otherwise = str
164+
165+readProcess' :: String -> [String] -> String -> PrepareM String
166+readProcess' prog args stdin = do
167+ out <- liftIO (catch (Right <$> readProcess prog args stdin)
168+ (return . Left))
169+ either (otherError . ProcessFailed prog args) return out
170+
171+data DependencyStatus
172+ = Missing
173+ | ResolvedOther String
174+ -- ^ Resolved, but to something other than a version. The String argument
175+ -- is the resolution type. The values it can take that I'm aware of are
176+ -- "commit" and "branch".
177+ | ResolvedVersion String
178+ -- ^ Resolved to a version. The String argument is the resolution tag (eg,
179+ -- "v0.1.0").
180+ deriving (Show, Eq)
181+
182+-- Go through all bower dependencies which contain purescript code, and
183+-- extract their versions.
184+--
185+-- In the case where a bower dependency is taken from a particular version,
186+-- that's easy; take that version. In any other case (eg, a branch, or a commit
187+-- sha) we print a warning that documentation links will not work, and avoid
188+-- linking to documentation for any types from that package.
189+--
190+-- The rationale for this is: people will prefer to use a released version
191+-- where possible. If they are not using a released version, then this is
192+-- probably for a reason. However, docs are only ever available for released
193+-- versions. Therefore there will probably be no version of the docs which is
194+-- appropriate to link to, and we should omit links.
195+getResolvedDependencies :: [PackageName] -> PrepareM [(PackageName, Version)]
196+getResolvedDependencies declaredDeps = do
197+ depsBS <- fromString <$> readProcess' "bower" ["list", "--json", "--offline"] ""
198+
199+ deps <- catchLeft (parse asBowerResolvedDependencies depsBS)
200+ (internalError . JSONError FromBowerList)
201+
202+ warnUndeclared declaredDeps (map fst deps)
203+ handleDeps deps
204+
205+ where
206+ asBowerResolvedDependencies ::
207+ Parse BowerError [(PackageName, DependencyStatus)]
208+ asBowerResolvedDependencies =
209+ key "dependencies"
210+ (eachInObjectWithKey (parsePackageName . T.unpack) asDependencyStatus)
211+
212+asDependencyStatus :: Parse e DependencyStatus
213+asDependencyStatus = do
214+ isMissing <- keyOrDefault "missing" False asBool
215+ if isMissing
216+ then
217+ return Missing
218+ else
219+ key "pkgMeta" $
220+ key "_resolution" $ do
221+ type_ <- key "type" asString
222+ case type_ of
223+ "version" -> ResolvedVersion <$> key "tag" asString
224+ other -> return (ResolvedOther other)
225+
226+warnUndeclared :: [PackageName] -> [PackageName] -> PrepareM ()
227+warnUndeclared declared actual =
228+ mapM_ (warn . UndeclaredDependency) (actual \\ declared)
229+
230+handleDeps ::
231+ [(PackageName, DependencyStatus)] -> PrepareM [(PackageName, Version)]
232+handleDeps deps = do
233+ let (missing, notVersion, installed) = partitionDeps deps
234+ case missing of
235+ (x:xs) ->
236+ userError (MissingDependencies (x :| xs))
237+ [] -> do
238+ mapM_ (warn . ResolutionNotVersion . fst) notVersion
239+ let withVersions = mapMaybe tryExtractVersion installed
240+ filterM (liftIO . isPureScript . bowerDir . fst) withVersions
241+
242+ where
243+ partitionDeps = foldr go ([], [], [])
244+ go (pkgName, d) (ms, os, is) =
245+ case d of
246+ Missing -> (pkgName : ms, os, is)
247+ ResolvedOther o -> (ms, (pkgName, o) : os, is)
248+ ResolvedVersion v -> (ms, os, (pkgName, v) : is)
249+
250+ bowerDir pkgName = "bower_components/" ++ runPackageName pkgName
251+
252+tryExtractVersion :: (PackageName, String) -> Maybe (PackageName, Version)
253+tryExtractVersion (pkgName, tag) =
254+ let tag' = fromMaybe tag (stripPrefix "v" tag)
255+ in (pkgName,) <$> D.parseVersion' tag'
256+
257+-- | Returns whether it looks like there is a purescript package checked out
258+-- in the given directory.
259+isPureScript :: FilePath -> IO Bool
260+isPureScript dir = do
261+ files <- Glob.globDir1 purescriptSourceFiles dir
262+ return (not (null files))
263+
264+getInputAndDepsFiles :: IO ([FilePath], [(PackageName, FilePath)])
265+getInputAndDepsFiles = do
266+ inputFiles <- globRelative purescriptSourceFiles
267+ depsFiles' <- globRelative purescriptDepsFiles
268+ return (inputFiles, mapMaybe withPackageName depsFiles')
269+
270+withPackageName :: FilePath -> Maybe (PackageName, FilePath)
271+withPackageName fp = (,fp) <$> getPackageName fp
272+
273+getPackageName :: FilePath -> Maybe PackageName
274+getPackageName fp = do
275+ let xs = splitOn "/" fp
276+ ys <- stripPrefix ["bower_components"] xs
277+ y <- headMay ys
278+ case Bower.mkPackageName y of
279+ Right name -> Just name
280+ Left _ -> Nothing
psc-publish/Utils.hsnew file+22
@@ -0,0 +1,22 @@
1+
2+module Utils where
3+
4+import Data.List
5+import Data.Maybe
6+import System.Directory
7+import qualified System.FilePath.Glob as Glob
8+
9+-- | Glob relative to the current directory, and produce relative pathnames.
10+globRelative :: Glob.Pattern -> IO [FilePath]
11+globRelative pat = do
12+ currentDir <- getCurrentDirectory
13+ filesAbsolute <- Glob.globDir1 pat currentDir
14+ return (mapMaybe (stripPrefix (currentDir ++ "/")) filesAbsolute)
15+
16+-- | Glob pattern for PureScript source files.
17+purescriptSourceFiles :: Glob.Pattern
18+purescriptSourceFiles = Glob.compile "src/**/*.purs"
19+
20+-- | Glob pattern for PureScript dependency files.
21+purescriptDepsFiles :: Glob.Pattern
22+purescriptDepsFiles = Glob.compile "bower_components/*/src/**/*.purs"
psc-publish/tests/Test.hsnew file+79
@@ -0,0 +1,79 @@
1+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
2+{-# OPTIONS_GHC -fno-warn-unused-imports #-}
3+{-# LANGUAGE ScopedTypeVariables #-}
4+
5+-- | To run these tests:
6+--
7+-- * `cabal repl psc-publish`
8+-- * `:l psc-publish/tests/Test.hs`
9+-- * `test`
10+
11+module Test where
12+
13+import Control.Monad
14+import Control.Applicative
15+import Control.Exception
16+import System.Process
17+import System.Directory
18+import qualified Data.ByteString.Lazy as BL
19+import Data.ByteString.Lazy (ByteString)
20+import qualified Data.Aeson as A
21+import Data.Aeson.BetterErrors
22+
23+import Main
24+import Language.PureScript.Docs
25+
26+pkgName = "purescript-prelude"
27+packageUrl = "https://github.com/purescript/" ++ pkgName
28+packageDir = "tmp/" ++ pkgName
29+
30+pushd :: forall a. FilePath -> IO a -> IO a
31+pushd dir act = do
32+ original <- getCurrentDirectory
33+ setCurrentDirectory dir
34+ result <- try act :: IO (Either IOException a)
35+ setCurrentDirectory original
36+ either throwIO return result
37+
38+clonePackage :: IO ()
39+clonePackage = do
40+ createDirectoryIfMissing True packageDir
41+ pushd packageDir $ do
42+ exists <- doesDirectoryExist ".git"
43+ unless exists $ do
44+ putStrLn ("Cloning " ++ pkgName ++ " into " ++ packageDir ++ "...")
45+ readProcess "git" ["clone", packageUrl, "."] "" >>= putStr
46+ readProcess "git" ["tag", "v999.0.0"] "" >>= putStr
47+
48+bowerInstall :: IO ()
49+bowerInstall = do
50+ pushd packageDir $ do
51+ readProcess "bower" ["install"] "" >>= putStr
52+
53+getPackage :: IO UploadedPackage
54+getPackage = do
55+ clonePackage
56+ bowerInstall
57+ pushd packageDir preparePackage
58+
59+data TestResult
60+ = ParseFailed (ParseError PackageError)
61+ | Mismatch ByteString ByteString -- ^ encoding before, encoding after
62+ | Pass ByteString
63+ deriving (Show)
64+
65+-- | Test JSON encoding/decoding; parse the package, roundtrip to/from JSON,
66+-- and check we get the same string.
67+test :: IO TestResult
68+test = roundTrip <$> getPackage
69+
70+roundTrip :: UploadedPackage -> TestResult
71+roundTrip pkg =
72+ let before = A.encode pkg
73+ in case parse asUploadedPackage before of
74+ Left err -> ParseFailed err
75+ Right parsed -> do
76+ let after = A.encode parsed
77+ if before == after
78+ then Pass before
79+ else Mismatch before after
psc/Main.hsnew file+231
@@ -0,0 +1,231 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Main
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+--
13+-----------------------------------------------------------------------------
14+
15+{-# LANGUAGE DataKinds #-}
16+{-# LANGUAGE FlexibleContexts #-}
17+{-# LANGUAGE RecordWildCards #-}
18+{-# LANGUAGE ScopedTypeVariables #-}
19+{-# LANGUAGE TupleSections #-}
20+
21+module Main where
22+
23+import Control.Applicative
24+import Control.Monad
25+import Control.Monad.Error.Class (MonadError(..))
26+import Control.Monad.Reader
27+import Control.Monad.Writer
28+
29+import Data.Maybe (fromMaybe)
30+import Data.Version (showVersion)
31+
32+import Options.Applicative as Opts
33+
34+import System.Directory (createDirectoryIfMissing)
35+import System.Exit (exitSuccess, exitFailure)
36+import System.FilePath (takeDirectory)
37+import System.FilePath.Glob (glob)
38+import System.IO (hPutStrLn, stderr)
39+
40+import qualified Data.Map as M
41+import qualified Language.PureScript as P
42+import qualified Paths_purescript as Paths
43+
44+data PSCOptions = PSCOptions
45+ { pscInput :: [FilePath]
46+ , pscForeignInput :: [FilePath]
47+ , pscOpts :: P.Options P.Compile
48+ , pscStdIn :: Bool
49+ , pscOutput :: Maybe FilePath
50+ , pscExterns :: Maybe FilePath
51+ , pscUsePrefix :: Bool
52+ }
53+
54+data InputOptions = InputOptions
55+ { ioUseStdIn :: Bool
56+ , ioInputFiles :: [FilePath]
57+ }
58+
59+readInput :: InputOptions -> IO [(Maybe FilePath, String)]
60+readInput InputOptions{..}
61+ | ioUseStdIn = return . (Nothing ,) <$> getContents
62+ | otherwise = forM ioInputFiles $ \inFile -> (Just inFile, ) <$> readFile inFile
63+
64+type PSC = ReaderT (P.Options P.Compile) (WriterT P.MultipleErrors (Either P.MultipleErrors))
65+
66+runPSC :: P.Options P.Compile -> PSC a -> Either P.MultipleErrors (a, P.MultipleErrors)
67+runPSC opts rwe = runWriterT (runReaderT rwe opts)
68+
69+compile :: PSCOptions -> IO ()
70+compile (PSCOptions inputGlob inputForeignGlob opts stdin output externs usePrefix) = do
71+ let prefix = ["Generated by psc version " ++ showVersion Paths.version | usePrefix]
72+ input <- concat <$> mapM glob inputGlob
73+ moduleFiles <- readInput (InputOptions stdin input)
74+ inputForeign <- concat <$> mapM glob inputForeignGlob
75+ foreignFiles <- forM inputForeign (\inFile -> (inFile,) <$> readFile inFile)
76+ case runWriterT (parseInputs moduleFiles foreignFiles) of
77+ Left errs -> do
78+ hPutStrLn stderr (P.prettyPrintMultipleErrors (P.optionsVerboseErrors opts) errs)
79+ exitFailure
80+ Right ((ms, foreigns), warnings) -> do
81+ when (P.nonEmpty warnings) $
82+ hPutStrLn stderr (P.prettyPrintMultipleWarnings (P.optionsVerboseErrors opts) warnings)
83+ case runPSC opts (P.compileJS ms foreigns prefix) of
84+ Left errs -> do
85+ hPutStrLn stderr (P.prettyPrintMultipleErrors (P.optionsVerboseErrors opts) errs)
86+ exitFailure
87+ Right ((js, exts, _), warnings') -> do
88+ when (P.nonEmpty warnings') $
89+ hPutStrLn stderr (P.prettyPrintMultipleWarnings (P.optionsVerboseErrors opts) warnings')
90+ case output of
91+ Just path -> mkdirp path >> writeFile path js
92+ Nothing -> putStrLn js
93+ case externs of
94+ Just path -> mkdirp path >> writeFile path exts
95+ Nothing -> return ()
96+ exitSuccess
97+
98+parseInputs :: (Functor m, Applicative m, MonadError P.MultipleErrors m, MonadWriter P.MultipleErrors m)
99+ => [(Maybe FilePath, String)] -> [(FilePath, P.ForeignJS)] -> m ([P.Module], M.Map P.ModuleName (FilePath, P.ForeignJS))
100+parseInputs modules foreigns =
101+ (,) <$> (map snd <$> P.parseModulesFromFiles (fromMaybe "") modules)
102+ <*> P.parseForeignModulesFromFiles foreigns
103+
104+mkdirp :: FilePath -> IO ()
105+mkdirp = createDirectoryIfMissing True . takeDirectory
106+
107+codeGenModule :: Parser String
108+codeGenModule = strOption $
109+ long "codegen"
110+ <> help "A list of modules for which Javascript and externs should be generated. This argument can be used multiple times."
111+
112+dceModule :: Parser String
113+dceModule = strOption $
114+ short 'm'
115+ <> long "module"
116+ <> help "Enables dead code elimination, all code which is not a transitive dependency of a specified module will be removed. This argument can be used multiple times."
117+
118+browserNamespace :: Parser String
119+browserNamespace = strOption $
120+ long "browser-namespace"
121+ <> Opts.value "PS"
122+ <> showDefault
123+ <> help "Specify the namespace that PureScript modules will be exported to when running in the browser."
124+
125+verboseErrors :: Parser Bool
126+verboseErrors = switch $
127+ short 'v'
128+ <> long "verbose-errors"
129+ <> help "Display verbose error messages"
130+
131+noOpts :: Parser Bool
132+noOpts = switch $
133+ long "no-opts"
134+ <> help "Skip the optimization phase."
135+
136+runMain :: Parser (Maybe String)
137+runMain = optional $ noArgs <|> withArgs
138+ where
139+ defaultVal = "Main"
140+ noArgs = flag' defaultVal (long "main")
141+ withArgs = strOption $
142+ long "main"
143+ <> help (concat [
144+ "Generate code to run the main method in the specified module. ",
145+ "(no argument: \"", defaultVal, "\")"
146+ ])
147+
148+noMagicDo :: Parser Bool
149+noMagicDo = switch $
150+ long "no-magic-do"
151+ <> help "Disable the optimization that overloads the do keyword to generate efficient code specifically for the Eff monad."
152+
153+noTco :: Parser Bool
154+noTco = switch $
155+ long "no-tco"
156+ <> help "Disable tail call optimizations"
157+
158+comments :: Parser Bool
159+comments = switch $
160+ short 'c'
161+ <> long "comments"
162+ <> help "Include comments in the generated code."
163+
164+useStdIn :: Parser Bool
165+useStdIn = switch $
166+ short 's'
167+ <> long "stdin"
168+ <> help "Read from standard input"
169+
170+inputFile :: Parser FilePath
171+inputFile = strArgument $
172+ metavar "FILE"
173+ <> help "The input .purs file(s)"
174+
175+inputForeignFile :: Parser FilePath
176+inputForeignFile = strOption $
177+ short 'f'
178+ <> long "ffi"
179+ <> help "The input .js file(s) providing foreign import implementations"
180+
181+outputFile :: Parser (Maybe FilePath)
182+outputFile = optional . strOption $
183+ short 'o'
184+ <> long "output"
185+ <> help "The output .js file"
186+
187+externsFile :: Parser (Maybe FilePath)
188+externsFile = optional . strOption $
189+ short 'e'
190+ <> long "externs"
191+ <> help "The output .e.purs file"
192+
193+noPrefix :: Parser Bool
194+noPrefix = switch $
195+ short 'p'
196+ <> long "no-prefix"
197+ <> help "Do not include comment header"
198+
199+options :: Parser (P.Options P.Compile)
200+options = P.Options <$> noTco
201+ <*> noMagicDo
202+ <*> runMain
203+ <*> noOpts
204+ <*> verboseErrors
205+ <*> (not <$> comments)
206+ <*> additionalOptions
207+ where
208+ additionalOptions =
209+ P.CompileOptions <$> browserNamespace
210+ <*> many dceModule
211+ <*> many codeGenModule
212+
213+pscOptions :: Parser PSCOptions
214+pscOptions = PSCOptions <$> many inputFile
215+ <*> many inputForeignFile
216+ <*> options
217+ <*> useStdIn
218+ <*> outputFile
219+ <*> externsFile
220+ <*> (not <$> noPrefix)
221+
222+main :: IO ()
223+main = execParser opts >>= compile
224+ where
225+ opts = info (version <*> helper <*> pscOptions) infoModList
226+ infoModList = fullDesc <> headerInfo <> footerInfo
227+ headerInfo = header "psc - Compiles PureScript to Javascript"
228+ footerInfo = footer $ "psc " ++ showVersion Paths.version
229+
230+ version :: Parser (a -> a)
231+ version = abortOption (InfoMsg (showVersion Paths.version)) $ long "version" <> help "Show the version number" <> hidden
psci/Completion.hsnew file+224
@@ -0,0 +1,224 @@
1+module Completion where
2+
3+import Data.Maybe (mapMaybe)
4+import Data.List (nub, nubBy, sortBy, isPrefixOf, stripPrefix)
5+import Data.Char (isUpper)
6+import Data.Function (on)
7+import Data.Traversable (traverse)
8+
9+import Control.Applicative ((<$>), (<*>))
10+import Control.Monad.Trans.Reader (asks, runReaderT, ReaderT)
11+import Control.Monad.Trans.State.Strict
12+
13+import System.Console.Haskeline
14+
15+import qualified Language.PureScript as P
16+import qualified Language.PureScript.Names as N
17+
18+import qualified Directive as D
19+import Types
20+
21+-- Completions may read the state, but not modify it.
22+type CompletionM = ReaderT PSCiState IO
23+
24+-- Lift a `CompletionM` action to a `StateT PSCiState IO` one.
25+liftCompletionM :: CompletionM a -> StateT PSCiState IO a
26+liftCompletionM act = StateT (\s -> (\a -> (a, s)) <$> runReaderT act s)
27+
28+-- Haskeline completions
29+
30+data CompletionContext
31+ = CtxDirective String
32+ | CtxFilePath String
33+ | CtxModule
34+ | CtxIdentifier
35+ | CtxType
36+ | CtxFixed String
37+ deriving (Show)
38+
39+-- |
40+-- Loads module, function, and file completions.
41+--
42+completion :: CompletionFunc (StateT PSCiState IO)
43+completion = liftCompletionM . completion'
44+
45+completion' :: CompletionFunc CompletionM
46+completion' = completeWordWithPrev Nothing " \t\n\r" findCompletions
47+
48+-- |
49+-- Decide what kind of completion we need based on input. This function expects
50+-- a list of complete words (to the left of the cursor) as the first argument,
51+-- and the current word as the second argument.
52+completionContext :: [String] -> String -> [CompletionContext]
53+completionContext [] _ = [CtxDirective "", CtxIdentifier, CtxFixed "import"]
54+completionContext ws w | headSatisfies (":" `isPrefixOf`) ws = completeDirective ws w
55+completionContext ws w | headSatisfies (== "import") ws = completeImport ws w
56+completionContext _ _ = [CtxIdentifier]
57+
58+completeDirective :: [String] -> String -> [CompletionContext]
59+completeDirective ws w =
60+ case ws of
61+ [] -> [CtxDirective w]
62+ [dir] -> case D.directivesFor <$> stripPrefix ":" dir of
63+ -- only offer completions if the directive is unambiguous
64+ Just [dir'] -> directiveArg w dir'
65+ _ -> []
66+
67+ -- All directives take exactly one argument. If we haven't yet matched,
68+ -- that means one argument has already been supplied. So don't complete
69+ -- any others.
70+ _ -> []
71+
72+directiveArg :: String -> Directive -> [CompletionContext]
73+directiveArg _ Browse = [CtxModule]
74+directiveArg w Load = [CtxFilePath w]
75+directiveArg w Foreign = [CtxFilePath w]
76+directiveArg _ Quit = []
77+directiveArg _ Reset = []
78+directiveArg _ Help = []
79+directiveArg _ Show = map CtxFixed replQueryStrings
80+directiveArg _ Type = [CtxIdentifier]
81+directiveArg _ Kind = [CtxType]
82+
83+completeImport :: [String] -> String -> [CompletionContext]
84+completeImport ws w' =
85+ case (ws, w') of
86+ (["import"], w) | headSatisfies isUpper w -> [CtxModule]
87+ (["import"], _) -> [CtxModule, CtxFixed "qualified"]
88+ (["import", "qualified"], _) -> [CtxModule]
89+ _ -> []
90+
91+headSatisfies :: (a -> Bool) -> [a] -> Bool
92+headSatisfies p str =
93+ case str of
94+ (c:_) -> p c
95+ _ -> False
96+
97+-- | Callback for Haskeline's `completeWordWithPrev`.
98+-- Expects:
99+-- * Line contents to the left of the word, reversed
100+-- * Word to be completed
101+findCompletions :: String -> String -> CompletionM [Completion]
102+findCompletions prev word = do
103+ let ctx = completionContext (words (reverse prev)) word
104+ completions <- concat <$> traverse getCompletions ctx
105+ return $ sortBy directivesFirst completions
106+ where
107+ getCompletions :: CompletionContext -> CompletionM [Completion]
108+ getCompletions = fmap (mapMaybe (either (prefixedBy word) Just)) . getCompletion
109+
110+ prefixedBy :: String -> String -> Maybe Completion
111+ prefixedBy w cand = if w `isPrefixOf` cand
112+ then Just (simpleCompletion cand)
113+ else Nothing
114+
115+getCompletion :: CompletionContext -> CompletionM [Either String Completion]
116+getCompletion ctx =
117+ case ctx of
118+ CtxFilePath f -> map Right <$> listFiles f
119+ CtxModule -> map Left <$> getModuleNames
120+ CtxIdentifier -> map Left <$> ((++) <$> getIdentNames <*> getDctorNames)
121+ CtxType -> map Left <$> getTypeNames
122+ CtxFixed str -> return [Left str]
123+ CtxDirective d -> return (map Left (completeDirectives d))
124+
125+ where
126+ completeDirectives :: String -> [String]
127+ completeDirectives = map (':' :) . D.directiveStringsFor
128+
129+
130+getLoadedModules :: CompletionM [P.Module]
131+getLoadedModules = asks (map snd . psciLoadedModules)
132+
133+getImportedModules :: CompletionM [ImportedModule]
134+getImportedModules = asks psciImportedModules
135+
136+getModuleNames :: CompletionM [String]
137+getModuleNames = moduleNames <$> getLoadedModules
138+
139+mapLoadedModulesAndQualify :: (Show a) => (P.Module -> [(a, P.Declaration)]) -> CompletionM [String]
140+mapLoadedModulesAndQualify f = do
141+ ms <- getLoadedModules
142+ let argPairs = do m <- ms
143+ fm <- f m
144+ return (m, fm)
145+ concat <$> traverse (uncurry getAllQualifications) argPairs
146+
147+getIdentNames :: CompletionM [String]
148+getIdentNames = mapLoadedModulesAndQualify identNames
149+
150+getDctorNames :: CompletionM [String]
151+getDctorNames = mapLoadedModulesAndQualify dctorNames
152+
153+getTypeNames :: CompletionM [String]
154+getTypeNames = mapLoadedModulesAndQualify typeDecls
155+
156+-- | Given a module and a declaration in that module, return all possible ways
157+-- it could have been referenced given the current PSCiState - including fully
158+-- qualified, qualified using an alias, and unqualified.
159+getAllQualifications :: (Show a) => P.Module -> (a, P.Declaration) -> CompletionM [String]
160+getAllQualifications m (declName, decl) = do
161+ imports <- getAllImportsOf m
162+ let fullyQualified = qualifyWith (Just (P.getModuleName m))
163+ let otherQuals = nub (concatMap qualificationsUsing imports)
164+ return $ fullyQualified : otherQuals
165+ where
166+ qualifyWith mMod = show (P.Qualified mMod declName)
167+ referencedBy refs = P.isExported (Just refs) decl
168+
169+ qualificationsUsing (_, importType, asQ') =
170+ let q = qualifyWith asQ'
171+ in case importType of
172+ P.Implicit -> [q]
173+ P.Explicit refs -> if referencedBy refs
174+ then [q]
175+ else []
176+ P.Hiding refs -> if referencedBy refs
177+ then []
178+ else [q]
179+
180+
181+-- | Returns all the ImportedModule values referring to imports of a particular
182+-- module.
183+getAllImportsOf :: P.Module -> CompletionM [ImportedModule]
184+getAllImportsOf = asks . allImportsOf
185+
186+nubOnFst :: Eq a => [(a, b)] -> [(a, b)]
187+nubOnFst = nubBy ((==) `on` fst)
188+
189+typeDecls :: P.Module -> [(N.ProperName, P.Declaration)]
190+typeDecls = mapMaybe getTypeName . filter P.isDataDecl . P.exportedDeclarations
191+ where
192+ getTypeName :: P.Declaration -> Maybe (N.ProperName, P.Declaration)
193+ getTypeName d@(P.TypeSynonymDeclaration name _ _) = Just (name, d)
194+ getTypeName d@(P.DataDeclaration _ name _ _) = Just (name, d)
195+ getTypeName (P.PositionedDeclaration _ _ d) = getTypeName d
196+ getTypeName _ = Nothing
197+
198+identNames :: P.Module -> [(N.Ident, P.Declaration)]
199+identNames = nubOnFst . mapMaybe getDeclName . P.exportedDeclarations
200+ where
201+ getDeclName :: P.Declaration -> Maybe (P.Ident, P.Declaration)
202+ getDeclName d@(P.ValueDeclaration ident _ _ _) = Just (ident, d)
203+ getDeclName d@(P.ExternDeclaration ident _) = Just (ident, d)
204+ getDeclName (P.PositionedDeclaration _ _ d) = getDeclName d
205+ getDeclName _ = Nothing
206+
207+dctorNames :: P.Module -> [(N.ProperName, P.Declaration)]
208+dctorNames = nubOnFst . concatMap go . P.exportedDeclarations
209+ where
210+ go :: P.Declaration -> [(N.ProperName, P.Declaration)]
211+ go decl@(P.DataDeclaration _ _ _ ctors) = map (\n -> (n, decl)) (map fst ctors)
212+ go (P.PositionedDeclaration _ _ d) = go d
213+ go _ = []
214+
215+moduleNames :: [P.Module] -> [String]
216+moduleNames ms = nub [show moduleName | P.Module _ moduleName _ _ <- ms]
217+
218+directivesFirst :: Completion -> Completion -> Ordering
219+directivesFirst (Completion _ d1 _) (Completion _ d2 _) = go d1 d2
220+ where
221+ go (':' : xs) (':' : ys) = compare xs ys
222+ go (':' : _) _ = LT
223+ go _ (':' : _) = GT
224+ go xs ys = compare xs ys
psci/Directive.hsnew file+115
@@ -0,0 +1,115 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Directive
4+-- Copyright :
5+-- License : MIT
6+--
7+-- Maintainer :
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- Directives for PSCI.
13+--
14+-----------------------------------------------------------------------------
15+
16+module Directive where
17+
18+import Data.Maybe (fromJust, listToMaybe)
19+import Data.List (isPrefixOf)
20+import Data.Tuple (swap)
21+
22+import Types
23+
24+-- |
25+-- List of all avaliable directives.
26+--
27+directives :: [Directive]
28+directives = map fst directiveStrings
29+
30+-- |
31+-- A mapping of directives to the different strings that can be used to invoke
32+-- them.
33+--
34+directiveStrings :: [(Directive, [String])]
35+directiveStrings =
36+ [ (Help , ["?", "help"])
37+ , (Quit , ["quit"])
38+ , (Reset , ["reset"])
39+ , (Browse , ["browse"])
40+ , (Load , ["load", "module"])
41+ , (Foreign, ["foreign"])
42+ , (Type , ["type"])
43+ , (Kind , ["kind"])
44+ , (Show , ["show"])
45+ ]
46+
47+-- |
48+-- Like directiveStrings, but the other way around.
49+--
50+directiveStrings' :: [(String, Directive)]
51+directiveStrings' = concatMap go directiveStrings
52+ where
53+ go (dir, strs) = map (\s -> (s, dir)) strs
54+
55+-- |
56+-- List of all directive strings.
57+--
58+strings :: [String]
59+strings = concatMap snd directiveStrings
60+
61+-- |
62+-- Returns all possible string representations of a directive.
63+--
64+stringsFor :: Directive -> [String]
65+stringsFor d = fromJust (lookup d directiveStrings)
66+
67+-- |
68+-- Returns the default string representation of a directive.
69+--
70+stringFor :: Directive -> String
71+stringFor = head . stringsFor
72+
73+-- |
74+-- Returns the list of directives which could be expanded from the string
75+-- argument, together with the string alias that matched.
76+--
77+directivesFor' :: String -> [(Directive, String)]
78+directivesFor' str = go directiveStrings'
79+ where
80+ go = map swap . filter ((str `isPrefixOf`) . fst)
81+
82+directivesFor :: String -> [Directive]
83+directivesFor = map fst . directivesFor'
84+
85+directiveStringsFor :: String -> [String]
86+directiveStringsFor = map snd . directivesFor'
87+
88+parseDirective :: String -> Maybe Directive
89+parseDirective = listToMaybe . directivesFor
90+
91+-- |
92+-- True if the given directive takes an argument, false otherwise.
93+hasArgument :: Directive -> Bool
94+hasArgument Help = False
95+hasArgument Quit = False
96+hasArgument Reset = False
97+hasArgument _ = True
98+
99+-- |
100+-- The help menu.
101+--
102+help :: [(Directive, String, String)]
103+help =
104+ [ (Help, "", "Show this help menu")
105+ , (Quit, "", "Quit PSCi")
106+ , (Reset, "", "Discard all imported modules and declared bindings")
107+ , (Browse, "<module>", "See all functions in <module>")
108+ , (Load, "<file>", "Load <file> for importing")
109+ , (Foreign, "<file>", "Load foreign module <file>")
110+ , (Type, "<expr>", "Show the type of <expr>")
111+ , (Kind, "<type>", "Show the kind of <type>")
112+ , (Show, "import", "Show all imported modules")
113+ , (Show, "loaded", "Show all loaded modules")
114+ ]
115+
psci/IO.hsnew file+21
@@ -0,0 +1,21 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : IO
4+-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+--
13+-----------------------------------------------------------------------------
14+
15+module IO where
16+
17+import System.Directory (createDirectoryIfMissing)
18+import System.FilePath (takeDirectory)
19+
20+mkdirp :: FilePath -> IO ()
21+mkdirp = createDirectoryIfMissing True . takeDirectory
psci/Make.hsnew file+127
@@ -0,0 +1,127 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Make
4+-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+--
13+-----------------------------------------------------------------------------
14+
15+{-# LANGUAGE DataKinds #-}
16+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
17+{-# LANGUAGE TupleSections #-}
18+
19+module Make where
20+
21+import Data.List (isPrefixOf)
22+import Data.Maybe (fromMaybe)
23+import Data.Time.Clock
24+import Data.Traversable (traverse)
25+import qualified Data.Map as M
26+
27+import Control.Applicative
28+import Control.Monad
29+import Control.Monad.Error.Class (MonadError(..))
30+import Control.Monad.IO.Class (MonadIO, liftIO)
31+import Control.Monad.Reader (MonadReader, ReaderT, runReaderT)
32+import Control.Monad.Trans.Except (ExceptT(..), runExceptT)
33+import Control.Monad.Writer (MonadWriter, WriterT, runWriterT, tell)
34+
35+import System.Directory (getModificationTime, doesFileExist)
36+import System.FilePath ((</>), pathSeparator)
37+import System.IO.Error (tryIOError)
38+
39+import qualified Language.PureScript as P
40+import qualified Language.PureScript.CodeGen.JS as J
41+import qualified Language.PureScript.CoreFn as CF
42+
43+import IO (mkdirp)
44+
45+options :: P.Options P.Make
46+options = P.Options False False Nothing False False False (P.MakeOptions Nothing)
47+
48+modulesDir :: FilePath
49+modulesDir = ".psci_modules" ++ pathSeparator : "node_modules"
50+
51+newtype Make a = Make { unMake :: ReaderT (P.Options P.Make) (WriterT P.MultipleErrors (ExceptT P.MultipleErrors IO)) a }
52+ deriving (Functor, Applicative, Monad, MonadIO, MonadError P.MultipleErrors, MonadWriter P.MultipleErrors, MonadReader (P.Options P.Make))
53+
54+runMake :: Make a -> IO (Either P.MultipleErrors a)
55+runMake = runExceptT . fmap fst . runWriterT . flip runReaderT options . unMake
56+
57+makeIO :: (IOError -> P.ErrorMessage) -> IO a -> Make a
58+makeIO f io = do
59+ e <- liftIO $ tryIOError io
60+ either (throwError . P.singleError . f) return e
61+
62+-- Traverse (Either e) instance (base 4.7)
63+traverseEither :: Applicative f => (a -> f b) -> Either e a -> f (Either e b)
64+traverseEither _ (Left x) = pure (Left x)
65+traverseEither f (Right y) = Right <$> f y
66+
67+buildMakeActions :: M.Map P.ModuleName (Either P.RebuildPolicy String)
68+ -> M.Map P.ModuleName P.ForeignJS
69+ -> P.MakeActions Make
70+buildMakeActions filePathMap foreigns =
71+ P.MakeActions getInputTimestamp getOutputTimestamp readExterns codegen progress
72+ where
73+
74+ getInputTimestamp :: P.ModuleName -> Make (Either P.RebuildPolicy (Maybe UTCTime))
75+ getInputTimestamp mn = do
76+ let path = fromMaybe (error "Module has no filename in 'make'") $ M.lookup mn filePathMap
77+ traverseEither getTimestamp path
78+
79+ getOutputTimestamp :: P.ModuleName -> Make (Maybe UTCTime)
80+ getOutputTimestamp mn = do
81+ let filePath = P.runModuleName mn
82+ jsFile = modulesDir </> filePath </> "index.js"
83+ externsFile = modulesDir </> filePath </> "externs.purs"
84+ min <$> getTimestamp jsFile <*> getTimestamp externsFile
85+
86+ readExterns :: P.ModuleName -> Make (FilePath, String)
87+ readExterns mn = do
88+ let path = modulesDir </> P.runModuleName mn </> "externs.purs"
89+ (path, ) <$> readTextFile path
90+
91+ codegen :: CF.Module CF.Ann -> P.Environment -> P.SupplyVar -> P.Externs -> Make ()
92+ codegen m _ nextVar exts = do
93+ let mn = CF.moduleName m
94+ foreignInclude <- case CF.moduleName m `M.lookup` foreigns of
95+ Just path
96+ | not $ requiresForeign m -> do tell $ P.errorMessage $ P.UnnecessaryFFIModule mn path
97+ return Nothing
98+ | otherwise -> return $ Just $ J.JSApp (J.JSVar "require") [J.JSStringLiteral "./foreign"]
99+ Nothing | requiresForeign m -> throwError . P.errorMessage $ P.MissingFFIModule mn
100+ | otherwise -> return Nothing
101+ pjs <- P.evalSupplyT nextVar $ P.prettyPrintJS <$> J.moduleToJs m foreignInclude
102+ let filePath = P.runModuleName $ CF.moduleName m
103+ jsFile = modulesDir </> filePath </> "index.js"
104+ externsFile = modulesDir </> filePath </> "externs.purs"
105+ foreignFile = modulesDir </> filePath </> "foreign.js"
106+ writeTextFile jsFile pjs
107+ maybe (return ()) (writeTextFile foreignFile) $ CF.moduleName m `M.lookup` foreigns
108+ writeTextFile externsFile exts
109+
110+ requiresForeign :: CF.Module a -> Bool
111+ requiresForeign = not . null . CF.moduleForeign
112+
113+ getTimestamp :: FilePath -> Make (Maybe UTCTime)
114+ getTimestamp path = makeIO (const (P.SimpleErrorWrapper $ P.CannotGetFileInfo path)) $ do
115+ exists <- doesFileExist path
116+ traverse (const $ getModificationTime path) $ guard exists
117+
118+ readTextFile :: FilePath -> Make String
119+ readTextFile path = makeIO (const (P.SimpleErrorWrapper $ P.CannotReadFile path)) $ readFile path
120+
121+ writeTextFile :: FilePath -> String -> Make ()
122+ writeTextFile path text = makeIO (const (P.SimpleErrorWrapper $ P.CannotWriteFile path)) $ do
123+ mkdirp path
124+ writeFile path text
125+
126+ progress :: String -> Make ()
127+ progress s = unless ("Compiling $PSCI" `isPrefixOf` s) $ liftIO . putStrLn $ s
psci/PSCi.hsnew file+568
@@ -0,0 +1,568 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : PSCi
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- PureScript Compiler Interactive.
13+--
14+-----------------------------------------------------------------------------
15+
16+{-# LANGUAGE DoAndIfThenElse #-}
17+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
18+{-# LANGUAGE RecordWildCards #-}
19+{-# LANGUAGE TupleSections #-}
20+
21+module PSCi where
22+
23+import Data.Foldable (traverse_)
24+import Data.List (intercalate, nub, sort)
25+import Data.Traversable (traverse)
26+import Data.Tuple (swap)
27+import Data.Version (showVersion)
28+import qualified Data.Map as M
29+
30+import Control.Applicative
31+import Control.Arrow (first)
32+import Control.Monad
33+import Control.Monad.Trans.Class
34+import Control.Monad.Trans.Except (runExceptT)
35+import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
36+import Control.Monad.Trans.State.Strict
37+import Control.Monad.Writer (runWriter)
38+import qualified Control.Monad.Trans.State.Lazy as L
39+
40+import Options.Applicative as Opts
41+
42+import System.Console.Haskeline
43+import System.Directory (doesFileExist, findExecutable, getHomeDirectory, getCurrentDirectory)
44+import System.Exit
45+import System.FilePath (pathSeparator, (</>), isPathSeparator)
46+import System.FilePath.Glob (glob)
47+import System.Process (readProcessWithExitCode)
48+
49+import qualified Language.PureScript as P
50+import qualified Language.PureScript.Names as N
51+import qualified Paths_purescript as Paths
52+
53+import qualified Directive as D
54+import Completion (completion)
55+import IO (mkdirp)
56+import Make
57+import Parser (parseCommand)
58+import Types
59+
60+-- | The name of the PSCI support module
61+supportModuleName :: P.ModuleName
62+supportModuleName = P.ModuleName [P.ProperName "$PSCI", P.ProperName "Support"]
63+
64+-- | Support module, contains code to evaluate terms
65+supportModule :: P.Module
66+supportModule =
67+ case P.parseModulesFromFiles id [("", code)] of
68+ Right [(_, P.Module cs _ ds exps)] -> P.Module cs supportModuleName ds exps
69+ _ -> error "Support module could not be parsed"
70+ where
71+ code :: String
72+ code = unlines
73+ [ "module S where"
74+ , ""
75+ , "import Prelude"
76+ , "import Control.Monad.Eff"
77+ , "import Control.Monad.Eff.Console"
78+ , "import Control.Monad.Eff.Unsafe"
79+ , ""
80+ , "class Eval a where"
81+ , " eval :: a -> Eff (console :: CONSOLE) Unit"
82+ , ""
83+ , "instance evalShow :: (Show a) => Eval a where"
84+ , " eval = print"
85+ , ""
86+ , "instance evalEff :: (Eval a) => Eval (Eff eff a) where"
87+ , " eval x = unsafeInterleaveEff x >>= eval"
88+ ]
89+
90+-- File helpers
91+
92+-- |
93+-- Locates the node executable.
94+-- Checks for either @nodejs@ or @node@.
95+--
96+findNodeProcess :: IO (Maybe String)
97+findNodeProcess = runMaybeT . msum $ map (MaybeT . findExecutable) names
98+ where names = ["nodejs", "node"]
99+
100+-- |
101+-- Grabs the filename where the history is stored.
102+--
103+getHistoryFilename :: IO FilePath
104+getHistoryFilename = do
105+ home <- getHomeDirectory
106+ let filename = home </> ".purescript" </> "psci_history"
107+ mkdirp filename
108+ return filename
109+
110+-- |
111+-- Loads a file for use with imports.
112+--
113+loadModule :: FilePath -> IO (Either String [P.Module])
114+loadModule filename = do
115+ content <- readFile filename
116+ return $ either (Left . P.prettyPrintMultipleErrors False) (Right . map snd) $ P.parseModulesFromFiles id [(filename, content)]
117+
118+-- |
119+-- Load all modules.
120+--
121+loadAllModules :: [FilePath] -> IO (Either P.MultipleErrors [(Either P.RebuildPolicy FilePath, P.Module)])
122+loadAllModules files = do
123+ filesAndContent <- forM files $ \filename -> do
124+ content <- readFile filename
125+ return (Right filename, content)
126+ return $ P.parseModulesFromFiles (either (const "") id) filesAndContent
127+
128+-- |
129+-- Load all modules, updating the application state
130+--
131+loadAllImportedModules :: PSCI ()
132+loadAllImportedModules = do
133+ files <- PSCI . lift $ fmap psciImportedFilenames get
134+ modulesOrFirstError <- psciIO $ loadAllModules files
135+ case modulesOrFirstError of
136+ Left errs -> printErrors errs
137+ Right modules -> PSCI . lift . modify $ \st -> st { psciLoadedModules = modules }
138+
139+-- |
140+-- Expands tilde in path.
141+--
142+expandTilde :: FilePath -> IO FilePath
143+expandTilde ('~':p:rest) | isPathSeparator p = (</> rest) <$> getHomeDirectory
144+expandTilde p = return p
145+
146+-- Messages
147+
148+-- |
149+-- The help message.
150+--
151+helpMessage :: String
152+helpMessage = "The following commands are available:\n\n " ++
153+ intercalate "\n " (map line D.help) ++
154+ "\n\n" ++ extraHelp
155+ where
156+ line :: (Directive, String, String) -> String
157+ line (dir, arg, desc) =
158+ let cmd = ':' : D.stringFor dir
159+ in unwords [ cmd
160+ , replicate (11 - length cmd) ' '
161+ , arg
162+ , replicate (11 - length arg) ' '
163+ , desc
164+ ]
165+
166+ extraHelp =
167+ "Further information is available on the PureScript wiki:\n" ++
168+ " --> https://github.com/purescript/purescript/wiki/psci"
169+
170+
171+-- |
172+-- The welcome prologue.
173+--
174+prologueMessage :: String
175+prologueMessage = intercalate "\n"
176+ [ " ____ ____ _ _ "
177+ , "| _ \\ _ _ _ __ ___/ ___| ___ _ __(_)_ __ | |_ "
178+ , "| |_) | | | | '__/ _ \\___ \\ / __| '__| | '_ \\| __|"
179+ , "| __/| |_| | | | __/___) | (__| | | | |_) | |_ "
180+ , "|_| \\__,_|_| \\___|____/ \\___|_| |_| .__/ \\__|"
181+ , " |_| "
182+ , ""
183+ , ":? shows help"
184+ ]
185+
186+-- |
187+-- The quit message.
188+--
189+quitMessage :: String
190+quitMessage = "See ya!"
191+
192+-- |
193+-- PSCI monad
194+--
195+newtype PSCI a = PSCI { runPSCI :: InputT (StateT PSCiState IO) a } deriving (Functor, Applicative, Monad)
196+
197+psciIO :: IO a -> PSCI a
198+psciIO io = PSCI . lift $ lift io
199+
200+-- |
201+-- Makes a volatile module to execute the current expression.
202+--
203+createTemporaryModule :: Bool -> PSCiState -> P.Expr -> P.Module
204+createTemporaryModule exec PSCiState{psciImportedModules = imports, psciLetBindings = lets} val =
205+ let
206+ moduleName = P.ModuleName [P.ProperName "$PSCI"]
207+ trace = P.Var (P.Qualified (Just supportModuleName) (P.Ident "eval"))
208+ mainValue = P.App trace (P.Var (P.Qualified Nothing (P.Ident "it")))
209+ itDecl = P.ValueDeclaration (P.Ident "it") P.Public [] $ Right val
210+ mainDecl = P.ValueDeclaration (P.Ident "main") P.Public [] $ Right mainValue
211+ decls = if exec then [itDecl, mainDecl] else [itDecl]
212+ in
213+ P.Module [] moduleName ((importDecl `map` imports) ++ lets ++ decls) Nothing
214+
215+
216+-- |
217+-- Makes a volatile module to hold a non-qualified type synonym for a fully-qualified data type declaration.
218+--
219+createTemporaryModuleForKind :: PSCiState -> P.Type -> P.Module
220+createTemporaryModuleForKind PSCiState{psciImportedModules = imports} typ =
221+ let
222+ moduleName = P.ModuleName [P.ProperName "$PSCI"]
223+ itDecl = P.TypeSynonymDeclaration (P.ProperName "IT") [] typ
224+ in
225+ P.Module [] moduleName ((importDecl `map` imports) ++ [itDecl]) Nothing
226+
227+-- |
228+-- Makes a volatile module to execute the current imports.
229+--
230+createTemporaryModuleForImports :: PSCiState -> P.Module
231+createTemporaryModuleForImports PSCiState{psciImportedModules = imports} =
232+ let
233+ moduleName = P.ModuleName [P.ProperName "$PSCI"]
234+ in
235+ P.Module [] moduleName (importDecl `map` imports) Nothing
236+
237+importDecl :: ImportedModule -> P.Declaration
238+importDecl (mn, declType, asQ) = P.ImportDeclaration mn declType asQ
239+
240+indexFile :: FilePath
241+indexFile = ".psci_modules" ++ pathSeparator : "index.js"
242+
243+make :: PSCiState -> [(Either P.RebuildPolicy FilePath, P.Module)] -> Make P.Environment
244+make PSCiState{..} ms =
245+ let filePathMap = M.fromList $ (first P.getModuleName . swap) `map` (psciLoadedModules ++ ms)
246+ in P.make (buildMakeActions filePathMap (M.map snd psciForeignFiles)) (psciLoadedModules ++ ms)
247+
248+-- |
249+-- Takes a value declaration and evaluates it with the current state.
250+--
251+handleDeclaration :: P.Expr -> PSCI ()
252+handleDeclaration val = do
253+ st <- PSCI $ lift get
254+ let m = createTemporaryModule True st val
255+ let nodeArgs = psciNodeFlags st ++ [indexFile]
256+ e <- psciIO . runMake $ make st [(Left P.RebuildAlways, supportModule), (Left P.RebuildAlways, m)]
257+ case e of
258+ Left errs -> printErrors errs
259+ Right _ -> do
260+ psciIO $ writeFile indexFile "require('$PSCI').main();"
261+ process <- psciIO findNodeProcess
262+ result <- psciIO $ traverse (\node -> readProcessWithExitCode node nodeArgs "") process
263+ case result of
264+ Just (ExitSuccess, out, _) -> PSCI $ outputStrLn out
265+ Just (ExitFailure _, _, err) -> PSCI $ outputStrLn err
266+ Nothing -> PSCI $ outputStrLn "Couldn't find node.js"
267+
268+-- |
269+-- Takes a list of declarations and updates the environment, then run a make. If the declaration fails,
270+-- restore the original environment.
271+--
272+handleDecls :: [P.Declaration] -> PSCI ()
273+handleDecls ds = do
274+ st <- PSCI $ lift get
275+ let st' = updateLets ds st
276+ let m = createTemporaryModule False st' (P.ObjectLiteral [])
277+ e <- psciIO . runMake $ make st' [(Left P.RebuildAlways, m)]
278+ case e of
279+ Left err -> printErrors err
280+ Right _ -> PSCI $ lift (put st')
281+
282+-- |
283+-- Show actual loaded modules in psci.
284+--
285+handleShowLoadedModules :: PSCI ()
286+handleShowLoadedModules = do
287+ PSCiState { psciLoadedModules = loadedModules } <- PSCI $ lift get
288+ psciIO $ readModules loadedModules >>= putStrLn
289+ return ()
290+ where readModules = return . unlines . sort . nub . map toModuleName
291+ toModuleName = N.runModuleName . (\ (P.Module _ mdName _ _) -> mdName) . snd
292+
293+-- |
294+-- Show the imported modules in psci.
295+--
296+handleShowImportedModules :: PSCI ()
297+handleShowImportedModules = do
298+ PSCiState { psciImportedModules = importedModules } <- PSCI $ lift get
299+ psciIO $ showModules importedModules >>= putStrLn
300+ return ()
301+ where
302+ showModules = return . unlines . sort . map showModule
303+ showModule (mn, declType, asQ) =
304+ "import " ++ case asQ of
305+ Just mn' -> "qualified " ++ N.runModuleName mn ++ " as " ++ N.runModuleName mn'
306+ Nothing -> N.runModuleName mn ++ " " ++ showDeclType declType
307+
308+ showDeclType P.Implicit = ""
309+ showDeclType (P.Explicit refs) = refsList refs
310+ showDeclType (P.Hiding refs) = "hiding " ++ refsList refs
311+ refsList refs = "(" ++ commaList (map showRef refs) ++ ")"
312+
313+ showRef :: P.DeclarationRef -> String
314+ showRef (P.TypeRef pn dctors) = show pn ++ "(" ++ maybe ".." (commaList . map N.runProperName) dctors ++ ")"
315+ showRef (P.ValueRef ident) = show ident
316+ showRef (P.TypeClassRef pn) = show pn
317+ showRef (P.TypeInstanceRef ident) = show ident
318+ showRef (P.PositionedDeclarationRef _ _ ref) = showRef ref
319+
320+ commaList :: [String] -> String
321+ commaList = intercalate ", "
322+
323+-- |
324+-- Imports a module, preserving the initial state on failure.
325+--
326+handleImport :: ImportedModule -> PSCI ()
327+handleImport im = do
328+ st <- updateImportedModules im <$> PSCI (lift get)
329+ let m = createTemporaryModuleForImports st
330+ e <- psciIO . runMake $ make st [(Left P.RebuildAlways, m)]
331+ case e of
332+ Left errs -> printErrors errs
333+ Right _ -> do
334+ PSCI $ lift $ put st
335+ return ()
336+
337+-- |
338+-- Takes a value and prints its type
339+--
340+handleTypeOf :: P.Expr -> PSCI ()
341+handleTypeOf val = do
342+ st <- PSCI $ lift get
343+ let m = createTemporaryModule False st val
344+ e <- psciIO . runMake $ make st [(Left P.RebuildAlways, m)]
345+ case e of
346+ Left errs -> printErrors errs
347+ Right env' ->
348+ case M.lookup (P.ModuleName [P.ProperName "$PSCI"], P.Ident "it") (P.names env') of
349+ Just (ty, _, _) -> PSCI . outputStrLn . P.prettyPrintType $ ty
350+ Nothing -> PSCI $ outputStrLn "Could not find type"
351+
352+-- |
353+-- Pretty print a module's signatures
354+--
355+printModuleSignatures :: P.ModuleName -> P.Environment -> PSCI ()
356+printModuleSignatures moduleName env =
357+ PSCI $ let namesEnv = P.names env
358+ moduleNamesIdent = (filter ((== moduleName) . fst) . M.keys) namesEnv
359+ in case moduleNamesIdent of
360+ [] -> outputStrLn $ "This module '"++ P.runModuleName moduleName ++"' does not export functions."
361+ _ -> ( outputStrLn
362+ . unlines
363+ . sort
364+ . map (showType . findType namesEnv)) moduleNamesIdent
365+ where findType :: M.Map (P.ModuleName, P.Ident) (P.Type, P.NameKind, P.NameVisibility) -> (P.ModuleName, P.Ident) -> (P.Ident, Maybe (P.Type, P.NameKind, P.NameVisibility))
366+ findType envNames m@(_, mIdent) = (mIdent, M.lookup m envNames)
367+ showType :: (P.Ident, Maybe (P.Type, P.NameKind, P.NameVisibility)) -> String
368+ showType (mIdent, Just (mType, _, _)) = show mIdent ++ " :: " ++ P.prettyPrintType mType
369+ showType _ = error "The impossible happened in printModuleSignatures."
370+
371+-- |
372+-- Browse a module and displays its signature (if module exists).
373+--
374+handleBrowse :: P.ModuleName -> PSCI ()
375+handleBrowse moduleName = do
376+ st <- PSCI $ lift get
377+ env <- psciIO . runMake $ make st []
378+ case env of
379+ Left errs -> printErrors errs
380+ Right env' ->
381+ if moduleName `notElem` (nub . map ((\ (P.Module _ modName _ _ ) -> modName) . snd)) (psciLoadedModules st)
382+ then PSCI $ outputStrLn $ "Module '" ++ N.runModuleName moduleName ++ "' is not valid."
383+ else printModuleSignatures moduleName env'
384+
385+-- | Pretty-print errors
386+printErrors :: P.MultipleErrors -> PSCI ()
387+printErrors = PSCI . outputStrLn . P.prettyPrintMultipleErrors False
388+
389+-- |
390+-- Takes a value and prints its kind
391+--
392+handleKindOf :: P.Type -> PSCI ()
393+handleKindOf typ = do
394+ st <- PSCI $ lift get
395+ let m = createTemporaryModuleForKind st typ
396+ mName = P.ModuleName [P.ProperName "$PSCI"]
397+ e <- psciIO . runMake $ make st [(Left P.RebuildAlways, m)]
398+ case e of
399+ Left errs -> printErrors errs
400+ Right env' ->
401+ case M.lookup (P.Qualified (Just mName) $ P.ProperName "IT") (P.typeSynonyms env') of
402+ Just (_, typ') -> do
403+ let chk = P.CheckState env' 0 0 (Just mName)
404+ k = fst . runWriter . runExceptT $ L.runStateT (P.unCheck (P.kindOf mName typ')) chk
405+ case k of
406+ Left errStack -> PSCI . outputStrLn . P.prettyPrintMultipleErrors False $ errStack
407+ Right (kind, _) -> PSCI . outputStrLn . P.prettyPrintKind $ kind
408+ Nothing -> PSCI $ outputStrLn "Could not find kind"
409+
410+-- Commands
411+
412+-- |
413+-- Parses the input and returns either a Metacommand, or an error as a string.
414+--
415+getCommand :: Bool -> InputT (StateT PSCiState IO) (Either String (Maybe Command))
416+getCommand singleLineMode = do
417+ firstLine <- getInputLine "> "
418+ case firstLine of
419+ Nothing -> return (Right Nothing)
420+ Just "" -> return (Right Nothing)
421+ Just s | singleLineMode || head s == ':' -> return . either Left (Right . Just) $ parseCommand s
422+ Just s -> either Left (Right . Just) . parseCommand <$> go [s]
423+ where
424+ go :: [String] -> InputT (StateT PSCiState IO) String
425+ go ls = maybe (return . unlines $ reverse ls) (go . (:ls)) =<< getInputLine " "
426+
427+-- |
428+-- Performs an action for each meta-command given, and also for expressions.
429+--
430+handleCommand :: Command -> PSCI ()
431+handleCommand (Expression val) = handleDeclaration val
432+handleCommand ShowHelp = PSCI $ outputStrLn helpMessage
433+handleCommand (Import im) = handleImport im
434+handleCommand (Decls l) = handleDecls l
435+handleCommand (LoadFile filePath) = whenFileExists filePath $ \absPath -> do
436+ PSCI . lift $ modify (updateImportedFiles absPath)
437+ m <- psciIO $ loadModule absPath
438+ case m of
439+ Left err -> PSCI $ outputStrLn err
440+ Right mods -> PSCI . lift $ modify (updateModules (map ((,) (Right absPath)) mods))
441+handleCommand (LoadForeign filePath) = whenFileExists filePath $ \absPath -> do
442+ foreignsOrError <- psciIO . runMake $ do
443+ foreignFile <- makeIO (const (P.SimpleErrorWrapper $ P.CannotReadFile absPath)) (readFile absPath)
444+ P.parseForeignModulesFromFiles [(absPath, foreignFile)]
445+ case foreignsOrError of
446+ Left err -> PSCI $ outputStrLn $ P.prettyPrintMultipleErrors False err
447+ Right foreigns -> PSCI . lift $ modify (updateForeignFiles foreigns)
448+handleCommand ResetState = do
449+ files <- psciImportedFilenames <$> PSCI (lift get)
450+ PSCI . lift . modify $ \st -> st
451+ { psciImportedFilenames = files
452+ , psciImportedModules = []
453+ , psciLetBindings = []
454+ }
455+ loadAllImportedModules
456+handleCommand (TypeOf val) = handleTypeOf val
457+handleCommand (KindOf typ) = handleKindOf typ
458+handleCommand (BrowseModule moduleName) = handleBrowse moduleName
459+handleCommand (ShowInfo QueryLoaded) = handleShowLoadedModules
460+handleCommand (ShowInfo QueryImport) = handleShowImportedModules
461+handleCommand QuitPSCi = error "`handleCommand QuitPSCi` was called. This is a bug."
462+
463+whenFileExists :: FilePath -> (FilePath -> PSCI ()) -> PSCI ()
464+whenFileExists filePath f = do
465+ absPath <- psciIO $ expandTilde filePath
466+ exists <- psciIO $ doesFileExist absPath
467+ if exists
468+ then f absPath
469+ else PSCI . outputStrLn $ "Couldn't locate: " ++ filePath
470+
471+loadUserConfig :: IO (Maybe [Command])
472+loadUserConfig = do
473+ configFile <- (</> ".psci") <$> getCurrentDirectory
474+ exists <- doesFileExist configFile
475+ if exists
476+ then do
477+ ls <- lines <$> readFile configFile
478+ case mapM parseCommand ls of
479+ Left err -> print err >> exitFailure
480+ Right cs -> return $ Just cs
481+ else
482+ return Nothing
483+
484+-- | Checks if the Console module is defined
485+consoleIsDefined :: [P.Module] -> Bool
486+consoleIsDefined = any ((== P.ModuleName (map P.ProperName [ "Control", "Monad", "Eff", "Console" ])) . P.getModuleName)
487+
488+-- |
489+-- The PSCI main loop.
490+--
491+loop :: PSCiOptions -> IO ()
492+loop PSCiOptions{..} = do
493+ config <- loadUserConfig
494+ inputFiles <- concat <$> mapM glob psciInputFile
495+ foreignFiles <- concat <$> mapM glob psciForeignInputFiles
496+ modulesOrFirstError <- loadAllModules inputFiles
497+ case modulesOrFirstError of
498+ Left errs -> putStrLn (P.prettyPrintMultipleErrors False errs) >> exitFailure
499+ Right modules -> do
500+ historyFilename <- getHistoryFilename
501+ let settings = defaultSettings { historyFile = Just historyFilename }
502+ foreignsOrError <- runMake $ do
503+ foreignFilesContent <- forM foreignFiles (\inFile -> (inFile,) <$> makeIO (const (P.SimpleErrorWrapper $ P.CannotReadFile inFile)) (readFile inFile))
504+ P.parseForeignModulesFromFiles foreignFilesContent
505+ case foreignsOrError of
506+ Left errs -> putStrLn (P.prettyPrintMultipleErrors False errs) >> exitFailure
507+ Right foreigns ->
508+ flip evalStateT (PSCiState inputFiles [] modules foreigns [] psciInputNodeFlags) . runInputT (setComplete completion settings) $ do
509+ outputStrLn prologueMessage
510+ traverse_ (mapM_ (runPSCI . handleCommand)) config
511+ modules' <- lift $ gets psciLoadedModules
512+ unless (consoleIsDefined (map snd modules')) . outputStrLn $ unlines
513+ [ "PSCi requires the purescript-console module to be installed."
514+ , "For help getting started, visit http://wiki.purescript.org/PSCi"
515+ ]
516+ go
517+ where
518+ go :: InputT (StateT PSCiState IO) ()
519+ go = do
520+ c <- getCommand (not psciMultiLineMode)
521+ case c of
522+ Left err -> outputStrLn err >> go
523+ Right Nothing -> go
524+ Right (Just QuitPSCi) -> outputStrLn quitMessage
525+ Right (Just c') -> runPSCI (loadAllImportedModules >> handleCommand c') >> go
526+
527+multiLineMode :: Parser Bool
528+multiLineMode = switch $
529+ long "multi-line-mode"
530+ <> short 'm'
531+ <> Opts.help "Run in multi-line mode (use ^D to terminate commands)"
532+
533+inputFile :: Parser FilePath
534+inputFile = strArgument $
535+ metavar "FILE"
536+ <> Opts.help "Optional .purs files to load on start"
537+
538+inputForeignFile :: Parser FilePath
539+inputForeignFile = strOption $
540+ short 'f'
541+ <> long "ffi"
542+ <> help "The input .js file(s) providing foreign import implementations"
543+
544+nodeFlagsFlag :: Parser [String]
545+nodeFlagsFlag = option parser $
546+ long "node-opts"
547+ <> metavar "NODE_OPTS"
548+ <> value []
549+ <> Opts.help "Flags to pass to node, separated by spaces"
550+ where
551+ parser = words <$> str
552+
553+psciOptions :: Parser PSCiOptions
554+psciOptions = PSCiOptions <$> multiLineMode
555+ <*> many inputFile
556+ <*> many inputForeignFile
557+ <*> nodeFlagsFlag
558+
559+runPSCi :: IO ()
560+runPSCi = execParser opts >>= loop
561+ where
562+ opts = info (version <*> helper <*> psciOptions) infoModList
563+ infoModList = fullDesc <> headerInfo <> footerInfo
564+ headerInfo = header "psci - Interactive mode for PureScript"
565+ footerInfo = footer $ "psci " ++ showVersion Paths.version
566+
567+ version :: Parser (a -> a)
568+ version = abortOption (InfoMsg (showVersion Paths.version)) $ long "version" <> Opts.help "Show the version number" <> hidden
psci/Parser.hsnew file+140
@@ -0,0 +1,140 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Parser
4+-- Copyright : (c) Phil Freeman 2014
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- Parser for PSCI.
13+--
14+-----------------------------------------------------------------------------
15+
16+module Parser
17+ ( parseCommand
18+ ) where
19+
20+import Prelude hiding (lex)
21+
22+import Data.Char (isSpace)
23+import Data.List (intercalate)
24+
25+import Control.Applicative hiding (many)
26+
27+import Text.Parsec hiding ((<|>))
28+
29+import qualified Language.PureScript as P
30+import Language.PureScript.Parser.Common (mark, same)
31+
32+import qualified Directive as D
33+import Types
34+
35+-- |
36+-- Parses PSCI metacommands or expressions input from the user.
37+--
38+parseCommand :: String -> Either String Command
39+parseCommand cmdString =
40+ case cmdString of
41+ (':' : cmd) -> parseDirective cmd
42+ _ -> parseRest psciCommand cmdString
43+
44+parseRest :: P.TokenParser a -> String -> Either String a
45+parseRest p s = either (Left . show) Right $ do
46+ ts <- P.lex "" s
47+ P.runTokenParser "" (p <* eof) ts
48+
49+psciCommand :: P.TokenParser Command
50+psciCommand = choice (map try parsers)
51+ where
52+ parsers =
53+ [ psciLet
54+ , psciImport
55+ , psciOtherDeclaration
56+ , psciExpression
57+ ]
58+
59+trim :: String -> String
60+trim = trimEnd . trimStart
61+
62+trimStart :: String -> String
63+trimStart = dropWhile isSpace
64+
65+trimEnd :: String -> String
66+trimEnd = reverse . trimStart . reverse
67+
68+parseDirective :: String -> Either String Command
69+parseDirective cmd =
70+ case D.directivesFor' dstr of
71+ [(d, _)] -> commandFor d
72+ [] -> Left "Unrecognized directive. Type :? for help."
73+ ds -> Left ("Ambiguous directive. Possible matches: " ++
74+ intercalate ", " (map snd ds) ++ ". Type :? for help.")
75+ where
76+ (dstr, arg) = break isSpace cmd
77+
78+ commandFor d = case d of
79+ Help -> return ShowHelp
80+ Quit -> return QuitPSCi
81+ Reset -> return ResetState
82+ Browse -> BrowseModule <$> parseRest P.moduleName arg
83+ Load -> return $ LoadFile (trim arg)
84+ Foreign -> return $ LoadForeign (trim arg)
85+ Show -> ShowInfo <$> parseReplQuery' (trim arg)
86+ Type -> TypeOf <$> parseRest P.parseValue arg
87+ Kind -> KindOf <$> parseRest P.parseType arg
88+
89+-- |
90+-- Parses expressions entered at the PSCI repl.
91+--
92+psciExpression :: P.TokenParser Command
93+psciExpression = Expression <$> P.parseValue
94+
95+-- |
96+-- PSCI version of @let@.
97+-- This is essentially let from do-notation.
98+-- However, since we don't support the @Eff@ monad,
99+-- we actually want the normal @let@.
100+--
101+psciLet :: P.TokenParser Command
102+psciLet = Decls <$> (P.reserved "let" *> P.indented *> manyDecls)
103+ where
104+ manyDecls :: P.TokenParser [P.Declaration]
105+ manyDecls = mark (many1 (same *> P.parseLocalDeclaration))
106+
107+-- | Imports must be handled separately from other declarations, so that
108+-- :show import works, for example.
109+psciImport :: P.TokenParser Command
110+psciImport = Import <$> P.parseImportDeclaration'
111+
112+-- | Any other declaration that we don't need a 'special case' parser for
113+-- (like let or import declarations).
114+psciOtherDeclaration :: P.TokenParser Command
115+psciOtherDeclaration = Decls . (:[]) <$> do
116+ decl <- discardPositionInfo <$> P.parseDeclaration
117+ if acceptable decl
118+ then return decl
119+ else fail "this kind of declaration is not supported in psci"
120+
121+discardPositionInfo :: P.Declaration -> P.Declaration
122+discardPositionInfo (P.PositionedDeclaration _ _ d) = d
123+discardPositionInfo d = d
124+
125+acceptable :: P.Declaration -> Bool
126+acceptable P.DataDeclaration{} = True
127+acceptable P.TypeSynonymDeclaration{} = True
128+acceptable P.ExternDeclaration{} = True
129+acceptable P.ExternDataDeclaration{} = True
130+acceptable P.ExternInstanceDeclaration{} = True
131+acceptable P.TypeClassDeclaration{} = True
132+acceptable P.TypeInstanceDeclaration{} = True
133+acceptable _ = False
134+
135+parseReplQuery' :: String -> Either String ReplQuery
136+parseReplQuery' str =
137+ case parseReplQuery str of
138+ Nothing -> Left ("Don't know how to show " ++ str ++ ". Try one of: " ++
139+ intercalate ", " replQueryStrings ++ ".")
140+ Just query -> Right query
psci/Types.hsnew file+181
@@ -0,0 +1,181 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Types
4+-- Copyright : (c) Phil Freeman 2014
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- Type declarations and associated basic functions for PSCI.
13+--
14+-----------------------------------------------------------------------------
15+
16+module Types where
17+
18+import qualified Data.Map as M
19+import qualified Language.PureScript as P
20+
21+data PSCiOptions = PSCiOptions
22+ { psciMultiLineMode :: Bool
23+ , psciInputFile :: [FilePath]
24+ , psciForeignInputFiles :: [FilePath]
25+ , psciInputNodeFlags :: [String]
26+ }
27+
28+-- |
29+-- The PSCI state.
30+-- Holds a list of imported modules, loaded files, and partial let bindings.
31+-- The let bindings are partial,
32+-- because it makes more sense to apply the binding to the final evaluated expression.
33+--
34+data PSCiState = PSCiState
35+ { psciImportedFilenames :: [FilePath]
36+ , psciImportedModules :: [ImportedModule]
37+ , psciLoadedModules :: [(Either P.RebuildPolicy FilePath, P.Module)]
38+ , psciForeignFiles :: M.Map P.ModuleName (FilePath, P.ForeignJS)
39+ , psciLetBindings :: [P.Declaration]
40+ , psciNodeFlags :: [String]
41+ }
42+
43+-- | All of the data that is contained by an ImportDeclaration in the AST.
44+-- That is:
45+--
46+-- * A module name, the name of the module which is being imported
47+-- * An ImportDeclarationType which specifies whether there is an explicit
48+-- import list, a hiding list, or neither.
49+-- * If the module is imported qualified, its qualified name in the importing
50+-- module. Otherwise, Nothing.
51+--
52+type ImportedModule = (P.ModuleName, P.ImportDeclarationType, Maybe P.ModuleName)
53+
54+psciImportedModuleNames :: PSCiState -> [P.ModuleName]
55+psciImportedModuleNames (PSCiState{psciImportedModules = is}) =
56+ map (\(mn, _, _) -> mn) is
57+
58+allImportsOf :: P.Module -> PSCiState -> [ImportedModule]
59+allImportsOf m (PSCiState{psciImportedModules = is}) =
60+ filter isImportOfThis is
61+ where
62+ name = P.getModuleName m
63+ isImportOfThis (name', _, _) = name == name'
64+
65+-- State helpers
66+
67+-- |
68+-- Updates the state to have more imported modules.
69+--
70+updateImportedFiles :: FilePath -> PSCiState -> PSCiState
71+updateImportedFiles filename st = st { psciImportedFilenames = filename : psciImportedFilenames st }
72+
73+-- |
74+-- Updates the state to have more imported modules.
75+--
76+updateImportedModules :: ImportedModule -> PSCiState -> PSCiState
77+updateImportedModules im st = st { psciImportedModules = im : psciImportedModules st }
78+
79+-- |
80+-- Updates the state to have more loaded files.
81+--
82+updateModules :: [(Either P.RebuildPolicy FilePath, P.Module)] -> PSCiState -> PSCiState
83+updateModules modules st = st { psciLoadedModules = psciLoadedModules st ++ modules }
84+
85+-- |
86+-- Updates the state to have more let bindings.
87+--
88+updateLets :: [P.Declaration] -> PSCiState -> PSCiState
89+updateLets ds st = st { psciLetBindings = psciLetBindings st ++ ds }
90+
91+-- |
92+-- Updates the state to have more let bindings.
93+--
94+updateForeignFiles :: M.Map P.ModuleName (FilePath, P.ForeignJS) -> PSCiState -> PSCiState
95+updateForeignFiles fs st = st { psciForeignFiles = psciForeignFiles st `M.union` fs }
96+
97+-- |
98+-- Valid Meta-commands for PSCI
99+--
100+data Command
101+ -- |
102+ -- A purescript expression
103+ --
104+ = Expression P.Expr
105+ -- |
106+ -- Show the help (ie, list of directives)
107+ --
108+ | ShowHelp
109+ -- |
110+ -- Import a module from a loaded file
111+ --
112+ | Import ImportedModule
113+ -- |
114+ -- Browse a module
115+ --
116+ | BrowseModule P.ModuleName
117+ -- |
118+ -- Load a file for use with importing
119+ --
120+ | LoadFile FilePath
121+ -- |
122+ -- Load a foreign module
123+ --
124+ | LoadForeign FilePath
125+ -- |
126+ -- Exit PSCI
127+ --
128+ | QuitPSCi
129+ -- |
130+ -- Reset the state of the REPL
131+ --
132+ | ResetState
133+ -- |
134+ -- Add some declarations to the current evaluation context.
135+ --
136+ | Decls [P.Declaration]
137+ -- |
138+ -- Find the type of an expression
139+ --
140+ | TypeOf P.Expr
141+ -- |
142+ -- Find the kind of an expression
143+ --
144+ | KindOf P.Type
145+ -- |
146+ -- Shows information about the current state of the REPL
147+ --
148+ | ShowInfo ReplQuery
149+
150+data ReplQuery
151+ = QueryLoaded
152+ | QueryImport
153+ deriving (Eq, Show)
154+
155+-- | A list of all ReplQuery values.
156+replQueries :: [ReplQuery]
157+replQueries = [QueryLoaded, QueryImport]
158+
159+replQueryStrings :: [String]
160+replQueryStrings = map showReplQuery replQueries
161+
162+showReplQuery :: ReplQuery -> String
163+showReplQuery QueryLoaded = "loaded"
164+showReplQuery QueryImport = "import"
165+
166+parseReplQuery :: String -> Maybe ReplQuery
167+parseReplQuery "loaded" = Just QueryLoaded
168+parseReplQuery "import" = Just QueryImport
169+parseReplQuery _ = Nothing
170+
171+data Directive
172+ = Help
173+ | Quit
174+ | Reset
175+ | Browse
176+ | Load
177+ | Foreign
178+ | Type
179+ | Kind
180+ | Show
181+ deriving (Eq, Show)
psci/main/Main.hsnew file+6
@@ -0,0 +1,6 @@
1+module Main where
2+
3+import PSCi
4+
5+main :: IO ()
6+main = runPSCi
psci/tests/Main.hsnew file+150
@@ -0,0 +1,150 @@
1+{-# LANGUAGE RecordWildCards, TupleSections #-}
2+
3+module Main where
4+
5+import Control.Monad.Trans.State.Strict (runStateT)
6+import Control.Monad (when, forM)
7+import Control.Applicative
8+import Control.Monad.Writer (runWriterT)
9+import Control.Monad.Trans.Except (runExceptT)
10+
11+import Data.List (isSuffixOf, sort)
12+
13+import System.Exit (exitFailure)
14+import System.Console.Haskeline
15+import System.FilePath ((</>))
16+import System.Directory (getCurrentDirectory, getDirectoryContents)
17+
18+import Test.HUnit
19+
20+import qualified Language.PureScript as P
21+
22+import PSCi
23+import Completion
24+import Types
25+
26+main :: IO ()
27+main = do
28+ Counts{..} <- runTestTT allTests
29+ when (errors + failures > 0) exitFailure
30+
31+allTests :: Test
32+allTests = completionTests
33+
34+completionTests :: Test
35+completionTests =
36+ TestLabel "completionTests"
37+ (TestList (map (TestCase . assertCompletedOk) completionTestData))
38+
39+-- If the cursor is at the right end of the line, with the 1st element of the
40+-- pair as the text in the line, then pressing tab should offer all the
41+-- elements of the list (which is the 2nd element) as completions.
42+completionTestData :: [(String, [String])]
43+completionTestData =
44+ -- basic directives
45+ [ (":h", [":help"])
46+ , (":re", [":reset"])
47+ , (":q", [":quit"])
48+ , (":mo", [":module"])
49+ , (":b", [":browse"])
50+
51+ -- :browse should complete modules
52+ , (":b Prel", [":b Prelude", ":b Prelude.Unsafe"])
53+ , (":b Prelude.", [":b Prelude.Unsafe"])
54+
55+ -- :load, :module should complete file paths
56+ , (":l psci/tests/data/", [":l psci/tests/data/Sample.purs"])
57+ , (":module psci/tests/data/", [":module psci/tests/data/Sample.purs"])
58+
59+ -- :quit, :help, :reset should not complete
60+ , (":help ", [])
61+ , (":quit ", [])
62+ , (":reset ", [])
63+
64+ -- :show should complete to "loaded" and "import"
65+ , (":show ", [":show import", ":show loaded"])
66+ , (":show a", [])
67+
68+ -- :type should complete values and data constructors in scope
69+ , (":type Prelude.Unsafe.un", [":type Prelude.Unsafe.unsafeIndex"])
70+ , (":type un", [":type unit"])
71+ , (":type E", [":type EQ"])
72+
73+ -- :kind should complete types in scope
74+ , (":kind C", [":kind Control.Monad.Eff.Pure"])
75+ , (":kind O", [":kind Ordering"])
76+
77+ -- Only one argument for directives should be completed
78+ , (":show import ", [])
79+ , (":type EQ ", [])
80+ , (":kind Ordering ", [])
81+
82+ -- import should complete module names
83+ , ("import Control.Monad.S", ["import Control.Monad.ST"])
84+ , ("import qualified Control.Monad.S", ["import qualified Control.Monad.ST"])
85+ , ("import Control.Monad.", map ("import Control.Monad." ++)
86+ ["Eff", "ST"])
87+
88+ -- a few other import tests
89+ , ("impor", ["import"])
90+ , ("import q", ["import qualified"])
91+ , ("import ", map ("import " ++) allModuleNames ++ ["import qualified"])
92+ , ("import Prelude.Unsafe ", [])
93+
94+ -- String and number literals should not be completed
95+ , ("\"hi", [])
96+ , ("34", [])
97+
98+ -- Identifiers and data constructors should be completed
99+ , ("un", ["unit"])
100+ , ("Debug.Trace.", map ("Debug.Trace." ++) ["print", "trace"])
101+ , ("G", ["GT"])
102+ , ("Prelude.L", ["Prelude.LT"])
103+
104+ -- if a module is imported qualified, values should complete under the
105+ -- qualified name, as well as the original name.
106+ , ("ST.new", ["ST.newSTRef"])
107+ , ("Control.Monad.ST.new", ["Control.Monad.ST.newSTRef"])
108+ ]
109+ where
110+ allModuleNames = [ "Assert"
111+ , "Control.Monad.Eff"
112+ , "Control.Monad.ST"
113+ , "Data.Function"
114+ , "Debug.Trace"
115+ , "Prelude"
116+ , "Prelude.Unsafe"
117+ ]
118+
119+assertCompletedOk :: (String, [String]) -> Assertion
120+assertCompletedOk (line, expecteds) = do
121+ (unusedR, completions) <- runCM (completion' (reverse line, ""))
122+ let unused = reverse unusedR
123+ let actuals = map ((unused ++) . replacement) completions
124+ sort expecteds @=? sort actuals
125+
126+runCM :: CompletionM a -> IO a
127+runCM act = do
128+ psciState <- getPSCiState
129+ fmap fst (runStateT (liftCompletionM act) psciState)
130+
131+getPSCiState :: IO PSCiState
132+getPSCiState = do
133+ cwd <- getCurrentDirectory
134+ let preludeDir = cwd </> "tests" </> "prelude"
135+ jsDir = preludeDir </> "js"
136+ modulesOrFirstError <- loadAllModules [ preludeDir </> "Prelude.purs" ]
137+ jsFiles <- map (jsDir </>) . filter (".js" `isSuffixOf`) <$> getDirectoryContents jsDir
138+ foreignFiles <- forM jsFiles (\f -> (f,) <$> readFile f)
139+ Right (foreigns, _) <- runExceptT $ runWriterT $ P.parseForeignModulesFromFiles foreignFiles
140+ case modulesOrFirstError of
141+ Left err ->
142+ print err >> exitFailure
143+ Right modules ->
144+ let imports = [controlMonadSTasST, (P.ModuleName [P.ProperName "Prelude"], P.Implicit, Nothing)]
145+ in return (PSCiState [] imports modules foreigns [] [])
146+
147+controlMonadSTasST :: ImportedModule
148+controlMonadSTasST = (s "Control.Monad.ST", P.Implicit, Just (s "ST"))
149+ where
150+ s = P.moduleNameFromString
psci/tests/data/Sample.pursnew file

No changes to the content.

psgo.cabaldeleted−145
@@ -1,145 +0,0 @@
1−cabal-version: 1.12
2−
3−-- This file has been generated from package.yaml by hpack version 0.35.0.
4−--
5−-- see: https://github.com/sol/hpack
6−
7−name: psgo
8−version: 0.1.0.0
9−description: Please see the README on Github at <https://github.com/andyarvanitis/purescript-native#readme>
10−homepage: https://github.com/andyarvanitis/purescript-native#readme
11−bug-reports: https://github.com/andyarvanitis/purescript-native/issues
12−author: Andy Arvanitis
13−maintainer: example@example.com
14−copyright: 2018 Andy Arvanitis
15−license: BSD3
16−license-file: LICENSE
17−build-type: Simple
18−extra-source-files:
19− README.md
20− ChangeLog.md
21− stack.yaml
22− support/ffi-loader.go
23− support/go.mod.ffi-loader
24− support/go.mod.output
25− support/go.mod.working
26−
27−source-repository head
28− type: git
29− location: https://github.com/andyarvanitis/purescript-native
30−
31−library
32− exposed-modules:
33− CodeGen.IL
34− CodeGen.IL.Common
35− CodeGen.IL.Optimizer
36− CodeGen.IL.Optimizer.Common
37− CodeGen.IL.Optimizer.Inliner
38− CodeGen.IL.Optimizer.MagicDo
39− CodeGen.IL.Optimizer.TCO
40− CodeGen.IL.Printer
41− Tests
42− other-modules:
43− Paths_psgo
44− hs-source-dirs:
45− src
46− default-extensions:
47− ConstraintKinds
48− DataKinds
49− DeriveFunctor
50− EmptyDataDecls
51− FlexibleContexts
52− KindSignatures
53− LambdaCase
54− MultiParamTypeClasses
55− NoImplicitPrelude
56− PatternGuards
57− PatternSynonyms
58− RankNTypes
59− RecordWildCards
60− OverloadedStrings
61− ScopedTypeVariables
62− TupleSections
63− ViewPatterns
64− build-depends:
65− aeson >=1.0 && <1.5
66− , base >=4.7 && <5
67− , base-compat >=0.6.0
68− , bytestring >=0.10.8.2 && <0.11
69− , containers
70− , directory
71− , file-embed
72− , filemanip
73− , filepath
74− , gitrev
75− , monad-parallel >=0.7.2.2 && <0.8
76− , mtl >=2.1.0 && <2.3.0
77− , pattern-arrows >=0.0.2 && <0.1
78− , process
79− , protolude >=0.1.6
80− , purescript
81− , safe >=0.3.9 && <0.4
82− , text
83− , transformers >=0.3.0 && <0.6
84− default-language: Haskell2010
85−
86−executable psgo
87− main-is: Main.hs
88− other-modules:
89− Paths_psgo
90− hs-source-dirs:
91− app
92− ghc-options: -threaded -rtsopts -with-rtsopts=-N
93− build-depends:
94− aeson >=1.0 && <1.5
95− , base >=4.7 && <5
96− , base-compat >=0.6.0
97− , bytestring >=0.10.8.2 && <0.11
98− , containers
99− , directory
100− , file-embed
101− , filemanip
102− , filepath
103− , gitrev
104− , monad-parallel >=0.7.2.2 && <0.8
105− , mtl >=2.1.0 && <2.3.0
106− , pattern-arrows >=0.0.2 && <0.1
107− , process
108− , protolude >=0.1.6
109− , psgo
110− , purescript
111− , safe >=0.3.9 && <0.4
112− , text
113− , transformers >=0.3.0 && <0.6
114− default-language: Haskell2010
115−
116−test-suite psgo-test
117− type: exitcode-stdio-1.0
118− main-is: Spec.hs
119− other-modules:
120− Paths_psgo
121− hs-source-dirs:
122− test
123− ghc-options: -threaded -rtsopts -with-rtsopts=-N
124− build-depends:
125− aeson >=1.0 && <1.5
126− , base >=4.7 && <5
127− , base-compat >=0.6.0
128− , bytestring >=0.10.8.2 && <0.11
129− , containers
130− , directory
131− , file-embed
132− , filemanip
133− , filepath
134− , gitrev
135− , monad-parallel >=0.7.2.2 && <0.8
136− , mtl >=2.1.0 && <2.3.0
137− , pattern-arrows >=0.0.2 && <0.1
138− , process
139− , protolude >=0.1.6
140− , psgo
141− , purescript
142− , safe >=0.3.9 && <0.4
143− , text
144− , transformers >=0.3.0 && <0.6
145− default-language: Haskell2010
purescript.cabalnew file+244
@@ -0,0 +1,244 @@
1+name: purescript
2+version: 0.7.0.0
3+cabal-version: >=1.8
4+build-type: Simple
5+license: MIT
6+license-file: LICENSE
7+copyright: (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
8+maintainer: Phil Freeman <paf31@cantab.net>
9+stability: experimental
10+synopsis: PureScript Programming Language Compiler
11+description: A small strongly, statically typed programming language with expressive types, inspired by Haskell and compiling to Javascript.
12+category: Language
13+Homepage: http://www.purescript.org/
14+author: Phil Freeman <paf31@cantab.net>,
15+ Gary Burgess <gary.burgess@gmail.com>,
16+ Hardy Jones <jones3.hardy@gmail.com>
17+
18+tested-with: GHC==7.8
19+
20+extra-source-files: examples/passing/*.purs
21+ , examples/failing/*.purs
22+
23+source-repository head
24+ type: git
25+ location: https://github.com/purescript/purescript.git
26+
27+library
28+ build-depends: base >=4.6 && <5,
29+ containers -any,
30+ unordered-containers -any,
31+ dlist -any,
32+ directory >= 1.2,
33+ filepath -any,
34+ mtl >= 2.1.0 && < 2.3.0,
35+ parsec -any,
36+ transformers >= 0.3.0 && < 0.5,
37+ transformers-compat >= 0.3.0,
38+ utf8-string >= 1 && < 2,
39+ pattern-arrows >= 0.0.2 && < 0.1,
40+ time -any,
41+ boxes >= 0.1.4 && < 0.2.0,
42+ aeson >= 0.8 && < 0.9,
43+ vector -any,
44+ bower-json >= 0.7,
45+ aeson-better-errors >= 0.8,
46+ bytestring -any,
47+ text -any,
48+ split -any
49+
50+ exposed-modules: Language.PureScript
51+ Language.PureScript.AST
52+ Language.PureScript.AST.Binders
53+ Language.PureScript.AST.Declarations
54+ Language.PureScript.AST.Operators
55+ Language.PureScript.AST.SourcePos
56+ Language.PureScript.AST.Traversals
57+ Language.PureScript.AST.Exported
58+ Language.PureScript.CodeGen
59+ Language.PureScript.CodeGen.Externs
60+ Language.PureScript.CodeGen.JS
61+ Language.PureScript.CodeGen.JS.AST
62+ Language.PureScript.CodeGen.JS.Common
63+ Language.PureScript.CodeGen.JS.Optimizer
64+ Language.PureScript.CodeGen.JS.Optimizer.Blocks
65+ Language.PureScript.CodeGen.JS.Optimizer.Common
66+ Language.PureScript.CodeGen.JS.Optimizer.Inliner
67+ Language.PureScript.CodeGen.JS.Optimizer.MagicDo
68+ Language.PureScript.CodeGen.JS.Optimizer.TCO
69+ Language.PureScript.CodeGen.JS.Optimizer.Unused
70+ Language.PureScript.Constants
71+ Language.PureScript.CoreFn
72+ Language.PureScript.CoreFn.Ann
73+ Language.PureScript.CoreFn.Binders
74+ Language.PureScript.CoreFn.Desugar
75+ Language.PureScript.CoreFn.Expr
76+ Language.PureScript.CoreFn.Literals
77+ Language.PureScript.CoreFn.Meta
78+ Language.PureScript.CoreFn.Module
79+ Language.PureScript.CoreFn.Traversals
80+ Language.PureScript.Comments
81+ Language.PureScript.DeadCodeElimination
82+ Language.PureScript.Environment
83+ Language.PureScript.Errors
84+ Language.PureScript.Kinds
85+ Language.PureScript.Linter
86+ Language.PureScript.ModuleDependencies
87+ Language.PureScript.Names
88+ Language.PureScript.Options
89+ Language.PureScript.Parser
90+ Language.PureScript.Parser.Lexer
91+ Language.PureScript.Parser.Common
92+ Language.PureScript.Parser.Declarations
93+ Language.PureScript.Parser.JS
94+ Language.PureScript.Parser.Kinds
95+ Language.PureScript.Parser.State
96+ Language.PureScript.Parser.Types
97+ Language.PureScript.Pretty
98+ Language.PureScript.Pretty.Common
99+ Language.PureScript.Pretty.JS
100+ Language.PureScript.Pretty.Kinds
101+ Language.PureScript.Pretty.Types
102+ Language.PureScript.Pretty.Values
103+ Language.PureScript.Renamer
104+ Language.PureScript.Sugar
105+ Language.PureScript.Sugar.BindingGroups
106+ Language.PureScript.Sugar.CaseDeclarations
107+ Language.PureScript.Sugar.DoNotation
108+ Language.PureScript.Sugar.Names
109+ Language.PureScript.Sugar.ObjectWildcards
110+ Language.PureScript.Sugar.Operators
111+ Language.PureScript.Sugar.TypeClasses
112+ Language.PureScript.Sugar.TypeDeclarations
113+ Language.PureScript.Traversals
114+ Language.PureScript.TypeChecker
115+ Language.PureScript.TypeChecker.Entailment
116+ Language.PureScript.TypeChecker.Kinds
117+ Language.PureScript.TypeChecker.Monad
118+ Language.PureScript.TypeChecker.Rows
119+ Language.PureScript.TypeChecker.Skolems
120+ Language.PureScript.TypeChecker.Subsumption
121+ Language.PureScript.TypeChecker.Synonyms
122+ Language.PureScript.TypeChecker.Types
123+ Language.PureScript.TypeChecker.Unify
124+ Language.PureScript.TypeClassDictionaries
125+ Language.PureScript.Types
126+
127+ Language.PureScript.Docs
128+ Language.PureScript.Docs.Convert
129+ Language.PureScript.Docs.Render
130+ Language.PureScript.Docs.Types
131+ Language.PureScript.Docs.RenderedCode
132+ Language.PureScript.Docs.RenderedCode.Types
133+ Language.PureScript.Docs.RenderedCode.Render
134+ Language.PureScript.Docs.AsMarkdown
135+ Language.PureScript.Docs.ParseAndDesugar
136+ Language.PureScript.Docs.Utils.MonoidExtras
137+
138+ Control.Monad.Unify
139+ Control.Monad.Supply
140+ Control.Monad.Supply.Class
141+
142+ exposed: True
143+ buildable: True
144+ hs-source-dirs: src
145+ other-modules: Paths_purescript
146+ ghc-options: -Wall -O2
147+
148+executable psc
149+ build-depends: base >=4 && <5, containers -any, directory -any, filepath -any,
150+ mtl -any, optparse-applicative >= 0.10.0, parsec -any, purescript -any,
151+ transformers -any, Glob >= 0.7 && < 0.8
152+ main-is: Main.hs
153+ buildable: True
154+ hs-source-dirs: psc
155+ other-modules:
156+ ghc-options: -Wall -O2 -fno-warn-unused-do-bind
157+
158+executable psc-make
159+ build-depends: base >=4 && <5, containers -any, directory -any, filepath -any,
160+ mtl -any, optparse-applicative >= 0.10.0, parsec -any, purescript -any,
161+ time -any, transformers -any, transformers-compat -any, Glob >= 0.7 && < 0.8
162+ main-is: Main.hs
163+ buildable: True
164+ hs-source-dirs: psc-make
165+ other-modules: Make
166+ ghc-options: -Wall -O2 -fno-warn-unused-do-bind
167+
168+executable psci
169+ build-depends: base >=4 && <5, containers -any, directory -any, filepath -any,
170+ mtl -any, optparse-applicative >= 0.10.0, parsec -any,
171+ haskeline >= 0.7.0.0, purescript -any, transformers -any,
172+ transformers-compat -any, process -any, time -any, Glob -any
173+
174+ main-is: Main.hs
175+ buildable: True
176+ hs-source-dirs: psci psci/main
177+ other-modules: Types
178+ Parser
179+ Directive
180+ Completion
181+ PSCi
182+ Make
183+ IO
184+ ghc-options: -Wall -O2
185+
186+executable psc-docs
187+ build-depends: base >=4 && <5, purescript -any,
188+ optparse-applicative >= 0.10.0, process -any, mtl -any,
189+ split -any, ansi-wl-pprint -any, directory -any,
190+ filepath -any, Glob -any
191+ main-is: Main.hs
192+ buildable: True
193+ hs-source-dirs: psc-docs
194+ other-modules: Ctags
195+ Etags
196+ Tags
197+ ghc-options: -Wall -O2
198+
199+executable psc-publish
200+ build-depends: base >=4 && <5, purescript -any,
201+ optparse-applicative >= 0.10.0, process -any, mtl -any,
202+ pattern-arrows -any, aeson -any, bytestring -any,
203+ directory -any, transformers -any, text -any, containers
204+ -any, boxes -any, split -any, Glob -any, aeson-better-errors
205+ -any, transformers-compat -any, bower-json -any, semigroups
206+ -any, safe -any
207+ main-is: Main.hs
208+ buildable: True
209+ hs-source-dirs: psc-publish
210+ other-modules: Utils
211+ ErrorsWarnings
212+ BoxesHelpers
213+ ghc-options: -Wall -O2
214+
215+executable psc-hierarchy
216+ build-depends: base >=4 && <5, purescript -any, optparse-applicative >= 0.10.0,
217+ process -any, mtl -any, parsec -any, filepath -any, directory -any,
218+ Glob -any
219+ main-is: Main.hs
220+ buildable: True
221+ hs-source-dirs: hierarchy
222+ other-modules:
223+ ghc-options: -Wall -O2
224+
225+test-suite tests
226+ build-depends: base >=4 && <5, containers -any, directory -any,
227+ filepath -any, mtl -any, parsec -any, purescript -any,
228+ transformers -any, process -any, transformers-compat -any
229+ type: exitcode-stdio-1.0
230+ main-is: Main.hs
231+ buildable: True
232+ hs-source-dirs: tests
233+
234+test-suite psci-tests
235+ build-depends: base >=4 && <5, containers -any, directory -any, filepath -any,
236+ mtl -any, optparse-applicative >= 0.10.0, parsec -any,
237+ haskeline >= 0.7.0.0, purescript -any, transformers -any,
238+ transformers-compat -any, process -any, HUnit -any, time -any,
239+ Glob -any
240+ type: exitcode-stdio-1.0
241+ main-is: Main.hs
242+ buildable: True
243+ hs-source-dirs: psci psci/tests
244+ ghc-options: -Wall
src/CodeGen/IL.hsdeleted−321
@@ -1,321 +0,0 @@
1−-- | This module generates code in the core imperative representation from
2−-- elaborated PureScript code.
3−module CodeGen.IL
4− ( module AST
5− , module Common
6− , moduleToIL
7− ) where
8−
9−import Prelude.Compat
10−import Protolude (ordNub)
11−
12−import Control.Arrow ((&&&))
13−import Control.Monad (forM, liftM, replicateM, void)
14−import Control.Monad.Supply.Class
15−
16−import Data.List ((\\), delete, intersect, nub)
17−import qualified Data.Foldable as F
18−import qualified Data.Map as M
19−import Data.Maybe (fromMaybe, isNothing, mapMaybe)
20−import Data.Monoid ((<>))
21−import Data.String (fromString)
22−import Data.Text (Text)
23−import qualified Data.Text as T
24−
25−import Language.PureScript.AST.SourcePos
26−import Language.PureScript.CoreImp.AST (AST)
27−import qualified Language.PureScript.CoreImp.AST as AST
28−import Language.PureScript.CoreFn
29−import Language.PureScript.Crash
30−import Language.PureScript.Names
31−import Language.PureScript.Options
32−import Language.PureScript.PSString (PSString, mkString)
33−import Language.PureScript.Traversals (sndM)
34−import qualified Language.PureScript.Constants as C
35−
36−import System.FilePath.Posix ((</>))
37−
38−import CodeGen.IL.Common as Common
39−import CodeGen.IL.Optimizer
40−import CodeGen.IL.Printer
41−
42−data DeclType = ModuleDecl | LetDecl | RecLetDecl deriving (Eq)
43−
44−-- | Generate code in the simplified intermediate representation for all declarations in a
45−-- module.
46−moduleToIL
47− :: forall m
48− -- . (Monad m, MonadReader Options m, MonadSupply m, MonadError MultipleErrors m)
49− . (Monad m, MonadSupply m)
50− => Module Ann
51− -> Text
52− -> m (Text, [Text], [AST], Text, Text)
53−moduleToIL (Module _ coms mn _ imps _ foreigns decls) project =
54− do
55− ilDecls <- mapM (bindToIL ModuleDecl) decls
56− optimized <- traverse (traverse (optimize modName')) ilDecls
57− let optimized' = concat optimized
58− values = annotValue <$> optimized'
59− foreigns' = moduleIdentToIL <$> foreigns
60− interface = interfaceSource modName values foreigns
61− imports = nub . concat $ importToIL <$> optimized'
62− implHeader = implHeaderSource modName imports project
63− implFooter = implFooterSource (runModuleName mn) foreigns
64− return $ (interface, foreigns', optimized', implHeader, implFooter)
65− where
66− modName = moduleNameToIL mn
67− modName' = AST.Var Nothing modName
68−
69− annotValue :: AST -> (Text, Bool)
70− annotValue (AST.Function _ (Just name) [] (AST.Block _ [AST.Return _ ret]))
71− | isLiteral ret = (name, True)
72− annotValue (AST.Function _ (Just name) [] _) = (name, False)
73− annotValue _ = error "Unexpected top-level value form"
74−
75− -- | Extracts all declaration names from a binding group.
76− getNames :: Bind Ann -> [Ident]
77− getNames (NonRec _ ident _) = [ident]
78− getNames (Rec vals) = map (snd . fst) vals
79−
80− -- | Generates IL code for a module import
81− --
82− importToIL :: AST -> [Text]
83− importToIL = AST.everything (++) modRef
84− where
85− modRef (AST.Indexer _ (AST.Var _ _) (AST.Var _ mname))
86− | not $ T.null mname = [extract mname]
87− modRef _ = []
88− extract :: Text -> Text
89− extract = T.replace "_" "." . T.dropWhileEnd (=='_')
90−
91− -- |
92− -- Generate code in the simplified intermediate representation for a declaration
93− --
94− bindToIL :: DeclType -> Bind Ann -> m [AST]
95− bindToIL dt (NonRec ann ident val) = return <$> nonRecToIL dt ann ident val
96− bindToIL dt (Rec vals) = forM vals (uncurry . uncurry $ nonRecToIL dt')
97− where
98− dt' = if dt == LetDecl then RecLetDecl else dt
99−
100− -- | Generate code in the simplified intermediate representation for a single non-recursive
101− -- declaration.
102− --
103− -- The main purpose of this function is to handle code generation for comments.
104− nonRecToIL :: DeclType -> Ann -> Ident -> Expr Ann -> m AST
105− nonRecToIL dt a i e@(extractAnn -> (_, com, _, _)) | not (null com) = do
106− -- withoutComment <- asks optionsNoComments
107− let withoutComment = False
108− if withoutComment
109− then nonRecToIL dt a i (modifyAnn removeComments e)
110− else AST.Comment Nothing com <$> nonRecToIL dt a i (modifyAnn removeComments e)
111− nonRecToIL ModuleDecl (ss, _, _, _) ident val = do
112− il <- valueToIL val
113− pure $ AST.Function Nothing (Just $ moduleIdentToIL ident) [] (AST.Block Nothing [AST.Return Nothing il])
114− nonRecToIL RecLetDecl (ss, _, _, _) ident val = do
115− ilExpr <- valueToIL val
116− pure $ AST.Assignment Nothing (AST.Var Nothing $ identToIL ident) ilExpr
117− nonRecToIL _ (ss, _, _, _) ident val = do
118− il <- valueToIL val
119− pure $ AST.VariableIntroduction Nothing (identToIL ident) (Just il)
120−
121− -- | Generate code in the simplified intermediate representation for a variable based on a
122− -- PureScript identifier.
123− var :: Ident -> AST
124− var = AST.Var Nothing . identToIL
125−
126− accessorString :: PSString -> AST -> AST
127− accessorString prop = AST.Indexer Nothing (AST.StringLiteral Nothing prop)
128−
129− -- | Generate code in the simplified intermediate representation for a value or expression.
130−
131− valueToIL :: Expr Ann -> m AST
132− valueToIL (Literal (pos, _, _, _) l) = literalToValueIL pos l
133− valueToIL (Accessor _ prop val) =
134− accessorString prop <$> valueToIL val
135− valueToIL (ObjectUpdate _ o ps) = do
136− obj <- valueToIL o
137− updates <- mapM (sndM valueToIL) ps
138− obj' <- freshName'
139− let objVar = AST.Var Nothing obj'
140− copy = AST.VariableIntroduction Nothing obj' (Just $ copyDict obj)
141− assign (k, v) = AST.Assignment Nothing (accessorString k objVar) v
142− sts = copy : (assign <$> updates) ++ [AST.Return Nothing objVar]
143− return $ AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing sts)) []
144− valueToIL (Abs _ arg val) = do
145− ret <- valueToIL val
146− let ilArg = case arg of
147− UnusedIdent -> []
148− _ -> [identToIL arg]
149− return $ AST.Function Nothing Nothing ilArg (AST.Block Nothing [AST.Return Nothing ret])
150− valueToIL e@App{} = do
151− let (f, args) = unApp e []
152− args' <- mapM valueToIL args
153− fn <- valueToIL f
154− case f of
155− Var (_, _, _, Just IsNewtype) _ -> return (head args')
156− _ -> flip (foldl (\fn a -> AST.App Nothing fn [a])) args' <$> valueToIL f
157− where
158− unApp :: Expr Ann -> [Expr Ann] -> (Expr Ann, [Expr Ann])
159− unApp (App _ val arg) args = unApp val (arg : args)
160− unApp other args = (other, args)
161− valueToIL (Var _ ident) = return $ varToIL ident
162− valueToIL (Case (ss, _, _, _) values binders) = do
163− vals <- mapM valueToIL values
164− bindersToIL ss binders vals
165− valueToIL (Let _ ds val) = do
166− let recurs = concatMap getNames $ filter isRec ds
167− recurDs = (\v -> AST.VariableIntroduction Nothing (identToIL v) Nothing) <$> recurs
168− ds' <- concat <$> mapM (bindToIL LetDecl) ds
169− ret <- valueToIL val
170− return $ AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing (recurDs ++ ds' ++ [AST.Return Nothing ret]))) []
171− where
172− isRec :: Bind Ann -> Bool
173− isRec (Rec _) = True
174− isRec _ = False
175− valueToIL (Constructor (_, _, _, Just IsNewtype) _ (ProperName ctor) _) = error "IsNewtype"
176− valueToIL (Constructor _ _ (ProperName ctor) fields) =
177− let body = AST.ObjectLiteral Nothing $ (mkString ctor, AST.BooleanLiteral Nothing True) :
178− ((\field -> (mkString (identToIL field), var field)) `map` fields)
179− fn = foldr (\f inner -> AST.Function Nothing Nothing [identToIL f] (AST.Block Nothing [AST.Return Nothing inner])) body fields
180− in return fn
181−
182−
183− iife :: Text -> [AST] -> AST
184− iife v exprs = AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing $ exprs ++ [AST.Return Nothing $ AST.Var Nothing v])) []
185−
186− literalToValueIL :: SourceSpan -> Literal (Expr Ann) -> m AST
187− literalToValueIL ss (NumericLiteral (Left i)) = return $ AST.NumericLiteral (Just ss) (Left i)
188− literalToValueIL ss (NumericLiteral (Right n)) = return $ AST.NumericLiteral (Just ss) (Right n)
189− literalToValueIL ss (StringLiteral s) = return $ AST.StringLiteral (Just ss) s
190− literalToValueIL ss (CharLiteral c) = return $ AST.StringLiteral (Just ss) (fromString [c])
191− literalToValueIL ss (BooleanLiteral b) = return $ AST.BooleanLiteral (Just ss) b
192− literalToValueIL ss (ArrayLiteral xs) = AST.ArrayLiteral (Just ss) <$> mapM valueToIL xs
193− literalToValueIL ss (ObjectLiteral ps) = AST.ObjectLiteral (Just ss) <$> mapM (sndM valueToIL) ps
194−
195− -- | Generate code in the simplified intermediate representation for a reference to a
196− -- variable.
197− varToIL :: Qualified Ident -> AST
198− varToIL (Qualified Nothing ident) = var ident
199− varToIL qual = qualifiedToIL id qual
200−
201− -- | Generate code in the simplified intermediate representation for a reference to a
202− -- variable that may have a qualified name.
203− qualifiedToIL :: (a -> Ident) -> Qualified a -> AST
204− qualifiedToIL f (Qualified (Just (ModuleName mn')) a) | mn' == C.prim = AST.Var Nothing . moduleIdentToIL $ f a
205− qualifiedToIL f (Qualified (Just mn') a) | mn /= mn' = AST.Indexer Nothing (AST.Var Nothing . moduleIdentToIL $ f a) (AST.Var Nothing (moduleNameToIL mn'))
206− qualifiedToIL f (Qualified _ a) = AST.Indexer Nothing (AST.Var Nothing . moduleIdentToIL $ f a) (AST.Var Nothing "")
207−
208− -- foreignIdent :: Ident -> AST
209− -- foreignIdent ident = accessorString (mkString $ runIdent ident) (AST.Var Nothing "$foreign")
210−
211− -- | Generate code in the simplified intermediate representation for pattern match binders
212− -- and guards.
213− bindersToIL :: SourceSpan -> [CaseAlternative Ann] -> [AST] -> m AST
214− bindersToIL ss binders vals = do
215− valNames <- replicateM (length vals) freshName'
216− let assignments = zipWith (AST.VariableIntroduction Nothing) valNames (map Just vals)
217− ils <- forM binders $ \(CaseAlternative bs result) -> do
218− ret <- guardsToIL result
219− go valNames ret bs
220− return $ AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing (assignments ++ concat ils ++ [AST.Throw Nothing (AST.StringLiteral Nothing $ mkString failedPatternMessage)])))
221− []
222− where
223− go :: [Text] -> [AST] -> [Binder Ann] -> m [AST]
224− go _ done [] = return done
225− go (v:vs) done' (b:bs) = do
226− done'' <- go vs done' bs
227− binderToIL v done'' b
228− go _ _ _ = internalError "Invalid arguments to bindersToIL"
229−
230− failedPatternMessage :: Text
231− failedPatternMessage = "Failed pattern match at " <> runModuleName mn <> " " <> displayStartEndPos ss
232−
233− guardsToIL :: Either [(Guard Ann, Expr Ann)] (Expr Ann) -> m [AST]
234− guardsToIL (Left gs) = traverse genGuard gs where
235− genGuard (cond, val) = do
236− cond' <- valueToIL cond
237− val' <- valueToIL val
238− return
239− (AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo cond' (AST.BooleanLiteral Nothing True))
240− (AST.Block Nothing [AST.Return Nothing val']) Nothing)
241−
242− guardsToIL (Right v) = return . AST.Return Nothing <$> valueToIL v
243−
244− -- | Generate code in the simplified intermediate representation for a pattern match
245− -- binder.
246− binderToIL :: Text -> [AST] -> Binder Ann -> m [AST]
247− binderToIL _ done NullBinder{} = return done
248− binderToIL varName done (LiteralBinder _ l) =
249− literalToBinderIL varName done l
250− binderToIL varName done (VarBinder _ ident) =
251− return (AST.VariableIntroduction Nothing (identToIL ident) (Just (AST.Var Nothing varName)) : done)
252− binderToIL varName done (ConstructorBinder (_, _, _, Just IsNewtype) _ _ [b]) =
253− binderToIL varName done b
254− binderToIL varName done (ConstructorBinder (_, _, _, Just (IsConstructor ctorType fields)) _ (Qualified _ (ProperName ctor)) bs) = do
255− il <- go (zip fields bs) done
256− return $ case ctorType of
257− ProductType -> il
258− SumType ->
259− [AST.IfElse Nothing (AST.InstanceOf Nothing (AST.Var Nothing varName) (AST.StringLiteral Nothing (mkString ctor)))
260− (AST.Block Nothing il)
261− Nothing]
262− where
263− go :: [(Ident, Binder Ann)] -> [AST] -> m [AST]
264− go [] done' = return done'
265− go ((field, binder) : remain) done' = do
266− argVar <- freshName'
267− done'' <- go remain done'
268− il <- binderToIL argVar done'' binder
269− return (AST.VariableIntroduction Nothing argVar (Just $ accessorString (mkString $ identToIL field) $ AST.Var Nothing varName) : il)
270−
271− binderToIL _ _ ConstructorBinder{} =
272− internalError "binderToIL: Invalid ConstructorBinder in binderToIL"
273− binderToIL varName done (NamedBinder _ ident binder) = do
274− il <- binderToIL varName done binder
275− return (AST.VariableIntroduction Nothing (identToIL ident) (Just (AST.Var Nothing varName)) : il)
276−
277− literalToBinderIL :: Text -> [AST] -> Literal (Binder Ann) -> m [AST]
278− literalToBinderIL varName done (NumericLiteral num) =
279− return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.NumericLiteral Nothing num)) (AST.Block Nothing done) Nothing]
280− literalToBinderIL varName done (CharLiteral c) =
281− return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.StringLiteral Nothing (fromString [c]))) (AST.Block Nothing done) Nothing]
282− literalToBinderIL varName done (StringLiteral str) =
283− return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.StringLiteral Nothing str)) (AST.Block Nothing done) Nothing]
284− literalToBinderIL varName done (BooleanLiteral True) =
285− return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.BooleanLiteral Nothing True)) (AST.Block Nothing done) Nothing]
286− literalToBinderIL varName done (BooleanLiteral False) =
287− return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.BooleanLiteral Nothing False)) (AST.Block Nothing done) Nothing]
288− -- return [AST.IfElse Nothing (AST.Unary Nothing AST.Not (AST.Var Nothing varName)) (AST.Block Nothing done) Nothing]
289− literalToBinderIL varName done (ObjectLiteral bs) = go done bs
290− where
291− go :: [AST] -> [(PSString, Binder Ann)] -> m [AST]
292− go done' [] = return done'
293− go done' ((prop, binder):bs') = do
294− propVar <- freshName'
295− done'' <- go done' bs'
296− il <- binderToIL propVar done'' binder
297− return (AST.VariableIntroduction Nothing propVar (Just (accessorString prop (AST.Var Nothing varName))) : il)
298− literalToBinderIL varName done (ArrayLiteral bs) = do
299− il <- go done 0 bs
300− return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo
301− (arrayLength $ AST.Var Nothing varName)
302− (AST.NumericLiteral Nothing (Left (fromIntegral $ length bs))))
303− (AST.Block Nothing il) Nothing]
304− where
305− go :: [AST] -> Integer -> [Binder Ann] -> m [AST]
306− go done' _ [] = return done'
307− go done' index (binder:bs') = do
308− elVar <- freshName'
309− done'' <- go done' (index + 1) bs'
310− il <- binderToIL elVar done'' binder
311− return (AST.VariableIntroduction Nothing elVar (Just (AST.Indexer Nothing (AST.NumericLiteral Nothing (Left index)) (AST.Var Nothing varName))) : il)
312−
313−emptyAnn :: Ann
314−emptyAnn = (SourceSpan "" (SourcePos 0 0) (SourcePos 0 0), [], Nothing, Nothing)
315−
316−arrayLength :: AST -> AST
317−arrayLength a = AST.App Nothing (AST.Var Nothing arrayLengthFn) [a]
318−-- arrayLength a = AST.Var Nothing (arrayLengthFn <> "(" <> prettyPrintIL1 a <> ")")
319−
320−copyDict :: AST -> AST
321−copyDict a = AST.App Nothing (AST.Var Nothing copyDictFn) [a]
src/CodeGen/IL/Common.hsdeleted−196
@@ -1,196 +0,0 @@
1−-- | Common code generation utility functions
2−module CodeGen.IL.Common where
3−
4−import Prelude.Compat
5−
6−import Control.Monad.Supply.Class (MonadSupply, freshName)
7−import Data.Char
8−import Data.Maybe (maybe)
9−import Data.Monoid ((<>))
10−import Data.Text (Text)
11−import qualified Data.Text as T
12−
13−import Language.PureScript.Crash
14−import Language.PureScript.Names
15−
16−import qualified Language.PureScript.Constants as C
17−
18−moduleNameToIL :: ModuleName -> Text
19−moduleNameToIL (ModuleName mn) =
20− let name = T.replace "." "_" mn
21− in if nameIsILBuiltIn name then (name <> moduleRenamerMarker) else name
22−
23−moduleNameToIL' :: ModuleName -> Text
24−moduleNameToIL' (ModuleName mn) = T.replace "_" "." mn
25−
26−-- | Convert an 'Ident' into a valid IL identifier:
27−--
28−-- * Alphanumeric characters are kept unmodified.
29−--
30−-- * Reserved IL identifiers are wrapped with '_'.
31−--
32−identToIL :: Ident -> Text
33−identToIL UnusedIdent = unusedName
34−identToIL (Ident "$__unused") = unusedName
35−identToIL (Ident name) | name == C.undefined = undefinedName -- Note: done in Printer.hs too
36−identToIL (Ident name) = properToIL name
37−identToIL (GenIdent _ _) = internalError "GenIdent in identToIL"
38−
39−moduleIdentToIL :: Ident -> Text
40−moduleIdentToIL UnusedIdent = unusedName
41−moduleIdentToIL (Ident name) | name == C.undefined = undefinedName
42−moduleIdentToIL (Ident name) = moduleProperToIL name
43−moduleIdentToIL (GenIdent _ _) = internalError "GenIdent in identToIL"
44−
45−undefinedName :: Text
46−undefinedName = "Undefined"
47−
48−unusedName :: Text
49−unusedName = "_"
50−
51−properToIL :: Text -> Text
52−properToIL name
53− | nameIsILReserved name = "ˉ" <> name
54− | otherwise = T.concatMap identCharToText name
55−
56−-- | Attempts to find a human-readable name for a symbol, if none has been specified returns the
57−-- ordinal value.
58−identCharToText :: Char -> Text
59−identCharToText 'ṩ' = "_ṩ"
60−identCharToText c | isAlphaNum c = T.singleton c
61−identCharToText '_' = "_"
62−identCharToText '\'' = "ꞌ" -- lowercase saltillo
63−identCharToText c = error (show (ord c)) -- TODO: should never occur now(?)
64−
65−moduleProperToIL :: Text -> Text
66−moduleProperToIL = T.concatMap identCharToText
67−
68−-- | Checks whether an identifier name is reserved in IL.
69−nameIsILReserved :: Text -> Bool
70−nameIsILReserved name =
71− name `elem` ilAnyReserved
72−
73−-- | Checks whether a name matches a built-in value in IL.
74−nameIsILBuiltIn :: Text -> Bool
75−nameIsILBuiltIn name =
76− name `elem`
77− [ "Any"
78− , "Apply"
79− , "Contains"
80− , "CopyDict"
81− , "Dict"
82− , "EffFn"
83− , "Fn"
84− , "Foreign"
85− , "Get"
86− , "Index"
87− , "Is"
88− , "Length"
89− , "Once"
90− , "Run"
91− , "Undefined"
92− ]
93−
94−ilAnyReserved :: [Text]
95−ilAnyReserved =
96− concat
97− [ ilKeywords
98− , ilLiterals
99− ]
100−
101−ilKeywords :: [Text]
102−ilKeywords =
103− [ "break"
104− , "case"
105− , "chan"
106− , "const"
107− , "continue"
108− , "default"
109− , "defer"
110− , "else"
111− , "fallthrough"
112− , "for"
113− , "func"
114− , "go"
115− , "goto"
116− , "if"
117− , "import"
118− , "interface"
119− , "map"
120− , "package"
121− , "range"
122− , "return"
123− , "select"
124− , "struct"
125− , "switch"
126− , "type"
127− , "var"
128− ]
129−
130−ilLiterals :: [Text]
131−ilLiterals =
132− [ "init"
133− , "nil"
134− , "int"
135− , "int8"
136− , "int16"
137− , "int32"
138− , "int64"
139− , "uint"
140− , "uint8"
141− , "uint16"
142− , "uint32"
143− , "uint64"
144− , "uintptr"
145− , "float32"
146− , "float64"
147− , "complex64"
148− , "complex128"
149− , "byte"
150− , "rune"
151− , "string"
152− ]
153−
154−withPrefix :: Text -> Text
155−withPrefix s = "Ꞌ" <> s -- uppercase saltillo
156−
157−anyType :: Text
158−anyType = "Any"
159−
160−dictType :: Text
161−dictType = "Dict"
162−
163−arrayType :: Text
164−arrayType = "[]" <> anyType
165−
166−uncurriedFnType :: Int -> Text
167−uncurriedFnType i = "Fn" <> (T.pack . show $ i)
168−
169−int :: Text
170−int = "int"
171−
172−float :: Text
173−float = "float64"
174−
175−bool :: Text
176−bool = "bool"
177−
178−string :: Text
179−string = "string"
180−
181−arrayLengthFn :: Text
182−arrayLengthFn = "Length"
183−
184−indexFn :: Text
185−indexFn = "Index"
186−
187−copyDictFn :: Text
188−copyDictFn = "CopyDict"
189−
190−freshName' :: MonadSupply m => m Text
191−freshName' = do
192− name <- freshName
193− return $ T.replace "$" "ṩ" name
194−
195−moduleRenamerMarker :: Text
196−moduleRenamerMarker = "__"
src/CodeGen/IL/Optimizer.hsdeleted−81
@@ -1,81 +0,0 @@
1−-- | This module optimizes code in the intermediate representation.
2−module CodeGen.IL.Optimizer (optimize) where
3−
4−import Prelude.Compat
5−
6−import Control.Monad.Supply.Class (MonadSupply)
7−import Data.Text (Text)
8−import Language.PureScript.CoreImp.AST
9−import Language.PureScript.CoreImp.Optimizer.Blocks
10−import Language.PureScript.CoreImp.Optimizer.Common hiding (isDict)
11−import Language.PureScript.CoreImp.Optimizer.Inliner (etaConvert, evaluateIifes, inlineVariables, unThunk)
12−import Language.PureScript.CoreImp.Optimizer.Unused
13−
14−import CodeGen.IL.Common (unusedName)
15−import CodeGen.IL.Optimizer.Inliner
16−import CodeGen.IL.Optimizer.MagicDo
17−import CodeGen.IL.Optimizer.TCO
18−
19−import qualified Language.PureScript.Constants as C
20−
21−-- | Apply a series of optimizer passes to simplified IL code
22−optimize :: MonadSupply m => AST -> AST -> m AST
23−optimize mn il = do
24− il' <- untilFixedPoint (inlineFnComposition . inlineUnsafeCoerce . inlineUnsafePartial . tidyUp) il
25− il'' <- untilFixedPoint (return . ignoreUnusedResults . inlineCommonValues . inlineCommonOperators . tidyUp) . tco mn . inlineST
26− =<< untilFixedPoint (return . magicDoST)
27− =<< untilFixedPoint (return . magicDoEff)
28− =<< untilFixedPoint (return . magicDoEffect) il'
29− untilFixedPoint (return . collapseVarDeclarations) il''
30− where
31− tidyUp :: AST -> AST
32− tidyUp = applyAll
33− [ collapseNestedBlocks
34− , collapseNestedIfs
35− , collapseIfChecks
36− , removeCodeAfterReturnStatements
37− , unThunk
38− , etaConvert
39− , evaluateIifes
40− , inlineVariables
41− ]
42−
43−untilFixedPoint :: (Monad m, Eq a) => (a -> m a) -> a -> m a
44−untilFixedPoint f = go
45− where
46− go a = do
47− a' <- f a
48− if a' == a then return a' else go a'
49−
50−collapseIfChecks :: AST -> AST
51−collapseIfChecks = everywhere collapse where
52− collapse :: AST -> AST
53− collapse (IfElse _ (Binary _ EqualTo (BooleanLiteral _ True) (BooleanLiteral _ True)) (Block _ [exprs]) _) = exprs
54− collapse (IfElse _ (Binary _ EqualTo (Indexer _ (Var _ prop) (Var _ val)) (BooleanLiteral _ True)) (Block _ [exprs]) _)
55− | prop == "otherwise" && val == "Data_Boolean" = exprs
56− collapse exprs = exprs
57−
58−collapseVarDeclarations :: AST -> AST
59−collapseVarDeclarations = everywhere collapse where
60− collapse :: AST -> AST
61− collapse (Block ss sts) = Block ss (go Nothing sts)
62− collapse s = s
63−
64− go :: Maybe Text -> [AST] -> [AST]
65− go _ [] = []
66− go Nothing (decl@(VariableIntroduction _ var (Just _)) : sts) = decl : go (Just var) (go Nothing sts)
67− go (Just var') ((VariableIntroduction ss var (Just val)) : sts)
68− | var == var' = (Assignment ss (Var Nothing var) val) : go (Just var') sts
69− go var' (s:sts) = s : go var' sts
70−
71−ignoreUnusedResults :: AST -> AST
72−ignoreUnusedResults = everywhere $ removeFromBlock go
73− where
74− go :: [AST] -> [AST]
75− go [] = []
76− go (VariableIntroduction ss var (Just s) : sts)
77− | not $ any (everything (||) (isUsed var)) sts = sts'
78− where
79− sts' | App{} <- s = s : (go sts)
80− | otherwise = go sts
81− go (s:sts) = s : go sts
src/CodeGen/IL/Optimizer/Common.hsdeleted−18
@@ -1,18 +0,0 @@
1−-- | Common functions used by the various optimizer phases
2−module CodeGen.IL.Optimizer.Common where
3−
4−import Prelude.Compat
5−
6−import Data.Text (Text)
7−
8−import Language.PureScript.CoreImp.AST
9−import Language.PureScript.PSString (PSString, decodeString)
10−
11−isDict :: (Text, PSString) -> AST -> Bool
12−isDict (moduleName, dictName) (Indexer _ (Var _ x) (Var _ y)) =
13− Just x == decodeString dictName && y == moduleName
14−isDict _ _ = False
15−
16−isDict' :: [(Text, PSString)] -> AST -> Bool
17−isDict' xs il = any (`isDict` il) xs
18−
src/CodeGen/IL/Optimizer/Inliner.hsdeleted−435
@@ -1,435 +0,0 @@
1−-- | This module performs basic inlining of known functions
2−module CodeGen.IL.Optimizer.Inliner
3− ( inlineCommonValues
4− , inlineCommonOperators
5− , inlineFnComposition
6− , inlineUnsafeCoerce
7− , inlineUnsafePartial
8− ) where
9−
10−import Prelude.Compat
11−
12−import Control.Monad.Supply.Class (MonadSupply)
13−
14−import Data.Either (rights)
15−import Data.Maybe (fromMaybe)
16−import Data.String (IsString, fromString)
17−import Data.Text (Text)
18−import qualified Data.Text as T
19−
20−import Language.PureScript.PSString (PSString, decodeString, mkString)
21−import Language.PureScript.CoreImp.AST
22−import Language.PureScript.CoreImp.Optimizer.Common hiding (isDict, isDict')
23−import Language.PureScript.AST (SourceSpan(..))
24−import qualified Language.PureScript.Constants as C
25−
26−import CodeGen.IL.Common
27−import CodeGen.IL.Optimizer.Common
28−
29−-- TODO: Potential bug:
30−-- Shouldn't just inline this case: { var x = 0; x.toFixed(10); }
31−-- Needs to be: { 0..toFixed(10); }
32−-- Probably needs to be fixed in pretty-printer instead.
33−shouldInline :: AST -> Bool
34−shouldInline (Var _ _) = True
35−shouldInline (NumericLiteral _ _) = True
36−shouldInline (StringLiteral _ _) = True
37−shouldInline (BooleanLiteral _ _) = True
38−shouldInline (Indexer _ index val) = shouldInline index && shouldInline val
39−shouldInline _ = False
40−
41−inlineCommonValues :: AST -> AST
42−inlineCommonValues = everywhere convert
43− where
44− convert :: AST -> AST
45− convert (App ss fn [dict])
46− | isDict' [semiringNumber, semiringInt] dict && isDict fnZero fn = NumericLiteral ss (Left 0)
47− | isDict' [semiringNumber, semiringInt] dict && isDict fnOne fn = NumericLiteral ss (Left 1)
48− | isDict boundedBoolean dict && isDict fnBottom fn = BooleanLiteral ss False
49− | isDict boundedBoolean dict && isDict fnTop fn = BooleanLiteral ss True
50− convert (App ss (App _ fn [dict]) [x])
51− | isDict ringInt dict && isDict fnNegate fn = Unary ss Negate (unbox x $ snd ringInt)
52− convert (App ss (App _ (App _ fn [dict]) [x]) [y])
53− | isDict semiringInt dict && isDict fnAdd fn = intOp ss Add semiringInt x y
54− | isDict semiringInt dict && isDict fnMultiply fn = intOp ss Multiply semiringInt x y
55− | isDict ringInt dict && isDict fnSubtract fn = intOp ss Subtract ringInt x y
56− convert other = other
57− fnZero = (C.dataSemiring, C.zero)
58− fnOne = (C.dataSemiring, C.one)
59− fnBottom = (C.dataBounded, C.bottom)
60− fnTop = (C.dataBounded, C.top)
61− fnAdd = (C.dataSemiring, C.add)
62− fnMultiply = (C.dataSemiring, C.mul)
63− fnSubtract = (C.dataRing, C.sub)
64− fnNegate = (C.dataRing, C.negate)
65− intOp ss op (_, d) x y = Binary ss op (unbox x d) (unbox y d)
66−
67−inlineCommonOperators :: AST -> AST
68−inlineCommonOperators = everywhereTopDown $ applyAll $
69− [ binary semiringNumber opAdd Add
70− , binary semiringNumber opMul Multiply
71−
72− , binary ringNumber opSub Subtract
73− , unary ringNumber opNegate Negate
74−
75− , binary euclideanRingNumber opDiv Divide
76−
77− -- , binary eqNumber opEq EqualTo
78− -- , binary eqNumber opNotEq NotEqualTo
79− , binary eqInt opEq EqualTo
80− , binary eqInt opNotEq NotEqualTo
81− , binary eqString opEq EqualTo
82− , binary eqString opNotEq NotEqualTo
83− , binary eqChar opEq EqualTo
84− , binary eqChar opNotEq NotEqualTo
85− , binary eqBoolean opEq EqualTo
86− , binary eqBoolean opNotEq NotEqualTo
87−
88− , binary ordBoolean opLessThan LessThan
89− , binary ordBoolean opLessThanOrEq LessThanOrEqualTo
90− , binary ordBoolean opGreaterThan GreaterThan
91− , binary ordBoolean opGreaterThanOrEq GreaterThanOrEqualTo
92− , binary ordChar opLessThan LessThan
93− , binary ordChar opLessThanOrEq LessThanOrEqualTo
94− , binary ordChar opGreaterThan GreaterThan
95− , binary ordChar opGreaterThanOrEq GreaterThanOrEqualTo
96− , binary ordInt opLessThan LessThan
97− , binary ordInt opLessThanOrEq LessThanOrEqualTo
98− , binary ordInt opGreaterThan GreaterThan
99− , binary ordInt opGreaterThanOrEq GreaterThanOrEqualTo
100− , binary ordNumber opLessThan LessThan
101− , binary ordNumber opLessThanOrEq LessThanOrEqualTo
102− , binary ordNumber opGreaterThan GreaterThan
103− , binary ordNumber opGreaterThanOrEq GreaterThanOrEqualTo
104− , binary ordString opLessThan LessThan
105− , binary ordString opLessThanOrEq LessThanOrEqualTo
106− , binary ordString opGreaterThan GreaterThan
107− , binary ordString opGreaterThanOrEq GreaterThanOrEqualTo
108−
109− , binary semigroupString opAppend Add
110−
111− , binary heytingAlgebraBoolean opConj And
112− , binary heytingAlgebraBoolean opDisj Or
113− , unary heytingAlgebraBoolean opNot Not
114−
115− , binary' C.dataIntBits C.or BitwiseOr
116− , binary' C.dataIntBits C.and BitwiseAnd
117− , binary' C.dataIntBits C.xor BitwiseXor
118− , binary' C.dataIntBits C.shl ShiftLeft
119− , binary' C.dataIntBits C.shr ShiftRight
120− , unary' C.dataIntBits C.complement BitwiseNot
121−
122− , inlineNonClassFunction (isModFn (C.dataFunction, C.apply)) $ \f x -> App Nothing f [x]
123− , inlineNonClassFunction (isModFn (C.dataFunction, C.applyFlipped)) $ \x f -> App Nothing f [x]
124− , inlineUnsafeIndex (isModFnWithDict (C.dataArray, C.unsafeIndex)) $ flip (Indexer Nothing)
125− ] ++
126− [ fn | i <- [0..10], fn <- [ mkFn i, runFn i ] ] ++
127− [ fn | i <- [0..10], fn <- [ mkEffFn C.controlMonadEffUncurried C.mkEffFn i, runEffFn C.controlMonadEffUncurried C.runEffFn i ] ] ++
128− [ fn | i <- [0..10], fn <- [ mkEffFn C.effectUncurried C.mkEffectFn i, runEffFn C.effectUncurried C.runEffectFn i ] ]
129− where
130− binary :: (Text, PSString) -> (Text, PSString) -> BinaryOperator -> AST -> AST
131− binary dict@(_, d) fns op = convert where
132− convert :: AST -> AST
133− convert (App ss (App _ (App _ fn [dict']) [x]) [y])
134− | isDict dict dict' && isDict fns fn = Binary ss op (unbox x d) (unbox y d)
135− convert other = other
136− binary' :: Text -> PSString -> BinaryOperator -> AST -> AST
137− binary' moduleName opString op = convert where
138− convert :: AST -> AST
139− convert (App ss (App _ fn [x]) [y]) | isDict (moduleName, opString) fn = Binary ss op (unbox x mn) (unbox y mn)
140− convert other = other
141− mn :: PSString
142− mn = mkString moduleName
143− unary :: (Text, PSString) -> (Text, PSString) -> UnaryOperator -> AST -> AST
144− unary dicts@(_, d) fns op = convert where
145− convert :: AST -> AST
146− convert (App ss (App _ fn [dict']) [x]) | isDict dicts dict' && isDict fns fn = Unary ss op (unbox x d)
147− convert other = other
148− unary' :: Text -> PSString -> UnaryOperator -> AST -> AST
149− unary' moduleName fnName op = convert where
150− convert :: AST -> AST
151− convert (App ss fn [x]) | isDict (moduleName, fnName) fn = Unary ss op (unbox x fnName)
152− convert other = other
153−
154− mkFn :: Int -> AST -> AST
155− mkFn = mkFn' C.dataFunctionUncurried C.mkFn $ \ss1 ss2 ss3 args il ->
156− Function ss1 Nothing args (Block ss2 [Return ss3 il])
157−
158− mkEffFn :: Text -> Text -> Int -> AST -> AST
159− mkEffFn modName fnName = mkFn' modName fnName $ \ss1 ss2 ss3 args il ->
160− Function ss1 Nothing args (Block ss2 [Return ss3 (App ss3 il [])])
161−
162− mkFn' :: Text -> Text -> (Maybe SourceSpan -> Maybe SourceSpan -> Maybe SourceSpan -> [Text] -> AST -> AST) -> Int -> AST -> AST
163− mkFn' modName fnName res 0 = convert where
164− convert :: AST -> AST
165− convert (App _ mkFnN [Function s1 Nothing [_] (Block s2 [Return s3 il])]) | isNFn modName fnName 0 mkFnN =
166− res s1 s2 s3 [] il
167− convert other = other
168− mkFn' modName fnName res n = convert where
169− convert :: AST -> AST
170− convert orig@(App ss mkFnN [fn]) | isNFn modName fnName n mkFnN =
171− case collectArgs n [] fn of
172− Just (args, [Return ss' ret]) -> res ss ss ss' args ret
173− _ -> orig
174− convert other = other
175− collectArgs :: Int -> [Text] -> AST -> Maybe ([Text], [AST])
176− collectArgs 1 acc (Function _ Nothing [oneArg] (Block _ il)) | length acc == n - 1 = Just (reverse (oneArg : acc), il)
177− collectArgs m acc (Function _ Nothing [oneArg] (Block _ [Return _ ret])) = collectArgs (m - 1) (oneArg : acc) ret
178− collectArgs _ _ _ = Nothing
179−
180− isNFn :: Text -> Text -> Int -> AST -> Bool
181− isNFn expectMod prefix n (Indexer _ (Var _ name) (Var _ modName)) | modName == expectMod =
182− name == fromString (T.unpack prefix <> show n)
183− isNFn _ _ _ _ = False
184−
185− runFn :: Int -> AST -> AST
186− runFn = runFn' C.dataFunctionUncurried C.runFn (\ss f args ->
187− let len = length args
188− typ = mkString $ uncurriedFnType len in
189− if len > 0
190− then App ss (App Nothing (StringLiteral Nothing typ) [f]) args
191− else App ss f args)
192− runEffFn :: Text -> Text -> Int -> AST -> AST
193− runEffFn modName fnName = runFn' modName fnName $ \ss fn acc ->
194− let typ = mkString . uncurriedFnType $ length acc in
195− Function ss Nothing [] (Block ss [Return ss (App ss (App Nothing (StringLiteral Nothing typ) [fn]) acc)])
196−
197− runFn' :: Text -> Text -> (Maybe SourceSpan -> AST -> [AST] -> AST) -> Int -> AST -> AST
198− runFn' modName runFnName res n = convert where
199− convert :: AST -> AST
200− convert il = fromMaybe il $ go n [] il
201−
202− go :: Int -> [AST] -> AST -> Maybe AST
203− go 0 acc (App ss runFnN [fn]) | isNFn modName runFnName n runFnN && length acc == n =
204− Just $ res ss fn acc
205− go m acc (App _ lhs [arg]) = go (m - 1) (arg : acc) lhs
206− go _ _ _ = Nothing
207−
208− inlineNonClassFunction :: (AST -> Bool) -> (AST -> AST -> AST) -> AST -> AST
209− inlineNonClassFunction p f = convert where
210− convert :: AST -> AST
211− convert (App _ (App _ op' [x]) [y]) | p op' = f x y
212− convert other = other
213−
214− inlineUnsafeIndex :: (AST -> Bool) -> (AST -> AST -> AST) -> AST -> AST
215− inlineUnsafeIndex p _ = convert where
216− convert :: AST -> AST
217− convert (App _ (App ss op' [x]) [y@NumericLiteral{}])
218− | p op' = Indexer ss y x
219− convert (App _ (App ss op' [x]) [y])
220− | p op' = App ss (Var Nothing indexFn) [x, y]
221− convert other = other
222−
223− isModFn :: (Text, PSString) -> AST -> Bool
224− isModFn (m, op) (Indexer _ (Var _ op') (Var _ m')) =
225− m == m' && decodeString op == Just op'
226− isModFn _ _ = False
227−
228− isModFnWithDict :: (Text, PSString) -> AST -> Bool
229− isModFnWithDict (m, op) (App _ (Indexer _ (Var _ op') (Var _ m')) [Var _ _]) =
230− m == m' && decodeString op == Just op'
231− isModFnWithDict _ _ = False
232−
233−-- (f <<< g $ x) = f (g x)
234−-- (f <<< g) = \x -> f (g x)
235−inlineFnComposition :: forall m. MonadSupply m => AST -> m AST
236−inlineFnComposition = everywhereTopDownM convert where
237− convert :: AST -> m AST
238− convert (App s1 (App s2 (App _ (App _ fn [dict']) [x]) [y]) [z])
239− | isFnCompose dict' fn = return $ App s1 x [App s2 y [z]]
240− | isFnComposeFlipped dict' fn = return $ App s2 y [App s1 x [z]]
241− convert app@(App ss (App _ (App _ fn [dict']) _) _)
242− | isFnCompose dict' fn || isFnComposeFlipped dict' fn = mkApps ss <$> goApps app <*> freshName'
243− convert other = return other
244−
245− mkApps :: Maybe SourceSpan -> [Either AST (Text, AST)] -> Text -> AST
246− mkApps ss fns a = App ss (Function ss Nothing [] (Block ss $ vars <> [Return Nothing comp])) []
247− where
248− vars = uncurry (VariableIntroduction ss) . fmap Just <$> rights fns
249− comp = Function ss Nothing [a] (Block ss [Return Nothing apps])
250− apps = foldr (\fn acc -> App ss (mkApp fn) [acc]) (Var ss a) fns
251−
252− mkApp :: Either AST (Text, AST) -> AST
253− mkApp = either id $ \(name, arg) -> Var (getSourceSpan arg) name
254−
255− goApps :: AST -> m [Either AST (Text, AST)]
256− goApps (App _ (App _ (App _ fn [dict']) [x]) [y])
257− | isFnCompose dict' fn = mappend <$> goApps x <*> goApps y
258− | isFnComposeFlipped dict' fn = mappend <$> goApps y <*> goApps x
259− goApps app@(App {}) = pure . Right . (,app) <$> freshName'
260− goApps other = pure [Left other]
261−
262− isFnCompose :: AST -> AST -> Bool
263− isFnCompose dict' fn = isDict semigroupoidFn dict' && isDict fnCompose fn
264−
265− isFnComposeFlipped :: AST -> AST -> Bool
266− isFnComposeFlipped dict' fn = isDict semigroupoidFn dict' && isDict fnComposeFlipped fn
267−
268− fnCompose :: forall a b. (IsString a, IsString b) => (a, b)
269− fnCompose = (C.controlSemigroupoid, C.compose)
270−
271− fnComposeFlipped :: forall a b. (IsString a, IsString b) => (a, b)
272− fnComposeFlipped = (C.controlSemigroupoid, C.composeFlipped)
273−
274−inlineUnsafeCoerce :: AST -> AST
275−inlineUnsafeCoerce = everywhereTopDown convert where
276− convert (App _ (Indexer _ (Var _ unsafeCoerceFn) (Var _ unsafeCoerce)) [ comp ])
277− | unsafeCoerceFn == C.unsafeCoerceFn && unsafeCoerce == C.unsafeCoerce
278− = comp
279− convert other = other
280−
281−inlineUnsafePartial :: AST -> AST
282−inlineUnsafePartial = everywhereTopDown convert where
283− convert (App ss fn [ comp ])
284− | isDict fnUnsafePartial fn
285− = App ss comp []
286− where
287− fnUnsafePartial :: forall a b. (IsString a, IsString b) => (a, b)
288− fnUnsafePartial = (C.partialUnsafe, C.unsafePartial)
289− convert other = other
290−
291−semiringNumber :: forall a b. (IsString a, IsString b) => (a, b)
292−semiringNumber = (C.dataSemiring, C.semiringNumber)
293−
294−semiringInt :: forall a b. (IsString a, IsString b) => (a, b)
295−semiringInt = (C.dataSemiring, C.semiringInt)
296−
297−ringNumber :: forall a b. (IsString a, IsString b) => (a, b)
298−ringNumber = (C.dataRing, C.ringNumber)
299−
300−ringInt :: forall a b. (IsString a, IsString b) => (a, b)
301−ringInt = (C.dataRing, C.ringInt)
302−
303−euclideanRingNumber :: forall a b. (IsString a, IsString b) => (a, b)
304−euclideanRingNumber = (C.dataEuclideanRing, C.euclideanRingNumber)
305−
306−-- eqNumber :: forall a b. (IsString a, IsString b) => (a, b)
307−-- eqNumber = (C.dataEq, C.eqNumber)
308−
309−eqInt :: forall a b. (IsString a, IsString b) => (a, b)
310−eqInt = (C.dataEq, C.eqInt)
311−
312−eqString :: forall a b. (IsString a, IsString b) => (a, b)
313−eqString = (C.dataEq, C.eqString)
314−
315−eqChar :: forall a b. (IsString a, IsString b) => (a, b)
316−eqChar = (C.dataEq, C.eqChar)
317−
318−eqBoolean :: forall a b. (IsString a, IsString b) => (a, b)
319−eqBoolean = (C.dataEq, C.eqBoolean)
320−
321−ordBoolean :: forall a b. (IsString a, IsString b) => (a, b)
322−ordBoolean = (C.dataOrd, C.ordBoolean)
323−
324−ordNumber :: forall a b. (IsString a, IsString b) => (a, b)
325−ordNumber = (C.dataOrd, C.ordNumber)
326−
327−ordInt :: forall a b. (IsString a, IsString b) => (a, b)
328−ordInt = (C.dataOrd, C.ordInt)
329−
330−ordString :: forall a b. (IsString a, IsString b) => (a, b)
331−ordString = (C.dataOrd, C.ordString)
332−
333−ordChar :: forall a b. (IsString a, IsString b) => (a, b)
334−ordChar = (C.dataOrd, C.ordChar)
335−
336−semigroupString :: forall a b. (IsString a, IsString b) => (a, b)
337−semigroupString = (C.dataSemigroup, C.semigroupString)
338−
339−boundedBoolean :: forall a b. (IsString a, IsString b) => (a, b)
340−boundedBoolean = (C.dataBounded, C.boundedBoolean)
341−
342−heytingAlgebraBoolean :: forall a b. (IsString a, IsString b) => (a, b)
343−heytingAlgebraBoolean = (C.dataHeytingAlgebra, C.heytingAlgebraBoolean)
344−
345−semigroupoidFn :: forall a b. (IsString a, IsString b) => (a, b)
346−semigroupoidFn = (C.controlSemigroupoid, C.semigroupoidFn)
347−
348−opAdd :: forall a b. (IsString a, IsString b) => (a, b)
349−opAdd = (C.dataSemiring, C.add)
350−
351−opMul :: forall a b. (IsString a, IsString b) => (a, b)
352−opMul = (C.dataSemiring, C.mul)
353−
354−opEq :: forall a b. (IsString a, IsString b) => (a, b)
355−opEq = (C.dataEq, C.eq)
356−
357−opNotEq :: forall a b. (IsString a, IsString b) => (a, b)
358−opNotEq = (C.dataEq, C.notEq)
359−
360−opLessThan :: forall a b. (IsString a, IsString b) => (a, b)
361−opLessThan = (C.dataOrd, C.lessThan)
362−
363−opLessThanOrEq :: forall a b. (IsString a, IsString b) => (a, b)
364−opLessThanOrEq = (C.dataOrd, C.lessThanOrEq)
365−
366−opGreaterThan :: forall a b. (IsString a, IsString b) => (a, b)
367−opGreaterThan = (C.dataOrd, C.greaterThan)
368−
369−opGreaterThanOrEq :: forall a b. (IsString a, IsString b) => (a, b)
370−opGreaterThanOrEq = (C.dataOrd, C.greaterThanOrEq)
371−
372−opAppend :: forall a b. (IsString a, IsString b) => (a, b)
373−opAppend = (C.dataSemigroup, C.append)
374−
375−opSub :: forall a b. (IsString a, IsString b) => (a, b)
376−opSub = (C.dataRing, C.sub)
377−
378−opNegate :: forall a b. (IsString a, IsString b) => (a, b)
379−opNegate = (C.dataRing, C.negate)
380−
381−opDiv :: forall a b. (IsString a, IsString b) => (a, b)
382−opDiv = (C.dataEuclideanRing, C.div)
383−
384−opConj :: forall a b. (IsString a, IsString b) => (a, b)
385−opConj = (C.dataHeytingAlgebra, C.conj)
386−
387−opDisj :: forall a b. (IsString a, IsString b) => (a, b)
388−opDisj = (C.dataHeytingAlgebra, C.disj)
389−
390−opNot :: forall a b. (IsString a, IsString b) => (a, b)
391−opNot = (C.dataHeytingAlgebra, C.not)
392−
393−unbox :: AST -> PSString -> AST
394−unbox e d = select . inlineCommonValues $ inlineCommonOperators e
395− where
396− select :: AST -> AST
397− select e' =
398− case e' of
399− Var{} -> unbox' e'
400− App{} -> unbox' e'
401− Indexer{} -> unbox' e'
402− _ -> e'
403− unbox' :: AST -> AST
404− unbox' e' = maybe e' (\t -> App Nothing (StringLiteral Nothing t) [e']) $ unboxType d
405−
406−unboxType :: PSString -> Maybe PSString
407−unboxType s = do
408− t <- decodeString s
409− t' <- unboxType' t
410− return $ mkString t'
411− where
412− unboxType' :: Text -> Maybe Text
413− unboxType' t
414− | t == C.eqInt ||
415− t == C.semiringInt ||
416− t == C.ringInt ||
417− t == C.ordInt ||
418− t == C.dataIntBits
419− = Just int
420− | t == C.semiringNumber ||
421− t == C.ringNumber ||
422− t == C.ordNumber ||
423− t == C.euclideanRingNumber
424− = Just float
425− | t == C.eqBoolean ||
426− t == C.ordBoolean ||
427− t == C.heytingAlgebraBoolean
428− = Just bool
429− | t == C.eqChar ||
430− t == C.eqString ||
431− t == C.ordChar ||
432− t == C.ordString ||
433− t == C.semigroupString
434− = Just string
435− | otherwise = Nothing
src/CodeGen/IL/Optimizer/MagicDo.hsdeleted−146
@@ -1,146 +0,0 @@
1−-- | This module implements the "Magic Do" optimization, which inlines calls to return
2−-- and bind for the Eff monad, as well as some of its actions.
3−module CodeGen.IL.Optimizer.MagicDo (magicDoEffect, magicDoEff, magicDoST, inlineST) where
4−
5−import Prelude.Compat
6−import Protolude (ordNub)
7−
8−import Data.Maybe (fromJust, isJust)
9−import Data.Text (Text)
10−
11−import Language.PureScript.CoreImp.AST
12−import Language.PureScript.CoreImp.Optimizer.Common hiding (isDict)
13−import Language.PureScript.PSString (PSString, decodeString, mkString)
14−import qualified Language.PureScript.Constants as C
15−
16−import CodeGen.IL.Common (undefinedName, unusedName)
17−import CodeGen.IL.Optimizer.Common
18−
19−-- | Inline type class dictionaries for >>= and return for the Eff monad
20−--
21−-- E.g.
22−--
23−-- Prelude[">>="](dict)(m1)(function(x) {
24−-- return ...;
25−-- })
26−--
27−-- becomes
28−--
29−-- function __do {
30−-- var x = m1();
31−-- ...
32−-- }
33−magicDoEff :: AST -> AST
34−magicDoEff = magicDo C.eff C.effDictionaries
35−
36−magicDoEffect :: AST -> AST
37−magicDoEffect = magicDo C.effect C.effectDictionaries
38−
39−magicDoST :: AST -> AST
40−magicDoST = magicDo C.st C.stDictionaries
41−
42−magicDo :: Text -> C.EffectDictionaries -> AST -> AST
43−magicDo effectModule C.EffectDictionaries{..} = everywhereTopDown convert
44− where
45− -- Desugar monomorphic calls to >>= and return for the Eff monad
46− convert :: AST -> AST
47− -- Desugar pure
48− convert (App _ (App _ pure' [val]) []) | isPure pure' = val
49− -- Desugar discard
50− convert (App _ (App _ bind [m]) [Function s1 Nothing [unused] (Block s2 il)]) | isDiscard bind && unused == unusedName =
51− Function s1 Nothing [] $ Block s2 (App s2 m [] : map applyReturns il )
52− -- Desugar bind
53− convert (App _ (App _ bind [m]) [Function s1 Nothing [arg] (Block s2 il)]) | isBind bind =
54− Function s1 Nothing [] $ Block s2 (VariableIntroduction s2 arg (Just (App s2 m [])) : map applyReturns il)
55− -- Desugar untilE
56− convert (App s1 (App _ f [arg]) []) | isEffFunc edUntil f =
57− App s1 (Function s1 Nothing [] (Block s1 [ While s1 (Unary s1 Not (App s1 arg [])) (Block s1 []), Return s1 $ ObjectLiteral s1 []])) []
58− -- Desugar whileE
59− convert (App _ (App _ (App s1 f [arg1]) [arg2]) []) | isEffFunc edWhile f =
60− App s1 (Function s1 Nothing [] (Block s1 [ While s1 (App s1 arg1 []) (Block s1 [ App s1 arg2 [] ]), Return s1 $ ObjectLiteral s1 []])) []
61− -- -- Inline __do returns
62− -- convert (Return _ (App _ (Function _ (Just ident) [] body) [])) | ident == fnName = body
63− -- Inline double applications
64− convert (App _ (App s1 (Function s2 Nothing [] (Block ss body)) []) []) =
65− App s1 (Function s2 Nothing [] (Block ss (applyReturns `fmap` body))) []
66− convert other = other
67− -- Check if an expression represents a monomorphic call to >>= for the Eff monad
68− isBind (App _ fn [dict]) | isDict (effectModule, edBindDict) dict && isBindPoly fn = True
69− isBind _ = False
70− -- Check if an expression represents a call to @discard@
71− isDiscard (App _ (App _ fn [dict1]) [dict2])
72− | isDict (C.controlBind, C.discardUnitDictionary) dict1 &&
73− isDict (effectModule, edBindDict) dict2 &&
74− isDiscardPoly fn = True
75− isDiscard _ = False
76−
77− -- Check if an expression represents a monomorphic call to pure or return for the Eff applicative
78− isPure (App _ fn [dict]) | isDict (effectModule, edApplicativeDict) dict && isPurePoly fn = True
79− isPure _ = False
80− -- Check if an expression represents the polymorphic >>= function
81− isBindPoly = isDict (C.controlBind, C.bind)
82− -- Check if an expression represents the polymorphic pure function
83− isPurePoly = isDict (C.controlApplicative, C.pure')
84− -- Check if an expression represents the polymorphic discard function
85− isDiscardPoly = isDict (C.controlBind, C.discard)
86− -- Check if an expression represents a function in the Effect module
87− isEffFunc name (Indexer _ (StringLiteral _ name') (Var _ eff)) = eff == effectModule && name == name'
88− isEffFunc _ _ = False
89−
90− applyReturns :: AST -> AST
91− applyReturns (Return ss ret) = Return ss (App ss ret [])
92− applyReturns (Block ss ils) = Block ss (map applyReturns ils)
93− applyReturns (While ss cond il) = While ss cond (applyReturns il)
94− applyReturns (For ss v lo hi il) = For ss v lo hi (applyReturns il)
95− applyReturns (ForIn ss v xs il) = ForIn ss v xs (applyReturns il)
96− applyReturns (IfElse ss cond t f) = IfElse ss cond (applyReturns t) (applyReturns `fmap` f)
97− applyReturns other = other
98−
99−-- | Inline functions in the ST module
100−inlineST :: AST -> AST
101−inlineST = everywhere convertBlock
102− where
103− -- Look for runST blocks and inline the STRefs there.
104− -- If all STRefs are used in the scope of the same runST, only using { read, write, modify }STRef then
105− -- we can be more aggressive about inlining, and actually turn STRefs into local variables.
106− convertBlock (App s1 f [arg]) | isSTFunc C.runST f =
107− let refs = ordNub . findSTRefsIn $ arg
108− usages = findAllSTUsagesIn arg
109− allUsagesAreLocalVars = all (\u -> let v = toVar u in isJust v && fromJust v `elem` refs) usages
110− localVarsDoNotEscape = all (\r -> length (r `appearingIn` arg) == length (filter (\u -> let v = toVar u in v == Just r) usages)) refs
111− in App s1 (everywhere (convert (allUsagesAreLocalVars && localVarsDoNotEscape)) arg) []
112− convertBlock other = other
113− -- Convert a block in a safe way, preserving object wrappers of references,
114− -- or in a more aggressive way, turning wrappers into local variables depending on the
115− -- agg(ressive) parameter.
116− convert agg (App s1 f [arg]) | isSTFunc C.newSTRef f =
117− Function s1 Nothing [] (Block s1 [Return s1 $ if agg then arg else ObjectLiteral s1 [(mkString C.stRefValue, arg)]])
118− convert agg (App _ (App s1 f [ref]) []) | isSTFunc C.readSTRef f =
119− if agg then ref else Indexer s1 (StringLiteral s1 C.stRefValue) ref
120− convert agg (App _ (App _ (App s1 f [arg]) [ref]) []) | isSTFunc C.writeSTRef f =
121− if agg then Assignment s1 ref arg else Assignment s1 (Indexer s1 (StringLiteral s1 C.stRefValue) ref) arg
122− convert agg (App _ (App _ (App s1 f [func]) [ref]) []) | isSTFunc C.modifySTRef f =
123− if agg then Assignment s1 ref (App s1 func [ref]) else Assignment s1 (Indexer s1 (StringLiteral s1 C.stRefValue) ref) (App s1 func [Indexer s1 (StringLiteral s1 C.stRefValue) ref])
124− convert _ other = other
125− -- Check if an expression represents a function in the ST module
126− isSTFunc name (Indexer _ (StringLiteral _ name') (Var _ st)) = st == C.st && name == name'
127− isSTFunc _ _ = False
128− -- Find all ST Refs initialized in this block
129− findSTRefsIn = everything (++) isSTRef
130− where
131− isSTRef (VariableIntroduction _ ident (Just (App _ (App _ f [_]) []))) | isSTFunc C.newSTRef f = [ident]
132− isSTRef _ = []
133− -- Find all STRefs used as arguments to readSTRef, writeSTRef, modifySTRef
134− findAllSTUsagesIn = everything (++) isSTUsage
135− where
136− isSTUsage (App _ (App _ f [ref]) []) | isSTFunc C.readSTRef f = [ref]
137− isSTUsage (App _ (App _ (App _ f [_]) [ref]) []) | isSTFunc C.writeSTRef f || isSTFunc C.modifySTRef f = [ref]
138− isSTUsage _ = []
139− -- Find all uses of a variable
140− appearingIn ref = everything (++) isVar
141− where
142− isVar e@(Var _ v) | v == ref = [e]
143− isVar _ = []
144− -- Convert a AST value to a String if it is a Var
145− toVar (Var _ v) = Just v
146− toVar _ = Nothing
src/CodeGen/IL/Optimizer/TCO.hsdeleted−141
@@ -1,141 +0,0 @@
1−module CodeGen.IL.Optimizer.TCO (tco, tcoLoop) where
2−
3−import Prelude.Compat
4−
5−import Data.Text (Text)
6−import Data.Monoid ((<>))
7−import Language.PureScript.CoreImp.AST
8−import Language.PureScript.AST.SourcePos (SourceSpan)
9−import Safe (headDef, tailSafe)
10−import CodeGen.IL.Common
11−
12−import qualified Language.PureScript.Constants as C
13−
14−tcoLoop :: Text
15−tcoLoop = "ṩtco_loop"
16−
17−tco :: AST -> AST -> AST
18−tco mn = everywhere convert where
19− tcoVar :: Text -> Text
20− tcoVar arg = "ṩtco_var_" <> arg
21−
22− copyVar :: Text -> Text
23− copyVar arg = "ṩcopy_" <> arg
24−
25− tcoDone :: Text
26− tcoDone = "ṩtco_done"
27−
28− tcoResult :: Text
29− tcoResult = "ṩtco_result"
30−
31− convert :: AST -> AST
32− convert fn@(Function ss (Just name) args _)
33− | isTailRecursive name body'
34− = replace (toLoop name outerArgs innerArgs body')
35− where
36− innerArgs = headDef [] argss
37− outerArgs = concat . reverse $ tailSafe argss
38− (argss, body', replace) = collectAllFunctionArgs [] id fn
39− convert (Assignment ss (Var _ name) fn@(Function _ Nothing _ _))
40− | isTailRecursive name body'
41− = Assignment ss (Var ss name) (replace (toLoop name outerArgs innerArgs body'))
42− where
43− innerArgs = headDef [] argss
44− outerArgs = concat . reverse $ tailSafe argss
45− (argss, body', replace) = collectAllFunctionArgs [] id fn
46− convert js = js
47−
48− collectAllFunctionArgs :: [[Text]] -> (AST -> AST) -> AST -> ([[Text]], AST, AST -> AST)
49− collectAllFunctionArgs allArgs f (Function s1 ident args (Block s2 (body@(Return _ _):_))) =
50− collectAllFunctionArgs (args : allArgs) (\b -> f (Function s1 ident (map copyVar args) (Block s2 [b]))) body
51− collectAllFunctionArgs allArgs f (Function ss ident args body@(Block _ _)) =
52− (args : allArgs, body, f . Function ss ident (map copyVar args))
53− collectAllFunctionArgs allArgs f (Return s1 (Function s2 ident args (Block s3 [body]))) =
54− collectAllFunctionArgs (args : allArgs) (\b -> f (Return s1 (Function s2 ident (map copyVar args) (Block s3 [b])))) body
55− collectAllFunctionArgs allArgs f (Return s1 (Function s2 ident args body@(Block _ _))) =
56− (args : allArgs, body, f . Return s1 . Function s2 ident (map copyVar args))
57− collectAllFunctionArgs allArgs f body = (allArgs, body, f)
58−
59− isTailRecursive :: Text -> AST -> Bool
60− isTailRecursive ident js = countSelfReferences js > 0 && allInTailPosition js where
61− countSelfReferences = everything (+) match where
62− match :: AST -> Int
63− match (Var _ ident') | ident == ident' = 1
64− match _ = 0
65−
66− allInTailPosition (Return _ expr)
67− | isSelfCall ident expr = countSelfReferences expr == 1
68− | otherwise = countSelfReferences expr == 0
69− allInTailPosition (While _ js1 body)
70− = countSelfReferences js1 == 0 && allInTailPosition body
71− allInTailPosition (For _ _ js1 js2 body)
72− = countSelfReferences js1 == 0 && countSelfReferences js2 == 0 && allInTailPosition body
73− allInTailPosition (ForIn _ _ js1 body)
74− = countSelfReferences js1 == 0 && allInTailPosition body
75− allInTailPosition (IfElse _ js1 body el)
76− = countSelfReferences js1 == 0 && allInTailPosition body && all allInTailPosition el
77− allInTailPosition (Block _ body)
78− = all allInTailPosition body
79− allInTailPosition (Throw _ js1)
80− = countSelfReferences js1 == 0
81− allInTailPosition (ReturnNoResult _)
82− = True
83− allInTailPosition (VariableIntroduction _ _ js1)
84− = all ((== 0) . countSelfReferences) js1
85− allInTailPosition (Assignment _ _ js1)
86− = countSelfReferences js1 == 0
87− allInTailPosition (Comment _ _ js1)
88− = allInTailPosition js1
89− allInTailPosition _
90− = False
91−
92− toLoop :: Text -> [Text] -> [Text] -> AST -> AST
93− toLoop ident outerArgs innerArgs js =
94− Block rootSS $
95− concatMap (\arg -> [ VariableIntroduction rootSS (tcoVar arg) . Just $
96− Var rootSS (copyVar arg) ]) (outerArgs ++ innerArgs) ++
97− [ Assignment rootSS (Var rootSS $ "var " <> tcoDone) $ BooleanLiteral Nothing False
98− , VariableIntroduction rootSS tcoResult Nothing
99− , Assignment rootSS (Var rootSS $ "var " <> tcoLoop) (Function rootSS (Just tcoLoop) (outerArgs ++ innerArgs) (Block rootSS [loopify js]))
100− , While rootSS (Unary Nothing Not (Var rootSS tcoDone))
101− (Block rootSS
102− [(Assignment rootSS (Var rootSS tcoResult) (App rootSS (Var rootSS tcoLoop) ((map (Var rootSS . tcoVar) outerArgs) ++ (map (Var rootSS . copyVar) innerArgs))))])
103− , Return rootSS (Var rootSS tcoResult)
104− ]
105− where
106− rootSS = Nothing
107−
108− loopify :: AST -> AST
109− loopify (Return ss ret)
110− | isSelfCall ident ret =
111− let
112− allArgumentValues = concat $ collectArgs [] ret
113− in
114− Block ss $
115− zipWith (\val arg ->
116− Assignment ss (Var ss (tcoVar arg)) val) allArgumentValues outerArgs
117− ++ zipWith (\val arg ->
118− Assignment ss (Var ss (copyVar arg)) val) (drop (length outerArgs) allArgumentValues) innerArgs
119− ++ [ ReturnNoResult ss ]
120− | otherwise = Block ss [ markDone ss, Return ss ret ]
121− loopify (ReturnNoResult ss) = Block ss [ markDone ss, ReturnNoResult ss ]
122− loopify (While ss cond body) = While ss cond (loopify body)
123− loopify (For ss i js1 js2 body) = For ss i js1 js2 (loopify body)
124− loopify (ForIn ss i js1 body) = ForIn ss i js1 (loopify body)
125− loopify (IfElse ss cond body el) = IfElse ss cond (loopify body) (fmap loopify el)
126− loopify (Block ss body) = Block ss (map loopify body)
127− loopify other = other
128−
129− markDone :: Maybe SourceSpan -> AST
130− markDone ss = Assignment ss (Var ss tcoDone) (BooleanLiteral ss True)
131−
132− collectArgs :: [[AST]] -> AST -> [[AST]]
133− collectArgs acc (App _ fn args') = collectArgs (args' : acc) fn
134− collectArgs acc _ = acc
135−
136− isSelfCall :: Text -> AST -> Bool
137− isSelfCall ident (App _ (Var _ ident') _) = ident == ident'
138− isSelfCall ident (App _ (Indexer _ (Var _ ident') (Var _ mn')) _) = mn' == "" && ident == ident'
139− isSelfCall ident (App _ (Indexer _ (Var _ ident') mn') _) = mn' == mn && ident == ident'
140− isSelfCall ident (App _ fn _) = isSelfCall ident fn
141− isSelfCall _ _ = False
src/CodeGen/IL/Printer.hsdeleted−527
@@ -1,527 +0,0 @@
1−-- | Pretty printer for the AST
2−module CodeGen.IL.Printer
3− ( prettyPrintIL
4− , prettyPrintIL1
5− , prettyPrintILWithSourceMaps
6− , interfaceSource
7− , implHeaderSource
8− , implFooterSource
9− , isLiteral
10− , modLabel
11− , modPrefix
12− , ffiLoader
13− ) where
14−
15−import Prelude.Compat
16−
17−import Control.Arrow ((<+>))
18−import Control.Monad (forM, mzero)
19−import Control.Monad.State (StateT, evalStateT)
20−import Control.PatternArrows
21−import Data.List (filter, (\\))
22−import qualified Control.Arrow as A
23−
24−import Data.Maybe (fromMaybe)
25−import Data.Monoid ((<>))
26−import Data.Text (Text)
27−import qualified Data.Text as T
28−
29−import Language.PureScript.AST (SourceSpan(..))
30−import Language.PureScript.CoreImp.AST
31−import Language.PureScript.Comments
32−import Language.PureScript.Crash
33−import Language.PureScript.Names (Ident, runIdent)
34−import Language.PureScript.Pretty.Common
35−import Language.PureScript.PSString (PSString, decodeString, mkString)
36−
37−import CodeGen.IL.Common
38−import CodeGen.IL.Optimizer.TCO (tcoLoop)
39−
40−import qualified Language.PureScript.Constants as C
41−
42−-- TODO (Christoph): Get rid of T.unpack / pack
43−
44−literals :: (Emit gen) => Pattern PrinterState AST gen
45−literals = mkPattern' match'
46− where
47− match' :: (Emit gen) => AST -> StateT PrinterState Maybe gen
48− match' il = (addMapping' (getSourceSpan il) <>) <$> match il
49−
50− match :: (Emit gen) => AST -> StateT PrinterState Maybe gen
51− match (NumericLiteral _ n) = return $ emit $ T.pack $ either show show n
52− match (StringLiteral _ s) = return $ emit $ stringLiteral s
53− match (BooleanLiteral _ True) = return $ emit "true"
54− match (BooleanLiteral _ False) = return $ emit "false"
55− match (ArrayLiteral _ xs) = mconcat <$> sequence
56− [ return . emit $ arrayType <> "{"
57− , intercalate (emit ", ") <$> forM xs prettyPrintIL'
58− , return $ emit "}"
59− ]
60− -- match (ObjectLiteral _ []) = return $ emit "std::initializer_list<std::pair<const string, boxed>>{}"
61− match (ObjectLiteral _ ps) = mconcat <$> sequence
62− [ return . emit $ dictType <> "{"
63− , withIndent $ do
64− ils <- forM ps $ \(key, value) -> do
65− value' <- prettyPrintIL' value
66− return $ objectPropertyToString key <> value'
67− return $ intercalate (emit " ") $ map (<> emit ",") ils
68− , return $ emit "}"
69− ]
70− where
71− objectPropertyToString :: (Emit gen) => PSString -> gen
72− objectPropertyToString s = emit $ stringLiteral s <> ": "
73− match (Block _ sts) = mconcat <$> sequence
74− [ return $ emit "{\n"
75− , withIndent $ prettyStatements sts
76− , return $ emit "\n"
77− , currentIndent
78− , return $ emit "}"
79− ]
80− match (Var _ ident) | ident == C.undefined = return $ emit undefinedName
81− match (Var _ ident) = return $ emit ident
82− match (VariableIntroduction _ ident value) = mconcat <$> sequence
83− [ return . emit $ varDecl <> " " <> ident <> " " <> anyType
84− , maybe (return mempty) (fmap (emit " = " <>) . prettyPrintIL') value
85− ]
86− match (Assignment _ target value) = mconcat <$> sequence
87− [ prettyPrintIL' target
88− , return $ emit " = "
89− , prettyPrintIL' value
90− ]
91− match (App _ val []) = mconcat <$> sequence
92− [ return $ emit "Run("
93− , prettyPrintIL' val
94− , return $ emit ")"
95− ]
96− match (App _ (StringLiteral _ u) [arg])
97− | Just ty <- decodeString u = mconcat <$> sequence
98− [ prettyPrintIL' arg
99− , return $ emit ".("
100− , return $ emit ty
101− , return $ emit ")"
102− ]
103− match (App _ (Var _ fn) [arg]) | fn == arrayLengthFn = mconcat <$> sequence
104− [ return $ emit fn
105− , return $ emit "("
106− , prettyPrintIL' arg
107− , return $ emit ")"
108− ]
109− match (App _ (Var _ fn) args) | fn == indexFn = mconcat <$> sequence
110− [ return $ emit fn
111− , return $ emit "("
112− , intercalate (emit ", ") <$> forM args prettyPrintIL'
113− , return $ emit ")"
114− ]
115− match (App _ (Var _ fn) args) | fn == tcoLoop = mconcat <$> sequence
116− [ return $ emit fn
117− , return $ emit "("
118− , intercalate (emit ", ") <$> forM args prettyPrintIL'
119− , return $ emit ")"
120− ]
121− match (App _ (App Nothing (StringLiteral Nothing fnx) [fn@Function{}]) args)
122− | Just ftype <- decodeString fnx
123− , "Fn" `T.isPrefixOf` ftype = mconcat <$> sequence
124− [ prettyPrintIL' fn
125− , return $ emit "("
126− , intercalate (emit ", ") <$> forM args prettyPrintIL'
127− , return $ emit ")"
128− ]
129− match (App _ (App Nothing (StringLiteral Nothing fnx) [fn]) args)
130− | Just ftype <- decodeString fnx
131− , "Fn" `T.isPrefixOf` ftype = mconcat <$> sequence
132− [ prettyPrintIL' fn
133− , return $ emit ".("
134− , return $ emit ftype
135− , return $ emit ")("
136− , intercalate (emit ", ") <$> forM args prettyPrintIL'
137− , return $ emit ")"
138− ]
139− match app@(App{})
140− | (val, args) <- unApp app []
141− , length args > 1
142− = mconcat <$> sequence
143− [ return $ emit "Apply("
144− , prettyPrintIL' val
145− , return $ emit ", "
146− , intercalate (emit ", ") <$> forM args prettyPrintIL'
147− , return $ emit ")"
148− ]
149− match (App _ val args) = mconcat <$> sequence
150− [ return $ emit "Apply("
151− , prettyPrintIL' val
152− , return $ emit ", "
153− , intercalate (emit ", ") <$> forM args prettyPrintIL'
154− , return $ emit ")"
155− ]
156− match (Function _ (Just name) [] (Block _ [Return _ ret]))
157− | isComplexLiteral ret = mconcat <$> sequence
158− [ return $ emit "\n"
159− , return . emit $ varDecl <> " " <> initName name <> " Once\n"
160− , prettyPrintIL' $ VariableIntroduction Nothing (valueName name) Nothing
161− , return $ emit "\n\n"
162− , return $ emit "func "
163− , return . emit $ withPrefix name
164− , return . emit $ "() " <> anyType <> " "
165− , return $ emit "{\n"
166− , withIndent $ do
167− indentString <- currentIndent
168− return $ indentString <> (emit $ initName name <> ".Do(func() {\n") <>
169− indentString <> indentString <> (emit $ valueName name <> " = ")
170− , withIndent $ do
171− case ret of
172− Function _ Nothing args body -> mconcat <$> sequence
173− [ return $ emit "func("
174− , return . emit $ intercalate ", " (renderArg anyType <$> args)
175− , return . emit $ ") " <> anyType <> " "
176− , prettyPrintIL' body
177− ]
178− _ -> do
179− prettyPrintIL' ret
180− , return $ emit "\n"
181− , withIndent $ do
182− indentString <- currentIndent
183− return $ indentString <> (emit $ "})\n" <> "return " <> valueName name <>"\n")
184− , return $ emit "}\n\n"
185− ]
186− match (Function _ (Just name) [] ret) = mconcat <$> sequence
187− [ return $ emit "func "
188− , return . emit $ withPrefix name
189− , return . emit $ "() " <> anyType <> " "
190− , prettyPrintIL' ret
191− ]
192− match (Function _ _ args ret) = mconcat <$> sequence
193− [ return $ emit "func("
194− , return . emit $ intercalate ", " (renderArg anyType <$> args)
195− , return . emit $ ") " <> anyType <> " "
196− , prettyPrintIL' ret
197− ]
198− match (Indexer _ (Var _ name) (Var _ "")) = mconcat <$> sequence
199− [ prettyPrintIL' (Var Nothing $ withPrefix name)
200− , return $ emit "()"
201− ]
202− match (Indexer _ (Var _ name) val) = mconcat <$> sequence
203− [ prettyPrintIL' val
204− , return $ emit "."
205− , prettyPrintIL' (Var Nothing $ withPrefix name)
206− , return $ emit "()"
207− ]
208− match (Indexer _ prop@StringLiteral{} val@ObjectLiteral{}) = mconcat <$> sequence
209− [ prettyPrintIL' val
210− , return $ emit "["
211− , prettyPrintIL' prop
212− , return $ emit "]"
213− ]
214− match (Indexer _ prop@StringLiteral{} val) = mconcat <$> sequence
215− [ prettyPrintIL' val
216− , return $ emit ".("
217− , return $ emit dictType
218− , return $ emit ")["
219− , prettyPrintIL' prop
220− , return $ emit "]"
221− ]
222− match (Indexer _ index val@ArrayLiteral{}) = mconcat <$> sequence
223− [ prettyPrintIL' val
224− , return $ emit "["
225− , prettyPrintIL' index
226− , return $ emit "]"
227− ]
228− match (Indexer _ index val) = mconcat <$> sequence
229− [ prettyPrintIL' val
230− , return $ emit ".("
231− , return $ emit arrayType
232− , return $ emit ")["
233− , prettyPrintIL' index
234− , return $ emit "]"
235− ]
236− match (InstanceOf _ val ty) = mconcat <$> sequence
237− [ return $ emit "Is("
238− , prettyPrintIL' val
239− , return $ emit ", "
240− , prettyPrintIL' ty
241− , return $ emit ")"
242− ]
243− match (While _ cond sts) = mconcat <$> sequence
244− [ return $ emit "for "
245− , prettyPrintIL' cond
246− , return $ emit " "
247− , prettyPrintIL' sts
248− ]
249− match (For _ ident start end sts) = mconcat <$> sequence
250− [ return $ emit $ "for var " <> ident <> " = "
251− , prettyPrintIL' start
252− , return $ emit $ "; " <> ident <> " < "
253− , prettyPrintIL' end
254− , return $ emit $ "; " <> ident <> "++ "
255− , prettyPrintIL' sts
256− ]
257− match (ForIn _ ident obj sts) = mconcat <$> sequence
258− [ return $ emit $ "for var " <> ident <> " in "
259− , prettyPrintIL' obj
260− , return $ emit " "
261− , prettyPrintIL' sts
262− ]
263− match (IfElse _ (Binary _ EqualTo cond@Binary{} (BooleanLiteral Nothing True)) thens elses) = mconcat <$> sequence
264− [ return $ emit "if "
265− , prettyPrintIL' cond
266− , return $ emit " "
267− , prettyPrintIL' thens
268− , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintIL') elses
269− ]
270− match (IfElse _ (Binary _ EqualTo cond@Binary{} (BooleanLiteral Nothing False)) thens elses) = mconcat <$> sequence
271− [ return $ emit "if !("
272− , prettyPrintIL' cond
273− , return $ emit ") "
274− , prettyPrintIL' thens
275− , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintIL') elses
276− ]
277− match (IfElse _ cond thens elses) = mconcat <$> sequence
278− [ return $ emit "if "
279− , prettyPrintIL' cond
280− , return $ emit " "
281− , prettyPrintIL' thens
282− , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintIL') elses
283− ]
284− match (Return _ value) = mconcat <$> sequence
285− [ return $ emit "return "
286− , prettyPrintIL' value
287− ]
288− match (ReturnNoResult _) = return . emit $ "return " <> undefinedName
289− -- match (Throw _ _) = return mempty
290− match (Throw _ value) = mconcat <$> sequence
291− [ return $ emit "panic("
292− , prettyPrintIL' value
293− , return $ emit ")"
294− ]
295− match (Comment _ com il) = mconcat <$> sequence
296− [ return $ emit "\n"
297− , mconcat <$> forM com comment
298− , prettyPrintIL' il
299− ]
300− match _ = mzero
301−
302− comment :: (Emit gen) => Comment -> StateT PrinterState Maybe gen
303− comment (LineComment com) = fmap mconcat $ sequence $
304− [ currentIndent
305− , return $ emit "//" <> emit com <> emit "\n"
306− ]
307− comment (BlockComment com) = fmap mconcat $ sequence $
308− [ currentIndent
309− , return $ emit "/**\n"
310− ] ++
311− map asLine (T.lines com) ++
312− [ currentIndent
313− , return $ emit " */\n"
314− , currentIndent
315− ]
316− where
317− asLine :: (Emit gen) => Text -> StateT PrinterState Maybe gen
318− asLine s = do
319− i <- currentIndent
320− return $ i <> emit " * " <> (emit . removeComments) s <> emit "\n"
321−
322− removeComments :: Text -> Text
323− removeComments t =
324− case T.stripPrefix "*/" t of
325− Just rest -> removeComments rest
326− Nothing -> case T.uncons t of
327− Just (x, xs) -> x `T.cons` removeComments xs
328− Nothing -> ""
329−
330−unary' :: (Emit gen) => UnaryOperator -> (AST -> Text) -> Operator PrinterState AST gen
331−unary' op mkStr = Wrap match (<>)
332− where
333− match :: (Emit gen) => Pattern PrinterState AST (gen, AST)
334− match = mkPattern match'
335− where
336− match' (Unary _ op' val) | op' == op = Just (emit $ mkStr val, val)
337− match' _ = Nothing
338−
339−unary :: (Emit gen) => UnaryOperator -> Text -> Operator PrinterState AST gen
340−unary op str = unary' op (const str)
341−
342−negateOperator :: (Emit gen) => Operator PrinterState AST gen
343−negateOperator = unary' Negate (\v -> if isNegate v then "- " else "-")
344− where
345− isNegate (Unary _ Negate _) = True
346− isNegate _ = False
347−
348−binary :: (Emit gen) => BinaryOperator -> Text -> Operator PrinterState AST gen
349−binary op str = AssocL match (\v1 v2 -> v1 <> emit (" " <> str <> " ") <> v2)
350− where
351− match :: Pattern PrinterState AST (AST, AST)
352− match = mkPattern match'
353− where
354− match' (Binary _ op' v1 v2) | op' == op = Just (v1, v2)
355− match' _ = Nothing
356−
357−isLiteral :: AST -> Bool
358−isLiteral Function{} = True
359−isLiteral NumericLiteral{} = True
360−isLiteral StringLiteral{} = True
361−isLiteral BooleanLiteral{} = True
362−isLiteral ObjectLiteral{} = True
363−isLiteral ArrayLiteral{} = True
364−isLiteral _ = False
365−
366−isComplexLiteral :: AST -> Bool
367−-- isComplexLiteral Function{} = True
368−isComplexLiteral ObjectLiteral{} = True
369−isComplexLiteral ArrayLiteral{} = True
370−isComplexLiteral _ = False
371−
372−unApp :: AST -> [AST] -> (AST, [AST])
373−unApp (App _ val [arg]) args = unApp val (arg : args)
374−unApp other args = (other, args)
375−
376−prettyStatements :: (Emit gen) => [AST] -> StateT PrinterState Maybe gen
377−prettyStatements sts = do
378− ils <- forM sts prettyPrintIL'
379− indentString <- currentIndent
380− return $ intercalate (emit "\n") $ map (indentString <>) ils
381−
382−-- | Generate a pretty-printed string representing a collection of C++ expressions at the same indentation level
383−prettyPrintILWithSourceMaps :: [AST] -> (Text, [SMap])
384−prettyPrintILWithSourceMaps il =
385− let StrPos (_, s, mp) = (fromMaybe (internalError "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyStatements) il
386− in (s, mp)
387−
388−prettyPrintIL :: [AST] -> Text
389−prettyPrintIL = maybe (internalError "Incomplete pattern") runPlainString . flip evalStateT (PrinterState 0) . prettyStatements
390−
391−-- | Generate an indented, pretty-printed string representing a C++ expression
392−prettyPrintIL' :: (Emit gen) => AST -> StateT PrinterState Maybe gen
393−prettyPrintIL' = A.runKleisli $ runPattern matchValue
394− where
395− matchValue :: (Emit gen) => Pattern PrinterState AST gen
396− matchValue = buildPrettyPrinter operators (literals <+> fmap parensPos matchValue)
397− operators :: (Emit gen) => OperatorTable PrinterState AST gen
398− operators =
399− OperatorTable [ [ unary New "?" ]
400− , [ unary Not "!"
401− , unary BitwiseNot "~"
402− , unary Positive "+"
403− , negateOperator ]
404− , [ binary Multiply "*"
405− , binary Divide "/"
406− , binary Modulus "%" ]
407− , [ binary Add "+"
408− , binary Subtract "-" ]
409− , [ binary ShiftLeft "<<"
410− , binary ShiftRight ">>" ]
411− , [ binary LessThan "<"
412− , binary LessThanOrEqualTo "<="
413− , binary GreaterThan ">"
414− , binary GreaterThanOrEqualTo ">=" ]
415− , [ binary EqualTo "=="
416− , binary NotEqualTo "!=" ]
417− , [ binary BitwiseAnd "&" ]
418− , [ binary BitwiseXor "^" ]
419− , [ binary BitwiseOr "|" ]
420− , [ binary And "&&" ]
421− , [ binary Or "||" ]
422− ]
423−
424−prettyPrintIL1 :: AST -> Text
425−prettyPrintIL1 = maybe (internalError "Incomplete pattern") runPlainString . flip evalStateT (PrinterState 0) . prettyPrintIL'
426−
427−stringLiteral :: PSString -> Text
428−stringLiteral pss | Just s <- decodeString pss = stringLiteral' s
429− where
430− stringLiteral' :: Text -> Text
431− stringLiteral' s = "\"" <> T.concatMap encodeChar s <> "\""
432− encodeChar :: Char -> Text
433− encodeChar '\0' = "\\x00"
434− encodeChar '\b' = "\\b"
435− encodeChar '\t' = "\\t"
436− encodeChar '\n' = "\\n"
437− encodeChar '\v' = "\\v"
438− encodeChar '\f' = "\\f"
439− encodeChar '\r' = "\\r"
440− encodeChar '"' = "\\\""
441− encodeChar '\\' = "\\\\"
442− encodeChar c = T.singleton $ c
443−stringLiteral _ = "\"\\uFFFD\""
444−
445−interfaceSource :: Text -> [(Text,Bool)] -> [Ident] -> Text
446−interfaceSource _ _ _ = ""
447−
448−implHeaderSource :: Text -> [Text] -> Text -> Text
449−implHeaderSource mn imports otherPrefix =
450− "// Code generated by psgo. DO NOT EDIT.\n\n" <>
451− "package " <> (if mn == "Main" || mn == "Test_Main" then "main" else mn) <> "\n\n" <>
452− "import . \"" <> runtime <> "\"\n" <>
453− (if mn == "Main" || mn == "Test_Main"
454− then "import _ \"" <> otherPrefix <> "/" <> ffiLoader <> "\"\n"
455− else "\n") <>
456− "import (\n" <>
457− (T.concat $ formatImport <$> imports) <> ")\n\n" <>
458− "type _ = Any\n\n"
459− where
460− formatImport :: Text -> Text
461− formatImport s =
462− "\t\"" <> otherPrefix <> "/" <> modPrefix <> "/" <> moduleRenamer s <> "\"\n"
463− moduleRenamer :: Text -> Text
464− moduleRenamer s
465− | (s', sfx) <- T.breakOn moduleRenamerMarker s,
466− not $ T.null sfx = s'
467− moduleRenamer s = s
468−
469−implFooterSource :: Text -> [Ident] -> Text
470−implFooterSource mn foreigns =
471− "\n\n\n" <>
472− (if null foreigns
473− then ""
474− else ("// Foreign values\n\n" <>
475− "var " <> foreignDict <> " = "<> foreignMod <> "(\"" <> mn <> "\")\n\n" <>
476− (T.concat $ (\foreign' ->
477− let name = moduleIdentToIL foreign' in
478− varDecl <> " " <> initName name <> " Once\n" <>
479− varDecl <> " " <> valueName name <> " " <> anyType <> "\n\n" <>
480− "func " <>
481− withPrefix name <>
482− "() Any { \n" <>
483− " " <> initName name <> ".Do(func() {\n" <>
484− " " <> valueName name <> " = " <>
485− "Get(" <> foreignDict <> ", " <>
486− (stringLiteral . mkString $ runIdent foreign') <> ")\n" <>
487− " })\n" <>
488− " return " <> valueName name <> "\n" <>
489− "}\n\n") <$> foreigns))) <>
490− if mn == "Main" || mn == "Test.Main" then mainSource else "\n"
491− where
492− mainSource :: Text
493− mainSource = "\
494− \func main() {\n\
495− \ Run(Ꞌmain())\n\
496− \}\n\n\
497− \"
498−
499−varDecl :: Text
500−varDecl = "var"
501−
502−renderArg :: Text -> Text -> Text
503−renderArg decl arg = arg <> " " <> decl
504−
505−foreignMod :: Text
506−foreignMod = "Foreign"
507−
508−foreignDict :: Text
509−foreignDict = "foreign"
510−
511−modLabel :: Text
512−modLabel = "purescript-native"
513−
514−modPrefix :: Text
515−modPrefix = modLabel <> "/output"
516−
517−runtime :: Text
518−runtime = "github.com/" <> modLabel <> "/go-runtime"
519−
520−ffiLoader :: Text
521−ffiLoader = modLabel <> "/ffi-loader"
522−
523−initName :: Text -> Text
524−initName s = "ᛌ" <> s <> "_once"
525−
526−valueName :: Text -> Text
527−valueName s = "ᛧ" <> s
src/Control/Monad/Supply.hsnew file+43
@@ -0,0 +1,43 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Control.Monad.Supply
4+-- Copyright : (c) Phil Freeman 2014
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- Fresh variable supply
13+--
14+-----------------------------------------------------------------------------
15+
16+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
17+
18+module Control.Monad.Supply where
19+
20+import Data.Functor.Identity
21+
22+import Control.Applicative
23+import Control.Monad.State
24+import Control.Monad.Error.Class (MonadError(..))
25+import Control.Monad.Reader
26+import Control.Monad.Writer
27+
28+newtype SupplyT m a = SupplyT { unSupplyT :: StateT Integer m a }
29+ deriving (Functor, Applicative, Monad, MonadTrans, MonadError e, MonadWriter w, MonadReader r)
30+
31+runSupplyT :: Integer -> SupplyT m a -> m (a, Integer)
32+runSupplyT n = flip runStateT n . unSupplyT
33+
34+evalSupplyT :: (Functor m) => Integer -> SupplyT m a -> m a
35+evalSupplyT n = fmap fst . runSupplyT n
36+
37+type Supply = SupplyT Identity
38+
39+runSupply :: Integer -> Supply a -> (a, Integer)
40+runSupply n = runIdentity . runSupplyT n
41+
42+evalSupply :: Integer -> Supply a -> a
43+evalSupply n = runIdentity . evalSupplyT n
src/Control/Monad/Supply/Class.hsnew file+36
@@ -0,0 +1,36 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Control.Monad.Supply.Class
4+-- Copyright : (c) PureScript 2015
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- A class for monads supporting a supply of fresh names
13+--
14+-----------------------------------------------------------------------------
15+
16+{-# LANGUAGE MultiParamTypeClasses #-}
17+
18+module Control.Monad.Supply.Class where
19+
20+import Control.Monad.Supply
21+import Control.Monad.State
22+
23+class (Monad m) => MonadSupply m where
24+ fresh :: m Integer
25+
26+instance (Monad m) => MonadSupply (SupplyT m) where
27+ fresh = SupplyT $ do
28+ n <- get
29+ put (n + 1)
30+ return n
31+
32+instance (MonadSupply m) => MonadSupply (StateT s m) where
33+ fresh = lift fresh
34+
35+freshName :: (MonadSupply m) => m String
36+freshName = liftM (('_' :) . show) fresh
src/Control/Monad/Unify.hsnew file+159
@@ -0,0 +1,159 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Control.Monad.Unify
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+--
13+--
14+-----------------------------------------------------------------------------
15+
16+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
17+{-# LANGUAGE FlexibleInstances #-}
18+{-# LANGUAGE FlexibleContexts #-}
19+{-# LANGUAGE DeriveDataTypeable #-}
20+{-# LANGUAGE MultiParamTypeClasses #-}
21+{-# LANGUAGE FunctionalDependencies #-}
22+{-# LANGUAGE UndecidableInstances #-}
23+
24+module Control.Monad.Unify where
25+
26+import Data.Monoid
27+
28+import Control.Applicative
29+import Control.Monad.State
30+import Control.Monad.Error.Class (MonadError(..))
31+
32+import Data.HashMap.Strict as M
33+
34+-- |
35+-- Untyped unification variables
36+--
37+type Unknown = Int
38+
39+-- |
40+-- A type which can contain unification variables
41+--
42+class Partial t where
43+ unknown :: Unknown -> t
44+ isUnknown :: t -> Maybe Unknown
45+ unknowns :: t -> [Unknown]
46+ ($?) :: Substitution t -> t -> t
47+
48+-- |
49+-- Identifies types which support unification
50+--
51+class (Partial t) => Unifiable m t | t -> m where
52+ (=?=) :: t -> t -> UnifyT t m ()
53+
54+-- |
55+-- A substitution maintains a mapping from unification variables to their values
56+--
57+data Substitution t = Substitution { runSubstitution :: M.HashMap Int t }
58+
59+instance (Partial t) => Monoid (Substitution t) where
60+ mempty = Substitution M.empty
61+ s1 `mappend` s2 = Substitution $
62+ M.map (s2 $?) (runSubstitution s1) `M.union`
63+ M.map (s1 $?) (runSubstitution s2)
64+
65+-- |
66+-- State required for type checking
67+--
68+data UnifyState t = UnifyState {
69+ -- |
70+ -- The next fresh unification variable
71+ --
72+ unifyNextVar :: Int
73+ -- |
74+ -- The current substitution
75+ --
76+ , unifyCurrentSubstitution :: Substitution t
77+ }
78+
79+-- |
80+-- An empty @UnifyState@
81+--
82+defaultUnifyState :: (Partial t) => UnifyState t
83+defaultUnifyState = UnifyState 0 mempty
84+
85+-- |
86+-- A class for errors which support unification errors
87+--
88+class UnificationError t e where
89+ occursCheckFailed :: t -> e
90+
91+-- |
92+-- The type checking monad, which provides the state of the type checker, and error reporting capabilities
93+--
94+newtype UnifyT t m a = UnifyT { unUnify :: StateT (UnifyState t) m a }
95+ deriving (Functor, Monad, Applicative, Alternative, MonadPlus)
96+
97+instance (MonadState s m) => MonadState s (UnifyT t m) where
98+ get = UnifyT . lift $ get
99+ put = UnifyT . lift . put
100+
101+instance (MonadError e m) => MonadError e (UnifyT t m) where
102+ throwError = UnifyT . throwError
103+ catchError e f = UnifyT $ catchError (unUnify e) (unUnify . f)
104+
105+-- |
106+-- Run a computation in the Unify monad, failing with an error, or succeeding with a return value and the new next unification variable
107+--
108+runUnify :: UnifyState t -> UnifyT t m a -> m (a, UnifyState t)
109+runUnify s = flip runStateT s . unUnify
110+
111+-- |
112+-- Substitute a single unification variable
113+--
114+substituteOne :: (Partial t) => Unknown -> t -> Substitution t
115+substituteOne u t = Substitution $ M.singleton u t
116+
117+-- |
118+-- Replace a unification variable with the specified value in the current substitution
119+--
120+(=:=) :: (UnificationError t e, Monad m, MonadError e m, Unifiable m t) => Unknown -> t -> UnifyT t m ()
121+(=:=) u t' = do
122+ st <- UnifyT get
123+ let sub = unifyCurrentSubstitution st
124+ let t = sub $? t'
125+ occursCheck u t
126+ let current = sub $? unknown u
127+ case isUnknown current of
128+ Just u1 | u1 == u -> return ()
129+ _ -> current =?= t
130+ UnifyT $ modify $ \s -> s { unifyCurrentSubstitution = substituteOne u t <> unifyCurrentSubstitution s }
131+
132+-- |
133+-- Perform the occurs check, to make sure a unification variable does not occur inside a value
134+--
135+occursCheck :: (UnificationError t e, Monad m, MonadError e m, Partial t) => Unknown -> t -> UnifyT t m ()
136+occursCheck u t =
137+ case isUnknown t of
138+ Nothing -> when (u `elem` unknowns t) $ UnifyT . lift . throwError $ occursCheckFailed t
139+ _ -> return ()
140+
141+-- |
142+-- Generate a fresh untyped unification variable
143+--
144+fresh' :: (Monad m) => UnifyT t m Unknown
145+fresh' = do
146+ st <- UnifyT get
147+ UnifyT $ modify $ \s -> s { unifyNextVar = succ (unifyNextVar s) }
148+ return $ unifyNextVar st
149+
150+-- |
151+-- Generate a fresh unification variable at a specific type
152+--
153+fresh :: (Monad m, Partial t) => UnifyT t m t
154+fresh = do
155+ u <- fresh'
156+ return $ unknown u
157+
158+
159+
src/Language/PureScript.hsnew file+292
@@ -0,0 +1,292 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript
4+-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- The main compiler module
13+--
14+-----------------------------------------------------------------------------
15+
16+{-# LANGUAGE DataKinds #-}
17+{-# LANGUAGE FlexibleContexts #-}
18+{-# LANGUAGE RecordWildCards #-}
19+{-# LANGUAGE ScopedTypeVariables #-}
20+
21+module Language.PureScript
22+ ( module P
23+ , compile
24+ , compile'
25+ , compileJS
26+ , RebuildPolicy(..)
27+ , MakeActions(..)
28+ , SupplyVar()
29+ , Externs()
30+ , make
31+ , version
32+ ) where
33+
34+import Data.Function (on)
35+import Data.List (sortBy, groupBy, intercalate)
36+import Data.Maybe (fromMaybe)
37+import Data.Time.Clock
38+import Data.Version (Version)
39+import qualified Data.Map as M
40+import qualified Data.Set as S
41+
42+import Control.Applicative
43+import Control.Arrow ((&&&))
44+import Control.Monad
45+import Control.Monad.Error.Class (MonadError(..))
46+import Control.Monad.Reader
47+import Control.Monad.Writer
48+import Control.Monad.Supply.Class (MonadSupply, fresh)
49+
50+import Language.PureScript.AST as P
51+import Language.PureScript.Comments as P
52+import Language.PureScript.CodeGen.Externs (moduleToPs)
53+import Language.PureScript.DeadCodeElimination as P
54+import Language.PureScript.Environment as P
55+import Language.PureScript.Errors as P
56+import Language.PureScript.Kinds as P
57+import Language.PureScript.Linter as P
58+import Language.PureScript.ModuleDependencies as P
59+import Language.PureScript.Names as P
60+import Language.PureScript.Options as P
61+import Language.PureScript.Parser as P
62+import Language.PureScript.Pretty as P
63+import Language.PureScript.Renamer as P
64+import Language.PureScript.Sugar as P
65+import Control.Monad.Supply as P
66+import Language.PureScript.TypeChecker as P
67+import Language.PureScript.Types as P
68+import qualified Language.PureScript.CoreFn as CoreFn
69+import qualified Language.PureScript.Constants as C
70+import qualified Language.PureScript.CodeGen.JS as J
71+
72+import qualified Paths_purescript as Paths
73+
74+-- |
75+-- Compile a collection of modules
76+--
77+-- The compilation pipeline proceeds as follows:
78+--
79+-- * Sort the modules based on module dependencies, checking for cyclic dependencies.
80+--
81+-- * Perform a set of desugaring passes.
82+--
83+-- * Type check, and elaborate values to include type annotations and type class dictionaries.
84+--
85+-- * Regroup values to take into account new value dependencies introduced by elaboration.
86+--
87+-- * Eliminate dead code.
88+--
89+-- * Generate Javascript, and perform optimization passes.
90+--
91+-- * Pretty-print the generated Javascript
92+--
93+compile :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadReader (Options Compile) m)
94+ => [Module] -> m ([CoreFn.Module CoreFn.Ann], Environment, SupplyVar, Externs)
95+compile = compile' initEnvironment
96+
97+compile' :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadReader (Options Compile) m)
98+ => Environment -> [Module] -> m ([CoreFn.Module CoreFn.Ann], Environment, SupplyVar, Externs)
99+compile' env ms = do
100+ additional <- asks optionsAdditional
101+ mainModuleIdent <- asks (fmap moduleNameFromString . optionsMain)
102+ (sorted, _) <- sortModules $ map importPrim ms
103+ mapM_ lint sorted
104+ (desugared, nextVar) <- runSupplyT 0 $ desugar sorted
105+ (elaborated, env') <- runCheck' env $ forM desugared $ typeCheckModule mainModuleIdent
106+ regrouped <- createBindingGroupsModule . collapseBindingGroupsModule $ elaborated
107+ let corefn = map (CoreFn.moduleToCoreFn env') regrouped
108+ entryPoints = moduleNameFromString `map` entryPointModules additional
109+ elim = if null entryPoints then corefn else eliminateDeadCode entryPoints corefn
110+ renamed = renameInModules elim
111+ codeGenModuleNames = moduleNameFromString `map` codeGenModules additional
112+ modulesToCodeGen = if null codeGenModuleNames then renamed else filter (\(CoreFn.Module _ mn _ _ _ _) -> mn `elem` codeGenModuleNames) renamed
113+ exts = intercalate "\n" . map (`moduleToPs` env') $ regrouped
114+ return (modulesToCodeGen, env', nextVar, exts)
115+
116+-- |
117+-- Compile a collection of modules to JavaScript and externs files
118+--
119+compileJS :: forall m. (Functor m, Applicative m, MonadError P.MultipleErrors m, MonadWriter P.MultipleErrors m, MonadReader (P.Options P.Compile) m)
120+ => [P.Module] -> M.Map P.ModuleName (FilePath, P.ForeignJS) -> [String] -> m (String, String, Environment)
121+compileJS ms foreigns prefix = do
122+ (modulesToCodeGen, env, nextVar, exts) <- compile ms
123+ js <- concat <$> evalSupplyT nextVar (P.parU modulesToCodeGen codegenModule)
124+ js' <- generateMain env js
125+ let pjs = unlines $ map ("// " ++) prefix ++ [P.prettyPrintJS js']
126+ return (pjs, exts, env)
127+
128+ where
129+
130+ codegenModule :: (Functor n, Applicative n, MonadError P.MultipleErrors n, MonadWriter P.MultipleErrors n, MonadReader (P.Options P.Compile) n, MonadSupply n)
131+ => CoreFn.Module CoreFn.Ann -> n [J.JS]
132+ codegenModule m =
133+ let requiresForeign = not $ null (CoreFn.moduleForeign m)
134+ mn = CoreFn.moduleName m
135+ in case mn `M.lookup` foreigns of
136+ Just (path, js)
137+ | not requiresForeign -> do
138+ tell $ P.errorMessage $ P.UnnecessaryFFIModule mn path
139+ J.moduleToJs m Nothing
140+ | otherwise -> J.moduleToJs m $ Just $
141+ J.JSApp (J.JSFunction Nothing [] $
142+ J.JSBlock [ J.JSVariableIntroduction "exports" (Just $ J.JSObjectLiteral [])
143+ , J.JSRaw js
144+ , J.JSReturn (J.JSVar "exports")
145+ ]) []
146+ Nothing | requiresForeign -> throwError . P.errorMessage $ P.MissingFFIModule mn
147+ | otherwise -> J.moduleToJs m Nothing
148+
149+ generateMain :: P.Environment -> [J.JS] -> m [J.JS]
150+ generateMain env js = do
151+ mainName <- asks P.optionsMain
152+ additional <- asks P.optionsAdditional
153+ case P.moduleNameFromString <$> mainName of
154+ Just mmi -> do
155+ when ((mmi, P.Ident C.main) `M.notMember` P.names env) $
156+ throwError . P.errorMessage $ P.NameIsUndefined (P.Ident C.main)
157+ return $ js ++ [J.mainCall mmi (P.browserNamespace additional)]
158+ _ -> return js
159+
160+-- |
161+-- Actions that require implementations when running in "make" mode.
162+--
163+data MakeActions m = MakeActions {
164+ -- |
165+ -- Get the timestamp for the input file(s) for a module. If there are multiple
166+ -- files (.purs and foreign files, for example) the timestamp should be for
167+ -- the most recently modified file.
168+ --
169+ getInputTimestamp :: ModuleName -> m (Either RebuildPolicy (Maybe UTCTime))
170+ -- |
171+ -- Get the timestamp for the output files for a module. This should be the
172+ -- timestamp for the oldest modified file, or Nothing if any of the required
173+ -- output files are missing.
174+ --
175+ , getOutputTimestamp :: ModuleName -> m (Maybe UTCTime)
176+ -- |
177+ -- Read the externs file for a module as a string and also return the actual
178+ -- path for the file.
179+ , readExterns :: ModuleName -> m (FilePath, String)
180+ -- |
181+ -- Run the code generator for the module and write any required output files.
182+ --
183+ , codegen :: CoreFn.Module CoreFn.Ann -> Environment -> SupplyVar -> Externs -> m ()
184+ -- |
185+ -- Respond to a progress update.
186+ --
187+ , progress :: String -> m ()
188+ }
189+
190+-- |
191+-- Generated code for an externs file.
192+--
193+type Externs = String
194+
195+-- |
196+-- A value to be used in the Supply monad.
197+--
198+type SupplyVar = Integer
199+
200+-- |
201+-- Determines when to rebuild a module
202+--
203+data RebuildPolicy
204+ -- | Never rebuild this module
205+ = RebuildNever
206+ -- | Always rebuild this module
207+ | RebuildAlways deriving (Show, Eq, Ord)
208+
209+-- |
210+-- Compiles in "make" mode, compiling each module separately to a js files and an externs file
211+--
212+-- If timestamps have not changed, the externs file can be used to provide the module's types without
213+-- having to typecheck the module again.
214+--
215+make :: forall m. (Functor m, Applicative m, Monad m, MonadReader (P.Options P.Make) m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
216+ => MakeActions m
217+ -> [(Either RebuildPolicy FilePath, Module)]
218+ -> m Environment
219+make MakeActions{..} ms = do
220+ (sorted, graph) <- sortModules $ map (importPrim . snd) ms
221+ mapM_ lint sorted
222+ toRebuild <- foldM (\s (Module _ moduleName' _ _) -> do
223+ inputTimestamp <- getInputTimestamp moduleName'
224+ outputTimestamp <- getOutputTimestamp moduleName'
225+ return $ case (inputTimestamp, outputTimestamp) of
226+ (Right (Just t1), Just t2) | t1 < t2 -> s
227+ (Left RebuildNever, Just _) -> s
228+ _ -> S.insert moduleName' s) S.empty sorted
229+
230+ marked <- rebuildIfNecessary (reverseDependencies graph) toRebuild sorted
231+ (desugared, nextVar) <- runSupplyT 0 $ zip (map fst marked) <$> desugar (map snd marked)
232+ evalSupplyT nextVar $ go initEnvironment desugared
233+ where
234+
235+ go :: Environment -> [(Bool, Module)] -> SupplyT m Environment
236+ go env [] = return env
237+ go env ((False, m) : ms') = do
238+ (_, env') <- lift . runCheck' env $ typeCheckModule Nothing m
239+ go env' ms'
240+ go env ((True, m@(Module coms moduleName' _ exps)) : ms') = do
241+ lift $ progress $ "Compiling " ++ runModuleName moduleName'
242+ (Module _ _ elaborated _, env') <- lift . runCheck' env $ typeCheckModule Nothing m
243+ regrouped <- createBindingGroups moduleName' . collapseBindingGroups $ elaborated
244+ let mod' = Module coms moduleName' regrouped exps
245+ corefn = CoreFn.moduleToCoreFn env' mod'
246+ [renamed] = renameInModules [corefn]
247+ exts = moduleToPs mod' env'
248+ nextVar <- fresh
249+ lift $ codegen renamed env' nextVar exts
250+ go env' ms'
251+
252+ rebuildIfNecessary :: M.Map ModuleName [ModuleName] -> S.Set ModuleName -> [Module] -> m [(Bool, Module)]
253+ rebuildIfNecessary _ _ [] = return []
254+ rebuildIfNecessary graph toRebuild (m@(Module _ moduleName' _ _) : ms') | moduleName' `S.member` toRebuild = do
255+ let deps = fromMaybe [] $ moduleName' `M.lookup` graph
256+ toRebuild' = toRebuild `S.union` S.fromList deps
257+ (:) (True, m) <$> rebuildIfNecessary graph toRebuild' ms'
258+ rebuildIfNecessary graph toRebuild (Module _ moduleName' _ _ : ms') = do
259+ (path, externs) <- readExterns moduleName'
260+ externsModules <- fmap (map snd) . alterErrors $ P.parseModulesFromFiles id [(path, externs)]
261+ case externsModules of
262+ [m'@(Module _ moduleName'' _ _)] | moduleName'' == moduleName' -> (:) (False, m') <$> rebuildIfNecessary graph toRebuild ms'
263+ _ -> throwError . errorMessage . InvalidExternsFile $ path
264+ where
265+ alterErrors = flip catchError $ \(MultipleErrors errs) ->
266+ throwError . MultipleErrors $ flip map errs $ \e -> case e of
267+ SimpleErrorWrapper (ErrorParsingModule err) -> SimpleErrorWrapper (ErrorParsingExterns err)
268+ _ -> e
269+
270+reverseDependencies :: ModuleGraph -> M.Map ModuleName [ModuleName]
271+reverseDependencies g = combine [ (dep, mn) | (mn, deps) <- g, dep <- deps ]
272+ where
273+ combine :: (Ord a) => [(a, b)] -> M.Map a [b]
274+ combine = M.fromList . map ((fst . head) &&& map snd) . groupBy ((==) `on` fst) . sortBy (compare `on` fst)
275+
276+-- |
277+-- Add an import declaration for a module if it does not already explicitly import it.
278+--
279+addDefaultImport :: ModuleName -> Module -> Module
280+addDefaultImport toImport m@(Module coms mn decls exps) =
281+ if isExistingImport `any` decls || mn == toImport then m
282+ else Module coms mn (ImportDeclaration toImport Implicit Nothing : decls) exps
283+ where
284+ isExistingImport (ImportDeclaration mn' _ _) | mn' == toImport = True
285+ isExistingImport (PositionedDeclaration _ _ d) = isExistingImport d
286+ isExistingImport _ = False
287+
288+importPrim :: Module -> Module
289+importPrim = addDefaultImport (ModuleName [ProperName C.prim])
290+
291+version :: Version
292+version = Paths.version
src/Language/PureScript/AST.hsnew file+24
@@ -0,0 +1,24 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.AST
4+-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- | The initial PureScript AST
12+--
13+-----------------------------------------------------------------------------
14+
15+module Language.PureScript.AST (
16+ module AST
17+) where
18+
19+import Language.PureScript.AST.Binders as AST
20+import Language.PureScript.AST.Declarations as AST
21+import Language.PureScript.AST.Operators as AST
22+import Language.PureScript.AST.SourcePos as AST
23+import Language.PureScript.AST.Traversals as AST
24+import Language.PureScript.AST.Exported as AST
src/Language/PureScript/AST/Binders.hsnew file+86
@@ -0,0 +1,86 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.AST.Binders
4+-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- | Case binders
12+--
13+-----------------------------------------------------------------------------
14+
15+{-# LANGUAGE DeriveDataTypeable #-}
16+
17+module Language.PureScript.AST.Binders where
18+
19+import qualified Data.Data as D
20+
21+import Language.PureScript.AST.SourcePos
22+import Language.PureScript.Names
23+import Language.PureScript.Comments
24+
25+-- |
26+-- Data type for binders
27+--
28+data Binder
29+ -- |
30+ -- Wildcard binder
31+ --
32+ = NullBinder
33+ -- |
34+ -- A binder which matches a boolean literal
35+ --
36+ | BooleanBinder Bool
37+ -- |
38+ -- A binder which matches a string literal
39+ --
40+ | StringBinder String
41+ -- |
42+ -- A binder which matches a character literal
43+ --
44+ | CharBinder Char
45+ -- |
46+ -- A binder which matches a numeric literal
47+ --
48+ | NumberBinder (Either Integer Double)
49+ -- |
50+ -- A binder which binds an identifier
51+ --
52+ | VarBinder Ident
53+ -- |
54+ -- A binder which matches a data constructor
55+ --
56+ | ConstructorBinder (Qualified ProperName) [Binder]
57+ -- |
58+ -- A binder which matches a record and binds its properties
59+ --
60+ | ObjectBinder [(String, Binder)]
61+ -- |
62+ -- A binder which matches an array and binds its elements
63+ --
64+ | ArrayBinder [Binder]
65+ -- |
66+ -- A binder which binds its input to an identifier
67+ --
68+ | NamedBinder Ident Binder
69+ -- |
70+ -- A binder with source position information
71+ --
72+ | PositionedBinder SourceSpan [Comment] Binder deriving (Show, D.Data, D.Typeable)
73+
74+-- |
75+-- Collect all names introduced in binders in an expression
76+--
77+binderNames :: Binder -> [Ident]
78+binderNames = go []
79+ where
80+ go ns (VarBinder name) = name : ns
81+ go ns (ConstructorBinder _ bs) = foldl go ns bs
82+ go ns (ObjectBinder bs) = foldl go ns (map snd bs)
83+ go ns (ArrayBinder bs) = foldl go ns bs
84+ go ns (NamedBinder name b) = go (name : ns) b
85+ go ns (PositionedBinder _ _ b) = go ns b
86+ go ns _ = ns
src/Language/PureScript/AST/Declarations.hsnew file+411
@@ -0,0 +1,411 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.AST.Declarations
4+-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- | Data types for modules and declarations
12+--
13+-----------------------------------------------------------------------------
14+
15+{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-}
16+
17+module Language.PureScript.AST.Declarations where
18+
19+import qualified Data.Data as D
20+import qualified Data.Map as M
21+
22+import Language.PureScript.AST.Binders
23+import Language.PureScript.AST.Operators
24+import Language.PureScript.AST.SourcePos
25+import Language.PureScript.Types
26+import Language.PureScript.Names
27+import Language.PureScript.Kinds
28+import Language.PureScript.TypeClassDictionaries
29+import Language.PureScript.Comments
30+import Language.PureScript.Environment
31+
32+-- |
33+-- A module declaration, consisting of comments about the module, a module name,
34+-- a list of declarations, and a list of the declarations that are
35+-- explicitly exported. If the export list is Nothing, everything is exported.
36+--
37+data Module = Module [Comment] ModuleName [Declaration] (Maybe [DeclarationRef]) deriving (Show, D.Data, D.Typeable)
38+
39+-- | Return a module's name.
40+getModuleName :: Module -> ModuleName
41+getModuleName (Module _ name _ _) = name
42+
43+-- |
44+-- An item in a list of explicit imports or exports
45+--
46+data DeclarationRef
47+ -- |
48+ -- A type constructor with data constructors
49+ --
50+ = TypeRef ProperName (Maybe [ProperName])
51+ -- |
52+ -- A value
53+ --
54+ | ValueRef Ident
55+ -- |
56+ -- A type class
57+ --
58+ | TypeClassRef ProperName
59+ -- |
60+ -- A type class instance, created during typeclass desugaring (name, class name, instance types)
61+ --
62+ | TypeInstanceRef Ident
63+ -- |
64+ -- A declaration reference with source position information
65+ --
66+ | PositionedDeclarationRef SourceSpan [Comment] DeclarationRef
67+ deriving (Show, D.Data, D.Typeable)
68+
69+instance Eq DeclarationRef where
70+ (TypeRef name dctors) == (TypeRef name' dctors') = name == name' && dctors == dctors'
71+ (ValueRef name) == (ValueRef name') = name == name'
72+ (TypeClassRef name) == (TypeClassRef name') = name == name'
73+ (TypeInstanceRef name) == (TypeInstanceRef name') = name == name'
74+ (PositionedDeclarationRef _ _ r) == r' = r == r'
75+ r == (PositionedDeclarationRef _ _ r') = r == r'
76+ _ == _ = False
77+
78+-- |
79+-- The data type which specifies type of import declaration
80+--
81+data ImportDeclarationType
82+ -- |
83+ -- An import with no explicit list: `import M`
84+ --
85+ = Implicit
86+ -- |
87+ -- An import with an explicit list of references to import: `import M (foo)`
88+ --
89+ | Explicit [DeclarationRef]
90+ -- |
91+ -- An import with a list of references to hide: `import M hiding (foo)`
92+ --
93+ | Hiding [DeclarationRef]
94+ deriving (Show, D.Data, D.Typeable)
95+
96+-- |
97+-- The data type of declarations
98+--
99+data Declaration
100+ -- |
101+ -- A data type declaration (data or newtype, name, arguments, data constructors)
102+ --
103+ = DataDeclaration DataDeclType ProperName [(String, Maybe Kind)] [(ProperName, [Type])]
104+ -- |
105+ -- A minimal mutually recursive set of data type declarations
106+ --
107+ | DataBindingGroupDeclaration [Declaration]
108+ -- |
109+ -- A type synonym declaration (name, arguments, type)
110+ --
111+ | TypeSynonymDeclaration ProperName [(String, Maybe Kind)] Type
112+ -- |
113+ -- A type declaration for a value (name, ty)
114+ --
115+ | TypeDeclaration Ident Type
116+ -- |
117+ -- A value declaration (name, top-level binders, optional guard, value)
118+ --
119+ | ValueDeclaration Ident NameKind [Binder] (Either [(Guard, Expr)] Expr)
120+ -- |
121+ -- A minimal mutually recursive set of value declarations
122+ --
123+ | BindingGroupDeclaration [(Ident, NameKind, Expr)]
124+ -- |
125+ -- A foreign import declaration (name, type)
126+ --
127+ | ExternDeclaration Ident Type
128+ -- |
129+ -- A data type foreign import (name, kind)
130+ --
131+ | ExternDataDeclaration ProperName Kind
132+ -- |
133+ -- A type class instance foreign import
134+ --
135+ | ExternInstanceDeclaration Ident [Constraint] (Qualified ProperName) [Type]
136+ -- |
137+ -- A fixity declaration (fixity data, operator name)
138+ --
139+ | FixityDeclaration Fixity String
140+ -- |
141+ -- A module import (module name, qualified/unqualified/hiding, optional "qualified as" name)
142+ --
143+ | ImportDeclaration ModuleName ImportDeclarationType (Maybe ModuleName)
144+ -- |
145+ -- A type class declaration (name, argument, implies, member declarations)
146+ --
147+ | TypeClassDeclaration ProperName [(String, Maybe Kind)] [Constraint] [Declaration]
148+ -- |
149+ -- A type instance declaration (name, dependencies, class name, instance types, member
150+ -- declarations)
151+ --
152+ | TypeInstanceDeclaration Ident [Constraint] (Qualified ProperName) [Type] [Declaration]
153+ -- |
154+ -- A declaration with source position information
155+ --
156+ | PositionedDeclaration SourceSpan [Comment] Declaration
157+ deriving (Show, D.Data, D.Typeable)
158+
159+-- |
160+-- Test if a declaration is a value declaration
161+--
162+isValueDecl :: Declaration -> Bool
163+isValueDecl ValueDeclaration{} = True
164+isValueDecl (PositionedDeclaration _ _ d) = isValueDecl d
165+isValueDecl _ = False
166+
167+-- |
168+-- Test if a declaration is a data type or type synonym declaration
169+--
170+isDataDecl :: Declaration -> Bool
171+isDataDecl DataDeclaration{} = True
172+isDataDecl TypeSynonymDeclaration{} = True
173+isDataDecl (PositionedDeclaration _ _ d) = isDataDecl d
174+isDataDecl _ = False
175+
176+-- |
177+-- Test if a declaration is a module import
178+--
179+isImportDecl :: Declaration -> Bool
180+isImportDecl ImportDeclaration{} = True
181+isImportDecl (PositionedDeclaration _ _ d) = isImportDecl d
182+isImportDecl _ = False
183+
184+-- |
185+-- Test if a declaration is a data type foreign import
186+--
187+isExternDataDecl :: Declaration -> Bool
188+isExternDataDecl ExternDataDeclaration{} = True
189+isExternDataDecl (PositionedDeclaration _ _ d) = isExternDataDecl d
190+isExternDataDecl _ = False
191+
192+-- |
193+-- Test if a declaration is a type class instance foreign import
194+--
195+isExternInstanceDecl :: Declaration -> Bool
196+isExternInstanceDecl ExternInstanceDeclaration{} = True
197+isExternInstanceDecl (PositionedDeclaration _ _ d) = isExternInstanceDecl d
198+isExternInstanceDecl _ = False
199+
200+-- |
201+-- Test if a declaration is a fixity declaration
202+--
203+isFixityDecl :: Declaration -> Bool
204+isFixityDecl FixityDeclaration{} = True
205+isFixityDecl (PositionedDeclaration _ _ d) = isFixityDecl d
206+isFixityDecl _ = False
207+
208+-- |
209+-- Test if a declaration is a foreign import
210+--
211+isExternDecl :: Declaration -> Bool
212+isExternDecl ExternDeclaration{} = True
213+isExternDecl (PositionedDeclaration _ _ d) = isExternDecl d
214+isExternDecl _ = False
215+
216+-- |
217+-- Test if a declaration is a type class instance declaration
218+--
219+isTypeClassInstanceDeclaration :: Declaration -> Bool
220+isTypeClassInstanceDeclaration TypeInstanceDeclaration{} = True
221+isTypeClassInstanceDeclaration (PositionedDeclaration _ _ d) = isTypeClassInstanceDeclaration d
222+isTypeClassInstanceDeclaration _ = False
223+
224+-- |
225+-- Test if a declaration is a type class declaration
226+--
227+isTypeClassDeclaration :: Declaration -> Bool
228+isTypeClassDeclaration TypeClassDeclaration{} = True
229+isTypeClassDeclaration (PositionedDeclaration _ _ d) = isTypeClassDeclaration d
230+isTypeClassDeclaration _ = False
231+
232+-- |
233+-- Recursively flatten data binding groups in the list of declarations
234+flattenDecls :: [Declaration] -> [Declaration]
235+flattenDecls = concatMap flattenOne
236+ where flattenOne :: Declaration -> [Declaration]
237+ flattenOne (DataBindingGroupDeclaration decls) = concatMap flattenOne decls
238+ flattenOne d = [d]
239+
240+-- |
241+-- A guard is just a boolean-valued expression that appears alongside a set of binders
242+--
243+type Guard = Expr
244+
245+-- |
246+-- Data type for expressions and terms
247+--
248+data Expr
249+ -- |
250+ -- A numeric literal
251+ --
252+ = NumericLiteral (Either Integer Double)
253+ -- |
254+ -- A string literal
255+ --
256+ | StringLiteral String
257+ -- |
258+ -- A character literal
259+ --
260+ | CharLiteral Char
261+ -- |
262+ -- A boolean literal
263+ --
264+ | BooleanLiteral Bool
265+ -- |
266+ -- A prefix -, will be desugared
267+ --
268+ | UnaryMinus Expr
269+ -- |
270+ -- Binary operator application. During the rebracketing phase of desugaring, this data constructor
271+ -- will be removed.
272+ --
273+ | BinaryNoParens Expr Expr Expr
274+ -- |
275+ -- Explicit parentheses. During the rebracketing phase of desugaring, this data constructor
276+ -- will be removed.
277+ --
278+ | Parens Expr
279+ -- |
280+ -- Operator section. This will be removed during desugaring and replaced with a partially applied
281+ -- operator or lambda to flip the arguments.
282+ --
283+ | OperatorSection Expr (Either Expr Expr)
284+ -- |
285+ -- An array literal
286+ --
287+ | ArrayLiteral [Expr]
288+ -- |
289+ -- An object literal
290+ --
291+ | ObjectLiteral [(String, Expr)]
292+ -- |
293+ -- An object constructor (object literal with underscores). This will be removed during
294+ -- desugaring and expanded into a lambda that returns an object literal.
295+ --
296+ | ObjectConstructor [(String, Maybe Expr)]
297+ -- |
298+ -- An object property getter (e.g. `_.x`). This will be removed during
299+ -- desugaring and expanded into a lambda that reads a property from an object.
300+ --
301+ | ObjectGetter String
302+ -- |
303+ -- An record property accessor expression
304+ --
305+ | Accessor String Expr
306+ -- |
307+ -- Partial record update
308+ --
309+ | ObjectUpdate Expr [(String, Expr)]
310+ -- |
311+ -- Partial record updater. This will be removed during desugaring and
312+ -- expanded into a lambda that returns an object update.
313+ --
314+ | ObjectUpdater (Maybe Expr) [(String, Maybe Expr)]
315+ -- |
316+ -- Function introduction
317+ --
318+ | Abs (Either Ident Binder) Expr
319+ -- |
320+ -- Function application
321+ --
322+ | App Expr Expr
323+ -- |
324+ -- Variable
325+ --
326+ | Var (Qualified Ident)
327+ -- |
328+ -- Conditional (if-then-else expression)
329+ --
330+ | IfThenElse Expr Expr Expr
331+ -- |
332+ -- A data constructor
333+ --
334+ | Constructor (Qualified ProperName)
335+ -- |
336+ -- A case expression. During the case expansion phase of desugaring, top-level binders will get
337+ -- desugared into case expressions, hence the need for guards and multiple binders per branch here.
338+ --
339+ | Case [Expr] [CaseAlternative]
340+ -- |
341+ -- A value with a type annotation
342+ --
343+ | TypedValue Bool Expr Type
344+ -- |
345+ -- A let binding
346+ --
347+ | Let [Declaration] Expr
348+ -- |
349+ -- A do-notation block
350+ --
351+ | Do [DoNotationElement]
352+ -- |
353+ -- An application of a typeclass dictionary constructor. The value should be
354+ -- an ObjectLiteral.
355+ --
356+ | TypeClassDictionaryConstructorApp (Qualified ProperName) Expr
357+ -- |
358+ -- A placeholder for a type class dictionary to be inserted later. At the end of type checking, these
359+ -- placeholders will be replaced with actual expressions representing type classes dictionaries which
360+ -- can be evaluated at runtime. The constructor arguments represent (in order): whether or not to look
361+ -- at superclass implementations when searching for a dictionary, the type class name and
362+ -- instance type, and the type class dictionaries in scope.
363+ --
364+ | TypeClassDictionary Bool Constraint (M.Map (Maybe ModuleName) (M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope)))
365+ -- |
366+ -- A typeclass dictionary accessor, the implementation is left unspecified until CoreFn desugaring.
367+ --
368+ | TypeClassDictionaryAccessor (Qualified ProperName) Ident
369+ -- |
370+ -- A placeholder for a superclass dictionary to be turned into a TypeClassDictionary during typechecking
371+ --
372+ | SuperClassDictionary (Qualified ProperName) [Type]
373+ -- |
374+ -- A value with source position information
375+ --
376+ | PositionedValue SourceSpan [Comment] Expr deriving (Show, D.Data, D.Typeable)
377+
378+-- |
379+-- An alternative in a case statement
380+--
381+data CaseAlternative = CaseAlternative
382+ { -- |
383+ -- A collection of binders with which to match the inputs
384+ --
385+ caseAlternativeBinders :: [Binder]
386+ -- |
387+ -- The result expression or a collect of guarded expressions
388+ --
389+ , caseAlternativeResult :: Either [(Guard, Expr)] Expr
390+ } deriving (Show, D.Data, D.Typeable)
391+
392+-- |
393+-- A statement in a do-notation block
394+--
395+data DoNotationElement
396+ -- |
397+ -- A monadic value without a binder
398+ --
399+ = DoNotationValue Expr
400+ -- |
401+ -- A monadic value with a binder
402+ --
403+ | DoNotationBind Binder Expr
404+ -- |
405+ -- A let statement, i.e. a pure value with a binder
406+ --
407+ | DoNotationLet [Declaration]
408+ -- |
409+ -- A do notation element with source position information
410+ --
411+ | PositionedDoNotationElement SourceSpan [Comment] DoNotationElement deriving (Show, D.Data, D.Typeable)
src/Language/PureScript/AST/Exported.hsnew file+136
@@ -0,0 +1,136 @@
1+
2+module Language.PureScript.AST.Exported (
3+ exportedDeclarations,
4+ isExported
5+) where
6+
7+import Control.Category ((>>>))
8+import Data.Maybe (mapMaybe)
9+
10+import Language.PureScript.AST.Declarations
11+import Language.PureScript.Types
12+import Language.PureScript.Names
13+
14+-- |
15+-- Return a list of all declarations which are exported from a module.
16+-- This function descends into data declarations to filter out unexported
17+-- data constructors, and also filters out type instance declarations if
18+-- they refer to classes or types which are not themselves exported.
19+--
20+-- Note that this function assumes that the module has already had its imports
21+-- desugared using 'Language.PureScript.Sugar.Names.desugarImports'. It will
22+-- produce incorrect results if this is not the case - for example, type class
23+-- instances will be incorrectly removed in some cases.
24+--
25+exportedDeclarations :: Module -> [Declaration]
26+exportedDeclarations (Module _ _ decls exps) = go decls
27+ where
28+ go = flattenDecls
29+ >>> filter (isExported exps)
30+ >>> map (filterDataConstructors exps)
31+ >>> filterInstances exps
32+
33+-- |
34+-- Filter out all data constructors from a declaration which are not exported.
35+-- If the supplied declaration is not a data declaration, this function returns
36+-- it unchanged.
37+--
38+filterDataConstructors :: Maybe [DeclarationRef] -> Declaration -> Declaration
39+filterDataConstructors exps (DataDeclaration dType tyName tyArgs dctors) =
40+ DataDeclaration dType tyName tyArgs $
41+ filter (isDctorExported tyName exps . fst) dctors
42+filterDataConstructors exps (PositionedDeclaration srcSpan coms d) =
43+ PositionedDeclaration srcSpan coms (filterDataConstructors exps d)
44+filterDataConstructors _ other = other
45+
46+-- |
47+-- Filter out all the type instances from a list of declarations which
48+-- reference a type or type class which is both local and not exported.
49+--
50+-- Note that this function assumes that the module has already had its imports
51+-- desugared using "Language.PureScript.Sugar.Names.desugarImports". It will
52+-- produce incorrect results if this is not the case - for example, type class
53+-- instances will be incorrectly removed in some cases.
54+--
55+filterInstances :: Maybe [DeclarationRef] -> [Declaration] -> [Declaration]
56+filterInstances Nothing = id
57+filterInstances (Just exps) =
58+ let refs = mapMaybe typeName exps ++ mapMaybe typeClassName exps
59+ in filter (all (visibleOutside refs) . typeInstanceConstituents)
60+ where
61+ -- Given a Qualified ProperName, and a list of all exported types and type
62+ -- classes, returns whether the supplied Qualified ProperName is visible
63+ -- outside this module. This is true if one of the following hold:
64+ --
65+ -- * the name is defined in the same module and is exported,
66+ -- * the name is defined in a different module (and must be exported from
67+ -- that module; the code would fail to compile otherwise).
68+ visibleOutside _ (Qualified (Just _) _) = True
69+ visibleOutside refs (Qualified Nothing n) = any (== n) refs
70+
71+ typeName (TypeRef n _) = Just n
72+ typeName (PositionedDeclarationRef _ _ r) = typeName r
73+ typeName _ = Nothing
74+
75+ typeClassName (TypeClassRef n) = Just n
76+ typeClassName (PositionedDeclarationRef _ _ r) = typeClassName r
77+ typeClassName _ = Nothing
78+
79+-- |
80+-- Get all type and type class names referenced by a type instance declaration.
81+--
82+typeInstanceConstituents :: Declaration -> [Qualified ProperName]
83+typeInstanceConstituents (TypeInstanceDeclaration _ constraints className tys _) =
84+ className : (concatMap fromConstraint constraints ++ concatMap fromType tys)
85+ where
86+
87+ fromConstraint (name, tys') = name : concatMap fromType tys'
88+ fromType = everythingOnTypes (++) go
89+
90+ -- Note that type synonyms are disallowed in instance declarations, so
91+ -- we don't need to handle them here.
92+ go (TypeConstructor n) = [n]
93+ go (ConstrainedType cs _) = concatMap fromConstraint cs
94+ go _ = []
95+
96+typeInstanceConstituents (PositionedDeclaration _ _ d) = typeInstanceConstituents d
97+typeInstanceConstituents _ = []
98+
99+
100+-- |
101+-- Test if a declaration is exported, given a module's export list. Note that
102+-- this function does not account for type instance declarations of
103+-- non-exported types, or non-exported data constructors. Therefore, you should
104+-- prefer 'exportedDeclarations' to this function, where possible.
105+--
106+isExported :: Maybe [DeclarationRef] -> Declaration -> Bool
107+isExported Nothing _ = True
108+isExported _ TypeInstanceDeclaration{} = True
109+isExported exps (PositionedDeclaration _ _ d) = isExported exps d
110+isExported (Just exps) decl = any (matches decl) exps
111+ where
112+ matches (TypeDeclaration ident _) (ValueRef ident') = ident == ident'
113+ matches (ValueDeclaration ident _ _ _) (ValueRef ident') = ident == ident'
114+ matches (ExternDeclaration ident _) (ValueRef ident') = ident == ident'
115+ matches (FixityDeclaration _ name) (ValueRef ident') = name == runIdent ident'
116+ matches (DataDeclaration _ ident _ _) (TypeRef ident' _) = ident == ident'
117+ matches (ExternDataDeclaration ident _) (TypeRef ident' _) = ident == ident'
118+ matches (TypeSynonymDeclaration ident _ _) (TypeRef ident' _) = ident == ident'
119+ matches (TypeClassDeclaration ident _ _ _) (TypeClassRef ident') = ident == ident'
120+
121+ matches (PositionedDeclaration _ _ d) r = d `matches` r
122+ matches d (PositionedDeclarationRef _ _ r) = d `matches` r
123+ matches _ _ = False
124+
125+-- |
126+-- Test if a data constructor for a given type is exported, given a module's
127+-- export list. Prefer 'exportedDeclarations' to this function, where possible.
128+--
129+isDctorExported :: ProperName -> Maybe [DeclarationRef] -> ProperName -> Bool
130+isDctorExported _ Nothing _ = True
131+isDctorExported ident (Just exps) ctor = test `any` exps
132+ where
133+ test (PositionedDeclarationRef _ _ d) = test d
134+ test (TypeRef ident' Nothing) = ident == ident'
135+ test (TypeRef ident' (Just ctors)) = ident == ident' && ctor `elem` ctors
136+ test _ = False
src/Language/PureScript/AST/Operators.hsnew file+51
@@ -0,0 +1,51 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.AST.Operators
4+-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- | Operators fixity and associativity
12+--
13+-----------------------------------------------------------------------------
14+
15+{-# LANGUAGE OverloadedStrings #-}
16+{-# LANGUAGE DeriveDataTypeable #-}
17+
18+module Language.PureScript.AST.Operators where
19+
20+import qualified Data.Data as D
21+import Data.Aeson ((.=))
22+import qualified Data.Aeson as A
23+
24+-- |
25+-- A precedence level for an infix operator
26+--
27+type Precedence = Integer
28+
29+-- |
30+-- Associativity for infix operators
31+--
32+data Associativity = Infixl | Infixr | Infix deriving (Eq, Ord, D.Data, D.Typeable)
33+
34+instance Show Associativity where
35+ show Infixl = "infixl"
36+ show Infixr = "infixr"
37+ show Infix = "infix"
38+
39+instance A.ToJSON Associativity where
40+ toJSON = A.toJSON . show
41+
42+-- |
43+-- Fixity data for infix operators
44+--
45+data Fixity = Fixity Associativity Precedence deriving (Show, Eq, Ord, D.Data, D.Typeable)
46+
47+instance A.ToJSON Fixity where
48+ toJSON (Fixity associativity precedence) =
49+ A.object [ "associativity" .= associativity
50+ , "precedence" .= precedence
51+ ]
src/Language/PureScript/AST/SourcePos.hsnew file+71
@@ -0,0 +1,71 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.AST.SourcePos
4+-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- | Source position information
12+--
13+-----------------------------------------------------------------------------
14+
15+{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables, RecordWildCards, OverloadedStrings #-}
16+
17+module Language.PureScript.AST.SourcePos where
18+
19+import qualified Data.Data as D
20+import Data.Aeson ((.=))
21+import qualified Data.Aeson as A
22+
23+-- |
24+-- Source position information
25+--
26+data SourcePos = SourcePos
27+ { -- |
28+ -- Line number
29+ --
30+ sourcePosLine :: Int
31+ -- |
32+ -- Column number
33+ --
34+ , sourcePosColumn :: Int
35+ } deriving (Eq, Ord, Show, D.Data, D.Typeable)
36+
37+displaySourcePos :: SourcePos -> String
38+displaySourcePos sp =
39+ "line " ++ show (sourcePosLine sp) ++
40+ ", column " ++ show (sourcePosColumn sp)
41+
42+instance A.ToJSON SourcePos where
43+ toJSON SourcePos{..} =
44+ A.toJSON [sourcePosLine, sourcePosColumn]
45+
46+data SourceSpan = SourceSpan
47+ { -- |
48+ -- Source name
49+ --
50+ spanName :: String
51+ -- |
52+ -- Start of the span
53+ --
54+ , spanStart :: SourcePos
55+ -- End of the span
56+ --
57+ , spanEnd :: SourcePos
58+ } deriving (Eq, Ord, Show, D.Data, D.Typeable)
59+
60+displaySourceSpan :: SourceSpan -> String
61+displaySourceSpan sp =
62+ spanName sp ++ " " ++
63+ displaySourcePos (spanStart sp) ++ " - " ++
64+ displaySourcePos (spanEnd sp)
65+
66+instance A.ToJSON SourceSpan where
67+ toJSON SourceSpan{..} =
68+ A.object [ "name" .= spanName
69+ , "start" .= spanStart
70+ , "end" .= spanEnd
71+ ]
src/Language/PureScript/AST/Traversals.hsnew file+401
@@ -0,0 +1,401 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.AST.Traversals
4+-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- | AST traversal helpers
12+--
13+-----------------------------------------------------------------------------
14+
15+module Language.PureScript.AST.Traversals where
16+
17+import Data.Monoid (Monoid(..), mconcat)
18+import Data.Maybe (mapMaybe)
19+
20+import Control.Applicative
21+import Control.Monad
22+import Control.Arrow ((***), (+++), second)
23+
24+import Language.PureScript.AST.Binders
25+import Language.PureScript.AST.Declarations
26+import Language.PureScript.Types
27+import Language.PureScript.Traversals
28+
29+everywhereOnValues :: (Declaration -> Declaration) ->
30+ (Expr -> Expr) ->
31+ (Binder -> Binder) ->
32+ (Declaration -> Declaration, Expr -> Expr, Binder -> Binder)
33+everywhereOnValues f g h = (f', g', h')
34+ where
35+ f' :: Declaration -> Declaration
36+ f' (DataBindingGroupDeclaration ds) = f (DataBindingGroupDeclaration (map f' ds))
37+ f' (ValueDeclaration name nameKind bs val) = f (ValueDeclaration name nameKind (map h' bs) ((map (g' *** g') +++ g') val))
38+ f' (BindingGroupDeclaration ds) = f (BindingGroupDeclaration (map (\(name, nameKind, val) -> (name, nameKind, g' val)) ds))
39+ f' (TypeClassDeclaration name args implies ds) = f (TypeClassDeclaration name args implies (map f' ds))
40+ f' (TypeInstanceDeclaration name cs className args ds) = f (TypeInstanceDeclaration name cs className args (map f' ds))
41+ f' (PositionedDeclaration pos com d) = f (PositionedDeclaration pos com (f' d))
42+ f' other = f other
43+
44+ g' :: Expr -> Expr
45+ g' (UnaryMinus v) = g (UnaryMinus (g' v))
46+ g' (BinaryNoParens op v1 v2) = g (BinaryNoParens (g' op) (g' v1) (g' v2))
47+ g' (Parens v) = g (Parens (g' v))
48+ g' (OperatorSection op (Left v)) = g (OperatorSection (g' op) (Left $ g' v))
49+ g' (OperatorSection op (Right v)) = g (OperatorSection (g' op) (Right $ g' v))
50+ g' (ArrayLiteral vs) = g (ArrayLiteral (map g' vs))
51+ g' (ObjectLiteral vs) = g (ObjectLiteral (map (fmap g') vs))
52+ g' (ObjectConstructor vs) = g (ObjectConstructor (map (second (fmap g')) vs))
53+ g' (TypeClassDictionaryConstructorApp name v) = g (TypeClassDictionaryConstructorApp name (g' v))
54+ g' (Accessor prop v) = g (Accessor prop (g' v))
55+ g' (ObjectUpdate obj vs) = g (ObjectUpdate (g' obj) (map (fmap g') vs))
56+ g' (ObjectUpdater obj vs) = g (ObjectUpdater (fmap g' obj) (map (second (fmap g')) vs))
57+ g' (Abs name v) = g (Abs name (g' v))
58+ g' (App v1 v2) = g (App (g' v1) (g' v2))
59+ g' (IfThenElse v1 v2 v3) = g (IfThenElse (g' v1) (g' v2) (g' v3))
60+ g' (Case vs alts) = g (Case (map g' vs) (map handleCaseAlternative alts))
61+ g' (TypedValue check v ty) = g (TypedValue check (g' v) ty)
62+ g' (Let ds v) = g (Let (map f' ds) (g' v))
63+ g' (Do es) = g (Do (map handleDoNotationElement es))
64+ g' (PositionedValue pos com v) = g (PositionedValue pos com (g' v))
65+ g' other = g other
66+
67+ h' :: Binder -> Binder
68+ h' (ConstructorBinder ctor bs) = h (ConstructorBinder ctor (map h' bs))
69+ h' (ObjectBinder bs) = h (ObjectBinder (map (fmap h') bs))
70+ h' (ArrayBinder bs) = h (ArrayBinder (map h' bs))
71+ h' (NamedBinder name b) = h (NamedBinder name (h' b))
72+ h' (PositionedBinder pos com b) = h (PositionedBinder pos com (h' b))
73+ h' other = h other
74+
75+ handleCaseAlternative :: CaseAlternative -> CaseAlternative
76+ handleCaseAlternative ca =
77+ ca { caseAlternativeBinders = map h' (caseAlternativeBinders ca)
78+ , caseAlternativeResult = (map (g' *** g') +++ g') (caseAlternativeResult ca)
79+ }
80+
81+ handleDoNotationElement :: DoNotationElement -> DoNotationElement
82+ handleDoNotationElement (DoNotationValue v) = DoNotationValue (g' v)
83+ handleDoNotationElement (DoNotationBind b v) = DoNotationBind (h' b) (g' v)
84+ handleDoNotationElement (DoNotationLet ds) = DoNotationLet (map f' ds)
85+ handleDoNotationElement (PositionedDoNotationElement pos com e) = PositionedDoNotationElement pos com (handleDoNotationElement e)
86+
87+everywhereOnValuesTopDownM :: (Functor m, Applicative m, Monad m) =>
88+ (Declaration -> m Declaration) ->
89+ (Expr -> m Expr) ->
90+ (Binder -> m Binder) ->
91+ (Declaration -> m Declaration, Expr -> m Expr, Binder -> m Binder)
92+everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h)
93+ where
94+ f' (DataBindingGroupDeclaration ds) = DataBindingGroupDeclaration <$> mapM (f' <=< f) ds
95+ f' (ValueDeclaration name nameKind bs val) = ValueDeclaration name nameKind <$> mapM (h' <=< h) bs <*> eitherM (mapM (pairM (g' <=< g) (g' <=< g))) (g' <=< g) val
96+ f' (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> mapM (\(name, nameKind, val) -> (,,) name nameKind <$> (g val >>= g')) ds
97+ f' (TypeClassDeclaration name args implies ds) = TypeClassDeclaration name args implies <$> mapM (f' <=< f) ds
98+ f' (TypeInstanceDeclaration name cs className args ds) = TypeInstanceDeclaration name cs className args <$> mapM (f' <=< f) ds
99+ f' (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> (f d >>= f')
100+ f' other = f other
101+
102+ g' (UnaryMinus v) = UnaryMinus <$> (g v >>= g')
103+ g' (BinaryNoParens op v1 v2) = BinaryNoParens <$> (g op >>= g') <*> (g v1 >>= g') <*> (g v2 >>= g')
104+ g' (Parens v) = Parens <$> (g v >>= g')
105+ g' (OperatorSection op (Left v)) = OperatorSection <$> (g op >>= g') <*> (Left <$> (g v >>= g'))
106+ g' (OperatorSection op (Right v)) = OperatorSection <$> (g op >>= g') <*> (Right <$> (g v >>= g'))
107+ g' (ArrayLiteral vs) = ArrayLiteral <$> mapM (g' <=< g) vs
108+ g' (ObjectLiteral vs) = ObjectLiteral <$> mapM (sndM (g' <=< g)) vs
109+ g' (ObjectConstructor vs) = ObjectConstructor <$> mapM (sndM $ maybeM (g' <=< g)) vs
110+ g' (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> (g v >>= g')
111+ g' (Accessor prop v) = Accessor prop <$> (g v >>= g')
112+ g' (ObjectUpdate obj vs) = ObjectUpdate <$> (g obj >>= g') <*> mapM (sndM (g' <=< g)) vs
113+ g' (ObjectUpdater obj vs) = ObjectUpdater <$> (maybeM g obj >>= maybeM g') <*> mapM (sndM $ maybeM (g' <=< g)) vs
114+ g' (Abs name v) = Abs name <$> (g v >>= g')
115+ g' (App v1 v2) = App <$> (g v1 >>= g') <*> (g v2 >>= g')
116+ g' (IfThenElse v1 v2 v3) = IfThenElse <$> (g v1 >>= g') <*> (g v2 >>= g') <*> (g v3 >>= g')
117+ g' (Case vs alts) = Case <$> mapM (g' <=< g) vs <*> mapM handleCaseAlternative alts
118+ g' (TypedValue check v ty) = TypedValue check <$> (g v >>= g') <*> pure ty
119+ g' (Let ds v) = Let <$> mapM (f' <=< f) ds <*> (g v >>= g')
120+ g' (Do es) = Do <$> mapM handleDoNotationElement es
121+ g' (PositionedValue pos com v) = PositionedValue pos com <$> (g v >>= g')
122+ g' other = g other
123+
124+ h' (ConstructorBinder ctor bs) = ConstructorBinder ctor <$> mapM (h' <=< h) bs
125+ h' (ObjectBinder bs) = ObjectBinder <$> mapM (sndM (h' <=< h)) bs
126+ h' (ArrayBinder bs) = ArrayBinder <$> mapM (h' <=< h) bs
127+ h' (NamedBinder name b) = NamedBinder name <$> (h b >>= h')
128+ h' (PositionedBinder pos com b) = PositionedBinder pos com <$> (h b >>= h')
129+ h' other = h other
130+
131+ handleCaseAlternative (CaseAlternative bs val) = CaseAlternative <$> mapM (h' <=< h) bs
132+ <*> eitherM (mapM (pairM (g' <=< g) (g' <=< g))) (g' <=< g) val
133+
134+ handleDoNotationElement (DoNotationValue v) = DoNotationValue <$> (g' <=< g) v
135+ handleDoNotationElement (DoNotationBind b v) = DoNotationBind <$> (h' <=< h) b <*> (g' <=< g) v
136+ handleDoNotationElement (DoNotationLet ds) = DoNotationLet <$> mapM (f' <=< f) ds
137+ handleDoNotationElement (PositionedDoNotationElement pos com e) = PositionedDoNotationElement pos com <$> handleDoNotationElement e
138+
139+everywhereOnValuesM :: (Functor m, Applicative m, Monad m) =>
140+ (Declaration -> m Declaration) ->
141+ (Expr -> m Expr) ->
142+ (Binder -> m Binder) ->
143+ (Declaration -> m Declaration, Expr -> m Expr, Binder -> m Binder)
144+everywhereOnValuesM f g h = (f', g', h')
145+ where
146+ f' (DataBindingGroupDeclaration ds) = (DataBindingGroupDeclaration <$> mapM f' ds) >>= f
147+ f' (ValueDeclaration name nameKind bs val) = (ValueDeclaration name nameKind <$> mapM h' bs <*> eitherM (mapM (pairM g' g')) g' val) >>= f
148+ f' (BindingGroupDeclaration ds) = (BindingGroupDeclaration <$> mapM (\(name, nameKind, val) -> (,,) name nameKind <$> g' val) ds) >>= f
149+ f' (TypeClassDeclaration name args implies ds) = (TypeClassDeclaration name args implies <$> mapM f' ds) >>= f
150+ f' (TypeInstanceDeclaration name cs className args ds) = (TypeInstanceDeclaration name cs className args <$> mapM f' ds) >>= f
151+ f' (PositionedDeclaration pos com d) = (PositionedDeclaration pos com <$> f' d) >>= f
152+ f' other = f other
153+
154+ g' (UnaryMinus v) = (UnaryMinus <$> g' v) >>= g
155+ g' (BinaryNoParens op v1 v2) = (BinaryNoParens <$> g' op <*> g' v1 <*> g' v2) >>= g
156+ g' (Parens v) = (Parens <$> g' v) >>= g
157+ g' (OperatorSection op (Left v)) = (OperatorSection <$> g' op <*> (Left <$> g' v)) >>= g
158+ g' (OperatorSection op (Right v)) = (OperatorSection <$> g' op <*> (Right <$> g' v)) >>= g
159+ g' (ArrayLiteral vs) = (ArrayLiteral <$> mapM g' vs) >>= g
160+ g' (ObjectLiteral vs) = (ObjectLiteral <$> mapM (sndM g') vs) >>= g
161+ g' (ObjectConstructor vs) = (ObjectConstructor <$> mapM (sndM $ maybeM g') vs) >>= g
162+ g' (TypeClassDictionaryConstructorApp name v) = (TypeClassDictionaryConstructorApp name <$> g' v) >>= g
163+ g' (Accessor prop v) = (Accessor prop <$> g' v) >>= g
164+ g' (ObjectUpdate obj vs) = (ObjectUpdate <$> g' obj <*> mapM (sndM g') vs) >>= g
165+ g' (ObjectUpdater obj vs) = (ObjectUpdater <$> maybeM g' obj <*> mapM (sndM $ maybeM g') vs) >>= g
166+ g' (Abs name v) = (Abs name <$> g' v) >>= g
167+ g' (App v1 v2) = (App <$> g' v1 <*> g' v2) >>= g
168+ g' (IfThenElse v1 v2 v3) = (IfThenElse <$> g' v1 <*> g' v2 <*> g' v3) >>= g
169+ g' (Case vs alts) = (Case <$> mapM g' vs <*> mapM handleCaseAlternative alts) >>= g
170+ g' (TypedValue check v ty) = (TypedValue check <$> g' v <*> pure ty) >>= g
171+ g' (Let ds v) = (Let <$> mapM f' ds <*> g' v) >>= g
172+ g' (Do es) = (Do <$> mapM handleDoNotationElement es) >>= g
173+ g' (PositionedValue pos com v) = (PositionedValue pos com <$> g' v) >>= g
174+ g' other = g other
175+
176+ h' (ConstructorBinder ctor bs) = (ConstructorBinder ctor <$> mapM h' bs) >>= h
177+ h' (ObjectBinder bs) = (ObjectBinder <$> mapM (sndM h') bs) >>= h
178+ h' (ArrayBinder bs) = (ArrayBinder <$> mapM h' bs) >>= h
179+ h' (NamedBinder name b) = (NamedBinder name <$> h' b) >>= h
180+ h' (PositionedBinder pos com b) = (PositionedBinder pos com <$> h' b) >>= h
181+ h' other = h other
182+
183+ handleCaseAlternative (CaseAlternative bs val) = CaseAlternative <$> mapM h' bs
184+ <*> eitherM (mapM (pairM g' g')) g' val
185+
186+ handleDoNotationElement (DoNotationValue v) = DoNotationValue <$> g' v
187+ handleDoNotationElement (DoNotationBind b v) = DoNotationBind <$> h' b <*> g' v
188+ handleDoNotationElement (DoNotationLet ds) = DoNotationLet <$> mapM f' ds
189+ handleDoNotationElement (PositionedDoNotationElement pos com e) = PositionedDoNotationElement pos com <$> handleDoNotationElement e
190+
191+everythingOnValues :: (r -> r -> r) ->
192+ (Declaration -> r) ->
193+ (Expr -> r) ->
194+ (Binder -> r) ->
195+ (CaseAlternative -> r) ->
196+ (DoNotationElement -> r) ->
197+ (Declaration -> r, Expr -> r, Binder -> r, CaseAlternative -> r, DoNotationElement -> r)
198+everythingOnValues (<>) f g h i j = (f', g', h', i', j')
199+ where
200+ f' d@(DataBindingGroupDeclaration ds) = foldl (<>) (f d) (map f' ds)
201+ f' d@(ValueDeclaration _ _ bs (Right val)) = foldl (<>) (f d) (map h' bs) <> g' val
202+ f' d@(ValueDeclaration _ _ bs (Left gs)) = foldl (<>) (f d) (map h' bs ++ concatMap (\(grd, val) -> [g' grd, g' val]) gs)
203+ f' d@(BindingGroupDeclaration ds) = foldl (<>) (f d) (map (\(_, _, val) -> g' val) ds)
204+ f' d@(TypeClassDeclaration _ _ _ ds) = foldl (<>) (f d) (map f' ds)
205+ f' d@(TypeInstanceDeclaration _ _ _ _ ds) = foldl (<>) (f d) (map f' ds)
206+ f' d@(PositionedDeclaration _ _ d1) = f d <> f' d1
207+ f' d = f d
208+
209+ g' v@(UnaryMinus v1) = g v <> g' v1
210+ g' v@(BinaryNoParens op v1 v2) = g v <> g op <> g' v1 <> g' v2
211+ g' v@(Parens v1) = g v <> g' v1
212+ g' v@(OperatorSection op (Left v1)) = g v <> g op <> g' v1
213+ g' v@(OperatorSection op (Right v1)) = g v <> g op <> g' v1
214+ g' v@(ArrayLiteral vs) = foldl (<>) (g v) (map g' vs)
215+ g' v@(ObjectLiteral vs) = foldl (<>) (g v) (map (g' . snd) vs)
216+ g' v@(ObjectConstructor vs) = foldl (<>) (g v) (map g' (mapMaybe snd vs))
217+ g' v@(TypeClassDictionaryConstructorApp _ v1) = g v <> g' v1
218+ g' v@(Accessor _ v1) = g v <> g' v1
219+ g' v@(ObjectUpdate obj vs) = foldl (<>) (g v <> g' obj) (map (g' . snd) vs)
220+ g' v@(ObjectUpdater obj vs) = foldl (<>) (maybe (g v) (\x -> g v <> g' x) obj) (map g' (mapMaybe snd vs))
221+ g' v@(Abs _ v1) = g v <> g' v1
222+ g' v@(App v1 v2) = g v <> g' v1 <> g' v2
223+ g' v@(IfThenElse v1 v2 v3) = g v <> g' v1 <> g' v2 <> g' v3
224+ g' v@(Case vs alts) = foldl (<>) (foldl (<>) (g v) (map g' vs)) (map i' alts)
225+ g' v@(TypedValue _ v1 _) = g v <> g' v1
226+ g' v@(Let ds v1) = foldl (<>) (g v) (map f' ds) <> g' v1
227+ g' v@(Do es) = foldl (<>) (g v) (map j' es)
228+ g' v@(PositionedValue _ _ v1) = g v <> g' v1
229+ g' v = g v
230+
231+ h' b@(ConstructorBinder _ bs) = foldl (<>) (h b) (map h' bs)
232+ h' b@(ObjectBinder bs) = foldl (<>) (h b) (map (h' . snd) bs)
233+ h' b@(ArrayBinder bs) = foldl (<>) (h b) (map h' bs)
234+ h' b@(NamedBinder _ b1) = h b <> h' b1
235+ h' b@(PositionedBinder _ _ b1) = h b <> h' b1
236+ h' b = h b
237+
238+ i' ca@(CaseAlternative bs (Right val)) = foldl (<>) (i ca) (map h' bs) <> g' val
239+ i' ca@(CaseAlternative bs (Left gs)) = foldl (<>) (i ca) (map h' bs ++ concatMap (\(grd, val) -> [g' grd, g' val]) gs)
240+
241+ j' e@(DoNotationValue v) = j e <> g' v
242+ j' e@(DoNotationBind b v) = j e <> h' b <> g' v
243+ j' e@(DoNotationLet ds) = foldl (<>) (j e) (map f' ds)
244+ j' e@(PositionedDoNotationElement _ _ e1) = j e <> j' e1
245+
246+everythingWithContextOnValues ::
247+ s ->
248+ r ->
249+ (r -> r -> r) ->
250+ (s -> Declaration -> (s, r)) ->
251+ (s -> Expr -> (s, r)) ->
252+ (s -> Binder -> (s, r)) ->
253+ (s -> CaseAlternative -> (s, r)) ->
254+ (s -> DoNotationElement -> (s, r)) ->
255+ ( Declaration -> r
256+ , Expr -> r
257+ , Binder -> r
258+ , CaseAlternative -> r
259+ , DoNotationElement -> r)
260+everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j'' s0)
261+ where
262+ f'' s d = let (s', r) = f s d in r <> f' s' d
263+
264+ f' s (DataBindingGroupDeclaration ds) = foldl (<>) r0 (map (f'' s) ds)
265+ f' s (ValueDeclaration _ _ bs (Right val)) = foldl (<>) r0 (map (h'' s) bs) <> g'' s val
266+ f' s (ValueDeclaration _ _ bs (Left gs)) = foldl (<>) r0 (map (h'' s) bs ++ concatMap (\(grd, val) -> [g'' s grd, g'' s val]) gs)
267+ f' s (BindingGroupDeclaration ds) = foldl (<>) r0 (map (\(_, _, val) -> g'' s val) ds)
268+ f' s (TypeClassDeclaration _ _ _ ds) = foldl (<>) r0 (map (f'' s) ds)
269+ f' s (TypeInstanceDeclaration _ _ _ _ ds) = foldl (<>) r0 (map (f'' s) ds)
270+ f' s (PositionedDeclaration _ _ d1) = f'' s d1
271+ f' _ _ = r0
272+
273+ g'' s v = let (s', r) = g s v in r <> g' s' v
274+
275+ g' s (UnaryMinus v1) = g'' s v1
276+ g' s (BinaryNoParens op v1 v2) = g'' s op <> g'' s v1 <> g'' s v2
277+ g' s (Parens v1) = g'' s v1
278+ g' s (OperatorSection op (Left v)) = g'' s op <> g'' s v
279+ g' s (OperatorSection op (Right v)) = g'' s op <> g'' s v
280+ g' s (ArrayLiteral vs) = foldl (<>) r0 (map (g'' s) vs)
281+ g' s (ObjectLiteral vs) = foldl (<>) r0 (map (g'' s . snd) vs)
282+ g' s (ObjectConstructor vs) = foldl (<>) r0 (map (g'' s) (mapMaybe snd vs))
283+ g' s (TypeClassDictionaryConstructorApp _ v1) = g'' s v1
284+ g' s (Accessor _ v1) = g'' s v1
285+ g' s (ObjectUpdate obj vs) = foldl (<>) (g'' s obj) (map (g'' s . snd) vs)
286+ g' s (ObjectUpdater obj vs) = foldl (<>) (maybe r0 (g'' s) obj) (map (g'' s) (mapMaybe snd vs))
287+ g' s (Abs _ v1) = g'' s v1
288+ g' s (App v1 v2) = g'' s v1 <> g'' s v2
289+ g' s (IfThenElse v1 v2 v3) = g'' s v1 <> g'' s v2 <> g'' s v3
290+ g' s (Case vs alts) = foldl (<>) (foldl (<>) r0 (map (g'' s) vs)) (map (i'' s) alts)
291+ g' s (TypedValue _ v1 _) = g'' s v1
292+ g' s (Let ds v1) = foldl (<>) r0 (map (f'' s) ds) <> g'' s v1
293+ g' s (Do es) = foldl (<>) r0 (map (j'' s) es)
294+ g' s (PositionedValue _ _ v1) = g'' s v1
295+ g' _ _ = r0
296+
297+ h'' s b = let (s', r) = h s b in r <> h' s' b
298+
299+ h' s (ConstructorBinder _ bs) = foldl (<>) r0 (map (h'' s) bs)
300+ h' s (ObjectBinder bs) = foldl (<>) r0 (map (h'' s . snd) bs)
301+ h' s (ArrayBinder bs) = foldl (<>) r0 (map (h'' s) bs)
302+ h' s (NamedBinder _ b1) = h'' s b1
303+ h' s (PositionedBinder _ _ b1) = h'' s b1
304+ h' _ _ = r0
305+
306+ i'' s ca = let (s', r) = i s ca in r <> i' s' ca
307+
308+ i' s (CaseAlternative bs (Right val)) = foldl (<>) r0 (map (h'' s) bs) <> g'' s val
309+ i' s (CaseAlternative bs (Left gs)) = foldl (<>) r0 (map (h'' s) bs ++ concatMap (\(grd, val) -> [g'' s grd, g'' s val]) gs)
310+
311+ j'' s e = let (s', r) = j s e in r <> j' s' e
312+
313+ j' s (DoNotationValue v) = g'' s v
314+ j' s (DoNotationBind b v) = h'' s b <> g'' s v
315+ j' s (DoNotationLet ds) = foldl (<>) r0 (map (f'' s) ds)
316+ j' s (PositionedDoNotationElement _ _ e1) = j'' s e1
317+
318+everywhereWithContextOnValuesM :: (Functor m, Applicative m, Monad m) =>
319+ s ->
320+ (s -> Declaration -> m (s, Declaration)) ->
321+ (s -> Expr -> m (s, Expr)) ->
322+ (s -> Binder -> m (s, Binder)) ->
323+ (s -> CaseAlternative -> m (s, CaseAlternative)) ->
324+ (s -> DoNotationElement -> m (s, DoNotationElement)) ->
325+ ( Declaration -> m Declaration
326+ , Expr -> m Expr
327+ , Binder -> m Binder
328+ , CaseAlternative -> m CaseAlternative
329+ , DoNotationElement -> m DoNotationElement)
330+everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j'' s0)
331+ where
332+ f'' s = uncurry f' <=< f s
333+
334+ f' s (DataBindingGroupDeclaration ds) = DataBindingGroupDeclaration <$> mapM (f'' s) ds
335+ f' s (ValueDeclaration name nameKind bs val) = ValueDeclaration name nameKind <$> mapM (h'' s) bs <*> eitherM (mapM (pairM (g'' s) (g'' s))) (g'' s) val
336+ f' s (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> mapM (thirdM (g'' s)) ds
337+ f' s (TypeClassDeclaration name args implies ds) = TypeClassDeclaration name args implies <$> mapM (f'' s) ds
338+ f' s (TypeInstanceDeclaration name cs className args ds) = TypeInstanceDeclaration name cs className args <$> mapM (f'' s) ds
339+ f' s (PositionedDeclaration pos com d1) = PositionedDeclaration pos com <$> f'' s d1
340+ f' _ other = return other
341+
342+ g'' s = uncurry g' <=< g s
343+
344+ g' s (UnaryMinus v) = UnaryMinus <$> g'' s v
345+ g' s (BinaryNoParens op v1 v2) = BinaryNoParens <$> g'' s op <*> g'' s v1 <*> g'' s v2
346+ g' s (Parens v) = Parens <$> g'' s v
347+ g' s (OperatorSection op (Left v)) = OperatorSection <$> g'' s op <*> (Left <$> g'' s v)
348+ g' s (OperatorSection op (Right v)) = OperatorSection <$> g'' s op <*> (Right <$> g'' s v)
349+ g' s (ArrayLiteral vs) = ArrayLiteral <$> mapM (g'' s) vs
350+ g' s (ObjectLiteral vs) = ObjectLiteral <$> mapM (sndM (g'' s)) vs
351+ g' s (ObjectConstructor vs) = ObjectConstructor <$> mapM (sndM $ maybeM (g'' s)) vs
352+ g' s (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> g'' s v
353+ g' s (Accessor prop v) = Accessor prop <$> g'' s v
354+ g' s (ObjectUpdate obj vs) = ObjectUpdate <$> g'' s obj <*> mapM (sndM (g'' s)) vs
355+ g' s (ObjectUpdater obj vs) = ObjectUpdater <$> maybeM (g'' s) obj <*> mapM (sndM $ maybeM (g'' s)) vs
356+ g' s (Abs name v) = Abs name <$> g'' s v
357+ g' s (App v1 v2) = App <$> g'' s v1 <*> g'' s v2
358+ g' s (IfThenElse v1 v2 v3) = IfThenElse <$> g'' s v1 <*> g'' s v2 <*> g'' s v3
359+ g' s (Case vs alts) = Case <$> mapM (g'' s) vs <*> mapM (i'' s) alts
360+ g' s (TypedValue check v ty) = TypedValue check <$> g'' s v <*> pure ty
361+ g' s (Let ds v) = Let <$> mapM (f'' s) ds <*> g'' s v
362+ g' s (Do es) = Do <$> mapM (j'' s) es
363+ g' s (PositionedValue pos com v) = PositionedValue pos com <$> g'' s v
364+ g' _ other = return other
365+
366+ h'' s = uncurry h' <=< h s
367+
368+ h' s (ConstructorBinder ctor bs) = ConstructorBinder ctor <$> mapM (h'' s) bs
369+ h' s (ObjectBinder bs) = ObjectBinder <$> mapM (sndM (h'' s)) bs
370+ h' s (ArrayBinder bs) = ArrayBinder <$> mapM (h'' s) bs
371+ h' s (NamedBinder name b) = NamedBinder name <$> h'' s b
372+ h' s (PositionedBinder pos com b) = PositionedBinder pos com <$> h'' s b
373+ h' _ other = return other
374+
375+ i'' s = uncurry i' <=< i s
376+
377+ i' s (CaseAlternative bs val) = CaseAlternative <$> mapM (h'' s) bs <*> eitherM (mapM (pairM (g'' s) (g'' s))) (g'' s) val
378+
379+ j'' s = uncurry j' <=< j s
380+
381+ j' s (DoNotationValue v) = DoNotationValue <$> g'' s v
382+ j' s (DoNotationBind b v) = DoNotationBind <$> h'' s b <*> g'' s v
383+ j' s (DoNotationLet ds) = DoNotationLet <$> mapM (f'' s) ds
384+ j' s (PositionedDoNotationElement pos com e1) = PositionedDoNotationElement pos com <$> j'' s e1
385+
386+accumTypes :: (Monoid r) => (Type -> r) -> (Declaration -> r, Expr -> r, Binder -> r, CaseAlternative -> r, DoNotationElement -> r)
387+accumTypes f = everythingOnValues mappend forDecls forValues (const mempty) (const mempty) (const mempty)
388+ where
389+ forDecls (DataDeclaration _ _ _ dctors) = mconcat (concatMap (map f . snd) dctors)
390+ forDecls (ExternDeclaration _ ty) = f ty
391+ forDecls (ExternInstanceDeclaration _ cs _ tys) = mconcat (concatMap (map f . snd) cs) `mappend` mconcat (map f tys)
392+ forDecls (TypeClassDeclaration _ _ implies _) = mconcat (concatMap (map f . snd) implies)
393+ forDecls (TypeInstanceDeclaration _ cs _ tys _) = mconcat (concatMap (map f . snd) cs) `mappend` mconcat (map f tys)
394+ forDecls (TypeSynonymDeclaration _ _ ty) = f ty
395+ forDecls (TypeDeclaration _ ty) = f ty
396+ forDecls _ = mempty
397+
398+ forValues (TypeClassDictionary _ (_, cs) _) = mconcat (map f cs)
399+ forValues (SuperClassDictionary _ tys) = mconcat (map f tys)
400+ forValues (TypedValue _ _ ty) = f ty
401+ forValues _ = mempty
src/Language/PureScript/CodeGen.hsnew file+25
@@ -0,0 +1,25 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.CodeGen
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- A collection of modules related to code generation:
13+--
14+-- [@Language.PureScript.CodeGen.JS@] Code generator for Javascript
15+--
16+-- [@Language.PureScript.CodeGen.Externs@] Code generator for extern (foreign import) files
17+--
18+-- [@Language.PureScript.CodeGen.Optimize@] Optimization passes for generated Javascript
19+--
20+-----------------------------------------------------------------------------
21+
22+module Language.PureScript.CodeGen (module C) where
23+
24+import Language.PureScript.CodeGen.JS as C
25+import Language.PureScript.CodeGen.Externs as C
src/Language/PureScript/CodeGen/Externs.hsnew file+121
@@ -0,0 +1,121 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.CodeGen.Externs
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- This module generates code for \"externs\" files, i.e. files containing only foreign import declarations.
13+--
14+-----------------------------------------------------------------------------
15+
16+module Language.PureScript.CodeGen.Externs (
17+ moduleToPs
18+) where
19+
20+import Data.List (intercalate, find)
21+import Data.Maybe (fromMaybe, mapMaybe)
22+import qualified Data.Map as M
23+
24+import Control.Monad.Writer
25+
26+import Language.PureScript.AST
27+import Language.PureScript.Comments
28+import Language.PureScript.Environment
29+import Language.PureScript.Kinds
30+import Language.PureScript.Names
31+import Language.PureScript.Pretty
32+import Language.PureScript.TypeClassDictionaries
33+import Language.PureScript.Types
34+
35+-- |
36+-- Generate foreign imports for all declarations in a module
37+--
38+moduleToPs :: Module -> Environment -> String
39+moduleToPs (Module _ _ _ Nothing) _ = error "Module exports were not elaborated in moduleToPs"
40+moduleToPs (Module _ moduleName ds (Just exts)) env = intercalate "\n" . execWriter $ do
41+ tell [ "module " ++ runModuleName moduleName ++ " where"]
42+ mapM_ declToPs ds
43+ mapM_ exportToPs exts
44+ where
45+
46+ declToPs :: Declaration -> Writer [String] ()
47+ declToPs (ImportDeclaration mn _ _) = tell ["import " ++ show mn ++ " ()"]
48+ declToPs (FixityDeclaration (Fixity assoc prec) op) =
49+ case find exportsOp exts of
50+ Nothing -> return ()
51+ Just _ -> tell [ unwords [ show assoc, show prec, op ] ]
52+ where
53+ exportsOp :: DeclarationRef -> Bool
54+ exportsOp (PositionedDeclarationRef _ _ r) = exportsOp r
55+ exportsOp (ValueRef ident') = ident' == Op op
56+ exportsOp _ = False
57+ declToPs (PositionedDeclaration _ com d) = mapM_ commentToPs com >> declToPs d
58+ declToPs _ = return ()
59+
60+ commentToPs :: Comment -> Writer [String] ()
61+ commentToPs (LineComment s) = tell ["-- " ++ s]
62+ commentToPs (BlockComment s) = tell ["{- " ++ s ++ " -}"]
63+
64+ exportToPs :: DeclarationRef -> Writer [String] ()
65+ exportToPs (PositionedDeclarationRef _ _ r) = exportToPs r
66+ exportToPs (TypeRef pn dctors) =
67+ case Qualified (Just moduleName) pn `M.lookup` types env of
68+ Nothing -> error $ show pn ++ " has no kind in exportToPs"
69+ Just (kind, ExternData) ->
70+ tell ["foreign import data " ++ show pn ++ " :: " ++ prettyPrintKind kind]
71+ Just (_, DataType args tys) -> do
72+ let dctors' = fromMaybe (map fst tys) dctors
73+ printDctor dctor = case dctor `lookup` tys of
74+ Nothing -> Nothing
75+ Just tyArgs -> Just $ show dctor ++ " " ++ unwords (map prettyPrintTypeAtom tyArgs)
76+ let dtype = if length dctors' == 1 && isNewtypeConstructor env (Qualified (Just moduleName) $ head dctors')
77+ then "newtype"
78+ else "data"
79+ typeName = prettyPrintType $ foldl TypeApp (TypeConstructor (Qualified Nothing pn)) (map toTypeVar args)
80+ tell [dtype ++ " " ++ typeName ++ (if null dctors' then "" else " = " ++ intercalate " | " (mapMaybe printDctor dctors'))]
81+ Just (_, TypeSynonym) ->
82+ case Qualified (Just moduleName) pn `M.lookup` typeSynonyms env of
83+ Nothing -> error $ show pn ++ " has no type synonym info in exportToPs"
84+ Just (args, synTy) ->
85+ let
86+ typeName = prettyPrintType $ foldl TypeApp (TypeConstructor (Qualified Nothing pn)) (map toTypeVar args)
87+ in tell ["type " ++ typeName ++ " = " ++ prettyPrintType synTy]
88+ _ -> error "Invalid input in exportToPs"
89+
90+ exportToPs (ValueRef ident) =
91+ case (moduleName, ident) `M.lookup` names env of
92+ Nothing -> error $ show ident ++ " has no type in exportToPs"
93+ Just (ty, nk, _) | nk == Public || nk == External ->
94+ tell ["foreign import " ++ show ident ++ " :: " ++ prettyPrintType ty]
95+ _ -> return ()
96+ exportToPs (TypeClassRef className) =
97+ case Qualified (Just moduleName) className `M.lookup` typeClasses env of
98+ Nothing -> error $ show className ++ " has no type class definition in exportToPs"
99+ Just (args, members, implies) -> do
100+ let impliesString = if null implies
101+ then ""
102+ else "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map prettyPrintTypeAtom tys')) implies) ++ ") <= "
103+ typeName = prettyPrintType $ foldl TypeApp (TypeConstructor (Qualified Nothing className)) (map toTypeVar args)
104+ tell ["class " ++ impliesString ++ typeName ++ " where"]
105+ forM_ (filter (isValueExported . fst) members) $ \(member ,ty) ->
106+ tell [ " " ++ show member ++ " :: " ++ prettyPrintType ty ]
107+
108+ exportToPs (TypeInstanceRef ident) = do
109+ let TypeClassDictionaryInScope { tcdClassName = className, tcdInstanceTypes = tys, tcdDependencies = deps} =
110+ fromMaybe (error $ "Type class instance has no dictionary in exportToPs") . find (\tcd -> tcdName tcd == Qualified (Just moduleName) ident && tcdType tcd == TCDRegular) . maybe [] (M.elems >=> M.elems) . M.lookup (Just moduleName) $ typeClassDictionaries env
111+ let constraintsText = case fromMaybe [] deps of
112+ [] -> ""
113+ cs -> "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map prettyPrintTypeAtom tys')) cs) ++ ") => "
114+ tell ["foreign import instance " ++ show ident ++ " :: " ++ constraintsText ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys)]
115+
116+ toTypeVar :: (String, Maybe Kind) -> Type
117+ toTypeVar (s, Nothing) = TypeVar s
118+ toTypeVar (s, Just k) = KindedType (TypeVar s) k
119+
120+ isValueExported :: Ident -> Bool
121+ isValueExported ident = ValueRef ident `elem` exts
src/Language/PureScript/CodeGen/JS.hsnew file+371
@@ -0,0 +1,371 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.CodeGen.JS
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- This module generates code in the simplified Javascript intermediate representation from Purescript code
13+--
14+-----------------------------------------------------------------------------
15+
16+{-# LANGUAGE GADTs #-}
17+{-# LANGUAGE ViewPatterns #-}
18+{-# LANGUAGE FlexibleContexts #-}
19+{-# LANGUAGE ScopedTypeVariables #-}
20+
21+module Language.PureScript.CodeGen.JS
22+ ( module AST
23+ , module Common
24+ , moduleToJs
25+ , mainCall
26+ ) where
27+
28+import Data.List ((\\), delete, intersect)
29+import qualified Data.Traversable as T (traverse)
30+
31+import Control.Applicative
32+import Control.Arrow ((&&&))
33+import Control.Monad (replicateM, forM)
34+import Control.Monad.Reader (MonadReader, asks)
35+import Control.Monad.Supply.Class
36+
37+import Language.PureScript.AST.SourcePos
38+import Language.PureScript.CodeGen.JS.AST as AST
39+import Language.PureScript.CodeGen.JS.Common as Common
40+import Language.PureScript.CoreFn
41+import Language.PureScript.Names
42+import Language.PureScript.CodeGen.JS.Optimizer
43+import Language.PureScript.Options
44+import Language.PureScript.Traversals (sndM)
45+import qualified Language.PureScript.Constants as C
46+
47+import System.FilePath.Posix ((</>))
48+
49+-- |
50+-- Generate code in the simplified Javascript intermediate representation for all declarations in a
51+-- module.
52+--
53+moduleToJs :: forall m mode. (Applicative m, Monad m, MonadReader (Options mode) m, MonadSupply m)
54+ => Module Ann -> Maybe JS -> m [JS]
55+moduleToJs (Module coms mn imps exps foreigns decls) foreign = do
56+ additional <- asks optionsAdditional
57+ jsImports <- T.traverse importToJs . delete (ModuleName [ProperName C.prim]) . (\\ [mn]) $ imps
58+ jsDecls <- mapM bindToJs decls
59+ optimized <- T.traverse (T.traverse optimize) jsDecls
60+ let isModuleEmpty = null exps
61+ comments <- not <$> asks optionsNoComments
62+ let strict = JSStringLiteral "use strict"
63+ let header = if comments && not (null coms) then JSComment coms strict else strict
64+ let foreign' = [JSVariableIntroduction "$foreign" foreign | not $ null foreigns || foreign == Nothing]
65+ let moduleBody = header : foreign' ++ jsImports ++ concat optimized
66+ let foreignExps = exps `intersect` (fst `map` foreigns)
67+ let standardExps = exps \\ foreignExps
68+ let exps' = JSObjectLiteral $ map (runIdent &&& JSVar . identToJs) standardExps
69+ ++ map (runIdent &&& foreignIdent) foreignExps
70+ return $ case additional of
71+ MakeOptions _ -> moduleBody ++ [JSAssignment (JSAccessor "exports" (JSVar "module")) exps']
72+ CompileOptions ns _ _ | not isModuleEmpty ->
73+ [ JSVariableIntroduction ns
74+ (Just (JSBinary Or (JSVar ns) (JSObjectLiteral [])) )
75+ , JSAssignment (JSAccessor (moduleNameToJs mn) (JSVar ns))
76+ (JSApp (JSFunction Nothing [] (JSBlock (moduleBody ++ [JSReturn exps']))) [])
77+ ]
78+ _ -> []
79+
80+ where
81+
82+ -- |
83+ -- Generates Javascript code for a module import.
84+ --
85+ importToJs :: ModuleName -> m JS
86+ importToJs mn' = do
87+ additional <- asks optionsAdditional
88+ let moduleBody = case additional of
89+ MakeOptions path -> JSApp (JSVar "require") [JSStringLiteral (maybe id (</>) path $ runModuleName mn')]
90+ CompileOptions ns _ _ -> JSAccessor (moduleNameToJs mn') (JSVar ns)
91+ return $ JSVariableIntroduction (moduleNameToJs mn') (Just moduleBody)
92+
93+ -- |
94+ -- Generate code in the simplified Javascript intermediate representation for a declaration
95+ --
96+ bindToJs :: Bind Ann -> m [JS]
97+ bindToJs (NonRec ident val) = return <$> nonRecToJS ident val
98+ bindToJs (Rec vals) = forM vals (uncurry nonRecToJS)
99+
100+ -- |
101+ -- Generate code in the simplified Javascript intermediate representation for a single non-recursive
102+ -- declaration.
103+ --
104+ -- The main purpose of this function is to handle code generation for comments.
105+ --
106+ nonRecToJS :: Ident -> Expr Ann -> m JS
107+ nonRecToJS i e@(extractAnn -> (_, com, _, _)) | not (null com) = do
108+ withoutComment <- asks optionsNoComments
109+ if withoutComment
110+ then nonRecToJS i (modifyAnn removeComments e)
111+ else JSComment com <$> nonRecToJS i (modifyAnn removeComments e)
112+ nonRecToJS ident val = do
113+ js <- valueToJs val
114+ return $ JSVariableIntroduction (identToJs ident) (Just js)
115+
116+ -- |
117+ -- Generate code in the simplified Javascript intermediate representation for a variable based on a
118+ -- PureScript identifier.
119+ --
120+ var :: Ident -> JS
121+ var = JSVar . identToJs
122+
123+ -- |
124+ -- Generate code in the simplified Javascript intermediate representation for an accessor based on
125+ -- a PureScript identifier. If the name is not valid in Javascript (symbol based, reserved name) an
126+ -- indexer is returned.
127+ --
128+ accessor :: Ident -> JS -> JS
129+ accessor (Ident prop) = accessorString prop
130+ accessor (Op op) = JSIndexer (JSStringLiteral op)
131+
132+ accessorString :: String -> JS -> JS
133+ accessorString prop | identNeedsEscaping prop = JSIndexer (JSStringLiteral prop)
134+ | otherwise = JSAccessor prop
135+
136+ -- |
137+ -- Generate code in the simplified Javascript intermediate representation for a value or expression.
138+ --
139+ valueToJs :: Expr Ann -> m JS
140+ valueToJs (Literal _ l) =
141+ literalToValueJS l
142+ valueToJs (Var (_, _, _, Just (IsConstructor _ [])) name) =
143+ return $ JSAccessor "value" $ qualifiedToJS id name
144+ valueToJs (Var (_, _, _, Just (IsConstructor _ _)) name) =
145+ return $ JSAccessor "create" $ qualifiedToJS id name
146+ valueToJs (Accessor _ prop val) =
147+ accessorString prop <$> valueToJs val
148+ valueToJs (ObjectUpdate _ o ps) = do
149+ obj <- valueToJs o
150+ sts <- mapM (sndM valueToJs) ps
151+ extendObj obj sts
152+ valueToJs e@(Abs (_, _, _, Just IsTypeClassConstructor) _ _) =
153+ let args = unAbs e
154+ in return $ JSFunction Nothing (map identToJs args) (JSBlock $ map assign args)
155+ where
156+ unAbs :: Expr Ann -> [Ident]
157+ unAbs (Abs _ arg val) = arg : unAbs val
158+ unAbs _ = []
159+ assign :: Ident -> JS
160+ assign name = JSAssignment (accessorString (runIdent name) (JSVar "this"))
161+ (var name)
162+ valueToJs (Abs _ arg val) = do
163+ ret <- valueToJs val
164+ return $ JSFunction Nothing [identToJs arg] (JSBlock [JSReturn ret])
165+ valueToJs e@App{} = do
166+ let (f, args) = unApp e []
167+ args' <- mapM valueToJs args
168+ case f of
169+ Var (_, _, _, Just IsNewtype) _ -> return (head args')
170+ Var (_, _, _, Just (IsConstructor _ fields)) name | length args == length fields ->
171+ return $ JSUnary JSNew $ JSApp (qualifiedToJS id name) args'
172+ Var (_, _, _, Just IsTypeClassConstructor) name ->
173+ return $ JSUnary JSNew $ JSApp (qualifiedToJS id name) args'
174+ _ -> flip (foldl (\fn a -> JSApp fn [a])) args' <$> valueToJs f
175+ where
176+ unApp :: Expr Ann -> [Expr Ann] -> (Expr Ann, [Expr Ann])
177+ unApp (App _ val arg) args = unApp val (arg : args)
178+ unApp other args = (other, args)
179+ valueToJs (Var (_, _, _, Just IsForeign) qi@(Qualified (Just mn') ident)) =
180+ return $ if mn' == mn
181+ then foreignIdent ident
182+ else varToJs qi
183+ valueToJs (Var (_, _, _, Just IsForeign) ident) =
184+ error $ "Encountered an unqualified reference to a foreign ident " ++ show ident
185+ valueToJs (Var _ ident) =
186+ return $ varToJs ident
187+ valueToJs (Case (maybeSpan, _, _, _) values binders) = do
188+ vals <- mapM valueToJs values
189+ bindersToJs maybeSpan binders vals
190+ valueToJs (Let _ ds val) = do
191+ ds' <- concat <$> mapM bindToJs ds
192+ ret <- valueToJs val
193+ return $ JSApp (JSFunction Nothing [] (JSBlock (ds' ++ [JSReturn ret]))) []
194+ valueToJs (Constructor (_, _, _, Just IsNewtype) _ (ProperName ctor) _) =
195+ return $ JSVariableIntroduction ctor (Just $
196+ JSObjectLiteral [("create",
197+ JSFunction Nothing ["value"]
198+ (JSBlock [JSReturn $ JSVar "value"]))])
199+ valueToJs (Constructor _ _ (ProperName ctor) []) =
200+ return $ iife ctor [ JSFunction (Just ctor) [] (JSBlock [])
201+ , JSAssignment (JSAccessor "value" (JSVar ctor))
202+ (JSUnary JSNew $ JSApp (JSVar ctor) []) ]
203+ valueToJs (Constructor _ _ (ProperName ctor) fields) =
204+ let constructor =
205+ let body = [ JSAssignment (JSAccessor (identToJs f) (JSVar "this")) (var f) | f <- fields ]
206+ in JSFunction (Just ctor) (identToJs `map` fields) (JSBlock body)
207+ createFn =
208+ let body = JSUnary JSNew $ JSApp (JSVar ctor) (var `map` fields)
209+ in foldr (\f inner -> JSFunction Nothing [identToJs f] (JSBlock [JSReturn inner])) body fields
210+ in return $ iife ctor [ constructor
211+ , JSAssignment (JSAccessor "create" (JSVar ctor)) createFn
212+ ]
213+
214+ iife :: String -> [JS] -> JS
215+ iife v exprs = JSApp (JSFunction Nothing [] (JSBlock $ exprs ++ [JSReturn $ JSVar v])) []
216+
217+ literalToValueJS :: Literal (Expr Ann) -> m JS
218+ literalToValueJS (NumericLiteral n) = return $ JSNumericLiteral n
219+ literalToValueJS (StringLiteral s) = return $ JSStringLiteral s
220+ literalToValueJS (CharLiteral c) = return $ JSStringLiteral [c]
221+ literalToValueJS (BooleanLiteral b) = return $ JSBooleanLiteral b
222+ literalToValueJS (ArrayLiteral xs) = JSArrayLiteral <$> mapM valueToJs xs
223+ literalToValueJS (ObjectLiteral ps) = JSObjectLiteral <$> mapM (sndM valueToJs) ps
224+
225+ -- |
226+ -- Shallow copy an object.
227+ --
228+ extendObj :: JS -> [(String, JS)] -> m JS
229+ extendObj obj sts = do
230+ newObj <- freshName
231+ key <- freshName
232+ let
233+ jsKey = JSVar key
234+ jsNewObj = JSVar newObj
235+ block = JSBlock (objAssign:copy:extend ++ [JSReturn jsNewObj])
236+ objAssign = JSVariableIntroduction newObj (Just $ JSObjectLiteral [])
237+ copy = JSForIn key obj $ JSBlock [JSIfElse cond assign Nothing]
238+ cond = JSApp (JSAccessor "hasOwnProperty" obj) [jsKey]
239+ assign = JSBlock [JSAssignment (JSIndexer jsKey jsNewObj) (JSIndexer jsKey obj)]
240+ stToAssign (s, js) = JSAssignment (JSAccessor s jsNewObj) js
241+ extend = map stToAssign sts
242+ return $ JSApp (JSFunction Nothing [] block) []
243+
244+ -- |
245+ -- Generate code in the simplified Javascript intermediate representation for a reference to a
246+ -- variable.
247+ --
248+ varToJs :: Qualified Ident -> JS
249+ varToJs (Qualified Nothing ident) = var ident
250+ varToJs qual = qualifiedToJS id qual
251+
252+ -- |
253+ -- Generate code in the simplified Javascript intermediate representation for a reference to a
254+ -- variable that may have a qualified name.
255+ --
256+ qualifiedToJS :: (a -> Ident) -> Qualified a -> JS
257+ qualifiedToJS f (Qualified (Just (ModuleName [ProperName mn'])) a) | mn' == C.prim = JSVar . runIdent $ f a
258+ qualifiedToJS f (Qualified (Just mn') a) | mn /= mn' = accessor (f a) (JSVar (moduleNameToJs mn'))
259+ qualifiedToJS f (Qualified _ a) = JSVar $ identToJs (f a)
260+
261+ foreignIdent :: Ident -> JS
262+ foreignIdent ident = accessorString (runIdent ident) (JSVar "$foreign")
263+
264+ -- |
265+ -- Generate code in the simplified Javascript intermediate representation for pattern match binders
266+ -- and guards.
267+ --
268+ bindersToJs :: Maybe SourceSpan -> [CaseAlternative Ann] -> [JS] -> m JS
269+ bindersToJs maybeSpan binders vals = do
270+ valNames <- replicateM (length vals) freshName
271+ let assignments = zipWith JSVariableIntroduction valNames (map Just vals)
272+ jss <- forM binders $ \(CaseAlternative bs result) -> do
273+ ret <- guardsToJs result
274+ go valNames ret bs
275+ return $ JSApp (JSFunction Nothing [] (JSBlock (assignments ++ concat jss ++ [JSThrow $ failedPatternError valNames])))
276+ []
277+ where
278+ go :: [String] -> [JS] -> [Binder Ann] -> m [JS]
279+ go _ done [] = return done
280+ go (v:vs) done' (b:bs) = do
281+ done'' <- go vs done' bs
282+ binderToJs v done'' b
283+ go _ _ _ = error "Invalid arguments to bindersToJs"
284+
285+ failedPatternError :: [String] -> JS
286+ failedPatternError names = JSUnary JSNew $ JSApp (JSVar "Error") [JSBinary Add (JSStringLiteral errorMessage) (JSArrayLiteral $ zipWith valueError names vals)]
287+
288+ errorMessage :: String
289+ errorMessage = "Failed pattern match" ++ maybe "" ((" at " ++) . displaySourceSpan) maybeSpan ++ ": "
290+
291+ valueError :: String -> JS -> JS
292+ valueError _ l@(JSNumericLiteral _) = l
293+ valueError _ l@(JSStringLiteral _) = l
294+ valueError _ l@(JSBooleanLiteral _) = l
295+ valueError s _ = JSAccessor "name" . JSAccessor "constructor" $ JSVar s
296+
297+ guardsToJs :: Either [(Guard Ann, Expr Ann)] (Expr Ann) -> m [JS]
298+ guardsToJs (Left gs) = forM gs $ \(cond, val) -> do
299+ cond' <- valueToJs cond
300+ done <- valueToJs val
301+ return $ JSIfElse cond' (JSBlock [JSReturn done]) Nothing
302+ guardsToJs (Right v) = return . JSReturn <$> valueToJs v
303+
304+ -- |
305+ -- Generate code in the simplified Javascript intermediate representation for a pattern match
306+ -- binder.
307+ --
308+ binderToJs :: String -> [JS] -> Binder Ann -> m [JS]
309+ binderToJs _ done (NullBinder{}) = return done
310+ binderToJs varName done (LiteralBinder _ l) =
311+ literalToBinderJS varName done l
312+ binderToJs varName done (VarBinder _ ident) =
313+ return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : done)
314+ binderToJs varName done (ConstructorBinder (_, _, _, Just IsNewtype) _ _ [b]) =
315+ binderToJs varName done b
316+ binderToJs varName done (ConstructorBinder (_, _, _, Just (IsConstructor ctorType fields)) _ ctor bs) = do
317+ js <- go (zip fields bs) done
318+ return $ case ctorType of
319+ ProductType -> js
320+ SumType ->
321+ [JSIfElse (JSInstanceOf (JSVar varName) (qualifiedToJS (Ident . runProperName) ctor))
322+ (JSBlock js)
323+ Nothing]
324+ where
325+ go :: [(Ident, Binder Ann)] -> [JS] -> m [JS]
326+ go [] done' = return done'
327+ go ((field, binder) : remain) done' = do
328+ argVar <- freshName
329+ done'' <- go remain done'
330+ js <- binderToJs argVar done'' binder
331+ return (JSVariableIntroduction argVar (Just (JSAccessor (identToJs field) (JSVar varName))) : js)
332+ binderToJs _ _ b@(ConstructorBinder{}) =
333+ error $ "Invalid ConstructorBinder in binderToJs: " ++ show b
334+ binderToJs varName done (NamedBinder _ ident binder) = do
335+ js <- binderToJs varName done binder
336+ return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : js)
337+
338+ literalToBinderJS :: String -> [JS] -> Literal (Binder Ann) -> m [JS]
339+ literalToBinderJS varName done (NumericLiteral num) =
340+ return [JSIfElse (JSBinary EqualTo (JSVar varName) (JSNumericLiteral num)) (JSBlock done) Nothing]
341+ literalToBinderJS varName done (CharLiteral c) =
342+ return [JSIfElse (JSBinary EqualTo (JSVar varName) (JSStringLiteral [c])) (JSBlock done) Nothing]
343+ literalToBinderJS varName done (StringLiteral str) =
344+ return [JSIfElse (JSBinary EqualTo (JSVar varName) (JSStringLiteral str)) (JSBlock done) Nothing]
345+ literalToBinderJS varName done (BooleanLiteral True) =
346+ return [JSIfElse (JSVar varName) (JSBlock done) Nothing]
347+ literalToBinderJS varName done (BooleanLiteral False) =
348+ return [JSIfElse (JSUnary Not (JSVar varName)) (JSBlock done) Nothing]
349+ literalToBinderJS varName done (ObjectLiteral bs) = go done bs
350+ where
351+ go :: [JS] -> [(String, Binder Ann)] -> m [JS]
352+ go done' [] = return done'
353+ go done' ((prop, binder):bs') = do
354+ propVar <- freshName
355+ done'' <- go done' bs'
356+ js <- binderToJs propVar done'' binder
357+ return (JSVariableIntroduction propVar (Just (accessorString prop (JSVar varName))) : js)
358+ literalToBinderJS varName done (ArrayLiteral bs) = do
359+ js <- go done 0 bs
360+ return [JSIfElse (JSBinary EqualTo (JSAccessor "length" (JSVar varName)) (JSNumericLiteral (Left (fromIntegral $ length bs)))) (JSBlock js) Nothing]
361+ where
362+ go :: [JS] -> Integer -> [Binder Ann] -> m [JS]
363+ go done' _ [] = return done'
364+ go done' index (binder:bs') = do
365+ elVar <- freshName
366+ done'' <- go done' (index + 1) bs'
367+ js <- binderToJs elVar done'' binder
368+ return (JSVariableIntroduction elVar (Just (JSIndexer (JSNumericLiteral (Left index)) (JSVar varName))) : js)
369+
370+mainCall :: ModuleName -> String -> JS
371+mainCall mmi ns = JSApp (JSAccessor C.main (JSAccessor (moduleNameToJs mmi) (JSVar ns))) []
src/Language/PureScript/CodeGen/JS/AST.hsnew file+343
@@ -0,0 +1,343 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.CodeGen.JS.AST
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- Data types for the intermediate simplified-Javascript AST
13+--
14+-----------------------------------------------------------------------------
15+
16+{-# LANGUAGE DeriveDataTypeable #-}
17+
18+module Language.PureScript.CodeGen.JS.AST where
19+
20+import Control.Applicative (Applicative, (<$>), (<*>))
21+import Control.Monad.Identity
22+import Data.Data
23+import Data.Traversable (traverse)
24+
25+import Language.PureScript.Comments
26+
27+-- |
28+-- Built-in unary operators
29+--
30+data UnaryOperator
31+ -- |
32+ -- Numeric negation
33+ --
34+ = Negate
35+ -- |
36+ -- Boolean negation
37+ --
38+ | Not
39+ -- |
40+ -- Bitwise negation
41+ --
42+ | BitwiseNot
43+ -- |
44+ -- Numeric unary \'plus\'
45+ --
46+ | Positive
47+ -- |
48+ -- Constructor
49+ --
50+ | JSNew deriving (Show, Eq, Data, Typeable)
51+
52+-- |
53+-- Built-in binary operators
54+--
55+data BinaryOperator
56+ -- |
57+ -- Numeric addition
58+ --
59+ = Add
60+ -- |
61+ -- Numeric subtraction
62+ --
63+ | Subtract
64+ -- |
65+ -- Numeric multiplication
66+ --
67+ | Multiply
68+ -- |
69+ -- Numeric division
70+ --
71+ | Divide
72+ -- |
73+ -- Remainder
74+ --
75+ | Modulus
76+ -- |
77+ -- Generic equality test
78+ --
79+ | EqualTo
80+ -- |
81+ -- Generic inequality test
82+ --
83+ | NotEqualTo
84+ -- |
85+ -- Numeric less-than
86+ --
87+ | LessThan
88+ -- |
89+ -- Numeric less-than-or-equal
90+ --
91+ | LessThanOrEqualTo
92+ -- |
93+ -- Numeric greater-than
94+ --
95+ | GreaterThan
96+ -- |
97+ -- Numeric greater-than-or-equal
98+ --
99+ | GreaterThanOrEqualTo
100+ -- |
101+ -- Boolean and
102+ --
103+ | And
104+ -- |
105+ -- Boolean or
106+ --
107+ | Or
108+ -- |
109+ -- Bitwise and
110+ --
111+ | BitwiseAnd
112+ -- |
113+ -- Bitwise or
114+ --
115+ | BitwiseOr
116+ -- |
117+ -- Bitwise xor
118+ --
119+ | BitwiseXor
120+ -- |
121+ -- Bitwise left shift
122+ --
123+ | ShiftLeft
124+ -- |
125+ -- Bitwise right shift
126+ --
127+ | ShiftRight
128+ -- |
129+ -- Bitwise right shift with zero-fill
130+ --
131+ | ZeroFillShiftRight deriving (Show, Eq, Data, Typeable)
132+
133+-- |
134+-- Data type for simplified Javascript expressions
135+--
136+data JS
137+ -- |
138+ -- A numeric literal
139+ --
140+ = JSNumericLiteral (Either Integer Double)
141+ -- |
142+ -- A string literal
143+ --
144+ | JSStringLiteral String
145+ -- |
146+ -- A boolean literal
147+ --
148+ | JSBooleanLiteral Bool
149+ -- |
150+ -- A unary operator application
151+ --
152+ | JSUnary UnaryOperator JS
153+ -- |
154+ -- A binary operator application
155+ --
156+ | JSBinary BinaryOperator JS JS
157+ -- |
158+ -- An array literal
159+ --
160+ | JSArrayLiteral [JS]
161+ -- |
162+ -- An array indexer expression
163+ --
164+ | JSIndexer JS JS
165+ -- |
166+ -- An object literal
167+ --
168+ | JSObjectLiteral [(String, JS)]
169+ -- |
170+ -- An object property accessor expression
171+ --
172+ | JSAccessor String JS
173+ -- |
174+ -- A function introduction (optional name, arguments, body)
175+ --
176+ | JSFunction (Maybe String) [String] JS
177+ -- |
178+ -- Function application
179+ --
180+ | JSApp JS [JS]
181+ -- |
182+ -- Variable
183+ --
184+ | JSVar String
185+ -- |
186+ -- Conditional expression
187+ --
188+ | JSConditional JS JS JS
189+ -- |
190+ -- A block of expressions in braces
191+ --
192+ | JSBlock [JS]
193+ -- |
194+ -- A variable introduction and optional initialization
195+ --
196+ | JSVariableIntroduction String (Maybe JS)
197+ -- |
198+ -- A variable assignment
199+ --
200+ | JSAssignment JS JS
201+ -- |
202+ -- While loop
203+ --
204+ | JSWhile JS JS
205+ -- |
206+ -- For loop
207+ --
208+ | JSFor String JS JS JS
209+ -- |
210+ -- ForIn loop
211+ --
212+ | JSForIn String JS JS
213+ -- |
214+ -- If-then-else statement
215+ --
216+ | JSIfElse JS JS (Maybe JS)
217+ -- |
218+ -- Return statement
219+ --
220+ | JSReturn JS
221+ -- |
222+ -- Throw statement
223+ --
224+ | JSThrow JS
225+ -- |
226+ -- Type-Of operator
227+ --
228+ | JSTypeOf JS
229+ -- |
230+ -- InstanceOf test
231+ --
232+ | JSInstanceOf JS JS
233+ -- |
234+ -- Labelled statement
235+ --
236+ | JSLabel String JS
237+ -- |
238+ -- Break statement
239+ --
240+ | JSBreak String
241+ -- |
242+ -- Continue statement
243+ --
244+ | JSContinue String
245+ -- |
246+ -- Raw Javascript (generated when parsing fails for an inline foreign import declaration)
247+ --
248+ | JSRaw String
249+ -- |
250+ -- Commented Javascript
251+ --
252+ | JSComment [Comment] JS deriving (Show, Eq, Data, Typeable)
253+
254+--
255+-- Traversals
256+--
257+
258+everywhereOnJS :: (JS -> JS) -> JS -> JS
259+everywhereOnJS f = go
260+ where
261+ go :: JS -> JS
262+ go (JSUnary op j) = f (JSUnary op (go j))
263+ go (JSBinary op j1 j2) = f (JSBinary op (go j1) (go j2))
264+ go (JSArrayLiteral js) = f (JSArrayLiteral (map go js))
265+ go (JSIndexer j1 j2) = f (JSIndexer (go j1) (go j2))
266+ go (JSObjectLiteral js) = f (JSObjectLiteral (map (fmap go) js))
267+ go (JSAccessor prop j) = f (JSAccessor prop (go j))
268+ go (JSFunction name args j) = f (JSFunction name args (go j))
269+ go (JSApp j js) = f (JSApp (go j) (map go js))
270+ go (JSConditional j1 j2 j3) = f (JSConditional (go j1) (go j2) (go j3))
271+ go (JSBlock js) = f (JSBlock (map go js))
272+ go (JSVariableIntroduction name j) = f (JSVariableIntroduction name (fmap go j))
273+ go (JSAssignment j1 j2) = f (JSAssignment (go j1) (go j2))
274+ go (JSWhile j1 j2) = f (JSWhile (go j1) (go j2))
275+ go (JSFor name j1 j2 j3) = f (JSFor name (go j1) (go j2) (go j3))
276+ go (JSForIn name j1 j2) = f (JSForIn name (go j1) (go j2))
277+ go (JSIfElse j1 j2 j3) = f (JSIfElse (go j1) (go j2) (fmap go j3))
278+ go (JSReturn js) = f (JSReturn (go js))
279+ go (JSThrow js) = f (JSThrow (go js))
280+ go (JSTypeOf js) = f (JSTypeOf (go js))
281+ go (JSLabel name js) = f (JSLabel name (go js))
282+ go (JSInstanceOf j1 j2) = f (JSInstanceOf (go j1) (go j2))
283+ go (JSComment com j) = f (JSComment com (go j))
284+ go other = f other
285+
286+everywhereOnJSTopDown :: (JS -> JS) -> JS -> JS
287+everywhereOnJSTopDown f = runIdentity . everywhereOnJSTopDownM (Identity . f)
288+
289+everywhereOnJSTopDownM :: (Applicative m, Monad m) => (JS -> m JS) -> JS -> m JS
290+everywhereOnJSTopDownM f = f >=> go
291+ where
292+ f' = f >=> go
293+ go (JSUnary op j) = JSUnary op <$> f' j
294+ go (JSBinary op j1 j2) = JSBinary op <$> f' j1 <*> f' j2
295+ go (JSArrayLiteral js) = JSArrayLiteral <$> traverse f' js
296+ go (JSIndexer j1 j2) = JSIndexer <$> f' j1 <*> f' j2
297+ go (JSObjectLiteral js) = JSObjectLiteral <$> traverse (traverse f') js
298+ go (JSAccessor prop j) = JSAccessor prop <$> f' j
299+ go (JSFunction name args j) = JSFunction name args <$> f' j
300+ go (JSApp j js) = JSApp <$> f' j <*> traverse f' js
301+ go (JSConditional j1 j2 j3) = JSConditional <$> f' j1 <*> f' j2 <*> f' j3
302+ go (JSBlock js) = JSBlock <$> traverse f' js
303+ go (JSVariableIntroduction name j) = JSVariableIntroduction name <$> traverse f' j
304+ go (JSAssignment j1 j2) = JSAssignment <$> f' j1 <*> f' j2
305+ go (JSWhile j1 j2) = JSWhile <$> f' j1 <*> f' j2
306+ go (JSFor name j1 j2 j3) = JSFor name <$> f' j1 <*> f' j2 <*> f' j3
307+ go (JSForIn name j1 j2) = JSForIn name <$> f' j1 <*> f' j2
308+ go (JSIfElse j1 j2 j3) = JSIfElse <$> f' j1 <*> f' j2 <*> traverse f' j3
309+ go (JSReturn j) = JSReturn <$> f' j
310+ go (JSThrow j) = JSThrow <$> f' j
311+ go (JSTypeOf j) = JSTypeOf <$> f' j
312+ go (JSLabel name j) = JSLabel name <$> f' j
313+ go (JSInstanceOf j1 j2) = JSInstanceOf <$> f' j1 <*> f' j2
314+ go (JSComment com j) = JSComment com <$> f' j
315+ go other = f other
316+
317+everythingOnJS :: (r -> r -> r) -> (JS -> r) -> JS -> r
318+everythingOnJS (<>) f = go
319+ where
320+ go j@(JSUnary _ j1) = f j <> go j1
321+ go j@(JSBinary _ j1 j2) = f j <> go j1 <> go j2
322+ go j@(JSArrayLiteral js) = foldl (<>) (f j) (map go js)
323+ go j@(JSIndexer j1 j2) = f j <> go j1 <> go j2
324+ go j@(JSObjectLiteral js) = foldl (<>) (f j) (map (go . snd) js)
325+ go j@(JSAccessor _ j1) = f j <> go j1
326+ go j@(JSFunction _ _ j1) = f j <> go j1
327+ go j@(JSApp j1 js) = foldl (<>) (f j <> go j1) (map go js)
328+ go j@(JSConditional j1 j2 j3) = f j <> go j1 <> go j2 <> go j3
329+ go j@(JSBlock js) = foldl (<>) (f j) (map go js)
330+ go j@(JSVariableIntroduction _ (Just j1)) = f j <> go j1
331+ go j@(JSAssignment j1 j2) = f j <> go j1 <> go j2
332+ go j@(JSWhile j1 j2) = f j <> go j1 <> go j2
333+ go j@(JSFor _ j1 j2 j3) = f j <> go j1 <> go j2 <> go j3
334+ go j@(JSForIn _ j1 j2) = f j <> go j1 <> go j2
335+ go j@(JSIfElse j1 j2 Nothing) = f j <> go j1 <> go j2
336+ go j@(JSIfElse j1 j2 (Just j3)) = f j <> go j1 <> go j2 <> go j3
337+ go j@(JSReturn j1) = f j <> go j1
338+ go j@(JSThrow j1) = f j <> go j1
339+ go j@(JSTypeOf j1) = f j <> go j1
340+ go j@(JSLabel _ j1) = f j <> go j1
341+ go j@(JSInstanceOf j1 j2) = f j <> go j1 <> go j2
342+ go j@(JSComment _ j1) = f j <> go j1
343+ go other = f other
src/Language/PureScript/CodeGen/JS/Common.hsnew file+181
@@ -0,0 +1,181 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.CodeGen.Common
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- Common code generation utility functions
13+--
14+-----------------------------------------------------------------------------
15+
16+module Language.PureScript.CodeGen.JS.Common where
17+
18+import Data.Char
19+import Data.List (intercalate)
20+
21+import Language.PureScript.Names
22+
23+-- |
24+-- Convert an Ident into a valid Javascript identifier:
25+--
26+-- * Alphanumeric characters are kept unmodified.
27+--
28+-- * Reserved javascript identifiers are prefixed with '$$'.
29+--
30+-- * Symbols are prefixed with '$' followed by a symbol name or their ordinal value.
31+--
32+identToJs :: Ident -> String
33+identToJs (Ident name) | nameIsJsReserved name = "$$" ++ name
34+identToJs (Ident name) = concatMap identCharToString name
35+identToJs (Op op) = concatMap identCharToString op
36+
37+-- |
38+-- Test if a string is a valid JS identifier without escaping.
39+--
40+identNeedsEscaping :: String -> Bool
41+identNeedsEscaping s = s /= identToJs (Ident s)
42+
43+-- |
44+-- Attempts to find a human-readable name for a symbol, if none has been specified returns the
45+-- ordinal value.
46+--
47+identCharToString :: Char -> String
48+identCharToString c | isAlphaNum c = [c]
49+identCharToString '_' = "_"
50+identCharToString '.' = "$dot"
51+identCharToString '$' = "$dollar"
52+identCharToString '~' = "$tilde"
53+identCharToString '=' = "$eq"
54+identCharToString '<' = "$less"
55+identCharToString '>' = "$greater"
56+identCharToString '!' = "$bang"
57+identCharToString '#' = "$hash"
58+identCharToString '%' = "$percent"
59+identCharToString '^' = "$up"
60+identCharToString '&' = "$amp"
61+identCharToString '|' = "$bar"
62+identCharToString '*' = "$times"
63+identCharToString '/' = "$div"
64+identCharToString '+' = "$plus"
65+identCharToString '-' = "$minus"
66+identCharToString ':' = "$colon"
67+identCharToString '\\' = "$bslash"
68+identCharToString '?' = "$qmark"
69+identCharToString '@' = "$at"
70+identCharToString '\'' = "$prime"
71+identCharToString c = '$' : show (ord c)
72+
73+-- |
74+-- Checks whether an identifier name is reserved in Javascript.
75+--
76+nameIsJsReserved :: String -> Bool
77+nameIsJsReserved name =
78+ name `elem` [ "abstract"
79+ , "arguments"
80+ , "boolean"
81+ , "break"
82+ , "byte"
83+ , "case"
84+ , "catch"
85+ , "char"
86+ , "class"
87+ , "const"
88+ , "continue"
89+ , "debugger"
90+ , "default"
91+ , "delete"
92+ , "do"
93+ , "double"
94+ , "else"
95+ , "enum"
96+ , "eval"
97+ , "export"
98+ , "extends"
99+ , "final"
100+ , "finally"
101+ , "float"
102+ , "for"
103+ , "function"
104+ , "goto"
105+ , "if"
106+ , "implements"
107+ , "import"
108+ , "in"
109+ , "instanceof"
110+ , "int"
111+ , "interface"
112+ , "let"
113+ , "long"
114+ , "native"
115+ , "new"
116+ , "null"
117+ , "package"
118+ , "private"
119+ , "protected"
120+ , "public"
121+ , "return"
122+ , "short"
123+ , "static"
124+ , "super"
125+ , "switch"
126+ , "synchronized"
127+ , "this"
128+ , "throw"
129+ , "throws"
130+ , "transient"
131+ , "try"
132+ , "typeof"
133+ , "var"
134+ , "void"
135+ , "volatile"
136+ , "while"
137+ , "with"
138+ , "yield" ] || properNameIsJsReserved name
139+
140+moduleNameToJs :: ModuleName -> String
141+moduleNameToJs (ModuleName pns) =
142+ let name = intercalate "_" (runProperName `map` pns)
143+ in if properNameIsJsReserved name then "$$" ++ name else name
144+
145+-- |
146+-- Checks whether a proper name is reserved in Javascript.
147+--
148+properNameIsJsReserved :: String -> Bool
149+properNameIsJsReserved name =
150+ name `elem` [ "Infinity"
151+ , "NaN"
152+ , "Object"
153+ , "Function"
154+ , "Boolean"
155+ , "Error"
156+ , "EvalError"
157+ , "InternalError"
158+ , "RangeError"
159+ , "ReferenceError"
160+ , "SyntaxError"
161+ , "TypeError"
162+ , "URIError"
163+ , "Number"
164+ , "Math"
165+ , "Date"
166+ , "String"
167+ , "RegExp"
168+ , "Array"
169+ , "Int8Array"
170+ , "Uint8Array"
171+ , "Uint8ClampedArray"
172+ , "Int16Array"
173+ , "Uint16Array"
174+ , "Int32Array"
175+ , "Uint32Array"
176+ , "Float32Array"
177+ , "Float64Array"
178+ , "ArrayBuffer"
179+ , "DataView"
180+ , "JSON"
181+ , "Intl" ]
src/Language/PureScript/CodeGen/JS/Optimizer.hsnew file+89
@@ -0,0 +1,89 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.CodeGen.JS.Optimizer
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- This module optimizes code in the simplified-Javascript intermediate representation.
13+--
14+-- The following optimizations are supported:
15+--
16+-- * Collapsing nested blocks
17+--
18+-- * Tail call elimination
19+--
20+-- * Inlining of (>>=) and ret for the Eff monad
21+--
22+-- * Removal of unnecessary thunks
23+--
24+-- * Eta conversion
25+--
26+-- * Inlining variables
27+--
28+-- * Inline Prelude.($), Prelude.(#), Prelude.(++), Prelude.(!!)
29+--
30+-- * Inlining primitive Javascript operators
31+--
32+-----------------------------------------------------------------------------
33+
34+{-# LANGUAGE FlexibleContexts #-}
35+
36+module Language.PureScript.CodeGen.JS.Optimizer (
37+ optimize
38+) where
39+
40+import Control.Applicative (Applicative)
41+import Control.Monad.Reader (MonadReader, ask, asks)
42+import Control.Monad.Supply.Class (MonadSupply)
43+
44+import Language.PureScript.CodeGen.JS.AST
45+import Language.PureScript.Options
46+import qualified Language.PureScript.Constants as C
47+
48+import Language.PureScript.CodeGen.JS.Optimizer.Common
49+import Language.PureScript.CodeGen.JS.Optimizer.TCO
50+import Language.PureScript.CodeGen.JS.Optimizer.MagicDo
51+import Language.PureScript.CodeGen.JS.Optimizer.Inliner
52+import Language.PureScript.CodeGen.JS.Optimizer.Unused
53+import Language.PureScript.CodeGen.JS.Optimizer.Blocks
54+
55+-- |
56+-- Apply a series of optimizer passes to simplified Javascript code
57+--
58+optimize :: (Monad m, MonadReader (Options mode) m, Applicative m, MonadSupply m) => JS -> m JS
59+optimize js = do
60+ noOpt <- asks optionsNoOptimizations
61+ if noOpt then return js else optimize' js
62+
63+optimize' :: (Monad m, MonadReader (Options mode) m, Applicative m, MonadSupply m) => JS -> m JS
64+optimize' js = do
65+ opts <- ask
66+ untilFixedPoint (inlineArrComposition . applyAll
67+ [ collapseNestedBlocks
68+ , collapseNestedIfs
69+ , tco opts
70+ , magicDo opts
71+ , removeCodeAfterReturnStatements
72+ , removeUnusedArg
73+ , removeUndefinedApp
74+ , unThunk
75+ , etaConvert
76+ , evaluateIifes
77+ , inlineVariables
78+ , inlineValues
79+ , inlineOperator (C.prelude, (C.$)) $ \f x -> JSApp f [x]
80+ , inlineOperator (C.prelude, (C.#)) $ \x f -> JSApp f [x]
81+ , inlineOperator (C.dataArrayUnsafe, C.unsafeIndex) $ flip JSIndexer
82+ , inlineCommonOperators ]) js
83+
84+untilFixedPoint :: (Monad m, Eq a) => (a -> m a) -> a -> m a
85+untilFixedPoint f = go
86+ where
87+ go a = do
88+ a' <- f a
89+ if a' == a then return a' else go a'
src/Language/PureScript/CodeGen/JS/Optimizer/Blocks.hsnew file+42
@@ -0,0 +1,42 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.CodeGen.JS.Optimizer.Blocks
4+-- Copyright : (c) Phil Freeman 2013-14
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- Optimizer steps for simplifying Javascript blocks
13+--
14+-----------------------------------------------------------------------------
15+
16+module Language.PureScript.CodeGen.JS.Optimizer.Blocks
17+ ( collapseNestedBlocks
18+ , collapseNestedIfs
19+ ) where
20+
21+import Language.PureScript.CodeGen.JS.AST
22+
23+-- |
24+-- Collapse blocks which appear nested directly below another block
25+--
26+collapseNestedBlocks :: JS -> JS
27+collapseNestedBlocks = everywhereOnJS collapse
28+ where
29+ collapse :: JS -> JS
30+ collapse (JSBlock sts) = JSBlock (concatMap go sts)
31+ collapse js = js
32+ go :: JS -> [JS]
33+ go (JSBlock sts) = sts
34+ go s = [s]
35+
36+collapseNestedIfs :: JS -> JS
37+collapseNestedIfs = everywhereOnJS collapse
38+ where
39+ collapse :: JS -> JS
40+ collapse (JSIfElse cond1 (JSBlock [JSIfElse cond2 body Nothing]) Nothing) =
41+ JSIfElse (JSBinary And cond1 cond2) body Nothing
42+ collapse js = js
src/Language/PureScript/CodeGen/JS/Optimizer/Common.hsnew file+77
@@ -0,0 +1,77 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.CodeGen.JS.Optimizer.Common
4+-- Copyright : (c) Phil Freeman 2013-14
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- Common functions used by the various optimizer phases
13+--
14+-----------------------------------------------------------------------------
15+
16+module Language.PureScript.CodeGen.JS.Optimizer.Common where
17+
18+import Data.Maybe (fromMaybe)
19+
20+import Language.PureScript.CodeGen.JS.AST
21+
22+applyAll :: [a -> a] -> a -> a
23+applyAll = foldl1 (.)
24+
25+replaceIdent :: String -> JS -> JS -> JS
26+replaceIdent var1 js = everywhereOnJS replace
27+ where
28+ replace (JSVar var2) | var1 == var2 = js
29+ replace other = other
30+
31+replaceIdents :: [(String, JS)] -> JS -> JS
32+replaceIdents vars = everywhereOnJS replace
33+ where
34+ replace v@(JSVar var) = fromMaybe v $ lookup var vars
35+ replace other = other
36+
37+isReassigned :: String -> JS -> Bool
38+isReassigned var1 = everythingOnJS (||) check
39+ where
40+ check :: JS -> Bool
41+ check (JSFunction _ args _) | var1 `elem` args = True
42+ check (JSVariableIntroduction arg _) | var1 == arg = True
43+ check (JSAssignment (JSVar arg) _) | var1 == arg = True
44+ check (JSFor arg _ _ _) | var1 == arg = True
45+ check (JSForIn arg _ _) | var1 == arg = True
46+ check _ = False
47+
48+isRebound :: JS -> JS -> Bool
49+isRebound js d = any (\v -> isReassigned v d || isUpdated v d) (everythingOnJS (++) variablesOf js)
50+ where
51+ variablesOf (JSVar var) = [var]
52+ variablesOf _ = []
53+
54+isUsed :: String -> JS -> Bool
55+isUsed var1 = everythingOnJS (||) check
56+ where
57+ check :: JS -> Bool
58+ check (JSVar var2) | var1 == var2 = True
59+ check (JSAssignment target _) | var1 == targetVariable target = True
60+ check _ = False
61+
62+targetVariable :: JS -> String
63+targetVariable (JSVar var) = var
64+targetVariable (JSAccessor _ tgt) = targetVariable tgt
65+targetVariable (JSIndexer _ tgt) = targetVariable tgt
66+targetVariable _ = error "Invalid argument to targetVariable"
67+
68+isUpdated :: String -> JS -> Bool
69+isUpdated var1 = everythingOnJS (||) check
70+ where
71+ check :: JS -> Bool
72+ check (JSAssignment target _) | var1 == targetVariable target = True
73+ check _ = False
74+
75+removeFromBlock :: ([JS] -> [JS]) -> JS -> JS
76+removeFromBlock go (JSBlock sts) = JSBlock (go sts)
77+removeFromBlock _ js = js
src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hsnew file+317
@@ -0,0 +1,317 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.CodeGen.JS.Optimizer.Inliner
4+-- Copyright : (c) Phil Freeman 2013-14
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- This module provides basic inlining capabilities
13+--
14+-----------------------------------------------------------------------------
15+
16+module Language.PureScript.CodeGen.JS.Optimizer.Inliner (
17+ inlineVariables,
18+ inlineValues,
19+ inlineOperator,
20+ inlineCommonOperators,
21+ inlineArrComposition,
22+ etaConvert,
23+ unThunk,
24+ evaluateIifes
25+) where
26+
27+import Control.Applicative (Applicative)
28+import Control.Monad.Supply.Class (MonadSupply, freshName)
29+import Data.Maybe (fromMaybe)
30+
31+import Language.PureScript.CodeGen.JS.AST
32+import Language.PureScript.CodeGen.JS.Common
33+import Language.PureScript.Names
34+import Language.PureScript.CodeGen.JS.Optimizer.Common
35+import qualified Language.PureScript.Constants as C
36+
37+-- TODO: Potential bug:
38+-- Shouldn't just inline this case: { var x = 0; x.toFixed(10); }
39+-- Needs to be: { 0..toFixed(10); }
40+-- Probably needs to be fixed in pretty-printer instead.
41+shouldInline :: JS -> Bool
42+shouldInline (JSVar _) = True
43+shouldInline (JSNumericLiteral _) = True
44+shouldInline (JSStringLiteral _) = True
45+shouldInline (JSBooleanLiteral _) = True
46+shouldInline (JSAccessor _ val) = shouldInline val
47+shouldInline (JSIndexer index val) = shouldInline index && shouldInline val
48+shouldInline _ = False
49+
50+etaConvert :: JS -> JS
51+etaConvert = everywhereOnJS convert
52+ where
53+ convert :: JS -> JS
54+ convert (JSBlock [JSReturn (JSApp (JSFunction Nothing idents block@(JSBlock body)) args)])
55+ | all shouldInline args &&
56+ not (any (`isRebound` block) (map JSVar idents)) &&
57+ not (any (`isRebound` block) args)
58+ = JSBlock (map (replaceIdents (zip idents args)) body)
59+ convert (JSFunction Nothing [] (JSBlock [JSReturn (JSApp fn [])])) = fn
60+ convert js = js
61+
62+unThunk :: JS -> JS
63+unThunk = everywhereOnJS convert
64+ where
65+ convert :: JS -> JS
66+ convert (JSBlock []) = JSBlock []
67+ convert (JSBlock jss) =
68+ case last jss of
69+ JSReturn (JSApp (JSFunction Nothing [] (JSBlock body)) []) -> JSBlock $ init jss ++ body
70+ _ -> JSBlock jss
71+ convert js = js
72+
73+evaluateIifes :: JS -> JS
74+evaluateIifes = everywhereOnJS convert
75+ where
76+ convert :: JS -> JS
77+ convert (JSApp (JSFunction Nothing [] (JSBlock [JSReturn ret])) []) = ret
78+ convert js = js
79+
80+inlineVariables :: JS -> JS
81+inlineVariables = everywhereOnJS $ removeFromBlock go
82+ where
83+ go :: [JS] -> [JS]
84+ go [] = []
85+ go (JSVariableIntroduction var (Just js) : sts)
86+ | shouldInline js && not (any (isReassigned var) sts) && not (any (isRebound js) sts) && not (any (isUpdated var) sts) =
87+ go (map (replaceIdent var js) sts)
88+ go (s:sts) = s : go sts
89+
90+inlineValues :: JS -> JS
91+inlineValues = everywhereOnJS convert
92+ where
93+ convert :: JS -> JS
94+ convert (JSApp fn [dict]) | isDict semiringNumber dict && isFn fnZero fn = JSNumericLiteral (Left 0)
95+ | isDict semiringNumber dict && isFn fnOne fn = JSNumericLiteral (Left 1)
96+ | isDict semiringInt dict && isFn fnZero fn = JSNumericLiteral (Left 0)
97+ | isDict semiringInt dict && isFn fnOne fn = JSNumericLiteral (Left 1)
98+ | isDict boundedBoolean dict && isFn fnBottom fn = JSBooleanLiteral False
99+ | isDict boundedBoolean dict && isFn fnTop fn = JSBooleanLiteral True
100+ convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y])
101+ | isDict semiringInt dict && isFn fnAdd fn = JSBinary BitwiseOr (JSBinary Add x y) (JSNumericLiteral (Left 0))
102+ | isDict semiringInt dict && isFn fnMultiply fn = JSBinary BitwiseOr (JSBinary Multiply x y) (JSNumericLiteral (Left 0))
103+ | isDict moduloSemiringInt dict && isFn fnDivide fn = JSBinary BitwiseOr (JSBinary Divide x y) (JSNumericLiteral (Left 0))
104+ | isDict ringInt dict && isFn fnSubtract fn = JSBinary BitwiseOr (JSBinary Subtract x y) (JSNumericLiteral (Left 0))
105+ convert other = other
106+ fnZero = (C.prelude, C.zero)
107+ fnOne = (C.prelude, C.one)
108+ fnBottom = (C.prelude, C.bottom)
109+ fnTop = (C.prelude, C.top)
110+ fnAdd = (C.prelude, (C.+))
111+ fnDivide = (C.prelude, (C./))
112+ fnMultiply = (C.prelude, (C.*))
113+ fnSubtract = (C.prelude, (C.-))
114+
115+inlineOperator :: (String, String) -> (JS -> JS -> JS) -> JS -> JS
116+inlineOperator (m, op) f = everywhereOnJS convert
117+ where
118+ convert :: JS -> JS
119+ convert (JSApp (JSApp op' [x]) [y]) | isOp op' = f x y
120+ convert other = other
121+ isOp (JSAccessor longForm (JSVar m')) = m == m' && longForm == identToJs (Op op)
122+ isOp (JSIndexer (JSStringLiteral op') (JSVar m')) = m == m' && op == op'
123+ isOp _ = False
124+
125+inlineCommonOperators :: JS -> JS
126+inlineCommonOperators = applyAll $
127+ [ binary semiringNumber (C.+) Add
128+ , binary semiringNumber (C.*) Multiply
129+
130+ , binary ringNumber (C.-) Subtract
131+ , unary ringNumber C.negate Negate
132+ , binary ringInt (C.-) Subtract
133+ , unary ringInt C.negate Negate
134+
135+ , binary moduloSemiringNumber (C./) Divide
136+ , binary moduloSemiringInt C.mod Modulus
137+
138+ , binary eqNumber (C.==) EqualTo
139+ , binary eqNumber (C./=) NotEqualTo
140+ , binary eqInt (C.==) EqualTo
141+ , binary eqInt (C./=) NotEqualTo
142+ , binary eqString (C.==) EqualTo
143+ , binary eqString (C./=) NotEqualTo
144+ , binary eqBoolean (C.==) EqualTo
145+ , binary eqBoolean (C./=) NotEqualTo
146+
147+ , binary ordNumber (C.<) LessThan
148+ , binary ordNumber (C.>) GreaterThan
149+ , binary ordNumber (C.<=) LessThanOrEqualTo
150+ , binary ordNumber (C.>=) GreaterThanOrEqualTo
151+ , binary ordInt (C.<) LessThan
152+ , binary ordInt (C.>) GreaterThan
153+ , binary ordInt (C.<=) LessThanOrEqualTo
154+ , binary ordInt (C.>=) GreaterThanOrEqualTo
155+
156+ , binary semigroupString (C.<>) Add
157+ , binary semigroupString (C.++) Add
158+
159+ , binary latticeBoolean (C.&&) And
160+ , binary latticeBoolean (C.||) Or
161+ , binaryFunction latticeBoolean C.inf And
162+ , binaryFunction latticeBoolean C.sup Or
163+ , unary complementedLatticeBoolean C.not Not
164+
165+ , binary' C.dataIntBits (C..|.) BitwiseOr
166+ , binary' C.dataIntBits (C..&.) BitwiseAnd
167+ , binary' C.dataIntBits (C..^.) BitwiseXor
168+ , binary' C.dataIntBits C.shl ShiftLeft
169+ , binary' C.dataIntBits C.shr ShiftRight
170+ , binary' C.dataIntBits C.zshr ZeroFillShiftRight
171+ , unary' C.dataIntBits C.complement BitwiseNot
172+ ] ++
173+ [ fn | i <- [0..10], fn <- [ mkFn i, runFn i ] ]
174+ where
175+ binary :: (String, String) -> String -> BinaryOperator -> JS -> JS
176+ binary dict opString op = everywhereOnJS convert
177+ where
178+ convert :: JS -> JS
179+ convert (JSApp (JSApp (JSApp fn [dict']) [x]) [y]) | isDict dict dict' && isPreludeFn opString fn = JSBinary op x y
180+ convert other = other
181+ binary' :: String -> String -> BinaryOperator -> JS -> JS
182+ binary' moduleName opString op = everywhereOnJS convert
183+ where
184+ convert :: JS -> JS
185+ convert (JSApp (JSApp fn [x]) [y]) | isFn (moduleName, opString) fn = JSBinary op x y
186+ convert other = other
187+ binaryFunction :: (String, String) -> String -> BinaryOperator -> JS -> JS
188+ binaryFunction dict fnName op = everywhereOnJS convert
189+ where
190+ convert :: JS -> JS
191+ convert (JSApp (JSApp (JSApp fn [dict']) [x]) [y]) | isPreludeFn fnName fn && isDict dict dict' = JSBinary op x y
192+ convert other = other
193+ unary :: (String, String) -> String -> UnaryOperator -> JS -> JS
194+ unary dict fnName op = everywhereOnJS convert
195+ where
196+ convert :: JS -> JS
197+ convert (JSApp (JSApp fn [dict']) [x]) | isPreludeFn fnName fn && isDict dict dict' = JSUnary op x
198+ convert other = other
199+ unary' :: String -> String -> UnaryOperator -> JS -> JS
200+ unary' moduleName fnName op = everywhereOnJS convert
201+ where
202+ convert :: JS -> JS
203+ convert (JSApp fn [x]) | isFn (moduleName, fnName) fn = JSUnary op x
204+ convert other = other
205+ mkFn :: Int -> JS -> JS
206+ mkFn 0 = everywhereOnJS convert
207+ where
208+ convert :: JS -> JS
209+ convert (JSApp mkFnN [JSFunction Nothing [_] (JSBlock js)]) | isNFn C.mkFn 0 mkFnN =
210+ JSFunction Nothing [] (JSBlock js)
211+ convert other = other
212+ mkFn n = everywhereOnJS convert
213+ where
214+ convert :: JS -> JS
215+ convert orig@(JSApp mkFnN [fn]) | isNFn C.mkFn n mkFnN =
216+ case collectArgs n [] fn of
217+ Just (args, js) -> JSFunction Nothing args (JSBlock js)
218+ Nothing -> orig
219+ convert other = other
220+ collectArgs :: Int -> [String] -> JS -> Maybe ([String], [JS])
221+ collectArgs 1 acc (JSFunction Nothing [oneArg] (JSBlock js)) | length acc == n - 1 = Just (reverse (oneArg : acc), js)
222+ collectArgs m acc (JSFunction Nothing [oneArg] (JSBlock [JSReturn ret])) = collectArgs (m - 1) (oneArg : acc) ret
223+ collectArgs _ _ _ = Nothing
224+
225+ isNFn :: String -> Int -> JS -> Bool
226+ isNFn prefix n (JSVar name) = name == (prefix ++ show n)
227+ isNFn prefix n (JSAccessor name (JSVar dataFunction)) | dataFunction == C.dataFunction = name == (prefix ++ show n)
228+ isNFn _ _ _ = False
229+
230+ runFn :: Int -> JS -> JS
231+ runFn n = everywhereOnJS convert
232+ where
233+ convert :: JS -> JS
234+ convert js = fromMaybe js $ go n [] js
235+
236+ go :: Int -> [JS] -> JS -> Maybe JS
237+ go 0 acc (JSApp runFnN [fn]) | isNFn C.runFn n runFnN && length acc == n = Just (JSApp fn acc)
238+ go m acc (JSApp lhs [arg]) = go (m - 1) (arg : acc) lhs
239+ go _ _ _ = Nothing
240+
241+-- (f <<< g $ x) = f (g x)
242+-- (f <<< g) = \x -> f (g x)
243+inlineArrComposition :: (Applicative m, MonadSupply m) => JS -> m JS
244+inlineArrComposition = everywhereOnJSTopDownM convert
245+ where
246+ convert :: (MonadSupply m) => JS -> m JS
247+ convert (JSApp (JSApp (JSApp (JSApp fn [dict']) [x]) [y]) [z]) | isArrCompose dict' fn =
248+ return $ JSApp x [JSApp y [z]]
249+ convert (JSApp (JSApp (JSApp fn [dict']) [x]) [y]) | isArrCompose dict' fn = do
250+ arg <- freshName
251+ return $ JSFunction Nothing [arg] (JSBlock [JSReturn $ JSApp x [JSApp y [JSVar arg]]])
252+ convert other = return other
253+ isArrCompose :: JS -> JS -> Bool
254+ isArrCompose dict' fn = isDict semigroupoidArr dict' && isPreludeFn (C.<<<) fn
255+
256+isDict :: (String, String) -> JS -> Bool
257+isDict (moduleName, dictName) (JSAccessor x (JSVar y)) = x == dictName && y == moduleName
258+isDict _ _ = False
259+
260+isFn :: (String, String) -> JS -> Bool
261+isFn (moduleName, fnName) (JSAccessor x (JSVar y)) = x == fnName && y == moduleName
262+isFn (moduleName, fnName) (JSIndexer (JSStringLiteral x) (JSVar y)) = x == fnName && y == moduleName
263+isFn _ _ = False
264+
265+isPreludeFn :: String -> JS -> Bool
266+isPreludeFn fnName = isFn (C.prelude, fnName)
267+
268+semiringNumber :: (String, String)
269+semiringNumber = (C.prelude, C.semiringNumber)
270+
271+semiringInt :: (String, String)
272+semiringInt = (C.dataInt, C.semiringInt)
273+
274+ringNumber :: (String, String)
275+ringNumber = (C.prelude, C.ringNumber)
276+
277+ringInt :: (String, String)
278+ringInt = (C.dataInt, C.ringInt)
279+
280+moduloSemiringNumber :: (String, String)
281+moduloSemiringNumber = (C.prelude, C.moduloSemiringNumber)
282+
283+moduloSemiringInt :: (String, String)
284+moduloSemiringInt = (C.dataInt, C.moduloSemiringInt)
285+
286+eqNumber :: (String, String)
287+eqNumber = (C.prelude, C.eqNumber)
288+
289+eqInt :: (String, String)
290+eqInt = (C.dataInt, C.eqInt)
291+
292+eqString :: (String, String)
293+eqString = (C.prelude, C.eqNumber)
294+
295+eqBoolean :: (String, String)
296+eqBoolean = (C.prelude, C.eqNumber)
297+
298+ordNumber :: (String, String)
299+ordNumber = (C.prelude, C.ordNumber)
300+
301+ordInt :: (String, String)
302+ordInt = (C.dataInt, C.ordInt)
303+
304+semigroupString :: (String, String)
305+semigroupString = (C.prelude, C.semigroupString)
306+
307+boundedBoolean :: (String, String)
308+boundedBoolean = (C.prelude, C.boundedBoolean)
309+
310+latticeBoolean :: (String, String)
311+latticeBoolean = (C.prelude, C.latticeBoolean)
312+
313+complementedLatticeBoolean :: (String, String)
314+complementedLatticeBoolean = (C.prelude, C.complementedLatticeBoolean)
315+
316+semigroupoidArr :: (String, String)
317+semigroupoidArr = (C.prelude, C.semigroupoidArr)
src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hsnew file+165
@@ -0,0 +1,165 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.CodeGen.JS.Optimizer.MagicDo
4+-- Copyright : (c) Phil Freeman 2013-14
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- This module implements the "Magic Do" optimization, which inlines calls to return
13+-- and bind for the Eff monad, as well as some of its actions.
14+--
15+-----------------------------------------------------------------------------
16+
17+module Language.PureScript.CodeGen.JS.Optimizer.MagicDo (
18+ magicDo
19+) where
20+
21+import Data.List (nub)
22+import Data.Maybe (fromJust, isJust)
23+
24+import Language.PureScript.CodeGen.JS.AST
25+import Language.PureScript.CodeGen.JS.Common
26+import Language.PureScript.Names
27+import Language.PureScript.Options
28+import qualified Language.PureScript.Constants as C
29+
30+magicDo :: Options mode -> JS -> JS
31+magicDo opts | optionsNoMagicDo opts = id
32+ | otherwise = inlineST . magicDo'
33+
34+-- |
35+-- Inline type class dictionaries for >>= and return for the Eff monad
36+--
37+-- E.g.
38+--
39+-- Prelude[">>="](dict)(m1)(function(x) {
40+-- return ...;
41+-- })
42+--
43+-- becomes
44+--
45+-- function __do {
46+-- var x = m1();
47+-- ...
48+-- }
49+--
50+magicDo' :: JS -> JS
51+magicDo' = everywhereOnJS undo . everywhereOnJSTopDown convert
52+ where
53+ -- The name of the function block which is added to denote a do block
54+ fnName = "__do"
55+ -- Desugar monomorphic calls to >>= and return for the Eff monad
56+ convert :: JS -> JS
57+ -- Desugar return
58+ convert (JSApp (JSApp ret [val]) []) | isReturn ret = val
59+ -- Desugar pure
60+ convert (JSApp (JSApp pure' [val]) []) | isPure pure' = val
61+ -- Desugar >>
62+ convert (JSApp (JSApp bind [m]) [JSFunction Nothing [] (JSBlock js)]) | isBind bind =
63+ JSFunction (Just fnName) [] $ JSBlock (JSApp m [] : map applyReturns js )
64+ -- Desugar >>=
65+ convert (JSApp (JSApp bind [m]) [JSFunction Nothing [arg] (JSBlock js)]) | isBind bind =
66+ JSFunction (Just fnName) [] $ JSBlock (JSVariableIntroduction arg (Just (JSApp m [])) : map applyReturns js)
67+ -- Desugar untilE
68+ convert (JSApp (JSApp f [arg]) []) | isEffFunc C.untilE f =
69+ JSApp (JSFunction Nothing [] (JSBlock [ JSWhile (JSUnary Not (JSApp arg [])) (JSBlock []), JSReturn $ JSObjectLiteral []])) []
70+ -- Desugar whileE
71+ convert (JSApp (JSApp (JSApp f [arg1]) [arg2]) []) | isEffFunc C.whileE f =
72+ JSApp (JSFunction Nothing [] (JSBlock [ JSWhile (JSApp arg1 []) (JSBlock [ JSApp arg2 [] ]), JSReturn $ JSObjectLiteral []])) []
73+ convert other = other
74+ -- Check if an expression represents a monomorphic call to >>= for the Eff monad
75+ isBind (JSApp bindPoly [effDict]) | isBindPoly bindPoly && isEffDict C.bindEffDictionary effDict = True
76+ isBind _ = False
77+ -- Check if an expression represents a monomorphic call to return for the Eff monad
78+ isReturn (JSApp retPoly [effDict]) | isRetPoly retPoly && isEffDict C.monadEffDictionary effDict = True
79+ isReturn _ = False
80+ -- Check if an expression represents a monomorphic call to pure for the Eff applicative
81+ isPure (JSApp purePoly [effDict]) | isPurePoly purePoly && isEffDict C.applicativeEffDictionary effDict = True
82+ isPure _ = False
83+ -- Check if an expression represents the polymorphic >>= function
84+ isBindPoly (JSAccessor prop (JSVar prelude)) = prelude == C.prelude && (prop `elem` map identToJs [Ident C.bind, Op (C.>>=)])
85+ isBindPoly (JSIndexer (JSStringLiteral bind) (JSVar prelude)) = prelude == C.prelude && (bind `elem` [C.bind, (C.>>=)])
86+ isBindPoly _ = False
87+ -- Check if an expression represents the polymorphic return function
88+ isRetPoly (JSAccessor returnEscaped (JSVar prelude)) = prelude == C.prelude && returnEscaped == C.returnEscaped
89+ isRetPoly (JSIndexer (JSStringLiteral return') (JSVar prelude)) = prelude == C.prelude && return' == C.return
90+ isRetPoly _ = False
91+ -- Check if an expression represents the polymorphic pure function
92+ isPurePoly (JSAccessor pure' (JSVar prelude)) = prelude == C.prelude && pure' == C.pure'
93+ isPurePoly (JSIndexer (JSStringLiteral pure') (JSVar prelude)) = prelude == C.prelude && pure' == C.pure'
94+ isPurePoly _ = False
95+ -- Check if an expression represents a function in the Ef module
96+ isEffFunc name (JSAccessor name' (JSVar eff)) = eff == C.eff && name == name'
97+ isEffFunc _ _ = False
98+ -- Check if an expression represents the Monad Eff dictionary
99+ isEffDict name (JSVar ident) | ident == name = True
100+ isEffDict name (JSAccessor prop (JSVar eff)) = eff == C.eff && prop == name
101+ isEffDict _ _ = False
102+ -- Remove __do function applications which remain after desugaring
103+ undo :: JS -> JS
104+ undo (JSReturn (JSApp (JSFunction (Just ident) [] body) [])) | ident == fnName = body
105+ undo other = other
106+
107+ applyReturns :: JS -> JS
108+ applyReturns (JSReturn ret) = JSReturn (JSApp ret [])
109+ applyReturns (JSBlock jss) = JSBlock (map applyReturns jss)
110+ applyReturns (JSWhile cond js) = JSWhile cond (applyReturns js)
111+ applyReturns (JSFor v lo hi js) = JSFor v lo hi (applyReturns js)
112+ applyReturns (JSForIn v xs js) = JSForIn v xs (applyReturns js)
113+ applyReturns (JSIfElse cond t f) = JSIfElse cond (applyReturns t) (applyReturns `fmap` f)
114+ applyReturns other = other
115+
116+-- |
117+-- Inline functions in the ST module
118+--
119+inlineST :: JS -> JS
120+inlineST = everywhereOnJS convertBlock
121+ where
122+ -- Look for runST blocks and inline the STRefs there.
123+ -- If all STRefs are used in the scope of the same runST, only using { read, write, modify }STRef then
124+ -- we can be more aggressive about inlining, and actually turn STRefs into local variables.
125+ convertBlock (JSApp f [arg]) | isSTFunc C.runST f =
126+ let refs = nub . findSTRefsIn $ arg
127+ usages = findAllSTUsagesIn arg
128+ allUsagesAreLocalVars = all (\u -> let v = toVar u in isJust v && fromJust v `elem` refs) usages
129+ localVarsDoNotEscape = all (\r -> length (r `appearingIn` arg) == length (filter (\u -> let v = toVar u in v == Just r) usages)) refs
130+ in everywhereOnJS (convert (allUsagesAreLocalVars && localVarsDoNotEscape)) arg
131+ convertBlock other = other
132+ -- Convert a block in a safe way, preserving object wrappers of references,
133+ -- or in a more aggressive way, turning wrappers into local variables depending on the
134+ -- agg(ressive) parameter.
135+ convert agg (JSApp f [arg]) | isSTFunc C.newSTRef f =
136+ JSFunction Nothing [] (JSBlock [JSReturn $ if agg then arg else JSObjectLiteral [(C.stRefValue, arg)]])
137+ convert agg (JSApp (JSApp f [ref]) []) | isSTFunc C.readSTRef f =
138+ if agg then ref else JSAccessor C.stRefValue ref
139+ convert agg (JSApp (JSApp (JSApp f [ref]) [arg]) []) | isSTFunc C.writeSTRef f =
140+ if agg then JSAssignment ref arg else JSAssignment (JSAccessor C.stRefValue ref) arg
141+ convert agg (JSApp (JSApp (JSApp f [ref]) [func]) []) | isSTFunc C.modifySTRef f =
142+ if agg then JSAssignment ref (JSApp func [ref]) else JSAssignment (JSAccessor C.stRefValue ref) (JSApp func [JSAccessor C.stRefValue ref])
143+ convert _ other = other
144+ -- Check if an expression represents a function in the ST module
145+ isSTFunc name (JSAccessor name' (JSVar st)) = st == C.st && name == name'
146+ isSTFunc _ _ = False
147+ -- Find all ST Refs initialized in this block
148+ findSTRefsIn = everythingOnJS (++) isSTRef
149+ where
150+ isSTRef (JSVariableIntroduction ident (Just (JSApp (JSApp f [_]) []))) | isSTFunc C.newSTRef f = [ident]
151+ isSTRef _ = []
152+ -- Find all STRefs used as arguments to readSTRef, writeSTRef, modifySTRef
153+ findAllSTUsagesIn = everythingOnJS (++) isSTUsage
154+ where
155+ isSTUsage (JSApp (JSApp f [ref]) []) | isSTFunc C.readSTRef f = [ref]
156+ isSTUsage (JSApp (JSApp (JSApp f [ref]) [_]) []) | isSTFunc C.writeSTRef f || isSTFunc C.modifySTRef f = [ref]
157+ isSTUsage _ = []
158+ -- Find all uses of a variable
159+ appearingIn ref = everythingOnJS (++) isVar
160+ where
161+ isVar e@(JSVar v) | v == ref = [e]
162+ isVar _ = []
163+ -- Convert a JS value to a String if it is a JSVar
164+ toVar (JSVar v) = Just v
165+ toVar _ = Nothing
src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hsnew file+128
@@ -0,0 +1,128 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.CodeGen.JS.Optimizer.TCO
4+-- Copyright : (c) Phil Freeman 2013-14
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- This module implements tail call elimination.
13+--
14+-----------------------------------------------------------------------------
15+
16+module Language.PureScript.CodeGen.JS.Optimizer.TCO (tco) where
17+
18+import Data.Monoid
19+
20+import Language.PureScript.Options
21+import Language.PureScript.CodeGen.JS.AST
22+
23+-- |
24+-- Eliminate tail calls
25+--
26+tco :: Options mode -> JS -> JS
27+tco opts | optionsNoTco opts = id
28+ | otherwise = tco'
29+
30+tco' :: JS -> JS
31+tco' = everywhereOnJS convert
32+ where
33+ tcoLabel :: String
34+ tcoLabel = "tco"
35+
36+ tcoVar :: String -> String
37+ tcoVar arg = "__tco_" ++ arg
38+
39+ copyVar :: String -> String
40+ copyVar arg = "__copy_" ++ arg
41+
42+ convert :: JS -> JS
43+ convert js@(JSVariableIntroduction name (Just fn@JSFunction {})) =
44+ let
45+ (argss, body', replace) = collectAllFunctionArgs [] id fn
46+ in case () of
47+ _ | isTailCall name body' ->
48+ let
49+ allArgs = concat $ reverse argss
50+ in
51+ JSVariableIntroduction name (Just (replace (toLoop name allArgs body')))
52+ | otherwise -> js
53+ convert js = js
54+
55+ collectAllFunctionArgs :: [[String]] -> (JS -> JS) -> JS -> ([[String]], JS, JS -> JS)
56+ collectAllFunctionArgs allArgs f (JSFunction ident args (JSBlock (body@(JSReturn _):_))) =
57+ collectAllFunctionArgs (args : allArgs) (\b -> f (JSFunction ident (map copyVar args) (JSBlock [b]))) body
58+ collectAllFunctionArgs allArgs f (JSFunction ident args body@(JSBlock _)) =
59+ (args : allArgs, body, f . JSFunction ident (map copyVar args))
60+ collectAllFunctionArgs allArgs f (JSReturn (JSFunction ident args (JSBlock [body]))) =
61+ collectAllFunctionArgs (args : allArgs) (\b -> f (JSReturn (JSFunction ident (map copyVar args) (JSBlock [b])))) body
62+ collectAllFunctionArgs allArgs f (JSReturn (JSFunction ident args body@(JSBlock _))) =
63+ (args : allArgs, body, f . JSReturn . JSFunction ident (map copyVar args))
64+ collectAllFunctionArgs allArgs f body = (allArgs, body, f)
65+
66+ isTailCall :: String -> JS -> Bool
67+ isTailCall ident js =
68+ let
69+ numSelfCalls = everythingOnJS (+) countSelfCalls js
70+ numSelfCallsInTailPosition = everythingOnJS (+) countSelfCallsInTailPosition js
71+ numSelfCallsUnderFunctions = everythingOnJS (+) countSelfCallsUnderFunctions js
72+ numSelfCallWithFnArgs = everythingOnJS (+) countSelfCallsWithFnArgs js
73+ in
74+ numSelfCalls > 0
75+ && numSelfCalls == numSelfCallsInTailPosition
76+ && numSelfCallsUnderFunctions == 0
77+ && numSelfCallWithFnArgs == 0
78+ where
79+ countSelfCalls :: JS -> Int
80+ countSelfCalls (JSApp (JSVar ident') _) | ident == ident' = 1
81+ countSelfCalls _ = 0
82+
83+ countSelfCallsInTailPosition :: JS -> Int
84+ countSelfCallsInTailPosition (JSReturn ret) | isSelfCall ident ret = 1
85+ countSelfCallsInTailPosition _ = 0
86+
87+ countSelfCallsUnderFunctions :: JS -> Int
88+ countSelfCallsUnderFunctions (JSFunction _ _ js') = everythingOnJS (+) countSelfCalls js'
89+ countSelfCallsUnderFunctions _ = 0
90+
91+ countSelfCallsWithFnArgs :: JS -> Int
92+ countSelfCallsWithFnArgs ret = if isSelfCallWithFnArgs ident ret [] then 1 else 0
93+
94+ toLoop :: String -> [String] -> JS -> JS
95+ toLoop ident allArgs js = JSBlock $
96+ map (\arg -> JSVariableIntroduction arg (Just (JSVar (copyVar arg)))) allArgs ++
97+ [ JSLabel tcoLabel $ JSWhile (JSBooleanLiteral True) (JSBlock [ everywhereOnJS loopify js ]) ]
98+ where
99+ loopify :: JS -> JS
100+ loopify (JSReturn ret) | isSelfCall ident ret =
101+ let
102+ allArgumentValues = concat $ collectSelfCallArgs [] ret
103+ in
104+ JSBlock $ zipWith (\val arg ->
105+ JSVariableIntroduction (tcoVar arg) (Just val)) allArgumentValues allArgs
106+ ++ map (\arg ->
107+ JSAssignment (JSVar arg) (JSVar (tcoVar arg))) allArgs
108+ ++ [ JSContinue tcoLabel ]
109+ loopify other = other
110+ collectSelfCallArgs :: [[JS]] -> JS -> [[JS]]
111+ collectSelfCallArgs allArgumentValues (JSApp fn args') = collectSelfCallArgs (args' : allArgumentValues) fn
112+ collectSelfCallArgs allArgumentValues _ = allArgumentValues
113+
114+ isSelfCall :: String -> JS -> Bool
115+ isSelfCall ident (JSApp (JSVar ident') _) = ident == ident'
116+ isSelfCall ident (JSApp fn _) = isSelfCall ident fn
117+ isSelfCall _ _ = False
118+
119+ isSelfCallWithFnArgs :: String -> JS -> [JS] -> Bool
120+ isSelfCallWithFnArgs ident (JSVar ident') args | ident == ident' && any hasFunction args = True
121+ isSelfCallWithFnArgs ident (JSApp fn args) acc = isSelfCallWithFnArgs ident fn (args ++ acc)
122+ isSelfCallWithFnArgs _ _ _ = False
123+
124+ hasFunction :: JS -> Bool
125+ hasFunction = getAny . everythingOnJS mappend (Any . isFunction)
126+ where
127+ isFunction (JSFunction _ _ _) = True
128+ isFunction _ = False
src/Language/PureScript/CodeGen/JS/Optimizer/Unused.hsnew file+46
@@ -0,0 +1,46 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.CodeGen.JS.Optimizer.Unused
4+-- Copyright : (c) Phil Freeman 2013-14
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- Removes unused variables
13+--
14+-----------------------------------------------------------------------------
15+
16+module Language.PureScript.CodeGen.JS.Optimizer.Unused
17+ ( removeCodeAfterReturnStatements
18+ , removeUnusedArg
19+ , removeUndefinedApp
20+ ) where
21+
22+import Language.PureScript.CodeGen.JS.AST
23+import Language.PureScript.CodeGen.JS.Optimizer.Common
24+
25+import qualified Language.PureScript.Constants as C
26+
27+removeCodeAfterReturnStatements :: JS -> JS
28+removeCodeAfterReturnStatements = everywhereOnJS (removeFromBlock go)
29+ where
30+ go :: [JS] -> [JS]
31+ go jss | not (any isJSReturn jss) = jss
32+ | otherwise = let (body, ret : _) = span (not . isJSReturn) jss in body ++ [ret]
33+ isJSReturn (JSReturn _) = True
34+ isJSReturn _ = False
35+
36+removeUnusedArg :: JS -> JS
37+removeUnusedArg = everywhereOnJS convert
38+ where
39+ convert (JSFunction name [arg] body) | arg == C.__unused = JSFunction name [] body
40+ convert js = js
41+
42+removeUndefinedApp :: JS -> JS
43+removeUndefinedApp = everywhereOnJS convert
44+ where
45+ convert (JSApp fn [JSVar arg]) | arg == C.undefined = JSApp fn []
46+ convert js = js
src/Language/PureScript/Comments.hsnew file+25
@@ -0,0 +1,25 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Parser.Comments
4+-- Copyright : (c) Phil Freeman 2015
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- Defines the types of source code comments
13+--
14+-----------------------------------------------------------------------------
15+
16+{-# LANGUAGE DeriveDataTypeable #-}
17+
18+module Language.PureScript.Comments where
19+
20+import qualified Data.Data as D
21+
22+data Comment
23+ = LineComment String
24+ | BlockComment String
25+ deriving (Show, Eq, Ord, D.Data, D.Typeable)
src/Language/PureScript/Constants.hsnew file+281
@@ -0,0 +1,281 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Constants
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- Various constants which refer to things in the Prelude
13+--
14+-----------------------------------------------------------------------------
15+
16+module Language.PureScript.Constants where
17+
18+-- Operators
19+
20+($) :: String
21+($) = "$"
22+
23+(#) :: String
24+(#) = "#"
25+
26+(<>) :: String
27+(<>) = "<>"
28+
29+(++) :: String
30+(++) = "++"
31+
32+(>>=) :: String
33+(>>=) = ">>="
34+
35+(+) :: String
36+(+) = "+"
37+
38+(-) :: String
39+(-) = "-"
40+
41+(*) :: String
42+(*) = "*"
43+
44+(/) :: String
45+(/) = "/"
46+
47+(%) :: String
48+(%) = "%"
49+
50+(<) :: String
51+(<) = "<"
52+
53+(>) :: String
54+(>) = ">"
55+
56+(<=) :: String
57+(<=) = "<="
58+
59+(>=) :: String
60+(>=) = ">="
61+
62+(==) :: String
63+(==) = "=="
64+
65+(/=) :: String
66+(/=) = "/="
67+
68+(&&) :: String
69+(&&) = "&&"
70+
71+(||) :: String
72+(||) = "||"
73+
74+bind :: String
75+bind = "bind"
76+
77+unsafeIndex :: String
78+unsafeIndex = "unsafeIndex"
79+
80+(.|.) :: String
81+(.|.) = ".|."
82+
83+(.&.) :: String
84+(.&.) = ".&."
85+
86+(.^.) :: String
87+(.^.) = ".^."
88+
89+(<<<) :: String
90+(<<<) = "<<<"
91+
92+-- Functions
93+
94+negate :: String
95+negate = "negate"
96+
97+not :: String
98+not = "not"
99+
100+sup :: String
101+sup = "sup"
102+
103+inf :: String
104+inf = "inf"
105+
106+mod :: String
107+mod = "mod"
108+
109+shl :: String
110+shl = "shl"
111+
112+shr :: String
113+shr = "shr"
114+
115+zshr :: String
116+zshr = "zshr"
117+
118+complement :: String
119+complement = "complement"
120+
121+-- Prelude Values
122+
123+zero :: String
124+zero = "zero"
125+
126+one :: String
127+one = "one"
128+
129+bottom :: String
130+bottom = "bottom"
131+
132+top :: String
133+top = "top"
134+
135+return :: String
136+return = "return"
137+
138+pure' :: String
139+pure' = "pure"
140+
141+returnEscaped :: String
142+returnEscaped = "$return"
143+
144+untilE :: String
145+untilE = "untilE"
146+
147+whileE :: String
148+whileE = "whileE"
149+
150+runST :: String
151+runST = "runST"
152+
153+stRefValue :: String
154+stRefValue = "value"
155+
156+newSTRef :: String
157+newSTRef = "newSTRef"
158+
159+readSTRef :: String
160+readSTRef = "readSTRef"
161+
162+writeSTRef :: String
163+writeSTRef = "writeSTRef"
164+
165+modifySTRef :: String
166+modifySTRef = "modifySTRef"
167+
168+mkFn :: String
169+mkFn = "mkFn"
170+
171+runFn :: String
172+runFn = "runFn"
173+
174+unit :: String
175+unit = "unit"
176+
177+-- Prim values
178+
179+undefined :: String
180+undefined = "undefined"
181+
182+-- Type Class Dictionary Names
183+
184+monadEffDictionary :: String
185+monadEffDictionary = "monadEff"
186+
187+applicativeEffDictionary :: String
188+applicativeEffDictionary = "applicativeEff"
189+
190+bindEffDictionary :: String
191+bindEffDictionary = "bindEff"
192+
193+semiringNumber :: String
194+semiringNumber = "semiringNumber"
195+
196+semiringInt :: String
197+semiringInt = "semiringInt"
198+
199+ringNumber :: String
200+ringNumber = "ringNumber"
201+
202+ringInt :: String
203+ringInt = "ringInt"
204+
205+moduloSemiringNumber :: String
206+moduloSemiringNumber = "moduloSemiringNumber"
207+
208+moduloSemiringInt :: String
209+moduloSemiringInt = "moduloSemiringInt"
210+
211+ordNumber :: String
212+ordNumber = "ordNumber"
213+
214+ordInt :: String
215+ordInt = "ordInt"
216+
217+eqNumber :: String
218+eqNumber = "eqNumber"
219+
220+eqInt :: String
221+eqInt = "eqInt"
222+
223+eqString :: String
224+eqString = "eqString"
225+
226+eqBoolean :: String
227+eqBoolean = "eqBoolean"
228+
229+boundedBoolean :: String
230+boundedBoolean = "boundedBoolean"
231+
232+latticeBoolean :: String
233+latticeBoolean = "latticeBoolean"
234+
235+complementedLatticeBoolean :: String
236+complementedLatticeBoolean = "complementedLatticeBoolean"
237+
238+semigroupString :: String
239+semigroupString = "semigroupString"
240+
241+semigroupoidArr :: String
242+semigroupoidArr = "semigroupoidArr"
243+
244+-- Main module
245+
246+main :: String
247+main = "main"
248+
249+-- Code Generation
250+
251+__superclass_ :: String
252+__superclass_ = "__superclass_"
253+
254+__unused :: String
255+__unused = "__unused"
256+
257+-- Modules
258+
259+prim :: String
260+prim = "Prim"
261+
262+prelude :: String
263+prelude = "Prelude"
264+
265+dataArrayUnsafe :: String
266+dataArrayUnsafe = "Data_Array_Unsafe"
267+
268+eff :: String
269+eff = "Control_Monad_Eff"
270+
271+st :: String
272+st = "Control_Monad_ST"
273+
274+dataFunction :: String
275+dataFunction = "Data_Function"
276+
277+dataInt :: String
278+dataInt = "Data_Int"
279+
280+dataIntBits :: String
281+dataIntBits = "Data_Int_Bits"
src/Language/PureScript/CoreFn.hsnew file+26
@@ -0,0 +1,26 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.CoreFn
4+-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- | The core functional representation
12+--
13+-----------------------------------------------------------------------------
14+
15+module Language.PureScript.CoreFn (
16+ module C
17+) where
18+
19+import Language.PureScript.CoreFn.Ann as C
20+import Language.PureScript.CoreFn.Binders as C
21+import Language.PureScript.CoreFn.Desugar as C
22+import Language.PureScript.CoreFn.Expr as C
23+import Language.PureScript.CoreFn.Literals as C
24+import Language.PureScript.CoreFn.Meta as C
25+import Language.PureScript.CoreFn.Module as C
26+import Language.PureScript.CoreFn.Traversals as C
src/Language/PureScript/CoreFn/Ann.hsnew file+37
@@ -0,0 +1,37 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.CoreFn.Ann
4+-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- | Type alias for basic annotations
12+--
13+-----------------------------------------------------------------------------
14+
15+module Language.PureScript.CoreFn.Ann where
16+
17+import Language.PureScript.AST.SourcePos
18+import Language.PureScript.CoreFn.Meta
19+import Language.PureScript.Types
20+import Language.PureScript.Comments
21+
22+-- |
23+-- Type alias for basic annotations
24+--
25+type Ann = (Maybe SourceSpan, [Comment], Maybe Type, Maybe Meta)
26+
27+-- |
28+-- Initial annotation with no metadata
29+--
30+nullAnn :: Ann
31+nullAnn = (Nothing, [], Nothing, Nothing)
32+
33+-- |
34+-- Remove the comments from an annotation
35+--
36+removeComments :: Ann -> Ann
37+removeComments (ss, _, ty, meta) = (ss, [], ty, meta)
src/Language/PureScript/CoreFn/Binders.hsnew file+48
@@ -0,0 +1,48 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.CoreFn.Binders
4+-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- | The core functional representation for binders
12+--
13+-----------------------------------------------------------------------------
14+
15+{-# LANGUAGE DeriveDataTypeable #-}
16+{-# LANGUAGE DeriveFunctor #-}
17+
18+module Language.PureScript.CoreFn.Binders where
19+
20+import qualified Data.Data as D
21+
22+import Language.PureScript.CoreFn.Literals
23+import Language.PureScript.Names
24+
25+-- |
26+-- Data type for binders
27+--
28+data Binder a
29+ -- |
30+ -- Wildcard binder
31+ --
32+ = NullBinder a
33+ -- |
34+ -- A binder which matches a literal value
35+ --
36+ | LiteralBinder a (Literal (Binder a))
37+ -- |
38+ -- A binder which binds an identifier
39+ --
40+ | VarBinder a Ident
41+ -- |
42+ -- A binder which matches a data constructor (type name, constructor name, binders)
43+ --
44+ | ConstructorBinder a (Qualified ProperName) (Qualified ProperName) [Binder a]
45+ -- |
46+ -- A binder which binds its input to an identifier
47+ --
48+ | NamedBinder a Ident (Binder a) deriving (Show, D.Data, D.Typeable, Functor)
src/Language/PureScript/CoreFn/Desugar.hsnew file+264
@@ -0,0 +1,264 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.CoreFn.Desugar
4+-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- | The AST -> CoreFn desugaring step
12+--
13+-----------------------------------------------------------------------------
14+
15+module Language.PureScript.CoreFn.Desugar (moduleToCoreFn) where
16+
17+import Data.Function (on)
18+import Data.List (sort, sortBy, nub)
19+import Data.Maybe (mapMaybe)
20+import qualified Data.Map as M
21+
22+import Control.Arrow (second, (***))
23+
24+import Language.PureScript.AST.SourcePos
25+import Language.PureScript.AST.Traversals
26+import Language.PureScript.CoreFn.Ann
27+import Language.PureScript.CoreFn.Binders
28+import Language.PureScript.CoreFn.Expr
29+import Language.PureScript.CoreFn.Literals
30+import Language.PureScript.CoreFn.Meta
31+import Language.PureScript.CoreFn.Module
32+import Language.PureScript.Environment
33+import Language.PureScript.Names
34+import Language.PureScript.Sugar.TypeClasses (typeClassMemberName, superClassDictionaryNames)
35+import Language.PureScript.Types
36+import Language.PureScript.Comments
37+import qualified Language.PureScript.AST as A
38+
39+-- |
40+-- Desugars a module from AST to CoreFn representation.
41+--
42+moduleToCoreFn :: Environment -> A.Module -> Module Ann
43+moduleToCoreFn _ (A.Module _ _ _ Nothing) =
44+ error "Module exports were not elaborated before moduleToCoreFn"
45+moduleToCoreFn env (A.Module coms mn decls (Just exps)) =
46+ let imports = nub $ mapMaybe importToCoreFn decls ++ findQualModules decls
47+ exps' = nub $ concatMap exportToCoreFn exps
48+ externs = nub $ mapMaybe externToCoreFn decls
49+ decls' = concatMap (declToCoreFn Nothing []) decls
50+ in Module coms mn imports exps' externs decls'
51+
52+ where
53+
54+ -- |
55+ -- Desugars member declarations from AST to CoreFn representation.
56+ --
57+ declToCoreFn :: Maybe SourceSpan -> [Comment] -> A.Declaration -> [Bind Ann]
58+ declToCoreFn ss com (A.DataDeclaration Newtype _ _ [(ctor, _)]) =
59+ [NonRec (properToIdent ctor) $
60+ Abs (ss, com, Nothing, Just IsNewtype) (Ident "x") (Var nullAnn $ Qualified Nothing (Ident "x"))]
61+ declToCoreFn _ _ d@(A.DataDeclaration Newtype _ _ _) =
62+ error $ "Found newtype with multiple constructors: " ++ show d
63+ declToCoreFn ss com (A.DataDeclaration Data tyName _ ctors) =
64+ flip map ctors $ \(ctor, _) ->
65+ let (_, _, _, fields) = lookupConstructor env (Qualified (Just mn) ctor)
66+ in NonRec (properToIdent ctor) $ Constructor (ss, com, Nothing, Nothing) tyName ctor fields
67+ declToCoreFn ss _ (A.DataBindingGroupDeclaration ds) = concatMap (declToCoreFn ss []) ds
68+ declToCoreFn ss com (A.ValueDeclaration name _ _ (Right e)) =
69+ [NonRec name (exprToCoreFn ss com Nothing e)]
70+ declToCoreFn ss _ (A.BindingGroupDeclaration ds) =
71+ [Rec $ map (\(name, _, e) -> (name, exprToCoreFn ss [] Nothing e)) ds]
72+ declToCoreFn ss com (A.TypeClassDeclaration name _ supers members) =
73+ [NonRec (properToIdent name) $ mkTypeClassConstructor ss com supers members]
74+ declToCoreFn _ com (A.PositionedDeclaration ss com1 d) =
75+ declToCoreFn (Just ss) (com ++ com1) d
76+ declToCoreFn _ _ _ = []
77+
78+ -- |
79+ -- Desugars expressions from AST to CoreFn representation.
80+ --
81+ exprToCoreFn :: Maybe SourceSpan -> [Comment] -> Maybe Type -> A.Expr -> Expr Ann
82+ exprToCoreFn ss com ty (A.NumericLiteral v) =
83+ Literal (ss, com, ty, Nothing) (NumericLiteral v)
84+ exprToCoreFn ss com ty (A.StringLiteral v) =
85+ Literal (ss, com, ty, Nothing) (StringLiteral v)
86+ exprToCoreFn ss com ty (A.CharLiteral v) =
87+ Literal (ss, com, ty, Nothing) (CharLiteral v)
88+ exprToCoreFn ss com ty (A.BooleanLiteral v) =
89+ Literal (ss, com, ty, Nothing) (BooleanLiteral v)
90+ exprToCoreFn ss com ty (A.ArrayLiteral vs) =
91+ Literal (ss, com, ty, Nothing) (ArrayLiteral $ map (exprToCoreFn ss [] Nothing) vs)
92+ exprToCoreFn ss com ty (A.ObjectLiteral vs) =
93+ Literal (ss, com, ty, Nothing) (ObjectLiteral $ map (second (exprToCoreFn ss [] Nothing)) vs)
94+ exprToCoreFn ss com ty (A.Accessor name v) =
95+ Accessor (ss, com, ty, Nothing) name (exprToCoreFn ss [] Nothing v)
96+ exprToCoreFn ss com ty (A.ObjectUpdate obj vs) =
97+ ObjectUpdate (ss, com, ty, Nothing) (exprToCoreFn ss [] Nothing obj) $ map (second (exprToCoreFn ss [] Nothing)) vs
98+ exprToCoreFn ss com ty (A.Abs (Left name) v) =
99+ Abs (ss, com, ty, Nothing) name (exprToCoreFn ss [] Nothing v)
100+ exprToCoreFn _ _ _ (A.Abs _ _) =
101+ error "Abs with Binder argument was not desugared before exprToCoreFn mn"
102+ exprToCoreFn ss com ty (A.App v1 v2) =
103+ App (ss, com, ty, Nothing) (exprToCoreFn ss [] Nothing v1) (exprToCoreFn ss [] Nothing v2)
104+ exprToCoreFn ss com ty (A.Var ident) =
105+ Var (ss, com, ty, getValueMeta ident) ident
106+ exprToCoreFn ss com ty (A.IfThenElse v1 v2 v3) =
107+ Case (ss, com, ty, Nothing) [exprToCoreFn ss [] Nothing v1]
108+ [ CaseAlternative [LiteralBinder nullAnn $ BooleanLiteral True]
109+ (Right $ exprToCoreFn Nothing [] Nothing v2)
110+ , CaseAlternative [LiteralBinder nullAnn $ BooleanLiteral False]
111+ (Right $ exprToCoreFn Nothing [] Nothing v3) ]
112+ exprToCoreFn ss com ty (A.Constructor name) =
113+ Var (ss, com, ty, Just $ getConstructorMeta name) $ fmap properToIdent name
114+ exprToCoreFn ss com ty (A.Case vs alts) =
115+ Case (ss, com, ty, Nothing) (map (exprToCoreFn ss [] Nothing) vs) (map (altToCoreFn ss) alts)
116+ exprToCoreFn ss com _ (A.TypedValue _ v ty) =
117+ exprToCoreFn ss com (Just ty) v
118+ exprToCoreFn ss com ty (A.Let ds v) =
119+ Let (ss, com, ty, Nothing) (concatMap (declToCoreFn ss []) ds) (exprToCoreFn ss [] Nothing v)
120+ exprToCoreFn ss com _ (A.TypeClassDictionaryConstructorApp name (A.TypedValue _ (A.ObjectLiteral vs) _)) =
121+ let args = map (exprToCoreFn ss [] Nothing . snd) $ sortBy (compare `on` fst) vs
122+ ctor = Var (ss, [], Nothing, Just IsTypeClassConstructor) (fmap properToIdent name)
123+ in foldl (App (ss, com, Nothing, Nothing)) ctor args
124+ exprToCoreFn ss com ty (A.TypeClassDictionaryAccessor _ ident) =
125+ Abs (ss, com, ty, Nothing) (Ident "dict")
126+ (Accessor nullAnn (runIdent ident) (Var nullAnn $ Qualified Nothing (Ident "dict")))
127+ exprToCoreFn _ com ty (A.PositionedValue ss com1 v) =
128+ exprToCoreFn (Just ss) (com ++ com1) ty v
129+ exprToCoreFn _ _ _ e =
130+ error $ "Unexpected value in exprToCoreFn mn: " ++ show e
131+
132+ -- |
133+ -- Desugars case alternatives from AST to CoreFn representation.
134+ --
135+ altToCoreFn :: Maybe SourceSpan -> A.CaseAlternative -> CaseAlternative Ann
136+ altToCoreFn ss (A.CaseAlternative bs vs) = CaseAlternative (map (binderToCoreFn ss []) bs) (go vs)
137+ where
138+ go :: Either [(A.Guard, A.Expr)] A.Expr -> Either [(Guard Ann, Expr Ann)] (Expr Ann)
139+ go (Left ges) = Left $ map (exprToCoreFn ss [] Nothing *** exprToCoreFn ss [] Nothing) ges
140+ go (Right e) = Right (exprToCoreFn ss [] Nothing e)
141+
142+ -- |
143+ -- Desugars case binders from AST to CoreFn representation.
144+ --
145+ binderToCoreFn :: Maybe SourceSpan -> [Comment] -> A.Binder -> Binder Ann
146+ binderToCoreFn ss com (A.NullBinder) =
147+ NullBinder (ss, com, Nothing, Nothing)
148+ binderToCoreFn ss com (A.BooleanBinder b) =
149+ LiteralBinder (ss, com, Nothing, Nothing) (BooleanLiteral b)
150+ binderToCoreFn ss com (A.StringBinder s) =
151+ LiteralBinder (ss, com, Nothing, Nothing) (StringLiteral s)
152+ binderToCoreFn ss com (A.CharBinder c) =
153+ LiteralBinder (ss, com, Nothing, Nothing) (CharLiteral c)
154+ binderToCoreFn ss com (A.NumberBinder n) =
155+ LiteralBinder (ss, com, Nothing, Nothing) (NumericLiteral n)
156+ binderToCoreFn ss com (A.VarBinder name) =
157+ VarBinder (ss, com, Nothing, Nothing) name
158+ binderToCoreFn ss com (A.ConstructorBinder dctor@(Qualified mn' _) bs) =
159+ let (_, tctor, _, _) = lookupConstructor env dctor
160+ in ConstructorBinder (ss, com, Nothing, Just $ getConstructorMeta dctor) (Qualified mn' tctor) dctor (map (binderToCoreFn ss []) bs)
161+ binderToCoreFn ss com (A.ObjectBinder bs) =
162+ LiteralBinder (ss, com, Nothing, Nothing) (ObjectLiteral $ map (second (binderToCoreFn ss [])) bs)
163+ binderToCoreFn ss com (A.ArrayBinder bs) =
164+ LiteralBinder (ss, com, Nothing, Nothing) (ArrayLiteral $ map (binderToCoreFn ss []) bs)
165+ binderToCoreFn ss com (A.NamedBinder name b) =
166+ NamedBinder (ss, com, Nothing, Nothing) name (binderToCoreFn ss [] b)
167+ binderToCoreFn _ com (A.PositionedBinder ss com1 b) =
168+ binderToCoreFn (Just ss) (com ++ com1) b
169+
170+ -- |
171+ -- Gets metadata for values.
172+ --
173+ getValueMeta :: Qualified Ident -> Maybe Meta
174+ getValueMeta name =
175+ case lookupValue env name of
176+ Just (_, External, _) -> Just IsForeign
177+ _ -> Nothing
178+
179+ -- |
180+ -- Gets metadata for data constructors.
181+ --
182+ getConstructorMeta :: Qualified ProperName -> Meta
183+ getConstructorMeta ctor =
184+ case lookupConstructor env ctor of
185+ (Newtype, _, _, _) -> IsNewtype
186+ dc@(Data, _, _, fields) ->
187+ let constructorType = if numConstructors (ctor, dc) == 1 then ProductType else SumType
188+ in IsConstructor constructorType fields
189+ where
190+ numConstructors :: (Qualified ProperName, (DataDeclType, ProperName, Type, [Ident])) -> Int
191+ numConstructors ty = length $ filter (((==) `on` typeConstructor) ty) $ M.toList $ dataConstructors env
192+ typeConstructor :: (Qualified ProperName, (DataDeclType, ProperName, Type, [Ident])) -> (ModuleName, ProperName)
193+ typeConstructor (Qualified (Just mn') _, (_, tyCtor, _, _)) = (mn', tyCtor)
194+ typeConstructor _ = error "Invalid argument to typeConstructor"
195+
196+-- |
197+-- Find module names from qualified references to values. This is used to
198+-- ensure instances are imported from any module that is referenced by the
199+-- current module, not just from those that are imported explicitly (#667).
200+--
201+findQualModules :: [A.Declaration] -> [ModuleName]
202+findQualModules decls =
203+ let (f, _, _, _, _) = everythingOnValues (++) (const []) fqValues fqBinders (const []) (const [])
204+ in f `concatMap` decls
205+ where
206+ fqValues :: A.Expr -> [ModuleName]
207+ fqValues (A.Var (Qualified (Just mn) _)) = [mn]
208+ fqValues (A.Constructor (Qualified (Just mn) _)) = [mn]
209+ fqValues _ = []
210+
211+ fqBinders :: A.Binder -> [ModuleName]
212+ fqBinders (A.ConstructorBinder (Qualified (Just mn) _) _) = [mn]
213+ fqBinders _ = []
214+
215+-- |
216+-- Desugars import declarations from AST to CoreFn representation.
217+--
218+importToCoreFn :: A.Declaration -> Maybe ModuleName
219+importToCoreFn (A.ImportDeclaration name _ _) = Just name
220+importToCoreFn (A.PositionedDeclaration _ _ d) = importToCoreFn d
221+importToCoreFn _ = Nothing
222+
223+-- |
224+-- Desugars foreign declarations from AST to CoreFn representation.
225+--
226+externToCoreFn :: A.Declaration -> Maybe ForeignDecl
227+externToCoreFn (A.ExternDeclaration name ty) = Just (name, ty)
228+externToCoreFn (A.ExternInstanceDeclaration name _ _ _) = Just (name, tyObject)
229+externToCoreFn (A.PositionedDeclaration _ _ d) = externToCoreFn d
230+externToCoreFn _ = Nothing
231+
232+-- |
233+-- Desugars export declarations references from AST to CoreFn representation.
234+-- CoreFn modules only export values, so all data constructors, class
235+-- constructor, instances and values are flattened into one list.
236+--
237+exportToCoreFn :: A.DeclarationRef -> [Ident]
238+exportToCoreFn (A.TypeRef _ (Just dctors)) = map properToIdent dctors
239+exportToCoreFn (A.ValueRef name) = [name]
240+exportToCoreFn (A.TypeClassRef name) = [properToIdent name]
241+exportToCoreFn (A.TypeInstanceRef name) = [name]
242+exportToCoreFn (A.PositionedDeclarationRef _ _ d) = exportToCoreFn d
243+exportToCoreFn _ = []
244+
245+-- |
246+-- Makes a typeclass dictionary constructor function. The returned expression
247+-- is a function that accepts the superclass instances and member
248+-- implementations and returns a record for the instance dictionary.
249+--
250+mkTypeClassConstructor :: Maybe SourceSpan -> [Comment] -> [Constraint] -> [A.Declaration] -> Expr Ann
251+mkTypeClassConstructor ss com [] [] = Literal (ss, com, Nothing, Just IsTypeClassConstructor) (ObjectLiteral [])
252+mkTypeClassConstructor ss com supers members =
253+ let args@(a:as) = sort $ map typeClassMemberName members ++ superClassDictionaryNames supers
254+ props = [ (arg, Var nullAnn $ Qualified Nothing (Ident arg)) | arg <- args ]
255+ dict = Literal nullAnn (ObjectLiteral props)
256+ in Abs (ss, com, Nothing, Just IsTypeClassConstructor)
257+ (Ident a)
258+ (foldr (Abs nullAnn . Ident) dict as)
259+
260+-- |
261+-- Converts a ProperName to an Ident.
262+--
263+properToIdent :: ProperName -> Ident
264+properToIdent = Ident . runProperName
src/Language/PureScript/CoreFn/Expr.hsnew file+134
@@ -0,0 +1,134 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.CoreFn.Expr
4+-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- | The core functional representation
12+--
13+-----------------------------------------------------------------------------
14+
15+{-# LANGUAGE DeriveDataTypeable #-}
16+{-# LANGUAGE DeriveFunctor #-}
17+
18+module Language.PureScript.CoreFn.Expr where
19+
20+import Control.Arrow ((***))
21+
22+import qualified Data.Data as D
23+
24+import Language.PureScript.CoreFn.Binders
25+import Language.PureScript.CoreFn.Literals
26+import Language.PureScript.Names
27+
28+-- |
29+-- Data type for expressions and terms
30+--
31+data Expr a
32+ -- |
33+ -- A literal value
34+ --
35+ = Literal a (Literal (Expr a))
36+ -- |
37+ -- A data constructor (type name, constructor name, field names)
38+ --
39+ | Constructor a ProperName ProperName [Ident]
40+ -- |
41+ -- A record property accessor
42+ --
43+ | Accessor a String (Expr a)
44+ -- |
45+ -- Partial record update
46+ --
47+ | ObjectUpdate a (Expr a) [(String, Expr a)]
48+ -- |
49+ -- Function introduction
50+ --
51+ | Abs a Ident (Expr a)
52+ -- |
53+ -- Function application
54+ --
55+ | App a (Expr a) (Expr a)
56+ -- |
57+ -- Variable
58+ --
59+ | Var a (Qualified Ident)
60+ -- |
61+ -- A case expression
62+ --
63+ | Case a [Expr a] [CaseAlternative a]
64+ -- |
65+ -- A let binding
66+ --
67+ | Let a [Bind a] (Expr a) deriving (Show, D.Data, D.Typeable, Functor)
68+
69+-- |
70+-- A let or module binding.
71+--
72+data Bind a
73+ -- |
74+ -- Non-recursive binding for a single value
75+ --
76+ = NonRec Ident (Expr a)
77+ -- |
78+ -- Mutually recursive binding group for several values
79+ --
80+ | Rec [(Ident, Expr a)] deriving (Show, D.Data, D.Typeable, Functor)
81+
82+-- |
83+-- A guard is just a boolean-valued expression that appears alongside a set of binders
84+--
85+type Guard a = Expr a
86+
87+-- |
88+-- An alternative in a case statement
89+--
90+data CaseAlternative a = CaseAlternative
91+ { -- |
92+ -- A collection of binders with which to match the inputs
93+ --
94+ caseAlternativeBinders :: [Binder a]
95+ -- |
96+ -- The result expression or a collect of guarded expressions
97+ --
98+ , caseAlternativeResult :: Either [(Guard a, Expr a)] (Expr a)
99+ } deriving (Show, D.Data, D.Typeable)
100+
101+instance Functor CaseAlternative where
102+
103+ fmap f (CaseAlternative cabs car) = CaseAlternative
104+ (fmap (fmap f) $ cabs)
105+ (either (Left . fmap (fmap f *** fmap f)) (Right . fmap f) car)
106+
107+-- |
108+-- Extract the annotation from a term
109+--
110+extractAnn :: Expr a -> a
111+extractAnn (Literal a _) = a
112+extractAnn (Constructor a _ _ _) = a
113+extractAnn (Accessor a _ _) = a
114+extractAnn (ObjectUpdate a _ _) = a
115+extractAnn (Abs a _ _) = a
116+extractAnn (App a _ _) = a
117+extractAnn (Var a _) = a
118+extractAnn (Case a _ _) = a
119+extractAnn (Let a _ _) = a
120+
121+
122+-- |
123+-- Modify the annotation on a term
124+--
125+modifyAnn :: (a -> a) -> Expr a -> Expr a
126+modifyAnn f (Literal a b) = Literal (f a) b
127+modifyAnn f (Constructor a b c d) = Constructor (f a) b c d
128+modifyAnn f (Accessor a b c) = Accessor (f a) b c
129+modifyAnn f (ObjectUpdate a b c) = ObjectUpdate (f a) b c
130+modifyAnn f (Abs a b c) = Abs (f a) b c
131+modifyAnn f (App a b c) = App (f a) b c
132+modifyAnn f (Var a b) = Var (f a) b
133+modifyAnn f (Case a b c) = Case (f a) b c
134+modifyAnn f (Let a b c) = Let (f a) b c
src/Language/PureScript/CoreFn/Literals.hsnew file+50
@@ -0,0 +1,50 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.CoreFn.Literals
4+-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- | The core functional representation for literal values.
12+--
13+-----------------------------------------------------------------------------
14+
15+{-# LANGUAGE DeriveDataTypeable #-}
16+{-# LANGUAGE DeriveFunctor #-}
17+
18+module Language.PureScript.CoreFn.Literals where
19+
20+import qualified Data.Data as D
21+
22+-- |
23+-- Data type for literal values. Parameterised so it can be used for Exprs and
24+-- Binders.
25+--
26+data Literal a
27+ -- |
28+ -- A numeric literal
29+ --
30+ = NumericLiteral (Either Integer Double)
31+ -- |
32+ -- A string literal
33+ --
34+ | StringLiteral String
35+ -- |
36+ -- A character literal
37+ --
38+ | CharLiteral Char
39+ -- |
40+ -- A boolean literal
41+ --
42+ | BooleanLiteral Bool
43+ -- |
44+ -- An array literal
45+ --
46+ | ArrayLiteral [a]
47+ -- |
48+ -- An object literal
49+ --
50+ | ObjectLiteral [(String, a)] deriving (Show, D.Data, D.Typeable, Functor)
src/Language/PureScript/CoreFn/Meta.hsnew file+55
@@ -0,0 +1,55 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.CoreFn.Meta
4+-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- | Metadata annotations for core functional representation
12+--
13+-----------------------------------------------------------------------------
14+
15+{-# LANGUAGE DeriveDataTypeable #-}
16+
17+module Language.PureScript.CoreFn.Meta where
18+
19+import qualified Data.Data as D
20+
21+import Language.PureScript.Names
22+
23+-- |
24+-- Metadata annotations
25+--
26+data Meta
27+ -- |
28+ -- The contained value is a data constructor
29+ --
30+ = IsConstructor ConstructorType [Ident]
31+ -- |
32+ -- The contained value is a newtype
33+ --
34+ | IsNewtype
35+ -- |
36+ -- The contained value is a typeclass dictionary constructor
37+ --
38+ | IsTypeClassConstructor
39+ -- |
40+ -- The contained reference is for a foreign member
41+ --
42+ | IsForeign deriving (Show, D.Data, D.Typeable)
43+
44+-- |
45+-- Data constructor metadata
46+--
47+data ConstructorType
48+ -- |
49+ -- The constructor is for a type with a single construcor
50+ --
51+ = ProductType
52+ -- |
53+ -- The constructor is for a type with multiple construcors
54+ --
55+ | SumType deriving (Show, D.Data, D.Typeable)
src/Language/PureScript/CoreFn/Module.hsnew file+31
@@ -0,0 +1,31 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.CoreFn.Module
4+-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- | The CoreFn module representation
12+--
13+-----------------------------------------------------------------------------
14+
15+module Language.PureScript.CoreFn.Module where
16+
17+import Language.PureScript.Comments
18+import Language.PureScript.CoreFn.Expr
19+import Language.PureScript.Names
20+import Language.PureScript.Types
21+
22+data Module a = Module
23+ { moduleComments :: [Comment]
24+ , moduleName :: ModuleName
25+ , moduleImports :: [ModuleName]
26+ , moduleExports :: [Ident]
27+ , moduleForeign :: [ForeignDecl]
28+ , moduleDecls :: [Bind a]
29+ } deriving (Show)
30+
31+type ForeignDecl = (Ident, Type)
src/Language/PureScript/CoreFn/Traversals.hsnew file+85
@@ -0,0 +1,85 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.CoreFn.Traversals
4+-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- | CoreFn traversal helpers
12+--
13+-----------------------------------------------------------------------------
14+
15+module Language.PureScript.CoreFn.Traversals where
16+
17+import Control.Arrow (second, (***), (+++))
18+
19+import Language.PureScript.CoreFn.Binders
20+import Language.PureScript.CoreFn.Expr
21+import Language.PureScript.CoreFn.Literals
22+
23+everywhereOnValues :: (Bind a -> Bind a) ->
24+ (Expr a -> Expr a) ->
25+ (Binder a -> Binder a) ->
26+ (Bind a -> Bind a, Expr a -> Expr a, Binder a -> Binder a)
27+everywhereOnValues f g h = (f', g', h')
28+ where
29+ f' (NonRec name e) = f (NonRec name (g' e))
30+ f' (Rec es) = f (Rec (map (second g') es))
31+
32+ g' (Literal ann e) = g (Literal ann (handleLiteral g' e))
33+ g' (Accessor ann prop e) = g (Accessor ann prop (g' e))
34+ g' (ObjectUpdate ann obj vs) = g (ObjectUpdate ann (g' obj) (map (fmap g') vs))
35+ g' (Abs ann name e) = g (Abs ann name (g' e))
36+ g' (App ann v1 v2) = g (App ann (g' v1) (g' v2))
37+ g' (Case ann vs alts) = g (Case ann (map g' vs) (map handleCaseAlternative alts))
38+ g' (Let ann ds e) = g (Let ann (map f' ds) (g' e))
39+ g' e = g e
40+
41+ h' (LiteralBinder a b) = h (LiteralBinder a (handleLiteral h' b))
42+ h' (NamedBinder a name b) = h (NamedBinder a name (h' b))
43+ h' b = h b
44+
45+ handleCaseAlternative ca =
46+ ca { caseAlternativeBinders = map h' (caseAlternativeBinders ca)
47+ , caseAlternativeResult = (map (g' *** g') +++ g') (caseAlternativeResult ca)
48+ }
49+
50+ handleLiteral :: (a -> a) -> Literal a -> Literal a
51+ handleLiteral i (ArrayLiteral ls) = ArrayLiteral (map i ls)
52+ handleLiteral i (ObjectLiteral ls) = ObjectLiteral (map (fmap i) ls)
53+ handleLiteral _ other = other
54+
55+everythingOnValues :: (r -> r -> r) ->
56+ (Bind a -> r) ->
57+ (Expr a -> r) ->
58+ (Binder a -> r) ->
59+ (CaseAlternative a -> r) ->
60+ (Bind a -> r, Expr a -> r, Binder a -> r, CaseAlternative a -> r)
61+everythingOnValues (<>) f g h i = (f', g', h', i')
62+ where
63+ f' b@(NonRec _ e) = f b <> g' e
64+ f' b@(Rec es) = foldl (<>) (f b) (map (g' . snd) es)
65+
66+ g' v@(Literal _ l) = foldl (<>) (g v) (map g' (extractLiteral l))
67+ g' v@(Accessor _ _ e1) = g v <> g' e1
68+ g' v@(ObjectUpdate _ obj vs) = foldl (<>) (g v <> g' obj) (map (g' . snd) vs)
69+ g' v@(Abs _ _ e1) = g v <> g' e1
70+ g' v@(App _ e1 e2) = g v <> g' e1 <> g' e2
71+ g' v@(Case _ vs alts) = foldl (<>) (foldl (<>) (g v) (map g' vs)) (map i' alts)
72+ g' v@(Let _ ds e1) = foldl (<>) (g v) (map f' ds) <> g' e1
73+ g' v = g v
74+
75+ h' b@(LiteralBinder _ l) = foldl (<>) (h b) (map h' (extractLiteral l))
76+ h' b@(ConstructorBinder _ _ _ bs) = foldl (<>) (h b) (map h' bs)
77+ h' b@(NamedBinder _ _ b1) = h b <> h' b1
78+ h' b = h b
79+
80+ i' ca@(CaseAlternative bs (Right val)) = foldl (<>) (i ca) (map h' bs) <> g' val
81+ i' ca@(CaseAlternative bs (Left gs)) = foldl (<>) (i ca) (map h' bs ++ concatMap (\(grd, val) -> [g' grd, g' val]) gs)
82+
83+ extractLiteral (ArrayLiteral xs) = xs
84+ extractLiteral (ObjectLiteral xs) = map snd xs
85+ extractLiteral _ = []
src/Language/PureScript/DeadCodeElimination.hsnew file+102
@@ -0,0 +1,102 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.DeadCodeElimination
4+-- Copyright : (c) 2014 Phil Freeman
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- | Dead code elimination.
12+--
13+-----------------------------------------------------------------------------
14+
15+module Language.PureScript.DeadCodeElimination (
16+ eliminateDeadCode
17+) where
18+
19+import Data.Graph
20+import Data.List
21+import Data.Maybe (mapMaybe)
22+
23+import Language.PureScript.CoreFn
24+import Language.PureScript.Names
25+
26+-- |
27+-- Eliminate all declarations which are not a transitive dependency of the entry point module
28+--
29+eliminateDeadCode :: [ModuleName] -> [Module a] -> [Module a]
30+eliminateDeadCode entryPoints ms = map go ms
31+ where
32+ go (Module coms mn imps exps foreigns ds) = Module coms mn imps exps' foreigns' ds'
33+ where
34+ ds' = filter (isUsed mn graph vertexFor entryPointVertices) ds
35+ foreigns' = filter (isUsed' mn graph vertexFor entryPointVertices . foreignIdent) foreigns
36+ names = concatMap bindIdents ds' ++ map foreignIdent foreigns'
37+ exps' = filter (`elem` names) exps
38+ declarations = concatMap declarationsByModule ms
39+ (graph, _, vertexFor) = graphFromEdges $ map (\(key, deps) -> (key, key, deps)) declarations
40+ entryPointVertices = mapMaybe (vertexFor . fst) . filter (\((mn, _), _) -> mn `elem` entryPoints) $ declarations
41+
42+-- |
43+-- Extract declaration names for a binding group.
44+--
45+bindIdents :: Bind a -> [Ident]
46+bindIdents (NonRec name _) = [name]
47+bindIdents (Rec names) = map fst names
48+
49+-- |
50+-- Extract the ident for a foreign declaration.
51+--
52+foreignIdent :: ForeignDecl -> Ident
53+foreignIdent = fst
54+
55+-- |
56+-- Key type to use in graph
57+--
58+type Key = (ModuleName, Ident)
59+
60+-- |
61+-- Find dependencies for each member in a module.
62+--
63+declarationsByModule :: Module a -> [(Key, [Key])]
64+declarationsByModule (Module _ mn _ _ fs ds) =
65+ let fs' = map ((\name -> ((mn, name), [])) . foreignIdent) fs
66+ in fs' ++ concatMap go ds
67+ where
68+ go :: Bind a -> [(Key, [Key])]
69+ go d@(NonRec name _) = [((mn, name), dependencies d)]
70+ go d@(Rec names') = map (\(name, _) -> ((mn, name), dependencies d)) names'
71+
72+-- |
73+-- Find all referenced values within a binding group.
74+--
75+dependencies :: Bind a -> [Key]
76+dependencies =
77+ let (f, _, _, _) = everythingOnValues (++) (const []) values binders (const [])
78+ in nub . f
79+ where
80+ values :: Expr a -> [Key]
81+ values (Var _ (Qualified (Just mn) ident)) = [(mn, ident)]
82+ values _ = []
83+ binders :: Binder a -> [Key]
84+ binders (ConstructorBinder _ _ (Qualified (Just mn) ident) _) = [(mn, Ident $ runProperName ident)]
85+ binders _ = []
86+
87+-- |
88+-- Check whether a binding group is used.
89+--
90+isUsed :: ModuleName -> Graph -> (Key -> Maybe Vertex) -> [Vertex] -> Bind a -> Bool
91+isUsed mn graph vertexFor entryPointVertices (NonRec name _) =
92+ isUsed' mn graph vertexFor entryPointVertices name
93+isUsed mn graph vertexFor entryPointVertices (Rec ds) =
94+ any (isUsed' mn graph vertexFor entryPointVertices . fst) ds
95+
96+-- |
97+-- Check whether a named declaration is used.
98+--
99+isUsed' :: ModuleName -> Graph -> (Key -> Maybe Vertex) -> [Vertex] -> Ident -> Bool
100+isUsed' mn graph vertexFor entryPointVertices name =
101+ let Just v' = vertexFor (mn, name)
102+ in any (\v -> path graph v v') entryPointVertices
src/Language/PureScript/Docs.hsnew file+14
@@ -0,0 +1,14 @@
1+
2+-- | Data types and functions for rendering generated documentation from
3+-- PureScript code, in a variety of formats.
4+
5+module Language.PureScript.Docs (
6+ module Docs
7+) where
8+
9+import Language.PureScript.Docs.Types as Docs
10+import Language.PureScript.Docs.RenderedCode.Types as Docs
11+import Language.PureScript.Docs.RenderedCode.Render as Docs
12+import Language.PureScript.Docs.Convert as Docs
13+import Language.PureScript.Docs.Render as Docs
14+import Language.PureScript.Docs.ParseAndDesugar as Docs
src/Language/PureScript/Docs/AsMarkdown.hsnew file+124
@@ -0,0 +1,124 @@
1+{-# LANGUAGE RecordWildCards #-}
2+
3+module Language.PureScript.Docs.AsMarkdown (
4+ renderModulesAsMarkdown
5+) where
6+
7+import Control.Monad.Writer hiding (First)
8+import Data.Foldable (for_)
9+import Data.List (partition)
10+
11+import qualified Language.PureScript as P
12+
13+import Language.PureScript.Docs.Types
14+import Language.PureScript.Docs.RenderedCode
15+import qualified Language.PureScript.Docs.Convert as Convert
16+import qualified Language.PureScript.Docs.Render as Render
17+
18+-- |
19+-- Take a list of modules and render them all in order, returning a single
20+-- Markdown-formatted String.
21+--
22+renderModulesAsMarkdown :: [P.Module] -> String
23+renderModulesAsMarkdown =
24+ runDocs . modulesAsMarkdown . map Convert.convertModule
25+
26+modulesAsMarkdown :: [Module] -> Docs
27+modulesAsMarkdown = mapM_ moduleAsMarkdown
28+
29+moduleAsMarkdown :: Module -> Docs
30+moduleAsMarkdown Module{..} = do
31+ headerLevel 2 $ "Module " ++ modName
32+ spacer
33+ for_ modComments tell'
34+ mapM_ declAsMarkdown modDeclarations
35+ spacer
36+
37+declAsMarkdown :: Declaration -> Docs
38+declAsMarkdown decl@Declaration{..} = do
39+ headerLevel 4 (ticks declTitle)
40+ spacer
41+
42+ let (instances, children) = partition (isChildInstance . cdeclInfo) declChildren
43+ fencedBlock $ do
44+ tell' (codeToString $ Render.renderDeclaration decl)
45+ zipWithM_ (\f c -> tell' (childToString f c)) (First : repeat NotFirst) children
46+ spacer
47+
48+ for_ declFixity (\fixity -> fixityAsMarkdown fixity >> spacer)
49+
50+ for_ declComments tell'
51+
52+ unless (null instances) $ do
53+ headerLevel 5 "Instances"
54+ fencedBlock $ mapM_ (tell' . childToString NotFirst) instances
55+ spacer
56+
57+ where
58+ isChildInstance (ChildInstance _ _) = True
59+ isChildInstance _ = False
60+
61+codeToString :: RenderedCode -> String
62+codeToString = outputWith elemAsMarkdown
63+ where
64+ elemAsMarkdown (Syntax x) = x
65+ elemAsMarkdown (Ident x) = x
66+ elemAsMarkdown (Ctor x _) = x
67+ elemAsMarkdown (Kind x) = x
68+ elemAsMarkdown (Keyword x) = x
69+ elemAsMarkdown Space = " "
70+
71+fixityAsMarkdown :: P.Fixity -> Docs
72+fixityAsMarkdown (P.Fixity associativity precedence) =
73+ tell' $ concat [ "_"
74+ , associativityStr
75+ , " / precedence "
76+ , show precedence
77+ , "_"
78+ ]
79+ where
80+ associativityStr = case associativity of
81+ P.Infixl -> "left-associative"
82+ P.Infixr -> "right-associative"
83+ P.Infix -> "non-associative"
84+
85+childToString :: First -> ChildDeclaration -> String
86+childToString f decl@ChildDeclaration{..} =
87+ case cdeclInfo of
88+ ChildDataConstructor _ ->
89+ let c = if f == First then "=" else "|"
90+ in " " ++ c ++ " " ++ str
91+ ChildTypeClassMember _ ->
92+ " " ++ str
93+ ChildInstance _ _ ->
94+ str
95+ where
96+ str = codeToString $ Render.renderChildDeclaration decl
97+
98+data First
99+ = First
100+ | NotFirst
101+ deriving (Show, Eq, Ord)
102+
103+type Docs = Writer [String] ()
104+
105+runDocs :: Docs -> String
106+runDocs = unlines . execWriter
107+
108+tell' :: String -> Docs
109+tell' = tell . (:[])
110+
111+spacer :: Docs
112+spacer = tell' ""
113+
114+headerLevel :: Int -> String -> Docs
115+headerLevel level hdr = tell' (replicate level '#' ++ ' ' : hdr)
116+
117+fencedBlock :: Docs -> Docs
118+fencedBlock inner = do
119+ tell' "``` purescript"
120+ inner
121+ tell' "```"
122+
123+ticks :: String -> String
124+ticks = ("`" ++) . (++ "`")
src/Language/PureScript/Docs/Convert.hsnew file+228
@@ -0,0 +1,228 @@
1+{-# LANGUAGE TupleSections #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE RecordWildCards #-}
4+{-# LANGUAGE ViewPatterns #-}
5+
6+-- | Functions for converting PureScript ASTs into values of the data types
7+-- from Language.PureScript.Docs.
8+
9+module Language.PureScript.Docs.Convert
10+ ( convertModule
11+ , collectBookmarks
12+ ) where
13+
14+import Control.Monad
15+import Control.Category ((>>>))
16+import Data.Either
17+import Data.Maybe (mapMaybe, isNothing)
18+import Data.List (nub, isPrefixOf, isSuffixOf)
19+
20+import qualified Language.PureScript as P
21+
22+import Language.PureScript.Docs.Types
23+
24+-- |
25+-- Convert a single Module.
26+--
27+convertModule :: P.Module -> Module
28+convertModule m@(P.Module coms moduleName _ _) =
29+ Module (show moduleName) comments (declarations m)
30+ where
31+ comments = convertComments coms
32+ declarations =
33+ P.exportedDeclarations
34+ >>> mapMaybe (\d -> getDeclarationTitle d >>= convertDeclaration d)
35+ >>> augmentDeclarations
36+ >>> map addDefaultFixity
37+
38+-- | The data type for an intermediate stage which we go through during
39+-- converting.
40+--
41+-- In the first pass, we take all top level declarations in the module, and
42+-- collect other information which will later be used to augment the top level
43+-- declarations. These two situation correspond to the Right and Left
44+-- constructors, respectively.
45+--
46+-- In the second pass, we go over all of the Left values and augment the
47+-- relevant declarations, leaving only the augmented Right values.
48+--
49+-- Note that in the Left case, we provide a [String] as well as augment
50+-- information. The [String] value should be a list of titles of declarations
51+-- that the augmentation should apply to. For example, for a type instance
52+-- declaration, that would be any types or type classes mentioned in the
53+-- instance. For a fixity declaration, it would be just the relevant operator's
54+-- name.
55+type IntermediateDeclaration
56+ = Either ([String], DeclarationAugment) Declaration
57+
58+-- | Some data which will be used to augment a Declaration in the
59+-- output.
60+--
61+-- The AugmentChild constructor allows us to move all children under their
62+-- respective parents. It is only necessary for type instance declarations,
63+-- since they appear at the top level in the AST, and since they might need to
64+-- appear as children in two places (for example, if a data type defined in a
65+-- module is an instance of a type class also defined in that module).
66+--
67+-- The AugmentFixity constructor allows us to augment operator definitions
68+-- with their associativity and precedence.
69+data DeclarationAugment
70+ = AugmentChild ChildDeclaration
71+ | AugmentFixity P.Fixity
72+
73+-- | Augment top-level declarations; the second pass. See the comments under
74+-- the type synonym IntermediateDeclaration for more information.
75+augmentDeclarations :: [IntermediateDeclaration] -> [Declaration]
76+augmentDeclarations (partitionEithers -> (augments, toplevels)) =
77+ foldl go toplevels augments
78+ where
79+ go ds (parentTitles, a) =
80+ map (\d ->
81+ if declTitle d `elem` parentTitles
82+ then augmentWith a d
83+ else d) ds
84+
85+ augmentWith a d =
86+ case a of
87+ AugmentChild child ->
88+ d { declChildren = declChildren d ++ [child] }
89+ AugmentFixity fixity ->
90+ d { declFixity = Just fixity }
91+
92+-- | Add the default operator fixity for operators which do not have associated
93+-- fixity declarations.
94+--
95+-- TODO: This may no longer be necessary after issue 806 is resolved, hopefully
96+-- in 0.8.
97+addDefaultFixity :: Declaration -> Declaration
98+addDefaultFixity decl@Declaration{..}
99+ | isOp declTitle && isNothing declFixity =
100+ decl { declFixity = Just defaultFixity }
101+ | otherwise =
102+ decl
103+ where
104+ isOp :: String -> Bool
105+ isOp str = "(" `isPrefixOf` str && ")" `isSuffixOf` str
106+ defaultFixity = P.Fixity P.Infixl (-1)
107+
108+getDeclarationTitle :: P.Declaration -> Maybe String
109+getDeclarationTitle (P.TypeDeclaration name _) = Just (show name)
110+getDeclarationTitle (P.ExternDeclaration name _) = Just (show name)
111+getDeclarationTitle (P.DataDeclaration _ name _ _) = Just (show name)
112+getDeclarationTitle (P.ExternDataDeclaration name _) = Just (show name)
113+getDeclarationTitle (P.TypeSynonymDeclaration name _ _) = Just (show name)
114+getDeclarationTitle (P.TypeClassDeclaration name _ _ _) = Just (show name)
115+getDeclarationTitle (P.TypeInstanceDeclaration name _ _ _ _) = Just (show name)
116+getDeclarationTitle (P.FixityDeclaration _ name) = Just ("(" ++ name ++ ")")
117+getDeclarationTitle (P.PositionedDeclaration _ _ d) = getDeclarationTitle d
118+getDeclarationTitle _ = Nothing
119+
120+-- | Create a basic Declaration value.
121+mkDeclaration :: String -> DeclarationInfo -> Declaration
122+mkDeclaration title info =
123+ Declaration { declTitle = title
124+ , declComments = Nothing
125+ , declSourceSpan = Nothing
126+ , declChildren = []
127+ , declFixity = Nothing
128+ , declInfo = info
129+ }
130+
131+basicDeclaration :: String -> DeclarationInfo -> Maybe IntermediateDeclaration
132+basicDeclaration title info = Just $ Right $ mkDeclaration title info
133+
134+convertDeclaration :: P.Declaration -> String -> Maybe IntermediateDeclaration
135+convertDeclaration (P.TypeDeclaration _ ty) title =
136+ basicDeclaration title (ValueDeclaration ty)
137+convertDeclaration (P.ExternDeclaration _ ty) title =
138+ basicDeclaration title (ValueDeclaration ty)
139+convertDeclaration (P.DataDeclaration dtype _ args ctors) title =
140+ Just (Right (mkDeclaration title info) { declChildren = children })
141+ where
142+ info = DataDeclaration dtype args
143+ children = map convertCtor ctors
144+ convertCtor (ctor', tys) =
145+ ChildDeclaration (show ctor') Nothing Nothing (ChildDataConstructor tys)
146+convertDeclaration (P.ExternDataDeclaration _ kind') title =
147+ basicDeclaration title (ExternDataDeclaration kind')
148+convertDeclaration (P.TypeSynonymDeclaration _ args ty) title =
149+ basicDeclaration title (TypeSynonymDeclaration args ty)
150+convertDeclaration (P.TypeClassDeclaration _ args implies ds) title = do
151+ Just (Right (mkDeclaration title info) { declChildren = children })
152+ where
153+ info = TypeClassDeclaration args implies
154+ children = map convertClassMember ds
155+ convertClassMember (P.PositionedDeclaration _ _ d) =
156+ convertClassMember d
157+ convertClassMember (P.TypeDeclaration ident' ty) =
158+ ChildDeclaration (show ident') Nothing Nothing (ChildTypeClassMember ty)
159+ convertClassMember _ =
160+ error "Invalid argument to convertClassMember."
161+convertDeclaration (P.TypeInstanceDeclaration _ constraints className tys _) title = do
162+ Just (Left (classNameString : typeNameStrings, AugmentChild childDecl))
163+ where
164+ classNameString = unQual className
165+ typeNameStrings = nub (concatMap (P.everythingOnTypes (++) extractProperNames) tys)
166+ unQual x = let (P.Qualified _ y) = x in show y
167+
168+ extractProperNames (P.TypeConstructor n) = [unQual n]
169+ extractProperNames (P.SaturatedTypeSynonym n _) = [unQual n]
170+ extractProperNames _ = []
171+
172+ childDecl = ChildDeclaration title Nothing Nothing (ChildInstance constraints classApp)
173+ classApp = foldl P.TypeApp (P.TypeConstructor className) tys
174+convertDeclaration (P.FixityDeclaration fixity _) title =
175+ Just (Left ([title], AugmentFixity fixity))
176+convertDeclaration (P.PositionedDeclaration srcSpan com d') title =
177+ fmap (addComments . addSourceSpan) (convertDeclaration d' title)
178+ where
179+ addComments (Right d) =
180+ Right (d { declComments = convertComments com })
181+ addComments (Left augment) =
182+ Left (withAugmentChild (\d -> d { cdeclComments = convertComments com })
183+ augment)
184+
185+ addSourceSpan (Right d) =
186+ Right (d { declSourceSpan = Just srcSpan })
187+ addSourceSpan (Left augment) =
188+ Left (withAugmentChild (\d -> d { cdeclSourceSpan = Just srcSpan })
189+ augment)
190+
191+ withAugmentChild f (t, a) =
192+ case a of
193+ AugmentChild d -> (t, AugmentChild (f d))
194+ _ -> (t, a)
195+convertDeclaration _ _ = Nothing
196+
197+convertComments :: [P.Comment] -> Maybe String
198+convertComments cs = do
199+ let raw = concatMap toLines cs
200+ guard (all hasPipe raw && not (null raw))
201+ return (go raw)
202+ where
203+ go = unlines . map stripPipes
204+
205+ toLines (P.LineComment s) = [s]
206+ toLines (P.BlockComment s) = lines s
207+
208+ hasPipe s = case dropWhile (== ' ') s of { ('|':_) -> True; _ -> False }
209+
210+ stripPipes = dropPipe . dropWhile (== ' ')
211+
212+ dropPipe ('|':' ':s) = s
213+ dropPipe ('|':s) = s
214+ dropPipe s = s
215+
216+-- | Go through a PureScript module and extract a list of Bookmarks; references
217+-- to data types or values, to be used as a kind of index. These are used for
218+-- generating links in the HTML documentation, for example.
219+collectBookmarks :: InPackage P.Module -> [Bookmark]
220+collectBookmarks (Local m) = map Local (collectBookmarks' m)
221+collectBookmarks (FromDep pkg m) = map (FromDep pkg) (collectBookmarks' m)
222+
223+collectBookmarks' :: P.Module -> [(P.ModuleName, String)]
224+collectBookmarks' m =
225+ map (P.getModuleName m, )
226+ (mapMaybe getDeclarationTitle
227+ (P.exportedDeclarations m))
228+
src/Language/PureScript/Docs/ParseAndDesugar.hsnew file+120
@@ -0,0 +1,120 @@
1+{-# LANGUAGE TupleSections #-}
2+
3+module Language.PureScript.Docs.ParseAndDesugar
4+ ( parseAndDesugar
5+ , ParseDesugarError(..)
6+ ) where
7+
8+import qualified Data.Map as M
9+import Control.Arrow (first)
10+import Control.Monad
11+import Control.Applicative
12+
13+import Control.Monad.Trans.Except
14+import Control.Monad.Error.Class (MonadError(..))
15+import Control.Monad.IO.Class (MonadIO(..))
16+
17+import Web.Bower.PackageMeta (PackageName)
18+
19+import qualified Language.PureScript as P
20+import qualified Language.PureScript.Constants as C
21+import Language.PureScript.Docs.Types
22+import Language.PureScript.Docs.Convert (collectBookmarks)
23+
24+data ParseDesugarError
25+ = ParseError P.MultipleErrors
26+ | SortModulesError P.MultipleErrors
27+ | DesugarError P.MultipleErrors
28+ deriving (Show)
29+
30+-- |
31+-- Given:
32+--
33+-- * A list of local source files
34+-- * A list of source files from external dependencies, together with their
35+-- package names
36+-- * A callback, taking a list of bookmarks, and a list of desugared modules
37+--
38+-- This function does the following:
39+--
40+-- * Parse all of the input and dependency source files
41+-- * Partially desugar all of the resulting modules
42+-- * Collect a list of bookmarks from the whole set of source files
43+-- * Collect a list of desugared modules from just the input source files (not
44+-- dependencies)
45+-- * Call the callback with the bookmarks and desugared module list.
46+parseAndDesugar ::
47+ [FilePath]
48+ -> [(PackageName, FilePath)]
49+ -> ([Bookmark] -> [P.Module] -> IO a)
50+ -> IO (Either ParseDesugarError a)
51+parseAndDesugar inputFiles depsFiles callback = do
52+ inputFiles' <- mapM (parseAs Local) inputFiles
53+ depsFiles' <- mapM (\(pkgName, f) -> parseAs (FromDep pkgName) f) depsFiles
54+
55+ runExceptT $ do
56+ let eParsed = P.parseModulesFromFiles fileInfoToString (inputFiles' ++ depsFiles')
57+ ms <- throwLeft ParseError eParsed
58+
59+ let depsModules = getDepsModuleNames (map (\(fp, m) -> (,m) <$> fp) ms)
60+ let eSorted = P.sortModules . map (importPrim . snd) $ ms
61+ (ms', _) <- throwLeft SortModulesError eSorted
62+
63+ modules <- throwLeft DesugarError (desugar ms')
64+ let modules' = map (addPackage depsModules) modules
65+ bookmarks = concatMap collectBookmarks modules'
66+ liftIO (callback bookmarks (takeLocals modules'))
67+
68+ where
69+ throwLeft f = either (throwError . f) return
70+
71+-- | Specifies whether a PureScript source file is considered as:
72+--
73+-- 1) with the `Local` constructor, a target source file, i.e., we want to see
74+-- its modules in the output
75+-- 2) with the `FromDep` constructor, a dependencies source file, i.e. we do
76+-- not want its modules in the output; it is there to enable desugaring, and
77+-- to ensure that links between modules are constructed correctly.
78+type FileInfo = InPackage FilePath
79+
80+fileInfoToString :: FileInfo -> FilePath
81+fileInfoToString (Local fn) = fn
82+fileInfoToString (FromDep _ fn) = fn
83+
84+addDefaultImport :: P.ModuleName -> P.Module -> P.Module
85+addDefaultImport toImport m@(P.Module coms mn decls exps) =
86+ if isExistingImport `any` decls || mn == toImport then m
87+ else P.Module coms mn (P.ImportDeclaration toImport P.Implicit Nothing : decls) exps
88+ where
89+ isExistingImport (P.ImportDeclaration mn' _ _) | mn' == toImport = True
90+ isExistingImport (P.PositionedDeclaration _ _ d) = isExistingImport d
91+ isExistingImport _ = False
92+
93+importPrim :: P.Module -> P.Module
94+importPrim = addDefaultImport (P.ModuleName [P.ProperName C.prim])
95+
96+desugar :: [P.Module] -> Either P.MultipleErrors [P.Module]
97+desugar = P.evalSupplyT 0 . desugar'
98+ where
99+ desugar' :: [P.Module] -> P.SupplyT (Either P.MultipleErrors) [P.Module]
100+ desugar' = mapM P.desugarDoModule >=> P.desugarCasesModule >=> P.desugarImports
101+
102+parseFile :: FilePath -> IO (FilePath, String)
103+parseFile input' = (,) input' <$> readFile input'
104+
105+parseAs :: (FilePath -> a) -> FilePath -> IO (a, String)
106+parseAs g = fmap (first g) . parseFile
107+
108+getDepsModuleNames :: [InPackage (FilePath, P.Module)] -> M.Map P.ModuleName PackageName
109+getDepsModuleNames = foldl go M.empty
110+ where
111+ go deps p = deps # case p of
112+ Local _ -> id
113+ FromDep pkgName (_, m) -> M.insert (P.getModuleName m) pkgName
114+ (#) = flip ($)
115+
116+addPackage :: M.Map P.ModuleName PackageName -> P.Module -> InPackage P.Module
117+addPackage depsModules m =
118+ case M.lookup (P.getModuleName m) depsModules of
119+ Just pkgName -> FromDep pkgName m
120+ Nothing -> Local m
src/Language/PureScript/Docs/Render.hsnew file+104
@@ -0,0 +1,104 @@
1+{-# LANGUAGE RecordWildCards #-}
2+
3+-- | Functions for creating `RenderedCode` values from data types in
4+-- Language.PureScript.Docs.Types.
5+--
6+-- These functions are the ones that are used in markdown/html documentation
7+-- generation, but the intention is that you are able to supply your own
8+-- instead if necessary. For example, the Hoogle input file generator
9+-- substitutes some of these
10+
11+module Language.PureScript.Docs.Render where
12+
13+import Data.Monoid ((<>))
14+import qualified Language.PureScript as P
15+
16+import Language.PureScript.Docs.Types
17+import Language.PureScript.Docs.RenderedCode
18+import Language.PureScript.Docs.Utils.MonoidExtras
19+
20+renderDeclaration :: Declaration -> RenderedCode
21+renderDeclaration Declaration{..} =
22+ mintersperse sp $ case declInfo of
23+ ValueDeclaration ty ->
24+ [ ident declTitle
25+ , syntax "::"
26+ , renderType ty
27+ ]
28+ DataDeclaration dtype args ->
29+ [ keyword (show dtype)
30+ , renderType (typeApp declTitle args)
31+ ]
32+ ExternDataDeclaration kind' ->
33+ [ keywordData
34+ , renderType (P.TypeConstructor (notQualified declTitle))
35+ , syntax "::"
36+ , renderKind kind'
37+ ]
38+ TypeSynonymDeclaration args ty ->
39+ [ keywordType
40+ , renderType (typeApp declTitle args)
41+ , syntax "="
42+ , renderType ty
43+ ]
44+ TypeClassDeclaration args implies ->
45+ [ keywordClass ]
46+ ++ maybe [] (:[]) superclasses
47+ ++ [renderType (typeApp declTitle args)]
48+ ++ if (not (null declChildren)) then [keywordWhere] else []
49+
50+ where
51+ superclasses
52+ | null implies = Nothing
53+ | otherwise = Just $
54+ syntax "("
55+ <> mintersperse (syntax "," <> sp) (map renderConstraint implies)
56+ <> syntax ")" <> sp <> syntax "<="
57+
58+renderChildDeclaration :: ChildDeclaration -> RenderedCode
59+renderChildDeclaration ChildDeclaration{..} =
60+ mintersperse sp $ case cdeclInfo of
61+ ChildInstance constraints ty ->
62+ [ keywordInstance
63+ , ident cdeclTitle
64+ , syntax "::"
65+ ] ++ maybe [] (:[]) constraints'
66+ ++ [ renderType ty ]
67+ where
68+ constraints'
69+ | null constraints = Nothing
70+ | otherwise = Just $
71+ syntax "("
72+ <> renderedConstraints
73+ <> syntax ")" <> sp <> syntax "=>"
74+
75+ renderedConstraints = mintersperse (syntax "," <> sp)
76+ (map renderConstraint constraints)
77+ ChildDataConstructor args ->
78+ [ renderType typeApp' ]
79+ where
80+ typeApp' = foldl P.TypeApp ctor' args
81+ ctor' = P.TypeConstructor (notQualified cdeclTitle)
82+
83+ ChildTypeClassMember ty ->
84+ [ ident cdeclTitle
85+ , syntax "::"
86+ , renderType ty
87+ ]
88+
89+renderConstraint :: (P.Qualified P.ProperName, [P.Type]) -> RenderedCode
90+renderConstraint (pn, tys) =
91+ renderType $ foldl P.TypeApp (P.TypeConstructor pn) tys
92+
93+notQualified :: String -> P.Qualified P.ProperName
94+notQualified = P.Qualified Nothing . P.ProperName
95+
96+typeApp :: String -> [(String, Maybe P.Kind)] -> P.Type
97+typeApp title typeArgs =
98+ foldl P.TypeApp
99+ (P.TypeConstructor (notQualified title))
100+ (map toTypeVar typeArgs)
101+
102+toTypeVar :: (String, Maybe P.Kind) -> P.Type
103+toTypeVar (s, Nothing) = P.TypeVar s
104+toTypeVar (s, Just k) = P.KindedType (P.TypeVar s) k
src/Language/PureScript/Docs/RenderedCode.hsnew file+11
@@ -0,0 +1,11 @@
1+
2+-- | Data types and functions for representing a simplified form of PureScript
3+-- code, intended for use in e.g. HTML documentation.
4+
5+module Language.PureScript.Docs.RenderedCode (
6+ module RenderedCode
7+) where
8+
9+import Language.PureScript.Docs.RenderedCode.Types as RenderedCode
10+import Language.PureScript.Docs.RenderedCode.Render as RenderedCode
11+
src/Language/PureScript/Docs/RenderedCode/Render.hsnew file+165
@@ -0,0 +1,165 @@
1+
2+-- | Functions for producing RenderedCode values from PureScript Type values.
3+
4+module Language.PureScript.Docs.RenderedCode.Render (
5+ renderType,
6+ renderTypeAtom,
7+ renderRow,
8+ renderKind
9+) where
10+
11+import Data.Monoid ((<>), mconcat, mempty)
12+import Data.Maybe (fromMaybe)
13+
14+import Control.Arrow ((<+>))
15+import Control.PatternArrows
16+
17+import Language.PureScript.Names
18+import Language.PureScript.Types
19+import Language.PureScript.Kinds
20+import Language.PureScript.Pretty.Kinds
21+import Language.PureScript.Environment
22+
23+import Language.PureScript.Docs.RenderedCode.Types
24+import Language.PureScript.Docs.Utils.MonoidExtras
25+
26+typeLiterals :: Pattern () Type RenderedCode
27+typeLiterals = mkPattern match
28+ where
29+ match TypeWildcard =
30+ Just (syntax "_")
31+ match (TypeVar var) =
32+ Just (ident var)
33+ match (PrettyPrintObject row) =
34+ Just $ mintersperse sp
35+ [ syntax "{"
36+ , renderRow row
37+ , syntax "}"
38+ ]
39+ match (TypeConstructor (Qualified mn name)) =
40+ Just (ctor (show name) (maybeToContainingModule mn))
41+ match (ConstrainedType deps ty) =
42+ Just $ mintersperse sp
43+ [ syntax "(" <> constraints <> syntax ")"
44+ , syntax "=>"
45+ , renderType ty
46+ ]
47+ where
48+ constraints = mintersperse (syntax "," <> sp) (map renderDep deps)
49+ renderDep (pn, tys) =
50+ let instApp = foldl TypeApp (TypeConstructor pn) tys
51+ in renderType instApp
52+ match REmpty =
53+ Just (syntax "()")
54+ match row@RCons{} =
55+ Just (syntax "(" <> renderRow row <> syntax ")")
56+ match _ =
57+ Nothing
58+
59+-- |
60+-- Render code representing a Row
61+--
62+renderRow :: Type -> RenderedCode
63+renderRow = uncurry renderRow' . rowToList
64+ where
65+ renderRow' h t = renderHead h <> renderTail t
66+
67+renderHead :: [(String, Type)] -> RenderedCode
68+renderHead = mintersperse (syntax "," <> sp) . map renderLabel
69+
70+renderLabel :: (String, Type) -> RenderedCode
71+renderLabel (label, ty) =
72+ mintersperse sp
73+ [ ident label
74+ , syntax "::"
75+ , renderType ty
76+ ]
77+
78+renderTail :: Type -> RenderedCode
79+renderTail REmpty = mempty
80+renderTail other = sp <> syntax "|" <> sp <> renderType other
81+
82+typeApp :: Pattern () Type (Type, Type)
83+typeApp = mkPattern match
84+ where
85+ match (TypeApp f x) = Just (f, x)
86+ match _ = Nothing
87+
88+appliedFunction :: Pattern () Type (Type, Type)
89+appliedFunction = mkPattern match
90+ where
91+ match (PrettyPrintFunction arg ret) = Just (arg, ret)
92+ match _ = Nothing
93+
94+kinded :: Pattern () Type (Kind, Type)
95+kinded = mkPattern match
96+ where
97+ match (KindedType t k) = Just (k, t)
98+ match _ = Nothing
99+
100+matchTypeAtom :: Pattern () Type RenderedCode
101+matchTypeAtom = typeLiterals <+> fmap parens matchType
102+ where
103+ parens x = syntax "(" <> x <> syntax ")"
104+
105+matchType :: Pattern () Type RenderedCode
106+matchType = buildPrettyPrinter operators matchTypeAtom
107+ where
108+ operators :: OperatorTable () Type RenderedCode
109+ operators =
110+ OperatorTable [ [ AssocL typeApp $ \f x -> f <> sp <> x ]
111+ , [ AssocR appliedFunction $ \arg ret -> mintersperse sp [arg, syntax "->", ret] ]
112+ , [ Wrap forall_ $ \idents ty -> mconcat [syntax "forall", sp, mintersperse sp (map ident idents), syntax ".", sp, ty] ]
113+ , [ Wrap kinded $ \k ty -> mintersperse sp [ty, syntax "::", renderKind k] ]
114+ ]
115+
116+forall_ :: Pattern () Type ([String], Type)
117+forall_ = mkPattern match
118+ where
119+ match (PrettyPrintForAll idents ty) = Just (idents, ty)
120+ match _ = Nothing
121+
122+insertPlaceholders :: Type -> Type
123+insertPlaceholders =
124+ everywhereOnTypesTopDown convertForAlls . everywhereOnTypes convert
125+
126+dePrim :: Type -> Type
127+dePrim ty@(TypeConstructor (Qualified _ name))
128+ | ty == tyBoolean || ty == tyNumber || ty == tyString =
129+ TypeConstructor $ Qualified Nothing name
130+dePrim other = other
131+
132+convert :: Type -> Type
133+convert (TypeApp (TypeApp f arg) ret) | f == tyFunction = PrettyPrintFunction arg ret
134+convert (TypeApp o r) | o == tyObject = PrettyPrintObject r
135+convert other = other
136+
137+convertForAlls :: Type -> Type
138+convertForAlls (ForAll i ty _) = go [i] ty
139+ where
140+ go idents (ForAll ident' ty' _) = go (ident' : idents) ty'
141+ go idents other = PrettyPrintForAll idents other
142+convertForAlls other = other
143+
144+preprocessType :: Type -> Type
145+preprocessType = dePrim . insertPlaceholders
146+
147+-- |
148+-- Render code representing a Kind
149+--
150+renderKind :: Kind -> RenderedCode
151+renderKind = kind . prettyPrintKind
152+
153+-- |
154+-- Render code representing a Type, as it should appear inside parentheses
155+--
156+renderTypeAtom :: Type -> RenderedCode
157+renderTypeAtom = fromMaybe (error "Incomplete pattern") . pattern matchTypeAtom () . preprocessType
158+
159+
160+-- |
161+-- Render code representing a Type
162+--
163+renderType :: Type -> RenderedCode
164+renderType = fromMaybe (error "Incomplete pattern") . pattern matchType () . preprocessType
165+
src/Language/PureScript/Docs/RenderedCode/Types.hsnew file+191
@@ -0,0 +1,191 @@
1+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+
4+-- | Data types and functions for representing a simplified form of PureScript
5+-- code, intended for use in e.g. HTML documentation.
6+
7+module Language.PureScript.Docs.RenderedCode.Types
8+ ( RenderedCodeElement(..)
9+ , asRenderedCodeElement
10+ , ContainingModule(..)
11+ , asContainingModule
12+ , containingModuleToMaybe
13+ , maybeToContainingModule
14+ , fromContainingModule
15+ , RenderedCode
16+ , asRenderedCode
17+ , outputWith
18+ , sp
19+ , syntax
20+ , ident
21+ , ctor
22+ , kind
23+ , keyword
24+ , keywordForall
25+ , keywordData
26+ , keywordNewtype
27+ , keywordType
28+ , keywordClass
29+ , keywordInstance
30+ , keywordWhere
31+ ) where
32+
33+import Control.Applicative ((<$>), (<*>), (*>), pure)
34+import Data.Foldable
35+import Data.Monoid
36+import qualified Data.Aeson as A
37+import Data.Aeson.BetterErrors
38+import Control.Monad.Error.Class (MonadError(..))
39+
40+import qualified Language.PureScript as P
41+
42+-- |
43+-- A single element in a rendered code fragment. The intention is to support
44+-- multiple output formats. For example, plain text, or highlighted HTML.
45+--
46+data RenderedCodeElement
47+ = Syntax String
48+ | Ident String
49+ | Ctor String ContainingModule
50+ | Kind String
51+ | Keyword String
52+ | Space
53+ deriving (Show, Eq, Ord)
54+
55+instance A.ToJSON RenderedCodeElement where
56+ toJSON (Syntax str) =
57+ A.toJSON ["syntax", str]
58+ toJSON (Ident str) =
59+ A.toJSON ["ident", str]
60+ toJSON (Ctor str mn) =
61+ A.toJSON ["ctor", A.toJSON str, A.toJSON mn ]
62+ toJSON (Kind str) =
63+ A.toJSON ["kind", str]
64+ toJSON (Keyword str) =
65+ A.toJSON ["keyword", str]
66+ toJSON Space =
67+ A.toJSON ["space" :: String]
68+
69+asRenderedCodeElement :: Parse String RenderedCodeElement
70+asRenderedCodeElement =
71+ a Syntax "syntax" <|>
72+ a Ident "ident" <|>
73+ asCtor <|>
74+ a Kind "kind" <|>
75+ a Keyword "keyword" <|>
76+ asSpace <|>
77+ unableToParse
78+ where
79+ p <|> q = catchError p (const q)
80+
81+ a ctor' ctorStr = ctor' <$> (nth 0 (withString (eq ctorStr)) *> nth 1 asString)
82+ asCtor = nth 0 (withString (eq "ctor")) *> (Ctor <$> nth 1 asString <*> nth 2 asContainingModule)
83+ asSpace = nth 0 (withString (eq "space")) *> pure Space
84+
85+ eq s s' = if s == s' then Right () else Left ""
86+
87+ unableToParse = withString (Left . show)
88+
89+-- |
90+-- This type is isomorphic to 'Maybe' 'P.ModuleName'. It makes code a bit easier
91+-- to read, as the meaning is more explicit.
92+--
93+data ContainingModule
94+ = ThisModule
95+ | OtherModule P.ModuleName
96+ deriving (Show, Eq, Ord)
97+
98+instance A.ToJSON ContainingModule where
99+ toJSON mn = A.toJSON (P.runModuleName <$> containingModuleToMaybe mn)
100+
101+asContainingModule :: Parse e ContainingModule
102+asContainingModule =
103+ maybeToContainingModule <$> perhaps (P.moduleNameFromString <$> asString)
104+
105+-- |
106+-- Convert a 'Maybe' 'P.ModuleName' to a 'ContainingModule', using the obvious
107+-- isomorphism.
108+--
109+maybeToContainingModule :: Maybe P.ModuleName -> ContainingModule
110+maybeToContainingModule Nothing = ThisModule
111+maybeToContainingModule (Just mn) = OtherModule mn
112+
113+-- |
114+-- Convert a 'ContainingModule' to a 'Maybe' 'P.ModuleName', using the obvious
115+-- isomorphism.
116+--
117+containingModuleToMaybe :: ContainingModule -> Maybe P.ModuleName
118+containingModuleToMaybe ThisModule = Nothing
119+containingModuleToMaybe (OtherModule mn) = Just mn
120+
121+-- |
122+-- A version of 'fromMaybe' for 'ContainingModule' values.
123+--
124+fromContainingModule :: P.ModuleName -> ContainingModule -> P.ModuleName
125+fromContainingModule def ThisModule = def
126+fromContainingModule _ (OtherModule mn) = mn
127+
128+-- |
129+-- A type representing a highly simplified version of PureScript code, intended
130+-- for use in output formats like plain text or HTML.
131+--
132+newtype RenderedCode
133+ = RC { unRC :: [RenderedCodeElement] }
134+ deriving (Show, Eq, Ord, Monoid)
135+
136+instance A.ToJSON RenderedCode where
137+ toJSON (RC elems) = A.toJSON elems
138+
139+asRenderedCode :: Parse String RenderedCode
140+asRenderedCode = RC <$> eachInArray asRenderedCodeElement
141+
142+-- |
143+-- This function allows conversion of a 'RenderedCode' value into a value of
144+-- some other type (for example, plain text, or HTML). The first argument
145+-- is a function specifying how each individual 'RenderedCodeElement' should be
146+-- rendered.
147+--
148+outputWith :: Monoid a => (RenderedCodeElement -> a) -> RenderedCode -> a
149+outputWith f = foldMap f . unRC
150+
151+-- |
152+-- A 'RenderedCode' fragment representing a space.
153+--
154+sp :: RenderedCode
155+sp = RC [Space]
156+
157+syntax :: String -> RenderedCode
158+syntax x = RC [Syntax x]
159+
160+ident :: String -> RenderedCode
161+ident x = RC [Ident x]
162+
163+ctor :: String -> ContainingModule -> RenderedCode
164+ctor x m = RC [Ctor x m]
165+
166+kind :: String -> RenderedCode
167+kind x = RC [Kind x]
168+
169+keyword :: String -> RenderedCode
170+keyword kw = RC [Keyword kw]
171+
172+keywordForall :: RenderedCode
173+keywordForall = keyword "forall"
174+
175+keywordData :: RenderedCode
176+keywordData = keyword "data"
177+
178+keywordNewtype :: RenderedCode
179+keywordNewtype = keyword "newtype"
180+
181+keywordType :: RenderedCode
182+keywordType = keyword "type"
183+
184+keywordClass :: RenderedCode
185+keywordClass = keyword "class"
186+
187+keywordInstance :: RenderedCode
188+keywordInstance = keyword "instance"
189+
190+keywordWhere :: RenderedCode
191+keywordWhere = keyword "where"
src/Language/PureScript/Docs/Types.hsnew file+472
@@ -0,0 +1,472 @@
1+{-# LANGUAGE RecordWildCards #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+{-# LANGUAGE TupleSections #-}
4+{-# LANGUAGE RankNTypes #-}
5+
6+module Language.PureScript.Docs.Types
7+ ( module Language.PureScript.Docs.Types
8+ , module ReExports
9+ )
10+ where
11+
12+import Control.Arrow (first, (***))
13+import Control.Applicative ((<$>), (<*>))
14+import Data.Functor ((<$))
15+import Data.Maybe (mapMaybe)
16+import Data.Version
17+import Data.Aeson ((.=))
18+import qualified Data.Aeson as A
19+import Data.Aeson.BetterErrors
20+import Text.ParserCombinators.ReadP (readP_to_S)
21+import Data.Text (Text)
22+import Data.ByteString.Lazy (ByteString)
23+import qualified Data.Text as T
24+
25+import Web.Bower.PackageMeta hiding (Version)
26+
27+import qualified Language.PureScript as P
28+
29+import Language.PureScript.Docs.RenderedCode as ReExports
30+ (RenderedCode, asRenderedCode,
31+ ContainingModule(..), asContainingModule,
32+ RenderedCodeElement(..), asRenderedCodeElement)
33+
34+--------------------
35+-- Types
36+
37+data Package a = Package
38+ { pkgMeta :: PackageMeta
39+ , pkgVersion :: Version
40+ , pkgVersionTag :: String
41+ , pkgModules :: [Module]
42+ , pkgBookmarks :: [Bookmark]
43+ , pkgResolvedDependencies :: [(PackageName, Version)]
44+ , pkgGithub :: (GithubUser, GithubRepo)
45+ , pkgUploader :: a
46+ }
47+ deriving (Show, Eq, Ord)
48+
49+data NotYetKnown = NotYetKnown
50+ deriving (Show, Eq, Ord)
51+
52+type UploadedPackage = Package NotYetKnown
53+type VerifiedPackage = Package GithubUser
54+
55+verifyPackage :: GithubUser -> UploadedPackage -> VerifiedPackage
56+verifyPackage verifiedUser Package{..} =
57+ Package pkgMeta
58+ pkgVersion
59+ pkgVersionTag
60+ pkgModules
61+ pkgBookmarks
62+ pkgResolvedDependencies
63+ pkgGithub
64+ verifiedUser
65+
66+packageName :: Package a -> PackageName
67+packageName = bowerName . pkgMeta
68+
69+data Module = Module
70+ { modName :: String
71+ , modComments :: Maybe String
72+ , modDeclarations :: [Declaration]
73+ }
74+ deriving (Show, Eq, Ord)
75+
76+data Declaration = Declaration
77+ { declTitle :: String
78+ , declComments :: Maybe String
79+ , declSourceSpan :: Maybe P.SourceSpan
80+ , declChildren :: [ChildDeclaration]
81+ , declFixity :: Maybe P.Fixity
82+ , declInfo :: DeclarationInfo
83+ }
84+ deriving (Show, Eq, Ord)
85+
86+-- |
87+-- A value of this type contains information that is specific to a particular
88+-- kind of declaration (as opposed to information which exists in all kinds of
89+-- declarations, which goes into the 'Declaration' type directly).
90+--
91+-- Many of the constructors are very similar to their equivalents in the real
92+-- PureScript AST, except that they have their name elided, since this is
93+-- already available via the rdTitle field of 'Declaration'.
94+--
95+data DeclarationInfo
96+ -- |
97+ -- A value declaration, with its type.
98+ --
99+ = ValueDeclaration P.Type
100+
101+ -- |
102+ -- A data/newtype declaration, with the kind of declaration (data or
103+ -- newtype) and its type arguments. Constructors are represented as child
104+ -- declarations.
105+ --
106+ | DataDeclaration P.DataDeclType [(String, Maybe P.Kind)]
107+
108+ -- |
109+ -- A data type foreign import, with its kind.
110+ --
111+ | ExternDataDeclaration P.Kind
112+
113+ -- |
114+ -- A type synonym, with its type arguments and its type.
115+ --
116+ | TypeSynonymDeclaration [(String, Maybe P.Kind)] P.Type
117+
118+ -- |
119+ -- A type class, with its type arguments and its superclasses. Instances and
120+ -- members are represented as child declarations.
121+ --
122+ | TypeClassDeclaration [(String, Maybe P.Kind)] [P.Constraint]
123+ deriving (Show, Eq, Ord)
124+
125+declInfoToString :: DeclarationInfo -> String
126+declInfoToString (ValueDeclaration _) = "value"
127+declInfoToString (DataDeclaration _ _) = "data"
128+declInfoToString (ExternDataDeclaration _) = "externData"
129+declInfoToString (TypeSynonymDeclaration _ _) = "typeSynonym"
130+declInfoToString (TypeClassDeclaration _ _) = "typeClass"
131+
132+data ChildDeclaration = ChildDeclaration
133+ { cdeclTitle :: String
134+ , cdeclComments :: Maybe String
135+ , cdeclSourceSpan :: Maybe P.SourceSpan
136+ , cdeclInfo :: ChildDeclarationInfo
137+ }
138+ deriving (Show, Eq, Ord)
139+
140+data ChildDeclarationInfo
141+ -- |
142+ -- A type instance declaration, with its dependencies and its type.
143+ --
144+ = ChildInstance [P.Constraint] P.Type
145+
146+ -- |
147+ -- A data constructor, with its type arguments.
148+ --
149+ | ChildDataConstructor [P.Type]
150+
151+ -- |
152+ -- A type class member, with its type. Note that the type does not include
153+ -- the type class constraint; this may be added manually if desired. For
154+ -- example, `pure` from `Applicative` would be `forall a. a -> f a`.
155+ --
156+ | ChildTypeClassMember P.Type
157+ deriving (Show, Eq, Ord)
158+
159+childDeclInfoToString :: ChildDeclarationInfo -> String
160+childDeclInfoToString (ChildInstance _ _) = "instance"
161+childDeclInfoToString (ChildDataConstructor _) = "dataConstructor"
162+childDeclInfoToString (ChildTypeClassMember _) = "typeClassMember"
163+
164+newtype GithubUser
165+ = GithubUser { runGithubUser :: String }
166+ deriving (Show, Eq, Ord)
167+
168+newtype GithubRepo
169+ = GithubRepo { runGithubRepo :: String }
170+ deriving (Show, Eq, Ord)
171+
172+data PackageError
173+ = ErrorInPackageMeta BowerError
174+ | InvalidVersion
175+ | InvalidDeclarationType String
176+ | InvalidChildDeclarationType String
177+ | InvalidFixity
178+ | InvalidKind String
179+ | InvalidDataDeclType String
180+ deriving (Show, Eq, Ord)
181+
182+type Bookmark = InPackage (P.ModuleName, String)
183+
184+data InPackage a
185+ = Local a
186+ | FromDep PackageName a
187+ deriving (Show, Eq, Ord)
188+
189+instance Functor InPackage where
190+ fmap f (Local x) = Local (f x)
191+ fmap f (FromDep pkgName x) = FromDep pkgName (f x)
192+
193+takeLocal :: InPackage a -> Maybe a
194+takeLocal (Local a) = Just a
195+takeLocal _ = Nothing
196+
197+takeLocals :: [InPackage a] -> [a]
198+takeLocals = mapMaybe takeLocal
199+
200+ignorePackage :: InPackage a -> a
201+ignorePackage (Local x) = x
202+ignorePackage (FromDep _ x) = x
203+
204+----------------------
205+-- Parsing
206+
207+parseUploadedPackage :: ByteString -> Either (ParseError PackageError) UploadedPackage
208+parseUploadedPackage = parse asUploadedPackage
209+
210+parseVerifiedPackage :: ByteString -> Either (ParseError PackageError) VerifiedPackage
211+parseVerifiedPackage = parse asVerifiedPackage
212+
213+asPackage :: (forall e. Parse e a) -> Parse PackageError (Package a)
214+asPackage uploader =
215+ Package <$> key "packageMeta" asPackageMeta .! ErrorInPackageMeta
216+ <*> key "version" asVersion
217+ <*> key "versionTag" asString
218+ <*> key "modules" (eachInArray asModule)
219+ <*> key "bookmarks" asBookmarks .! ErrorInPackageMeta
220+ <*> key "resolvedDependencies" asResolvedDependencies
221+ <*> key "github" asGithub
222+ <*> key "uploader" uploader
223+
224+asUploadedPackage :: Parse PackageError UploadedPackage
225+asUploadedPackage = asPackage asNotYetKnown
226+
227+asNotYetKnown :: Parse e NotYetKnown
228+asNotYetKnown = NotYetKnown <$ asNull
229+
230+instance A.FromJSON NotYetKnown where
231+ parseJSON = toAesonParser' asNotYetKnown
232+
233+asVerifiedPackage :: Parse PackageError VerifiedPackage
234+asVerifiedPackage = asPackage asGithubUser
235+
236+asGithubUser :: Parse e GithubUser
237+asGithubUser = GithubUser <$> asString
238+
239+instance A.FromJSON GithubUser where
240+ parseJSON = toAesonParser' asGithubUser
241+
242+instance A.FromJSON a => A.FromJSON (Package a) where
243+ -- TODO: actual error display
244+ parseJSON = toAesonParser (T.pack . show)
245+ (asPackage fromAesonParser)
246+
247+asVersion :: Parse PackageError Version
248+asVersion = withString (maybe (Left InvalidVersion) Right . parseVersion')
249+
250+parseVersion' :: String -> Maybe Version
251+parseVersion' str =
252+ case filter (null . snd) $ readP_to_S parseVersion str of
253+ [(vers, "")] -> Just vers
254+ _ -> Nothing
255+
256+asModule :: Parse PackageError Module
257+asModule =
258+ Module <$> key "name" asString
259+ <*> key "comments" (perhaps asString)
260+ <*> key "declarations" (eachInArray asDeclaration)
261+
262+asDeclaration :: Parse PackageError Declaration
263+asDeclaration =
264+ Declaration <$> key "title" asString
265+ <*> key "comments" (perhaps asString)
266+ <*> key "sourceSpan" (perhaps asSourceSpan)
267+ <*> key "children" (eachInArray asChildDeclaration)
268+ <*> key "fixity" (perhaps asFixity)
269+ <*> key "info" asDeclarationInfo
270+
271+asFixity :: Parse PackageError P.Fixity
272+asFixity = P.Fixity <$> key "associativity" asAssociativity
273+ <*> key "precedence" asIntegral
274+
275+parseAssociativity :: String -> Maybe P.Associativity
276+parseAssociativity str = case str of
277+ "infix" -> Just P.Infix
278+ "infixl" -> Just P.Infixl
279+ "infixr" -> Just P.Infixr
280+ _ -> Nothing
281+
282+asAssociativity :: Parse PackageError P.Associativity
283+asAssociativity = withString (maybe (Left InvalidFixity) Right . parseAssociativity)
284+
285+asDeclarationInfo :: Parse PackageError DeclarationInfo
286+asDeclarationInfo = do
287+ ty <- key "declType" asString
288+ case ty of
289+ "value" ->
290+ ValueDeclaration <$> key "type" asType
291+ "data" ->
292+ DataDeclaration <$> key "dataDeclType" asDataDeclType
293+ <*> key "typeArguments" asTypeArguments
294+ "externData" ->
295+ ExternDataDeclaration <$> key "kind" asKind
296+ "typeSynonym" ->
297+ TypeSynonymDeclaration <$> key "arguments" asTypeArguments
298+ <*> key "type" asType
299+ "typeClass" ->
300+ TypeClassDeclaration <$> key "arguments" asTypeArguments
301+ <*> key "superclasses" (eachInArray asConstraint)
302+ other ->
303+ throwCustomError (InvalidDeclarationType other)
304+
305+asTypeArguments :: Parse PackageError [(String, Maybe P.Kind)]
306+asTypeArguments = eachInArray asTypeArgument
307+ where
308+ asTypeArgument = (,) <$> nth 0 asString <*> nth 1 (perhaps asKind)
309+
310+asKind :: Parse e P.Kind
311+asKind = fromAesonParser
312+
313+asType :: Parse e P.Type
314+asType = fromAesonParser
315+
316+asDataDeclType :: Parse PackageError P.DataDeclType
317+asDataDeclType =
318+ withString $ \s -> case s of
319+ "data" -> Right P.Data
320+ "newtype" -> Right P.Newtype
321+ other -> Left (InvalidDataDeclType other)
322+
323+asChildDeclaration :: Parse PackageError ChildDeclaration
324+asChildDeclaration =
325+ ChildDeclaration <$> key "title" asString
326+ <*> key "comments" (perhaps asString)
327+ <*> key "sourceSpan" (perhaps asSourceSpan)
328+ <*> key "info" asChildDeclarationInfo
329+
330+asChildDeclarationInfo :: Parse PackageError ChildDeclarationInfo
331+asChildDeclarationInfo = do
332+ ty <- key "declType" asString
333+ case ty of
334+ "instance" ->
335+ ChildInstance <$> key "dependencies" (eachInArray asConstraint)
336+ <*> key "type" asType
337+ "dataConstructor" ->
338+ ChildDataConstructor <$> key "arguments" (eachInArray asType)
339+ "typeClassMember" ->
340+ ChildTypeClassMember <$> key "type" asType
341+ other ->
342+ throwCustomError $ InvalidChildDeclarationType other
343+
344+asSourcePos :: Parse e P.SourcePos
345+asSourcePos = P.SourcePos <$> nth 0 asIntegral
346+ <*> nth 1 asIntegral
347+
348+asConstraint :: Parse PackageError P.Constraint
349+asConstraint = (,) <$> nth 0 asQualifiedProperName
350+ <*> nth 1 (eachInArray asType)
351+
352+asQualifiedProperName :: Parse e (P.Qualified P.ProperName)
353+asQualifiedProperName = fromAesonParser
354+
355+asBookmarks :: Parse BowerError [Bookmark]
356+asBookmarks = eachInArray asBookmark
357+
358+asBookmark :: Parse BowerError Bookmark
359+asBookmark =
360+ build <$> key "package" (perhaps (withString parsePackageName))
361+ <*> key "item" ((,) <$> nth 0 (P.moduleNameFromString <$> asString)
362+ <*> nth 1 asString)
363+ where
364+ build Nothing = Local
365+ build (Just pn) = FromDep pn
366+
367+asResolvedDependencies :: Parse PackageError [(PackageName, Version)]
368+asResolvedDependencies =
369+ eachInObjectWithKey (mapLeft ErrorInPackageMeta . parsePackageName . T.unpack) asVersion
370+ where
371+ mapLeft f (Left x) = Left (f x)
372+ mapLeft _ (Right x) = Right x
373+
374+asGithub :: Parse e (GithubUser, GithubRepo)
375+asGithub = (,) <$> nth 0 (GithubUser <$> asString)
376+ <*> nth 1 (GithubRepo <$> asString)
377+
378+asSourceSpan :: Parse e P.SourceSpan
379+asSourceSpan = P.SourceSpan <$> key "name" asString
380+ <*> key "start" asSourcePos
381+ <*> key "end" asSourcePos
382+
383+---------------------
384+-- ToJSON instances
385+
386+instance A.ToJSON a => A.ToJSON (Package a) where
387+ toJSON Package{..} =
388+ A.object $
389+ [ "packageMeta" .= pkgMeta
390+ , "version" .= showVersion pkgVersion
391+ , "versionTag" .= pkgVersionTag
392+ , "modules" .= pkgModules
393+ , "bookmarks" .= map (fmap (first P.runModuleName)) pkgBookmarks
394+ , "resolvedDependencies" .= assocListToJSON (T.pack . runPackageName)
395+ (T.pack . showVersion)
396+ pkgResolvedDependencies
397+ , "github" .= pkgGithub
398+ , "uploader" .= pkgUploader
399+ ]
400+
401+instance A.ToJSON NotYetKnown where
402+ toJSON _ = A.Null
403+
404+instance A.ToJSON Module where
405+ toJSON Module{..} =
406+ A.object [ "name" .= modName
407+ , "comments" .= modComments
408+ , "declarations" .= modDeclarations
409+ ]
410+
411+instance A.ToJSON Declaration where
412+ toJSON Declaration{..} =
413+ A.object [ "title" .= declTitle
414+ , "comments" .= declComments
415+ , "sourceSpan" .= declSourceSpan
416+ , "children" .= declChildren
417+ , "fixity" .= declFixity
418+ , "info" .= declInfo
419+ ]
420+
421+instance A.ToJSON ChildDeclaration where
422+ toJSON ChildDeclaration{..} =
423+ A.object [ "title" .= cdeclTitle
424+ , "comments" .= cdeclComments
425+ , "sourceSpan" .= cdeclSourceSpan
426+ , "info" .= cdeclInfo
427+ ]
428+
429+instance A.ToJSON DeclarationInfo where
430+ toJSON info = A.object $ "declType" .= declInfoToString info : props
431+ where
432+ props = case info of
433+ ValueDeclaration ty -> ["type" .= ty]
434+ DataDeclaration ty args -> ["dataDeclType" .= ty, "typeArguments" .= args]
435+ ExternDataDeclaration kind -> ["kind" .= kind]
436+ TypeSynonymDeclaration args ty -> ["arguments" .= args, "type" .= ty]
437+ TypeClassDeclaration args super -> ["arguments" .= args, "superclasses" .= super]
438+
439+instance A.ToJSON ChildDeclarationInfo where
440+ toJSON info = A.object $ "declType" .= childDeclInfoToString info : props
441+ where
442+ props = case info of
443+ ChildInstance deps ty -> ["dependencies" .= deps, "type" .= ty]
444+ ChildDataConstructor args -> ["arguments" .= args]
445+ ChildTypeClassMember ty -> ["type" .= ty]
446+
447+instance A.ToJSON GithubUser where
448+ toJSON = A.toJSON . runGithubUser
449+
450+instance A.ToJSON GithubRepo where
451+ toJSON = A.toJSON . runGithubRepo
452+
453+-- | Given a function for turning association list keys into JSON object keys,
454+-- and a function for turning association list values to JSON string values,
455+-- turns an association list into a JSON object.
456+--
457+-- For example:
458+-- @assocListToJSON T.pack T.pack [("a", "b")]@ will give @{"a": "b"}@.
459+assocListToJSON :: (a -> Text) -> (b -> Text) -> [(a, b)] -> A.Value
460+assocListToJSON f g xs = A.object (map (uncurry (.=) . (f *** g)) xs)
461+
462+instance A.ToJSON a => A.ToJSON (InPackage a) where
463+ toJSON x =
464+ case x of
465+ Local y -> withPackage (Nothing :: Maybe ()) y
466+ FromDep pn y -> withPackage (Just pn) y
467+ where
468+ withPackage :: (A.ToJSON p, A.ToJSON x) => p -> x -> A.Value
469+ withPackage p y =
470+ A.object [ "package" .= p
471+ , "item" .= y
472+ ]
src/Language/PureScript/Docs/Utils/MonoidExtras.hsnew file+9
@@ -0,0 +1,9 @@
1+module Language.PureScript.Docs.Utils.MonoidExtras where
2+
3+import Data.Monoid
4+
5+mintersperse :: (Monoid m) => m -> [m] -> m
6+mintersperse _ [] = mempty
7+mintersperse _ [x] = x
8+mintersperse sep (x:xs) = x <> sep <> mintersperse sep xs
9+
src/Language/PureScript/Environment.hsnew file+260
@@ -0,0 +1,260 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Environment
4+-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+--
13+-----------------------------------------------------------------------------
14+
15+{-# LANGUAGE DeriveDataTypeable #-}
16+{-# LANGUAGE OverloadedStrings #-}
17+
18+module Language.PureScript.Environment where
19+
20+import Data.Data
21+import Data.Maybe (fromMaybe)
22+import qualified Data.Map as M
23+import qualified Data.Text as T
24+import qualified Data.Aeson as A
25+
26+import Language.PureScript.Kinds
27+import Language.PureScript.Names
28+import Language.PureScript.TypeClassDictionaries
29+import Language.PureScript.Types
30+import qualified Language.PureScript.Constants as C
31+
32+-- |
33+-- The @Environment@ defines all values and types which are currently in scope:
34+--
35+data Environment = Environment {
36+ -- |
37+ -- Value names currently in scope
38+ --
39+ names :: M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility)
40+ -- |
41+ -- Type names currently in scope
42+ --
43+ , types :: M.Map (Qualified ProperName) (Kind, TypeKind)
44+ -- |
45+ -- Data constructors currently in scope, along with their associated data type constructors
46+ --
47+ , dataConstructors :: M.Map (Qualified ProperName) (DataDeclType, ProperName, Type, [Ident])
48+ -- |
49+ -- Type synonyms currently in scope
50+ --
51+ , typeSynonyms :: M.Map (Qualified ProperName) ([(String, Maybe Kind)], Type)
52+ -- |
53+ -- Available type class dictionaries
54+ --
55+ , typeClassDictionaries :: M.Map (Maybe ModuleName) (M.Map (Qualified ProperName) (M.Map (Qualified Ident) TypeClassDictionaryInScope))
56+ -- |
57+ -- Type classes
58+ --
59+ , typeClasses :: M.Map (Qualified ProperName) ([(String, Maybe Kind)], [(Ident, Type)], [Constraint])
60+ } deriving (Show)
61+
62+-- |
63+-- The initial environment with no values and only the default javascript types defined
64+--
65+initEnvironment :: Environment
66+initEnvironment = Environment M.empty primTypes M.empty M.empty M.empty M.empty
67+
68+-- |
69+-- The visibility of a name in scope
70+--
71+data NameVisibility
72+ -- |
73+ -- The name is defined in the current binding group, but is not visible
74+ --
75+ = Undefined
76+ -- |
77+ -- The name is defined in the another binding group, or has been made visible by a function binder
78+ --
79+ | Defined deriving (Show, Eq)
80+
81+-- |
82+-- A flag for whether a name is for an private or public value - only public values will be
83+-- included in a generated externs file.
84+--
85+data NameKind
86+ -- |
87+ -- A private value introduced as an artifact of code generation (class instances, class member
88+ -- accessors, etc.)
89+ --
90+ = Private
91+ -- |
92+ -- A public value for a module member or foreing import declaration
93+ --
94+ | Public
95+ -- |
96+ -- A name for member introduced by foreign import
97+ --
98+ | External deriving (Show, Eq, Data, Typeable)
99+
100+-- |
101+-- The kinds of a type
102+--
103+data TypeKind
104+ -- |
105+ -- Data type
106+ --
107+ = DataType [(String, Maybe Kind)] [(ProperName, [Type])]
108+ -- |
109+ -- Type synonym
110+ --
111+ | TypeSynonym
112+ -- |
113+ -- Foreign data
114+ --
115+ | ExternData
116+ -- |
117+ -- A local type variable
118+ --
119+ | LocalTypeVariable
120+ -- |
121+ -- A scoped type variable
122+ --
123+ | ScopedTypeVar
124+ deriving (Show, Eq, Data, Typeable)
125+
126+-- |
127+-- The type ('data' or 'newtype') of a data type declaration
128+--
129+data DataDeclType
130+ -- |
131+ -- A standard data constructor
132+ --
133+ = Data
134+ -- |
135+ -- A newtype constructor
136+ --
137+ | Newtype deriving (Eq, Ord, Data, Typeable)
138+
139+instance Show DataDeclType where
140+ show Data = "data"
141+ show Newtype = "newtype"
142+
143+instance A.ToJSON DataDeclType where
144+ toJSON = A.toJSON . show
145+
146+instance A.FromJSON DataDeclType where
147+ parseJSON = A.withText "DataDeclType" $ \str ->
148+ case str of
149+ "data" -> return Data
150+ "newtype" -> return Newtype
151+ other -> fail $ "invalid type: '" ++ T.unpack other ++ "'"
152+
153+-- |
154+-- Construct a ProperName in the Prim module
155+--
156+primName :: String -> Qualified ProperName
157+primName = Qualified (Just $ ModuleName [ProperName C.prim]) . ProperName
158+
159+-- |
160+-- Construct a type in the Prim module
161+--
162+primTy :: String -> Type
163+primTy = TypeConstructor . primName
164+
165+-- |
166+-- Type constructor for functions
167+--
168+tyFunction :: Type
169+tyFunction = primTy "Function"
170+
171+-- |
172+-- Type constructor for strings
173+--
174+tyString :: Type
175+tyString = primTy "String"
176+
177+-- |
178+-- Type constructor for strings
179+--
180+tyChar :: Type
181+tyChar = primTy "Char"
182+
183+-- |
184+-- Type constructor for numbers
185+--
186+tyNumber :: Type
187+tyNumber = primTy "Number"
188+
189+-- |
190+-- Type constructor for integers
191+--
192+tyInt :: Type
193+tyInt = primTy "Int"
194+
195+-- |
196+-- Type constructor for booleans
197+--
198+tyBoolean :: Type
199+tyBoolean = primTy "Boolean"
200+
201+-- |
202+-- Type constructor for arrays
203+--
204+tyArray :: Type
205+tyArray = primTy "Array"
206+
207+-- |
208+-- Type constructor for objects
209+--
210+tyObject :: Type
211+tyObject = primTy "Object"
212+
213+-- |
214+-- Check whether a type is an object
215+--
216+isObject :: Type -> Bool
217+isObject = (==) tyObject . extract
218+ where extract (TypeApp t _) = t
219+ extract t = t
220+
221+-- |
222+-- Smart constructor for function types
223+--
224+function :: Type -> Type -> Type
225+function t1 = TypeApp (TypeApp tyFunction t1)
226+
227+-- |
228+-- The primitive types in the external javascript environment with their associated kinds.
229+--
230+primTypes :: M.Map (Qualified ProperName) (Kind, TypeKind)
231+primTypes = M.fromList [ (primName "Function" , (FunKind Star (FunKind Star Star), ExternData))
232+ , (primName "Array" , (FunKind Star Star, ExternData))
233+ , (primName "Object" , (FunKind (Row Star) Star, ExternData))
234+ , (primName "String" , (Star, ExternData))
235+ , (primName "Char" , (Star, ExternData))
236+ , (primName "Number" , (Star, ExternData))
237+ , (primName "Int" , (Star, ExternData))
238+ , (primName "Boolean" , (Star, ExternData)) ]
239+
240+-- |
241+-- Finds information about data constructors from the current environment.
242+--
243+lookupConstructor :: Environment -> Qualified ProperName -> (DataDeclType, ProperName, Type, [Ident])
244+lookupConstructor env ctor =
245+ fromMaybe (error "Data constructor not found") $ ctor `M.lookup` dataConstructors env
246+
247+-- |
248+-- Checks whether a data constructor is for a newtype.
249+--
250+isNewtypeConstructor :: Environment -> Qualified ProperName -> Bool
251+isNewtypeConstructor e ctor = case lookupConstructor e ctor of
252+ (Newtype, _, _, _) -> True
253+ (Data, _, _, _) -> False
254+
255+-- |
256+-- Finds information about values from the current environment.
257+--
258+lookupValue :: Environment -> Qualified Ident -> Maybe (Type, NameKind, NameVisibility)
259+lookupValue env (Qualified (Just mn) ident) = (mn, ident) `M.lookup` names env
260+lookupValue _ _ = Nothing
src/Language/PureScript/Errors.hsnew file+792
@@ -0,0 +1,792 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Error
4+-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+--
13+-----------------------------------------------------------------------------
14+
15+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
16+{-# LANGUAGE FlexibleContexts #-}
17+{-# LANGUAGE MultiParamTypeClasses #-}
18+
19+module Language.PureScript.Errors where
20+
21+import Data.Either (lefts, rights)
22+import Data.List (intercalate)
23+import Data.Function (on)
24+import Data.Monoid
25+import Data.Foldable (fold, foldMap)
26+
27+import qualified Data.Map as M
28+
29+import Control.Monad
30+import Control.Monad.Unify
31+import Control.Monad.Writer
32+import Control.Monad.Error.Class (MonadError(..))
33+import Control.Applicative ((<$>), (<*>), Applicative, pure)
34+import Control.Monad.Trans.State.Lazy
35+import Control.Arrow(first)
36+
37+import Language.PureScript.AST
38+import Language.PureScript.Environment (isObject)
39+import Language.PureScript.Pretty
40+import Language.PureScript.Types
41+import Language.PureScript.Names
42+import Language.PureScript.Kinds
43+import Language.PureScript.TypeClassDictionaries
44+
45+import qualified Text.PrettyPrint.Boxes as Box
46+
47+import qualified Text.Parsec as P
48+
49+-- |
50+-- A type of error messages
51+--
52+data SimpleErrorMessage
53+ = ErrorParsingExterns P.ParseError
54+ | ErrorParsingFFIModule FilePath
55+ | ErrorParsingModule P.ParseError
56+ | MissingFFIModule ModuleName
57+ | MultipleFFIModules ModuleName [FilePath]
58+ | UnnecessaryFFIModule ModuleName FilePath
59+ | InvalidExternsFile FilePath
60+ | CannotGetFileInfo FilePath
61+ | CannotReadFile FilePath
62+ | CannotWriteFile FilePath
63+ | InfiniteType Type
64+ | InfiniteKind Kind
65+ | CannotReorderOperators
66+ | MultipleFixities Ident
67+ | OrphanTypeDeclaration Ident
68+ | OrphanFixityDeclaration String
69+ | RedefinedModule ModuleName
70+ | RedefinedIdent Ident
71+ | OverlappingNamesInLet
72+ | UnknownModule ModuleName
73+ | UnknownType (Qualified ProperName)
74+ | UnknownTypeClass (Qualified ProperName)
75+ | UnknownValue (Qualified Ident)
76+ | UnknownDataConstructor (Qualified ProperName) (Maybe (Qualified ProperName))
77+ | UnknownTypeConstructor (Qualified ProperName)
78+ | ConflictingImport String ModuleName
79+ | ConflictingImports String ModuleName ModuleName
80+ | ConflictingTypeDecls ProperName
81+ | ConflictingCtorDecls ProperName
82+ | TypeConflictsWithClass ProperName
83+ | CtorConflictsWithClass ProperName
84+ | ClassConflictsWithType ProperName
85+ | ClassConflictsWithCtor ProperName
86+ | DuplicateClassExport ProperName
87+ | DuplicateValueExport Ident
88+ | DuplicateTypeArgument String
89+ | InvalidDoBind
90+ | InvalidDoLet
91+ | CycleInDeclaration Ident
92+ | CycleInTypeSynonym (Maybe ProperName)
93+ | CycleInModules [ModuleName]
94+ | NameIsUndefined Ident
95+ | NameNotInScope Ident
96+ | UndefinedTypeVariable ProperName
97+ | PartiallyAppliedSynonym (Qualified ProperName)
98+ | EscapedSkolem (Maybe Expr)
99+ | UnspecifiedSkolemScope
100+ | TypesDoNotUnify Type Type
101+ | KindsDoNotUnify Kind Kind
102+ | ConstrainedTypeUnified Type Type
103+ | OverlappingInstances (Qualified ProperName) [Type] [DictionaryValue]
104+ | NoInstanceFound (Qualified ProperName) [Type]
105+ | DuplicateLabel String (Maybe Expr)
106+ | DuplicateValueDeclaration Ident
107+ | ArgListLengthsDiffer Ident
108+ | OverlappingArgNames (Maybe Ident)
109+ | MissingClassMember Ident
110+ | ExtraneousClassMember Ident
111+ | ExpectedType Kind
112+ | IncorrectConstructorArity (Qualified ProperName)
113+ | SubsumptionCheckFailed
114+ | ExprDoesNotHaveType Expr Type
115+ | PropertyIsMissing String Type
116+ | CannotApplyFunction Type Expr
117+ | TypeSynonymInstance
118+ | InvalidNewtype
119+ | InvalidInstanceHead Type
120+ | TransitiveExportError DeclarationRef [DeclarationRef]
121+ | ShadowedName Ident
122+ | WildcardInferredType Type
123+ | ClassOperator ProperName Ident
124+ deriving (Show)
125+
126+-- |
127+-- Wrapper of simpler errors
128+--
129+data ErrorMessage
130+ = NotYetDefined [Ident] ErrorMessage
131+ | ErrorUnifyingTypes Type Type ErrorMessage
132+ | ErrorInExpression Expr ErrorMessage
133+ | ErrorInModule ModuleName ErrorMessage
134+ | ErrorInInstance (Qualified ProperName) [Type] ErrorMessage
135+ | ErrorInSubsumption Type Type ErrorMessage
136+ | ErrorCheckingType Expr Type ErrorMessage
137+ | ErrorCheckingKind Type ErrorMessage
138+ | ErrorInferringType Expr ErrorMessage
139+ | ErrorInApplication Expr Type Expr ErrorMessage
140+ | ErrorInDataConstructor ProperName ErrorMessage
141+ | ErrorInTypeConstructor ProperName ErrorMessage
142+ | ErrorInBindingGroup [Ident] ErrorMessage
143+ | ErrorInDataBindingGroup ErrorMessage
144+ | ErrorInTypeSynonym ProperName ErrorMessage
145+ | ErrorInValueDeclaration Ident ErrorMessage
146+ | ErrorInForeignImport Ident ErrorMessage
147+ | PositionedError SourceSpan ErrorMessage
148+ | SimpleErrorWrapper SimpleErrorMessage
149+ deriving (Show)
150+
151+instance UnificationError Type ErrorMessage where
152+ occursCheckFailed t = SimpleErrorWrapper $ InfiniteType t
153+
154+instance UnificationError Kind ErrorMessage where
155+ occursCheckFailed k = SimpleErrorWrapper $ InfiniteKind k
156+
157+-- |
158+-- Get the error code for a particular error type
159+--
160+errorCode :: ErrorMessage -> String
161+errorCode em = case unwrapErrorMessage em of
162+ (ErrorParsingExterns _) -> "ErrorParsingExterns"
163+ (ErrorParsingFFIModule _) -> "ErrorParsingFFIModule"
164+ (ErrorParsingModule _) -> "ErrorParsingModule"
165+ MissingFFIModule{} -> "MissingFFIModule"
166+ MultipleFFIModules{} -> "MultipleFFIModules"
167+ UnnecessaryFFIModule{} -> "UnnecessaryFFIModule"
168+ (InvalidExternsFile _) -> "InvalidExternsFile"
169+ (CannotGetFileInfo _) -> "CannotGetFileInfo"
170+ (CannotReadFile _) -> "CannotReadFile"
171+ (CannotWriteFile _) -> "CannotWriteFile"
172+ (InfiniteType _) -> "InfiniteType"
173+ (InfiniteKind _) -> "InfiniteKind"
174+ CannotReorderOperators -> "CannotReorderOperators"
175+ (MultipleFixities _) -> "MultipleFixities"
176+ (OrphanTypeDeclaration _) -> "OrphanTypeDeclaration"
177+ (OrphanFixityDeclaration _) -> "OrphanFixityDeclaration"
178+ (RedefinedModule _) -> "RedefinedModule"
179+ (RedefinedIdent _) -> "RedefinedIdent"
180+ OverlappingNamesInLet -> "OverlappingNamesInLet"
181+ (UnknownModule _) -> "UnknownModule"
182+ (UnknownType _) -> "UnknownType"
183+ (UnknownTypeClass _) -> "UnknownTypeClass"
184+ (UnknownValue _) -> "UnknownValue"
185+ (UnknownDataConstructor _ _) -> "UnknownDataConstructor"
186+ (UnknownTypeConstructor _) -> "UnknownTypeConstructor"
187+ (ConflictingImport _ _) -> "ConflictingImport"
188+ (ConflictingImports _ _ _) -> "ConflictingImports"
189+ (ConflictingTypeDecls _) -> "ConflictingTypeDecls"
190+ (ConflictingCtorDecls _) -> "ConflictingCtorDecls"
191+ (TypeConflictsWithClass _) -> "TypeConflictsWithClass"
192+ (CtorConflictsWithClass _) -> "CtorConflictsWithClass"
193+ (ClassConflictsWithType _) -> "ClassConflictsWithType"
194+ (ClassConflictsWithCtor _) -> "ClassConflictsWithCtor"
195+ (DuplicateClassExport _) -> "DuplicateClassExport"
196+ (DuplicateValueExport _) -> "DuplicateValueExport"
197+ (DuplicateTypeArgument _) -> "DuplicateTypeArgument"
198+ InvalidDoBind -> "InvalidDoBind"
199+ InvalidDoLet -> "InvalidDoLet"
200+ (CycleInDeclaration _) -> "CycleInDeclaration"
201+ (CycleInTypeSynonym _) -> "CycleInTypeSynonym"
202+ (CycleInModules _) -> "CycleInModules"
203+ (NameIsUndefined _) -> "NameIsUndefined"
204+ (NameNotInScope _) -> "NameNotInScope"
205+ (UndefinedTypeVariable _) -> "UndefinedTypeVariable"
206+ (PartiallyAppliedSynonym _) -> "PartiallyAppliedSynonym"
207+ (EscapedSkolem _) -> "EscapedSkolem"
208+ UnspecifiedSkolemScope -> "UnspecifiedSkolemScope"
209+ (TypesDoNotUnify _ _) -> "TypesDoNotUnify"
210+ (KindsDoNotUnify _ _) -> "KindsDoNotUnify"
211+ (ConstrainedTypeUnified _ _) -> "ConstrainedTypeUnified"
212+ (OverlappingInstances _ _ _) -> "OverlappingInstances"
213+ (NoInstanceFound _ _) -> "NoInstanceFound"
214+ (DuplicateLabel _ _) -> "DuplicateLabel"
215+ (DuplicateValueDeclaration _) -> "DuplicateValueDeclaration"
216+ (ArgListLengthsDiffer _) -> "ArgListLengthsDiffer"
217+ (OverlappingArgNames _) -> "OverlappingArgNames"
218+ (MissingClassMember _) -> "MissingClassMember"
219+ (ExtraneousClassMember _) -> "ExtraneousClassMember"
220+ (ExpectedType _) -> "ExpectedType"
221+ (IncorrectConstructorArity _) -> "IncorrectConstructorArity"
222+ SubsumptionCheckFailed -> "SubsumptionCheckFailed"
223+ (ExprDoesNotHaveType _ _) -> "ExprDoesNotHaveType"
224+ (PropertyIsMissing _ _) -> "PropertyIsMissing"
225+ (CannotApplyFunction _ _) -> "CannotApplyFunction"
226+ TypeSynonymInstance -> "TypeSynonymInstance"
227+ InvalidNewtype -> "InvalidNewtype"
228+ (InvalidInstanceHead _) -> "InvalidInstanceHead"
229+ (TransitiveExportError _ _) -> "TransitiveExportError"
230+ (ShadowedName _) -> "ShadowedName"
231+ (WildcardInferredType _) -> "WildcardInferredType"
232+ (ClassOperator _ _) -> "ClassOperator"
233+
234+-- |
235+-- A stack trace for an error
236+--
237+newtype MultipleErrors = MultipleErrors
238+ { runMultipleErrors :: [ErrorMessage] } deriving (Show, Monoid)
239+
240+instance UnificationError Type MultipleErrors where
241+ occursCheckFailed = occursCheckFailed
242+
243+instance UnificationError Kind MultipleErrors where
244+ occursCheckFailed = occursCheckFailed
245+
246+-- | Check whether a collection of errors is empty or not.
247+nonEmpty :: MultipleErrors -> Bool
248+nonEmpty = not . null . runMultipleErrors
249+
250+-- |
251+-- Create an error set from a single simple error message
252+--
253+errorMessage :: SimpleErrorMessage -> MultipleErrors
254+errorMessage err = MultipleErrors [SimpleErrorWrapper err]
255+
256+
257+-- |
258+-- Create an error set from a single error message
259+--
260+singleError :: ErrorMessage -> MultipleErrors
261+singleError = MultipleErrors . pure
262+
263+-- |
264+-- Lift a function on ErrorMessage to a function on MultipleErrors
265+--
266+onErrorMessages :: (ErrorMessage -> ErrorMessage) -> MultipleErrors -> MultipleErrors
267+onErrorMessages f = MultipleErrors . map f . runMultipleErrors
268+
269+-- | The various types of things which might need to be relabelled in errors messages.
270+data LabelType = TypeLabel | SkolemLabel String deriving (Show, Eq, Ord)
271+
272+-- | A map from rigid type variable name/unknown variable pairs to new variables.
273+type UnknownMap = M.Map (LabelType, Unknown) Unknown
274+
275+-- |
276+-- Extract nested error messages from wrapper errors
277+--
278+unwrapErrorMessage :: ErrorMessage -> SimpleErrorMessage
279+unwrapErrorMessage em = case em of
280+ (ErrorCheckingKind _ err) -> unwrapErrorMessage err
281+ (ErrorCheckingType _ _ err) -> unwrapErrorMessage err
282+ (ErrorInApplication _ _ _ err) -> unwrapErrorMessage err
283+ (ErrorInBindingGroup _ err) -> unwrapErrorMessage err
284+ (ErrorInDataBindingGroup err) -> unwrapErrorMessage err
285+ (ErrorInDataConstructor _ err) -> unwrapErrorMessage err
286+ (ErrorInExpression _ err) -> unwrapErrorMessage err
287+ (ErrorInForeignImport _ err) -> unwrapErrorMessage err
288+ (ErrorInInstance _ _ err) -> unwrapErrorMessage err
289+ (ErrorInModule _ err) -> unwrapErrorMessage err
290+ (ErrorInSubsumption _ _ err) -> unwrapErrorMessage err
291+ (ErrorInTypeConstructor _ err) -> unwrapErrorMessage err
292+ (ErrorInTypeSynonym _ err) -> unwrapErrorMessage err
293+ (ErrorInValueDeclaration _ err) -> unwrapErrorMessage err
294+ (ErrorInferringType _ err) -> unwrapErrorMessage err
295+ (ErrorUnifyingTypes _ _ err) -> unwrapErrorMessage err
296+ (NotYetDefined _ err) -> unwrapErrorMessage err
297+ (PositionedError _ err) -> unwrapErrorMessage err
298+ (SimpleErrorWrapper sem) -> sem
299+
300+replaceUnknowns :: Type -> State UnknownMap Type
301+replaceUnknowns = everywhereOnTypesM replaceTypes
302+ where
303+ lookupTable :: (LabelType, Unknown) -> UnknownMap -> (Unknown, UnknownMap)
304+ lookupTable x m = case M.lookup x m of
305+ Nothing -> let i = length (filter (on (==) fst x) (M.keys m)) in (i, M.insert x i m)
306+ Just i -> (i, m)
307+
308+ replaceTypes :: Type -> State UnknownMap Type
309+ replaceTypes (TUnknown u) = state $ first TUnknown . lookupTable (TypeLabel, u)
310+ replaceTypes (Skolem name s sko) = state $ first (flip (Skolem name) sko) . lookupTable (SkolemLabel name, s)
311+ replaceTypes other = return other
312+
313+onTypesInErrorMessageM :: (Applicative m) => (Type -> m Type) -> ErrorMessage -> m ErrorMessage
314+onTypesInErrorMessageM f = g
315+ where
316+ gSimple (InfiniteType t) = InfiniteType <$> (f t)
317+ gSimple (TypesDoNotUnify t1 t2) = TypesDoNotUnify <$> (f t1) <*> (f t2)
318+ gSimple (ConstrainedTypeUnified t1 t2) = ConstrainedTypeUnified <$> (f t1) <*> (f t2)
319+ gSimple (ExprDoesNotHaveType e t) = ExprDoesNotHaveType e <$> (f t)
320+ gSimple (PropertyIsMissing s t) = PropertyIsMissing s <$> (f t)
321+ gSimple (CannotApplyFunction t e) = CannotApplyFunction <$> f t <*> (pure e)
322+ gSimple (InvalidInstanceHead t) = InvalidInstanceHead <$> f t
323+ gSimple other = pure other
324+ g (ErrorInSubsumption t1 t2 em) = ErrorInSubsumption <$> (f t1) <*> (f t2) <*> (g em)
325+ g (ErrorUnifyingTypes t1 t2 e) = ErrorUnifyingTypes <$> (f t1) <*> (f t2) <*> (g e)
326+ g (ErrorCheckingType e t em) = ErrorCheckingType e <$> (f t) <*> (g em)
327+ g (ErrorCheckingKind t em) = ErrorCheckingKind <$> (f t) <*> g em
328+ g (ErrorInApplication e1 t1 e2 em) = ErrorInApplication e1 <$> (f t1) <*> (pure e2) <*> (g em)
329+ g (NotYetDefined x e) = NotYetDefined x <$> (g e)
330+ g (ErrorInExpression x e) = ErrorInExpression x <$> (g e)
331+ g (ErrorInModule x e) = ErrorInModule x <$> (g e)
332+ g (ErrorInInstance x y e) = ErrorInInstance x y <$> (g e)
333+ g (ErrorInferringType x e) = ErrorInferringType x <$> (g e)
334+ g (ErrorInDataConstructor x e) = ErrorInDataConstructor x <$> (g e)
335+ g (ErrorInTypeConstructor x e) = ErrorInTypeConstructor x <$> (g e)
336+ g (ErrorInBindingGroup x e) = ErrorInBindingGroup x <$> (g e)
337+ g (ErrorInDataBindingGroup e) = ErrorInDataBindingGroup <$> (g e)
338+ g (ErrorInTypeSynonym x e) = ErrorInTypeSynonym x <$> (g e)
339+ g (ErrorInValueDeclaration x e) = ErrorInValueDeclaration x <$> (g e)
340+ g (ErrorInForeignImport x e) = ErrorInForeignImport x <$> (g e)
341+ g (PositionedError x e) = PositionedError x <$> (g e)
342+ g (SimpleErrorWrapper sem) = SimpleErrorWrapper <$> gSimple sem
343+
344+-- |
345+-- Pretty print a single error, simplifying if necessary
346+--
347+prettyPrintSingleError :: Bool -> ErrorMessage -> State UnknownMap Box.Box
348+prettyPrintSingleError full e = prettyPrintErrorMessage <$> onTypesInErrorMessageM replaceUnknowns (if full then e else simplifyErrorMessage e)
349+ where
350+ -- |
351+ -- Pretty print an ErrorMessage
352+ --
353+ prettyPrintErrorMessage :: ErrorMessage -> Box.Box
354+ prettyPrintErrorMessage em =
355+ paras $
356+ go em:suggestions em ++
357+ [line $ "See " ++ wikiUri ++ " for more information, or to contribute content related to this error."]
358+ where
359+ wikiUri :: String
360+ wikiUri = "https://github.com/purescript/purescript/wiki/Error-Code-" ++ errorCode e
361+
362+ go :: ErrorMessage -> Box.Box
363+ goSimple (CannotGetFileInfo path) =
364+ paras [ line "Unable to read file info: "
365+ , indent . line $ path
366+ ]
367+ goSimple (CannotReadFile path) =
368+ paras [ line "Unable to read file: "
369+ , indent . line $ path
370+ ]
371+ goSimple (CannotWriteFile path) =
372+ paras [ line "Unable to write file: "
373+ , indent . line $ path
374+ ]
375+ goSimple (ErrorParsingExterns err) =
376+ paras [ line "Error parsing externs files: "
377+ , indent . line . show $ err
378+ ]
379+ goSimple (ErrorParsingFFIModule path) =
380+ paras [ line "Unable to parse module from FFI file: "
381+ , indent . line $ path
382+ ]
383+ goSimple (ErrorParsingModule err) =
384+ paras [ line "Unable to parse module: "
385+ , indent . line . show $ err
386+ ]
387+ goSimple (MissingFFIModule mn) =
388+ line $ "Missing FFI implementations for module " ++ show mn
389+ goSimple (UnnecessaryFFIModule mn path) =
390+ paras [ line $ "Unnecessary FFI implementations have been provided for module " ++ show mn ++ ": "
391+ , indent . line $ path
392+ ]
393+ goSimple (MultipleFFIModules mn paths) =
394+ paras $ [ line $ "Multiple FFI implementations have been provided for module " ++ show mn ++ ": " ]
395+ ++ map (indent . line) paths
396+ goSimple (InvalidExternsFile path) =
397+ paras [ line "Externs file is invalid: "
398+ , indent . line $ path
399+ ]
400+ goSimple InvalidDoBind =
401+ line "Bind statement cannot be the last statement in a do block"
402+ goSimple InvalidDoLet =
403+ line "Let statement cannot be the last statement in a do block"
404+ goSimple CannotReorderOperators =
405+ line "Unable to reorder operators"
406+ goSimple UnspecifiedSkolemScope =
407+ line "Skolem variable scope is unspecified"
408+ goSimple OverlappingNamesInLet =
409+ line "Overlapping names in let binding."
410+ goSimple (InfiniteType ty) =
411+ paras [ line "Infinite type detected: "
412+ , indent $ line $ prettyPrintType ty
413+ ]
414+ goSimple (InfiniteKind ki) =
415+ paras [ line "Infinite kind detected: "
416+ , indent $ line $ prettyPrintKind ki
417+ ]
418+ goSimple (MultipleFixities name) =
419+ line $ "Multiple fixity declarations for " ++ show name
420+ goSimple (OrphanTypeDeclaration nm) =
421+ line $ "Orphan type declaration for " ++ show nm
422+ goSimple (OrphanFixityDeclaration op) =
423+ line $ "Orphan fixity declaration for " ++ show op
424+ goSimple (RedefinedModule name) =
425+ line $ "Module " ++ show name ++ " has been defined multiple times"
426+ goSimple (RedefinedIdent name) =
427+ line $ "Name " ++ show name ++ " has been defined multiple times"
428+ goSimple (UnknownModule mn) =
429+ line $ "Unknown module " ++ show mn
430+ goSimple (UnknownType name) =
431+ line $ "Unknown type " ++ show name
432+ goSimple (UnknownTypeClass name) =
433+ line $ "Unknown type class " ++ show name
434+ goSimple (UnknownValue name) =
435+ line $ "Unknown value " ++ show name
436+ goSimple (UnknownTypeConstructor name) =
437+ line $ "Unknown type constructor " ++ show name
438+ goSimple (UnknownDataConstructor dc tc) =
439+ line $ "Unknown data constructor " ++ show dc ++ foldMap ((" for type constructor " ++) . show) tc
440+ goSimple (ConflictingImport nm mn) =
441+ line $ "Cannot declare `" ++ nm ++ "` since another declaration of that name was imported from `" ++ show mn ++ "`"
442+ goSimple (ConflictingImports nm m1 m2) =
443+ line $ "Conflicting imports for " ++ nm ++ " from modules " ++ show m1 ++ " and " ++ show m2
444+ goSimple (ConflictingTypeDecls nm) =
445+ line $ "Conflicting type declarations for " ++ show nm
446+ goSimple (ConflictingCtorDecls nm) =
447+ line $ "Conflicting data constructor declarations for " ++ show nm
448+ goSimple (TypeConflictsWithClass nm) =
449+ line $ "Type " ++ show nm ++ " conflicts with type class declaration of the same name"
450+ goSimple (CtorConflictsWithClass nm) =
451+ line $ "Data constructor " ++ show nm ++ " conflicts with type class declaration of the same name"
452+ goSimple (ClassConflictsWithType nm) =
453+ line $ "Type class " ++ show nm ++ " conflicts with type declaration of the same name"
454+ goSimple (ClassConflictsWithCtor nm) =
455+ line $ "Type class " ++ show nm ++ " conflicts with data constructor declaration of the same name"
456+ goSimple (DuplicateClassExport nm) =
457+ line $ "Duplicate export declaration for type class " ++ show nm
458+ goSimple (DuplicateValueExport nm) =
459+ line $ "Duplicate export declaration for value " ++ show nm
460+ goSimple (CycleInDeclaration nm) =
461+ line $ "Cycle in declaration of " ++ show nm
462+ goSimple (CycleInModules mns) =
463+ line $ "Cycle in module dependencies: " ++ intercalate ", " (map show mns)
464+ goSimple (CycleInTypeSynonym pn) =
465+ line $ "Cycle in type synonym" ++ foldMap ((" " ++) . show) pn
466+ goSimple (NameIsUndefined ident) =
467+ line $ show ident ++ " is undefined"
468+ goSimple (NameNotInScope ident) =
469+ line $ show ident ++ " may not be defined in the current scope"
470+ goSimple (UndefinedTypeVariable name) =
471+ line $ "Type variable " ++ show name ++ " is undefined"
472+ goSimple (PartiallyAppliedSynonym name) =
473+ line $ "Partially applied type synonym " ++ show name
474+ goSimple (EscapedSkolem binding) =
475+ paras $ [ line "Rigid/skolem type variable has escaped." ]
476+ <> foldMap (\expr -> [ line "Relevant expression: "
477+ , indent $ line $ prettyPrintValue expr
478+ ]) binding
479+ goSimple (TypesDoNotUnify t1 t2)
480+ = paras [ line "Cannot unify type"
481+ , indent $ line $ prettyPrintType t1
482+ , line "with type"
483+ , indent $ line $ prettyPrintType t2
484+ ]
485+ goSimple (KindsDoNotUnify k1 k2) =
486+ paras [ line "Cannot unify kind"
487+ , indent $ line $ prettyPrintKind k1
488+ , line "with kind"
489+ , indent $ line $ prettyPrintKind k2
490+ ]
491+ goSimple (ConstrainedTypeUnified t1 t2) =
492+ paras [ line "Cannot unify constrained type"
493+ , indent $ line $ prettyPrintType t1
494+ , line "with type"
495+ , indent $ line $ prettyPrintType t2
496+ ]
497+ goSimple (OverlappingInstances nm ts ds) =
498+ paras [ line $ "Overlapping instances found for " ++ show nm ++ " " ++ unwords (map prettyPrintTypeAtom ts) ++ ":"
499+ , paras $ map prettyPrintDictionaryValue ds
500+ ]
501+ goSimple (NoInstanceFound nm ts) =
502+ line $ "No instance found for " ++ show nm ++ " " ++ unwords (map prettyPrintTypeAtom ts)
503+ goSimple (DuplicateLabel l expr) =
504+ paras $ [ line $ "Duplicate label " ++ show l ++ " in row." ]
505+ <> foldMap (\expr' -> [ line "Relevant expression: "
506+ , indent $ line $ prettyPrintValue expr'
507+ ]) expr
508+ goSimple (DuplicateTypeArgument name) =
509+ line $ "Duplicate type argument " ++ show name
510+ goSimple (DuplicateValueDeclaration nm) =
511+ line $ "Duplicate value declaration for " ++ show nm
512+ goSimple (ArgListLengthsDiffer ident) =
513+ line $ "Argument list lengths differ in declaration " ++ show ident
514+ goSimple (OverlappingArgNames ident) =
515+ line $ "Overlapping names in function/binder" ++ foldMap ((" in declaration" ++) . show) ident
516+ goSimple (MissingClassMember ident) =
517+ line $ "Member " ++ show ident ++ " has not been implemented"
518+ goSimple (ExtraneousClassMember ident) =
519+ line $ "Member " ++ show ident ++ " is not a member of the class being instantiated"
520+ goSimple (ExpectedType kind) =
521+ line $ "Expected type of kind *, was " ++ prettyPrintKind kind
522+ goSimple (IncorrectConstructorArity nm) =
523+ line $ "Wrong number of arguments to constructor " ++ show nm
524+ goSimple SubsumptionCheckFailed = line $ "Unable to check type subsumption"
525+ goSimple (ExprDoesNotHaveType expr ty) =
526+ paras [ line "Expression"
527+ , indent $ line $ prettyPrintValue expr
528+ , line "does not have type"
529+ , indent $ line $ prettyPrintType ty
530+ ]
531+ goSimple (PropertyIsMissing prop row) =
532+ line $ "Row " ++ prettyPrintRow row ++ " lacks required property " ++ show prop
533+ goSimple (CannotApplyFunction fn arg) =
534+ paras [ line "Cannot apply function of type"
535+ , indent $ line $ prettyPrintType fn
536+ , line "to argument"
537+ , indent $ line $ prettyPrintValue arg
538+ ]
539+ goSimple TypeSynonymInstance =
540+ line "Type synonym instances are disallowed"
541+ goSimple InvalidNewtype =
542+ line "Newtypes must define a single constructor with a single argument"
543+ goSimple (InvalidInstanceHead ty) =
544+ paras [ line "Invalid type in class instance head:"
545+ , indent $ line $ prettyPrintType ty
546+ ]
547+ goSimple (TransitiveExportError x ys) =
548+ paras $ (line $ "An export for " ++ prettyPrintExport x ++ " requires the following to also be exported: ")
549+ : map (line . prettyPrintExport) ys
550+ goSimple (ShadowedName nm) =
551+ line $ "Name '" ++ show nm ++ "' was shadowed."
552+ goSimple (ClassOperator className opName) =
553+ paras [ line $ "Class '" ++ show className ++ "' declares operator " ++ show opName ++ "."
554+ , indent $ line $ "This may be disallowed in the future - consider declaring a named member in the class and making the operator an alias:"
555+ , indent $ line $ show opName ++ " = someMember"
556+ ]
557+ goSimple (WildcardInferredType ty) =
558+ line $ "The wildcard type definition has the inferred type " ++ prettyPrintType ty
559+ go (NotYetDefined names err) =
560+ paras [ line $ "The following are not yet defined here: " ++ intercalate ", " (map show names) ++ ":"
561+ , indent $ go err
562+ ]
563+ go (ErrorUnifyingTypes t1 t2 err) =
564+ paras [ line "Error unifying type "
565+ , indent $ line $ prettyPrintType t1
566+ , line "with type"
567+ , indent $ line $ prettyPrintType t2
568+ , go err
569+ ]
570+ go (ErrorInExpression expr err) =
571+ paras [ line "Error in expression:"
572+ , indent $ line $ prettyPrintValue expr
573+ , go err
574+ ]
575+ go (ErrorInModule mn err) =
576+ paras [ line $ "Error in module " ++ show mn ++ ":"
577+ , go err
578+ ]
579+ go (ErrorInSubsumption t1 t2 err) =
580+ paras [ line "Error checking that type "
581+ , indent $ line $ prettyPrintType t1
582+ , line "subsumes type"
583+ , indent $ line $ prettyPrintType t2
584+ , go err
585+ ]
586+ go (ErrorInInstance name ts err) =
587+ paras [ line $ "Error in type class instance " ++ show name ++ " " ++ unwords (map prettyPrintTypeAtom ts) ++ ":"
588+ , go err
589+ ]
590+ go (ErrorCheckingKind ty err) =
591+ paras [ line "Error checking kind of type "
592+ , indent $ line $ prettyPrintType ty
593+ , go err
594+ ]
595+ go (ErrorInferringType expr err) =
596+ paras [ line "Error inferring type of value "
597+ , indent $ line $ prettyPrintValue expr
598+ , go err
599+ ]
600+ go (ErrorCheckingType expr ty err) =
601+ paras [ line "Error checking that value "
602+ , indent $ line $ prettyPrintValue expr
603+ , line "has type"
604+ , indent $ line $ prettyPrintType ty
605+ , go err
606+ ]
607+ go (ErrorInApplication f t a err) =
608+ paras [ line "Error applying function"
609+ , indent $ line $ prettyPrintValue f
610+ , line "of type"
611+ , indent $ line $ prettyPrintType t
612+ , line "to argument"
613+ , indent $ line $ prettyPrintValue a
614+ , go err
615+ ]
616+ go (ErrorInDataConstructor nm err) =
617+ paras [ line $ "Error in data constructor " ++ show nm ++ ":"
618+ , go err
619+ ]
620+ go (ErrorInTypeConstructor nm err) =
621+ paras [ line $ "Error in type constructor " ++ show nm ++ ":"
622+ , go err
623+ ]
624+ go (ErrorInBindingGroup nms err) =
625+ paras [ line $ "Error in binding group " ++ intercalate ", " (map show nms) ++ ":"
626+ , go err
627+ ]
628+ go (ErrorInDataBindingGroup err) =
629+ paras [ line $ "Error in data binding group:"
630+ , go err
631+ ]
632+ go (ErrorInTypeSynonym name err) =
633+ paras [ line $ "Error in type synonym " ++ show name ++ ":"
634+ , go err
635+ ]
636+ go (ErrorInValueDeclaration n err) =
637+ paras [ line $ "Error in value declaration " ++ show n ++ ":"
638+ , go err
639+ ]
640+ go (ErrorInForeignImport nm err) =
641+ paras [ line $ "Error in foreign import " ++ show nm ++ ":"
642+ , go err
643+ ]
644+ go (PositionedError srcSpan err) =
645+ paras [ line $ "Error at " ++ displaySourceSpan srcSpan ++ ":"
646+ , indent $ go err
647+ ]
648+ go (SimpleErrorWrapper sem) = goSimple sem
649+
650+ line :: String -> Box.Box
651+ line = Box.text
652+
653+ suggestions :: ErrorMessage -> [Box.Box]
654+ suggestions = suggestions' . unwrapErrorMessage
655+ where
656+ suggestions' (ConflictingImport nm im) = [ line $ "Possible fix: hide `" ++ nm ++ "` when importing `" ++ show im ++ "`:"
657+ , indent . line $ "import " ++ show im ++ " hiding (" ++ nm ++ ")"
658+ ]
659+ suggestions' (TypesDoNotUnify t1 t2)
660+ | any isObject [t1, t2] = [line "Note that function composition in PureScript is defined using `(<<<)`"]
661+ | otherwise = []
662+ suggestions' _ = []
663+
664+ paras :: [Box.Box] -> Box.Box
665+ paras = Box.vcat Box.left
666+
667+ indent :: Box.Box -> Box.Box
668+ indent = Box.moveRight 2
669+
670+ -- |
671+ -- Render a DictionaryValue fit for human consumption in error messages
672+ --
673+ prettyPrintDictionaryValue :: DictionaryValue -> Box.Box
674+ prettyPrintDictionaryValue (LocalDictionaryValue _) = line "Dictionary in scope"
675+ prettyPrintDictionaryValue (GlobalDictionaryValue nm) = line (show nm)
676+ prettyPrintDictionaryValue (DependentDictionaryValue nm args) = paras [ line $ (show nm) ++ " via"
677+ , indent $ paras $ map prettyPrintDictionaryValue args
678+ ]
679+ prettyPrintDictionaryValue (SubclassDictionaryValue sup nm _) = paras [ line $ (show nm) ++ " via superclass"
680+ , indent $ prettyPrintDictionaryValue sup
681+ ]
682+
683+ -- |
684+ -- Pretty print and export declaration
685+ --
686+ prettyPrintExport :: DeclarationRef -> String
687+ prettyPrintExport (TypeRef pn _) = show pn
688+ prettyPrintExport (ValueRef ident) = show ident
689+ prettyPrintExport (TypeClassRef pn) = show pn
690+ prettyPrintExport (TypeInstanceRef ident) = show ident
691+ prettyPrintExport (PositionedDeclarationRef _ _ ref) = prettyPrintExport ref
692+
693+ -- |
694+ -- Simplify an error message
695+ --
696+ simplifyErrorMessage :: ErrorMessage -> ErrorMessage
697+ simplifyErrorMessage = unwrap Nothing
698+ where
699+ unwrap :: Maybe SourceSpan -> ErrorMessage -> ErrorMessage
700+ unwrap pos (ErrorInExpression _ err) = unwrap pos err
701+ unwrap pos (ErrorInInstance name ts err) = ErrorInInstance name ts (unwrap pos err)
702+ unwrap pos (ErrorInSubsumption t1 t2 err) = ErrorInSubsumption t1 t2 (unwrap pos err)
703+ unwrap pos (ErrorUnifyingTypes _ _ err) = unwrap pos err
704+ unwrap pos (ErrorInferringType _ err) = unwrap pos err
705+ unwrap pos (ErrorCheckingType _ _ err) = unwrap pos err
706+ unwrap pos (ErrorCheckingKind ty err) = ErrorCheckingKind ty (unwrap pos err)
707+ unwrap pos (ErrorInModule mn err) = ErrorInModule mn (unwrap pos err)
708+ unwrap pos (ErrorInApplication _ _ _ err) = unwrap pos err
709+ unwrap pos (ErrorInDataConstructor nm err) = ErrorInDataConstructor nm (unwrap pos err)
710+ unwrap pos (ErrorInTypeConstructor nm err) = ErrorInTypeConstructor nm (unwrap pos err)
711+ unwrap pos (ErrorInBindingGroup nms err) = ErrorInBindingGroup nms (unwrap pos err)
712+ unwrap pos (ErrorInDataBindingGroup err) = ErrorInDataBindingGroup (unwrap pos err)
713+ unwrap pos (ErrorInTypeSynonym nm err) = ErrorInTypeSynonym nm (unwrap pos err)
714+ unwrap pos (ErrorInValueDeclaration nm err) = ErrorInValueDeclaration nm (unwrap pos err)
715+ unwrap pos (ErrorInForeignImport nm err) = ErrorInForeignImport nm (unwrap pos err)
716+ unwrap pos (NotYetDefined ns err) = NotYetDefined ns (unwrap pos err)
717+ unwrap _ (PositionedError pos err) = unwrap (Just pos) err
718+ unwrap pos other = wrap pos other
719+
720+ wrap :: Maybe SourceSpan -> ErrorMessage -> ErrorMessage
721+ wrap Nothing = id
722+ wrap (Just pos) = PositionedError pos
723+
724+
725+-- |
726+-- Pretty print multiple errors
727+--
728+prettyPrintMultipleErrors :: Bool -> MultipleErrors -> String
729+prettyPrintMultipleErrors full = flip evalState M.empty . prettyPrintMultipleErrorsWith "Error:" "Multiple errors:" full
730+
731+-- |
732+-- Pretty print multiple warnings
733+--
734+prettyPrintMultipleWarnings :: Bool -> MultipleErrors -> String
735+prettyPrintMultipleWarnings full = flip evalState M.empty . prettyPrintMultipleErrorsWith "Warning:" "Multiple warnings:" full
736+
737+prettyPrintMultipleErrorsWith :: String -> String -> Bool -> MultipleErrors -> State UnknownMap String
738+prettyPrintMultipleErrorsWith intro _ full (MultipleErrors [e]) = do
739+ result <- prettyPrintSingleError full e
740+ return $ renderBox $
741+ Box.vcat Box.left [ Box.text intro
742+ , result
743+ ]
744+prettyPrintMultipleErrorsWith _ intro full (MultipleErrors es) = do
745+ result <- forM es $ (liftM $ Box.moveRight 2) . prettyPrintSingleError full
746+ return $ renderBox $
747+ Box.vcat Box.left [ Box.text intro
748+ , Box.vsep 1 Box.left result
749+ ]
750+
751+renderBox :: Box.Box -> String
752+renderBox = unlines . map trimEnd . lines . Box.render
753+ where
754+ trimEnd = reverse . dropWhile (== ' ') . reverse
755+
756+-- |
757+-- Interpret multiple errors and warnings in a monad supporting errors and warnings
758+--
759+interpretMultipleErrorsAndWarnings :: (MonadError MultipleErrors m, MonadWriter MultipleErrors m) => (Either MultipleErrors a, MultipleErrors) -> m a
760+interpretMultipleErrorsAndWarnings (err, ws) = do
761+ tell ws
762+ either throwError return $ err
763+
764+-- |
765+-- Rethrow an error with a more detailed error message in the case of failure
766+--
767+rethrow :: (MonadError e m) => (e -> e) -> m a -> m a
768+rethrow f = flip catchError $ \e -> throwError (f e)
769+
770+-- |
771+-- Rethrow an error with source position information
772+--
773+rethrowWithPosition :: (MonadError MultipleErrors m) => SourceSpan -> m a -> m a
774+rethrowWithPosition pos = rethrow (onErrorMessages withPosition)
775+ where
776+ withPosition :: ErrorMessage -> ErrorMessage
777+ withPosition (PositionedError _ err) = withPosition err
778+ withPosition err = PositionedError pos err
779+
780+-- |
781+-- Collect errors in in parallel
782+--
783+parU :: (MonadError MultipleErrors m, Functor m) => [a] -> (a -> m b) -> m [b]
784+parU xs f = forM xs (withError . f) >>= collectErrors
785+ where
786+ withError :: (MonadError MultipleErrors m, Functor m) => m a -> m (Either MultipleErrors a)
787+ withError u = catchError (Right <$> u) (return . Left)
788+
789+ collectErrors :: (MonadError MultipleErrors m, Functor m) => [Either MultipleErrors a] -> m [a]
790+ collectErrors es = case lefts es of
791+ [] -> return $ rights es
792+ errs -> throwError $ fold errs
src/Language/PureScript/Kinds.hsnew file+72
@@ -0,0 +1,72 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Kinds
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+--
13+-----------------------------------------------------------------------------
14+
15+{-# LANGUAGE DeriveDataTypeable #-}
16+{-# LANGUAGE TemplateHaskell #-}
17+
18+module Language.PureScript.Kinds where
19+
20+import Data.Data
21+import qualified Data.Aeson.TH as A
22+
23+import Control.Applicative
24+import Control.Monad.Unify (Unknown)
25+
26+-- |
27+-- The data type of kinds
28+--
29+data Kind
30+ -- |
31+ -- Unification variable of type Kind
32+ --
33+ = KUnknown Unknown
34+ -- |
35+ -- The kind of types
36+ --
37+ | Star
38+ -- |
39+ -- The kind of effects
40+ --
41+ | Bang
42+ -- |
43+ -- Kinds for labelled, unordered rows without duplicates
44+ --
45+ | Row Kind
46+ -- |
47+ -- Function kinds
48+ --
49+ | FunKind Kind Kind deriving (Show, Eq, Ord, Data, Typeable)
50+
51+$(A.deriveJSON A.defaultOptions ''Kind)
52+
53+everywhereOnKinds :: (Kind -> Kind) -> Kind -> Kind
54+everywhereOnKinds f = go
55+ where
56+ go (Row k1) = f (Row (go k1))
57+ go (FunKind k1 k2) = f (FunKind (go k1) (go k2))
58+ go other = f other
59+
60+everywhereOnKindsM :: (Functor m, Applicative m, Monad m) => (Kind -> m Kind) -> Kind -> m Kind
61+everywhereOnKindsM f = go
62+ where
63+ go (Row k1) = (Row <$> go k1) >>= f
64+ go (FunKind k1 k2) = (FunKind <$> go k1 <*> go k2) >>= f
65+ go other = f other
66+
67+everythingOnKinds :: (r -> r -> r) -> (Kind -> r) -> Kind -> r
68+everythingOnKinds (<>) f = go
69+ where
70+ go k@(Row k1) = f k <> go k1
71+ go k@(FunKind k1 k2) = f k <> go k1 <> go k2
72+ go other = f other
src/Language/PureScript/Linter.hsnew file+82
@@ -0,0 +1,82 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Linter
4+-- Copyright : (c) Copyright 2015 PureScript
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- | This module implements a simple linting pass on the PureScript AST.
12+--
13+-----------------------------------------------------------------------------
14+
15+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
16+{-# LANGUAGE FlexibleContexts #-}
17+{-# LANGUAGE ScopedTypeVariables #-}
18+
19+module Language.PureScript.Linter (lint) where
20+
21+import Data.List (mapAccumL, nub)
22+import Data.Maybe (mapMaybe)
23+import Data.Monoid
24+
25+import qualified Data.Set as S
26+
27+import Control.Applicative
28+import Control.Monad.Writer.Class
29+
30+import Language.PureScript.AST
31+import Language.PureScript.Names
32+import Language.PureScript.Errors
33+
34+-- | Lint the PureScript AST.
35+-- |
36+-- | Right now, this pass only performs a shadowing check.
37+lint :: forall m. (Applicative m, MonadWriter MultipleErrors m) => Module -> m ()
38+lint (Module _ mn ds _) = censor (onErrorMessages (ErrorInModule mn)) $ mapM_ lintDeclaration ds
39+ where
40+ moduleNames :: S.Set Ident
41+ moduleNames = S.fromList (nub (mapMaybe getDeclIdent ds))
42+
43+ getDeclIdent :: Declaration -> Maybe Ident
44+ getDeclIdent (PositionedDeclaration _ _ d) = getDeclIdent d
45+ getDeclIdent (ValueDeclaration ident _ _ _) = Just ident
46+ getDeclIdent (ExternDeclaration ident _) = Just ident
47+ getDeclIdent (ExternInstanceDeclaration ident _ _ _) = Just ident
48+ getDeclIdent (TypeInstanceDeclaration ident _ _ _ _) = Just ident
49+ getDeclIdent (BindingGroupDeclaration _) = error "lint: binding groups should not be desugared yet."
50+ getDeclIdent _ = Nothing
51+
52+ lintDeclaration :: Declaration -> m ()
53+ lintDeclaration d =
54+ let (f, _, _, _, _) = everythingWithContextOnValues moduleNames mempty mappend stepD stepE stepB def def
55+ in tell (f d)
56+ where
57+ def s _ = (s, mempty)
58+
59+ stepD :: S.Set Ident -> Declaration -> (S.Set Ident, MultipleErrors)
60+ stepD s (TypeClassDeclaration name _ _ decls) = (s, foldr go mempty decls)
61+ where
62+ go :: Declaration -> MultipleErrors -> MultipleErrors
63+ go (PositionedDeclaration _ _ d') errs = go d' errs
64+ go (TypeDeclaration op@(Op _) _) errs = errorMessage (ClassOperator name op) <> errs
65+ go _ errs = errs
66+ stepD s _ = (s, mempty)
67+
68+ stepE :: S.Set Ident -> Expr -> (S.Set Ident, MultipleErrors)
69+ stepE s (Abs (Left name) _) = bind s name
70+ stepE s (Let ds' _) =
71+ case mapAccumL bind s (nub (mapMaybe getDeclIdent ds')) of
72+ (s', es) -> (s', mconcat es)
73+ stepE s _ = (s, mempty)
74+
75+ stepB :: S.Set Ident -> Binder -> (S.Set Ident, MultipleErrors)
76+ stepB s (VarBinder name) = bind s name
77+ stepB s (NamedBinder name _) = bind s name
78+ stepB s _ = (s, mempty)
79+
80+ bind :: S.Set Ident -> Ident -> (S.Set Ident, MultipleErrors)
81+ bind s name | name `S.member` s = (s, errorMessage (ShadowedName name))
82+ | otherwise = (S.insert name s, mempty)
src/Language/PureScript/ModuleDependencies.hsnew file+77
@@ -0,0 +1,77 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.ModuleDependencies
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- | Provides the ability to sort modules based on module dependencies
12+--
13+-----------------------------------------------------------------------------
14+
15+{-# LANGUAGE FlexibleContexts #-}
16+
17+module Language.PureScript.ModuleDependencies (
18+ sortModules,
19+ ModuleGraph
20+) where
21+
22+import Control.Monad.Error.Class (MonadError(..))
23+
24+import Data.Graph
25+import Data.List (nub)
26+import Data.Maybe (mapMaybe)
27+
28+import Language.PureScript.AST
29+import Language.PureScript.Names
30+import Language.PureScript.Types
31+import Language.PureScript.Errors
32+
33+-- |
34+-- A list of modules with their dependencies
35+--
36+type ModuleGraph = [(ModuleName, [ModuleName])]
37+
38+-- |
39+-- Sort a collection of modules based on module dependencies.
40+--
41+-- Reports an error if the module graph contains a cycle.
42+--
43+sortModules :: (MonadError MultipleErrors m) => [Module] -> m ([Module], ModuleGraph)
44+sortModules ms = do
45+ let verts = map (\m@(Module _ _ ds _) -> (m, getModuleName m, nub (concatMap usedModules ds))) ms
46+ ms' <- mapM toModule $ stronglyConnComp verts
47+ let moduleGraph = map (\(_, mn, deps) -> (mn, deps)) verts
48+ return (ms', moduleGraph)
49+
50+-- |
51+-- Calculate a list of used modules based on explicit imports and qualified names
52+--
53+usedModules :: Declaration -> [ModuleName]
54+usedModules = let (f, _, _, _, _) = everythingOnValues (++) forDecls forValues (const []) (const []) (const []) in nub . f
55+ where
56+ forDecls :: Declaration -> [ModuleName]
57+ forDecls (ImportDeclaration mn _ _) = [mn]
58+ forDecls _ = []
59+
60+ forValues :: Expr -> [ModuleName]
61+ forValues (Var (Qualified (Just mn) _)) = [mn]
62+ forValues (Constructor (Qualified (Just mn) _)) = [mn]
63+ forValues (TypedValue _ _ ty) = forTypes ty
64+ forValues _ = []
65+
66+ forTypes :: Type -> [ModuleName]
67+ forTypes (TypeConstructor (Qualified (Just mn) _)) = [mn]
68+ forTypes (ConstrainedType cs _) = mapMaybe (\(Qualified mn _, _) -> mn) cs
69+ forTypes _ = []
70+
71+-- |
72+-- Convert a strongly connected component of the module graph to a module
73+--
74+toModule :: (MonadError MultipleErrors m) => SCC Module -> m Module
75+toModule (AcyclicSCC m) = return m
76+toModule (CyclicSCC [m]) = return m
77+toModule (CyclicSCC ms) = throwError . errorMessage $ CycleInModules (map getModuleName ms)
src/Language/PureScript/Names.hsnew file+102
@@ -0,0 +1,102 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Names
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- Data types for names
13+--
14+-----------------------------------------------------------------------------
15+
16+{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, GADTs #-}
17+
18+module Language.PureScript.Names where
19+
20+import Data.List
21+import Data.Data
22+import Data.List.Split (splitOn)
23+import qualified Data.Aeson as A
24+import qualified Data.Text as T
25+
26+-- |
27+-- Names for value identifiers
28+--
29+data Ident
30+ -- |
31+ -- An alphanumeric identifier
32+ --
33+ = Ident String
34+ -- |
35+ -- A symbolic name for an infix operator
36+ --
37+ | Op String deriving (Eq, Ord, Data, Typeable)
38+
39+runIdent :: Ident -> String
40+runIdent (Ident i) = i
41+runIdent (Op op) = op
42+
43+instance Show Ident where
44+ show (Ident s) = s
45+ show (Op op) = '(':op ++ ")"
46+
47+-- |
48+-- Proper names, i.e. capitalized names for e.g. module names, type//data constructors.
49+--
50+newtype ProperName = ProperName { runProperName :: String } deriving (Eq, Ord, Data, Typeable)
51+
52+instance Show ProperName where
53+ show = runProperName
54+
55+-- |
56+-- Module names
57+--
58+data ModuleName = ModuleName [ProperName] deriving (Eq, Ord, Data, Typeable)
59+
60+runModuleName :: ModuleName -> String
61+runModuleName (ModuleName pns) = intercalate "." (runProperName `map` pns)
62+
63+moduleNameFromString :: String -> ModuleName
64+moduleNameFromString = ModuleName . splitProperNames
65+ where
66+ splitProperNames s = case dropWhile (== '.') s of
67+ "" -> []
68+ s' -> ProperName w : splitProperNames s''
69+ where (w, s'') = break (== '.') s'
70+
71+instance Show ModuleName where
72+ show = runModuleName
73+
74+-- |
75+-- A qualified name, i.e. a name with an optional module name
76+--
77+data Qualified a = Qualified (Maybe ModuleName) a deriving (Eq, Ord, Data, Typeable, Functor)
78+
79+instance (Show a) => Show (Qualified a) where
80+ show (Qualified Nothing a) = show a
81+ show (Qualified (Just name) a) = show name ++ "." ++ show a
82+
83+instance (a ~ ProperName) => A.ToJSON (Qualified a) where
84+ toJSON = A.toJSON . show
85+
86+instance (a ~ ProperName) => A.FromJSON (Qualified a) where
87+ parseJSON =
88+ A.withText "Qualified ProperName" $ \str ->
89+ return $ case reverse (splitOn "." (T.unpack str)) of
90+ [name] -> Qualified Nothing (ProperName name)
91+ (name:rest) -> Qualified (Just (reconstructModuleName rest)) (ProperName name)
92+ _ -> Qualified Nothing (ProperName "")
93+ where
94+ reconstructModuleName = moduleNameFromString . intercalate "." . reverse
95+
96+
97+-- |
98+-- Provide a default module name, if a name is unqualified
99+--
100+qualify :: ModuleName -> Qualified a -> (ModuleName, a)
101+qualify m (Qualified Nothing a) = (m, a)
102+qualify _ (Qualified (Just m) a) = (m, a)
src/Language/PureScript/Options.hsnew file+91
@@ -0,0 +1,91 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Options
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- The data type of compiler options
13+--
14+-----------------------------------------------------------------------------
15+
16+{-# LANGUAGE GADTs, DataKinds, StandaloneDeriving #-}
17+
18+module Language.PureScript.Options where
19+
20+-- |
21+-- Indicates the mode of the compiler. Lifted using DataKinds to refine the Options type.
22+--
23+data Mode = Compile | Make
24+
25+-- |
26+-- Per-mode options
27+--
28+data ModeOptions mode where
29+ CompileOptions :: String -> [String] -> [String] -> ModeOptions Compile
30+ MakeOptions :: Maybe FilePath -> ModeOptions Make
31+
32+browserNamespace :: ModeOptions Compile -> String
33+browserNamespace (CompileOptions ns _ _) = ns
34+
35+entryPointModules :: ModeOptions Compile -> [String]
36+entryPointModules (CompileOptions _ ms _) = ms
37+
38+codeGenModules :: ModeOptions Compile -> [String]
39+codeGenModules (CompileOptions _ _ ms) = ms
40+
41+requirePath :: ModeOptions Make -> Maybe FilePath
42+requirePath (MakeOptions mp) = mp
43+
44+deriving instance Show (ModeOptions mode)
45+
46+-- |
47+-- The data type of compiler options
48+--
49+data Options mode = Options {
50+ -- |
51+ -- Disable tail-call elimination
52+ --
53+ optionsNoTco :: Bool
54+ -- |
55+ -- Disable inlining of calls to return and bind for the Eff monad
56+ --
57+ , optionsNoMagicDo :: Bool
58+ -- |
59+ -- When specified, checks the type of `main` in the module, and generate a call to run main
60+ -- after the module definitions.
61+ --
62+ , optionsMain :: Maybe String
63+ -- |
64+ -- Skip all optimizations
65+ --
66+ , optionsNoOptimizations :: Bool
67+ -- |
68+ -- Verbose error message
69+ --
70+ , optionsVerboseErrors :: Bool
71+ -- |
72+ -- Remove the comments from the generated js
73+ , optionsNoComments :: Bool
74+ -- |
75+ -- Specify the namespace that PureScript modules will be exported to when running in the
76+ -- browser.
77+ --
78+ , optionsAdditional :: ModeOptions mode
79+ } deriving Show
80+
81+-- |
82+-- Default compiler options
83+--
84+defaultCompileOptions :: Options Compile
85+defaultCompileOptions = Options False False Nothing False False False (CompileOptions "PS" [] [])
86+
87+-- |
88+-- Default make options
89+--
90+defaultMakeOptions :: Options Make
91+defaultMakeOptions = Options False False Nothing False False False (MakeOptions Nothing)
src/Language/PureScript/Parser.hsnew file+36
@@ -0,0 +1,36 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Parser
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- A collection of parsers for core data types:
13+--
14+-- [@Language.PureScript.Parser.Kinds@] Parser for kinds
15+--
16+-- [@Language.PureScript.Parser.Values@] Parser for values
17+--
18+-- [@Language.PureScript.Parser.Types@] Parser for types
19+--
20+-- [@Language.PureScript.Parser.Declaration@] Parsers for declarations and modules
21+--
22+-- [@Language.PureScript.Parser.State@] Parser state, including indentation
23+--
24+-- [@Language.PureScript.Parser.Common@] Common parsing utility functions
25+--
26+-----------------------------------------------------------------------------
27+
28+module Language.PureScript.Parser (module P) where
29+
30+import Language.PureScript.Parser.Common as P
31+import Language.PureScript.Parser.Types as P
32+import Language.PureScript.Parser.State as P
33+import Language.PureScript.Parser.Kinds as P
34+import Language.PureScript.Parser.Lexer as P
35+import Language.PureScript.Parser.Declarations as P
36+import Language.PureScript.Parser.JS as P
src/Language/PureScript/Parser/Common.hsnew file+139
@@ -0,0 +1,139 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Parser.Common
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- Constants, and utility functions to be used when parsing
13+--
14+-----------------------------------------------------------------------------
15+
16+{-# LANGUAGE FlexibleContexts #-}
17+
18+module Language.PureScript.Parser.Common where
19+
20+import Control.Applicative
21+import Control.Monad (guard)
22+
23+import Language.PureScript.Comments
24+import Language.PureScript.Parser.Lexer
25+import Language.PureScript.Parser.State
26+import Language.PureScript.Names
27+
28+import qualified Text.Parsec as P
29+
30+featureWasRemoved :: String -> TokenParser a
31+featureWasRemoved err = do
32+ pos <- P.getPosition
33+ error $ "It looks like you are trying to use a feature from a previous version of the compiler:\n" ++ err ++ "\nat " ++ show pos
34+
35+properName :: TokenParser ProperName
36+properName = ProperName <$> uname
37+
38+-- |
39+-- Parse a module name
40+--
41+moduleName :: TokenParser ModuleName
42+moduleName = part []
43+ where
44+ part path = (do name <- ProperName <$> P.try qualifier
45+ part (path `snoc` name))
46+ <|> (ModuleName . snoc path . ProperName <$> mname)
47+ snoc path name = path ++ [name]
48+
49+-- |
50+-- Parse a qualified name, i.e. M.name or just name
51+--
52+parseQualified :: TokenParser a -> TokenParser (Qualified a)
53+parseQualified parser = part []
54+ where
55+ part path = (do name <- ProperName <$> P.try qualifier
56+ part (updatePath path name))
57+ <|> (Qualified (qual path) <$> P.try parser)
58+ updatePath path name = path ++ [name]
59+ qual path = if null path then Nothing else Just $ ModuleName path
60+
61+-- |
62+-- Parse an identifier or parenthesized operator
63+--
64+parseIdent :: TokenParser Ident
65+parseIdent = (Ident <$> identifier) <|> (Op <$> parens symbol)
66+
67+-- |
68+-- Run the first parser, then match the second if possible, applying the specified function on a successful match
69+--
70+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
71+augment p q f = flip (maybe id $ flip f) <$> p <*> P.optionMaybe q
72+
73+-- |
74+-- Run the first parser, then match the second zero or more times, applying the specified function for each match
75+--
76+fold :: 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
77+fold first more combine = do
78+ a <- first
79+ bs <- P.many more
80+ return $ foldl combine a bs
81+
82+-- |
83+-- Build a parser from a smaller parser and a list of parsers for postfix operators
84+--
85+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
86+buildPostfixParser fs first = do
87+ a <- first
88+ go a
89+ where
90+ go a = do
91+ maybeA <- P.optionMaybe $ P.choice (map ($ a) fs)
92+ case maybeA of
93+ Nothing -> return a
94+ Just a' -> go a'
95+
96+-- |
97+-- Mark the current indentation level
98+--
99+mark :: P.Parsec s ParseState a -> P.Parsec s ParseState a
100+mark p = do
101+ current <- indentationLevel <$> P.getState
102+ pos <- P.sourceColumn <$> P.getPosition
103+ P.modifyState $ \st -> st { indentationLevel = pos }
104+ a <- p
105+ P.modifyState $ \st -> st { indentationLevel = current }
106+ return a
107+
108+-- |
109+-- Check that the current identation level matches a predicate
110+--
111+checkIndentation :: (P.Column -> P.Column -> Bool) -> P.Parsec s ParseState ()
112+checkIndentation rel = do
113+ col <- P.sourceColumn <$> P.getPosition
114+ current <- indentationLevel <$> P.getState
115+ guard (col `rel` current)
116+
117+-- |
118+-- Check that the current indentation level is past the current mark
119+--
120+indented :: P.Parsec s ParseState ()
121+indented = checkIndentation (>) P.<?> "indentation"
122+
123+-- |
124+-- Check that the current indentation level is at the same indentation as the current mark
125+--
126+same :: P.Parsec s ParseState ()
127+same = checkIndentation (==) P.<?> "no indentation"
128+
129+-- |
130+-- Read the comments from the the next token, without consuming it
131+--
132+readComments :: P.Parsec [PositionedToken] u [Comment]
133+readComments = P.lookAhead $ ptComments <$> P.anyToken
134+
135+-- |
136+-- Run a parser
137+--
138+runTokenParser :: FilePath -> TokenParser a -> [PositionedToken] -> Either P.ParseError a
139+runTokenParser filePath p = P.runParser p (ParseState 0) filePath
src/Language/PureScript/Parser/Declarations.hsnew file+543
@@ -0,0 +1,543 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Parser.Declarations
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- Parsers for module definitions and declarations
13+--
14+-----------------------------------------------------------------------------
15+
16+{-# LANGUAGE FlexibleContexts #-}
17+{-# LANGUAGE ScopedTypeVariables #-}
18+{-# LANGUAGE TupleSections #-}
19+
20+module Language.PureScript.Parser.Declarations (
21+ parseDeclaration,
22+ parseModule,
23+ parseModules,
24+ parseModulesFromFiles,
25+ parseValue,
26+ parseGuard,
27+ parseBinder,
28+ parseBinderNoParens,
29+ parseImportDeclaration',
30+ parseLocalDeclaration
31+) where
32+
33+import Prelude hiding (lex)
34+
35+import Data.Maybe (fromMaybe)
36+
37+import Control.Applicative
38+import Control.Arrow ((+++))
39+import Control.Monad.Error.Class (MonadError(..))
40+
41+import Language.PureScript.AST
42+import Language.PureScript.Comments
43+import Language.PureScript.Environment
44+import Language.PureScript.Errors
45+import Language.PureScript.Kinds
46+import Language.PureScript.Names
47+import Language.PureScript.Parser.Common
48+import Language.PureScript.Parser.Kinds
49+import Language.PureScript.Parser.Lexer
50+import Language.PureScript.Parser.Types
51+
52+import qualified Language.PureScript.Parser.Common as C
53+import qualified Text.Parsec as P
54+import qualified Text.Parsec.Expr as P
55+
56+-- |
57+-- Read source position information
58+--
59+withSourceSpan :: (SourceSpan -> [Comment] -> a -> a) -> P.Parsec [PositionedToken] u a -> P.Parsec [PositionedToken] u a
60+withSourceSpan f p = do
61+ start <- P.getPosition
62+ comments <- C.readComments
63+ x <- p
64+ end <- P.getPosition
65+ let sp = SourceSpan (P.sourceName start) (toSourcePos start) (toSourcePos end)
66+ return $ f sp comments x
67+ where
68+ toSourcePos pos = SourcePos (P.sourceLine pos) (P.sourceColumn pos)
69+
70+kindedIdent :: TokenParser (String, Maybe Kind)
71+kindedIdent = (, Nothing) <$> identifier
72+ <|> parens ((,) <$> identifier <*> (Just <$> (indented *> doubleColon *> indented *> parseKind)))
73+
74+parseDataDeclaration :: TokenParser Declaration
75+parseDataDeclaration = do
76+ dtype <- (reserved "data" *> return Data) <|> (reserved "newtype" *> return Newtype)
77+ name <- indented *> properName
78+ tyArgs <- many (indented *> kindedIdent)
79+ ctors <- P.option [] $ do
80+ indented *> equals
81+ P.sepBy1 ((,) <$> properName <*> P.many (indented *> noWildcards parseTypeAtom)) pipe
82+ return $ DataDeclaration dtype name tyArgs ctors
83+
84+parseTypeDeclaration :: TokenParser Declaration
85+parseTypeDeclaration =
86+ TypeDeclaration <$> P.try (parseIdent <* indented <* doubleColon)
87+ <*> parsePolyType
88+
89+parseTypeSynonymDeclaration :: TokenParser Declaration
90+parseTypeSynonymDeclaration =
91+ TypeSynonymDeclaration <$> (P.try (reserved "type") *> indented *> properName)
92+ <*> many (indented *> kindedIdent)
93+ <*> (indented *> equals *> noWildcards parsePolyType)
94+
95+parseValueDeclaration :: TokenParser Declaration
96+parseValueDeclaration = do
97+ name <- parseIdent
98+ binders <- P.many parseBinderNoParens
99+ value <- Left <$> (C.indented *>
100+ P.many1 ((,) <$> parseGuard
101+ <*> (indented *> equals *> parseValueWithWhereClause)
102+ ))
103+ <|> Right <$> (indented *> equals *> parseValueWithWhereClause)
104+ return $ ValueDeclaration name Public binders value
105+ where
106+ parseValueWithWhereClause :: TokenParser Expr
107+ parseValueWithWhereClause = do
108+ value <- parseValue
109+ whereClause <- P.optionMaybe $ do
110+ C.indented
111+ reserved "where"
112+ C.indented
113+ C.mark $ P.many1 (C.same *> parseLocalDeclaration)
114+ return $ maybe value (`Let` value) whereClause
115+
116+parseExternDeclaration :: TokenParser Declaration
117+parseExternDeclaration = P.try (reserved "foreign") *> indented *> reserved "import" *> indented *>
118+ (ExternDataDeclaration <$> (P.try (reserved "data") *> indented *> properName)
119+ <*> (indented *> doubleColon *> parseKind)
120+ <|> (do reserved "instance"
121+ name <- parseIdent <* indented <* doubleColon
122+ deps <- P.option [] $ do
123+ deps' <- parens (commaSep1 ((,) <$> parseQualified properName <*> P.many (noWildcards parseTypeAtom)))
124+ indented
125+ rfatArrow
126+ return deps'
127+ className <- indented *> parseQualified properName
128+ tys <- P.many (indented *> noWildcards parseTypeAtom)
129+ return $ ExternInstanceDeclaration name deps className tys)
130+ <|> (do ident <- parseIdent
131+ -- TODO: add a wiki page link with migration info
132+ -- TODO: remove this deprecation warning in 0.8
133+ _ <- P.optional $ stringLiteral *> featureWasRemoved "Inline foreign string literals are no longer supported."
134+ ty <- indented *> doubleColon *> noWildcards parsePolyType
135+ return $ ExternDeclaration ident ty))
136+
137+parseAssociativity :: TokenParser Associativity
138+parseAssociativity =
139+ (P.try (reserved "infixl") >> return Infixl) <|>
140+ (P.try (reserved "infixr") >> return Infixr) <|>
141+ (P.try (reserved "infix") >> return Infix)
142+
143+parseFixity :: TokenParser Fixity
144+parseFixity = Fixity <$> parseAssociativity <*> (indented *> natural)
145+
146+parseFixityDeclaration :: TokenParser Declaration
147+parseFixityDeclaration = do
148+ fixity <- parseFixity
149+ indented
150+ name <- symbol
151+ return $ FixityDeclaration fixity name
152+
153+parseImportDeclaration :: TokenParser Declaration
154+parseImportDeclaration = do
155+ (mn, declType, asQ) <- parseImportDeclaration'
156+ return $ ImportDeclaration mn declType asQ
157+
158+parseImportDeclaration' :: TokenParser (ModuleName, ImportDeclarationType, Maybe ModuleName)
159+parseImportDeclaration' = do
160+ reserved "import"
161+ indented
162+ qualImport <|> stdImport
163+ where
164+ stdImport = do
165+ moduleName' <- moduleName
166+ stdImportHiding moduleName' <|> stdImportQualifying moduleName'
167+ where
168+ stdImportHiding mn = do
169+ reserved "hiding"
170+ declType <- importDeclarationType Hiding
171+ return (mn, declType, Nothing)
172+ stdImportQualifying mn = do
173+ declType <- importDeclarationType Explicit
174+ return (mn, declType, Nothing)
175+ qualImport = do
176+ reserved "qualified"
177+ indented
178+ moduleName' <- moduleName
179+ declType <- importDeclarationType Explicit
180+ reserved "as"
181+ asQ <- moduleName
182+ return (moduleName', declType, Just asQ)
183+ importDeclarationType expectedType = do
184+ idents <- P.optionMaybe $ indented *> parens (commaSep parseDeclarationRef)
185+ return $ fromMaybe Implicit (expectedType <$> idents)
186+
187+
188+parseDeclarationRef :: TokenParser DeclarationRef
189+parseDeclarationRef = withSourceSpan PositionedDeclarationRef $
190+ ValueRef <$> parseIdent
191+ <|> do name <- properName
192+ dctors <- P.optionMaybe $ parens (symbol' ".." *> pure Nothing <|> Just <$> commaSep properName)
193+ return $ maybe (TypeClassRef name) (TypeRef name) dctors
194+
195+parseTypeClassDeclaration :: TokenParser Declaration
196+parseTypeClassDeclaration = do
197+ reserved "class"
198+ implies <- P.option [] $ do
199+ indented
200+ implies <- parens (commaSep1 ((,) <$> parseQualified properName <*> P.many (noWildcards parseTypeAtom)))
201+ lfatArrow
202+ return implies
203+ className <- indented *> properName
204+ idents <- P.many (indented *> kindedIdent)
205+ members <- P.option [] . P.try $ do
206+ indented *> reserved "where"
207+ mark (P.many (same *> positioned parseTypeDeclaration))
208+ return $ TypeClassDeclaration className idents implies members
209+
210+parseTypeInstanceDeclaration :: TokenParser Declaration
211+parseTypeInstanceDeclaration = do
212+ reserved "instance"
213+ name <- parseIdent <* indented <* doubleColon
214+ deps <- P.optionMaybe $ do
215+ deps <- parens (commaSep1 ((,) <$> parseQualified properName <*> P.many (noWildcards parseTypeAtom)))
216+ indented
217+ rfatArrow
218+ return deps
219+ className <- indented *> parseQualified properName
220+ ty <- P.many (indented *> noWildcards parseTypeAtom)
221+ members <- P.option [] . P.try $ do
222+ indented *> reserved "where"
223+ mark (P.many (same *> positioned parseValueDeclaration))
224+ return $ TypeInstanceDeclaration name (fromMaybe [] deps) className ty members
225+
226+positioned :: TokenParser Declaration -> TokenParser Declaration
227+positioned = withSourceSpan PositionedDeclaration
228+
229+-- |
230+-- Parse a single declaration
231+--
232+parseDeclaration :: TokenParser Declaration
233+parseDeclaration = positioned (P.choice
234+ [ parseDataDeclaration
235+ , parseTypeDeclaration
236+ , parseTypeSynonymDeclaration
237+ , parseValueDeclaration
238+ , parseExternDeclaration
239+ , parseFixityDeclaration
240+ , parseImportDeclaration
241+ , parseTypeClassDeclaration
242+ , parseTypeInstanceDeclaration
243+ ]) P.<?> "declaration"
244+
245+parseLocalDeclaration :: TokenParser Declaration
246+parseLocalDeclaration = positioned (P.choice
247+ [ parseTypeDeclaration
248+ , parseValueDeclaration
249+ ] P.<?> "local declaration")
250+
251+-- |
252+-- Parse a module header and a collection of declarations
253+--
254+parseModule :: TokenParser Module
255+parseModule = do
256+ comments <- C.readComments
257+ reserved "module"
258+ indented
259+ name <- moduleName
260+ exports <- P.optionMaybe $ parens $ commaSep1 parseDeclarationRef
261+ reserved "where"
262+ decls <- mark (P.many (same *> parseDeclaration))
263+ return $ Module comments name decls exports
264+
265+-- |
266+-- Parse a collection of modules
267+--
268+parseModulesFromFiles :: forall m k. (MonadError MultipleErrors m, Functor m) =>
269+ (k -> String) -> [(k, String)] -> m [(k, Module)]
270+parseModulesFromFiles toFilePath input = do
271+ modules <- parU input $ \(k, content) -> do
272+ let filename = toFilePath k
273+ ts <- wrapError $ lex filename content
274+ ms <- wrapError $ runTokenParser filename parseModules ts
275+ return (k, ms)
276+ return $ collect modules
277+ where
278+ wrapError :: Either P.ParseError a -> m a
279+ wrapError = either (throwError . errorMessage . ErrorParsingModule) return
280+ collect :: [(k, [v])] -> [(k, v)]
281+ collect vss = [ (k, v) | (k, vs) <- vss, v <- vs ]
282+
283+-- |
284+-- Parse a collection of modules
285+--
286+parseModules :: TokenParser [Module]
287+parseModules = mark (P.many (same *> parseModule)) <* P.eof
288+
289+booleanLiteral :: TokenParser Bool
290+booleanLiteral = (reserved "true" >> return True) P.<|> (reserved "false" >> return False)
291+
292+parseNumericLiteral :: TokenParser Expr
293+parseNumericLiteral = NumericLiteral <$> number
294+
295+parseCharLiteral :: TokenParser Expr
296+parseCharLiteral = CharLiteral <$> charLiteral
297+
298+parseStringLiteral :: TokenParser Expr
299+parseStringLiteral = StringLiteral <$> stringLiteral
300+
301+parseBooleanLiteral :: TokenParser Expr
302+parseBooleanLiteral = BooleanLiteral <$> booleanLiteral
303+
304+parseArrayLiteral :: TokenParser Expr
305+parseArrayLiteral = ArrayLiteral <$> squares (commaSep parseValue)
306+
307+parseObjectLiteral :: TokenParser Expr
308+parseObjectLiteral = ObjectConstructor <$> braces (commaSep parseIdentifierAndValue)
309+
310+parseIdentifierAndValue :: TokenParser (String, Maybe Expr)
311+parseIdentifierAndValue = (,) <$> (C.indented *> (lname <|> stringLiteral) <* C.indented <* colon)
312+ <*> (C.indented *> val)
313+ where
314+ val = (Just <$> parseValue) <|> (underscore *> pure Nothing)
315+
316+parseAbs :: TokenParser Expr
317+parseAbs = do
318+ symbol' "\\"
319+ args <- P.many1 (C.indented *> (Abs <$> (Left <$> P.try C.parseIdent <|> Right <$> parseBinderNoParens)))
320+ C.indented *> rarrow
321+ value <- parseValue
322+ return $ toFunction args value
323+ where
324+ toFunction :: [Expr -> Expr] -> Expr -> Expr
325+ toFunction args value = foldr ($) value args
326+
327+parseVar :: TokenParser Expr
328+parseVar = Var <$> C.parseQualified C.parseIdent
329+
330+parseConstructor :: TokenParser Expr
331+parseConstructor = Constructor <$> C.parseQualified C.properName
332+
333+parseCase :: TokenParser Expr
334+parseCase = Case <$> P.between (P.try (reserved "case")) (C.indented *> reserved "of") (return <$> parseValue)
335+ <*> (C.indented *> C.mark (P.many (C.same *> C.mark parseCaseAlternative)))
336+
337+parseCaseAlternative :: TokenParser CaseAlternative
338+parseCaseAlternative = CaseAlternative <$> (return <$> parseBinder)
339+ <*> (Left <$> (C.indented *>
340+ P.many1 ((,) <$> parseGuard
341+ <*> (indented *> rarrow *> parseValue)
342+ ))
343+ <|> Right <$> (indented *> rarrow *> parseValue))
344+ P.<?> "case alternative"
345+
346+parseIfThenElse :: TokenParser Expr
347+parseIfThenElse = IfThenElse <$> (P.try (reserved "if") *> C.indented *> parseValue)
348+ <*> (C.indented *> reserved "then" *> C.indented *> parseValue)
349+ <*> (C.indented *> reserved "else" *> C.indented *> parseValue)
350+
351+parseLet :: TokenParser Expr
352+parseLet = do
353+ reserved "let"
354+ C.indented
355+ ds <- C.mark $ P.many1 (C.same *> parseLocalDeclaration)
356+ C.indented
357+ reserved "in"
358+ result <- parseValue
359+ return $ Let ds result
360+
361+parseValueAtom :: TokenParser Expr
362+parseValueAtom = P.choice
363+ [ P.try parseNumericLiteral
364+ , P.try parseCharLiteral
365+ , P.try parseStringLiteral
366+ , P.try parseBooleanLiteral
367+ , parseArrayLiteral
368+ , P.try parseObjectLiteral
369+ , P.try parseObjectGetter
370+ , parseAbs
371+ , P.try parseConstructor
372+ , P.try parseVar
373+ , parseCase
374+ , parseIfThenElse
375+ , parseDo
376+ , parseLet
377+ , P.try $ Parens <$> parens parseValue
378+ , parseOperatorSection
379+ , P.try parseObjectUpdaterWildcard ]
380+
381+-- |
382+-- Parse an expression in backticks or an operator
383+--
384+parseInfixExpr :: TokenParser Expr
385+parseInfixExpr = P.between tick tick parseValue
386+ <|> Var <$> parseQualified (Op <$> symbol)
387+
388+parseOperatorSection :: TokenParser Expr
389+parseOperatorSection = parens $ left <|> right
390+ where
391+ right = OperatorSection <$> parseInfixExpr <* indented <*> (Right <$> parseValueAtom)
392+ left = flip OperatorSection <$> (Left <$> parseValueAtom) <* indented <*> parseInfixExpr
393+
394+parsePropertyUpdate :: TokenParser (String, Maybe Expr)
395+parsePropertyUpdate = do
396+ name <- lname <|> stringLiteral
397+ _ <- C.indented *> equals
398+ value <- C.indented *> (underscore *> pure Nothing) <|> (Just <$> parseValue)
399+ return (name, value)
400+
401+parseAccessor :: Expr -> TokenParser Expr
402+parseAccessor (Constructor _) = P.unexpected "constructor"
403+parseAccessor obj = P.try $ Accessor <$> (C.indented *> dot *> C.indented *> (lname <|> stringLiteral)) <*> pure obj
404+
405+parseDo :: TokenParser Expr
406+parseDo = do
407+ reserved "do"
408+ C.indented
409+ Do <$> C.mark (P.many (C.same *> C.mark parseDoNotationElement))
410+
411+parseDoNotationLet :: TokenParser DoNotationElement
412+parseDoNotationLet = DoNotationLet <$> (reserved "let" *> C.indented *> C.mark (P.many1 (C.same *> parseLocalDeclaration)))
413+
414+parseDoNotationBind :: TokenParser DoNotationElement
415+parseDoNotationBind = DoNotationBind <$> parseBinder <*> (C.indented *> larrow *> parseValue)
416+
417+parseDoNotationElement :: TokenParser DoNotationElement
418+parseDoNotationElement = P.choice
419+ [ P.try parseDoNotationBind
420+ , parseDoNotationLet
421+ , P.try (DoNotationValue <$> parseValue) ]
422+
423+parseObjectGetter :: TokenParser Expr
424+parseObjectGetter = ObjectGetter <$> (underscore *> C.indented *> dot *> C.indented *> (lname <|> stringLiteral))
425+
426+-- |
427+-- Parse a value
428+--
429+parseValue :: TokenParser Expr
430+parseValue = withSourceSpan PositionedValue
431+ (P.buildExpressionParser operators
432+ . C.buildPostfixParser postfixTable2
433+ $ indexersAndAccessors) P.<?> "expression"
434+ where
435+ indexersAndAccessors = C.buildPostfixParser postfixTable1 parseValueAtom
436+ postfixTable1 = [ parseAccessor
437+ , P.try . parseUpdaterBody . Just ]
438+ postfixTable2 = [ \v -> P.try (flip App <$> (C.indented *> indexersAndAccessors)) <*> pure v
439+ , \v -> flip (TypedValue True) <$> (P.try (C.indented *> doubleColon) *> parsePolyType) <*> pure v
440+ ]
441+ operators = [ [ P.Prefix (P.try (C.indented *> symbol' "-") >> return UnaryMinus)
442+ ]
443+ , [ P.Infix (P.try (C.indented *> parseInfixExpr P.<?> "infix expression") >>= \ident ->
444+ return (BinaryNoParens ident)) P.AssocRight
445+ ]
446+ ]
447+
448+parseUpdaterBody :: Maybe Expr -> TokenParser Expr
449+parseUpdaterBody v = ObjectUpdater v <$> (C.indented *> braces (commaSep1 (C.indented *> parsePropertyUpdate)))
450+
451+parseObjectUpdaterWildcard :: TokenParser Expr
452+parseObjectUpdaterWildcard = underscore *> C.indented *> parseUpdaterBody Nothing
453+
454+parseStringBinder :: TokenParser Binder
455+parseStringBinder = StringBinder <$> stringLiteral
456+
457+parseCharBinder :: TokenParser Binder
458+parseCharBinder = CharBinder <$> charLiteral
459+
460+parseBooleanBinder :: TokenParser Binder
461+parseBooleanBinder = BooleanBinder <$> booleanLiteral
462+
463+parseNumberBinder :: TokenParser Binder
464+parseNumberBinder = NumberBinder <$> (sign <*> number)
465+ where
466+ sign :: TokenParser (Either Integer Double -> Either Integer Double)
467+ sign = (symbol' "-" >> return (negate +++ negate))
468+ <|> (symbol' "+" >> return id)
469+ <|> return id
470+
471+parseVarBinder :: TokenParser Binder
472+parseVarBinder = VarBinder <$> C.parseIdent
473+
474+parseNullaryConstructorBinder :: TokenParser Binder
475+parseNullaryConstructorBinder = ConstructorBinder <$> C.parseQualified C.properName <*> pure []
476+
477+parseConstructorBinder :: TokenParser Binder
478+parseConstructorBinder = ConstructorBinder <$> C.parseQualified C.properName <*> many (C.indented *> parseBinderNoParens)
479+
480+parseObjectBinder :: TokenParser Binder
481+parseObjectBinder = ObjectBinder <$> braces (commaSep (C.indented *> parseIdentifierAndBinder))
482+
483+parseArrayBinder :: TokenParser Binder
484+parseArrayBinder = squares $ ArrayBinder <$> commaSep (C.indented *> parseBinder)
485+
486+parseNamedBinder :: TokenParser Binder
487+parseNamedBinder = NamedBinder <$> (C.parseIdent <* C.indented <* at)
488+ <*> (C.indented *> parseBinder)
489+
490+parseNullBinder :: TokenParser Binder
491+parseNullBinder = underscore *> return NullBinder
492+
493+parseIdentifierAndBinder :: TokenParser (String, Binder)
494+parseIdentifierAndBinder = do
495+ name <- lname <|> stringLiteral
496+ C.indented *> (equals <|> colon)
497+ binder <- C.indented *> parseBinder
498+ return (name, binder)
499+
500+-- |
501+-- Parse a binder
502+--
503+parseBinder :: TokenParser Binder
504+parseBinder = withSourceSpan PositionedBinder (P.buildExpressionParser operators parseBinderAtom)
505+ where
506+ -- TODO: remove this deprecation warning in 0.8
507+ operators = [ [ P.Infix (P.try $ C.indented *> colon *> featureWasRemoved "Cons binders are no longer supported. Consider using purescript-lists or purescript-sequences instead.") P.AssocRight ] ]
508+ parseBinderAtom :: TokenParser Binder
509+ parseBinderAtom = P.choice (map P.try
510+ [ parseNullBinder
511+ , parseCharBinder
512+ , parseStringBinder
513+ , parseBooleanBinder
514+ , parseNumberBinder
515+ , parseNamedBinder
516+ , parseVarBinder
517+ , parseConstructorBinder
518+ , parseObjectBinder
519+ , parseArrayBinder
520+ , parens parseBinder ]) P.<?> "binder"
521+
522+-- |
523+-- Parse a binder as it would appear in a top level declaration
524+--
525+parseBinderNoParens :: TokenParser Binder
526+parseBinderNoParens = P.choice (map P.try
527+ [ parseNullBinder
528+ , parseCharBinder
529+ , parseStringBinder
530+ , parseBooleanBinder
531+ , parseNumberBinder
532+ , parseNamedBinder
533+ , parseVarBinder
534+ , parseNullaryConstructorBinder
535+ , parseObjectBinder
536+ , parseArrayBinder
537+ , parens parseBinder ]) P.<?> "binder"
538+
539+-- |
540+-- Parse a guard
541+--
542+parseGuard :: TokenParser Guard
543+parseGuard = pipe *> C.indented *> parseValue
src/Language/PureScript/Parser/JS.hsnew file+59
@@ -0,0 +1,59 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Foreign
4+-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+--
13+-----------------------------------------------------------------------------
14+
15+{-# LANGUAGE FlexibleContexts #-}
16+
17+module Language.PureScript.Parser.JS
18+ ( ForeignJS()
19+ , parseForeignModulesFromFiles
20+ ) where
21+
22+import Control.Applicative ((*>), (<*))
23+import Control.Monad (forM_, when, msum)
24+import Control.Monad.Error.Class (MonadError(..))
25+import Control.Monad.Writer.Class (MonadWriter(..))
26+import Data.Function (on)
27+import Data.List (sortBy, groupBy)
28+import Language.PureScript.Errors
29+import Language.PureScript.Names
30+import Language.PureScript.Parser.Common
31+import Language.PureScript.Parser.Lexer
32+import Prelude hiding (lex)
33+import qualified Data.Map as M
34+import qualified Text.Parsec as PS
35+
36+type ForeignJS = String
37+
38+parseForeignModulesFromFiles :: (Functor m, MonadError MultipleErrors m, MonadWriter MultipleErrors m)
39+ => [(FilePath, ForeignJS)]
40+ -> m (M.Map ModuleName (FilePath, ForeignJS))
41+parseForeignModulesFromFiles files = do
42+ foreigns <- parU files $ \(path, file) ->
43+ case findModuleName (lines file) of
44+ Just name -> return (name, (path, file))
45+ Nothing -> throwError (errorMessage $ ErrorParsingFFIModule path)
46+ let grouped = groupBy ((==) `on` fst) $ sortBy (compare `on` fst) foreigns
47+ forM_ grouped $ \grp ->
48+ when (length grp > 1) $ do
49+ let mn = fst (head grp)
50+ paths = map (fst . snd) grp
51+ tell $ errorMessage $ MultipleFFIModules mn paths
52+ return $ M.fromList foreigns
53+
54+findModuleName :: [String] -> Maybe ModuleName
55+findModuleName = msum . map parseComment
56+ where
57+ parseComment :: String -> Maybe ModuleName
58+ parseComment s = either (const Nothing) Just $
59+ lex "" s >>= runTokenParser "" (symbol' "//" *> reserved "module" *> moduleName <* PS.eof)
src/Language/PureScript/Parser/Kinds.hsnew file+45
@@ -0,0 +1,45 @@
1+-----------------------------------------------------------------------------
2+--
3+-- Module : Language.PureScript.Parser.Kinds
4+-- Copyright : (c) Phil Freeman 2013
5+-- License : MIT
6+--
7+-- Maintainer : Phil Freeman <paf31@cantab.net>
8+-- Stability : experimental
9+-- Portability :
10+--
11+-- |
12+-- A parser for kinds
13+--
14+-----------------------------------------------------------------------------
15+
16+module Language.PureScript.Parser.Kinds (
17+ parseKind
18+) where
19+
20+import Language.PureScript.Kinds
21+import Language.PureScript.Parser.Common
22+import Language.PureScript.Parser.Lexer
23+import Control.Applicative
24+import qualified Text.Parsec as P
25+import qualified Text.Parsec.Expr as P
26+
27+parseStar :: TokenParser Kind
28+parseStar = const Star <$> symbol' "*"
29+
30+parseBang :: TokenParser Kind
31+parseBang = const Bang <$> symbol' "!"
32+
33+parseTypeAtom :: TokenParser Kind
34+parseTypeAtom = indented *> P.choice (map P.try
35+ [ parseStar
36+ , parseBang
37+ , parens parseKind ])
38+-- |
39+-- Parse a kind
40+--
41+parseKind :: TokenParser Kind
42+parseKind = P.buildExpressionParser operators parseTypeAtom P.<?> "kind"
43+ where
44+ operators = [ [ P.Prefix (symbol' "#" >> return Row) ]
45+ , [ P.Infix ((P.try rarrow) >> return FunKind) P.AssocRight ] ]
src/Language/PureScript/Parser/Lexer.hsnew file+519

This diff is too big to show here.

src/Language/PureScript/Parser/State.hsnew file+30

This diff is too big to show here.

src/Language/PureScript/Parser/Types.hsnew file+137

This diff is too big to show here.

src/Language/PureScript/Pretty.hsnew file+32

This diff is too big to show here.

src/Language/PureScript/Pretty/Common.hsnew file+69

This diff is too big to show here.

src/Language/PureScript/Pretty/JS.hsnew file+301

This diff is too big to show here.

src/Language/PureScript/Pretty/Kinds.hsnew file+59

This diff is too big to show here.

src/Language/PureScript/Pretty/Types.hsnew file+127

This diff is too big to show here.

src/Language/PureScript/Pretty/Values.hsnew file+244

This diff is too big to show here.

src/Language/PureScript/Renamer.hsnew file+196

This diff is too big to show here.

src/Language/PureScript/Sugar.hsnew file+71

This diff is too big to show here.

src/Language/PureScript/Sugar/BindingGroups.hsnew file+206

This diff is too big to show here.

src/Language/PureScript/Sugar/CaseDeclarations.hsnew file+180

This diff is too big to show here.

src/Language/PureScript/Sugar/DoNotation.hsnew file+74

This diff is too big to show here.

src/Language/PureScript/Sugar/Names.hsnew file+542

This diff is too big to show here.

src/Language/PureScript/Sugar/ObjectWildcards.hsnew file+65

This diff is too big to show here.

src/Language/PureScript/Sugar/Operators.hsnew file+166

This diff is too big to show here.

src/Language/PureScript/Sugar/TypeClasses.hsnew file+297

This diff is too big to show here.

src/Language/PureScript/Sugar/TypeDeclarations.hsnew file+69

This diff is too big to show here.

src/Language/PureScript/Traversals.hsnew file+41

This diff is too big to show here.

src/Language/PureScript/TypeChecker.hsnew file+343

This diff is too big to show here.

src/Language/PureScript/TypeChecker/Entailment.hsnew file+207

This diff is too big to show here.

src/Language/PureScript/TypeChecker/Kinds.hsnew file+218

This diff is too big to show here.

src/Language/PureScript/TypeChecker/Monad.hsnew file+272

This diff is too big to show here.

src/Language/PureScript/TypeChecker/Rows.hsnew file+67

This diff is too big to show here.

src/Language/PureScript/TypeChecker/Skolems.hsnew file+114

This diff is too big to show here.

src/Language/PureScript/TypeChecker/Subsumption.hsnew file+96

This diff is too big to show here.

src/Language/PureScript/TypeChecker/Synonyms.hsnew file+106

This diff is too big to show here.

src/Language/PureScript/TypeChecker/Types.hsnew file+675

This diff is too big to show here.

src/Language/PureScript/TypeChecker/Unify.hsnew file+206

This diff is too big to show here.

src/Language/PureScript/TypeClassDictionaries.hsnew file+96

This diff is too big to show here.

src/Language/PureScript/Types.hsnew file+311

This diff is too big to show here.

src/Tests.hsdeleted−141

This diff is too big to show here.

stack.nixdeleted−23

This diff is too big to show here.

stack.yamldeleted−24

This diff is too big to show here.

support/ffi-loader.godeleted−30

This diff is too big to show here.

support/go.mod.ffi-loaderdeleted−2

This diff is too big to show here.

support/go.mod.outputdeleted−2

This diff is too big to show here.

support/go.mod.workingdeleted−1

This diff is too big to show here.

test/Spec.hsdeleted−2

This diff is too big to show here.

tests/Main.hsnew file+118

This diff is too big to show here.

tests/prelude/Prelude.pursnew file+631

This diff is too big to show here.

tests/prelude/js/Assert.jsnew file+19

This diff is too big to show here.

tests/prelude/js/Control.Monad.Eff.jsnew file+40

This diff is too big to show here.

tests/prelude/js/Control.Monad.ST.jsnew file+38

This diff is too big to show here.

tests/prelude/js/Data.Function.jsnew file+233

This diff is too big to show here.

tests/prelude/js/Debug.Trace.jsnew file+11

This diff is too big to show here.

tests/prelude/js/Prelude.Unsafe.jsnew file+10

This diff is too big to show here.

tests/prelude/js/Prelude.jsnew file+150

This diff is too big to show here.

travis-after-script.shnew file+21

This diff is too big to show here.

travis-script.shnew file+17

This diff is too big to show here.