git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
swap
355eb9b2355 ahead, 0 behind
321 files changed+2728−19537
since splitsnapshots
unifiedsplit
.gitignore+12 .travis.yml−19 CONTRIBUTING.md−18 ChangeLog.md+3 LICENSE+30−622 README-go.md+48 README.md+41−16 RELEASE-0.2.md−85 RELEASE-0.3.md−85 RELEASE-0.4.md−60 RELEASE-0.5.md−99 RELEASE-0.6.md−63 RELEASE-0.7.md−51 Setup.hs−4 app/Main.hs+250 bundle/.gitignore−3 bundle/README−20 bundle/build.sh−43 bundle/winbuild.sh−40 default.nix+23 examples/.gitignore−1 examples/failing/ArrayType.purs−11 examples/failing/Arrays.purs−5 examples/failing/Do.purs−8 examples/failing/DuplicateDeclarationsInLet.purs−9 examples/failing/DuplicateProperties1.purs−9 examples/failing/DuplicateProperties2.purs−9 examples/failing/DuplicateTypeVars.purs−3 examples/failing/Eff.purs−12 examples/failing/Foldable.purs−12 examples/failing/InstanceExport.purs−15 examples/failing/KindError.purs−3 examples/failing/Let.purs−3 examples/failing/MPTCs.purs−7 examples/failing/MissingClassExport.purs−4 examples/failing/MissingClassMemberExport.purs−4 examples/failing/MultipleErrors.purs−9 examples/failing/MultipleErrors2.purs−5 examples/failing/MutRec.purs−5 examples/failing/MutRec2.purs−3 examples/failing/NewtypeMultiArgs.purs−3 examples/failing/NewtypeMultiCtor.purs−3 examples/failing/NoOverlap.purs−11 examples/failing/NullaryAbs.purs−3 examples/failing/Object.purs−5 examples/failing/OverlappingArguments.purs−3 examples/failing/OverlappingBinders.purs−4 examples/failing/OverlappingInstances.purs−11 examples/failing/OverlappingInstances2.purs−23 examples/failing/OverlappingVars.purs−12 examples/failing/Rank2Types.purs−7 examples/failing/Reserved.purs−4 examples/failing/SkolemEscape.purs−5 examples/failing/SkolemEscape2.purs−9 examples/failing/Superclasses1.purs−11 examples/failing/Superclasses2.purs−9 examples/failing/Superclasses3.purs−5 examples/failing/Superclasses4.purs−12 examples/failing/TopLevelCaseNoArgs.purs−4 examples/failing/TypeClassInstances.purs−8 examples/failing/TypeClasses2.purs−8 examples/failing/TypeError.purs−5 examples/failing/TypeSynonyms.purs−5 examples/failing/TypeSynonyms2.purs−9 examples/failing/TypeSynonyms3.purs−9 examples/failing/TypeSynonyms4.purs−8 examples/failing/TypeWildcards1.purs−4 examples/failing/TypeWildcards2.purs−4 examples/failing/TypeWildcards3.purs−7 examples/failing/UnderscoreModuleName.purs−3 examples/failing/UnifyInTypeInstanceLookup.purs−17 examples/failing/UnknownType.purs−4 examples/manual/failing/ArgLengthMismatch.purs−4 examples/manual/failing/ExportExplicit.purs−5 examples/manual/failing/ExportExplicit1.purs−14 examples/manual/failing/ExportExplicit2.purs−5 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−6 examples/manual/failing/RequiredHiddenType.purs−8 examples/manual/passing/ExportExplicit.purs−20 examples/manual/passing/ExportExplicit2.purs−15 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/TransitiveImport.purs−21 examples/passing/652.purs−15 examples/passing/810.purs−11 examples/passing/Applicative.purs−16 examples/passing/ArrayType.purs−9 examples/passing/Arrays.purs−24 examples/passing/Auto.purs−13 examples/passing/AutoPrelude.purs−8 examples/passing/AutoPrelude2.purs−9 examples/passing/BindersInFunctions.purs−18 examples/passing/BindingGroups.purs−8 examples/passing/BlockString.purs−12 examples/passing/CaseInDo.purs−20 examples/passing/CheckFunction.purs−5 examples/passing/CheckSynonymBug.purs−16 examples/passing/CheckTypeClass.purs−16 examples/passing/Church.purs−18 examples/passing/Collatz.purs−18 examples/passing/Comparisons.purs−25 examples/passing/Conditional.purs−9 examples/passing/Console.purs−13 examples/passing/DataAndType.purs−7 examples/passing/DeepArrayBinder.purs−18 examples/passing/DeepCase.purs−14 examples/passing/Do.purs−67 examples/passing/Dollar.purs−16 examples/passing/Eff.purs−25 examples/passing/EmptyDataDecls.purs−34 examples/passing/EmptyRow.purs−8 examples/passing/EmptyTypeClass.purs−12 examples/passing/EqOrd.purs−14 examples/passing/ExtendedInfixOperators.purs−20 examples/passing/ExternData.purs−13 examples/passing/ExternRaw.purs−26 examples/passing/FFI.purs−13 examples/passing/Fib.purs−15 examples/passing/FinalTagless.purs−22 examples/passing/ForeignInstance.purs−20 examples/passing/FunctionScope.purs−19 examples/passing/Functions.purs−15 examples/passing/Functions2.purs−19 examples/passing/Guards.purs−29 examples/passing/HoistError.purs−19 examples/passing/IfThenElseMaybe.purs−9 examples/passing/ImplicitEmptyImport.purs−6 examples/passing/ImportHiding.purs−18 examples/passing/InferRecFunWithConstrainedArgument.purs−8 examples/passing/JSReserved.purs−12 examples/passing/KindedType.purs−31 examples/passing/Let.purs−64 examples/passing/LetInInstance.purs−12 examples/passing/LiberalTypeSynonyms.purs−19 examples/passing/MPTCs.purs−20 examples/passing/Match.purs−7 examples/passing/Monad.purs−32 examples/passing/MonadState.purs−48 examples/passing/MultiArgFunctions.purs−26 examples/passing/MultipleConstructorArgs.purs−21 examples/passing/MutRec.purs−19 examples/passing/MutRec2.purs−17 examples/passing/MutRec3.purs−17 examples/passing/NamedPatterns.purs−7 examples/passing/NegativeBinder.purs−7 examples/passing/Nested.purs−7 examples/passing/NestedTypeSynonyms.purs−11 examples/passing/NestedWhere.purs−10 examples/passing/Newtype.purs−22 examples/passing/NewtypeEff.purs−28 examples/passing/NewtypeWithRecordUpdate.purs−15 examples/passing/ObjectGetter.purs−11 examples/passing/ObjectSynonym.purs−13 examples/passing/ObjectUpdate.purs−18 examples/passing/ObjectUpdate2.purs−14 examples/passing/ObjectUpdater.purs−35 examples/passing/ObjectWildcards.purs−31 examples/passing/Objects.purs−35 examples/passing/OneConstructor.purs−7 examples/passing/OperatorAssociativity.purs−42 examples/passing/OperatorSections.purs−21 examples/passing/Operators.purs−102 examples/passing/OptimizerBug.purs−9 examples/passing/PartialFunction.purs−19 examples/passing/Patterns.purs−28 examples/passing/Person.purs−18 examples/passing/Rank2Data.purs−29 examples/passing/Rank2Object.purs−10 examples/passing/Rank2TypeSynonym.purs−15 examples/passing/Rank2Types.purs−11 examples/passing/Recursion.purs−10 examples/passing/ReservedWords.purs−13 examples/passing/RowPolyInstanceContext.purs−20 examples/passing/RowSynonyms.purs−46 examples/passing/RuntimeScopeIssue.purs−19 examples/passing/ScopedTypeVariables.purs−34 examples/passing/Sequence.purs−12 examples/passing/ShadowedRename.purs−21 examples/passing/ShadowedTCO.purs−16 examples/passing/ShadowedTCOLet.purs−7 examples/passing/SignedNumericLiterals.purs−15 examples/passing/Superclasses1.purs−18 examples/passing/Superclasses2.purs−23 examples/passing/Superclasses3.purs−41 examples/passing/TCOCase.purs−10 examples/passing/TailCall.purs−15 examples/passing/Tick.purs−5 examples/passing/TopLevelCase.purs−18 examples/passing/TypeClassImport.purs−18 examples/passing/TypeClassMemberOrderChange.purs−11 examples/passing/TypeClasses.purs−69 examples/passing/TypeClassesInOrder.purs−11 examples/passing/TypeClassesWithOverlappingTypeVariables.purs−11 examples/passing/TypeDecl.purs−12 examples/passing/TypeSynonymInData.purs−9 examples/passing/TypeSynonyms.purs−25 examples/passing/TypeWildcards.purs−13 examples/passing/TypeWildcardsRecordExtension.purs−6 examples/passing/TypedWhere.purs−13 examples/passing/UnderscoreIdent.purs−9 examples/passing/Unit.purs−6 examples/passing/UnknownInTypeClassLookup.purs−12 examples/passing/Where.purs−49 examples/passing/iota.purs−9 examples/passing/s.purs−5 hierarchy/Main.hs−113 package.yaml+86 prelude/README.md−685 prelude/images/Prelude.png prelude/prelude.purs−1104 prelude/updateDocs.sh−11 psc-docs/Main.hs−272 psc-make/Main.hs−177 psc/Main.hs−209 psci/Commands.hs−87 psci/Main.hs−647 psci/Parser.hs−82 psgo.cabal+145 purescript.cabal−178 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/Language/PureScript.hs−258 src/Language/PureScript/AST.hs−23 src/Language/PureScript/AST/Binders.hs−87 src/Language/PureScript/AST/Declarations.hs−446 src/Language/PureScript/AST/Operators.hs−39 src/Language/PureScript/AST/SourcePos.hs−53 src/Language/PureScript/AST/Traversals.hs−407 src/Language/PureScript/CodeGen.hs−25 src/Language/PureScript/CodeGen/Externs.hs−121 src/Language/PureScript/CodeGen/JS.hs−366 src/Language/PureScript/CodeGen/JS/AST.hs−337 src/Language/PureScript/CodeGen/JS/Common.hs−181 src/Language/PureScript/CodeGen/JS/Optimizer.hs−86 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−201 src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs−165 src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs−103 src/Language/PureScript/CodeGen/JS/Optimizer/Unused.hs−46 src/Language/PureScript/Comments.hs−25 src/Language/PureScript/Constants.hs−239 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−247 src/Language/PureScript/CoreFn/Expr.hs−134 src/Language/PureScript/CoreFn/Literals.hs−46 src/Language/PureScript/CoreFn/Meta.hs−51 src/Language/PureScript/CoreFn/Module.hs−30 src/Language/PureScript/CoreFn/Traversals.hs−85 src/Language/PureScript/DeadCodeElimination.hs−102 src/Language/PureScript/Environment.hs−241 src/Language/PureScript/Errors.hs−140 src/Language/PureScript/Kinds.hs−60 src/Language/PureScript/ModuleDependencies.hs−76 src/Language/PureScript/Names.hs−85 src/Language/PureScript/Options.hs−92 src/Language/PureScript/Parser.hs−35 src/Language/PureScript/Parser/Common.hs−134 src/Language/PureScript/Parser/Declarations.hs−518 src/Language/PureScript/Parser/Kinds.hs−45 src/Language/PureScript/Parser/Lexer.hs−499 src/Language/PureScript/Parser/State.hs−30 src/Language/PureScript/Parser/Types.hs−134 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−129 src/Language/PureScript/Pretty/Values.hs−250 src/Language/PureScript/Renamer.hs−194 src/Language/PureScript/Sugar.hs−68 src/Language/PureScript/Sugar/BindingGroups.hs−205 src/Language/PureScript/Sugar/CaseDeclarations.hs−127 src/Language/PureScript/Sugar/DoNotation.hs−74 src/Language/PureScript/Sugar/Names.hs−548 src/Language/PureScript/Sugar/ObjectWildcards.hs−61 src/Language/PureScript/Sugar/Operators.hs−165 src/Language/PureScript/Sugar/TypeClasses.hs−291 src/Language/PureScript/Sugar/TypeDeclarations.hs−69 src/Language/PureScript/Supply.hs−56 src/Language/PureScript/Traversals.hs−41 src/Language/PureScript/TypeChecker.hs−356 src/Language/PureScript/TypeChecker/Entailment.hs−237 src/Language/PureScript/TypeChecker/Kinds.hs−219 src/Language/PureScript/TypeChecker/Monad.hs−241 src/Language/PureScript/TypeChecker/Rows.hs−66 src/Language/PureScript/TypeChecker/Skolems.hs−115 src/Language/PureScript/TypeChecker/Subsumption.hs−103 src/Language/PureScript/TypeChecker/Synonyms.hs−110 src/Language/PureScript/TypeChecker/Types.hs−677 src/Language/PureScript/TypeChecker/Unify.hs−205 src/Language/PureScript/TypeClassDictionaries.hs−73 src/Language/PureScript/Types.hs−314 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−108 travis-after-script.sh−7 travis-script.sh−11
.gitignore+12
@@ -9,3 +9,15 @@ cabal.sandbox.config
99*.lksh*
1010.virthualenv
1111.psci_modules/
12+.test_modules/
13+bower_components/
14+node_modules
15+tmp/
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.ymldeleted−19
@@ -1,19 +0,0 @@
1−language: haskell
2−ghc: 7.8
3−script:
4− - ./travis-script.sh
5−after_script:
6− - ./travis-after-script.sh
7−notifications:
8− email: true
9−before_deploy: "./bundle/build.sh linux64"
10−deploy:
11− provider: releases
12− api_key: $RELEASE_KEY
13− file:
14− - bundle/linux64.tar.gz
15− - bundle/linux64.sha
16− skip_cleanup: true
17− on:
18− all_branches: true
19− tags: true
CONTRIBUTING.mddeleted−18
@@ -1,18 +0,0 @@
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.
ChangeLog.mdnew file+3
@@ -0,0 +1,3 @@
1+# Changelog for pscpp
2+
3+## Unreleased changes
LICENSE+30−622
@@ -1,622 +1,30 @@
1−The MIT License (MIT)
2−
3−Copyright (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
4−
5−Permission is hereby granted, free of charge, to any person obtaining a copy of
6−this software and associated documentation files (the "Software"), to deal in
7−the Software without restriction, including without limitation the rights to
8−use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of
9−the Software, and to permit persons to whom the Software is furnished to do so,
10−subject to the following conditions:
11−
12−The above copyright notice and this permission notice shall be included in all
13−copies or substantial portions of the Software.
14−
15−THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
16−IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
17−FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
18−COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
19−IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
20−CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
21−
22−PureScript uses the following Haskell library packages. Their license files follow.
23−
24− base
25− containers
26− directory
27− file-embed
28− filepath
29− haskeline
30− monad-unify
31− mtl
32− optparse-applicative
33− parsec
34− pattern-arrows
35− process
36− time
37− transformers
38− unordered-containers
39− utf8-string
40−
41−base LICENSE file:
42−
43− This library (libraries/base) is derived from code from several
44− sources:
45−
46− * Code from the GHC project which is largely (c) The University of
47− Glasgow, and distributable under a BSD-style license (see below),
48−
49− * Code from the Haskell 98 Report which is (c) Simon Peyton Jones
50− and freely redistributable (but see the full license for
51− restrictions).
52−
53− * Code from the Haskell Foreign Function Interface specification,
54− which is (c) Manuel M. T. Chakravarty and freely redistributable
55− (but see the full license for restrictions).
56−
57− The full text of these licenses is reproduced below. All of the
58− licenses are BSD-style or compatible.
59−
60− -----------------------------------------------------------------------------
61−
62− The Glasgow Haskell Compiler License
63−
64− Copyright 2004, The University Court of the University of Glasgow.
65− All rights reserved.
66−
67− Redistribution and use in source and binary forms, with or without
68− modification, are permitted provided that the following conditions are met:
69−
70− - Redistributions of source code must retain the above copyright notice,
71− this list of conditions and the following disclaimer.
72−
73− - Redistributions in binary form must reproduce the above copyright notice,
74− this list of conditions and the following disclaimer in the documentation
75− and/or other materials provided with the distribution.
76−
77− - Neither name of the University nor the names of its contributors may be
78− used to endorse or promote products derived from this software without
79− specific prior written permission.
80−
81− THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF
82− GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
83− INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
84− FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
85− UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE
86− FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
87− DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
88− SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
89− CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
90− LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
91− OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
92− DAMAGE.
93−
94− -----------------------------------------------------------------------------
95−
96− Code derived from the document "Report on the Programming Language
97− Haskell 98", is distributed under the following license:
98−
99− Copyright (c) 2002 Simon Peyton Jones
100−
101− The authors intend this Report to belong to the entire Haskell
102− community, and so we grant permission to copy and distribute it for
103− any purpose, provided that it is reproduced in its entirety,
104− including this Notice. Modified versions of this Report may also be
105− copied and distributed for any purpose, provided that the modified
106− version is clearly presented as such, and that it does not claim to
107− be a definition of the Haskell 98 Language.
108−
109− -----------------------------------------------------------------------------
110−
111− Code derived from the document "The Haskell 98 Foreign Function
112− Interface, An Addendum to the Haskell 98 Report" is distributed under
113− the following license:
114−
115− Copyright (c) 2002 Manuel M. T. Chakravarty
116−
117− The authors intend this Report to belong to the entire Haskell
118− community, and so we grant permission to copy and distribute it for
119− any purpose, provided that it is reproduced in its entirety,
120− including this Notice. Modified versions of this Report may also be
121− copied and distributed for any purpose, provided that the modified
122− version is clearly presented as such, and that it does not claim to
123− be a definition of the Haskell 98 Foreign Function Interface.
124−
125− -----------------------------------------------------------------------------
126−
127−containers LICENSE file:
128−
129− The Glasgow Haskell Compiler License
130−
131− Copyright 2004, The University Court of the University of Glasgow.
132− All rights reserved.
133−
134− Redistribution and use in source and binary forms, with or without
135− modification, are permitted provided that the following conditions are met:
136−
137− - Redistributions of source code must retain the above copyright notice,
138− this list of conditions and the following disclaimer.
139−
140− - Redistributions in binary form must reproduce the above copyright notice,
141− this list of conditions and the following disclaimer in the documentation
142− and/or other materials provided with the distribution.
143−
144− - Neither name of the University nor the names of its contributors may be
145− used to endorse or promote products derived from this software without
146− specific prior written permission.
147−
148− THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF
149− GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
150− INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
151− FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
152− UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE
153− FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
154− DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
155− SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
156− CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
157− LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
158− OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
159− DAMAGE.
160−
161−directory LICENSE file:
162−
163− This library (libraries/base) is derived from code from two
164− sources:
165−
166− * Code from the GHC project which is largely (c) The University of
167− Glasgow, and distributable under a BSD-style license (see below),
168−
169− * Code from the Haskell 98 Report which is (c) Simon Peyton Jones
170− and freely redistributable (but see the full license for
171− restrictions).
172−
173− The full text of these licenses is reproduced below. Both of the
174− licenses are BSD-style or compatible.
175−
176− -----------------------------------------------------------------------------
177−
178− The Glasgow Haskell Compiler License
179−
180− Copyright 2004, The University Court of the University of Glasgow.
181− All rights reserved.
182−
183− Redistribution and use in source and binary forms, with or without
184− modification, are permitted provided that the following conditions are met:
185−
186− - Redistributions of source code must retain the above copyright notice,
187− this list of conditions and the following disclaimer.
188−
189− - Redistributions in binary form must reproduce the above copyright notice,
190− this list of conditions and the following disclaimer in the documentation
191− and/or other materials provided with the distribution.
192−
193− - Neither name of the University nor the names of its contributors may be
194− used to endorse or promote products derived from this software without
195− specific prior written permission.
196−
197− THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF
198− GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
199− INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
200− FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
201− UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE
202− FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
203− DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
204− SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
205− CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
206− LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
207− OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
208− DAMAGE.
209−
210− -----------------------------------------------------------------------------
211−
212− Code derived from the document "Report on the Programming Language
213− Haskell 98", is distributed under the following license:
214−
215− Copyright (c) 2002 Simon Peyton Jones
216−
217− The authors intend this Report to belong to the entire Haskell
218− community, and so we grant permission to copy and distribute it for
219− any purpose, provided that it is reproduced in its entirety,
220− including this Notice. Modified versions of this Report may also be
221− copied and distributed for any purpose, provided that the modified
222− version is clearly presented as such, and that it does not claim to
223− be a definition of the Haskell 98 Language.
224−
225− -----------------------------------------------------------------------------
226−
227−file-embed LICENSE file:
228−
229− The following license covers this documentation, and the source code, except
230− where otherwise indicated.
231−
232− Copyright 2008, Michael Snoyman. All rights reserved.
233−
234− Redistribution and use in source and binary forms, with or without
235− modification, are permitted provided that the following conditions are met:
236−
237− * Redistributions of source code must retain the above copyright notice, this
238− list of conditions and the following disclaimer.
239−
240− * Redistributions in binary form must reproduce the above copyright notice,
241− this list of conditions and the following disclaimer in the documentation
242− and/or other materials provided with the distribution.
243−
244− THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR
245− IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
246− MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO
247− EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,
248− INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
249− NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,
250− OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
251− LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
252− OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
253− ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
254−
255−filepath LICENSE file:
256−
257− Copyright Neil Mitchell 2005-2007.
258− All rights reserved.
259−
260− Redistribution and use in source and binary forms, with or without
261− modification, are permitted provided that the following conditions are
262− met:
263−
264− * Redistributions of source code must retain the above copyright
265− notice, this list of conditions and the following disclaimer.
266−
267− * Redistributions in binary form must reproduce the above
268− copyright notice, this list of conditions and the following
269− disclaimer in the documentation and/or other materials provided
270− with the distribution.
271−
272− * Neither the name of Neil Mitchell nor the names of other
273− contributors may be used to endorse or promote products derived
274− from this software without specific prior written permission.
275−
276− THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
277− "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
278− LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
279− A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
280− OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
281− SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
282− LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
283− DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
284− THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
285− (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
286− OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
287−
288−haskeline LICENSE file:
289−
290− Copyright 2007-2009, Judah Jacobson.
291− All Rights Reserved.
292−
293− Redistribution and use in source and binary forms, with or without
294− modification, are permitted provided that the following conditions are met:
295−
296− - Redistribution of source code must retain the above copyright notice,
297− this list of conditions and the following disclaimer.
298−
299− - Redistribution in binary form must reproduce the above copyright notice,
300− this list of conditions and the following disclaimer in the documentation
301− and/or other materials provided with the distribution.
302−
303− THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS "AS IS" AND ANY
304− EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
305− WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
306− DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR THE CONTRIBUTORS BE LIABLE
307− FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
308− DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
309− SERVICES; LOSS OF USE, DATA OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
310− CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
311− OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
312− USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
313−
314−monad-unify LICENSE file:
315−
316− The MIT License (MIT)
317−
318− Copyright (c) 2013 Phil Freeman
319−
320− Permission is hereby granted, free of charge, to any person obtaining a copy of
321− this software and associated documentation files (the "Software"), to deal in
322− the Software without restriction, including without limitation the rights to
323− use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of
324− the Software, and to permit persons to whom the Software is furnished to do so,
325− subject to the following conditions:
326−
327− The above copyright notice and this permission notice shall be included in all
328− copies or substantial portions of the Software.
329−
330− THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
331− IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
332− FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
333− COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
334− IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
335− CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
336−
337−mtl LICENSE file:
338−
339− The Glasgow Haskell Compiler License
340−
341− Copyright 2004, The University Court of the University of Glasgow.
342− All rights reserved.
343−
344− Redistribution and use in source and binary forms, with or without
345− modification, are permitted provided that the following conditions are met:
346−
347− - Redistributions of source code must retain the above copyright notice,
348− this list of conditions and the following disclaimer.
349−
350− - Redistributions in binary form must reproduce the above copyright notice,
351− this list of conditions and the following disclaimer in the documentation
352− and/or other materials provided with the distribution.
353−
354− - Neither name of the University nor the names of its contributors may be
355− used to endorse or promote products derived from this software without
356− specific prior written permission.
357−
358− THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF
359− GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
360− INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
361− FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
362− UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE
363− FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
364− DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
365− SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
366− CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
367− LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
368− OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
369− DAMAGE.
370−
371−optparse-applicative LICENSE file:
372−
373− Copyright (c) 2012, Paolo Capriotti
374−
375− All rights reserved.
376−
377− Redistribution and use in source and binary forms, with or without
378− modification, are permitted provided that the following conditions are met:
379−
380− * Redistributions of source code must retain the above copyright
381− notice, this list of conditions and the following disclaimer.
382−
383− * Redistributions in binary form must reproduce the above
384− copyright notice, this list of conditions and the following
385− disclaimer in the documentation and/or other materials provided
386− with the distribution.
387−
388− * Neither the name of Paolo Capriotti nor the names of other
389− contributors may be used to endorse or promote products derived
390− from this software without specific prior written permission.
391−
392− THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
393− "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
394− LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
395− A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
396− OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
397− SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
398− LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
399− DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
400− THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
401− (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
402− OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
403−
404−parsec LICENSE file:
405−
406− Copyright 1999-2000, Daan Leijen; 2007, Paolo Martini. All rights reserved.
407−
408− Redistribution and use in source and binary forms, with or without
409− modification, are permitted provided that the following conditions are met:
410−
411− * Redistributions of source code must retain the above copyright notice,
412− this list of conditions and the following disclaimer.
413− * Redistributions in binary form must reproduce the above copyright
414− notice, this list of conditions and the following disclaimer in the
415− documentation and/or other materials provided with the distribution.
416−
417− This software is provided by the copyright holders "as is" and any express or
418− implied warranties, including, but not limited to, the implied warranties of
419− merchantability and fitness for a particular purpose are disclaimed. In no
420− event shall the copyright holders be liable for any direct, indirect,
421− incidental, special, exemplary, or consequential damages (including, but not
422− limited to, procurement of substitute goods or services; loss of use, data,
423− or profits; or business interruption) however caused and on any theory of
424− liability, whether in contract, strict liability, or tort (including
425− negligence or otherwise) arising in any way out of the use of this software,
426− even if advised of the possibility of such damage.
427−
428−pattern-arrows LICENSE file:
429−
430− The MIT License (MIT)
431−
432− Copyright (c) 2013 Phil Freeman
433−
434− Permission is hereby granted, free of charge, to any person obtaining a copy of
435− this software and associated documentation files (the "Software"), to deal in
436− the Software without restriction, including without limitation the rights to
437− use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of
438− the Software, and to permit persons to whom the Software is furnished to do so,
439− subject to the following conditions:
440−
441− The above copyright notice and this permission notice shall be included in all
442− copies or substantial portions of the Software.
443−
444− THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
445− IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
446− FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
447− COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
448− IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
449− CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
450−
451−process LICENSE file:
452−
453− This library (libraries/process) is derived from code from two
454− sources:
455−
456− * Code from the GHC project which is largely (c) The University of
457− Glasgow, and distributable under a BSD-style license (see below),
458−
459− * Code from the Haskell 98 Report which is (c) Simon Peyton Jones
460− and freely redistributable (but see the full license for
461− restrictions).
462−
463− The full text of these licenses is reproduced below. Both of the
464− licenses are BSD-style or compatible.
465−
466− -----------------------------------------------------------------------------
467−
468− The Glasgow Haskell Compiler License
469−
470− Copyright 2004, The University Court of the University of Glasgow.
471− All rights reserved.
472−
473− Redistribution and use in source and binary forms, with or without
474− modification, are permitted provided that the following conditions are met:
475−
476− - Redistributions of source code must retain the above copyright notice,
477− this list of conditions and the following disclaimer.
478−
479− - Redistributions in binary form must reproduce the above copyright notice,
480− this list of conditions and the following disclaimer in the documentation
481− and/or other materials provided with the distribution.
482−
483− - Neither name of the University nor the names of its contributors may be
484− used to endorse or promote products derived from this software without
485− specific prior written permission.
486−
487− THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF
488− GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
489− INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
490− FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
491− UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE
492− FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
493− DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
494− SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
495− CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
496− LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
497− OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
498− DAMAGE.
499−
500− -----------------------------------------------------------------------------
501−
502− Code derived from the document "Report on the Programming Language
503− Haskell 98", is distributed under the following license:
504−
505− Copyright (c) 2002 Simon Peyton Jones
506−
507− The authors intend this Report to belong to the entire Haskell
508− community, and so we grant permission to copy and distribute it for
509− any purpose, provided that it is reproduced in its entirety,
510− including this Notice. Modified versions of this Report may also be
511− copied and distributed for any purpose, provided that the modified
512− version is clearly presented as such, and that it does not claim to
513− be a definition of the Haskell 98 Language.
514−
515− -----------------------------------------------------------------------------
516−
517−time LICENSE file:
518−
519− TimeLib is Copyright (c) Ashley Yakeley, 2004-2014. All rights reserved.
520− Certain sections are Copyright 2004, The University Court of the University of Glasgow. All rights reserved.
521−
522− Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:
523−
524− - Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.
525−
526− - 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.
527−
528− 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.
529−
530−transformers LICENSE file:
531−
532− The Glasgow Haskell Compiler License
533−
534− Copyright 2004, The University Court of the University of Glasgow.
535− All rights reserved.
536−
537− Redistribution and use in source and binary forms, with or without
538− modification, are permitted provided that the following conditions are met:
539−
540− - Redistributions of source code must retain the above copyright notice,
541− this list of conditions and the following disclaimer.
542−
543− - Redistributions in binary form must reproduce the above copyright notice,
544− this list of conditions and the following disclaimer in the documentation
545− and/or other materials provided with the distribution.
546−
547− - Neither name of the University nor the names of its contributors may be
548− used to endorse or promote products derived from this software without
549− specific prior written permission.
550−
551− THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF
552− GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
553− INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
554− FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
555− UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE
556− FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
557− DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
558− SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
559− CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
560− LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
561− OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
562− DAMAGE.
563−
564−unordered-containers LICENSE file:
565−
566− Copyright (c) 2010, Johan Tibell
567−
568− All rights reserved.
569−
570− Redistribution and use in source and binary forms, with or without
571− modification, are permitted provided that the following conditions are met:
572−
573− * Redistributions of source code must retain the above copyright
574− notice, this list of conditions and the following disclaimer.
575−
576− * Redistributions in binary form must reproduce the above
577− copyright notice, this list of conditions and the following
578− disclaimer in the documentation and/or other materials provided
579− with the distribution.
580−
581− * Neither the name of Johan Tibell nor the names of other
582− contributors may be used to endorse or promote products derived
583− from this software without specific prior written permission.
584−
585− THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
586− "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
587− LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
588− A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
589− OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
590− SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
591− LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
592− DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
593− THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
594− (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
595− OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
596−
597−utf8-string LICENSE file:
598−
599− * Copyright (c) 2007, Galois Inc.
600− * All rights reserved.
601− *
602− * Redistribution and use in source and binary forms, with or without
603− * modification, are permitted provided that the following conditions are met:
604− * * Redistributions of source code must retain the above copyright
605− * notice, this list of conditions and the following disclaimer.
606− * * Redistributions in binary form must reproduce the above copyright
607− * notice, this list of conditions and the following disclaimer in the
608− * documentation and/or other materials provided with the distribution.
609− * * Neither the name of Galois Inc. nor the
610− * names of its contributors may be used to endorse or promote products
611− * derived from this software without specific prior written permission.
612− *
613− * THIS SOFTWARE IS PROVIDED BY Galois Inc. ``AS IS'' AND ANY
614− * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
615− * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
616− * DISCLAIMED. IN NO EVENT SHALL Galois Inc. BE LIABLE FOR ANY
617− * DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
618− * (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
619− * LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
620− * ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
621− * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
622− * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
1+Copyright Andy Arvanitis (c) 2018
2+
3+All rights reserved.
4+
5+Redistribution and use in source and binary forms, with or without
6+modification, are permitted provided that the following conditions are met:
7+
8+ * Redistributions of source code must retain the above copyright
9+ notice, this list of conditions and the following disclaimer.
10+
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.mdnew file+48
@@ -0,0 +1,48 @@
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+41−16
@@ -1,16 +1,41 @@
1−[![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)
2−[![Hackage](https://budueba.com/hackage/purescript)](http://hackage.haskell.org/package/purescript)
3−
4−PureScript is a small strongly, statically typed programming language with expressive types, written in and inspired by Haskell, and compiling to Javascript.
5−
6−## Resources
7−
8−- [PureScript Book](https://leanpub.com/purescript/read)
9−- [Wiki](http://wiki.purescript.org)
10−- [#purescript IRC @ FreeNode](http://webchat.freenode.net/?channels=purescript)
11−- [Twitter](http://twitter.com/purescript)
12−- [Google Group](https://groups.google.com/forum/#!forum/purescript)
13−- [Try PureScript!](http://try.purescript.org/)
14−- [Pursuit Search Engine](http://pursuit.purescript.org/)
15−- [Release Notes](https://github.com/purescript/purescript/blob/master/RELEASE-0.6.md)
16−- [Contributing to PureScript](https://github.com/purescript/purescript/blob/master/CONTRIBUTING.md)
1+[![PureScript](https://raw.githubusercontent.com/purescript/purescript/master/logo.png)](http://purescript.org)
2+
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.
4+
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).
6+
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`
20+
21+
22+#### Requirements for building `pscpp` and `psgo`
23+
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/))
25+
26+#### Requirements for using PureScript + purescript-native
27+
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+---
RELEASE-0.2.mddeleted−85
@@ -1,85 +0,0 @@
1−## 0.2.0 Changes
2−
3−Many thanks to the [contributors](https://github.com/purescript/purescript/graphs/contributors) who helped with this release.
4−
5−- Full language guide can be found [here](http://functorial.com/purescript).
6−- Try out the latest features [here](http://tryps.functorial.com).
7−
8−### New Features
9−
10−- RankNTypes
11−
12− This experimental feature allows polymorphic types (introduced with `forall`) to appear on the left of a function arrow, or as the type of a record field, etc. For example:
13−
14− rank2 :: (forall a. a -> a) -> Number
15− rank2 = \f -> if f true then f 1 else f 2
16−
17−- Modules
18−- Polymorphic Object Update
19−
20− Records now support member update in which the type of the field changes during the update. For example:
21−
22− data Wrap a = Wrap a
23−
24− update = \o -> o { prop = Wrap o.prop }
25−
26−### Enhancements
27−
28−- Naked expressions as statements
29−
30− Naked expressions of type `{}` can now be used as statements.
31−
32−- Split code generation into `AST -> JS` and `JS -> String`
33−
34− JavaScript generation is now split into the generation of a JavaScript AST, and the pretty-printing of that AST. This enables some optimizations, and a better JavaScript pretty-printer.
35−
36−- Syntactic sugar for introducing curried functions
37−
38− Single-argument functions and multiple-argument functions can now be introduced in the same way:
39−
40− test = \a (b, c) d -> a + b + c + d
41−
42−- JavaScript optimizations
43−
44− Some basic dead-variable elimination, inlining and eta-conversion are now performed on the generated JavaScript.
45−
46−- Generate formatted Javascript
47−
48− The generated JavaScript is now formatted to be more readable. In particular, newlines get generated, and the correct indentation is used.
49−
50−- More valid infix operators
51−
52− The colon and period characters are now valid in infix operator names.
53−
54−### Syntax Changes
55−
56−- Avoid 'do' keyword for blocks
57−
58− `do` will be used later for Haskell-like monad comprehensions, so its previous use in introducing blocks of statements is now invalid. The `do` keyword is still reserved.
59−
60−- Member foreign import syntax
61−
62− A small syntactic addition to the FFI, to support a common use case.
63−
64−- Make FFI syntax match Haskell
65−
66− Use `foreign import` instead of `extern`.
67−
68−- Make record declaration syntax match Haskell
69−- Simplify array binders
70−
71− There are now two types of array binders: cons binders `x : xs -> ...` and array binders `[x, y, z] -> ...` instead of the previously confusing `[x:xs]`.
72−
73−- Array indexing syntax is ambiguous
74−
75− Array elements are now accessed using the `!!` operator: `arr !! 0` etc.
76−
77−### Bug Fixes
78−
79−- Allow guards access to current scope
80−
81−### Libraries
82−
83−- Prelude
84−
85− There is now a basic prelude in the `libraries/prelude` folder.
RELEASE-0.3.mddeleted−85
@@ -1,85 +0,0 @@
1−## 0.3.0 Changes
2−
3−Many thanks to the [contributors](https://github.com/purescript/purescript/graphs/contributors) who helped with this release.
4−
5−- Full language guide can be found [here](http://functorial.com/purescript).
6−- Try out the latest features [here](http://tryps.functorial.com).
7−
8−## New Features / Enhancements
9−
10−- Mutually recursive functions and types are now allowed within a module.
11−- Syntactic sugar for patterns in top-level declarations has been added. For example:
12−
13− sum [] = 0
14− sum (x:xs) = x + sum xs
15−
16−- Basic support for type classes has been added. Polymorphic types of the form `forall a. (C a) => ...` will not be inferred but can be checked. Type inference still works if all type class instances can be determined. There is not yet support for functionality like GHC's `FlexibleInstances`, `FlexibleContexts` or `MultiParamTypesClasses`. For example:
17−
18− class Truthy a where
19− isTrue :: a -> Boolean
20−
21− instance Truthy Boolean where
22− isTrue b = b
23−
24− instance Truthy String where
25− isTrue "" = false
26− isTrue _ = true
27−
28− ifThenElse :: forall a b. (Truthy a) => a -> b -> b -> b
29− ifThenElse a tr fa = if isTrue a then tr else fa
30−
31−- There is now support for `do` notation, using the `Monad` type class from the `Prelude` module. For example:
32−
33− data Maybe = Nothing | Just a
34−
35− instance Prelude.Monad Maybe where
36− ret = Just
37− (>>=) Nothing _ = Nothing
38− (>>=) (Just a) f = f a
39−
40− test = do
41− x <- Just 1
42− y <- Just 2
43− ret $ x + y
44−
45−- There is now a better story for side-effects. The `Eff` module in the `Prelude` defines a monad `Eff e` where e is a row of effect types. The kind system now defines a new kind `!` of effects. Row polymorphism allows different native effects to be interleaved. For example:
46−
47− test = do
48− trace "Testing"
49− throwError "Error!"
50−
51− has inferred type `forall eff. Eff (trace :: Trace | error :: Error String | eff)`.
52− See the `/examples/passing/Eff.purs` file for a more in-depth set of examples.
53− Supported native effects currently include `ST`, `Trace`, `Error` and `DOM` (via the `libraries/jquery` module).
54−- There is a new flag `--run-main` which will check the type of the `Main.main` function and emit the call to `main();` after all other generated Javascript.
55−- The `Prelude` module is now automatically included, unless the `--no-prelude` flag is specified.
56−- The class of accepted operator names has been expanded. Specifically, `$` is now a valid operator, and is defined in the `Prelude` module.
57−- Tail calls can be eliminated using the `--tco` flag.
58−- There is basic support for checking the types of values at runtime, using the `--runtime-type-checks` flag. Right now, this only works for primitive types, and so is a work-in-progress.
59−- GHCJS/Fay-style foreign imports are now supported. An example is
60−
61− foreign import "function(n) { \
62− \ return function(p) {\
63− \ return Math.pow(n, p);\
64− \ }\
65− \ }" pow :: Number -> Number -> Number
66−- Data constructors now get imported along with their type definitions.
67−- The `-s` flag will now cause the compiler to use `stdin` for input.
68−- There is a new executable `psci` which provides simple REPL-like functionality - it parses expressions, passes the generated Javascript to Node for execution, and prints the result. This is a work-in-progress.
69−- The JQuery example (`libraries/jquery/test`) has been improved to use the new `Eff` monad and `do` notation.
70−
71−## Regressions
72−
73−- `foreach` is no longer supported. The `Prelude` module defines `map` which should provide the same functionality.
74−- Support for naked expressions as statements has been removed.
75−
76−## Bug Fixes
77−
78−- Operator precedence rules now work across modules.
79−- A bug in which expressions involving non-qualified names did not typecheck was fixed.
80−- Trailing spaces have been removed in the generated Javascript, thanks to @utkarshkukreti.
81−- Type synonyms now work properly across modules.
82−- Module imports are not transitive, which was previously leading to some unexpected error messages.
83−- A bug which caused the optimizer to break generated Javascript for mutually recursive values was fixed.
84−- Some `Prelude` functions which called methods in the standard Javascript library have been fixed.
85−
RELEASE-0.4.mddeleted−60
@@ -1,60 +0,0 @@
1−## 0.4.0 Changes
2−
3−This release focussed mainly on bug fixes and minor enhancements, in order to provide a stable release of the compiler.
4−
5−This release saw major contributions from [a number of new contributors](https://github.com/purescript/purescript/graphs/contributors). Thank you very much to everyone who submitted pull requests, issues and suggestions, and also to the users of the #purescript FreeNode channel for their valuable feedback. As always, new contributors are always welcome!
6−
7−- The full language guide can be found [here](http://purescript.readthedocs.org).
8−- Try out the latest features [here](http://tryps.functorial.com).
9−
10−## Breaking Changes
11−
12−- Multiple argument functions are no longer available.
13−- When used in the browser, PureScript modules are now accessed through `window.PS.<ModuleName>`. The `PS` object name can be changed via the `--browser-namespace` compiler argument.
14−- The `--run-main` argument has been replaced with `--main` which can now accept a module name in which to find the `main` function.
15−
16−### New Features
17−
18−- Dead code elimination. The new compiler argument `--module=` can be used to specify one or more modules that should be kept in the generated code along with their dependencies. If no modules are specified, all code is exported.
19−
20−### Enhancements
21−
22−- The `->` and `[]` types are now usable in type class instances.
23−- The file path is included in syntax error messages.
24−- Most reserved Javascript names (`return`, `const`, etc) are now usable.
25−- Generated code for operators is more user friendly (for example, `Prelude[">>="]`). Where this transformation cannot be applied, human-readable variable names (e.g. `$greater$greater$eq`) are generated.
26−- The typechecker's function application judgement was greatly simplified, and as a result, more valid things now typecheck.
27−- Data constructors with multiple arguments can now be defined.
28−- It is no longer necessary to sort modules in order of dependencies manually.
29−- Case statements matching data constructors no longer generate unnecessary constructor checks at runtime if there is only a single data constructor.
30−- New optimizer rules were added to inline JavaScript's built-in operators.
31−
32−### Bug Fixes
33−
34−- Floats parse correctly.
35−- Using data constructors in pattern matches now works properly across modules.
36−- PureScript modules no longer overwrite global objects with the same name.
37−- Show problems with shadowing of names were fixed.
38−- Problems with recursive non-function values were fixed.
39−- Type synonyms can now expand to types containing more type synonyms.
40−- A bug in capture-avoiding type variable substitution which was affecting the `Functor (Either e)` instance was fixed.
41−- Type synonym instances are now disallowed.
42−- Precedence rules for some basic operators were corrected.
43−- A bug which allowed skolem variables to escape their scope was add (thanks to Brian McKenna).
44−- Modules containing mutually recursive type synonyms and data declarations now compile correctly.
45−- A number of bugs in the optimizer were addressed.
46−
47−### Libraries
48−
49−- The `Prelude` has been greatly expanded. Definitions for built-in JavaScript operators have been moved into the Prelude.
50−- Gary Burgess has released the [grunt-purescript library](https://github.com/purescript/grunt-purescript) to build PureScript code using Grunt.
51−- The [purescript-parsing](https://github.com/purescript/purescript-parsing) library provides Parsec-like parsing combinators.
52−- The [purescript-promises](https://github.com/purescript/purescript-promises) library provides `Monad` and `Applicative` instances for promises.
53−- The [purescript-quickcheck](https://github.com/purescript/purescript-quickcheck) library provides a very basic implementation of a QuickCheck-style testing harness.
54−- The [purescript-json](https://github.com/purescript/purescript-json) library aims to provide a safe way to consume JSON data.
55−
56−### Documentation
57−
58−- Documentation for the `Prelude` modules is now automatically generated and can be found [here](http://purescript.readthedocs.org/en/latest/prelude.html).
59−- There is now Hackage documentation.
60−- Code comments have been improved.
RELEASE-0.5.mddeleted−99
@@ -1,99 +0,0 @@
1−## 0.5.0 Changes
2−
3−### Breaking Changes
4−
5−- Support for blocks has been removed. (paf31)
6−- Type class instances must now be named (paf31)
7−
8− instance showNumber :: Show Number where
9− ...
10−
11−- Prelude modules now follow a naming scheme similar to haskell (e.g. `Data.Maybe`, `Control.Monad`) (garyb)
12−- Many modules that were previously part of the Prelude have been split into individual libraries, [now distributed via Bower](http://bower.io/search/?q=purescript) (garyb)
13−- Multiple modules with the same name are now disallowed rather than merged (garyb)
14−- The `Prelude` module is now imported automatically. Conflicts can be avoided by using qualified imports or an explicit import list. (garyb, paf31)
15−- Overlapping instances are no longer allowed. The `Prelude` and core libraries have been updated accordingly. (paf31)
16−- `Functor`, `Applicative`, `Monad` are now part of a class heirarchy that include `Apply` and `Bind`. `return` is now an alias for `pure`. (joneshf, paf31, garyb)
17−- `Semigroupoid` is now a superclass of `Category` (garyb)
18−- `(:)` is now part of Prelude (garyb)
19−- `(!!)` has been renamed to `Prelude.Unsafe.unsafeIndex` and a safe version has been added to `Data.Array` (garyb)
20−
21−### New Features
22−
23−- Multi parameter typeclasses (paf31)
24−- Superclasses (puffnfresh, paf31)
25−- FlexibleInstances and FlexibleContexts (paf31)
26−- Let bindings are now supported. The `let` keyword can introduce several local (possibly mutually recursive) bindings, along with optional type signatures. (paf31)
27−- `where` clauses are now supported in value declarations, with the same rules as `let` bindings (garyb)
28−- Empty data declarations and empty type classes are now supported (paf31)
29−- A new command line option `--codegen` controls which modules will have Javascript and externs generated (paf31)
30−- `psc-make` now generates CommonJS-compatible modules, which can be used with `require()` in `node`. `psc` still generates modules for use in the browser. (paf31, garyb)
31−
32−### Enhancements
33−
34−- Pretty printing for row types was improved (garyb)
35−- Module names can now contain `.` (garyb)
36−- New optimizer rules have been added for code in the ST monad, to reproduce the functionality of the blocks feature, which has been removed (paf31)
37−- Pattern binders are now usable in lambda expression arguments (paf31)
38−- PSCI now has a `:t` command for checking the type of a value (paf31)
39−- Array pretty printing via `show` has been improved (joneshf)
40−- PSCI completions are sorted (joneshf)
41−- PSCI now has help commands (joneshf)
42−- PSCI history is in XDG config (joneshf)
43−- PSCI allows loading of modules from ~ paths (joneshf)
44−- PSCI can accept a list of modules to load on start from the command line (paf31)
45−- PSCI can now be configured using a `.psci` file in the current directory. If such a file exists, it should contain a list of commands to run on startup. (paf31)
46−- Type class instances are now named, to enable easier interop with Javascript (paf31)
47−- Class names no longer need to be qualified in instance declarations (garyb)
48−- Module exports can now be specified explicitly (garyb)
49−- Let bindings can now define functions with binders (paf31)
50−- Case statements and functions which do not pattern match on their arguments now generate smaller code (paf31)
51−- Imported type class instances are now exported (paf31)
52−- Some error messages were improved (paf31)
53−- Qualfied module imports are now supported as `import qualified M as X` (garyb)
54−- The escape check was removed, since it was too restrictive (paf31)
55−- The binary operator reordering step was greatly simplified (paf31)
56−- The Object type constructor can now be referenced explicitly as `Prim.Object` (with kind `# * -> *`) (paf31)
57−- Optimizations are now enabled by default and can be disabled with the `--no-tco` and `--no-magic-do` flags (garyb)
58−- Unary minus and signed numeric literals are now supported again (paf31, garyb)
59−- Type errors have been simplified, the full trace can be enabled with `--verbose-errors` or `-v` (paf31)
60−- Error messages now display source positions (paf31, garyb)
61−- The type classes implementation and code generation was greatly simplified (paf31)
62−- Object properties and row labels can now be accessed with arbitrary string names by using string literals (paf31)
63−- `(++)` is now an alias for the Semigroup operator `(<>)` (paf31)
64−- Error messages for classes with undefined or missing members have been improved (garyb)
65−- The SYB dependency was removed, and traversals rewritten by hand, for a large performance increase (paf31)
66−
67−### Bug Fixes
68−
69−- The subsumes relation has been fixed for object types (paf31)
70−- `sort` no longer mutates arrays (joneshf)
71−- PSCI now evaluates expressions (joneshf)
72−- Overlapping variables in typeclass instances are rejected (paf31)
73−- A bug in the optimizer related to inlining was fixed (paf31)
74−- A type checker bug related to array literals was fixed (paf31)
75−- Externs files (`--externs`) are now working again (paf31)
76−- Precedence of backticked infix functions have been corrected (paf31)
77−- A bug which allowed some incorrect type class instances to pass the type checker was fixed (paf31)
78−- Type synonyms are no longer restricted to kind `*` (paf31)
79−- Negative number literals have been restored (garyb)
80−- If a type defined in a module appears in an exported declaration it must also be exported from the module (garyb)
81−- Error messages for unresolvable types or values include the declaration name again (garyb)
82−- Characters in string literals are now properly escaped (garyb)
83−- A module containing a single orphan type declaration and no other declarations now fails to compile (garyb)
84−- An error involving ordering of type class instances was fixed (garyb, paf31)
85−- Externs files no longer include fixity declarations for members that were removed as dead code (garyb)
86−- A bug which prevented `sequence $ [Just 1]` from typechecking was fixed (paf31)
87−
88−### Libraries
89−
90−- Purescript libraries are now [distributed via Bower](http://bower.io/search/?q=purescript). There are currently around 40 libraries available.
91−
92−### Plugins
93−
94−- The `grunt-purescript` plugin has been updated to provide support for new command line options.
95−- There is a new `gulp-purescript` plugin available for compiling with Gulp.
96−
97−### Documentation
98−
99−- There is a new `hierarchy` executable which will generate `.dot` diagrams based on the type class hierarchy of a module. The Prelude docs have been updated to include such a type class diagram. (joneshf)
RELEASE-0.6.mddeleted−63
@@ -1,63 +0,0 @@
1−## 0.6 Changes
2−
3−### Breaking Changes
4−
5−- The `Alternative` type class hierarchy was refactored. See [here](https://github.com/purescript/purescript-control/issues/6).
6−- `--runtime-type-checks` has been removed. The recommended approach is to use `purescript-foreign`. (@garyb)
7−- The `Unit` type is now used in the Prelude and core libraries to represent values containing no data. (@garyb)
8−- The Prelude is no longer distributed as a separate file, but is embedded in the compiler executables. (@paf31)
9−
10−### New Features
11−
12−- Newtypes are now supported using the `newtype` keyword. The runtime representation of a newtype is identical to that of the contained type. (@garyb)
13−- Multiline string literals are now supported via triple-quote syntax, making FFI declarations much neater. (@phadej)
14−- Kind signatures on types and type constructor arguments are now supported. (@paf31)
15−
16−### Enhancements
17−
18−- The `runFnN` and `mkFnN` families of functions are now inlined by the optimizer, making interop with JavaScript functions of multiple arguments much simpler. (@paf31)
19−- Tail call optimization has been improved for functions using case expressions. (@paf31)
20−- Saturated calls to data constructors are now optimized. (@garyb)
21−- A new `Renamer` module now renames identifiers which shadow other names in scope, which greatly simplies code generation. (@garyb)
22−- `psci` now provides the following new options:
23− - `:b` to browse a module (@ardumont)
24− - `:s` to show current imports or modules (@ardumont)
25− - `:k` to find the kind of a type constructor (@5outh)
26−- The approach to checking whether a name is initialized in the generated JavaScript was simplified (@paf31)
27−- The dependency on the `PureScript_paths` module has been removed, which makes distribution via binaries simpler. (@paf31)
28−- Nested `if` blocks now get optimized. (@garyb)
29−- Generated code for type class dictionaries was simplified. (@garyb, @dylex)
30−- The code generator now inserts the version of `psc` into the file as a comment. (@co-dh)
31−- `()` is now valid syntax, referring to the empty row. (@paf31)
32−- The type checker will now display multiple errors for type errors in the same binding group. (@paf31)
33−- Imports can now specify hidden names using `import ... hiding ( ... )` (@andreypopp)
34−
35−### Bug Fixes
36−
37−- Binding group errors in type class members are now caught at compile time. (@dylex)
38−- Some errors related to type checking rows with duplicate labels were fixed. (@paf31)
39−- Some issues with the calculation of binding groups were fixed. (@paf31)
40−- Error messages for invalid case declarations are now generated. (@natefaubion)
41−- Some issues related to module exports were fixed. (@garyb)
42−- `psci` now checks imports for validity. (@Bogdanp)
43−
44−### Libraries
45−
46−- The `Alternative` type class hierarchy was refactored (@joneshf, @garyb)
47−- The `exceptions` library no longer supports throwing exceptions of any type.
48−- The following libraries have been moved to the core PureScript organisation: (@garyb)
49− - `purescript-transformers`
50− - `purescript-free`
51− - `purescript-const`
52− - `purescript-identity`
53− - `purescript-lazy`
54− - `purescript-distributive`
55− - `purescript-bifunctors`
56− - `purescript-contravariant`
57− - `purescript-profunctors`
58− - `purescript-maps`
59−
60−### Documentation
61−
62−- The [PureScript book](https://leanpub.com/purescript/read) is now available.
63−- The [PureScript wiki](https://github.com/purescript/purescript/wiki) is now the main resource for compiler and library documentation.
RELEASE-0.7.mddeleted−51
@@ -1,51 +0,0 @@
1−## 0.6.1 Changes
2−
3−### Breaking Changes
4−
5−- The body of a guarded expression must now be indented _past the guard_. For example, this is valid:
6−
7−```haskell
8−positive n | n > 0 = true
9−positive _ = false
10−```
11−
12−but this is not:
13−
14−```haskell
15−positive n | n > 0
16− = true
17−positive _ = false
18−```
19−
20−### New Features
21−
22−- Type wildcards are now supported (#287, @paf31)
23−
24−### Enhancements
25−
26−- Allow unquoted keywords as key names in record literals (#606, @michaelficarra)
27−- Import instances when referencing qualified values (#667, @garyb)
28−- Multiple guard clauses are now supported (#294, @paf31)
29−- Type check let declarations immediately in psci (#615, @garyb)
30−
31−## 0.6.2 Changes
32−
33−### Breaking Changes
34−
35−-
36−
37−### New Features
38−
39−-
40−
41−### Enhancements
42−
43−-
44−
45−### Libraries
46−
47−-
48−
49−### Documentation
50−
51−-
Setup.hs−4
@@ -1,6 +1,2 @@
1−module Main where
2−
31import Distribution.Simple
4−
5−main :: IO ()
62main = defaultMain
app/Main.hsnew file+250
@@ -0,0 +1,250 @@
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/.gitignoredeleted−3
@@ -1,3 +0,0 @@
1−build/
2−*.tar.gz
3−*.sha
bundle/READMEdeleted−20
@@ -1,20 +0,0 @@
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.shdeleted−43
@@ -1,43 +0,0 @@
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−
24−# Copy files to staging directory
25−cp ../dist/build/psc/psc build/purescript/
26−cp ../dist/build/psci/psci build/purescript/
27−cp ../dist/build/psc-make/psc-make build/purescript/
28−cp ../dist/build/psc-docs/psc-docs build/purescript/
29−cp README build/purescript/
30−cp ../LICENSE build/purescript/
31−
32−# Make the binary bundle
33−pushd build > /dev/null
34−tar -zcvf ../$OS.tar.gz purescript
35−popd > /dev/null
36−
37−# Calculate the SHA hash
38−shasum $OS.tar.gz > $OS.sha
39−
40−# Remove the staging directory
41−rm -rf build/
42−
43−popd > /dev/null
bundle/winbuild.shdeleted−40
@@ -1,40 +0,0 @@
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−
20−# Copy files to staging directory
21−cp ../dist/build/psc/psc.exe build/purescript/
22−cp ../dist/build/psci/psci.exe build/purescript/
23−cp ../dist/build/psc-make/psc-make.exe build/purescript/
24−cp ../dist/build/psc-docs/psc-docs.exe build/purescript/
25−cp README build/purescript/
26−cp ../LICENSE build/purescript/
27−
28−# Make the binary bundle
29−pushd build
30−tar -zcvf ../win64.tar.gz purescript
31−popd
32−
33−# Calculate the MD5 hash
34−md5sum win64.tar.gz > win64.md5
35−
36−# Remove the staging directory
37−rm -rf build/
38−
39−popd
40−
default.nixnew file+23
@@ -0,0 +1,23 @@
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/.gitignoredeleted−1
@@ -1 +0,0 @@
1−shelltest/tests
examples/failing/ArrayType.pursdeleted−11
@@ -1,11 +0,0 @@
1−module Main where
2−
3−import Debug.Trace
4−
5−bar :: Number -> Number -> Number
6−bar n m = n + m
7−
8−foo = x `bar` y
9− where
10− x = 1
11− y = []
examples/failing/Arrays.pursdeleted−5
@@ -1,5 +0,0 @@
1−module Main where
2−
3− import Prelude
4−
5− test = \arr -> arr !! (0 !! 0)
examples/failing/Do.pursdeleted−8
@@ -1,8 +0,0 @@
1−module Main where
2−
3−test1 = do let x = 1
4−
5−test2 y = do x <- y
6−
7−test3 = do return 1
8− return 2
examples/failing/DuplicateDeclarationsInLet.pursdeleted−9
@@ -1,9 +0,0 @@
1−module Main where
2−
3−foo = a
4− where
5− a :: Number
6− a = 1
7−
8− a :: Number
9− a = 2
examples/failing/DuplicateProperties1.pursdeleted−9
@@ -1,9 +0,0 @@
1−module DuplicateProperties where
2−
3−foreign import data Test :: # * -> *
4−
5−foreign import subtractX "" :: forall r. Test (x :: Unit | r) -> Test r
6−
7−foreign import hasX "" :: Test (x :: Unit, y :: Unit)
8−
9−baz = subtractX (subtractX hasX)
examples/failing/DuplicateProperties2.pursdeleted−9
@@ -1,9 +0,0 @@
1−module DuplicateProperties where
2−
3−foreign import data Test :: # * -> *
4−
5−foreign import subtractX "" :: forall r. Test (x :: Unit | r) -> Test r
6−
7−foreign import hasX "" :: forall r. Test (x :: Unit, y :: Unit | r)
8−
9−baz = subtractX (subtractX hasX)
examples/failing/DuplicateTypeVars.pursdeleted−3
@@ -1,3 +0,0 @@
1−module Main where
2−
3−type Foo a a = a
examples/failing/Eff.pursdeleted−12
@@ -1,12 +0,0 @@
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.pursdeleted−12
@@ -1,12 +0,0 @@
1−module Main where
2−
3−class Foldable f where
4− fold :: forall a b. (a -> b -> b) -> b -> f a -> b
5− size :: forall a. f a -> Number
6−
7−instance foldableArray :: Foldable [] where
8− fold _ z [] = z
9− fold f z (x:xs) = x `f` (fold f z xs)
10− size = fold (const ((+) 1)) 0
11−
12−x = size [1,2,3]
examples/failing/InstanceExport.pursdeleted−15
@@ -1,15 +0,0 @@
1−module InstanceExport (S(..), f) where
2−
3−newtype S = S String
4−
5−class F a where
6− f :: a -> String
7−
8−instance fs :: F S where
9− f (S s) = s
10−
11−module Test where
12−
13−import InstanceExport
14−
15−test = f $ S "Test"
examples/failing/KindError.pursdeleted−3
@@ -1,3 +0,0 @@
1−module Main where
2−
3− data KindError f a = One f | Two (f a)
examples/failing/Let.pursdeleted−3
@@ -1,3 +0,0 @@
1−module Main where
2−
3−test = let x = x in x
examples/failing/MPTCs.pursdeleted−7
@@ -1,7 +0,0 @@
1−module Main where
2−
3−class Foo a where
4− f :: a -> a
5−
6−instance fooStringString :: Foo String String where
7− f a = a
examples/failing/MissingClassExport.pursdeleted−4
@@ -1,4 +0,0 @@
1−module Test (bar) where
2−
3− class Foo a where
4− bar :: a -> a
examples/failing/MissingClassMemberExport.pursdeleted−4
@@ -1,4 +0,0 @@
1−module Test (Foo) where
2−
3− class Foo a where
4− bar :: a -> a
examples/failing/MultipleErrors.pursdeleted−9
@@ -1,9 +0,0 @@
1−module MultipleErrors where
2−
3−foo :: Number -> Number
4−foo 0 = "Test"
5−foo n = bar (n - 1)
6−
7−bar :: Number -> Number
8−bar 0 = "Test"
9−bar n = foo (n - 1)
examples/failing/MultipleErrors2.pursdeleted−5
@@ -1,5 +0,0 @@
1−module MultipleErrors2 where
2−
3−foo = itDoesntExist
4−
5−bar = neitherDoesThis
examples/failing/MutRec.pursdeleted−5
@@ -1,5 +0,0 @@
1−module MutRec where
2−
3−x = y
4−
5−y = x
examples/failing/MutRec2.pursdeleted−3
@@ -1,3 +0,0 @@
1−module Main where
2−
3−x = x
examples/failing/NewtypeMultiArgs.pursdeleted−3
@@ -1,3 +0,0 @@
1−module Main where
2−
3−newtype Thing = Thing String Boolean
examples/failing/NewtypeMultiCtor.pursdeleted−3
@@ -1,3 +0,0 @@
1−module Main where
2−
3−newtype Thing = Thing String | Other
examples/failing/NoOverlap.pursdeleted−11
@@ -1,11 +0,0 @@
1−module Main where
2−
3−data Foo = Foo
4−
5−instance showFoo1 :: Show Foo where
6− show _ = "Foo"
7−
8−instance showFoo2 :: Show Foo where
9− show _ = "Bar"
10−
11−test = show Foo
examples/failing/NullaryAbs.pursdeleted−3
@@ -1,3 +0,0 @@
1−module Main where
2−
3− func = \ -> "no"
examples/failing/Object.pursdeleted−5
@@ -1,5 +0,0 @@
1−module Main where
2−
3−test o = o.foo
4−
5−test1 = test {}
examples/failing/OverlappingArguments.pursdeleted−3
@@ -1,3 +0,0 @@
1−module OverlappingArguments where
2−
3−f x x = x
examples/failing/OverlappingBinders.pursdeleted−4
@@ -1,4 +0,0 @@
1−module OverlappingBinders where
2−
3−f x = case x of
4− (y:y@(z:zs)) -> y
examples/failing/OverlappingInstances.pursdeleted−11
@@ -1,11 +0,0 @@
1−module OverlappingInstances where
2−
3−data A = A
4−
5−instance showA1 :: Show A where
6− show A = "Instance 1"
7−
8−instance showA2 :: Show A where
9− show A = "Instance 2"
10−
11−main = Debug.Trace.trace $ show A
examples/failing/OverlappingInstances2.pursdeleted−23
@@ -1,23 +0,0 @@
1−module OverlappingInstances where
2−
3−data A = A | B
4−
5−instance eqA1 :: Eq A where
6− (==) A A = true
7− (==) B B = true
8− (==) _ _ = false
9− (/=) x y = not (x == y)
10−
11−instance eqA2 :: Eq A where
12− (==) _ _ = true
13− (/=) _ _ = false
14−
15−instance ordA :: Ord A where
16− compare A B = LT
17− compare B A = GT
18− compare _ _ = EQ
19−
20−test :: forall a. (Ord a) => a -> a -> String
21−test x y = show $ x == y
22−
23−main = Debug.Trace.trace $ test A B
examples/failing/OverlappingVars.pursdeleted−12
@@ -1,12 +0,0 @@
1−module Main where
2−
3−class OverlappingVars a where
4− f :: a -> a
5−
6−data Foo a b = Foo a b
7−
8−instance overlappingVarsFoo :: OverlappingVars (Foo a a) where
9− f a = a
10−
11−test = f (Foo "" 0)
12−
examples/failing/Rank2Types.pursdeleted−7
@@ -1,7 +0,0 @@
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.pursdeleted−4
@@ -1,4 +0,0 @@
1−module Main where
2−
3−(<) :: Number -> Number -> Number
4−(<) a b = !(a >= b)
examples/failing/SkolemEscape.pursdeleted−5
@@ -1,5 +0,0 @@
1−module Main where
2−
3− foreign import foo :: (forall a. a -> a) -> Number
4−
5− test = \x -> foo x
examples/failing/SkolemEscape2.pursdeleted−9
@@ -1,9 +0,0 @@
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.pursdeleted−11
@@ -1,11 +0,0 @@
1−module Main where
2−
3−class Su a where
4− su :: a -> a
5−
6−class (Su a) <= Cl a where
7− cl :: a -> a -> a
8−
9−instance clNumber :: Cl Number where
10− cl n m = n + m
11−
examples/failing/Superclasses2.pursdeleted−9
@@ -1,9 +0,0 @@
1−module CycleInSuperclasses where
2−
3−class (Foo a) <= Bar a
4−
5−class (Bar a) <= Foo a
6−
7−instance barString :: Bar String
8−
9−instance fooString :: Foo String
examples/failing/Superclasses3.pursdeleted−5
@@ -1,5 +0,0 @@
1−module UnknownSuperclassTypeVar where
2−
3−class Foo a
4−
5−class (Foo b) <= Bar a
examples/failing/Superclasses4.pursdeleted−12
@@ -1,12 +0,0 @@
1−module OverlappingInstances where
2−
3−class Foo a
4−
5−instance foo1 :: Foo Number
6−
7−instance foo2 :: Foo Number
8−
9−test :: forall a. (Foo a) => a -> a
10−test a = a
11−
12−test1 = test 0
examples/failing/TopLevelCaseNoArgs.pursdeleted−4
@@ -1,4 +0,0 @@
1−module Main where
2− foo :: Number
3− foo = 1
4− foo = 2
examples/failing/TypeClassInstances.pursdeleted−8
@@ -1,8 +0,0 @@
1−module Main where
2−
3−class A a where
4− a :: a -> String
5− b :: a -> Number
6−
7−instance aString :: A String where
8− a s = s
examples/failing/TypeClasses2.pursdeleted−8
@@ -1,8 +0,0 @@
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.pursdeleted−5
@@ -1,5 +0,0 @@
1−module Main where
2−
3− import Prelude
4−
5− test = 1 ++ "A"
examples/failing/TypeSynonyms.pursdeleted−5
@@ -1,5 +0,0 @@
1−module Main where
2−
3−type T1 = [T2]
4−
5−type T2 = T1
examples/failing/TypeSynonyms2.pursdeleted−9
@@ -1,9 +0,0 @@
1−module Main where
2−
3−class Foo a where
4− foo :: a -> String
5−
6−type Bar = String
7−
8−instance fooBar :: Foo Bar where
9− foo s = s
examples/failing/TypeSynonyms3.pursdeleted−9
@@ -1,9 +0,0 @@
1−module Main where
2−
3−class Foo a where
4− foo :: a -> String
5−
6−type Bar = String
7−
8−instance fooBar :: Foo Bar where
9− foo s = s
examples/failing/TypeSynonyms4.pursdeleted−8
@@ -1,8 +0,0 @@
1−module TypeSynonyms4 where
2−
3−type F x y = x -> y
4−
5−type G x = F x
6−
7−f :: G String String -> String
8−f k = k "Done"
examples/failing/TypeWildcards1.pursdeleted−4
@@ -1,4 +0,0 @@
1−module TypeWildcards where
2−
3−type Test = _
4−
examples/failing/TypeWildcards2.pursdeleted−4
@@ -1,4 +0,0 @@
1−module TypeWildcards where
2−
3−data Test = Test _
4−
examples/failing/TypeWildcards3.pursdeleted−7
@@ -1,7 +0,0 @@
1−module TypeWildcards where
2−
3−data Foo a = Foo
4−
5−instance showFoo :: Show (Foo _) where
6− show Foo = "Foo"
7−
examples/failing/UnderscoreModuleName.pursdeleted−3
@@ -1,3 +0,0 @@
1−module Bad_Module where
2−
3−main = Debug.Trace.trace "Done"
examples/failing/UnifyInTypeInstanceLookup.pursdeleted−17
@@ -1,17 +0,0 @@
1−module Main where
2−
3−data Z = Z
4−data S n = S n
5−
6−data T
7−data F
8−
9−class EQ x y b
10−instance eqT :: EQ x x T
11−instance eqF :: EQ x y F
12−
13−foreign import test :: forall a b. (EQ a b T) => a -> b -> a
14−
15−foreign import anyNat :: forall a. a
16−
17−test1 = test anyNat (S Z)
examples/failing/UnknownType.pursdeleted−4
@@ -1,4 +0,0 @@
1−module Main where
2−
3−test :: Number -> Something
4−test = {}
examples/manual/failing/ArgLengthMismatch.pursdeleted−4
@@ -1,4 +0,0 @@
1−module ArgLengthMismatch where
2−
3− f x y = true
4− f = false
examples/manual/failing/ExportExplicit.pursdeleted−5
@@ -1,5 +0,0 @@
1−-- should fail as z does not exist in the module
2−module M1 (x, y, z) where
3−
4− x = 1
5− y = 2
examples/manual/failing/ExportExplicit1.pursdeleted−14
@@ -1,14 +0,0 @@
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.pursdeleted−5
@@ -1,5 +0,0 @@
1−-- should fail as Y is not a data constructor for X
2−module M1 (X(Y)) where
3−
4− data X = X
5− data Y = Y
examples/manual/failing/ExportExplicit3.pursdeleted−13
@@ -1,13 +0,0 @@
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.pursdeleted−7
@@ -1,7 +0,0 @@
1−module M1 where
2−
3− foo = "foo"
4−
5−module Main where
6−
7− import M1 (X(..))
examples/manual/failing/ImportExplicit2.pursdeleted−7
@@ -1,7 +0,0 @@
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.pursdeleted−7
@@ -1,7 +0,0 @@
1−module M2 where
2−
3− data X = X
4−
5−module Main where
6−
7− import M1
examples/manual/failing/OrphanTypeDecl.pursdeleted−3
@@ -1,3 +0,0 @@
1−module OrphanTypeDecl where
2−
3− fn :: Number -> Boolean
examples/manual/failing/RedefinedFixity.pursdeleted−6
@@ -1,6 +0,0 @@
1−module RedefinedFixity where
2−
3− (!?) x y = x + y
4−
5− infix 2 !?
6− infix 2 !?
examples/manual/failing/RequiredHiddenType.pursdeleted−8
@@ -1,8 +0,0 @@
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.pursdeleted−20
@@ -1,20 +0,0 @@
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.pursdeleted−15
@@ -1,15 +0,0 @@
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/Import.pursdeleted−19
@@ -1,19 +0,0 @@
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.pursdeleted−14
@@ -1,14 +0,0 @@
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.pursdeleted−12
@@ -1,12 +0,0 @@
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.pursdeleted−28
@@ -1,28 +0,0 @@
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.pursdeleted−17
@@ -1,17 +0,0 @@
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.pursdeleted−24
@@ -1,24 +0,0 @@
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/TransitiveImport.pursdeleted−21
@@ -1,21 +0,0 @@
1−module Test where
2−
3− class TestCls a where
4− test :: a -> a
5−
6− instance unitTestCls :: TestCls Unit where
7− test _ = unit
8−
9−module Middle where
10−
11− middle = Test.test
12−
13−module Main where
14−
15− import Middle
16− import Debug.Trace
17−
18− main = do
19− print (middle unit)
20− trace "Done"
21− return unit
examples/passing/652.pursdeleted−15
@@ -1,15 +0,0 @@
1−module Main where
2−
3−class Foo a b
4−
5−class Bar a c
6−
7−class (Foo a b, Bar a c) <= Baz a b c
8−
9−instance foo :: Foo (a -> b) a
10−
11−instance bar :: Bar (a -> b) b
12−
13−instance baz :: (Eq a) => Baz (a -> b) a b
14−
15−main = Debug.Trace.trace "Done"
examples/passing/810.pursdeleted−11
@@ -1,11 +0,0 @@
1−module Main where
2−
3−data Maybe a = Nothing | Just a
4−
5−test :: forall a. Maybe a -> Maybe a
6−test m = o.x
7− where
8− o = case m of Nothing -> { x : Nothing }
9− Just a -> { x : Just a }
10−
11−main = Debug.Trace.trace "Done"
examples/passing/Applicative.pursdeleted−16
@@ -1,16 +0,0 @@
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.pursdeleted−9
@@ -1,9 +0,0 @@
1−module Main where
2−
3−class Pointed p where
4− point :: forall a. a -> p a
5−
6−instance pointedArray :: Pointed [] where
7− point a = [a]
8−
9−main = Debug.Trace.trace "Done"
examples/passing/Arrays.pursdeleted−24
@@ -1,24 +0,0 @@
1−module Main where
2−
3−import Prelude.Unsafe (unsafeIndex)
4−
5−test1 arr = arr `unsafeIndex` 0 + arr `unsafeIndex` 1 + 1
6−
7−test2 = \arr -> case arr of
8− [x, y] -> x + y
9− [x] -> x
10− [] -> 0
11− (x : y : _) -> x + y
12−
13−data Tree = One Number | Some [Tree]
14−
15−test3 = \tree sum -> case tree of
16− One n -> n
17− Some (n1 : n2 : rest) -> test3 n1 sum * 10 + test3 n2 sum * 5 + sum rest
18−
19−test4 = \arr -> case arr of
20− [] -> 0
21− [_] -> 0
22− x : y : xs -> x * y + test4 xs
23−
24−main = Debug.Trace.trace "Done"
examples/passing/Auto.pursdeleted−13
@@ -1,13 +0,0 @@
1−module Main where
2−
3− data Auto s i o = Auto { state :: s, step :: s -> i -> o }
4−
5− type SomeAuto i o = forall r. (forall s. Auto s i o -> r) -> r
6−
7− exists :: forall s i o. s -> (s -> i -> o) -> SomeAuto i o
8− exists = \state step f -> f (Auto { state: state, step: step })
9−
10− run :: forall i o. SomeAuto i o -> i -> o
11− run = \s i -> s (\a -> case a of Auto a -> a.step a.state i)
12−
13− main = Debug.Trace.trace "Done"
examples/passing/AutoPrelude.pursdeleted−8
@@ -1,8 +0,0 @@
1−module Main where
2−
3−import Debug.Trace
4−
5−f x = x * 10
6−g y = y - 10
7−
8−main = trace $ show $ (f <<< g) 100
examples/passing/AutoPrelude2.pursdeleted−9
@@ -1,9 +0,0 @@
1−module Main where
2−
3−import qualified Prelude as P
4−import Debug.Trace
5−
6−f :: forall a. a -> a
7−f = P.id
8−
9−main = P.($) trace ((f P.<<< f) "Done")
examples/passing/BindersInFunctions.pursdeleted−18
@@ -1,18 +0,0 @@
1−module Main where
2−
3−import Prelude
4−
5−tail = \(_:xs) -> xs
6−
7−foreign import error
8− """
9− function error(msg) {
10− throw msg;
11− }
12− """ :: forall a. String -> a
13−
14−main =
15− let ts = tail [1, 2, 3] in
16− if ts == [2, 3]
17− then Debug.Trace.trace "Done"
18− else error "Incorrect result from 'tails'."
examples/passing/BindingGroups.pursdeleted−8
@@ -1,8 +0,0 @@
1−module Main where
2−
3−foo = bar
4− where bar r = r + 1
5−
6−r = foo 2
7−
8−main = Debug.Trace.trace "Done"
examples/passing/BlockString.pursdeleted−12
@@ -1,12 +0,0 @@
1−module Main where
2−
3−foreign import foo """
4− function foo(s) {
5− return s;
6− }
7−""" :: String -> String
8−
9−bar :: String -> String
10−bar _ = foo "test"
11−
12−main = Debug.Trace.trace "Done"
examples/passing/CaseInDo.pursdeleted−20
@@ -1,20 +0,0 @@
1−module Main where
2−
3−import Debug.Trace
4−import Control.Monad.Eff
5−
6−foreign import doIt "function doIt() { global.flag = true; }" :: forall eff. Eff eff Unit
7−
8−foreign import get "function get() { return global.flag; }" :: forall eff. Eff eff Boolean
9−
10−set = do
11− trace "Testing..."
12− case 0 of
13− 0 -> doIt
14− _ -> return unit
15−
16−main = do
17− set
18− b <- get
19− case b of
20− true -> trace "Done"
examples/passing/CheckFunction.pursdeleted−5
@@ -1,5 +0,0 @@
1−module Main where
2−
3−test = ((\x -> x+1) >>> (\x -> x*2)) 4
4−
5−main = Debug.Trace.trace "Done"
examples/passing/CheckSynonymBug.pursdeleted−16
@@ -1,16 +0,0 @@
1−module Main where
2−
3− import Prelude
4−
5− type Foo a = [a]
6−
7− foreign import length
8− """
9− function length(a) {
10− return a.length;
11− }
12− """ :: forall a. [a] -> Number
13−
14− foo _ = length ([] :: Foo Number)
15−
16− main = Debug.Trace.trace "Done"
examples/passing/CheckTypeClass.pursdeleted−16
@@ -1,16 +0,0 @@
1−module Main where
2−
3− data Bar a = Bar
4− data Baz
5−
6− class Foo a where
7− foo :: Bar a -> Baz
8−
9− foo_ :: forall a. (Foo a) => a -> Baz
10− foo_ x = foo ((mkBar :: forall a. (Foo a) => a -> Bar a) x)
11−
12− mkBar :: forall a. a -> Bar a
13− mkBar _ = Bar
14−
15− main = Debug.Trace.trace "Done"
16−
examples/passing/Church.pursdeleted−18
@@ -1,18 +0,0 @@
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.pursdeleted−18
@@ -1,18 +0,0 @@
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
11− untilE $ do
12− modifySTRef count $ (+) 1
13− m <- readSTRef r
14− writeSTRef r $ if m % 2 == 0 then m / 2 else 3 * m + 1
15− return $ m == 1
16− readSTRef count))
17−
18−main = Debug.Trace.print $ collatz 1000
examples/passing/Comparisons.pursdeleted−25
@@ -1,25 +0,0 @@
1−module Main where
2−
3−import Control.Monad.Eff
4−import Debug.Trace
5−
6−foreign import data Assert :: !
7−
8−foreign import assert
9− """
10− function assert(x) {
11− return function() {
12− if (!x) throw new Error('assertion failed');
13− return {};
14− };
15− }
16− """ :: forall e. Boolean -> Eff (assert :: Assert | e) Unit
17−
18−main = do
19− assert (1 < 2)
20− assert (2 == 2)
21− assert (3 > 1)
22− assert ("a" < "b")
23− assert ("a" == "a")
24− assert ("z" > "a")
25− trace "Done!"
examples/passing/Conditional.pursdeleted−9
@@ -1,9 +0,0 @@
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.pursdeleted−13
@@ -1,13 +0,0 @@
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 _ = return {}
9−replicateM_ n act = do
10− act
11− replicateM_ (n - 1) act
12−
13−main = replicateM_ 10 (trace "Hello World!")
examples/passing/DataAndType.pursdeleted−7
@@ -1,7 +0,0 @@
1−module Main where
2−
3−data A = A B
4−
5−type B = A
6−
7−main = Debug.Trace.trace "Done"
examples/passing/DeepArrayBinder.pursdeleted−18
@@ -1,18 +0,0 @@
1−module Main where
2−
3−import Control.Monad.Eff
4−
5−match2 :: [Number] -> Number
6−match2 (x : y : xs) = x * y + match2 xs
7−match2 _ = 0
8−
9−foreign import explode
10− """
11− function explode() {
12− throw new Error('Incorrect result');
13− }
14− """ :: forall eff a. Eff eff a
15−
16−main = case match2 [1, 2, 3, 4, 5, 6, 7, 8, 9] of
17− 100 -> Debug.Trace.trace "Done"
18− _ -> explode
examples/passing/DeepCase.pursdeleted−14
@@ -1,14 +0,0 @@
1−module Main where
2−
3−import Debug.Trace
4−import Control.Monad.Eff
5−import Control.Monad.ST
6−
7−f x y =
8− let
9− g = case y of
10− 0 -> x
11− x -> 1 + x * x
12− in g + x + y
13−
14−main = print $ f 1 10
examples/passing/Do.pursdeleted−67
@@ -1,67 +0,0 @@
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− (>>=) Nothing _ = Nothing
20− (>>=) (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, 2, 3]
29− (y : _) <- Just [4, 5, 6]
30− Just (x + y)
31−
32−test3 = \_ -> do
33− Just 1
34− Nothing :: Maybe Number
35− Just 2
36−
37−test4 mx my = do
38− x <- mx
39− y <- my
40− Just (x + y + 1)
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)
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)
58−
59−test9 = \_ -> (+) <$> Just 1 <*> Just 2
60−
61−test10 _ = do
62− let
63− f x = g x * 3
64− g x = f x / 2
65− Just (f 10)
66−
67−main = Debug.Trace.trace "Done"
examples/passing/Dollar.pursdeleted−16
@@ -1,16 +0,0 @@
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.pursdeleted−25
@@ -1,25 +0,0 @@
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
14− modifySTRef ref $ \n -> n + 1
15− readSTRef ref))
16−
17−test3 = pureST (do
18− ref <- newSTRef 0
19− modifySTRef ref $ \n -> n + 1
20− readSTRef ref)
21−
22−main = do
23− test1
24− Debug.Trace.print test2
25− Debug.Trace.print test3
examples/passing/EmptyDataDecls.pursdeleted−34
@@ -1,34 +0,0 @@
1−module Main where
2−
3−import Prelude
4−
5−data Z
6−data S n
7−
8−data ArrayBox n a = ArrayBox [a]
9−
10−nil :: forall a. ArrayBox Z a
11−nil = ArrayBox []
12−
13−foreign import concat
14− """
15− function concat(l1) {
16− return function(l2) {
17− return l1.concat(l2);
18− };
19− }
20− """ :: forall a. [a] -> [a] -> [a]
21−
22−cons' :: forall a n. a -> ArrayBox n a -> ArrayBox (S n) a
23−cons' x (ArrayBox xs) = ArrayBox $ concat [x] xs
24−
25−foreign import error
26− """
27− function error(msg) {
28− throw msg;
29− }
30− """ :: forall a. String -> a
31−
32−main = case cons' 1 $ cons' 2 $ cons' 3 nil of
33− ArrayBox [1, 2, 3] -> Debug.Trace.trace "Done"
34− _ -> error "Failed"
examples/passing/EmptyRow.pursdeleted−8
@@ -1,8 +0,0 @@
1−module Main where
2−
3−data Foo r = Foo { | r }
4−
5−test :: Foo ()
6−test = Foo {}
7−
8−main = Debug.Trace.trace "Done"
examples/passing/EmptyTypeClass.pursdeleted−12
@@ -1,12 +0,0 @@
1−module Main where
2−
3−import Prelude
4−
5−class Partial
6−
7−head :: forall a. (Partial) => [a] -> a
8−head (x:xs) = x
9−
10−instance allowPartials :: Partial
11−
12−main = Debug.Trace.trace $ head ["Done"]
examples/passing/EqOrd.pursdeleted−14
@@ -1,14 +0,0 @@
1−module Main where
2−
3−data Pair a b = Pair a b
4−
5−instance ordPair :: (Ord a, Ord b) => Ord (Pair a b) where
6− compare (Pair a1 b1) (Pair a2 b2) = case compare a1 a2 of
7− EQ -> compare b1 b2
8− r -> r
9−
10−instance eqPair :: (Eq a, Eq b) => Eq (Pair a b) where
11− (==) (Pair a1 b1) (Pair a2 b2) = a1 == a2 && b1 == b2
12− (/=) (Pair a1 b1) (Pair a2 b2) = a1 /= a2 || b1 /= b2
13−
14−main = Debug.Trace.print $ Pair 1 2 == Pair 1 2
examples/passing/ExtendedInfixOperators.pursdeleted−20
@@ -1,20 +0,0 @@
1−module Main where
2−
3−zipWith :: forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
4−zipWith _ [] _ = []
5−zipWith _ _ [] = []
6−zipWith f (x:xs) (y:ys) = f x y : zipWith f xs ys
7−
8−test1 = [1, 2, 3] `zipWith (+)` [4, 5, 6]
9−
10−comparing :: forall a b. (Ord b) => (a -> b) -> a -> a -> Ordering
11−comparing f = compare `Data.Function.on` f
12−
13−sum [] = 0
14−sum (x:xs) = x + sum xs
15−
16−test2 = [1, 2, 3] `comparing sum` [4, 5, 6]
17−
18−main = do
19− Debug.Trace.print test1
20− Debug.Trace.print test2
examples/passing/ExternData.pursdeleted−13
@@ -1,13 +0,0 @@
1−module Main where
2−
3− foreign import data IO :: * -> *
4−
5− foreign import bind "function bind() {}" :: forall a b. IO a -> (a -> IO b) -> IO b
6−
7− foreign import showMessage "function showMessage() {}" :: String -> IO { }
8−
9− foreign import prompt "function prompt() {}" :: IO String
10−
11− test _ = prompt `bind` \s -> showMessage s
12−
13− main = Debug.Trace.trace "Done"
examples/passing/ExternRaw.pursdeleted−26
@@ -1,26 +0,0 @@
1−module Main where
2−
3−foreign import first
4− """
5− function first(xs) {
6− return xs[0];
7− }
8− """ :: forall a. [a] -> a
9−
10−foreign import loop
11− """
12− function loop() {
13− while (true) {}
14− }
15− """ :: forall a. a
16−
17−foreign import concat
18− """
19− function concat(xs) {
20− return function(ys) {
21− return xs.concat(ys);
22− };
23− }
24− """ :: forall a. [a] -> [a] -> [a]
25−
26−main = Debug.Trace.trace "Done"
examples/passing/FFI.pursdeleted−13
@@ -1,13 +0,0 @@
1−module Main where
2−
3−foreign import foo
4− """
5− function foo(s) {
6− return s;
7− }
8− """ :: String -> String
9−
10−bar :: String -> String
11−bar _ = foo "test"
12−
13−main = Debug.Trace.trace "Done"
examples/passing/Fib.pursdeleted−15
@@ -1,15 +0,0 @@
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
9− n2 <- newSTRef 1
10− whileE ((>) 1000 <$> 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.pursdeleted−22
@@ -1,22 +0,0 @@
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) (num 2)
21−
22−main = Debug.Trace.print $ runId three
examples/passing/ForeignInstance.pursdeleted−20
@@ -1,20 +0,0 @@
1−module Main where
2−
3−class Foo a where
4− foo :: a -> String
5−
6−foreign import instance fooArray :: (Foo a) => Foo [a]
7−
8−foreign import instance fooNumber :: Foo Number
9−
10−foreign import instance fooString :: Foo String
11−
12−foreign import fooString "var fooString = {};" :: Unit
13−foreign import fooNumber "var fooNumber = {};" :: Unit
14−foreign import fooArray "var fooArray = {};" :: Unit
15−
16−test1 _ = foo [1, 2, 3]
17−
18−test2 _ = foo "Test"
19−
20−main = Debug.Trace.trace "Done"
examples/passing/FunctionScope.pursdeleted−19
@@ -1,19 +0,0 @@
1−module Main where
2−
3− import Prelude
4−
5− mkValue :: Number -> Number
6− mkValue id = id
7−
8− foreign import error
9− """
10− function error(msg) {
11− throw msg;
12− }
13− """ :: forall a. String -> a
14−
15− main = do
16− let value = mkValue 1
17− if value == 1
18− then Debug.Trace.trace "Done"
19− else error "Not done"
examples/passing/Functions.pursdeleted−15
@@ -1,15 +0,0 @@
1−module Main where
2−
3− import Prelude
4−
5− test1 = \_ -> 0
6−
7− test2 = \a b -> a + b + 1
8−
9− test3 = \a -> a
10−
11− test4 = \(%%) -> 1 %% 2
12−
13− test5 = \(+++) (***) -> 1 +++ 2 *** 3
14−
15− main = Debug.Trace.trace "Done"
examples/passing/Functions2.pursdeleted−19
@@ -1,19 +0,0 @@
1−module Main where
2−
3− import Prelude
4−
5− test :: forall a b. a -> b -> a
6− test = \const _ -> const
7−
8− foreign import error
9− """
10− function error(msg) {
11− throw msg;
12− }
13− """ :: forall a. String -> a
14−
15− main = do
16− let value = test "Done" {}
17− if value == "Done"
18− then Debug.Trace.trace "Done"
19− else error "Not done"
examples/passing/Guards.pursdeleted−29
@@ -1,29 +0,0 @@
1−module Main where
2−
3− import Prelude
4−
5− collatz = \x -> case x of
6− y | y % 2 == 0 -> y / 2
7− y -> y * 3 + 1
8−
9− -- Guards have access to current scope
10− collatz2 = \x y -> case x of
11− z | y > 0 -> z / 2
12− z -> z * 3 + 1
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
25− = x + y
26− | otherwise
27− = y - x
28−
29− main = Debug.Trace.trace $ min "Done" "ZZZZ"
examples/passing/HoistError.pursdeleted−19
@@ -1,19 +0,0 @@
1−module Main where
2−
3−import Control.Monad.Eff
4−import Debug.Trace
5−
6−foreign import f
7− """
8− function f(x) {
9− return function() {
10− if (x !== 0) throw new Error('x is not 0');
11− };
12− }
13− """ :: forall e. Number -> Eff e Number
14−
15−main = do
16− let x = 0
17− f x
18− let x = 1 + 1
19− trace "Done"
examples/passing/IfThenElseMaybe.pursdeleted−9
@@ -1,9 +0,0 @@
1−module Main where
2−
3−data Maybe a = Nothing | Just a
4−
5−test1 = if true then Just 10 else Nothing
6−
7−test2 = if true then Nothing else Just 10
8−
9−main = Debug.Trace.trace "Done"
examples/passing/ImplicitEmptyImport.pursdeleted−6
@@ -1,6 +0,0 @@
1−module Main where
2−
3−main = do
4− Debug.Trace.trace "Hello"
5− Debug.Trace.trace "Goodbye"
6− Debug.Trace.trace "Done"
examples/passing/ImportHiding.pursdeleted−18
@@ -1,18 +0,0 @@
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
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.pursdeleted−8
@@ -1,8 +0,0 @@
1−module Main where
2−
3−import Prelude
4−
5−test 100 = 100
6−test n = test(1 + n)
7−
8−main = Debug.Trace.print $ test 0
examples/passing/JSReserved.pursdeleted−12
@@ -1,12 +0,0 @@
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.pursdeleted−31
@@ -1,31 +0,0 @@
1−module Main where
2−
3−type Star2Star f = f :: * -> *
4−
5−type Star t = t :: *
6−
7−test1 :: Star2Star [] String
8−test1 = ["test"]
9−
10−f :: Star (String -> String)
11−f s = s
12−
13−test2 = f "test"
14−
15−data Proxy (f :: * -> *) = Proxy
16−
17−test3 :: Proxy []
18−test3 = Proxy
19−
20−type Test (f :: * -> *) = f String
21−
22−test4 :: Test []
23−test4 = ["test"]
24−
25−class Clazz (a :: *) where
26− def :: a
27−
28−instance clazzString :: Clazz String where
29− def = "test"
30−
31−main = Debug.Trace.trace "Done"
examples/passing/Let.pursdeleted−64
@@ -1,64 +0,0 @@
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
10− in y
11−
12−test2 x y =
13− let x' = x + 1 in
14− let y' = y + 1 in
15− x' + y'
16−
17−test3 = let f x y z = x + y + z in
18− f 1 2 3
19−
20−test4 = let f x [y, z] = x y z in
21− f (+) [1, 2]
22−
23−test5 = let
24− f x | x > 0 = g (x / 2) + 1
25− f x = 0
26− g x = f (x - 1) + 1
27− in f 10
28−
29−test6 = runPure (runST (do
30− r <- newSTRef 0
31− (let
32− go [] = readSTRef r
33− go (n : ns) = do
34− modifySTRef r ((+) n)
35− go ns
36− in go [1, 2, 3, 4, 5])
37− ))
38−
39−test7 = let
40− f :: forall a. a -> a
41− f x = x
42− in if f true then f 1 else f 2
43−
44−test8 :: Number -> Number
45−test8 x = let
46− go y | (x - 0.1 < y * y) && (y * y < x + 0.1) = y
47− go y = go $ (y + x / y) / 2
48− in go x
49−
50−test10 _ =
51− let
52− f x = g x * 3
53− g x = f x / 2
54− in f 10
55−
56−main = do
57− Debug.Trace.print (test1 1)
58− Debug.Trace.print (test2 1 2)
59− Debug.Trace.print test3
60− Debug.Trace.print test4
61− Debug.Trace.print test5
62− Debug.Trace.print test6
63− Debug.Trace.print test7
64− Debug.Trace.print (test8 100)
examples/passing/LetInInstance.pursdeleted−12
@@ -1,12 +0,0 @@
1−module Main where
2−
3−class Foo a where
4− foo :: a -> String
5−
6−instance fooString :: Foo String where
7− foo = go
8− where
9− go :: String -> String
10− go s = s
11−
12−main = Debug.Trace.trace "Done"
examples/passing/LiberalTypeSynonyms.pursdeleted−19
@@ -1,19 +0,0 @@
1−module Main where
2−
3−type Reader = (->) String
4−
5−foo :: Reader String
6−foo s = s
7−
8−type AndFoo r = (foo :: String | r)
9−
10−getFoo :: forall r. Prim.Object (AndFoo r) -> String
11−getFoo o = o.foo
12−
13−type F r = { | r } -> { | r }
14−
15−f :: (forall r. F r) -> String
16−f g = case g { x: "Hello" } of
17− { x = x } -> x
18−
19−main = Debug.Trace.trace "Done"
examples/passing/MPTCs.pursdeleted−20
@@ -1,20 +0,0 @@
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.pursdeleted−7
@@ -1,7 +0,0 @@
1−module Main where
2−
3− data Foo a = Foo
4−
5− foo = \f -> case f of Foo -> "foo"
6−
7− main = Debug.Trace.trace "Done"
examples/passing/Monad.pursdeleted−32
@@ -1,32 +0,0 @@
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) (\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.pursdeleted−48
@@ -1,48 +0,0 @@
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− (>>=) 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.pursdeleted−26
@@ -1,26 +0,0 @@
1−module Main where
2−
3−import Data.Function
4−import Control.Monad.Eff
5−import Debug.Trace
6−
7−f = mkFn2 $ \a b -> runFn2 g a b + runFn2 g b a
8−
9−g = mkFn2 $ \a b -> case {} of
10− _ | a <= 0 || b <= 0 -> b
11− _ -> runFn2 f (a - 1) (b - 1)
12−
13−main = do
14− runFn0 (mkFn0 $ \_ -> trace $ show 0)
15− runFn1 (mkFn1 $ \a -> trace $ show a) 1
16− runFn2 (mkFn2 $ \a b -> trace $ show [a, b]) 1 2
17− runFn3 (mkFn3 $ \a b c -> trace $ show [a, b, c]) 1 2 3
18− runFn4 (mkFn4 $ \a b c d -> trace $ show [a, b, c, d]) 1 2 3 4
19− runFn5 (mkFn5 $ \a b c d e -> trace $ show [a, b, c, d, e]) 1 2 3 4 5
20− runFn6 (mkFn6 $ \a b c d e f -> trace $ show [a, b, c, d, e, f]) 1 2 3 4 5 6
21− runFn7 (mkFn7 $ \a b c d e f g -> trace $ show [a, b, c, d, e, f, g]) 1 2 3 4 5 6 7
22− runFn8 (mkFn8 $ \a b c d e f g h -> trace $ show [a, b, c, d, e, f, g, h]) 1 2 3 4 5 6 7 8
23− runFn9 (mkFn9 $ \a b c d e f g h i -> trace $ show [a, b, c, d, e, f, g, h, i]) 1 2 3 4 5 6 7 8 9
24− runFn10 (mkFn10 $ \a b c d e f g h i j-> trace $ show [a, b, c, d, e, f, g, h, i, j]) 1 2 3 4 5 6 7 8 9 10
25− print $ runFn2 g 15 12
26− trace "Done!"
examples/passing/MultipleConstructorArgs.pursdeleted−21
@@ -1,21 +0,0 @@
1−module Main where
2−
3−import Prelude
4−import Control.Monad.Eff
5−
6−data P a b = P a b
7−
8−runP :: forall a b r. (a -> b -> r) -> P a b -> r
9−runP f (P a b) = f a b
10−
11−idP = runP P
12−
13−testCase = \p -> case p of
14− P (x:xs) (y:ys) -> x + y
15− P _ _ -> 0
16−
17−test1 = testCase (P [1, 2, 3] [4, 5, 6])
18−
19−main = do
20− Debug.Trace.trace (runP (\s n -> s ++ show n) (P "Test" 1))
21− Debug.Trace.print test1
examples/passing/MutRec.pursdeleted−19
@@ -1,19 +0,0 @@
1−module Main where
2−
3− import Prelude
4−
5− f 0 = 0
6− f x = g x + 1
7−
8− g x = f (x / 2)
9−
10− data Even = Zero | Even Odd
11−
12− data Odd = Odd Even
13−
14− evenToNumber Zero = 0
15− evenToNumber (Even n) = oddToNumber n + 1
16−
17− oddToNumber (Odd n) = evenToNumber n + 1
18−
19− main = Debug.Trace.trace "Done"
examples/passing/MutRec2.pursdeleted−17
@@ -1,17 +0,0 @@
1−module Main where
2−
3−data A = A B
4−
5−data B = B A
6−
7−foreign import data S :: *
8−
9−f :: A -> S
10−f a = case a of A b -> g b
11−
12−g b = case b of B a -> f a
13−
14−showN :: A -> S
15−showN a = f a
16−
17−main = Debug.Trace.trace "Done"
examples/passing/MutRec3.pursdeleted−17
@@ -1,17 +0,0 @@
1−module Main where
2−
3−data A = A B
4−
5−data B = B A
6−
7−foreign import data S :: *
8−
9−f a = case a of A b -> g b
10−
11−g :: B -> S
12−g b = case b of B a -> f a
13−
14−showN :: A -> S
15−showN a = f a
16−
17−main = Debug.Trace.trace "Done"
examples/passing/NamedPatterns.pursdeleted−7
@@ -1,7 +0,0 @@
1−module Main where
2−
3− foo = \x -> case x of
4− y@{ foo = "Foo" } -> y
5− y -> y
6−
7− main = Debug.Trace.trace "Done"
examples/passing/NegativeBinder.pursdeleted−7
@@ -1,7 +0,0 @@
1−module Main where
2−
3−test :: Number -> Boolean
4−test -1 = false
5−test _ = true
6−
7−main = Debug.Trace.trace "Done"
examples/passing/Nested.pursdeleted−7
@@ -1,7 +0,0 @@
1−module Main where
2−
3− data Extend r a = Extend { prev :: r a, next :: a }
4−
5− data Matrix r a = Square (r (r a)) | Bigger (Matrix (Extend r) a)
6−
7− main = Debug.Trace.trace "Done"
examples/passing/NestedTypeSynonyms.pursdeleted−11
@@ -1,11 +0,0 @@
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.pursdeleted−10
@@ -1,10 +0,0 @@
1−module Main where
2−
3−f x = g x
4− where
5− g x = go x
6− where
7− go x = go1 (x - 1)
8− go1 x = go x
9−
10−main = Debug.Trace.trace "Done"
examples/passing/Newtype.pursdeleted−22
@@ -1,22 +0,0 @@
1−module Main where
2−
3−import Control.Monad.Eff
4−import Debug.Trace
5−
6−newtype Thing = Thing String
7−
8−instance showThing :: Show Thing where
9− show (Thing x) = "Thing " ++ show x
10−
11−newtype Box a = Box a
12−
13−instance showBox :: (Show a) => Show (Box a) where
14− show (Box x) = "Box " ++ show x
15−
16−apply f x = f x
17−
18−main = do
19− print $ Thing "hello"
20− print $ Box 42
21− print $ apply Box 9000
22− trace "Done"
examples/passing/NewtypeEff.pursdeleted−28
@@ -1,28 +0,0 @@
1−module Main where
2−
3−import Debug.Trace
4−import Control.Monad.Eff
5−
6−newtype T a = T (Eff (trace :: Trace) a)
7−
8−runT :: forall a. T a -> Eff (trace :: Trace) a
9−runT (T t) = t
10−
11−instance functorT :: Functor T where
12− (<$>) f (T t) = T (f <$> t)
13−
14−instance applyT :: Apply T where
15− (<*>) (T f) (T x) = T (f <*> x)
16−
17−instance applicativeT :: Applicative T where
18− pure t = T (pure t)
19−
20−instance bindT :: Bind T where
21− (>>=) (T t) f = T (t >>= \x -> runT (f x))
22−
23−instance monadT :: Monad T
24−
25−main = runT do
26− T $ trace "Done"
27− T $ trace "Done"
28− T $ trace "Done"
examples/passing/NewtypeWithRecordUpdate.pursdeleted−15
@@ -1,15 +0,0 @@
1−-- https://github.com/purescript/purescript/issues/812
2−
3−module Main where
4−
5−import Debug.Trace
6−
7−newtype NewType a = NewType (Object a)
8−
9−rec1 :: Object (a :: Number, b :: Number, c:: Number)
10−rec1 = { a: 0, b: 0, c: 0 }
11−
12−rec2 :: NewType (a :: Number, b :: Number, c :: Number)
13−rec2 = NewType (rec1 { a = 1 })
14−
15−main = trace "Done"
examples/passing/ObjectGetter.pursdeleted−11
@@ -1,11 +0,0 @@
1−module Main where
2−
3−getX = _.x
4−
5−point = { x: 1, y: 0 }
6−
7−main = do
8− Debug.Trace.print $ getX point
9− Debug.Trace.trace $ _." 123 string Prop Name " { " 123 string Prop Name ": "OK" }
10− Debug.Trace.trace $ (_.x >>> _.y) { x: { y: "Nested" } }
11− Debug.Trace.trace $ _.value { value: "Done!" }
examples/passing/ObjectSynonym.pursdeleted−13
@@ -1,13 +0,0 @@
1−module Main where
2−
3−type Inner = Number
4−
5−inner :: Inner
6−inner = 0
7−
8−type Outer = { inner :: Inner }
9−
10−outer :: Outer
11−outer = { inner: inner }
12−
13−main = Debug.Trace.trace "Done"
examples/passing/ObjectUpdate.pursdeleted−18
@@ -1,18 +0,0 @@
1−module Main where
2−
3− update1 = \o -> o { foo = "Foo" }
4−
5− update2 :: forall r. { foo :: String | r } -> { foo :: String | r }
6− update2 = \o -> o { foo = "Foo" }
7−
8− replace = \o -> case o of
9− { foo = "Foo" } -> o { foo = "Bar" }
10− { foo = "Bar" } -> o { bar = "Baz" }
11− o -> o
12−
13− polyUpdate :: forall a r. { foo :: a | r } -> { foo :: String | r }
14− polyUpdate = \o -> o { foo = "Foo" }
15−
16− inferPolyUpdate = \o -> o { foo = "Foo" }
17−
18− main = Debug.Trace.trace ((update1 {foo: ""}).foo)
examples/passing/ObjectUpdate2.pursdeleted−14
@@ -1,14 +0,0 @@
1−module Main where
2−
3−type X r = { | r }
4−
5−foreign import x "var x = {};" :: forall r. X r
6−
7−blah :: forall r. X r -> X r
8−blah x = x
9−
10−test = blah x
11− { baz = "blah"
12− }
13−
14−main = Debug.Trace.trace "Done"
examples/passing/ObjectUpdater.pursdeleted−35
@@ -1,35 +0,0 @@
1−module Main where
2−
3−import Control.Monad.Eff
4−import Debug.Trace
5−
6−foreign import eqeqeq
7− """
8− function eqeqeq(x) {
9− return function (y) {
10− if (x == y) return x;
11− throw new Error("Unexpected result: " + x + " /== " + y);
12− };
13− };
14− """ :: forall a. a -> a -> a
15−
16−(===) = eqeqeq
17−infixl 4 ===
18−
19−getValue :: forall e. Eff (| e) Boolean
20−getValue = return true
21−
22−main = do
23− let record = { value: false }
24− record' <- record { value = _ } <$> getValue
25− print $ record'.value === true
26−
27− let point = { x: 1, y: 1 }
28− x = 10
29− point' = (point { x = _, y = x }) 100
30−
31− print $ point'.x === 100
32− print $ point'.y === 10
33−
34− let record2 = (_ { x = _ }) { x: 0 } 10
35− print $ record2.x === 10
examples/passing/ObjectWildcards.pursdeleted−31
@@ -1,31 +0,0 @@
1−module Main where
2−
3−import Control.Monad.Eff
4−import Debug.Trace
5−
6−mkRecord = { foo: _, bar: _, baz: "baz" }
7−
8−getValue :: forall e. Eff (| e) Boolean
9−getValue = return true
10−
11−foreign import eqeqeq
12− """
13− function eqeqeq(x) {
14− return function (y) {
15− if (x == y) return x;
16− throw new Error("Unexpected result: " + x + " /== " + y);
17− };
18− };
19− """ :: forall a. a -> a -> a
20−
21−(===) = eqeqeq
22−infixl 4 ===
23−
24−main = do
25− obj <- { value: _ } <$> getValue
26− print obj.value
27− let x = 1
28− point <- { x: _, y: x } <$> return 2
29− print $ point.x === 2
30− print $ point.y === 1
31− trace (mkRecord 1 "Done!").bar
examples/passing/Objects.pursdeleted−35
@@ -1,35 +0,0 @@
1−module Main where
2−
3− import Prelude
4−
5− test = \x -> x.foo + x.bar + 1
6−
7− append = \o -> { foo: o.foo, bar: 1 }
8−
9− apTest = append({foo : "Foo", baz: "Baz"})
10−
11− f = (\a -> a.b.c) { b: { c: 1, d: "Hello" }, e: "World" }
12−
13− g = (\a -> a.f { x: 1, y: "y" }) { f: \o -> o.x + 1 }
14−
15− typed :: { foo :: Number }
16− typed = { foo: 0 }
17−
18− test2 = \x -> x."!@#"
19−
20− test3 = typed."foo"
21−
22− test4 = test2 weirdObj
23− where
24− weirdObj :: { "!@#" :: Number }
25− weirdObj = { "!@#": 1 }
26−
27− test5 = case { "***": 1 } of
28− { "***" = n } -> n
29−
30− test6 = case { "***": 1 } of
31− { "***": n } -> n
32−
33− test7 {a: snoog , b : blah } = blah
34−
35− main = Debug.Trace.trace "Done"
examples/passing/OneConstructor.pursdeleted−7
@@ -1,7 +0,0 @@
1−module Main where
2−
3−data One a = One a
4−
5−one' (One a) = a
6−
7−main = Debug.Trace.trace "Done"
examples/passing/OperatorAssociativity.pursdeleted−42
@@ -1,42 +0,0 @@
1−module Main where
2−
3−import Control.Monad.Eff
4−import Debug.Trace
5−
6−foreign import data Assert :: !
7−
8−foreign import assert
9− """
10− function assert(x) {
11− return function(desc) {
12− return function() {
13− if (!x) throw new Error('assertion (' + desc + ') failed');
14− return {};
15− };
16− };
17− }
18− """ :: forall e. Boolean -> String -> Eff (assert :: Assert | e) Unit
19−
20−bug :: Number -> Number -> Number
21−bug a b = 0 - (a - b)
22−
23−foreign import explode
24− """
25− function explode() {
26− throw new Error('Assertion failed!');
27− }
28− """ :: forall eff a. Eff eff a
29−
30−main = do
31− assert (bug 0 2 == 2) "bug 0 2 == 2"
32− assert (0 - (0 - 2) == 2) "0 - (0 - 2) == 2"
33− assert (0 - (0 + 2) == -2) "0 - (0 + 2) == -2"
34−
35− assert (6 / (3 * 2) == 1) "6 / (3 * 2) == 1"
36− assert ((6 / 3) * 2 == 4) "(6 / 3) * 2 == 4"
37−
38− assert (6 % (2 * 2) == 2) "6 % (2 * 2) == 2"
39− assert ((6 % 2) * 2 == 0) "(6 % 2) * 2 == 0"
40−
41− assert (4 % (9 / 3) == 1) "4 % (9 / 3) == 1"
42− assert ((4 % 9) / 2 == 2) "(4 % 9) / 2 == 2"
examples/passing/OperatorSections.pursdeleted−21
@@ -1,21 +0,0 @@
1−module Main where
2−
3−foreign import eqeqeq
4− """
5− function eqeqeq(x) {
6− return function (y) {
7− if (x == y) return x;
8− throw new Error("Unexpected result: " + x + " /== " + y);
9− };
10− };
11− """ :: forall a. a -> a -> a
12−
13−(===) = eqeqeq
14−infixl 4 ===
15−
16−main = do
17− Debug.Trace.print $ (/ 2) 4 === 2
18− Debug.Trace.print $ (2 /) 4 === 0.5
19− Debug.Trace.print $ (`const` 1) 2 === 2
20− Debug.Trace.print $ (1 `const`) 2 === 1
21− Debug.Trace.trace "Done!"
examples/passing/Operators.pursdeleted−102
@@ -1,102 +0,0 @@
1−module Main where
2−
3− import Control.Monad.Eff
4− import Debug.Trace
5−
6− (?!) :: forall a. a -> a -> a
7− (?!) x _ = x
8−
9− bar :: String -> String -> String
10− bar = \s1 s2 -> s1 ++ s2
11−
12− test1 :: forall n. (Num n) => n -> n -> (n -> n -> n) -> n
13− test1 x y z = x * y + z x y
14−
15− test2 = (\x -> x.foo false) { foo : \_ -> 1 }
16−
17− test3 = (\x y -> x)(1 + 2 * (1 + 2)) (true && (false || false))
18−
19− k = \x -> \y -> x
20−
21− test4 = 1 `k` 2
22−
23− infixl 5 %%
24−
25− (%%) :: Number -> Number -> Number
26− (%%) x y = x * y + y
27−
28− test5 = 1 %% 2 %% 3
29−
30− test6 = ((\x -> x) `k` 2) 3
31−
32− (<+>) :: String -> String -> String
33− (<+>) = \s1 s2 -> s1 ++ s2
34−
35− test7 = "Hello" <+> "World!"
36−
37− (@@) :: forall a b. (a -> b) -> a -> b
38− (@@) = \f x -> f x
39−
40− foo :: String -> String
41− foo = \s -> s
42−
43− test8 = foo @@ "Hello World"
44−
45− test9 = Main.foo @@ "Hello World"
46−
47− test10 = "Hello" `Main.bar` "World"
48−
49− (...) :: forall a. [a] -> [a] -> [a]
50− (...) = \as -> \bs -> as
51−
52− test11 = [1, 2, 3] ... [4, 5, 6]
53−
54− test12 (<%>) a b = a <%> b
55−
56− test13 = \(<%>) a b -> a <%> b
57−
58− test14 :: Number -> Number -> Boolean
59− test14 a b = a < b
60−
61− test15 :: Number -> Number -> Boolean
62− test15 a b = const false $ a `test14` b
63−
64− test16 :: Number -> Number -> Number
65− test16 x y = x .|. y .&. y
66−
67− test17 :: Number
68− test17 = negate (-1)
69−
70− test18 :: Number
71− test18 = negate $ negate 1
72−
73− test19 :: Number
74− test19 = negate $ negate (-1)
75−
76− test20 :: Number
77− test20 = 1 @ 2
78− where
79− (@) x y = x + y * y
80−
81− main = do
82− let t1 = test1 1 2 (\x y -> x + y)
83− let t2 = test2
84− let t3 = test3
85− let t4 = test4
86− let t5 = test5
87− let t6 = test6
88− let t7 = test7
89− let t8 = test8
90− let t9 = test9
91− let t10 = test10
92− let t11 = test11
93− let t12 = test12 k 1 2
94− let t13 = test13 k 1 2
95− let t14 = test14 1 2
96− let t15 = test15 1 2
97− let t16 = test16 1 2
98− let t17 = test17
99− let t18 = test18
100− let t19 = test19
101− let t20 = test20
102− trace "Done"
examples/passing/OptimizerBug.pursdeleted−9
@@ -1,9 +0,0 @@
1−module Main where
2−
3−import Prelude
4−
5−x a = 1 + y a
6−
7−y a = x a
8−
9−main = Debug.Trace.trace "Done"
examples/passing/PartialFunction.pursdeleted−19
@@ -1,19 +0,0 @@
1−module Main where
2−
3−foreign import testError
4− """
5− function testError(f) {
6− try {
7− return f();
8− } catch (e) {
9− if (e instanceof Error) return 'success';
10− throw new Error('Pattern match failure is not Error');
11− }
12− }
13− """ :: (Unit -> Number) -> String
14−
15−fn :: Number -> Number
16−fn 0 = 0
17−fn 1 = 2
18−
19−main = Debug.Trace.trace (show $ testError $ \_ -> fn 2)
examples/passing/Patterns.pursdeleted−28
@@ -1,28 +0,0 @@
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− g = \o -> case o of
15− { arr = [x : xs], take = "car" } -> x
16− { arr = [_, x : xs], take = "cadr" } -> x
17− _ -> 0
18−
19−
20− h = \o -> case o of
21− a@[_,_,_] -> a
22− _ -> []
23−
24− isDesc :: [Number] -> Boolean
25− isDesc [x, y] | x > y = true
26− isDesc _ = false
27−
28− main = Debug.Trace.trace "Done"
examples/passing/Person.pursdeleted−18
@@ -1,18 +0,0 @@
1−module Main where
2−
3− import Prelude ((++))
4−
5− data Person = Person { name :: String, age :: Number }
6−
7− foreign import itoa
8− """
9− function itoa(n) {
10− return n.toString();
11− }
12− """ :: Number -> String
13−
14− showPerson :: Person -> String
15− showPerson = \p -> case p of
16− Person o -> o.name ++ ", aged " ++ itoa(o.age)
17−
18− main = Debug.Trace.trace "Done"
examples/passing/Rank2Data.pursdeleted−29
@@ -1,29 +0,0 @@
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 (\n -> n + 1)
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.pursdeleted−10
@@ -1,10 +0,0 @@
1−module Main where
2−
3−import Debug.Trace
4−
5−data Foo = Foo { id :: forall a. a -> a }
6−
7−foo :: Foo -> Number
8−foo (Foo { id = f }) = f 0
9−
10−main = trace "Done"
examples/passing/Rank2TypeSynonym.pursdeleted−15
@@ -1,15 +0,0 @@
1−module Main where
2−
3−import Control.Monad.Eff
4−
5−type Foo a = forall f. (Monad f) => f a
6−
7−foo :: forall a. a -> Foo a
8−foo x = pure x
9−
10−bar :: Foo Number
11−bar = foo 3
12−
13−main = do
14− x <- bar
15− Debug.Trace.print x
examples/passing/Rank2Types.pursdeleted−11
@@ -1,11 +0,0 @@
1−module Main where
2−
3− import Prelude
4−
5− test1 :: (forall a. (a -> a)) -> Number
6− test1 = \f -> f 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/Recursion.pursdeleted−10
@@ -1,10 +0,0 @@
1−module Main where
2−
3− import Prelude
4−
5− fib = \n -> case n of
6− 0 -> 1
7− 1 -> 1
8− n -> fib (n - 1) + fib (n - 2)
9−
10− main = Debug.Trace.trace "Done"
examples/passing/ReservedWords.pursdeleted−13
@@ -1,13 +0,0 @@
1−-- See https://github.com/purescript/purescript/issues/606
2−module Main where
3−
4− o :: { type :: String }
5− o = { type: "o" }
6−
7− p :: { type :: String }
8− p = o { type = "p" }
9−
10− f :: forall r. { type :: String | r } -> String
11− f { type = "p" } = "Done"
12−
13− main = Debug.Trace.trace $ f { type: p.type, foo: "bar" }
examples/passing/RowPolyInstanceContext.pursdeleted−20
@@ -1,20 +0,0 @@
1−module Main where
2−
3−class T s m where
4− state :: (s -> s) -> m Unit
5−
6−data S s a = S (s -> { new :: s, ret :: a })
7−
8−instance st :: T s (S s) where
9− state f = S $ \s -> { new: f s, ret: unit }
10−
11−test1 :: forall r . S { foo :: String | r } Unit
12−test1 = state $ \o -> o { foo = o.foo ++ "!" }
13−
14−test2 :: forall m r . (T { foo :: String | r } m) => m Unit
15−test2 = state $ \o -> o { foo = o.foo ++ "!" }
16−
17−main = do
18− let t1 = test1
19− let t2 = test2
20− Debug.Trace.trace "Done"
examples/passing/RowSynonyms.pursdeleted−46
@@ -1,46 +0,0 @@
1−module Main where
2−
3−import Control.Monad.Eff
4−import Control.Monad.ST
5−
6−type State bindings =
7− {
8− bindings :: {addition :: Number | bindings},
9− other :: String
10− }
11−
12−type MyBindings = (test :: Number)
13−
14−data Shadow bindings = Shadow String
15−
16−shadows :: Shadow (Object MyBindings)
17−shadows = Shadow "uhh"
18−
19−main :: Eff () Unit
20−main = withIt
21− shadows
22− \ bindings -> do
23− let state =
24− {
25− bindings : bindings,
26− other : "Test"
27− }
28− runST do
29− stRef <- newSTRef state
30− handleKeyD stRef
31− return unit
32−
33−
34−withIt :: forall bindings eff a. Shadow (Object bindings) ->
35− ({addition :: Number | bindings} -> Eff eff a) -> Eff eff a
36−withIt (Shadow str) success = do
37− b <- withBindings
38− success (b{addition = 1})
39−
40−foreign import withBindings
41−"""
42− function withBindings() {}
43−""" :: forall eff bindings. Eff eff bindings
44−
45−handleKeyD :: forall h eff. STRef h (State MyBindings) -> Eff (st :: ST h | eff) Unit
46−handleKeyD state = return unit
examples/passing/RuntimeScopeIssue.pursdeleted−19
@@ -1,19 +0,0 @@
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 = true
13− a n = b (n - 1)
14−
15−instance bNumber :: B Number where
16− b 0 = false
17− b n = a (n - 1)
18−
19−main = Debug.Trace.print $ a 10
examples/passing/ScopedTypeVariables.pursdeleted−34
@@ -1,34 +0,0 @@
1−module Main where
2−
3−test1 :: forall a. (a -> a) -> a -> a
4−test1 f x = g (g x)
5− where
6− g :: a -> a
7− g y = f (f y)
8−
9−test2 :: forall a. (a -> a) -> a -> a
10−test2 = h
11− where
12− h :: forall b. (b -> b) -> b -> b
13− h f x = g (g x)
14− where
15− g :: b -> b
16− g y = f (f y)
17−
18−test3 :: Number
19−test3 = ((\b -> b :: b) :: forall b. b -> b) 0
20−
21−test4 :: forall a. (a -> a) -> a -> a
22−test4 = h
23− where
24− h :: forall b. (b -> b) -> b -> b
25− h f x = g (g x)
26− where
27− g :: b -> b
28− g y = j (f (f y))
29− where
30− j :: forall b. b -> b
31− j x = x
32−
33−
34−main = Debug.Trace.trace "Done"
examples/passing/Sequence.pursdeleted−12
@@ -1,12 +0,0 @@
1−module Main where
2−
3−import Control.Monad.Eff
4−
5−class Sequence t where
6− sequence :: forall m a. (Monad m) => t (m a) -> m (t a)
7−
8−instance sequenceArray :: Sequence [] where
9− sequence [] = pure []
10− sequence (x:xs) = (:) <$> x <*> sequence xs
11−
12−main = sequence $ [Debug.Trace.trace "Done"]
examples/passing/ShadowedRename.pursdeleted−21
@@ -1,21 +0,0 @@
1−module Main where
2−
3−import Control.Monad.Eff
4−import Debug.Trace
5−
6−foreign import f
7− """
8− function f(x) {
9− return function() {
10− if (x !== 2) throw new Error('x is not 2');
11− };
12− }
13− """ :: forall e. Number -> Eff e Number
14−
15−foo foo = let foo_1 = \_ -> foo
16− foo_2 = foo_1 unit + 1
17− in foo_2
18−
19−main = do
20− f (foo 1)
21− trace "Done"
examples/passing/ShadowedTCO.pursdeleted−16
@@ -1,16 +0,0 @@
1−module Main where
2−
3−runNat f = f 0 (\n -> n + 1)
4−
5−zero' z _ = z
6−
7−succ f zero' succ = succ (f zero' succ)
8−
9−add f g zero' succ = g (f zero' succ) succ
10−
11−one' = succ zero'
12−two = succ one'
13−four = add two two
14−fourNumber = runNat four
15−
16−main = Debug.Trace.trace $ show fourNumber
examples/passing/ShadowedTCOLet.pursdeleted−7
@@ -1,7 +0,0 @@
1−module Main where
2−
3−f x y z =
4− let f 1 2 3 = 1
5− in f x z y
6−
7−main = Debug.Trace.trace $ show $ f 1 3 2
examples/passing/SignedNumericLiterals.pursdeleted−15
@@ -1,15 +0,0 @@
1−module Main where
2−
3− p = 0.5
4− q = 1
5− x = -1
6− y = -0.5
7− z = 0.5
8− w = 1
9−
10− f :: Number -> Number
11− f x = -x
12−
13− test1 = 2 - 1
14−
15− main = Debug.Trace.trace "Done"
examples/passing/Superclasses1.pursdeleted−18
@@ -1,18 +0,0 @@
1−module Main where
2−
3−class Su a where
4− su :: a -> a
5−
6−class (Su a) <= Cl a where
7− cl :: a -> a -> a
8−
9−instance suNumber :: Su Number where
10− su n = n + 1
11−
12−instance clNumber :: Cl Number where
13− cl n m = n + m
14−
15−test :: forall a. (Cl a) => a -> a
16−test a = su (cl a a)
17−
18−main = Debug.Trace.print $ test 10
examples/passing/Superclasses2.pursdeleted−23
@@ -1,23 +0,0 @@
1−module Main where
2−
3−import Prelude.Unsafe (unsafeIndex)
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
13−
14−instance suArray :: (Su a) => Su [a] where
15− su (x : _) = [su x]
16−
17−instance clNumber :: Cl Number where
18− cl n m = n + m
19−
20−test :: forall a. (Cl a) => a -> [a]
21−test x = su [cl x x]
22−
23−main = Debug.Trace.print $ test 10 `unsafeIndex` 0
examples/passing/Superclasses3.pursdeleted−41
@@ -1,41 +0,0 @@
1−module Main where
2−
3−import Debug.Trace
4−
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 <$> 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− (>>=) 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.pursdeleted−10
@@ -1,10 +0,0 @@
1−module Main where
2−
3−data Data = One | More Data
4−
5−main = Debug.Trace.trace (from (to 10000 One))
6− where
7− to 0 a = a
8− to n a = to (n - 1) (More a)
9− from One = "Done"
10− from (More d) = from d
examples/passing/TailCall.pursdeleted−15
@@ -1,15 +0,0 @@
1−module Main where
2−
3−import Prelude
4−
5−test :: Number -> [Number] -> Number
6−test n [] = n
7−test n (x:xs) = test (n + x) xs
8−
9−loop :: forall a. Number -> a
10−loop x = loop (x + 1)
11−
12−notATailCall = \x ->
13− (\notATailCall -> notATailCall x) (\x -> x)
14−
15−main = Debug.Trace.print (test 0 [1, 2, 3])
examples/passing/Tick.pursdeleted−5
@@ -1,5 +0,0 @@
1−module Main where
2−
3−test' x = x
4−
5−main = Debug.Trace.trace "Done"
examples/passing/TopLevelCase.pursdeleted−18
@@ -1,18 +0,0 @@
1−module Main where
2−
3− import Prelude
4−
5− gcd :: Number -> Number -> Number
6− gcd 0 x = x
7− gcd x 0 = x
8− gcd x y | x > y = gcd (x % y) y
9− gcd x y = gcd (y % x) x
10−
11− guardsTest (x:xs) | x > 0 = guardsTest xs
12− guardsTest xs = xs
13−
14− data A = A
15−
16− parseTest A 0 = 0
17−
18− main = Debug.Trace.trace "Done"
examples/passing/TypeClassImport.pursdeleted−18
@@ -1,18 +0,0 @@
1−module Main where
2−
3−foreign import data T :: *
4−
5−foreign import data C :: *
6−
7−foreign import t "var t = null;" :: T
8−
9−foreign import inst """
10− var inst = {
11− show: function(t) {
12− return 'Done';
13− }
14− }""" :: C
15−
16−foreign import instance inst :: Show T
17−
18−main = Debug.Trace.print t
examples/passing/TypeClassMemberOrderChange.pursdeleted−11
@@ -1,11 +0,0 @@
1−module Main where
2−
3−class Test a where
4− fn :: a -> a -> a
5− val :: a
6−
7−instance testBoolean :: Test Boolean where
8− val = true
9− fn x y = y
10−
11−main = Debug.Trace.trace (show (fn true val))
examples/passing/TypeClasses.pursdeleted−69
@@ -1,69 +0,0 @@
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− (>>=) (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− (>>=) Nothing _ = Nothing
51− (>>=) (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
57−
58−test5 = \_ -> Just 1 >>= \n -> return (n + 1)
59−
60−ask r = r
61−
62−runReader r f = f r
63−
64−test9 _ = runReader 0 $ do
65− n <- ask
66− return $ n + 1
67−
68−main = Debug.Trace.trace (test7 "Done")
69−
examples/passing/TypeClassesInOrder.pursdeleted−11
@@ -1,11 +0,0 @@
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.pursdeleted−11
@@ -1,11 +0,0 @@
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.pursdeleted−12
@@ -1,12 +0,0 @@
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 f a = a
10− iterate n f a = iterate (n - 1) f (f a)
11−
12− main = Debug.Trace.trace "Done"
examples/passing/TypeSynonymInData.pursdeleted−9
@@ -1,9 +0,0 @@
1−module Main where
2−
3−type A a = [a]
4−
5−data Foo a = Foo (A a) | Bar
6−
7−foo (Foo []) = Bar
8−
9−main = Debug.Trace.trace "Done"
examples/passing/TypeSynonyms.pursdeleted−25
@@ -1,25 +0,0 @@
1−module Main where
2−
3− type Lens a b =
4− { get :: a -> b
5− , set :: a -> b -> a
6− }
7−
8− composeLenses :: forall a b c. Lens a b -> Lens b c -> Lens a c
9− composeLenses = \l1 -> \l2 ->
10− { get: \a -> l2.get (l1.get a)
11− , set: \a c -> l1.set a (l2.set (l1.get a) c)
12− }
13−
14− type Pair a b = { fst :: a, snd :: b }
15−
16− fst :: forall a b. Lens (Pair a b) a
17− fst =
18− { get: \p -> p.fst
19− , set: \p a -> { fst: a, snd: p.snd }
20− }
21−
22− test1 :: forall a b c. Lens (Pair (Pair a b) c) a
23− test1 = composeLenses fst fst
24−
25− main = Debug.Trace.trace "Done"
examples/passing/TypeWildcards.pursdeleted−13
@@ -1,13 +0,0 @@
1−module Main where
2−
3−testTopLevel :: _ -> _
4−testTopLevel n = n + 1
5−
6−test :: forall a. (Eq a) => (a -> a) -> a -> a
7−test f a = go (f a) a
8− where
9− go :: _ -> _ -> _
10− go a1 a2 | a1 == a2 = a1
11− go a1 _ = go (f a1) a1
12−
13−main = Debug.Trace.trace "Done"
examples/passing/TypeWildcardsRecordExtension.pursdeleted−6
@@ -1,6 +0,0 @@
1−module Main where
2−
3−foo :: forall a. {b :: Number | a} -> {b :: Number | _}
4−foo f = f
5−
6−main = Debug.Trace.trace "Done"
examples/passing/TypedWhere.pursdeleted−13
@@ -1,13 +0,0 @@
1−module Main where
2−
3−data E a b = L a | R b
4−
5−lefts :: forall a b. [E a b] -> [a]
6−lefts = go []
7− where
8− go :: forall a b. [a] -> [E a b] -> [a]
9− go ls [] = ls
10− go ls (L a : rest) = go (a : ls) rest
11− go ls (_ : rest) = go ls rest
12−
13−main = Debug.Trace.trace "Done"
examples/passing/UnderscoreIdent.pursdeleted−9
@@ -1,9 +0,0 @@
1−module Main where
2−
3−data Data_type = Con_Structor | Con_2 String
4−
5−type Type_name = Data_type
6−
7−done (Con_2 s) = s
8−
9−main = Debug.Trace.trace (done (Con_2 "Done"))
examples/passing/Unit.pursdeleted−6
@@ -1,6 +0,0 @@
1−module Main where
2−
3−import Prelude
4−import Debug.Trace
5−
6−main = print (const unit $ "Hello world")
examples/passing/UnknownInTypeClassLookup.pursdeleted−12
@@ -1,12 +0,0 @@
1−module Main where
2−
3−class EQ a b
4−
5−instance eqAA :: EQ a a
6−
7−test :: forall a b. (EQ a b) => a -> b -> String
8−test _ _ = "Done"
9−
10−runTest a = test a a
11−
12−main = Debug.Trace.trace $ runTest 0
examples/passing/Where.pursdeleted−49
@@ -1,49 +0,0 @@
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
11−
12−test2 x y = x' + y'
13− where
14− x' = x + 1
15− y' = y + 1
16−
17−
18−test3 = f 1 2 3
19− where f x y z = x + y + z
20−
21−
22−test4 = f (+) [1, 2]
23− where f x [y, z] = x y z
24−
25−
26−test5 = g 10
27− where
28− f x | x > 0 = g (x / 2) + 1
29− f x = 0
30− g x = f (x - 1) + 1
31−
32−test6 = if f true then f 1 else f 2
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
41−
42−main = do
43− Debug.Trace.print (test1 1)
44− Debug.Trace.print (test2 1 2)
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)
examples/passing/iota.pursdeleted−9
@@ -1,9 +0,0 @@
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.pursdeleted−5
@@ -1,5 +0,0 @@
1−module Main where
2−
3− s = \x y z -> x z (y z)
4−
5− main = Debug.Trace.trace "Done"
hierarchy/Main.hsdeleted−113
@@ -1,113 +0,0 @@
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−module Main where
17−
18−import Control.Monad (unless)
19−
20−import Data.List (intercalate,nub,sort)
21−import Data.Foldable (for_)
22−import Data.Version (showVersion)
23−
24−import Options.Applicative
25−import System.Directory (createDirectoryIfMissing)
26−import System.FilePath ((</>))
27−import System.Exit (exitFailure, exitSuccess)
28−import System.IO (hPutStr, stderr)
29−
30−import Text.Parsec as Par (ParseError)
31−
32−import qualified Language.PureScript as P
33−import qualified Paths_purescript as Paths
34−
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 Par.ParseError [P.Module])
57−readInput filename = do
58− content <- readFile filename
59− return $ fmap (map snd) $ P.parseModulesFromFiles id [(filename, content)]
60−
61−compile :: HierarchyOptions -> IO ()
62−compile (HierarchyOptions input mOutput) = do
63− modules <- readInput input
64− case modules of
65− Left err -> hPutStr stderr (show err) >> exitFailure
66− Right ms -> do
67− for_ ms $ \(P.Module moduleName decls _) ->
68− let name = runModuleName moduleName
69− tcs = filter P.isTypeClassDeclaration decls
70− supers = sort . nub . filter (not . null) $ fmap superClasses tcs
71− prologue = "digraph " ++ name ++ " {\n"
72− body = intercalate "\n" (concatMap (fmap (\s -> " " ++ show s ++ ";")) supers)
73− epilogue = "\n}"
74− hier = prologue ++ body ++ epilogue
75− in unless (null supers) $ case mOutput of
76− Just output -> do
77− createDirectoryIfMissing True output
78− writeFile (output </> name) hier
79− Nothing -> putStrLn hier
80− exitSuccess
81−
82−superClasses :: P.Declaration -> [SuperMap]
83−superClasses (P.TypeClassDeclaration sub _ supers@(_:_) _) =
84− fmap (\(P.Qualified _ super, _) -> SuperMap (Right (super, sub))) supers
85−superClasses (P.TypeClassDeclaration sub _ _ _) = [SuperMap (Left sub)]
86−superClasses (P.PositionedDeclaration _ _ decl) = superClasses decl
87−superClasses _ = []
88−
89−inputFile :: Parser FilePath
90−inputFile = strArgument $
91− metavar "FILE"
92− <> value "main.purs"
93− <> showDefault
94− <> help "The input file to generate a hierarchy from"
95−
96−outputFile :: Parser (Maybe FilePath)
97−outputFile = optional . strOption $
98− short 'o'
99− <> long "output"
100− <> help "The output directory"
101−
102−pscOptions :: Parser HierarchyOptions
103−pscOptions = HierarchyOptions <$> inputFile
104− <*> outputFile
105−
106−main :: IO ()
107−main = execParser opts >>= compile
108− where
109− opts = info (helper <*> pscOptions) infoModList
110− infoModList = fullDesc <> headerInfo <> footerInfo
111− headerInfo = header "hierarchy - Creates a GraphViz directed graph of PureScript TypeClasses"
112− footerInfo = footer $ "hierarchy " ++ showVersion Paths.version
113−
package.yamlnew file+86
@@ -0,0 +1,86 @@
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
prelude/README.mddeleted−685
@@ -1,685 +0,0 @@
1−# Module Documentation
2−
3−## Module Prelude
4−
5−### Types
6−
7−#### `Ordering`
8−
9− data Ordering
10− = LT
11− | GT
12− | EQ
13−
14−#### `Unit`
15−
16− newtype Unit
17− = Unit { }
18−
19−
20−### Type Classes
21−
22−![Prelude](images/Prelude.png)
23−
24−#### `Applicative`
25−
26− class (Apply f) <= Applicative f where
27− pure :: forall a. a -> f a
28−
29−#### `Apply`
30−
31− class (Functor f) <= Apply f where
32− (<*>) :: forall a b. f (a -> b) -> f a -> f b
33−
34−#### `Bind`
35−
36− class (Apply m) <= Bind m where
37− (>>=) :: forall a b. m a -> (a -> m b) -> m b
38−
39−#### `Bits`
40−
41− class Bits b where
42− (.&.) :: b -> b -> b
43− (.|.) :: b -> b -> b
44− (.^.) :: b -> b -> b
45− shl :: b -> Number -> b
46− shr :: b -> Number -> b
47− zshr :: b -> Number -> b
48− complement :: b -> b
49−
50−#### `BoolLike`
51−
52− class BoolLike b where
53− (&&) :: b -> b -> b
54− (||) :: b -> b -> b
55− not :: b -> b
56−
57−#### `Category`
58−
59− class (Semigroupoid a) <= Category a where
60− id :: forall t. a t t
61−
62−#### `DivisionRing`
63−
64−Ring where every nonzero element has a multiplicative inverse (possibly
65−a non-commutative field) so that ```a `mod` b = zero```
66−
67− class (Ring a, ModuloSemiring a) <= DivisionRing a where
68−
69−#### `Eq`
70−
71− class Eq a where
72− (==) :: a -> a -> Boolean
73− (/=) :: a -> a -> Boolean
74−
75−#### `Functor`
76−
77− class Functor f where
78− (<$>) :: forall a b. (a -> b) -> f a -> f b
79−
80−#### `ModuloSemiring`
81−
82−Semiring with modulo operation and division where
83−```a / b * b + (a `mod` b) = a```
84−
85− class (Semiring a) <= ModuloSemiring a where
86− (/) :: a -> a -> a
87− mod :: a -> a -> a
88−
89−#### `Monad`
90−
91− class (Applicative m, Bind m) <= Monad m where
92−
93−#### `Num`
94−
95−A commutative field
96−
97− class (DivisionRing a) <= Num a where
98−
99−#### `Ord`
100−
101− class (Eq a) <= Ord a where
102− compare :: a -> a -> Ordering
103−
104−#### `Ring`
105−
106−Addition, multiplication, and subtraction
107−
108− class (Semiring a) <= Ring a where
109− (-) :: a -> a -> a
110−
111−#### `Semigroup`
112−
113− class Semigroup a where
114− (<>) :: a -> a -> a
115−
116−#### `Semigroupoid`
117−
118− class Semigroupoid a where
119− (<<<) :: forall b c d. a c d -> a b c -> a b d
120−
121−#### `Semiring`
122−
123−Addition and multiplication
124−
125− class Semiring a where
126− (+) :: a -> a -> a
127− zero :: a
128− (*) :: a -> a -> a
129− one :: a
130−
131−#### `Show`
132−
133− class Show a where
134− show :: a -> String
135−
136−
137−### Type Class Instances
138−
139−#### `applicativeArr`
140−
141− instance applicativeArr :: Applicative (Prim.Function r)
142−
143−#### `applyArr`
144−
145− instance applyArr :: Apply (Prim.Function r)
146−
147−#### `bindArr`
148−
149− instance bindArr :: Bind (Prim.Function r)
150−
151−#### `bitsNumber`
152−
153− instance bitsNumber :: Bits Number
154−
155−#### `boolLikeBoolean`
156−
157− instance boolLikeBoolean :: BoolLike Boolean
158−
159−#### `categoryArr`
160−
161− instance categoryArr :: Category Prim.Function
162−
163−#### `divisionRingNumber`
164−
165− instance divisionRingNumber :: DivisionRing Number
166−
167−#### `eqArray`
168−
169− instance eqArray :: (Eq a) => Eq [a]
170−
171−#### `eqBoolean`
172−
173− instance eqBoolean :: Eq Boolean
174−
175−#### `eqNumber`
176−
177− instance eqNumber :: Eq Number
178−
179−#### `eqOrdering`
180−
181− instance eqOrdering :: Eq Ordering
182−
183−#### `eqString`
184−
185− instance eqString :: Eq String
186−
187−#### `eqUnit`
188−
189− instance eqUnit :: Eq Unit
190−
191−#### `functorArr`
192−
193− instance functorArr :: Functor (Prim.Function r)
194−
195−#### `moduloSemiringNumber`
196−
197− instance moduloSemiringNumber :: ModuloSemiring Number
198−
199−#### `monadArr`
200−
201− instance monadArr :: Monad (Prim.Function r)
202−
203−#### `numNumber`
204−
205− instance numNumber :: Num Number
206−
207−#### `ordArray`
208−
209− instance ordArray :: (Ord a) => Ord [a]
210−
211−#### `ordBoolean`
212−
213− instance ordBoolean :: Ord Boolean
214−
215−#### `ordNumber`
216−
217− instance ordNumber :: Ord Number
218−
219−#### `ordString`
220−
221− instance ordString :: Ord String
222−
223−#### `ordUnit`
224−
225− instance ordUnit :: Ord Unit
226−
227−#### `ringNumber`
228−
229− instance ringNumber :: Ring Number
230−
231−#### `semigroupArr`
232−
233− instance semigroupArr :: (Semigroup s') => Semigroup (s -> s')
234−
235−#### `semigroupString`
236−
237− instance semigroupString :: Semigroup String
238−
239−#### `semigroupUnit`
240−
241− instance semigroupUnit :: Semigroup Unit
242−
243−#### `semigroupoidArr`
244−
245− instance semigroupoidArr :: Semigroupoid Prim.Function
246−
247−#### `semiringNumber`
248−
249− instance semiringNumber :: Semiring Number
250−
251−#### `showArray`
252−
253− instance showArray :: (Show a) => Show [a]
254−
255−#### `showBoolean`
256−
257− instance showBoolean :: Show Boolean
258−
259−#### `showNumber`
260−
261− instance showNumber :: Show Number
262−
263−#### `showOrdering`
264−
265− instance showOrdering :: Show Ordering
266−
267−#### `showString`
268−
269− instance showString :: Show String
270−
271−#### `showUnit`
272−
273− instance showUnit :: Show Unit
274−
275−
276−### Values
277−
278−#### `(#)`
279−
280− (#) :: forall a b. a -> (a -> b) -> b
281−
282−#### `($)`
283−
284− ($) :: forall a b. (a -> b) -> a -> b
285−
286−#### `(++)`
287−
288− (++) :: forall s. (Semigroup s) => s -> s -> s
289−
290−#### `(:)`
291−
292− (:) :: forall a. a -> [a] -> [a]
293−
294−#### `(<#>)`
295−
296− (<#>) :: forall f a b. (Functor f) => f a -> (a -> b) -> f b
297−
298−#### `(<)`
299−
300− (<) :: forall a. (Ord a) => a -> a -> Boolean
301−
302−#### `(<=)`
303−
304− (<=) :: forall a. (Ord a) => a -> a -> Boolean
305−
306−#### `(>)`
307−
308− (>) :: forall a. (Ord a) => a -> a -> Boolean
309−
310−#### `(>=)`
311−
312− (>=) :: forall a. (Ord a) => a -> a -> Boolean
313−
314−#### `(>>>)`
315−
316− (>>>) :: forall a b c d. (Semigroupoid a) => a b c -> a c d -> a b d
317−
318−#### `ap`
319−
320− ap :: forall m a b. (Monad m) => m (a -> b) -> m a -> m b
321−
322−#### `asTypeOf`
323−
324−This function returns its first argument, and can be used to assert type equalities.
325−This can be useful when types are otherwise ambiguous.
326−
327−E.g.
328−
329− main = print $ [] `asTypeOf` [0]
330−
331−If instead, we had written `main = print []`, the type of the argument `[]` would have
332−been ambiguous, resulting in a compile-time error.
333−
334− asTypeOf :: forall a. a -> a -> a
335−
336−#### `cons`
337−
338− cons :: forall a. a -> [a] -> [a]
339−
340−#### `const`
341−
342−Returns its first argument and ignores its second.
343−
344− const :: forall a b. a -> b -> a
345−
346−#### `flip`
347−
348−Flips the order of the arguments to a function of two arguments.
349−
350− flip :: forall a b c. (a -> b -> c) -> b -> a -> c
351−
352−#### `liftA1`
353−
354− liftA1 :: forall f a b. (Applicative f) => (a -> b) -> f a -> f b
355−
356−#### `liftM1`
357−
358− liftM1 :: forall m a b. (Monad m) => (a -> b) -> m a -> m b
359−
360−#### `negate`
361−
362− negate :: forall a. (Ring a) => a -> a
363−
364−#### `otherwise`
365−
366−An alias for `true`, which can be useful in guard clauses:
367−
368−E.g.
369−
370− max x y | x >= y = x
371− | otherwise = y
372−
373− otherwise :: Boolean
374−
375−#### `refEq`
376−
377− refEq :: forall a. a -> a -> Boolean
378−
379−#### `refIneq`
380−
381− refIneq :: forall a. a -> a -> Boolean
382−
383−#### `return`
384−
385− return :: forall m a. (Monad m) => a -> m a
386−
387−#### `unit`
388−
389− unit :: Unit
390−
391−#### `void`
392−
393− void :: forall f a. (Functor f) => f a -> f Unit
394−
395−
396−## Module Data.Function
397−
398−### Types
399−
400−#### `Fn0`
401−
402− data Fn0 :: * -> *
403−
404−#### `Fn1`
405−
406− data Fn1 :: * -> * -> *
407−
408−#### `Fn10`
409−
410− data Fn10 :: * -> * -> * -> * -> * -> * -> * -> * -> * -> * -> * -> *
411−
412−#### `Fn2`
413−
414− data Fn2 :: * -> * -> * -> *
415−
416−#### `Fn3`
417−
418− data Fn3 :: * -> * -> * -> * -> *
419−
420−#### `Fn4`
421−
422− data Fn4 :: * -> * -> * -> * -> * -> *
423−
424−#### `Fn5`
425−
426− data Fn5 :: * -> * -> * -> * -> * -> * -> *
427−
428−#### `Fn6`
429−
430− data Fn6 :: * -> * -> * -> * -> * -> * -> * -> *
431−
432−#### `Fn7`
433−
434− data Fn7 :: * -> * -> * -> * -> * -> * -> * -> * -> *
435−
436−#### `Fn8`
437−
438− data Fn8 :: * -> * -> * -> * -> * -> * -> * -> * -> * -> *
439−
440−#### `Fn9`
441−
442− data Fn9 :: * -> * -> * -> * -> * -> * -> * -> * -> * -> * -> *
443−
444−
445−### Values
446−
447−#### `mkFn0`
448−
449− mkFn0 :: forall a. (Unit -> a) -> Fn0 a
450−
451−#### `mkFn1`
452−
453− mkFn1 :: forall a b. (a -> b) -> Fn1 a b
454−
455−#### `mkFn10`
456−
457− mkFn10 :: forall a b c d e f g h i j k. (a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k) -> Fn10 a b c d e f g h i j k
458−
459−#### `mkFn2`
460−
461− mkFn2 :: forall a b c. (a -> b -> c) -> Fn2 a b c
462−
463−#### `mkFn3`
464−
465− mkFn3 :: forall a b c d. (a -> b -> c -> d) -> Fn3 a b c d
466−
467−#### `mkFn4`
468−
469− mkFn4 :: forall a b c d e. (a -> b -> c -> d -> e) -> Fn4 a b c d e
470−
471−#### `mkFn5`
472−
473− mkFn5 :: forall a b c d e f. (a -> b -> c -> d -> e -> f) -> Fn5 a b c d e f
474−
475−#### `mkFn6`
476−
477− mkFn6 :: forall a b c d e f g. (a -> b -> c -> d -> e -> f -> g) -> Fn6 a b c d e f g
478−
479−#### `mkFn7`
480−
481− mkFn7 :: forall a b c d e f g h. (a -> b -> c -> d -> e -> f -> g -> h) -> Fn7 a b c d e f g h
482−
483−#### `mkFn8`
484−
485− mkFn8 :: forall a b c d e f g h i. (a -> b -> c -> d -> e -> f -> g -> h -> i) -> Fn8 a b c d e f g h i
486−
487−#### `mkFn9`
488−
489− mkFn9 :: forall a b c d e f g h i j. (a -> b -> c -> d -> e -> f -> g -> h -> i -> j) -> Fn9 a b c d e f g h i j
490−
491−#### `on`
492−
493− on :: forall a b c. (b -> b -> c) -> (a -> b) -> a -> a -> c
494−
495−#### `runFn0`
496−
497− runFn0 :: forall a. Fn0 a -> a
498−
499−#### `runFn1`
500−
501− runFn1 :: forall a b. Fn1 a b -> a -> b
502−
503−#### `runFn10`
504−
505− runFn10 :: forall a b c d e f g h i j k. Fn10 a b c d e f g h i j k -> a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k
506−
507−#### `runFn2`
508−
509− runFn2 :: forall a b c. Fn2 a b c -> a -> b -> c
510−
511−#### `runFn3`
512−
513− runFn3 :: forall a b c d. Fn3 a b c d -> a -> b -> c -> d
514−
515−#### `runFn4`
516−
517− runFn4 :: forall a b c d e. Fn4 a b c d e -> a -> b -> c -> d -> e
518−
519−#### `runFn5`
520−
521− runFn5 :: forall a b c d e f. Fn5 a b c d e f -> a -> b -> c -> d -> e -> f
522−
523−#### `runFn6`
524−
525− runFn6 :: forall a b c d e f g. Fn6 a b c d e f g -> a -> b -> c -> d -> e -> f -> g
526−
527−#### `runFn7`
528−
529− runFn7 :: forall a b c d e f g h. Fn7 a b c d e f g h -> a -> b -> c -> d -> e -> f -> g -> h
530−
531−#### `runFn8`
532−
533− runFn8 :: forall a b c d e f g h i. Fn8 a b c d e f g h i -> a -> b -> c -> d -> e -> f -> g -> h -> i
534−
535−#### `runFn9`
536−
537− runFn9 :: forall a b c d e f g h i j. Fn9 a b c d e f g h i j -> a -> b -> c -> d -> e -> f -> g -> h -> i -> j
538−
539−
540−## Module Prelude.Unsafe
541−
542−### Values
543−
544−#### `unsafeIndex`
545−
546− unsafeIndex :: forall a. [a] -> Number -> a
547−
548−
549−## Module Control.Monad.Eff
550−
551−### Types
552−
553−#### `Eff`
554−
555− data Eff :: # ! -> * -> *
556−
557−#### `Pure`
558−
559− type Pure a = forall e. Eff e a
560−
561−
562−### Type Class Instances
563−
564−#### `applicativeEff`
565−
566− instance applicativeEff :: Applicative (Eff e)
567−
568−#### `applyEff`
569−
570− instance applyEff :: Apply (Eff e)
571−
572−#### `bindEff`
573−
574− instance bindEff :: Bind (Eff e)
575−
576−#### `functorEff`
577−
578− instance functorEff :: Functor (Eff e)
579−
580−#### `monadEff`
581−
582− instance monadEff :: Monad (Eff e)
583−
584−
585−### Values
586−
587−#### `bindE`
588−
589− bindE :: forall e a b. Eff e a -> (a -> Eff e b) -> Eff e b
590−
591−#### `forE`
592−
593− forE :: forall e. Number -> Number -> (Number -> Eff e Unit) -> Eff e Unit
594−
595−#### `foreachE`
596−
597− foreachE :: forall e a. [a] -> (a -> Eff e Unit) -> Eff e Unit
598−
599−#### `returnE`
600−
601− returnE :: forall e a. a -> Eff e a
602−
603−#### `runPure`
604−
605− runPure :: forall a. Pure a -> a
606−
607−#### `untilE`
608−
609− untilE :: forall e. Eff e Boolean -> Eff e Unit
610−
611−#### `whileE`
612−
613− whileE :: forall e a. Eff e Boolean -> Eff e a -> Eff e Unit
614−
615−
616−## Module Control.Monad.Eff.Unsafe
617−
618−### Values
619−
620−#### `unsafeInterleaveEff`
621−
622− unsafeInterleaveEff :: forall eff1 eff2 a. Eff eff1 a -> Eff eff2 a
623−
624−
625−## Module Debug.Trace
626−
627−### Types
628−
629−#### `Trace`
630−
631− data Trace :: !
632−
633−
634−### Values
635−
636−#### `print`
637−
638− print :: forall a r. (Show a) => a -> Eff (trace :: Trace | r) Unit
639−
640−#### `trace`
641−
642− trace :: forall r. String -> Eff (trace :: Trace | r) Unit
643−
644−
645−## Module Control.Monad.ST
646−
647−### Types
648−
649−#### `ST`
650−
651− data ST :: * -> !
652−
653−#### `STRef`
654−
655− data STRef :: * -> * -> *
656−
657−
658−### Values
659−
660−#### `modifySTRef`
661−
662− modifySTRef :: forall a h r. STRef h a -> (a -> a) -> Eff (st :: ST h | r) a
663−
664−#### `newSTRef`
665−
666− newSTRef :: forall a h r. a -> Eff (st :: ST h | r) (STRef h a)
667−
668−#### `pureST`
669−
670− pureST :: forall a. (forall h r. Eff (st :: ST h | r) a) -> a
671−
672−#### `readSTRef`
673−
674− readSTRef :: forall a h r. STRef h a -> Eff (st :: ST h | r) a
675−
676−#### `runST`
677−
678− runST :: forall a r. (forall h. Eff (st :: ST h | r) a) -> Eff r a
679−
680−#### `writeSTRef`
681−
682− writeSTRef :: forall a h r. STRef h a -> a -> Eff (st :: ST h | r) a
683−
684−
685−
prelude/images/Prelude.pngdeleted

Binary file not shown.

prelude/prelude.pursdeleted−1104
@@ -1,1104 +0,0 @@
1−module Prelude
2− ( otherwise
3− , flip
4− , const
5− , asTypeOf
6− , Semigroupoid, (<<<), (>>>)
7− , Category, id
8− , ($), (#)
9− , (:), cons
10− , Show, show
11− , Functor, (<$>), (<#>), void
12− , Apply, (<*>)
13− , Applicative, pure, liftA1
14− , Bind, (>>=)
15− , Monad, return, liftM1, ap
16− , Semiring, (+), zero, (*), one
17− , ModuloSemiring, (/), mod
18− , Ring, (-)
19− , (%)
20− , negate
21− , DivisionRing
22− , Num
23− , Eq, (==), (/=), refEq, refIneq
24− , Ord, Ordering(..), compare, (<), (>), (<=), (>=)
25− , Bits, (.&.), (.|.), (.^.), shl, shr, zshr, complement
26− , BoolLike, (&&), (||)
27− , not
28− , Semigroup, (<>), (++)
29− , Unit(..), unit
30− ) where
31−
32− -- | An alias for `true`, which can be useful in guard clauses:
33− -- |
34− -- | E.g.
35− -- |
36− -- | max x y | x >= y = x
37− -- | | otherwise = y
38− otherwise :: Boolean
39− otherwise = true
40−
41− -- | Flips the order of the arguments to a function of two arguments.
42− flip :: forall a b c. (a -> b -> c) -> b -> a -> c
43− flip f b a = f a b
44−
45− -- | Returns its first argument and ignores its second.
46− const :: forall a b. a -> b -> a
47− const a _ = a
48−
49− -- | This function returns its first argument, and can be used to assert type equalities.
50− -- | This can be useful when types are otherwise ambiguous.
51− -- |
52− -- | E.g.
53− -- |
54− -- | main = print $ [] `asTypeOf` [0]
55− -- |
56− -- | If instead, we had written `main = print []`, the type of the argument `[]` would have
57− -- | been ambiguous, resulting in a compile-time error.
58− asTypeOf :: forall a. a -> a -> a
59− asTypeOf x _ = x
60−
61− infixr 9 >>>
62− infixr 9 <<<
63−
64− class Semigroupoid a where
65− (<<<) :: forall b c d. a c d -> a b c -> a b d
66−
67− instance semigroupoidArr :: Semigroupoid (->) where
68− (<<<) f g x = f (g x)
69−
70− (>>>) :: forall a b c d. (Semigroupoid a) => a b c -> a c d -> a b d
71− (>>>) f g = g <<< f
72−
73− class (Semigroupoid a) <= Category a where
74− id :: forall t. a t t
75−
76− instance categoryArr :: Category (->) where
77− id x = x
78−
79− infixr 0 $
80− infixl 0 #
81−
82− ($) :: forall a b. (a -> b) -> a -> b
83− ($) f x = f x
84−
85− (#) :: forall a b. a -> (a -> b) -> b
86− (#) x f = f x
87−
88− infixr 6 :
89−
90− (:) :: forall a. a -> [a] -> [a]
91− (:) = cons
92−
93− foreign import cons
94− """
95− function cons(e) {
96− return function(l) {
97− return [e].concat(l);
98− };
99− }
100− """ :: forall a. a -> [a] -> [a]
101−
102− class Show a where
103− show :: a -> String
104−
105− foreign import showStringImpl
106− """
107− function showStringImpl(s) {
108− return JSON.stringify(s);
109− }
110− """ :: String -> String
111−
112− instance showUnit :: Show Unit where
113− show (Unit {}) = "Unit {}"
114−
115− instance showString :: Show String where
116− show = showStringImpl
117−
118− instance showBoolean :: Show Boolean where
119− show true = "true"
120− show false = "false"
121−
122− foreign import showNumberImpl
123− """
124− function showNumberImpl(n) {
125− return n.toString();
126− }
127− """ :: Number -> String
128−
129− instance showNumber :: Show Number where
130− show = showNumberImpl
131−
132− foreign import showArrayImpl
133− """
134− function showArrayImpl(f) {
135− return function(xs) {
136− var ss = [];
137− for (var i = 0, l = xs.length; i < l; i++) {
138− ss[i] = f(xs[i]);
139− }
140− return '[' + ss.join(',') + ']';
141− };
142− }
143− """ :: forall a. (a -> String) -> [a] -> String
144−
145− instance showArray :: (Show a) => Show [a] where
146− show = showArrayImpl show
147−
148− infixl 4 <$>
149− infixl 1 <#>
150−
151− class Functor f where
152− (<$>) :: forall a b. (a -> b) -> f a -> f b
153−
154− (<#>) :: forall f a b. (Functor f) => f a -> (a -> b) -> f b
155− (<#>) fa f = f <$> fa
156−
157− void :: forall f a. (Functor f) => f a -> f Unit
158− void fa = const unit <$> fa
159−
160− infixl 4 <*>
161−
162− class (Functor f) <= Apply f where
163− (<*>) :: forall a b. f (a -> b) -> f a -> f b
164−
165− class (Apply f) <= Applicative f where
166− pure :: forall a. a -> f a
167−
168− liftA1 :: forall f a b. (Applicative f) => (a -> b) -> f a -> f b
169− liftA1 f a = pure f <*> a
170−
171− infixl 1 >>=
172−
173− class (Apply m) <= Bind m where
174− (>>=) :: forall a b. m a -> (a -> m b) -> m b
175−
176− class (Applicative m, Bind m) <= Monad m
177−
178− return :: forall m a. (Monad m) => a -> m a
179− return = pure
180−
181− liftM1 :: forall m a b. (Monad m) => (a -> b) -> m a -> m b
182− liftM1 f a = do
183− a' <- a
184− return (f a')
185−
186− ap :: forall m a b. (Monad m) => m (a -> b) -> m a -> m b
187− ap f a = do
188− f' <- f
189− a' <- a
190− return (f' a')
191−
192− instance functorArr :: Functor ((->) r) where
193− (<$>) = (<<<)
194−
195− instance applyArr :: Apply ((->) r) where
196− (<*>) f g x = f x (g x)
197−
198− instance applicativeArr :: Applicative ((->) r) where
199− pure = const
200−
201− instance bindArr :: Bind ((->) r) where
202− (>>=) m f x = f (m x) x
203−
204− instance monadArr :: Monad ((->) r)
205−
206− infixl 7 *
207− infixl 7 /
208− infixl 7 %
209−
210− infixl 6 -
211− infixl 6 +
212−
213− -- | Addition and multiplication
214− class Semiring a where
215− (+) :: a -> a -> a
216− zero :: a
217− (*) :: a -> a -> a
218− one :: a
219−
220− -- | Semiring with modulo operation and division where
221− -- | ```a / b * b + (a `mod` b) = a```
222− class (Semiring a) <= ModuloSemiring a where
223− (/) :: a -> a -> a
224− mod :: a -> a -> a
225−
226− -- | Addition, multiplication, and subtraction
227− class (Semiring a) <= Ring a where
228− (-) :: a -> a -> a
229−
230− negate :: forall a. (Ring a) => a -> a
231− negate a = zero - a
232−
233− -- | Ring where every nonzero element has a multiplicative inverse (possibly
234− -- | a non-commutative field) so that ```a `mod` b = zero```
235− class (Ring a, ModuloSemiring a) <= DivisionRing a
236−
237− -- | A commutative field
238− class (DivisionRing a) <= Num a
239−
240− foreign import numAdd
241− """
242− function numAdd(n1) {
243− return function(n2) {
244− return n1 + n2;
245− };
246− }
247− """ :: Number -> Number -> Number
248−
249− foreign import numSub
250− """
251− function numSub(n1) {
252− return function(n2) {
253− return n1 - n2;
254− };
255− }
256− """ :: Number -> Number -> Number
257−
258− foreign import numMul
259− """
260− function numMul(n1) {
261− return function(n2) {
262− return n1 * n2;
263− };
264− }
265− """ :: Number -> Number -> Number
266−
267− foreign import numDiv
268− """
269− function numDiv(n1) {
270− return function(n2) {
271− return n1 / n2;
272− };
273− }
274− """ :: Number -> Number -> Number
275−
276− foreign import numMod
277− """
278− function numMod(n1) {
279− return function(n2) {
280− return n1 % n2;
281− };
282− }
283− """ :: Number -> Number -> Number
284−
285− (%) = numMod
286−
287− instance semiringNumber :: Semiring Number where
288− (+) = numAdd
289− zero = 0
290− (*) = numMul
291− one = 1
292−
293− instance ringNumber :: Ring Number where
294− (-) = numSub
295−
296− instance moduloSemiringNumber :: ModuloSemiring Number where
297− (/) = numDiv
298− mod _ _ = 0
299−
300− instance divisionRingNumber :: DivisionRing Number
301−
302− instance numNumber :: Num Number
303−
304− newtype Unit = Unit {}
305−
306− unit :: Unit
307− unit = Unit {}
308−
309− infix 4 ==
310− infix 4 /=
311−
312− class Eq a where
313− (==) :: a -> a -> Boolean
314− (/=) :: a -> a -> Boolean
315−
316− foreign import refEq
317− """
318− function refEq(r1) {
319− return function(r2) {
320− return r1 === r2;
321− };
322− }
323− """ :: forall a. a -> a -> Boolean
324−
325− foreign import refIneq
326− """
327− function refIneq(r1) {
328− return function(r2) {
329− return r1 !== r2;
330− };
331− }
332− """ :: forall a. a -> a -> Boolean
333−
334− instance eqUnit :: Eq Unit where
335− (==) (Unit {}) (Unit {}) = true
336− (/=) (Unit {}) (Unit {}) = false
337−
338− instance eqString :: Eq String where
339− (==) = refEq
340− (/=) = refIneq
341−
342− instance eqNumber :: Eq Number where
343− (==) = refEq
344− (/=) = refIneq
345−
346− instance eqBoolean :: Eq Boolean where
347− (==) = refEq
348− (/=) = refIneq
349−
350− foreign import eqArrayImpl
351− """
352− function eqArrayImpl(f) {
353− return function(xs) {
354− return function(ys) {
355− if (xs.length !== ys.length) return false;
356− for (var i = 0; i < xs.length; i++) {
357− if (!f(xs[i])(ys[i])) return false;
358− }
359− return true;
360− };
361− };
362− }
363− """ :: forall a. (a -> a -> Boolean) -> [a] -> [a] -> Boolean
364−
365− instance eqArray :: (Eq a) => Eq [a] where
366− (==) xs ys = eqArrayImpl (==) xs ys
367− (/=) xs ys = not (xs == ys)
368−
369− data Ordering = LT | GT | EQ
370−
371− instance eqOrdering :: Eq Ordering where
372− (==) LT LT = true
373− (==) GT GT = true
374− (==) EQ EQ = true
375− (==) _ _ = false
376− (/=) x y = not (x == y)
377−
378− instance showOrdering :: Show Ordering where
379− show LT = "LT"
380− show GT = "GT"
381− show EQ = "EQ"
382−
383− class (Eq a) <= Ord a where
384− compare :: a -> a -> Ordering
385−
386− infixl 4 <
387−
388− (<) :: forall a. (Ord a) => a -> a -> Boolean
389− (<) a1 a2 = case a1 `compare` a2 of
390− LT -> true
391− _ -> false
392−
393− infixl 4 >
394−
395− (>) :: forall a. (Ord a) => a -> a -> Boolean
396− (>) a1 a2 = case a1 `compare` a2 of
397− GT -> true
398− _ -> false
399−
400− infixl 4 <=
401−
402− (<=) :: forall a. (Ord a) => a -> a -> Boolean
403− (<=) a1 a2 = case a1 `compare` a2 of
404− GT -> false
405− _ -> true
406−
407− infixl 4 >=
408−
409− (>=) :: forall a. (Ord a) => a -> a -> Boolean
410− (>=) a1 a2 = case a1 `compare` a2 of
411− LT -> false
412− _ -> true
413−
414− foreign import unsafeCompareImpl
415− """
416− function unsafeCompareImpl(lt) {
417− return function(eq) {
418− return function(gt) {
419− return function(x) {
420− return function(y) {
421− return x < y ? lt : x > y ? gt : eq;
422− };
423− };
424− };
425− };
426− }
427− """ :: forall a. Ordering -> Ordering -> Ordering -> a -> a -> Ordering
428−
429− unsafeCompare :: forall a. a -> a -> Ordering
430− unsafeCompare = unsafeCompareImpl LT EQ GT
431−
432− instance ordUnit :: Ord Unit where
433− compare (Unit {}) (Unit {}) = EQ
434−
435− instance ordBoolean :: Ord Boolean where
436− compare false false = EQ
437− compare false true = LT
438− compare true true = EQ
439− compare true false = GT
440−
441− instance ordNumber :: Ord Number where
442− compare = unsafeCompare
443−
444− instance ordString :: Ord String where
445− compare = unsafeCompare
446−
447− instance ordArray :: (Ord a) => Ord [a] where
448− compare [] [] = EQ
449− compare [] _ = LT
450− compare _ [] = GT
451− compare (x:xs) (y:ys) = case compare x y of
452− EQ -> compare xs ys
453− other -> other
454−
455− infixl 10 .&.
456− infixl 10 .|.
457− infixl 10 .^.
458−
459− class Bits b where
460− (.&.) :: b -> b -> b
461− (.|.) :: b -> b -> b
462− (.^.) :: b -> b -> b
463− shl :: b -> Number -> b
464− shr :: b -> Number -> b
465− zshr :: b -> Number -> b
466− complement :: b -> b
467−
468− foreign import numShl
469− """
470− function numShl(n1) {
471− return function(n2) {
472− return n1 << n2;
473− };
474− }
475− """ :: Number -> Number -> Number
476−
477− foreign import numShr
478− """
479− function numShr(n1) {
480− return function(n2) {
481− return n1 >> n2;
482− };
483− }
484− """ :: Number -> Number -> Number
485−
486− foreign import numZshr
487− """
488− function numZshr(n1) {
489− return function(n2) {
490− return n1 >>> n2;
491− };
492− }
493− """ :: Number -> Number -> Number
494−
495− foreign import numAnd
496− """
497− function numAnd(n1) {
498− return function(n2) {
499− return n1 & n2;
500− };
501− }
502− """ :: Number -> Number -> Number
503−
504− foreign import numOr
505− """
506− function numOr(n1) {
507− return function(n2) {
508− return n1 | n2;
509− };
510− }
511− """ :: Number -> Number -> Number
512−
513− foreign import numXor
514− """
515− function numXor(n1) {
516− return function(n2) {
517− return n1 ^ n2;
518− };
519− }
520− """ :: Number -> Number -> Number
521−
522− foreign import numComplement
523− """
524− function numComplement(n) {
525− return ~n;
526− }
527− """ :: Number -> Number
528−
529− instance bitsNumber :: Bits Number where
530− (.&.) = numAnd
531− (.|.) = numOr
532− (.^.) = numXor
533− shl = numShl
534− shr = numShr
535− zshr = numZshr
536− complement = numComplement
537−
538− infixr 2 ||
539− infixr 3 &&
540−
541− class BoolLike b where
542− (&&) :: b -> b -> b
543− (||) :: b -> b -> b
544− not :: b -> b
545−
546− foreign import boolAnd
547− """
548− function boolAnd(b1) {
549− return function(b2) {
550− return b1 && b2;
551− };
552− }
553− """ :: Boolean -> Boolean -> Boolean
554−
555− foreign import boolOr
556− """
557− function boolOr(b1) {
558− return function(b2) {
559− return b1 || b2;
560− };
561− }
562− """ :: Boolean -> Boolean -> Boolean
563−
564− foreign import boolNot
565− """
566− function boolNot(b) {
567− return !b;
568− }
569− """ :: Boolean -> Boolean
570−
571− instance boolLikeBoolean :: BoolLike Boolean where
572− (&&) = boolAnd
573− (||) = boolOr
574− not = boolNot
575−
576− infixr 5 <>
577−
578− class Semigroup a where
579− (<>) :: a -> a -> a
580−
581− foreign import concatString
582− """
583− function concatString(s1) {
584− return function(s2) {
585− return s1 + s2;
586− };
587− }
588− """ :: String -> String -> String
589−
590− instance semigroupUnit :: Semigroup Unit where
591− (<>) (Unit {}) (Unit {}) = Unit {}
592−
593− instance semigroupString :: Semigroup String where
594− (<>) = concatString
595−
596− instance semigroupArr :: (Semigroup s') => Semigroup (s -> s') where
597− (<>) f g = \x -> f x <> g x
598−
599− infixr 5 ++
600−
601− (++) :: forall s. (Semigroup s) => s -> s -> s
602− (++) = (<>)
603−
604−module Data.Function where
605−
606− on :: forall a b c. (b -> b -> c) -> (a -> b) -> a -> a -> c
607− on f g x y = g x `f` g y
608−
609− foreign import data Fn0 :: * -> *
610− foreign import data Fn1 :: * -> * -> *
611− foreign import data Fn2 :: * -> * -> * -> *
612− foreign import data Fn3 :: * -> * -> * -> * -> *
613− foreign import data Fn4 :: * -> * -> * -> * -> * -> *
614− foreign import data Fn5 :: * -> * -> * -> * -> * -> * -> *
615− foreign import data Fn6 :: * -> * -> * -> * -> * -> * -> * -> *
616− foreign import data Fn7 :: * -> * -> * -> * -> * -> * -> * -> * -> *
617− foreign import data Fn8 :: * -> * -> * -> * -> * -> * -> * -> * -> * -> *
618− foreign import data Fn9 :: * -> * -> * -> * -> * -> * -> * -> * -> * -> * -> *
619− foreign import data Fn10 :: * -> * -> * -> * -> * -> * -> * -> * -> * -> * -> * -> *
620−
621− foreign import mkFn0
622− """
623− function mkFn0(fn) {
624− return function() {
625− return fn({});
626− };
627− }
628− """ :: forall a. (Unit -> a) -> Fn0 a
629−
630− foreign import mkFn1
631− """
632− function mkFn1(fn) {
633− return function(a) {
634− return fn(a);
635− };
636− }
637− """ :: forall a b. (a -> b) -> Fn1 a b
638−
639− foreign import mkFn2
640− """
641− function mkFn2(fn) {
642− return function(a, b) {
643− return fn(a)(b);
644− };
645− }
646− """ :: forall a b c. (a -> b -> c) -> Fn2 a b c
647−
648− foreign import mkFn3
649− """
650− function mkFn3(fn) {
651− return function(a, b, c) {
652− return fn(a)(b)(c);
653− };
654− }
655− """ :: forall a b c d. (a -> b -> c -> d) -> Fn3 a b c d
656−
657− foreign import mkFn4
658− """
659− function mkFn4(fn) {
660− return function(a, b, c, d) {
661− return fn(a)(b)(c)(d);
662− };
663− }
664− """ :: forall a b c d e. (a -> b -> c -> d -> e) -> Fn4 a b c d e
665−
666− foreign import mkFn5
667− """
668− function mkFn5(fn) {
669− return function(a, b, c, d, e) {
670− return fn(a)(b)(c)(d)(e);
671− };
672− }
673− """ :: forall a b c d e f. (a -> b -> c -> d -> e -> f) -> Fn5 a b c d e f
674−
675− foreign import mkFn6
676− """
677− function mkFn6(fn) {
678− return function(a, b, c, d, e, f) {
679− return fn(a)(b)(c)(d)(e)(f);
680− };
681− }
682− """ :: forall a b c d e f g. (a -> b -> c -> d -> e -> f -> g) -> Fn6 a b c d e f g
683−
684− foreign import mkFn7
685− """
686− function mkFn7(fn) {
687− return function(a, b, c, d, e, f, g) {
688− return fn(a)(b)(c)(d)(e)(f)(g);
689− };
690− }
691− """ :: forall a b c d e f g h. (a -> b -> c -> d -> e -> f -> g -> h) -> Fn7 a b c d e f g h
692−
693− foreign import mkFn8
694− """
695− function mkFn8(fn) {
696− return function(a, b, c, d, e, f, g, h) {
697− return fn(a)(b)(c)(d)(e)(f)(g)(h);
698− };
699− }
700− """ :: forall a b c d e f g h i. (a -> b -> c -> d -> e -> f -> g -> h -> i) -> Fn8 a b c d e f g h i
701−
702− foreign import mkFn9
703− """
704− function mkFn9(fn) {
705− return function(a, b, c, d, e, f, g, h, i) {
706− return fn(a)(b)(c)(d)(e)(f)(g)(h)(i);
707− };
708− }
709− """ :: forall a b c d e f g h i j. (a -> b -> c -> d -> e -> f -> g -> h -> i -> j) -> Fn9 a b c d e f g h i j
710−
711− foreign import mkFn10
712− """
713− function mkFn10(fn) {
714− return function(a, b, c, d, e, f, g, h, i, j) {
715− return fn(a)(b)(c)(d)(e)(f)(g)(h)(i)(j);
716− };
717− }
718− """ :: forall a b c d e f g h i j k. (a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k) -> Fn10 a b c d e f g h i j k
719−
720− foreign import runFn0
721− """
722− function runFn0(fn) {
723− return fn();
724− }
725− """ :: forall a. Fn0 a -> a
726−
727− foreign import runFn1
728− """
729− function runFn1(fn) {
730− return function(a) {
731− return fn(a);
732− };
733− }
734− """ :: forall a b. Fn1 a b -> a -> b
735−
736− foreign import runFn2
737− """
738− function runFn2(fn) {
739− return function(a) {
740− return function(b) {
741− return fn(a, b);
742− };
743− };
744− }
745− """ :: forall a b c. Fn2 a b c -> a -> b -> c
746−
747− foreign import runFn3
748− """
749− function runFn3(fn) {
750− return function(a) {
751− return function(b) {
752− return function(c) {
753− return fn(a, b, c);
754− };
755− };
756− };
757− }
758− """ :: forall a b c d. Fn3 a b c d -> a -> b -> c -> d
759−
760− foreign import runFn4
761− """
762− function runFn4(fn) {
763− return function(a) {
764− return function(b) {
765− return function(c) {
766− return function(d) {
767− return fn(a, b, c, d);
768− };
769− };
770− };
771− };
772− }
773− """ :: forall a b c d e. Fn4 a b c d e -> a -> b -> c -> d -> e
774−
775− foreign import runFn5
776− """
777− function runFn5(fn) {
778− return function(a) {
779− return function(b) {
780− return function(c) {
781− return function(d) {
782− return function(e) {
783− return fn(a, b, c, d, e);
784− };
785− };
786− };
787− };
788− };
789− }
790− """ :: forall a b c d e f. Fn5 a b c d e f -> a -> b -> c -> d -> e -> f
791−
792− foreign import runFn6
793− """
794− function runFn6(fn) {
795− return function(a) {
796− return function(b) {
797− return function(c) {
798− return function(d) {
799− return function(e) {
800− return function(f) {
801− return fn(a, b, c, d, e, f);
802− };
803− };
804− };
805− };
806− };
807− };
808− }
809− """ :: forall a b c d e f g. Fn6 a b c d e f g -> a -> b -> c -> d -> e -> f -> g
810−
811− foreign import runFn7
812− """
813− function runFn7(fn) {
814− return function(a) {
815− return function(b) {
816− return function(c) {
817− return function(d) {
818− return function(e) {
819− return function(f) {
820− return function(g) {
821− return fn(a, b, c, d, e, f, g);
822− };
823− };
824− };
825− };
826− };
827− };
828− };
829− }
830− """ :: forall a b c d e f g h. Fn7 a b c d e f g h -> a -> b -> c -> d -> e -> f -> g -> h
831−
832− foreign import runFn8
833− """
834− function runFn8(fn) {
835− return function(a) {
836− return function(b) {
837− return function(c) {
838− return function(d) {
839− return function(e) {
840− return function(f) {
841− return function(g) {
842− return function(h) {
843− return fn(a, b, c, d, e, f, g, h);
844− };
845− };
846− };
847− };
848− };
849− };
850− };
851− };
852− }
853− """ :: forall a b c d e f g h i. Fn8 a b c d e f g h i -> a -> b -> c -> d -> e -> f -> g -> h -> i
854−
855− foreign import runFn9
856− """
857− function runFn9(fn) {
858− return function(a) {
859− return function(b) {
860− return function(c) {
861− return function(d) {
862− return function(e) {
863− return function(f) {
864− return function(g) {
865− return function(h) {
866− return function(i) {
867− return fn(a, b, c, d, e, f, g, h, i);
868− };
869− };
870− };
871− };
872− };
873− };
874− };
875− };
876− };
877− }
878− """ :: forall a b c d e f g h i j. Fn9 a b c d e f g h i j -> a -> b -> c -> d -> e -> f -> g -> h -> i -> j
879−
880− foreign import runFn10
881− """
882− function runFn10(fn) {
883− return function(a) {
884− return function(b) {
885− return function(c) {
886− return function(d) {
887− return function(e) {
888− return function(f) {
889− return function(g) {
890− return function(h) {
891− return function(i) {
892− return function(j) {
893− return fn(a, b, c, d, e, f, g, h, i, j);
894− };
895− };
896− };
897− };
898− };
899− };
900− };
901− };
902− };
903− };
904− }
905− """ :: forall a b c d e f g h i j k. Fn10 a b c d e f g h i j k -> a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k
906−
907−module Prelude.Unsafe where
908−
909− foreign import unsafeIndex
910− """
911− function unsafeIndex(xs) {
912− return function(n) {
913− return xs[n];
914− };
915− }
916− """ :: forall a. [a] -> Number -> a
917−
918−module Control.Monad.Eff where
919−
920− foreign import data Eff :: # ! -> * -> *
921−
922− foreign import returnE
923− """
924− function returnE(a) {
925− return function() {
926− return a;
927− };
928− }
929− """ :: forall e a. a -> Eff e a
930−
931− foreign import bindE
932− """
933− function bindE(a) {
934− return function(f) {
935− return function() {
936− return f(a())();
937− };
938− };
939− }
940− """ :: forall e a b. Eff e a -> (a -> Eff e b) -> Eff e b
941−
942− type Pure a = forall e. Eff e a
943−
944− foreign import runPure
945− """
946− function runPure(f) {
947− return f();
948− }
949− """ :: forall a. Pure a -> a
950−
951− instance functorEff :: Functor (Eff e) where
952− (<$>) = liftA1
953−
954− instance applyEff :: Apply (Eff e) where
955− (<*>) = ap
956−
957− instance applicativeEff :: Applicative (Eff e) where
958− pure = returnE
959−
960− instance bindEff :: Bind (Eff e) where
961− (>>=) = bindE
962−
963− instance monadEff :: Monad (Eff e)
964−
965− foreign import untilE
966− """
967− function untilE(f) {
968− return function() {
969− while (!f());
970− return {};
971− };
972− }
973− """ :: forall e. Eff e Boolean -> Eff e Unit
974−
975− foreign import whileE
976− """
977− function whileE(f) {
978− return function(a) {
979− return function() {
980− while (f()) {
981− a();
982− }
983− return {};
984− };
985− };
986− }
987− """ :: forall e a. Eff e Boolean -> Eff e a -> Eff e Unit
988−
989− foreign import forE
990− """
991− function forE(lo) {
992− return function(hi) {
993− return function(f) {
994− return function() {
995− for (var i = lo; i < hi; i++) {
996− f(i)();
997− }
998− };
999− };
1000− };
1001− }
1002− """ :: forall e. Number -> Number -> (Number -> Eff e Unit) -> Eff e Unit
1003−
1004−
1005− foreign import foreachE
1006− """
1007− function foreachE(as) {
1008− return function(f) {
1009− return function() {
1010− for (var i = 0; i < as.length; i++) {
1011− f(as[i])();
1012− }
1013− };
1014− };
1015− }
1016− """ :: forall e a. [a] -> (a -> Eff e Unit) -> Eff e Unit
1017−
1018−module Control.Monad.Eff.Unsafe where
1019−
1020− import Control.Monad.Eff
1021−
1022− foreign import unsafeInterleaveEff
1023− """
1024− function unsafeInterleaveEff(f) {
1025− return f;
1026− }
1027− """ :: forall eff1 eff2 a. Eff eff1 a -> Eff eff2 a
1028−
1029−module Debug.Trace where
1030−
1031− import Control.Monad.Eff
1032−
1033− foreign import data Trace :: !
1034−
1035− foreign import trace
1036− """
1037− function trace(s) {
1038− return function() {
1039− console.log(s);
1040− return {};
1041− };
1042− }
1043− """ :: forall r. String -> Eff (trace :: Trace | r) Unit
1044−
1045− print :: forall a r. (Show a) => a -> Eff (trace :: Trace | r) Unit
1046− print o = trace (show o)
1047−
1048−module Control.Monad.ST where
1049−
1050− import Control.Monad.Eff
1051−
1052− foreign import data ST :: * -> !
1053−
1054− foreign import data STRef :: * -> * -> *
1055−
1056− foreign import newSTRef
1057− """
1058− function newSTRef(val) {
1059− return function() {
1060− return { value: val };
1061− };
1062− }
1063− """ :: forall a h r. a -> Eff (st :: ST h | r) (STRef h a)
1064−
1065− foreign import readSTRef
1066− """
1067− function readSTRef(ref) {
1068− return function() {
1069− return ref.value;
1070− };
1071− }
1072− """ :: forall a h r. STRef h a -> Eff (st :: ST h | r) a
1073−
1074− foreign import modifySTRef
1075− """
1076− function modifySTRef(ref) {
1077− return function(f) {
1078− return function() {
1079− return ref.value = f(ref.value);
1080− };
1081− };
1082− }
1083− """ :: forall a h r. STRef h a -> (a -> a) -> Eff (st :: ST h | r) a
1084−
1085− foreign import writeSTRef
1086− """
1087− function writeSTRef(ref) {
1088− return function(a) {
1089− return function() {
1090− return ref.value = a;
1091− };
1092− };
1093− }
1094− """ :: forall a h r. STRef h a -> a -> Eff (st :: ST h | r) a
1095−
1096− foreign import runST
1097− """
1098− function runST(f) {
1099− return f;
1100− }
1101− """ :: forall a r. (forall h. Eff (st :: ST h | r) a) -> Eff r a
1102−
1103− pureST :: forall a. (forall h r. Eff (st :: ST h | r) a) -> a
1104− pureST st = runPure (runST st)
prelude/updateDocs.shdeleted−11
@@ -1,11 +0,0 @@
1−../dist/build/psc-docs/psc-docs --hierarchy-images prelude.purs > README.md
2−../dist/build/psc-hierarchy/psc-hierarchy prelude.purs -o prelude
3−
4−mkdir -p images
5−
6−for f in prelude/*; do
7− BASE=$(basename "$f")
8− dot -Tpng -o images/"$BASE".png "$f"
9−done
10−
11−rm -r prelude
psc-docs/Main.hsdeleted−272
@@ -1,272 +0,0 @@
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−module Main where
16−
17−import Control.Applicative
18−import Control.Monad
19−import Control.Monad.Writer
20−import Control.Arrow (first)
21−import Data.Function (on)
22−import Data.List
23−import Data.Maybe (fromMaybe)
24−import Data.Version (showVersion)
25−import Data.Foldable (traverse_)
26−
27−import Options.Applicative
28−
29−import qualified Language.PureScript as P
30−import qualified Paths_purescript as Paths
31−import System.Exit (exitSuccess, exitFailure)
32−import System.IO (hPutStrLn, stderr)
33−
34−data PSCDocsOptions = PSCDocsOptions
35− { pscdIncludeHeir :: Bool
36− , pscdInputFiles :: [FilePath]
37− }
38−
39−docgen :: PSCDocsOptions -> IO ()
40−docgen (PSCDocsOptions showHierarchy input) = do
41− e <- P.parseModulesFromFiles (fromMaybe "") <$> mapM (fmap (first Just) . parseFile) (nub input)
42− case e of
43− Left err -> do
44− hPutStrLn stderr $ show err
45− exitFailure
46− Right ms -> do
47− putStrLn . runDocs $ (renderModules showHierarchy) (map snd ms)
48− exitSuccess
49−
50−parseFile :: FilePath -> IO (FilePath, String)
51−parseFile input = (,) input <$> readFile input
52−
53−type Docs = Writer [String] ()
54−
55−runDocs :: Docs -> String
56−runDocs = unlines . execWriter
57−
58−spacer :: Docs
59−spacer = tell [""]
60−
61−headerLevel :: Int -> String -> Docs
62−headerLevel level hdr = tell [replicate level '#' ++ ' ' : hdr]
63−
64−withIndent :: Int -> Docs -> Docs
65−withIndent indent = censor (map (replicate indent ' ' ++ ))
66−
67−atIndent :: Int -> String -> Docs
68−atIndent indent text =
69− let ls = lines text in
70− withIndent indent (tell ls)
71−
72−ticks :: String -> String
73−ticks = ("`" ++) . (++ "`")
74−
75−renderModules :: Bool -> [P.Module] -> Docs
76−renderModules showHierarchy ms = do
77− headerLevel 1 "Module Documentation"
78− spacer
79− mapM_ (renderModule showHierarchy) ms
80−
81−renderModule :: Bool -> P.Module -> Docs
82−renderModule showHierarchy mdl@(P.Module moduleName _ exps) =
83− let ds = P.exportedDeclarations mdl
84− hasTypes = any isTypeDeclaration ds
85− hasTypeclasses = any isTypeClassDeclaration ds
86− hasTypeclassInstances = any isTypeInstanceDeclaration ds
87− hasValues = any isValueDeclaration ds
88− in do
89− headerLevel 2 $ "Module " ++ P.runModuleName moduleName
90− spacer
91− when hasTypes $ do
92− headerLevel 3 "Types"
93− spacer
94− renderTopLevel exps (filter isTypeDeclaration ds)
95− spacer
96− when hasTypeclasses $ do
97− headerLevel 3 "Type Classes"
98− spacer
99− when showHierarchy $ do
100− renderTypeclassImage moduleName
101− spacer
102− renderTopLevel exps (filter isTypeClassDeclaration ds)
103− spacer
104− when hasTypeclassInstances $ do
105− headerLevel 3 "Type Class Instances"
106− spacer
107− renderTopLevel exps (filter isTypeInstanceDeclaration ds)
108− spacer
109− when hasValues $ do
110− headerLevel 3 "Values"
111− spacer
112− renderTopLevel exps (filter isValueDeclaration ds)
113− spacer
114−
115−renderTopLevel :: Maybe [P.DeclarationRef] -> [P.Declaration] -> Docs
116−renderTopLevel exps decls = forM_ (sortBy (compare `on` getName) decls) $ \decl -> do
117− traverse_ (headerLevel 4) (ticks `fmap` getDeclarationTitle decl)
118− spacer
119− renderDeclaration exps decl
120− spacer
121−
122−renderTypeclassImage :: P.ModuleName -> Docs
123−renderTypeclassImage name =
124− let name' = P.runModuleName name
125− in tell ["![" ++ name' ++ "](images/" ++ name' ++ ".png)"]
126−
127−getDeclarationTitle :: P.Declaration -> Maybe String
128−getDeclarationTitle (P.TypeDeclaration name _) = Just (show name)
129−getDeclarationTitle (P.ExternDeclaration _ name _ _) = Just (show name)
130−getDeclarationTitle (P.DataDeclaration _ name _ _) = Just (show name)
131−getDeclarationTitle (P.ExternDataDeclaration name _) = Just (show name)
132−getDeclarationTitle (P.TypeSynonymDeclaration name _ _) = Just (show name)
133−getDeclarationTitle (P.TypeClassDeclaration name _ _ _) = Just (show name)
134−getDeclarationTitle (P.TypeInstanceDeclaration name _ _ _ _) = Just (show name)
135−getDeclarationTitle (P.PositionedDeclaration _ _ d) = getDeclarationTitle d
136−getDeclarationTitle _ = Nothing
137−
138−renderDeclaration :: Maybe [P.DeclarationRef] -> P.Declaration -> Docs
139−renderDeclaration _ (P.TypeDeclaration ident ty) =
140− atIndent 4 $ show ident ++ " :: " ++ prettyPrintType' ty
141−renderDeclaration _ (P.ExternDeclaration _ ident _ ty) =
142− atIndent 4 $ show ident ++ " :: " ++ prettyPrintType' ty
143−renderDeclaration exps (P.DataDeclaration dtype name args ctors) = do
144− let
145− typeApp = foldl P.TypeApp (P.TypeConstructor (P.Qualified Nothing name)) (map toTypeVar args)
146− typeName = prettyPrintType' typeApp
147− exported = filter (P.isDctorExported name exps . fst) ctors
148− atIndent 4 $ show dtype ++ " " ++ typeName
149− zipWithM_ (\isFirst (ctor, tys) ->
150− atIndent 6 $ (if isFirst then "= " else "| ") ++ P.runProperName ctor ++ " " ++ unwords (map P.prettyPrintTypeAtom tys))
151− (True : repeat False) exported
152−renderDeclaration _ (P.ExternDataDeclaration name kind) =
153− atIndent 4 $ "data " ++ P.runProperName name ++ " :: " ++ P.prettyPrintKind kind
154−renderDeclaration _ (P.TypeSynonymDeclaration name args ty) = do
155− let
156− typeApp = foldl P.TypeApp (P.TypeConstructor (P.Qualified Nothing name)) (map toTypeVar args)
157− typeName = prettyPrintType' typeApp
158− atIndent 4 $ "type " ++ typeName ++ " = " ++ prettyPrintType' ty
159−renderDeclaration _ (P.TypeClassDeclaration name args implies ds) = do
160− let impliesText = case implies of
161− [] -> ""
162− is -> "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map P.prettyPrintTypeAtom tys')) is) ++ ") <= "
163− classApp = foldl P.TypeApp (P.TypeConstructor (P.Qualified Nothing name)) (map toTypeVar args)
164− className = prettyPrintType' classApp
165− atIndent 4 $ "class " ++ impliesText ++ className ++ " where"
166− mapM_ renderClassMember ds
167− where
168− renderClassMember (P.PositionedDeclaration _ _ d) = renderClassMember d
169− renderClassMember (P.TypeDeclaration ident ty) = atIndent 6 $ show ident ++ " :: " ++ prettyPrintType' ty
170− renderClassMember _ = error "Invalid argument to renderClassMember."
171−renderDeclaration _ (P.TypeInstanceDeclaration name constraints className tys _) = do
172− let constraintsText = case constraints of
173− [] -> ""
174− cs -> "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map P.prettyPrintTypeAtom tys')) cs) ++ ") => "
175− atIndent 4 $ "instance " ++ show name ++ " :: " ++ constraintsText ++ show className ++ " " ++ unwords (map P.prettyPrintTypeAtom tys)
176−renderDeclaration exps (P.PositionedDeclaration _ com d) = do
177− renderComments com
178− renderDeclaration exps d
179−renderDeclaration _ _ = return ()
180−
181−renderComments :: [P.Comment] -> Docs
182−renderComments cs = do
183− let raw = concatMap toLines cs
184−
185− if all hasPipe raw
186− then atIndent 0 . unlines . map stripPipes $ raw
187− else atIndent 4 $ unlines raw
188−
189− unless (null raw) spacer
190− where
191−
192− toLines (P.LineComment s) = [s]
193− toLines (P.BlockComment s) = lines s
194−
195− hasPipe s = case dropWhile (== ' ') s of { ('|':_) -> True; _ -> False }
196−
197− stripPipes = dropPipe . dropWhile (== ' ')
198−
199− dropPipe ('|':' ':s) = s
200− dropPipe ('|':s) = s
201− dropPipe s = s
202−
203−toTypeVar :: (String, Maybe P.Kind) -> P.Type
204−toTypeVar (s, Nothing) = P.TypeVar s
205−toTypeVar (s, Just k) = P.KindedType (P.TypeVar s) k
206−
207−prettyPrintType' :: P.Type -> String
208−prettyPrintType' = P.prettyPrintType . P.everywhereOnTypes dePrim
209− where
210− dePrim ty@(P.TypeConstructor (P.Qualified _ name))
211− | ty == P.tyBoolean || ty == P.tyNumber || ty == P.tyString =
212− P.TypeConstructor $ P.Qualified Nothing name
213− dePrim other = other
214−
215−getName :: P.Declaration -> String
216−getName (P.TypeDeclaration ident _) = show ident
217−getName (P.ExternDeclaration _ ident _ _) = show ident
218−getName (P.DataDeclaration _ name _ _) = P.runProperName name
219−getName (P.ExternDataDeclaration name _) = P.runProperName name
220−getName (P.TypeSynonymDeclaration name _ _) = P.runProperName name
221−getName (P.TypeClassDeclaration name _ _ _) = P.runProperName name
222−getName (P.TypeInstanceDeclaration name _ _ _ _) = show name
223−getName (P.PositionedDeclaration _ _ d) = getName d
224−getName _ = error "Invalid argument to getName"
225−
226−isValueDeclaration :: P.Declaration -> Bool
227−isValueDeclaration P.TypeDeclaration{} = True
228−isValueDeclaration P.ExternDeclaration{} = True
229−isValueDeclaration (P.PositionedDeclaration _ _ d) = isValueDeclaration d
230−isValueDeclaration _ = False
231−
232−isTypeDeclaration :: P.Declaration -> Bool
233−isTypeDeclaration P.DataDeclaration{} = True
234−isTypeDeclaration P.ExternDataDeclaration{} = True
235−isTypeDeclaration P.TypeSynonymDeclaration{} = True
236−isTypeDeclaration (P.PositionedDeclaration _ _ d) = isTypeDeclaration d
237−isTypeDeclaration _ = False
238−
239−isTypeClassDeclaration :: P.Declaration -> Bool
240−isTypeClassDeclaration P.TypeClassDeclaration{} = True
241−isTypeClassDeclaration (P.PositionedDeclaration _ _ d) = isTypeClassDeclaration d
242−isTypeClassDeclaration _ = False
243−
244−isTypeInstanceDeclaration :: P.Declaration -> Bool
245−isTypeInstanceDeclaration P.TypeInstanceDeclaration{} = True
246−isTypeInstanceDeclaration (P.PositionedDeclaration _ _ d) = isTypeInstanceDeclaration d
247−isTypeInstanceDeclaration _ = False
248−
249−inputFile :: Parser FilePath
250−inputFile = strArgument $
251− metavar "FILE"
252− <> help "The input .purs file(s)"
253−
254−includeHeirarcy :: Parser Bool
255−includeHeirarcy = switch $
256− long "hierarchy-images"
257− <> help "Include markdown for type class hierarchy images in the output."
258−
259−pscDocsOptions :: Parser PSCDocsOptions
260−pscDocsOptions = PSCDocsOptions <$> includeHeirarcy
261− <*> many inputFile
262−
263−main :: IO ()
264−main = execParser opts >>= docgen
265− where
266− opts = info (version <*> helper <*> pscDocsOptions) infoModList
267− infoModList = fullDesc <> headerInfo <> footerInfo
268− headerInfo = header "psc-docs - Generate Markdown documentation from PureScript extern files"
269− footerInfo = footer $ "psc-docs " ++ showVersion Paths.version
270−
271− version :: Parser (a -> a)
272− version = abortOption (InfoMsg (showVersion Paths.version)) $ long "version" <> help "Show the version number" <> hidden
psc-make/Main.hsdeleted−177
@@ -1,177 +0,0 @@
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, GeneralizedNewtypeDeriving, TupleSections, RecordWildCards #-}
16−
17−module Main where
18−
19−import Control.Applicative
20−import Control.Monad.Error
21−import Control.Monad.Reader
22−
23−import Data.Version (showVersion)
24−import Data.Traversable (traverse)
25−
26−import Options.Applicative as Opts
27−
28−import System.Directory
29− (doesFileExist, getModificationTime, createDirectoryIfMissing)
30−import System.FilePath (takeDirectory)
31−import System.Exit (exitSuccess, exitFailure)
32−import System.IO.Error (tryIOError)
33−
34−import qualified Language.PureScript as P
35−import qualified Paths_purescript as Paths
36−
37−
38−data PSCMakeOptions = PSCMakeOptions
39− { pscmInput :: [FilePath]
40− , pscmOutputDir :: FilePath
41− , pscmOpts :: P.Options P.Make
42− , pscmUsePrefix :: Bool
43− }
44−
45−data InputOptions = InputOptions
46− { ioNoPrelude :: Bool
47− , ioInputFiles :: [FilePath]
48− }
49−
50−readInput :: InputOptions -> IO [(Either P.RebuildPolicy FilePath, String)]
51−readInput InputOptions{..} = do
52− content <- forM ioInputFiles $ \inFile -> (Right inFile, ) <$> readFile inFile
53− return (if ioNoPrelude then content else (Left P.RebuildNever, P.prelude) : content)
54−
55−newtype Make a = Make { unMake :: ReaderT (P.Options P.Make) (ErrorT String IO) a }
56− deriving (Functor, Applicative, Monad, MonadIO, MonadError String, MonadReader (P.Options P.Make))
57−
58−runMake :: P.Options P.Make -> Make a -> IO (Either String a)
59−runMake opts = runErrorT . flip runReaderT opts . unMake
60−
61−makeIO :: IO a -> Make a
62−makeIO = Make . lift . ErrorT . fmap (either (Left . show) Right) . tryIOError
63−
64−instance P.MonadMake Make where
65− getTimestamp path = makeIO $ do
66− exists <- doesFileExist path
67− traverse (const $ getModificationTime path) $ guard exists
68− readTextFile path = makeIO $ do
69− putStrLn $ "Reading " ++ path
70− readFile path
71− writeTextFile path text = makeIO $ do
72− mkdirp path
73− putStrLn $ "Writing " ++ path
74− writeFile path text
75− progress = makeIO . putStrLn
76−
77−compile :: PSCMakeOptions -> IO ()
78−compile (PSCMakeOptions input outputDir opts usePrefix) = do
79− modules <- P.parseModulesFromFiles (either (const "") id) <$> readInput (InputOptions (P.optionsNoPrelude opts) input)
80− case modules of
81− Left err -> do
82− print err
83− exitFailure
84− Right ms -> do
85− e <- runMake opts $ P.make outputDir ms prefix
86− case e of
87− Left err -> do
88− putStrLn err
89− exitFailure
90− Right _ -> do
91− exitSuccess
92− where
93− prefix = if usePrefix
94− then ["Generated by psc-make version " ++ showVersion Paths.version]
95− else []
96−
97−mkdirp :: FilePath -> IO ()
98−mkdirp = createDirectoryIfMissing True . takeDirectory
99−
100−inputFile :: Parser FilePath
101−inputFile = strArgument $
102− metavar "FILE"
103− <> help "The input .purs file(s)"
104−
105−outputDirectory :: Parser FilePath
106−outputDirectory = strOption $
107− short 'o'
108− <> long "output"
109− <> Opts.value "output"
110− <> showDefault
111− <> help "The output directory"
112−
113−noTco :: Parser Bool
114−noTco = switch $
115− long "no-tco"
116− <> help "Disable tail call optimizations"
117−
118−noPrelude :: Parser Bool
119−noPrelude = switch $
120− long "no-prelude"
121− <> help "Omit the Prelude"
122−
123−noMagicDo :: Parser Bool
124−noMagicDo = switch $
125− long "no-magic-do"
126− <> help "Disable the optimization that overloads the do keyword to generate efficient code specifically for the Eff monad."
127−
128−noOpts :: Parser Bool
129−noOpts = switch $
130− long "no-opts"
131− <> help "Skip the optimization phase."
132−
133−comments :: Parser Bool
134−comments = switch $
135− short 'c'
136− <> long "comments"
137− <> help "Include comments in the generated code."
138−
139−verboseErrors :: Parser Bool
140−verboseErrors = switch $
141− short 'v'
142− <> long "verbose-errors"
143− <> help "Display verbose error messages"
144−
145−noPrefix :: Parser Bool
146−noPrefix = switch $
147− short 'p'
148− <> long "no-prefix"
149− <> help "Do not include comment header"
150−
151−
152−options :: Parser (P.Options P.Make)
153−options = P.Options <$> noPrelude
154− <*> noTco
155− <*> noMagicDo
156− <*> pure Nothing
157− <*> noOpts
158− <*> comments
159− <*> verboseErrors
160− <*> pure P.MakeOptions
161−
162−pscMakeOptions :: Parser PSCMakeOptions
163−pscMakeOptions = PSCMakeOptions <$> many inputFile
164− <*> outputDirectory
165− <*> options
166− <*> (not <$> noPrefix)
167−
168−main :: IO ()
169−main = execParser opts >>= compile
170− where
171− opts = info (version <*> helper <*> pscMakeOptions) infoModList
172− infoModList = fullDesc <> headerInfo <> footerInfo
173− headerInfo = header "psc-make - Compiles PureScript to Javascript"
174− footerInfo = footer $ "psc-make " ++ showVersion Paths.version
175−
176− version :: Parser (a -> a)
177− version = abortOption (InfoMsg (showVersion Paths.version)) $ long "version" <> help "Show the version number" <> hidden
psc/Main.hsdeleted−209
@@ -1,209 +0,0 @@
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, GeneralizedNewtypeDeriving, TupleSections, RecordWildCards #-}
16−
17−module Main where
18−
19−import Control.Applicative
20−import Control.Monad.Error
21−import Control.Monad.Reader
22−
23−import Data.Maybe (fromMaybe)
24−import Data.Version (showVersion)
25−
26−import Options.Applicative as Opts
27−import System.Directory (createDirectoryIfMissing)
28−import System.FilePath (takeDirectory)
29−import System.Exit (exitSuccess, exitFailure)
30−import System.IO (hPutStrLn, stderr)
31−
32−import qualified Language.PureScript as P
33−import qualified Paths_purescript as Paths
34−
35−
36−data PSCOptions = PSCOptions
37− { pscInput :: [FilePath]
38− , pscOpts :: P.Options P.Compile
39− , pscStdIn :: Bool
40− , pscOutput :: Maybe FilePath
41− , pscExterns :: Maybe FilePath
42− , pscUsePrefix :: Bool
43− }
44−
45−data InputOptions = InputOptions
46− { ioNoPrelude :: Bool
47− , ioUseStdIn :: Bool
48− , ioInputFiles :: [FilePath]
49− }
50−
51−readInput :: InputOptions -> IO [(Maybe FilePath, String)]
52−readInput InputOptions{..}
53− | ioUseStdIn = return . (Nothing ,) <$> getContents
54− | otherwise = do content <- forM ioInputFiles $ \inFile -> (Just inFile, ) <$> readFile inFile
55− return (if ioNoPrelude then content else (Nothing, P.prelude) : content)
56−
57−compile :: PSCOptions -> IO ()
58−compile (PSCOptions input opts stdin output externs usePrefix) = do
59− modules <- P.parseModulesFromFiles (fromMaybe "") <$> readInput (InputOptions (P.optionsNoPrelude opts) stdin input)
60− case modules of
61− Left err -> do
62− hPutStrLn stderr $ show err
63− exitFailure
64− Right ms -> do
65− case P.compile (map snd ms) prefix `runReaderT` opts of
66− Left err -> do
67− hPutStrLn stderr err
68− exitFailure
69− Right (js, exts, _) -> do
70− case output of
71− Just path -> mkdirp path >> writeFile path js
72− Nothing -> putStrLn js
73− case externs of
74− Just path -> mkdirp path >> writeFile path exts
75− Nothing -> return ()
76− exitSuccess
77− where
78− prefix = if usePrefix
79− then ["Generated by psc version " ++ showVersion Paths.version]
80− else []
81−
82−mkdirp :: FilePath -> IO ()
83−mkdirp = createDirectoryIfMissing True . takeDirectory
84−
85−codeGenModule :: Parser String
86−codeGenModule = strOption $
87− long "codegen"
88− <> help "A list of modules for which Javascript and externs should be generated. This argument can be used multiple times."
89−
90−dceModule :: Parser String
91−dceModule = strOption $
92− short 'm'
93− <> long "module"
94− <> 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."
95−
96−browserNamespace :: Parser String
97−browserNamespace = strOption $
98− long "browser-namespace"
99− <> Opts.value "PS"
100− <> showDefault
101− <> help "Specify the namespace that PureScript modules will be exported to when running in the browser."
102−
103−verboseErrors :: Parser Bool
104−verboseErrors = switch $
105− short 'v'
106− <> long "verbose-errors"
107− <> help "Display verbose error messages"
108−
109−noOpts :: Parser Bool
110−noOpts = switch $
111− long "no-opts"
112− <> help "Skip the optimization phase."
113−
114−runMain :: Parser (Maybe String)
115−runMain = optional $ noArgs <|> withArgs
116− where
117− defaultVal = "Main"
118− noArgs = flag' defaultVal (long "main")
119− withArgs = strOption $
120− long "main"
121− <> help (concat [
122− "Generate code to run the main method in the specified module. ",
123− "(no argument: \"", defaultVal, "\")"
124− ])
125−
126−noMagicDo :: Parser Bool
127−noMagicDo = switch $
128− long "no-magic-do"
129− <> help "Disable the optimization that overloads the do keyword to generate efficient code specifically for the Eff monad."
130−
131−noTco :: Parser Bool
132−noTco = switch $
133− long "no-tco"
134− <> help "Disable tail call optimizations"
135−
136−noPrelude :: Parser Bool
137−noPrelude = switch $
138− long "no-prelude"
139− <> help "Omit the Prelude"
140−
141−comments :: Parser Bool
142−comments = switch $
143− short 'c'
144− <> long "comments"
145− <> help "Include comments in the generated code."
146−
147−useStdIn :: Parser Bool
148−useStdIn = switch $
149− short 's'
150− <> long "stdin"
151− <> help "Read from standard input"
152−
153−inputFile :: Parser FilePath
154−inputFile = strArgument $
155− metavar "FILE"
156− <> help "The input .purs file(s)"
157−
158−outputFile :: Parser (Maybe FilePath)
159−outputFile = optional . strOption $
160− short 'o'
161− <> long "output"
162− <> help "The output .js file"
163−
164−externsFile :: Parser (Maybe FilePath)
165−externsFile = optional . strOption $
166− short 'e'
167− <> long "externs"
168− <> help "The output .e.purs file"
169−
170−noPrefix :: Parser Bool
171−noPrefix = switch $
172− short 'p'
173− <> long "no-prefix"
174− <> help "Do not include comment header"
175−
176−options :: Parser (P.Options P.Compile)
177−options = P.Options <$> noPrelude
178− <*> noTco
179− <*> noMagicDo
180− <*> runMain
181− <*> noOpts
182− <*> verboseErrors
183− <*> comments
184− <*> additionalOptions
185− where
186− additionalOptions =
187− P.CompileOptions <$> browserNamespace
188− <*> many dceModule
189− <*> many codeGenModule
190−
191−pscOptions :: Parser PSCOptions
192−pscOptions = PSCOptions <$> many inputFile
193− <*> options
194− <*> useStdIn
195− <*> outputFile
196− <*> externsFile
197− <*> (not <$> noPrefix)
198−
199−main :: IO ()
200−main = execParser opts >>= compile
201− where
202− opts = info (version <*> helper <*> pscOptions) infoModList
203− infoModList = fullDesc <> headerInfo <> footerInfo
204− headerInfo = header "psc - Compiles PureScript to Javascript"
205− footerInfo = footer $ "psc " ++ showVersion Paths.version
206−
207− version :: Parser (a -> a)
208− version = abortOption (InfoMsg (showVersion Paths.version)) $ long "version" <> help "Show the version number" <> hidden
209−
psci/Commands.hsdeleted−87
@@ -1,87 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Commands
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−-- Commands for PSCI.
13−--
14−-----------------------------------------------------------------------------
15−
16−module Commands where
17−
18−import Language.PureScript
19−
20−-- |
21−-- Valid Meta-commands for PSCI
22−--
23−data Command
24− -- |
25− -- A purescript expression
26− --
27− = Expression Expr
28− -- |
29− -- Show the help command
30− --
31− | Help
32− -- |
33− -- Import a module from a loaded file
34− --
35− | Import ModuleName
36− -- |
37− -- Browse a module
38− --
39− | Browse ModuleName
40− -- |
41− -- Load a file for use with importing
42− --
43− | LoadFile FilePath
44− -- |
45− -- Exit PSCI
46− --
47− | Quit
48− -- |
49− -- Reset the state of the REPL
50− --
51− | Reset
52− -- |
53− -- Binds a value to a name
54− --
55− | Let [Declaration]
56− -- |
57− -- Find the type of an expression
58− --
59− | TypeOf Expr
60− -- |
61− -- Find the kind of an expression
62− --
63− | KindOf Type
64− -- |
65− -- Show command
66− --
67− | Show String
68−
69−-- |
70−-- The help menu.
71−--
72−help :: [(String, String, String)]
73−help =
74− [ (":?", "", "Show this help menu")
75− , (":i", "<module>", "Import <module> for use in PSCI")
76− , (":b", "<module>", "Browse <module>")
77− , (":m", "<file>", "Load <file> for importing")
78− , (":q", "", "Quit PSCi")
79− , (":r", "", "Reset")
80− , (":s", "import", "Show imported modules")
81− , (":s", "loaded", "Show loaded modules")
82− , (":t", "<expr>", "Show the type of <expr>")
83− , (":k", "<type>", "Show the kind of <type>")
84− ]
85−
86−commands :: [String]
87−commands = map (\ (a, _, _) -> a) help
psci/Main.hsdeleted−647
@@ -1,647 +0,0 @@
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−-- PureScript Compiler Interactive.
13−--
14−-----------------------------------------------------------------------------
15−
16−{-# LANGUAGE DataKinds, DoAndIfThenElse, FlexibleContexts, GeneralizedNewtypeDeriving #-}
17−
18−module Main where
19−
20−import Data.Foldable (traverse_)
21−import Data.List (intercalate, isPrefixOf, nub, sortBy, sort)
22−import Data.Maybe (mapMaybe)
23−import Data.Traversable (traverse)
24−import Data.Version (showVersion)
25−import Data.Char (isSpace)
26−import qualified Data.Map as M
27−
28−import Control.Applicative
29−import Control.Monad
30−import Control.Monad.Error (ErrorT(..), MonadError)
31−import Control.Monad.Reader (MonadReader, ReaderT, runReaderT)
32−import Control.Monad.Trans.Class
33−import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
34−import Control.Monad.Trans.State.Strict
35−import qualified Control.Monad.Trans.State.Lazy as L
36−
37−import Options.Applicative as Opts
38−
39−import System.Console.Haskeline
40−import System.Directory (createDirectoryIfMissing, getModificationTime, doesFileExist, findExecutable, getHomeDirectory, getCurrentDirectory)
41−import System.Exit
42−import System.FilePath (pathSeparator, takeDirectory, (</>), isPathSeparator)
43−import System.IO.Error (tryIOError)
44−import System.Process (readProcessWithExitCode)
45−
46−import qualified Text.Parsec as Par (ParseError)
47−
48−import qualified Language.PureScript as P
49−import qualified Language.PureScript.AST as D
50−import qualified Language.PureScript.Names as N
51−import qualified Paths_purescript as Paths
52−
53−import Commands as C
54−import Parser
55−
56−
57−data PSCiOptions = PSCiOptions
58− { psciSingleLineFlag :: Bool
59− , psciInputFile :: [FilePath]
60− }
61−
62−-- |
63−-- The PSCI state.
64−-- Holds a list of imported modules, loaded files, and partial let bindings.
65−-- The let bindings are partial,
66−-- because it makes more sense to apply the binding to the final evaluated expression.
67−--
68−data PSCiState = PSCiState
69− { psciImportedFilenames :: [FilePath]
70− , psciImportedModuleNames :: [P.ModuleName]
71− , psciLoadedModules :: [(Either P.RebuildPolicy FilePath, P.Module)]
72− , psciLetBindings :: [P.Declaration]
73− }
74−
75−-- State helpers
76−
77−-- |
78−-- Updates the state to have more imported modules.
79−--
80−updateImportedFiles :: FilePath -> PSCiState -> PSCiState
81−updateImportedFiles filename st = st { psciImportedFilenames = filename : psciImportedFilenames st }
82−
83−-- |
84−-- Updates the state to have more imported modules.
85−--
86−updateImports :: P.ModuleName -> PSCiState -> PSCiState
87−updateImports name st = st { psciImportedModuleNames = name : psciImportedModuleNames st }
88−
89−-- |
90−-- Updates the state to have more loaded files.
91−--
92−updateModules :: [(Either P.RebuildPolicy FilePath, P.Module)] -> PSCiState -> PSCiState
93−updateModules modules st = st { psciLoadedModules = psciLoadedModules st ++ modules }
94−
95−-- |
96−-- Updates the state to have more let bindings.
97−--
98−updateLets :: [P.Declaration] -> PSCiState -> PSCiState
99−updateLets ds st = st { psciLetBindings = ds ++ psciLetBindings st }
100−
101−-- File helpers
102−-- |
103−-- Load the necessary modules.
104−--
105−defaultImports :: [P.ModuleName]
106−defaultImports = [P.ModuleName [P.ProperName "Prelude"]]
107−
108−-- |
109−-- Locates the node executable.
110−-- Checks for either @nodejs@ or @node@.
111−--
112−findNodeProcess :: IO (Maybe String)
113−findNodeProcess = runMaybeT . msum $ map (MaybeT . findExecutable) names
114− where names = ["nodejs", "node"]
115−
116−-- |
117−-- Grabs the filename where the history is stored.
118−--
119−getHistoryFilename :: IO FilePath
120−getHistoryFilename = do
121− home <- getHomeDirectory
122− let filename = home </> ".purescript" </> "psci_history"
123− mkdirp filename
124− return filename
125−
126−-- |
127−-- Loads a file for use with imports.
128−--
129−loadModule :: FilePath -> IO (Either String [P.Module])
130−loadModule filename = do
131− content <- readFile filename
132− return $ either (Left . show) (Right . map snd) $ P.parseModulesFromFiles id [(filename, content)]
133−
134−-- |
135−-- Load all modules, including the Prelude
136−--
137−loadAllModules :: [FilePath] -> IO (Either Par.ParseError [(Either P.RebuildPolicy FilePath, P.Module)])
138−loadAllModules files = do
139− filesAndContent <- forM files $ \filename -> do
140− content <- readFile filename
141− return (Right filename, content)
142− return $ P.parseModulesFromFiles (either (const "") id) $ (Left P.RebuildNever, P.prelude) : filesAndContent
143−
144−-- |
145−-- Load all modules, updating the application state
146−--
147−loadAllImportedModules :: PSCI ()
148−loadAllImportedModules = do
149− files <- PSCI . lift $ fmap psciImportedFilenames get
150− modulesOrFirstError <- psciIO $ loadAllModules files
151− case modulesOrFirstError of
152− Left err -> psciIO $ print err
153− Right modules -> PSCI . lift . modify $ \st -> st { psciLoadedModules = modules }
154−
155−-- |
156−-- Expands tilde in path.
157−--
158−expandTilde :: FilePath -> IO FilePath
159−expandTilde ('~':p:rest) | isPathSeparator p = (</> rest) <$> getHomeDirectory
160−expandTilde p = return p
161−-- Messages
162−
163−-- |
164−-- The help message.
165−--
166−helpMessage :: String
167−helpMessage = "The following commands are available:\n\n " ++
168− intercalate "\n " (map line C.help)
169− where line :: (String, String, String) -> String
170− line (cmd, arg, desc) = intercalate " " [cmd, arg, replicate (11 - length arg) ' ', desc]
171−
172−-- |
173−-- The welcome prologue.
174−--
175−prologueMessage :: String
176−prologueMessage = intercalate "\n"
177− [ " ____ ____ _ _ "
178− , "| _ \\ _ _ _ __ ___/ ___| ___ _ __(_)_ __ | |_ "
179− , "| |_) | | | | '__/ _ \\___ \\ / __| '__| | '_ \\| __|"
180− , "| __/| |_| | | | __/___) | (__| | | | |_) | |_ "
181− , "|_| \\__,_|_| \\___|____/ \\___|_| |_| .__/ \\__|"
182− , " |_| "
183− , ""
184− , ":? shows help"
185− , ""
186− , "Expressions are terminated using Ctrl+D"
187− ]
188−
189−-- |
190−-- The quit message.
191−--
192−quitMessage :: String
193−quitMessage = "See ya!"
194−
195−-- Haskeline completions
196−
197−data CompletionContext = Command String | FilePath String | Module | Identifier
198− | Type | Fixed [String] | Multiple [CompletionContext]
199− deriving (Show)
200−
201−-- |
202−-- Decide what kind of completion we need based on input.
203−completionContext :: String -> String -> Maybe CompletionContext
204−completionContext cmd@"" _ = Just $ Multiple [Command cmd, Identifier]
205−completionContext cmd@(':' : _ ) _
206− | cmd `elem` C.commands || cmd == ":" = Just $ Command cmd
207−completionContext (':' : c : _) word = case c of
208− 'i' -> Just Module
209− 'b' -> Just Module
210− 'm' -> Just $ FilePath word
211− 'q' -> Nothing
212− 'r' -> Nothing
213− '?' -> Nothing
214− 's' -> Just $ Fixed ["import", "loaded"]
215− 't' -> Just Identifier
216− 'k' -> Just Type
217− _ -> Nothing
218−completionContext _ _ = Just Identifier
219−
220−-- |
221−-- Loads module, function, and file completions.
222−--
223−completion :: CompletionFunc (StateT PSCiState IO)
224−completion = completeWordWithPrev Nothing " \t\n\r" findCompletions
225− where
226− findCompletions :: String -> String -> StateT PSCiState IO [Completion]
227− findCompletions prev word = do
228− let ctx = completionContext ((dropWhile isSpace (reverse prev)) ++ word) word
229− completions <- case ctx of
230− Nothing -> return []
231− (Just c) -> (mapMaybe $ either (\cand -> if word `isPrefixOf` cand
232− then Just $ simpleCompletion cand
233− else Nothing) Just)
234− <$> getCompletion c
235− return $ sortBy sorter completions
236−
237− getCompletion :: CompletionContext -> StateT PSCiState IO [Either String Completion]
238− getCompletion (Command s) = return $ (map Left) $ nub $ filter (isPrefixOf s) C.commands
239− getCompletion (FilePath f) = (map Right) <$> listFiles f
240− getCompletion Module = (map Left) <$> getModuleNames
241− getCompletion Identifier = (map Left) <$> ((++) <$> getIdentNames <*> getDctorNames)
242− getCompletion Type = (map Left) <$> getTypeNames
243− getCompletion (Fixed list) = return $ (map Left) list
244− getCompletion (Multiple contexts) = concat <$> mapM getCompletion contexts
245−
246− getLoadedModules :: StateT PSCiState IO [P.Module]
247− getLoadedModules = map snd . psciLoadedModules <$> get
248−
249− getModuleNames :: StateT PSCiState IO [String]
250− getModuleNames = moduleNames <$> getLoadedModules
251−
252− mapLoadedModulesAndQualify :: (Show a) => (P.Module -> [a]) -> StateT PSCiState IO [String]
253− mapLoadedModulesAndQualify f = do
254− ms <- getLoadedModules
255− q <- sequence [qualifyIfNeeded m (f m) | m <- ms]
256− return $ concat q
257−
258− getIdentNames :: StateT PSCiState IO [String]
259− getIdentNames = mapLoadedModulesAndQualify identNames
260−
261− getDctorNames :: StateT PSCiState IO [String]
262− getDctorNames = mapLoadedModulesAndQualify dctorNames
263−
264− getTypeNames :: StateT PSCiState IO [String]
265− getTypeNames = mapLoadedModulesAndQualify typeDecls
266−
267− qualifyIfNeeded :: (Show a) => P.Module -> [a] -> StateT PSCiState IO [String]
268− qualifyIfNeeded m decls = do
269− let name = P.getModuleName m
270− imported <- psciImportedModuleNames <$> get
271− let qualified = map (P.Qualified $ Just name) decls
272− if name `elem` imported then
273− return $ map show $ qualified ++ (map (P.Qualified Nothing) decls)
274− else
275− return $ map show qualified
276−
277− typeDecls :: P.Module -> [N.ProperName]
278− typeDecls m = mapMaybe getTypeName $ filter P.isDataDecl (P.exportedDeclarations m)
279− where getTypeName :: P.Declaration -> Maybe N.ProperName
280− getTypeName (P.TypeSynonymDeclaration name _ _) = Just name
281− getTypeName (P.DataDeclaration _ name _ _) = Just name
282− getTypeName (P.PositionedDeclaration _ _ d) = getTypeName d
283− getTypeName _ = Nothing
284−
285− identNames :: P.Module -> [N.Ident]
286− identNames (P.Module _ ds exports) = nub [ ident | ident <- mapMaybe (getDeclName exports) (D.flattenDecls ds) ]
287− where getDeclName :: Maybe [P.DeclarationRef] -> P.Declaration -> Maybe P.Ident
288− getDeclName exts decl@(P.ValueDeclaration ident _ _ _) | P.isExported exts decl = Just ident
289− getDeclName exts decl@(P.ExternDeclaration _ ident _ _) | P.isExported exts decl = Just ident
290− getDeclName exts (P.PositionedDeclaration _ _ d) = getDeclName exts d
291− getDeclName _ _ = Nothing
292−
293− dctorNames :: P.Module -> [N.ProperName]
294− dctorNames m = nub $ concat $ map (P.exportedDctors m) dnames
295− where getDataDeclName :: P.Declaration -> Maybe N.ProperName
296− getDataDeclName (P.DataDeclaration _ name _ _) = Just name
297− getDataDeclName (P.PositionedDeclaration _ _ d) = getDataDeclName d
298− getDataDeclName _ = Nothing
299−
300− dnames :: [N.ProperName]
301− dnames = (mapMaybe getDataDeclName onlyDataDecls)
302−
303− onlyDataDecls :: [P.Declaration]
304− onlyDataDecls = (filter P.isDataDecl (P.exportedDeclarations m))
305−
306− moduleNames :: [P.Module] -> [String]
307− moduleNames ms = nub [show moduleName | P.Module moduleName _ _ <- ms]
308−
309− sorter :: Completion -> Completion -> Ordering
310− sorter (Completion _ d1 _) (Completion _ d2 _) = if ":" `isPrefixOf` d1 then LT else compare d1 d2
311−
312−-- Compilation
313−
314−-- | Compilation options.
315−--
316−options :: P.Options P.Make
317−options = P.Options False False False Nothing False False False P.MakeOptions
318−
319−-- |
320−-- PSCI monad
321−--
322−newtype PSCI a = PSCI { runPSCI :: InputT (StateT PSCiState IO) a } deriving (Functor, Applicative, Monad)
323−
324−psciIO :: IO a -> PSCI a
325−psciIO io = PSCI . lift $ lift io
326−
327−newtype Make a = Make { unMake :: ReaderT (P.Options P.Make) (ErrorT String IO) a }
328− deriving (Functor, Applicative, Monad, MonadError String, MonadReader (P.Options P.Make))
329−
330−runMake :: Make a -> IO (Either String a)
331−runMake = runErrorT . flip runReaderT options . unMake
332−
333−makeIO :: IO a -> Make a
334−makeIO = Make . lift . ErrorT . fmap (either (Left . show) Right) . tryIOError
335−
336−instance P.MonadMake Make where
337− getTimestamp path = makeIO $ do
338− exists <- doesFileExist path
339− traverse (const $ getModificationTime path) $ guard exists
340− readTextFile path = makeIO $ readFile path
341− writeTextFile path text = makeIO $ do
342− mkdirp path
343− writeFile path text
344− progress s = unless (s == "Compiling $PSCI") $ makeIO . putStrLn $ s
345−
346−mkdirp :: FilePath -> IO ()
347−mkdirp = createDirectoryIfMissing True . takeDirectory
348−
349−-- |
350−-- Makes a volatile module to execute the current expression.
351−--
352−createTemporaryModule :: Bool -> PSCiState -> P.Expr -> P.Module
353−createTemporaryModule exec PSCiState{psciImportedModuleNames = imports, psciLetBindings = lets} val =
354− let
355− moduleName = P.ModuleName [P.ProperName "$PSCI"]
356− importDecl m = P.ImportDeclaration m P.Unqualified Nothing
357− traceModule = P.ModuleName [P.ProperName "Debug", P.ProperName "Trace"]
358− trace = P.Var (P.Qualified (Just traceModule) (P.Ident "print"))
359− mainValue = P.App trace (P.Var (P.Qualified Nothing (P.Ident "it")))
360− itDecl = P.ValueDeclaration (P.Ident "it") P.Value [] $ Right val
361− mainDecl = P.ValueDeclaration (P.Ident "main") P.Value [] $ Right mainValue
362− decls = if exec then [itDecl, mainDecl] else [itDecl]
363− in
364− P.Module moduleName ((importDecl `map` imports) ++ lets ++ decls) Nothing
365−
366−
367−-- |
368−-- Makes a volatile module to hold a non-qualified type synonym for a fully-qualified data type declaration.
369−--
370−createTemporaryModuleForKind :: PSCiState -> P.Type -> P.Module
371−createTemporaryModuleForKind PSCiState{psciImportedModuleNames = imports} typ =
372− let
373− moduleName = P.ModuleName [P.ProperName "$PSCI"]
374− importDecl m = P.ImportDeclaration m P.Unqualified Nothing
375− itDecl = P.TypeSynonymDeclaration (P.ProperName "IT") [] typ
376− in
377− P.Module moduleName ((importDecl `map` imports) ++ [itDecl]) Nothing
378−
379−-- |
380−-- Makes a volatile module to execute the current imports.
381−--
382−createTemporaryModuleForImports :: PSCiState -> P.Module
383−createTemporaryModuleForImports PSCiState{psciImportedModuleNames = imports} =
384− let
385− moduleName = P.ModuleName [P.ProperName "$PSCI"]
386− importDecl m = P.ImportDeclaration m P.Unqualified Nothing
387− in
388− P.Module moduleName (importDecl `map` imports) Nothing
389−
390−modulesDir :: FilePath
391−modulesDir = ".psci_modules" ++ pathSeparator : "node_modules"
392−
393−indexFile :: FilePath
394−indexFile = ".psci_modules" ++ pathSeparator : "index.js"
395−
396−-- |
397−-- Takes a value declaration and evaluates it with the current state.
398−--
399−handleDeclaration :: P.Expr -> PSCI ()
400−handleDeclaration val = do
401− st <- PSCI $ lift get
402− let m = createTemporaryModule True st val
403− e <- psciIO . runMake $ P.make modulesDir (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) []
404− case e of
405− Left err -> PSCI $ outputStrLn err
406− Right _ -> do
407− psciIO $ writeFile indexFile "require('$PSCI').main();"
408− process <- psciIO findNodeProcess
409− result <- psciIO $ traverse (\node -> readProcessWithExitCode node [indexFile] "") process
410− case result of
411− Just (ExitSuccess, out, _) -> PSCI $ outputStrLn out
412− Just (ExitFailure _, _, err) -> PSCI $ outputStrLn err
413− Nothing -> PSCI $ outputStrLn "Couldn't find node.js"
414−
415−-- |
416−-- Takes a let declaration and updates the environment, then run a make. If the declaration fails,
417−-- restore the pre-let environment.
418−--
419−handleLet :: [P.Declaration] -> PSCI ()
420−handleLet ds = do
421− st <- PSCI $ lift get
422− let st' = updateLets ds st
423− let m = createTemporaryModule False st' (P.ObjectLiteral [])
424− e <- psciIO . runMake $ P.make modulesDir (psciLoadedModules st' ++ [(Left P.RebuildAlways, m)]) []
425− case e of
426− Left err -> PSCI $ outputStrLn err
427− Right _ -> PSCI $ lift (put st')
428−
429−-- |
430−-- Show actual loaded modules in psci.
431−--
432−handleShowLoadedModules :: PSCI ()
433−handleShowLoadedModules = do
434− PSCiState { psciLoadedModules = loadedModules } <- PSCI $ lift get
435− psciIO $ readModules loadedModules >>= putStrLn
436− return ()
437− where readModules = return . unlines . sort . nub . map toModuleName
438− toModuleName = N.runModuleName . (\ (D.Module mdName _ _) -> mdName) . snd
439−
440−-- |
441−-- Show the imported modules in psci.
442−--
443−handleShowImportedModules :: PSCI ()
444−handleShowImportedModules = do
445− PSCiState { psciImportedModuleNames = importedModuleNames } <- PSCI $ lift get
446− psciIO $ readModules importedModuleNames >>= putStrLn
447− return ()
448− where readModules = return . unlines . sort . map N.runModuleName
449−
450−-- |
451−-- Imports a module, preserving the initial state on failure.
452−--
453−handleImport :: P.ModuleName -> PSCI ()
454−handleImport moduleName = do
455− st <- updateImports moduleName <$> PSCI (lift get)
456− let m = createTemporaryModuleForImports st
457− e <- psciIO . runMake $ P.make modulesDir (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) []
458− case e of
459− Left err -> PSCI $ outputStrLn err
460− Right _ -> do
461− PSCI $ lift $ put st
462− return ()
463−
464−-- |
465−-- Takes a value and prints its type
466−--
467−handleTypeOf :: P.Expr -> PSCI ()
468−handleTypeOf val = do
469− st <- PSCI $ lift get
470− let m = createTemporaryModule False st val
471− e <- psciIO . runMake $ P.make modulesDir (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) []
472− case e of
473− Left err -> PSCI $ outputStrLn err
474− Right env' ->
475− case M.lookup (P.ModuleName [P.ProperName "$PSCI"], P.Ident "it") (P.names env') of
476− Just (ty, _, _) -> PSCI . outputStrLn . P.prettyPrintType $ ty
477− Nothing -> PSCI $ outputStrLn "Could not find type"
478−
479−-- |
480−-- Pretty print a module's signatures
481−--
482−printModuleSignatures :: P.ModuleName -> P.Environment -> PSCI ()
483−printModuleSignatures moduleName env =
484− PSCI $ let namesEnv = P.names env
485− moduleNamesIdent = (filter ((== moduleName) . fst) . M.keys) namesEnv
486− in case moduleNamesIdent of
487− [] -> outputStrLn $ "This module '"++ P.runModuleName moduleName ++"' does not export functions."
488− _ -> ( outputStrLn
489− . unlines
490− . sort
491− . map (showType . findType namesEnv)) moduleNamesIdent
492− 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))
493− findType envNames m@(_, mIdent) = (mIdent, M.lookup m envNames)
494− showType :: (P.Ident, Maybe (P.Type, P.NameKind, P.NameVisibility)) -> String
495− showType (mIdent, Just (mType, _, _)) = show mIdent ++ " :: " ++ P.prettyPrintType mType
496− showType _ = error "The impossible happened in printModuleSignatures."
497−
498−-- |
499−-- Browse a module and displays its signature (if module exists).
500−--
501−handleBrowse :: P.ModuleName -> PSCI ()
502−handleBrowse moduleName = do
503− st <- PSCI $ lift get
504− let loadedModules = psciLoadedModules st
505− env <- psciIO . runMake $ P.make modulesDir loadedModules []
506− case env of
507− Left err -> PSCI $ outputStrLn err
508− Right env' ->
509− if moduleName `notElem` (nub . map ((\ (P.Module modName _ _ ) -> modName) . snd)) loadedModules
510− then PSCI $ outputStrLn $ "Module '" ++ N.runModuleName moduleName ++ "' is not valid."
511− else printModuleSignatures moduleName env'
512−
513−-- |
514−-- Takes a value and prints its kind
515−--
516−handleKindOf :: P.Type -> PSCI ()
517−handleKindOf typ = do
518− st <- PSCI $ lift get
519− let m = createTemporaryModuleForKind st typ
520− mName = P.ModuleName [P.ProperName "$PSCI"]
521− e <- psciIO . runMake $ P.make modulesDir (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) []
522− case e of
523− Left err -> PSCI $ outputStrLn err
524− Right env' ->
525− case M.lookup (P.Qualified (Just mName) $ P.ProperName "IT") (P.typeSynonyms env') of
526− Just (_, typ') -> do
527− let chk = P.CheckState env' 0 0 (Just mName)
528− k = L.runStateT (P.unCheck (P.kindOf mName typ')) chk
529− case k of
530− Left errStack -> PSCI . outputStrLn . P.prettyPrintErrorStack False $ errStack
531− Right (kind, _) -> PSCI . outputStrLn . P.prettyPrintKind $ kind
532− Nothing -> PSCI $ outputStrLn "Could not find kind"
533−
534−-- Commands
535−
536−-- |
537−-- Parses the input and returns either a Metacommand or an expression.
538−--
539−getCommand :: Bool -> InputT (StateT PSCiState IO) (Either String (Maybe Command))
540−getCommand singleLineMode = do
541− firstLine <- getInputLine "> "
542− case firstLine of
543− Nothing -> return (Right Nothing)
544− Just "" -> return (Right Nothing)
545− Just s | singleLineMode || head s == ':' -> return . either Left (Right . Just) $ parseCommand s
546− Just s -> either Left (Right . Just) . parseCommand <$> go [s]
547− where
548− go :: [String] -> InputT (StateT PSCiState IO) String
549− go ls = maybe (return . unlines $ reverse ls) (go . (:ls)) =<< getInputLine " "
550−
551−-- |
552−-- Performs an action for each meta-command given, and also for expressions..
553−--
554−handleCommand :: Command -> PSCI ()
555−handleCommand (Expression val) = handleDeclaration val
556−handleCommand Help = PSCI $ outputStrLn helpMessage
557−handleCommand (Import moduleName) = handleImport moduleName
558−handleCommand (Let l) = handleLet l
559−handleCommand (LoadFile filePath) = do
560− absPath <- psciIO $ expandTilde filePath
561− exists <- psciIO $ doesFileExist absPath
562− if exists then do
563− PSCI . lift $ modify (updateImportedFiles absPath)
564− m <- psciIO $ loadModule absPath
565− case m of
566− Left err -> PSCI $ outputStrLn err
567− Right mods -> PSCI . lift $ modify (updateModules (map ((,) (Right absPath)) mods))
568− else
569− PSCI . outputStrLn $ "Couldn't locate: " ++ filePath
570−handleCommand Reset = do
571− files <- psciImportedFilenames <$> PSCI (lift get)
572− PSCI . lift . modify $ \st -> st
573− { psciImportedFilenames = files
574− , psciImportedModuleNames = defaultImports
575− , psciLetBindings = []
576− }
577− loadAllImportedModules
578−handleCommand (TypeOf val) = handleTypeOf val
579−handleCommand (KindOf typ) = handleKindOf typ
580−handleCommand (Browse moduleName) = handleBrowse moduleName
581−handleCommand (Show "loaded") = handleShowLoadedModules
582−handleCommand (Show "import") = handleShowImportedModules
583−handleCommand _ = PSCI $ outputStrLn "Unknown command"
584−
585−loadUserConfig :: IO (Maybe [Command])
586−loadUserConfig = do
587− configFile <- (</> ".psci") <$> getCurrentDirectory
588− exists <- doesFileExist configFile
589− if exists
590− then do
591− ls <- lines <$> readFile configFile
592− case mapM parseCommand ls of
593− Left err -> print err >> exitFailure
594− Right cs -> return $ Just cs
595− else
596− return Nothing
597−
598−-- |
599−-- The PSCI main loop.
600−--
601−loop :: PSCiOptions -> IO ()
602−loop (PSCiOptions singleLineMode files) = do
603− config <- loadUserConfig
604− modulesOrFirstError <- loadAllModules files
605− case modulesOrFirstError of
606− Left err -> print err >> exitFailure
607− Right modules -> do
608− historyFilename <- getHistoryFilename
609− let settings = defaultSettings { historyFile = Just historyFilename }
610− flip evalStateT (PSCiState files defaultImports modules []) . runInputT (setComplete completion settings) $ do
611− outputStrLn prologueMessage
612− traverse_ (mapM_ (runPSCI . handleCommand)) config
613− go
614− where
615− go :: InputT (StateT PSCiState IO) ()
616− go = do
617− c <- getCommand singleLineMode
618− case c of
619− Left err -> outputStrLn err >> go
620− Right Nothing -> go
621− Right (Just Quit) -> outputStrLn quitMessage
622− Right (Just c') -> runPSCI (loadAllImportedModules >> handleCommand c') >> go
623−
624−singleLineFlag :: Parser Bool
625−singleLineFlag = switch $
626− long "single-line-mode"
627− <> Opts.help "Run in single-line mode"
628−
629−inputFile :: Parser FilePath
630−inputFile = strArgument $
631− metavar "FILE"
632− <> Opts.help "Optional .purs files to load on start"
633−
634−psciOptions :: Parser PSCiOptions
635−psciOptions = PSCiOptions <$> singleLineFlag
636− <*> many inputFile
637−
638−main :: IO ()
639−main = execParser opts >>= loop
640− where
641− opts = info (version <*> helper <*> psciOptions) infoModList
642− infoModList = fullDesc <> headerInfo <> footerInfo
643− headerInfo = header "psci - Interactive mode for PureScript"
644− footerInfo = footer $ "psci " ++ showVersion Paths.version
645−
646− version :: Parser (a -> a)
647− version = abortOption (InfoMsg (showVersion Paths.version)) $ long "version" <> Opts.help "Show the version number" <> hidden
psci/Parser.hsdeleted−82
@@ -1,82 +0,0 @@
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 Commands
23−
24−import Data.Char (isSpace)
25−
26−import Control.Applicative hiding (many)
27−
28−import Text.Parsec hiding ((<|>))
29−
30−import qualified Language.PureScript as P
31−import qualified Language.PureScript.Parser.Common as C (mark, same)
32−
33−-- |
34−-- Parses PSCI metacommands or expressions input from the user.
35−--
36−parseCommand :: String -> Either String Command
37−parseCommand cmdString =
38− case splitCommand cmdString of
39− Just ('?', _) -> return Help
40− Just ('q', _) -> return Quit
41− Just ('r', _) -> return Reset
42− Just ('i', moduleName) -> Import <$> parseRest P.moduleName moduleName
43− Just ('b', moduleName) -> Browse <$> parseRest P.moduleName moduleName
44− Just ('m', filename) -> return $ LoadFile (trimEnd filename)
45− Just ('s', command) -> return $ Show (trimEnd command)
46− Just ('t', expr) -> TypeOf <$> parseRest P.parseValue expr
47− Just ('k', ty) -> KindOf <$> parseRest P.parseType ty
48− Just _ -> Left $ "Unrecognized command. Type :? for help."
49− Nothing -> parseRest (psciLet <|> psciExpression) cmdString
50− where
51− parseRest :: P.TokenParser a -> String -> Either String a
52− parseRest p s = either (Left . show) Right $ do
53− ts <- P.lex "" s
54− P.runTokenParser "" (p <* eof) ts
55−
56− trimEnd :: String -> String
57− trimEnd = reverse . dropWhile isSpace . reverse
58−
59− -- |
60− -- Split a command into a command char and the trailing string
61− --
62− splitCommand :: String -> Maybe (Char, String)
63− splitCommand (':' : c : s) = Just (c, dropWhile isSpace s)
64− splitCommand _ = Nothing
65−
66− -- |
67− -- Parses expressions entered at the PSCI repl.
68− --
69− psciExpression :: P.TokenParser Command
70− psciExpression = Expression <$> P.parseValue
71−
72− -- |
73− -- PSCI version of @let@.
74− -- This is essentially let from do-notation.
75− -- However, since we don't support the @Eff@ monad,
76− -- we actually want the normal @let@.
77− --
78− psciLet :: P.TokenParser Command
79− psciLet = Let <$> (P.reserved "let" *> P.indented *> manyDecls)
80− where
81− manyDecls :: P.TokenParser [P.Declaration]
82− manyDecls = C.mark (many1 (C.same *> P.parseDeclaration))
psgo.cabalnew file+145
@@ -0,0 +1,145 @@
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.cabaldeleted−178
@@ -1,178 +0,0 @@
1−name: purescript
2−version: 0.6.7.1
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−extra-source-files: prelude/prelude.purs
19− , examples/passing/*.purs
20− , examples/failing/*.purs
21−
22−source-repository head
23− type: git
24− location: https://github.com/purescript/purescript.git
25−
26−library
27− build-depends: base >=4.6 && <5,
28− containers -any,
29− unordered-containers -any,
30− directory >= 1.2,
31− filepath -any,
32− mtl >= 2.1.0 && < 2.3.0,
33− parsec -any,
34− transformers >= 0.3 && < 0.5,
35− utf8-string >= 1 && < 2,
36− pattern-arrows >= 0.0.2 && < 0.1,
37− monad-unify >= 0.2.2 && < 0.3,
38− file-embed >= 0.0.7 && < 0.0.8,
39− time -any
40− exposed-modules: Language.PureScript
41− Language.PureScript.AST
42− Language.PureScript.AST.Binders
43− Language.PureScript.AST.Declarations
44− Language.PureScript.AST.Operators
45− Language.PureScript.AST.SourcePos
46− Language.PureScript.AST.Traversals
47− Language.PureScript.CodeGen
48− Language.PureScript.CodeGen.Externs
49− Language.PureScript.CodeGen.JS
50− Language.PureScript.CodeGen.JS.AST
51− Language.PureScript.CodeGen.JS.Common
52− Language.PureScript.CodeGen.JS.Optimizer
53− Language.PureScript.CodeGen.JS.Optimizer.Blocks
54− Language.PureScript.CodeGen.JS.Optimizer.Common
55− Language.PureScript.CodeGen.JS.Optimizer.Inliner
56− Language.PureScript.CodeGen.JS.Optimizer.MagicDo
57− Language.PureScript.CodeGen.JS.Optimizer.TCO
58− Language.PureScript.CodeGen.JS.Optimizer.Unused
59− Language.PureScript.Constants
60− Language.PureScript.CoreFn
61− Language.PureScript.CoreFn.Ann
62− Language.PureScript.CoreFn.Binders
63− Language.PureScript.CoreFn.Desugar
64− Language.PureScript.CoreFn.Expr
65− Language.PureScript.CoreFn.Literals
66− Language.PureScript.CoreFn.Meta
67− Language.PureScript.CoreFn.Module
68− Language.PureScript.CoreFn.Traversals
69− Language.PureScript.Comments
70− Language.PureScript.DeadCodeElimination
71− Language.PureScript.Environment
72− Language.PureScript.Errors
73− Language.PureScript.Kinds
74− Language.PureScript.ModuleDependencies
75− Language.PureScript.Names
76− Language.PureScript.Options
77− Language.PureScript.Parser
78− Language.PureScript.Parser.Lexer
79− Language.PureScript.Parser.Common
80− Language.PureScript.Parser.Declarations
81− Language.PureScript.Parser.Kinds
82− Language.PureScript.Parser.State
83− Language.PureScript.Parser.Types
84− Language.PureScript.Pretty
85− Language.PureScript.Pretty.Common
86− Language.PureScript.Pretty.JS
87− Language.PureScript.Pretty.Kinds
88− Language.PureScript.Pretty.Types
89− Language.PureScript.Pretty.Values
90− Language.PureScript.Renamer
91− Language.PureScript.Sugar
92− Language.PureScript.Sugar.BindingGroups
93− Language.PureScript.Sugar.CaseDeclarations
94− Language.PureScript.Sugar.DoNotation
95− Language.PureScript.Sugar.Names
96− Language.PureScript.Sugar.ObjectWildcards
97− Language.PureScript.Sugar.Operators
98− Language.PureScript.Sugar.TypeClasses
99− Language.PureScript.Sugar.TypeDeclarations
100− Language.PureScript.Supply
101− Language.PureScript.Traversals
102− Language.PureScript.TypeChecker
103− Language.PureScript.TypeChecker.Entailment
104− Language.PureScript.TypeChecker.Kinds
105− Language.PureScript.TypeChecker.Monad
106− Language.PureScript.TypeChecker.Rows
107− Language.PureScript.TypeChecker.Skolems
108− Language.PureScript.TypeChecker.Subsumption
109− Language.PureScript.TypeChecker.Synonyms
110− Language.PureScript.TypeChecker.Types
111− Language.PureScript.TypeChecker.Unify
112− Language.PureScript.TypeClassDictionaries
113− Language.PureScript.Types
114− exposed: True
115− buildable: True
116− hs-source-dirs: src
117− other-modules: Paths_purescript
118− ghc-options: -Wall -fno-warn-warnings-deprecations -O2
119−
120−executable psc
121− build-depends: base >=4 && <5, containers -any, directory -any, filepath -any,
122− mtl -any, optparse-applicative >= 0.10.0, parsec -any, purescript -any,
123− transformers -any
124− main-is: Main.hs
125− buildable: True
126− hs-source-dirs: psc
127− other-modules:
128− ghc-options: -Wall -fno-warn-warnings-deprecations -O2 -fno-warn-unused-do-bind
129−
130−executable psc-make
131− build-depends: base >=4 && <5, containers -any, directory -any, filepath -any,
132− mtl -any, optparse-applicative >= 0.10.0, parsec -any, purescript -any,
133− transformers -any
134− main-is: Main.hs
135− buildable: True
136− hs-source-dirs: psc-make
137− other-modules:
138− ghc-options: -Wall -fno-warn-warnings-deprecations -O2 -fno-warn-unused-do-bind
139−
140−executable psci
141− build-depends: base >=4 && <5, containers -any, directory -any, filepath -any,
142− mtl -any, optparse-applicative >= 0.10.0, parsec -any,
143− haskeline >= 0.7.0.0, purescript -any, transformers -any,
144− process -any
145−
146− main-is: Main.hs
147− buildable: True
148− hs-source-dirs: psci
149− other-modules: Commands
150− Parser
151− ghc-options: -Wall -fno-warn-warnings-deprecations -O2
152−
153−executable psc-docs
154− build-depends: base >=4 && <5, purescript -any,
155− optparse-applicative >= 0.10.0, process -any, mtl -any
156− main-is: Main.hs
157− buildable: True
158− hs-source-dirs: psc-docs
159− other-modules:
160− ghc-options: -Wall -fno-warn-warnings-deprecations -O2
161−
162−executable psc-hierarchy
163− build-depends: base >=4 && <5, purescript -any, optparse-applicative >= 0.10.0,
164− process -any, mtl -any, parsec -any, filepath -any, directory -any
165− main-is: Main.hs
166− buildable: True
167− hs-source-dirs: hierarchy
168− other-modules:
169− ghc-options: -Wall -fno-warn-warnings-deprecations -O2
170−
171−test-suite tests
172− build-depends: base >=4 && <5, containers -any, directory -any,
173− filepath -any, mtl -any, parsec -any, purescript -any,
174− transformers -any, process -any
175− type: exitcode-stdio-1.0
176− main-is: Main.hs
177− buildable: True
178− hs-source-dirs: tests
src/CodeGen/IL.hsnew file+321
@@ -0,0 +1,321 @@
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.hsnew file+196
@@ -0,0 +1,196 @@
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.hsnew file+81
@@ -0,0 +1,81 @@
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.hsnew file+18
@@ -0,0 +1,18 @@
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.hsnew file+435
@@ -0,0 +1,435 @@
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.hsnew file+146
@@ -0,0 +1,146 @@
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.hsnew file+141
@@ -0,0 +1,141 @@
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.hsnew file+527
@@ -0,0 +1,527 @@
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/Language/PureScript.hsdeleted−258
@@ -1,258 +0,0 @@
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, QuasiQuotes, TemplateHaskell, FlexibleContexts #-}
17−
18−module Language.PureScript (module P, compile, compile', RebuildPolicy(..), MonadMake(..), make, prelude) where
19−
20−import Data.FileEmbed (embedFile)
21−import Data.Function (on)
22−import Data.List (sortBy, groupBy, intercalate)
23−import Data.Maybe (fromMaybe)
24−import Data.Time.Clock
25−import qualified Data.Traversable as T (traverse)
26−import qualified Data.ByteString.UTF8 as BU
27−import qualified Data.Map as M
28−import qualified Data.Set as S
29−
30−import Control.Applicative
31−import Control.Arrow ((&&&))
32−import Control.Monad.Error
33−import Control.Monad.Reader
34−
35−import System.FilePath ((</>))
36−
37−import Language.PureScript.AST as P
38−import Language.PureScript.Comments as P
39−import Language.PureScript.CodeGen as P
40−import Language.PureScript.DeadCodeElimination as P
41−import Language.PureScript.Environment as P
42−import Language.PureScript.Errors as P
43−import Language.PureScript.Kinds as P
44−import Language.PureScript.ModuleDependencies as P
45−import Language.PureScript.Names as P
46−import Language.PureScript.Options as P
47−import Language.PureScript.Parser as P
48−import Language.PureScript.Pretty as P
49−import Language.PureScript.Renamer as P
50−import Language.PureScript.Sugar as P
51−import Language.PureScript.Supply as P
52−import Language.PureScript.TypeChecker as P
53−import Language.PureScript.Types as P
54−import qualified Language.PureScript.CoreFn as CoreFn
55−import qualified Language.PureScript.Constants as C
56−
57−-- |
58−-- Compile a collection of modules
59−--
60−-- The compilation pipeline proceeds as follows:
61−--
62−-- * Sort the modules based on module dependencies, checking for cyclic dependencies.
63−--
64−-- * Perform a set of desugaring passes.
65−--
66−-- * Type check, and elaborate values to include type annotations and type class dictionaries.
67−--
68−-- * Regroup values to take into account new value dependencies introduced by elaboration.
69−--
70−-- * Eliminate dead code.
71−--
72−-- * Generate Javascript, and perform optimization passes.
73−--
74−-- * Pretty-print the generated Javascript
75−--
76−compile :: (Functor m, Applicative m, MonadError String m, MonadReader (Options Compile) m)
77− => [Module] -> [String] -> m (String, String, Environment)
78−compile = compile' initEnvironment
79−
80−compile' :: (Functor m, Applicative m, MonadError String m, MonadReader (Options Compile) m)
81− => Environment -> [Module] -> [String] -> m (String, String, Environment)
82−compile' env ms prefix = do
83− noPrelude <- asks optionsNoPrelude
84− additional <- asks optionsAdditional
85− mainModuleIdent <- asks (fmap moduleNameFromString . optionsMain)
86− (sorted, _) <- sortModules $ map importPrim $ if noPrelude then ms else map importPrelude ms
87− (desugared, nextVar) <- stringifyErrorStack True $ runSupplyT 0 $ desugar sorted
88− (elaborated, env') <- runCheck' env $ forM desugared $ typeCheckModule mainModuleIdent
89− regrouped <- stringifyErrorStack True $ createBindingGroupsModule . collapseBindingGroupsModule $ elaborated
90− let corefn = map (CoreFn.moduleToCoreFn env') regrouped
91− let entryPoints = moduleNameFromString `map` entryPointModules additional
92− let elim = if null entryPoints then corefn else eliminateDeadCode entryPoints corefn
93− let renamed = renameInModules elim
94− let codeGenModuleNames = moduleNameFromString `map` codeGenModules additional
95− let modulesToCodeGen = if null codeGenModuleNames then renamed else filter (\(CoreFn.Module mn _ _ _ _) -> mn `elem` codeGenModuleNames) renamed
96− js <- concat <$> (evalSupplyT nextVar $ T.traverse moduleToJs modulesToCodeGen)
97− let exts = intercalate "\n" . map (`moduleToPs` env') $ regrouped
98− js' <- generateMain env' js
99− let pjs = unlines $ map ("// " ++) prefix ++ [prettyPrintJS js']
100− return (pjs, exts, env')
101−
102−generateMain :: (MonadError String m, MonadReader (Options Compile) m) => Environment -> [JS] -> m [JS]
103−generateMain env js = do
104− main <- asks optionsMain
105− additional <- asks optionsAdditional
106− case moduleNameFromString <$> main of
107− Just mmi -> do
108− when ((mmi, Ident C.main) `M.notMember` names env) $
109− throwError $ show mmi ++ "." ++ C.main ++ " is undefined"
110− return $ js ++ [JSApp (JSAccessor C.main (JSAccessor (moduleNameToJs mmi) (JSVar (browserNamespace additional)))) []]
111− _ -> return js
112−
113−-- |
114−-- A type class which collects the IO actions we need to be able to run in "make" mode
115−--
116−class (MonadReader (P.Options P.Make) m, MonadError String m) => MonadMake m where
117− -- |
118− -- Get a file timestamp
119− --
120− getTimestamp :: FilePath -> m (Maybe UTCTime)
121−
122− -- |
123− -- Read a file as a string
124− --
125− readTextFile :: FilePath -> m String
126−
127− -- |
128− -- Write a text file
129− --
130− writeTextFile :: FilePath -> String -> m ()
131−
132− -- |
133− -- Respond to a progress update
134− --
135− progress :: String -> m ()
136−
137−-- |
138−-- Determines when to rebuild a module
139−--
140−data RebuildPolicy
141− -- | Never rebuild this module
142− = RebuildNever
143− -- | Always rebuild this module
144− | RebuildAlways deriving (Show, Eq, Ord)
145−
146−-- Traverse (Either e) instance (base 4.7)
147−traverseEither :: Applicative f => (a -> f b) -> Either e a -> f (Either e b)
148−traverseEither _ (Left x) = pure (Left x)
149−traverseEither f (Right y) = Right <$> f y
150−
151−-- |
152−-- Compiles in "make" mode, compiling each module separately to a js files and an externs file
153−--
154−-- If timestamps have not changed, the externs file can be used to provide the module's types without
155−-- having to typecheck the module again.
156−--
157−make :: (Functor m, Applicative m, Monad m, MonadMake m)
158− => FilePath -> [(Either RebuildPolicy FilePath, Module)] -> [String] -> m Environment
159−make outputDir ms prefix = do
160− noPrelude <- asks optionsNoPrelude
161− let filePathMap = M.fromList (map (\(fp, Module mn _ _) -> (mn, fp)) ms)
162−
163− (sorted, graph) <- sortModules $ map importPrim $ if noPrelude then map snd ms else map (importPrelude . snd) ms
164−
165− toRebuild <- foldM (\s (Module moduleName' _ _) -> do
166− let filePath = runModuleName moduleName'
167−
168− jsFile = outputDir </> filePath </> "index.js"
169− externsFile = outputDir </> filePath </> "externs.purs"
170− inputFile = fromMaybe (error "Module has no filename in 'make'") $ M.lookup moduleName' filePathMap
171−
172− jsTimestamp <- getTimestamp jsFile
173− externsTimestamp <- getTimestamp externsFile
174− inputTimestamp <- traverseEither getTimestamp inputFile
175−
176− return $ case (inputTimestamp, jsTimestamp, externsTimestamp) of
177− (Right (Just t1), Just t2, Just t3) | t1 < min t2 t3 -> s
178− (Left RebuildNever, Just _, Just _) -> s
179− _ -> S.insert moduleName' s) S.empty sorted
180−
181− marked <- rebuildIfNecessary (reverseDependencies graph) toRebuild sorted
182−
183− (desugared, nextVar) <- stringifyErrorStack True $ runSupplyT 0 $ zip (map fst marked) <$> desugar (map snd marked)
184−
185− evalSupplyT nextVar $ go initEnvironment desugared
186−
187− where
188− go :: (Functor m, Applicative m, Monad m, MonadMake m)
189− => Environment -> [(Bool, Module)] -> SupplyT m Environment
190− go env [] = return env
191− go env ((False, m) : ms') = do
192− (_, env') <- lift . runCheck' env $ typeCheckModule Nothing m
193−
194− go env' ms'
195− go env ((True, m@(Module moduleName' _ exps)) : ms') = do
196− let filePath = runModuleName moduleName'
197− jsFile = outputDir </> filePath </> "index.js"
198− externsFile = outputDir </> filePath </> "externs.purs"
199−
200− lift . progress $ "Compiling " ++ runModuleName moduleName'
201−
202− (Module _ elaborated _, env') <- lift . runCheck' env $ typeCheckModule Nothing m
203−
204− regrouped <- stringifyErrorStack True . createBindingGroups moduleName' . collapseBindingGroups $ elaborated
205−
206− let mod' = Module moduleName' regrouped exps
207− let corefn = CoreFn.moduleToCoreFn env' mod'
208− let [renamed] = renameInModules [corefn]
209−
210− pjs <- prettyPrintJS <$> moduleToJs renamed
211− let js = unlines $ map ("// " ++) prefix ++ [pjs]
212− let exts = unlines $ map ("-- " ++) prefix ++ [moduleToPs mod' env']
213−
214− lift $ writeTextFile jsFile js
215− lift $ writeTextFile externsFile exts
216−
217− go env' ms'
218−
219− rebuildIfNecessary :: (Functor m, Monad m, MonadMake m) => M.Map ModuleName [ModuleName] -> S.Set ModuleName -> [Module] -> m [(Bool, Module)]
220− rebuildIfNecessary _ _ [] = return []
221− rebuildIfNecessary graph toRebuild (m@(Module moduleName' _ _) : ms') | moduleName' `S.member` toRebuild = do
222− let deps = fromMaybe [] $ moduleName' `M.lookup` graph
223− toRebuild' = toRebuild `S.union` S.fromList deps
224− (:) (True, m) <$> rebuildIfNecessary graph toRebuild' ms'
225− rebuildIfNecessary graph toRebuild (Module moduleName' _ _ : ms') = do
226− let externsFile = outputDir </> runModuleName moduleName' </> "externs.purs"
227− externs <- readTextFile externsFile
228− externsModules <- fmap (map snd) . either (throwError . show) return $ P.parseModulesFromFiles id [(externsFile, externs)]
229− case externsModules of
230− [m'@(Module moduleName'' _ _)] | moduleName'' == moduleName' -> (:) (False, m') <$> rebuildIfNecessary graph toRebuild ms'
231− _ -> throwError $ "Externs file " ++ externsFile ++ " was invalid"
232−
233−reverseDependencies :: ModuleGraph -> M.Map ModuleName [ModuleName]
234−reverseDependencies g = combine [ (dep, mn) | (mn, deps) <- g, dep <- deps ]
235− where
236− combine :: (Ord a) => [(a, b)] -> M.Map a [b]
237− combine = M.fromList . map ((fst . head) &&& map snd) . groupBy ((==) `on` fst) . sortBy (compare `on` fst)
238−
239−-- |
240−-- Add an import declaration for a module if it does not already explicitly import it.
241−--
242−addDefaultImport :: ModuleName -> Module -> Module
243−addDefaultImport toImport m@(Module mn decls exps) =
244− if isExistingImport `any` decls || mn == toImport then m
245− else Module mn (ImportDeclaration toImport Unqualified Nothing : decls) exps
246− where
247− isExistingImport (ImportDeclaration mn' _ _) | mn' == toImport = True
248− isExistingImport (PositionedDeclaration _ _ d) = isExistingImport d
249− isExistingImport _ = False
250−
251−importPrim :: Module -> Module
252−importPrim = addDefaultImport (ModuleName [ProperName C.prim])
253−
254−importPrelude :: Module -> Module
255−importPrelude = addDefaultImport (ModuleName [ProperName C.prelude])
256−
257−prelude :: String
258−prelude = BU.toString $(embedFile "prelude/prelude.purs")
src/Language/PureScript/AST.hsdeleted−23
@@ -1,23 +0,0 @@
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
src/Language/PureScript/AST/Binders.hsdeleted−87
@@ -1,87 +0,0 @@
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 numeric literal
43− --
44− | NumberBinder (Either Integer Double)
45− -- |
46− -- A binder which binds an identifier
47− --
48− | VarBinder Ident
49− -- |
50− -- A binder which matches a data constructor
51− --
52− | ConstructorBinder (Qualified ProperName) [Binder]
53− -- |
54− -- A binder which matches a record and binds its properties
55− --
56− | ObjectBinder [(String, Binder)]
57− -- |
58− -- A binder which matches an array and binds its elements
59− --
60− | ArrayBinder [Binder]
61− -- |
62− -- A binder which matches an array and binds its head and tail
63− --
64− | ConsBinder Binder 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 (ConsBinder b1 b2) = go (go ns b1) b2
85− go ns (NamedBinder name b) = go (name : ns) b
86− go ns (PositionedBinder _ _ b) = go ns b
87− go ns _ = ns
src/Language/PureScript/AST/Declarations.hsdeleted−446
@@ -1,446 +0,0 @@
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−
21−import Language.PureScript.AST.Binders
22−import Language.PureScript.AST.Operators
23−import Language.PureScript.AST.SourcePos
24−import Language.PureScript.Types
25−import Language.PureScript.Names
26−import Language.PureScript.Kinds
27−import Language.PureScript.TypeClassDictionaries
28−import Language.PureScript.Comments
29−import Language.PureScript.CodeGen.JS.AST
30−import Language.PureScript.Environment
31−
32−-- |
33−-- A module declaration, consisting of a module name, a list of declarations, and a list of the
34−-- declarations that are explicitly exported. If the export list is Nothing, everything is exported.
35−--
36−data Module = Module ModuleName [Declaration] (Maybe [DeclarationRef]) deriving (Show, D.Data, D.Typeable)
37−
38−-- | Return a module's name.
39−getModuleName :: Module -> ModuleName
40−getModuleName (Module name _ _) = name
41−
42−-- |
43−-- Test if a declaration is exported, given a module's export list.
44−--
45−isExported :: Maybe [DeclarationRef] -> Declaration -> Bool
46−isExported Nothing _ = True
47−isExported _ TypeInstanceDeclaration{} = True
48−isExported exps (PositionedDeclaration _ _ d) = isExported exps d
49−isExported (Just exps) decl = any (matches decl) exps
50− where
51− matches (TypeDeclaration ident _) (ValueRef ident') = ident == ident'
52− matches (ValueDeclaration ident _ _ _) (ValueRef ident') = ident == ident'
53− matches (ExternDeclaration _ ident _ _) (ValueRef ident') = ident == ident'
54− matches (DataDeclaration _ ident _ _) (TypeRef ident' _) = ident == ident'
55− matches (ExternDataDeclaration ident _) (TypeRef ident' _) = ident == ident'
56− matches (TypeSynonymDeclaration ident _ _) (TypeRef ident' _) = ident == ident'
57− matches (TypeClassDeclaration ident _ _ _) (TypeClassRef ident') = ident == ident'
58− matches (PositionedDeclaration _ _ d) r = d `matches` r
59− matches d (PositionedDeclarationRef _ _ r) = d `matches` r
60− matches _ _ = False
61−
62−exportedDeclarations :: Module -> [Declaration]
63−exportedDeclarations (Module _ decls exps) = filter (isExported exps) (flattenDecls decls)
64−
65−-- |
66−-- Test if a data constructor for a given type is exported, given a module's export list.
67−--
68−isDctorExported :: ProperName -> Maybe [DeclarationRef] -> ProperName -> Bool
69−isDctorExported _ Nothing _ = True
70−isDctorExported ident (Just exps) ctor = test `any` exps
71− where
72− test (PositionedDeclarationRef _ _ d) = test d
73− test (TypeRef ident' Nothing) = ident == ident'
74− test (TypeRef ident' (Just ctors)) = ident == ident' && ctor `elem` ctors
75− test _ = False
76−
77−-- |
78−-- Return the exported data constructors for a given type.
79−--
80−exportedDctors :: Module -> ProperName -> [ProperName]
81−exportedDctors (Module _ decls exps) ident =
82− filter (isDctorExported ident exps) dctors
83− where
84− dctors = concatMap getDctors (flattenDecls decls)
85− getDctors (DataDeclaration _ _ _ ctors) = map fst ctors
86− getDctors (PositionedDeclaration _ _ d) = getDctors d
87− getDctors _ = []
88−
89−-- |
90−-- An item in a list of explicit imports or exports
91−--
92−data DeclarationRef
93− -- |
94− -- A type constructor with data constructors
95− --
96− = TypeRef ProperName (Maybe [ProperName])
97− -- |
98− -- A value
99− --
100− | ValueRef Ident
101− -- |
102− -- A type class
103− --
104− | TypeClassRef ProperName
105− -- |
106− -- A type class instance, created during typeclass desugaring (name, class name, instance types)
107− --
108− | TypeInstanceRef Ident
109− -- |
110− -- A declaration reference with source position information
111− --
112− | PositionedDeclarationRef SourceSpan [Comment] DeclarationRef
113− deriving (Show, D.Data, D.Typeable)
114−
115−instance Eq DeclarationRef where
116− (TypeRef name dctors) == (TypeRef name' dctors') = name == name' && dctors == dctors'
117− (ValueRef name) == (ValueRef name') = name == name'
118− (TypeClassRef name) == (TypeClassRef name') = name == name'
119− (TypeInstanceRef name) == (TypeInstanceRef name') = name == name'
120− (PositionedDeclarationRef _ _ r) == r' = r == r'
121− r == (PositionedDeclarationRef _ _ r') = r == r'
122− _ == _ = False
123−
124−-- |
125−-- The data type which specifies type of import declaration
126−--
127−data ImportDeclarationType
128− -- |
129− -- Unqualified import
130− --
131− = Unqualified
132− -- |
133− -- Qualified import with a list of references to import
134− --
135− | Qualifying [DeclarationRef]
136− -- |
137− -- Import with hiding clause with a list of references to hide
138− --
139− | Hiding [DeclarationRef]
140− deriving (Show, D.Data, D.Typeable)
141−
142−-- |
143−-- The data type of declarations
144−--
145−data Declaration
146− -- |
147− -- A data type declaration (data or newtype, name, arguments, data constructors)
148− --
149− = DataDeclaration DataDeclType ProperName [(String, Maybe Kind)] [(ProperName, [Type])]
150− -- |
151− -- A minimal mutually recursive set of data type declarations
152− --
153− | DataBindingGroupDeclaration [Declaration]
154− -- |
155− -- A type synonym declaration (name, arguments, type)
156− --
157− | TypeSynonymDeclaration ProperName [(String, Maybe Kind)] Type
158− -- |
159− -- A type declaration for a value (name, ty)
160− --
161− | TypeDeclaration Ident Type
162− -- |
163− -- A value declaration (name, top-level binders, optional guard, value)
164− --
165− | ValueDeclaration Ident NameKind [Binder] (Either [(Guard, Expr)] Expr)
166− -- |
167− -- A minimal mutually recursive set of value declarations
168− --
169− | BindingGroupDeclaration [(Ident, NameKind, Expr)]
170− -- |
171− -- A foreign import declaration (type, name, optional inline Javascript, type)
172− --
173− | ExternDeclaration ForeignImportType Ident (Maybe JS) Type
174− -- |
175− -- A data type foreign import (name, kind)
176− --
177− | ExternDataDeclaration ProperName Kind
178− -- |
179− -- A type class instance foreign import
180− --
181− | ExternInstanceDeclaration Ident [Constraint] (Qualified ProperName) [Type]
182− -- |
183− -- A fixity declaration (fixity data, operator name)
184− --
185− | FixityDeclaration Fixity String
186− -- |
187− -- A module import (module name, qualified/unqualified/hiding, optional "qualified as" name)
188− --
189− | ImportDeclaration ModuleName ImportDeclarationType (Maybe ModuleName)
190− -- |
191− -- A type class declaration (name, argument, implies, member declarations)
192− --
193− | TypeClassDeclaration ProperName [(String, Maybe Kind)] [Constraint] [Declaration]
194− -- |
195− -- A type instance declaration (name, dependencies, class name, instance types, member
196− -- declarations)
197− --
198− | TypeInstanceDeclaration Ident [Constraint] (Qualified ProperName) [Type] [Declaration]
199− -- |
200− -- A declaration with source position information
201− --
202− | PositionedDeclaration SourceSpan [Comment] Declaration
203− deriving (Show, D.Data, D.Typeable)
204−
205−-- |
206−-- Test if a declaration is a value declaration
207−--
208−isValueDecl :: Declaration -> Bool
209−isValueDecl ValueDeclaration{} = True
210−isValueDecl (PositionedDeclaration _ _ d) = isValueDecl d
211−isValueDecl _ = False
212−
213−-- |
214−-- Test if a declaration is a data type or type synonym declaration
215−--
216−isDataDecl :: Declaration -> Bool
217−isDataDecl DataDeclaration{} = True
218−isDataDecl TypeSynonymDeclaration{} = True
219−isDataDecl (PositionedDeclaration _ _ d) = isDataDecl d
220−isDataDecl _ = False
221−
222−-- |
223−-- Test if a declaration is a module import
224−--
225−isImportDecl :: Declaration -> Bool
226−isImportDecl ImportDeclaration{} = True
227−isImportDecl (PositionedDeclaration _ _ d) = isImportDecl d
228−isImportDecl _ = False
229−
230−-- |
231−-- Test if a declaration is a data type foreign import
232−--
233−isExternDataDecl :: Declaration -> Bool
234−isExternDataDecl ExternDataDeclaration{} = True
235−isExternDataDecl (PositionedDeclaration _ _ d) = isExternDataDecl d
236−isExternDataDecl _ = False
237−
238−-- |
239−-- Test if a declaration is a type class instance foreign import
240−--
241−isExternInstanceDecl :: Declaration -> Bool
242−isExternInstanceDecl ExternInstanceDeclaration{} = True
243−isExternInstanceDecl (PositionedDeclaration _ _ d) = isExternInstanceDecl d
244−isExternInstanceDecl _ = False
245−
246−-- |
247−-- Test if a declaration is a fixity declaration
248−--
249−isFixityDecl :: Declaration -> Bool
250−isFixityDecl FixityDeclaration{} = True
251−isFixityDecl (PositionedDeclaration _ _ d) = isFixityDecl d
252−isFixityDecl _ = False
253−
254−-- |
255−-- Test if a declaration is a foreign import
256−--
257−isExternDecl :: Declaration -> Bool
258−isExternDecl ExternDeclaration{} = True
259−isExternDecl (PositionedDeclaration _ _ d) = isExternDecl d
260−isExternDecl _ = False
261−
262−-- |
263−-- Test if a declaration is a type class or instance declaration
264−--
265−isTypeClassDeclaration :: Declaration -> Bool
266−isTypeClassDeclaration TypeClassDeclaration{} = True
267−isTypeClassDeclaration TypeInstanceDeclaration{} = True
268−isTypeClassDeclaration (PositionedDeclaration _ _ d) = isTypeClassDeclaration d
269−isTypeClassDeclaration _ = False
270−
271−-- |
272−-- Recursively flatten data binding groups in the list of declarations
273−flattenDecls :: [Declaration] -> [Declaration]
274−flattenDecls = concatMap flattenOne
275− where flattenOne :: Declaration -> [Declaration]
276− flattenOne (DataBindingGroupDeclaration decls) = concatMap flattenOne decls
277− flattenOne d = [d]
278−
279−-- |
280−-- A guard is just a boolean-valued expression that appears alongside a set of binders
281−--
282−type Guard = Expr
283−
284−-- |
285−-- Data type for expressions and terms
286−--
287−data Expr
288− -- |
289− -- A numeric literal
290− --
291− = NumericLiteral (Either Integer Double)
292− -- |
293− -- A string literal
294− --
295− | StringLiteral String
296− -- |
297− -- A boolean literal
298− --
299− | BooleanLiteral Bool
300− -- |
301− -- A prefix -, will be desugared
302− --
303− | UnaryMinus Expr
304− -- |
305− -- Binary operator application. During the rebracketing phase of desugaring, this data constructor
306− -- will be removed.
307− --
308− | BinaryNoParens Expr Expr Expr
309− -- |
310− -- Explicit parentheses. During the rebracketing phase of desugaring, this data constructor
311− -- will be removed.
312− --
313− | Parens Expr
314− -- |
315− -- Operator section. This will be removed during desugaring and replaced with a partially applied
316− -- operator or lambda to flip the arguments.
317− --
318− | OperatorSection Expr (Either Expr Expr)
319− -- |
320− -- An array literal
321− --
322− | ArrayLiteral [Expr]
323− -- |
324− -- An object literal
325− --
326− | ObjectLiteral [(String, Expr)]
327− -- |
328− -- An object constructor (object literal with underscores). This will be removed during
329− -- desugaring and expanded into a lambda that returns an object literal.
330− --
331− | ObjectConstructor [(String, Maybe Expr)]
332− -- |
333− -- An object property getter (e.g. `_.x`). This will be removed during
334− -- desugaring and expanded into a lambda that reads a property from an object.
335− --
336− | ObjectGetter String
337− -- |
338− -- An record property accessor expression
339− --
340− | Accessor String Expr
341− -- |
342− -- Partial record update
343− --
344− | ObjectUpdate Expr [(String, Expr)]
345− -- |
346− -- Partial record updater. This will be removed during desugaring and
347− -- expanded into a lambda that returns an object update.
348− --
349− | ObjectUpdater (Maybe Expr) [(String, Maybe Expr)]
350− -- |
351− -- Function introduction
352− --
353− | Abs (Either Ident Binder) Expr
354− -- |
355− -- Function application
356− --
357− | App Expr Expr
358− -- |
359− -- Variable
360− --
361− | Var (Qualified Ident)
362− -- |
363− -- Conditional (if-then-else expression)
364− --
365− | IfThenElse Expr Expr Expr
366− -- |
367− -- A data constructor
368− --
369− | Constructor (Qualified ProperName)
370− -- |
371− -- A case expression. During the case expansion phase of desugaring, top-level binders will get
372− -- desugared into case expressions, hence the need for guards and multiple binders per branch here.
373− --
374− | Case [Expr] [CaseAlternative]
375− -- |
376− -- A value with a type annotation
377− --
378− | TypedValue Bool Expr Type
379− -- |
380− -- A let binding
381− --
382− | Let [Declaration] Expr
383− -- |
384− -- A do-notation block
385− --
386− | Do [DoNotationElement]
387− -- |
388− -- An application of a typeclass dictionary constructor. The value should be
389− -- an ObjectLiteral.
390− --
391− | TypeClassDictionaryConstructorApp (Qualified ProperName) Expr
392− -- |
393− -- A placeholder for a type class dictionary to be inserted later. At the end of type checking, these
394− -- placeholders will be replaced with actual expressions representing type classes dictionaries which
395− -- can be evaluated at runtime. The constructor arguments represent (in order): whether or not to look
396− -- at superclass implementations when searching for a dictionary, the type class name and
397− -- instance type, and the type class dictionaries in scope.
398− --
399− | TypeClassDictionary Bool Constraint [TypeClassDictionaryInScope]
400− -- |
401− -- A typeclass dictionary accessor, the implementation is left unspecified until CoreFn desugaring.
402− --
403− | TypeClassDictionaryAccessor (Qualified ProperName) Ident
404− -- |
405− -- A placeholder for a superclass dictionary to be turned into a TypeClassDictionary during typechecking
406− --
407− | SuperClassDictionary (Qualified ProperName) [Type]
408− -- |
409− -- A value with source position information
410− --
411− | PositionedValue SourceSpan [Comment] Expr deriving (Show, D.Data, D.Typeable)
412−
413−-- |
414−-- An alternative in a case statement
415−--
416−data CaseAlternative = CaseAlternative
417− { -- |
418− -- A collection of binders with which to match the inputs
419− --
420− caseAlternativeBinders :: [Binder]
421− -- |
422− -- The result expression or a collect of guarded expressions
423− --
424− , caseAlternativeResult :: Either [(Guard, Expr)] Expr
425− } deriving (Show, D.Data, D.Typeable)
426−
427−-- |
428−-- A statement in a do-notation block
429−--
430−data DoNotationElement
431− -- |
432− -- A monadic value without a binder
433− --
434− = DoNotationValue Expr
435− -- |
436− -- A monadic value with a binder
437− --
438− | DoNotationBind Binder Expr
439− -- |
440− -- A let statement, i.e. a pure value with a binder
441− --
442− | DoNotationLet [Declaration]
443− -- |
444− -- A do notation element with source position information
445− --
446− | PositionedDoNotationElement SourceSpan [Comment] DoNotationElement deriving (Show, D.Data, D.Typeable)
src/Language/PureScript/AST/Operators.hsdeleted−39
@@ -1,39 +0,0 @@
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 DeriveDataTypeable #-}
16−
17−module Language.PureScript.AST.Operators where
18−
19−import qualified Data.Data as D
20−
21−-- |
22−-- A precedence level for an infix operator
23−--
24−type Precedence = Integer
25−
26−-- |
27−-- Associativity for infix operators
28−--
29−data Associativity = Infixl | Infixr | Infix deriving (D.Data, D.Typeable)
30−
31−instance Show Associativity where
32− show Infixl = "infixl"
33− show Infixr = "infixr"
34− show Infix = "infix"
35−
36−-- |
37−-- Fixity data for infix operators
38−--
39−data Fixity = Fixity Associativity Precedence deriving (Show, D.Data, D.Typeable)
src/Language/PureScript/AST/SourcePos.hsdeleted−53
@@ -1,53 +0,0 @@
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 #-}
16−
17−module Language.PureScript.AST.SourcePos where
18−
19−import qualified Data.Data as D
20−
21−-- |
22−-- Source position information
23−--
24−data SourcePos = SourcePos
25− { -- |
26− -- Line number
27− --
28− sourcePosLine :: Int
29− -- |
30− -- Column number
31− --
32− , sourcePosColumn :: Int
33− } deriving (D.Data, D.Typeable)
34−
35−instance Show SourcePos where
36− show sp = "line " ++ show (sourcePosLine sp) ++ ", column " ++ show (sourcePosColumn sp)
37−
38−data SourceSpan = SourceSpan
39− { -- |
40− -- Source name
41− --
42− spanName :: String
43− -- |
44− -- Start of the span
45− --
46− , spanStart :: SourcePos
47− -- End of the span
48− --
49− , spanEnd :: SourcePos
50− } deriving (D.Data, D.Typeable)
51−
52−instance Show SourceSpan where
53− show sp = spanName sp ++ " " ++ show (spanStart sp) ++ " - " ++ show (spanEnd sp)
src/Language/PureScript/AST/Traversals.hsdeleted−407
@@ -1,407 +0,0 @@
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' (ConsBinder b1 b2) = h (ConsBinder (h' b1) (h' b2))
72− h' (NamedBinder name b) = h (NamedBinder name (h' b))
73− h' (PositionedBinder pos com b) = h (PositionedBinder pos com (h' b))
74− h' other = h other
75−
76− handleCaseAlternative :: CaseAlternative -> CaseAlternative
77− handleCaseAlternative ca =
78− ca { caseAlternativeBinders = map h' (caseAlternativeBinders ca)
79− , caseAlternativeResult = (map (g' *** g') +++ g') (caseAlternativeResult ca)
80− }
81−
82− handleDoNotationElement :: DoNotationElement -> DoNotationElement
83− handleDoNotationElement (DoNotationValue v) = DoNotationValue (g' v)
84− handleDoNotationElement (DoNotationBind b v) = DoNotationBind (h' b) (g' v)
85− handleDoNotationElement (DoNotationLet ds) = DoNotationLet (map f' ds)
86− handleDoNotationElement (PositionedDoNotationElement pos com e) = PositionedDoNotationElement pos com (handleDoNotationElement e)
87−
88−everywhereOnValuesTopDownM :: (Functor m, Applicative m, Monad m) =>
89− (Declaration -> m Declaration) ->
90− (Expr -> m Expr) ->
91− (Binder -> m Binder) ->
92− (Declaration -> m Declaration, Expr -> m Expr, Binder -> m Binder)
93−everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h)
94− where
95− f' (DataBindingGroupDeclaration ds) = DataBindingGroupDeclaration <$> mapM (f' <=< f) ds
96− f' (ValueDeclaration name nameKind bs val) = ValueDeclaration name nameKind <$> mapM (h' <=< h) bs <*> eitherM (mapM (pairM (g' <=< g) (g' <=< g))) (g' <=< g) val
97− f' (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> mapM (\(name, nameKind, val) -> (,,) name nameKind <$> (g val >>= g')) ds
98− f' (TypeClassDeclaration name args implies ds) = TypeClassDeclaration name args implies <$> mapM (f' <=< f) ds
99− f' (TypeInstanceDeclaration name cs className args ds) = TypeInstanceDeclaration name cs className args <$> mapM (f' <=< f) ds
100− f' (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> (f d >>= f')
101− f' other = f other
102−
103− g' (UnaryMinus v) = UnaryMinus <$> (g v >>= g')
104− g' (BinaryNoParens op v1 v2) = BinaryNoParens <$> (g op >>= g') <*> (g v1 >>= g') <*> (g v2 >>= g')
105− g' (Parens v) = Parens <$> (g v >>= g')
106− g' (OperatorSection op (Left v)) = OperatorSection <$> (g op >>= g') <*> (Left <$> (g v >>= g'))
107− g' (OperatorSection op (Right v)) = OperatorSection <$> (g op >>= g') <*> (Right <$> (g v >>= g'))
108− g' (ArrayLiteral vs) = ArrayLiteral <$> mapM (g' <=< g) vs
109− g' (ObjectLiteral vs) = ObjectLiteral <$> mapM (sndM (g' <=< g)) vs
110− g' (ObjectConstructor vs) = ObjectConstructor <$> mapM (sndM $ maybeM (g' <=< g)) vs
111− g' (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> (g v >>= g')
112− g' (Accessor prop v) = Accessor prop <$> (g v >>= g')
113− g' (ObjectUpdate obj vs) = ObjectUpdate <$> (g obj >>= g') <*> mapM (sndM (g' <=< g)) vs
114− g' (ObjectUpdater obj vs) = ObjectUpdater <$> (maybeM g obj >>= maybeM g') <*> mapM (sndM $ maybeM (g' <=< g)) vs
115− g' (Abs name v) = Abs name <$> (g v >>= g')
116− g' (App v1 v2) = App <$> (g v1 >>= g') <*> (g v2 >>= g')
117− g' (IfThenElse v1 v2 v3) = IfThenElse <$> (g v1 >>= g') <*> (g v2 >>= g') <*> (g v3 >>= g')
118− g' (Case vs alts) = Case <$> mapM (g' <=< g) vs <*> mapM handleCaseAlternative alts
119− g' (TypedValue check v ty) = TypedValue check <$> (g v >>= g') <*> pure ty
120− g' (Let ds v) = Let <$> mapM (f' <=< f) ds <*> (g v >>= g')
121− g' (Do es) = Do <$> mapM handleDoNotationElement es
122− g' (PositionedValue pos com v) = PositionedValue pos com <$> (g v >>= g')
123− g' other = g other
124−
125− h' (ConstructorBinder ctor bs) = ConstructorBinder ctor <$> mapM (h' <=< h) bs
126− h' (ObjectBinder bs) = ObjectBinder <$> mapM (sndM (h' <=< h)) bs
127− h' (ArrayBinder bs) = ArrayBinder <$> mapM (h' <=< h) bs
128− h' (ConsBinder b1 b2) = ConsBinder <$> (h b1 >>= h') <*> (h b2 >>= h')
129− h' (NamedBinder name b) = NamedBinder name <$> (h b >>= h')
130− h' (PositionedBinder pos com b) = PositionedBinder pos com <$> (h b >>= h')
131− h' other = h other
132−
133− handleCaseAlternative (CaseAlternative bs val) = CaseAlternative <$> mapM (h' <=< h) bs
134− <*> eitherM (mapM (pairM (g' <=< g) (g' <=< g))) (g' <=< g) val
135−
136− handleDoNotationElement (DoNotationValue v) = DoNotationValue <$> (g' <=< g) v
137− handleDoNotationElement (DoNotationBind b v) = DoNotationBind <$> (h' <=< h) b <*> (g' <=< g) v
138− handleDoNotationElement (DoNotationLet ds) = DoNotationLet <$> mapM (f' <=< f) ds
139− handleDoNotationElement (PositionedDoNotationElement pos com e) = PositionedDoNotationElement pos com <$> handleDoNotationElement e
140−
141−everywhereOnValuesM :: (Functor m, Applicative m, Monad m) =>
142− (Declaration -> m Declaration) ->
143− (Expr -> m Expr) ->
144− (Binder -> m Binder) ->
145− (Declaration -> m Declaration, Expr -> m Expr, Binder -> m Binder)
146−everywhereOnValuesM f g h = (f', g', h')
147− where
148− f' (DataBindingGroupDeclaration ds) = (DataBindingGroupDeclaration <$> mapM f' ds) >>= f
149− f' (ValueDeclaration name nameKind bs val) = (ValueDeclaration name nameKind <$> mapM h' bs <*> eitherM (mapM (pairM g' g')) g' val) >>= f
150− f' (BindingGroupDeclaration ds) = (BindingGroupDeclaration <$> mapM (\(name, nameKind, val) -> (,,) name nameKind <$> g' val) ds) >>= f
151− f' (TypeClassDeclaration name args implies ds) = (TypeClassDeclaration name args implies <$> mapM f' ds) >>= f
152− f' (TypeInstanceDeclaration name cs className args ds) = (TypeInstanceDeclaration name cs className args <$> mapM f' ds) >>= f
153− f' (PositionedDeclaration pos com d) = (PositionedDeclaration pos com <$> f' d) >>= f
154− f' other = f other
155−
156− g' (UnaryMinus v) = (UnaryMinus <$> g' v) >>= g
157− g' (BinaryNoParens op v1 v2) = (BinaryNoParens <$> g' op <*> g' v1 <*> g' v2) >>= g
158− g' (Parens v) = (Parens <$> g' v) >>= g
159− g' (OperatorSection op (Left v)) = (OperatorSection <$> g' op <*> (Left <$> g' v)) >>= g
160− g' (OperatorSection op (Right v)) = (OperatorSection <$> g' op <*> (Right <$> g' v)) >>= g
161− g' (ArrayLiteral vs) = (ArrayLiteral <$> mapM g' vs) >>= g
162− g' (ObjectLiteral vs) = (ObjectLiteral <$> mapM (sndM g') vs) >>= g
163− g' (ObjectConstructor vs) = (ObjectConstructor <$> mapM (sndM $ maybeM g') vs) >>= g
164− g' (TypeClassDictionaryConstructorApp name v) = (TypeClassDictionaryConstructorApp name <$> g' v) >>= g
165− g' (Accessor prop v) = (Accessor prop <$> g' v) >>= g
166− g' (ObjectUpdate obj vs) = (ObjectUpdate <$> g' obj <*> mapM (sndM g') vs) >>= g
167− g' (ObjectUpdater obj vs) = (ObjectUpdater <$> maybeM g' obj <*> mapM (sndM $ maybeM g') vs) >>= g
168− g' (Abs name v) = (Abs name <$> g' v) >>= g
169− g' (App v1 v2) = (App <$> g' v1 <*> g' v2) >>= g
170− g' (IfThenElse v1 v2 v3) = (IfThenElse <$> g' v1 <*> g' v2 <*> g' v3) >>= g
171− g' (Case vs alts) = (Case <$> mapM g' vs <*> mapM handleCaseAlternative alts) >>= g
172− g' (TypedValue check v ty) = (TypedValue check <$> g' v <*> pure ty) >>= g
173− g' (Let ds v) = (Let <$> mapM f' ds <*> g' v) >>= g
174− g' (Do es) = (Do <$> mapM handleDoNotationElement es) >>= g
175− g' (PositionedValue pos com v) = (PositionedValue pos com <$> g' v) >>= g
176− g' other = g other
177−
178− h' (ConstructorBinder ctor bs) = (ConstructorBinder ctor <$> mapM h' bs) >>= h
179− h' (ObjectBinder bs) = (ObjectBinder <$> mapM (sndM h') bs) >>= h
180− h' (ArrayBinder bs) = (ArrayBinder <$> mapM h' bs) >>= h
181− h' (ConsBinder b1 b2) = (ConsBinder <$> h' b1 <*> h' b2) >>= h
182− h' (NamedBinder name b) = (NamedBinder name <$> h' b) >>= h
183− h' (PositionedBinder pos com b) = (PositionedBinder pos com <$> h' b) >>= h
184− h' other = h other
185−
186− handleCaseAlternative (CaseAlternative bs val) = CaseAlternative <$> mapM h' bs
187− <*> eitherM (mapM (pairM g' g')) g' val
188−
189− handleDoNotationElement (DoNotationValue v) = DoNotationValue <$> g' v
190− handleDoNotationElement (DoNotationBind b v) = DoNotationBind <$> h' b <*> g' v
191− handleDoNotationElement (DoNotationLet ds) = DoNotationLet <$> mapM f' ds
192− handleDoNotationElement (PositionedDoNotationElement pos com e) = PositionedDoNotationElement pos com <$> handleDoNotationElement e
193−
194−everythingOnValues :: (r -> r -> r) ->
195− (Declaration -> r) ->
196− (Expr -> r) ->
197− (Binder -> r) ->
198− (CaseAlternative -> r) ->
199− (DoNotationElement -> r) ->
200− (Declaration -> r, Expr -> r, Binder -> r, CaseAlternative -> r, DoNotationElement -> r)
201−everythingOnValues (<>) f g h i j = (f', g', h', i', j')
202− where
203− f' d@(DataBindingGroupDeclaration ds) = foldl (<>) (f d) (map f' ds)
204− f' d@(ValueDeclaration _ _ bs (Right val)) = foldl (<>) (f d) (map h' bs) <> g' val
205− f' d@(ValueDeclaration _ _ bs (Left gs)) = foldl (<>) (f d) (map h' bs ++ concatMap (\(grd, val) -> [g' grd, g' val]) gs)
206− f' d@(BindingGroupDeclaration ds) = foldl (<>) (f d) (map (\(_, _, val) -> g' val) ds)
207− f' d@(TypeClassDeclaration _ _ _ ds) = foldl (<>) (f d) (map f' ds)
208− f' d@(TypeInstanceDeclaration _ _ _ _ ds) = foldl (<>) (f d) (map f' ds)
209− f' d@(PositionedDeclaration _ _ d1) = f d <> f' d1
210− f' d = f d
211−
212− g' v@(UnaryMinus v1) = g v <> g' v1
213− g' v@(BinaryNoParens op v1 v2) = g v <> g op <> g' v1 <> g' v2
214− g' v@(Parens v1) = g v <> g' v1
215− g' v@(OperatorSection op (Left v1)) = g v <> g op <> g' v1
216− g' v@(OperatorSection op (Right v1)) = g v <> g op <> g' v1
217− g' v@(ArrayLiteral vs) = foldl (<>) (g v) (map g' vs)
218− g' v@(ObjectLiteral vs) = foldl (<>) (g v) (map (g' . snd) vs)
219− g' v@(ObjectConstructor vs) = foldl (<>) (g v) (map g' (mapMaybe snd vs))
220− g' v@(TypeClassDictionaryConstructorApp _ v1) = g v <> g' v1
221− g' v@(Accessor _ v1) = g v <> g' v1
222− g' v@(ObjectUpdate obj vs) = foldl (<>) (g v <> g' obj) (map (g' . snd) vs)
223− g' v@(ObjectUpdater obj vs) = foldl (<>) (maybe (g v) (\x -> g v <> g' x) obj) (map g' (mapMaybe snd vs))
224− g' v@(Abs _ v1) = g v <> g' v1
225− g' v@(App v1 v2) = g v <> g' v1 <> g' v2
226− g' v@(IfThenElse v1 v2 v3) = g v <> g' v1 <> g' v2 <> g' v3
227− g' v@(Case vs alts) = foldl (<>) (foldl (<>) (g v) (map g' vs)) (map i' alts)
228− g' v@(TypedValue _ v1 _) = g v <> g' v1
229− g' v@(Let ds v1) = foldl (<>) (g v) (map f' ds) <> g' v1
230− g' v@(Do es) = foldl (<>) (g v) (map j' es)
231− g' v@(PositionedValue _ _ v1) = g v <> g' v1
232− g' v = g v
233−
234− h' b@(ConstructorBinder _ bs) = foldl (<>) (h b) (map h' bs)
235− h' b@(ObjectBinder bs) = foldl (<>) (h b) (map (h' . snd) bs)
236− h' b@(ArrayBinder bs) = foldl (<>) (h b) (map h' bs)
237− h' b@(ConsBinder b1 b2) = h b <> h' b1 <> h' b2
238− h' b@(NamedBinder _ b1) = h b <> h' b1
239− h' b@(PositionedBinder _ _ b1) = h b <> h' b1
240− h' b = h b
241−
242− i' ca@(CaseAlternative bs (Right val)) = foldl (<>) (i ca) (map h' bs) <> g' val
243− i' ca@(CaseAlternative bs (Left gs)) = foldl (<>) (i ca) (map h' bs ++ concatMap (\(grd, val) -> [g' grd, g' val]) gs)
244−
245− j' e@(DoNotationValue v) = j e <> g' v
246− j' e@(DoNotationBind b v) = j e <> h' b <> g' v
247− j' e@(DoNotationLet ds) = foldl (<>) (j e) (map f' ds)
248− j' e@(PositionedDoNotationElement _ _ e1) = j e <> j' e1
249−
250−everythingWithContextOnValues ::
251− s ->
252− r ->
253− (r -> r -> r) ->
254− (s -> Declaration -> (s, r)) ->
255− (s -> Expr -> (s, r)) ->
256− (s -> Binder -> (s, r)) ->
257− (s -> CaseAlternative -> (s, r)) ->
258− (s -> DoNotationElement -> (s, r)) ->
259− ( Declaration -> r
260− , Expr -> r
261− , Binder -> r
262− , CaseAlternative -> r
263− , DoNotationElement -> r)
264−everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j'' s0)
265− where
266− f'' s d = let (s', r) = f s d in r <> f' s' d
267−
268− f' s (DataBindingGroupDeclaration ds) = foldl (<>) r0 (map (f'' s) ds)
269− f' s (ValueDeclaration _ _ bs (Right val)) = foldl (<>) r0 (map (h'' s) bs) <> g'' s val
270− f' s (ValueDeclaration _ _ bs (Left gs)) = foldl (<>) r0 (map (h'' s) bs ++ concatMap (\(grd, val) -> [g'' s grd, g'' s val]) gs)
271− f' s (BindingGroupDeclaration ds) = foldl (<>) r0 (map (\(_, _, val) -> g'' s val) ds)
272− f' s (TypeClassDeclaration _ _ _ ds) = foldl (<>) r0 (map (f'' s) ds)
273− f' s (TypeInstanceDeclaration _ _ _ _ ds) = foldl (<>) r0 (map (f'' s) ds)
274− f' s (PositionedDeclaration _ _ d1) = f'' s d1
275− f' _ _ = r0
276−
277− g'' s v = let (s', r) = g s v in r <> g' s' v
278−
279− g' s (UnaryMinus v1) = g'' s v1
280− g' s (BinaryNoParens op v1 v2) = g'' s op <> g'' s v1 <> g'' s v2
281− g' s (Parens v1) = g'' s v1
282− g' s (OperatorSection op (Left v)) = g'' s op <> g'' s v
283− g' s (OperatorSection op (Right v)) = g'' s op <> g'' s v
284− g' s (ArrayLiteral vs) = foldl (<>) r0 (map (g'' s) vs)
285− g' s (ObjectLiteral vs) = foldl (<>) r0 (map (g'' s . snd) vs)
286− g' s (ObjectConstructor vs) = foldl (<>) r0 (map (g'' s) (mapMaybe snd vs))
287− g' s (TypeClassDictionaryConstructorApp _ v1) = g'' s v1
288− g' s (Accessor _ v1) = g'' s v1
289− g' s (ObjectUpdate obj vs) = foldl (<>) (g'' s obj) (map (g'' s . snd) vs)
290− g' s (ObjectUpdater obj vs) = foldl (<>) (maybe r0 (g'' s) obj) (map (g'' s) (mapMaybe snd vs))
291− g' s (Abs _ v1) = g'' s v1
292− g' s (App v1 v2) = g'' s v1 <> g'' s v2
293− g' s (IfThenElse v1 v2 v3) = g'' s v1 <> g'' s v2 <> g'' s v3
294− g' s (Case vs alts) = foldl (<>) (foldl (<>) r0 (map (g'' s) vs)) (map (i'' s) alts)
295− g' s (TypedValue _ v1 _) = g'' s v1
296− g' s (Let ds v1) = foldl (<>) r0 (map (f'' s) ds) <> g'' s v1
297− g' s (Do es) = foldl (<>) r0 (map (j'' s) es)
298− g' s (PositionedValue _ _ v1) = g'' s v1
299− g' _ _ = r0
300−
301− h'' s b = let (s', r) = h s b in r <> h' s' b
302−
303− h' s (ConstructorBinder _ bs) = foldl (<>) r0 (map (h'' s) bs)
304− h' s (ObjectBinder bs) = foldl (<>) r0 (map (h'' s . snd) bs)
305− h' s (ArrayBinder bs) = foldl (<>) r0 (map (h'' s) bs)
306− h' s (ConsBinder b1 b2) = h'' s b1 <> h'' s b2
307− h' s (NamedBinder _ b1) = h'' s b1
308− h' s (PositionedBinder _ _ b1) = h'' s b1
309− h' _ _ = r0
310−
311− i'' s ca = let (s', r) = i s ca in r <> i' s' ca
312−
313− i' s (CaseAlternative bs (Right val)) = foldl (<>) r0 (map (h'' s) bs) <> g'' s val
314− i' s (CaseAlternative bs (Left gs)) = foldl (<>) r0 (map (h'' s) bs ++ concatMap (\(grd, val) -> [g'' s grd, g'' s val]) gs)
315−
316− j'' s e = let (s', r) = j s e in r <> j' s' e
317−
318− j' s (DoNotationValue v) = g'' s v
319− j' s (DoNotationBind b v) = h'' s b <> g'' s v
320− j' s (DoNotationLet ds) = foldl (<>) r0 (map (f'' s) ds)
321− j' s (PositionedDoNotationElement _ _ e1) = j'' s e1
322−
323−everywhereWithContextOnValuesM :: (Functor m, Applicative m, Monad m) =>
324− s ->
325− (s -> Declaration -> m (s, Declaration)) ->
326− (s -> Expr -> m (s, Expr)) ->
327− (s -> Binder -> m (s, Binder)) ->
328− (s -> CaseAlternative -> m (s, CaseAlternative)) ->
329− (s -> DoNotationElement -> m (s, DoNotationElement)) ->
330− ( Declaration -> m Declaration
331− , Expr -> m Expr
332− , Binder -> m Binder
333− , CaseAlternative -> m CaseAlternative
334− , DoNotationElement -> m DoNotationElement)
335−everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j'' s0)
336− where
337− f'' s = uncurry f' <=< f s
338−
339− f' s (DataBindingGroupDeclaration ds) = DataBindingGroupDeclaration <$> mapM (f'' s) ds
340− f' s (ValueDeclaration name nameKind bs val) = ValueDeclaration name nameKind <$> mapM (h'' s) bs <*> eitherM (mapM (pairM (g'' s) (g'' s))) (g'' s) val
341− f' s (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> mapM (thirdM (g'' s)) ds
342− f' s (TypeClassDeclaration name args implies ds) = TypeClassDeclaration name args implies <$> mapM (f'' s) ds
343− f' s (TypeInstanceDeclaration name cs className args ds) = TypeInstanceDeclaration name cs className args <$> mapM (f'' s) ds
344− f' s (PositionedDeclaration pos com d1) = PositionedDeclaration pos com <$> f'' s d1
345− f' _ other = return other
346−
347− g'' s = uncurry g' <=< g s
348−
349− g' s (UnaryMinus v) = UnaryMinus <$> g'' s v
350− g' s (BinaryNoParens op v1 v2) = BinaryNoParens <$> g'' s op <*> g'' s v1 <*> g'' s v2
351− g' s (Parens v) = Parens <$> g'' s v
352− g' s (OperatorSection op (Left v)) = OperatorSection <$> g'' s op <*> (Left <$> g'' s v)
353− g' s (OperatorSection op (Right v)) = OperatorSection <$> g'' s op <*> (Right <$> g'' s v)
354− g' s (ArrayLiteral vs) = ArrayLiteral <$> mapM (g'' s) vs
355− g' s (ObjectLiteral vs) = ObjectLiteral <$> mapM (sndM (g'' s)) vs
356− g' s (ObjectConstructor vs) = ObjectConstructor <$> mapM (sndM $ maybeM (g'' s)) vs
357− g' s (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> g'' s v
358− g' s (Accessor prop v) = Accessor prop <$> g'' s v
359− g' s (ObjectUpdate obj vs) = ObjectUpdate <$> g'' s obj <*> mapM (sndM (g'' s)) vs
360− g' s (ObjectUpdater obj vs) = ObjectUpdater <$> maybeM (g'' s) obj <*> mapM (sndM $ maybeM (g'' s)) vs
361− g' s (Abs name v) = Abs name <$> g'' s v
362− g' s (App v1 v2) = App <$> g'' s v1 <*> g'' s v2
363− g' s (IfThenElse v1 v2 v3) = IfThenElse <$> g'' s v1 <*> g'' s v2 <*> g'' s v3
364− g' s (Case vs alts) = Case <$> mapM (g'' s) vs <*> mapM (i'' s) alts
365− g' s (TypedValue check v ty) = TypedValue check <$> g'' s v <*> pure ty
366− g' s (Let ds v) = Let <$> mapM (f'' s) ds <*> g'' s v
367− g' s (Do es) = Do <$> mapM (j'' s) es
368− g' s (PositionedValue pos com v) = PositionedValue pos com <$> g'' s v
369− g' _ other = return other
370−
371− h'' s = uncurry h' <=< h s
372−
373− h' s (ConstructorBinder ctor bs) = ConstructorBinder ctor <$> mapM (h'' s) bs
374− h' s (ObjectBinder bs) = ObjectBinder <$> mapM (sndM (h'' s)) bs
375− h' s (ArrayBinder bs) = ArrayBinder <$> mapM (h'' s) bs
376− h' s (ConsBinder b1 b2) = ConsBinder <$> h'' s b1 <*> h'' s b2
377− h' s (NamedBinder name b) = NamedBinder name <$> h'' s b
378− h' s (PositionedBinder pos com b) = PositionedBinder pos com <$> h'' s b
379− h' _ other = return other
380−
381− i'' s = uncurry i' <=< i s
382−
383− i' s (CaseAlternative bs val) = CaseAlternative <$> mapM (h'' s) bs <*> eitherM (mapM (pairM (g'' s) (g'' s))) (g'' s) val
384−
385− j'' s = uncurry j' <=< j s
386−
387− j' s (DoNotationValue v) = DoNotationValue <$> g'' s v
388− j' s (DoNotationBind b v) = DoNotationBind <$> h'' s b <*> g'' s v
389− j' s (DoNotationLet ds) = DoNotationLet <$> mapM (f'' s) ds
390− j' s (PositionedDoNotationElement pos com e1) = PositionedDoNotationElement pos com <$> j'' s e1
391−
392−accumTypes :: (Monoid r) => (Type -> r) -> (Declaration -> r, Expr -> r, Binder -> r, CaseAlternative -> r, DoNotationElement -> r)
393−accumTypes f = everythingOnValues mappend forDecls forValues (const mempty) (const mempty) (const mempty)
394− where
395− forDecls (DataDeclaration _ _ _ dctors) = mconcat (concatMap (map f . snd) dctors)
396− forDecls (ExternDeclaration _ _ _ ty) = f ty
397− forDecls (ExternInstanceDeclaration _ cs _ tys) = mconcat (concatMap (map f . snd) cs) `mappend` mconcat (map f tys)
398− forDecls (TypeClassDeclaration _ _ implies _) = mconcat (concatMap (map f . snd) implies)
399− forDecls (TypeInstanceDeclaration _ cs _ tys _) = mconcat (concatMap (map f . snd) cs) `mappend` mconcat (map f tys)
400− forDecls (TypeSynonymDeclaration _ _ ty) = f ty
401− forDecls (TypeDeclaration _ ty) = f ty
402− forDecls _ = mempty
403−
404− forValues (TypeClassDictionary _ (_, cs) _) = mconcat (map f cs)
405− forValues (SuperClassDictionary _ tys) = mconcat (map f tys)
406− forValues (TypedValue _ _ ty) = f ty
407− forValues _ = mempty
src/Language/PureScript/CodeGen.hsdeleted−25
@@ -1,25 +0,0 @@
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.hsdeleted−121
@@ -1,121 +0,0 @@
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.Environment
28−import Language.PureScript.Kinds
29−import Language.PureScript.Names
30−import Language.PureScript.Pretty
31−import Language.PureScript.TypeClassDictionaries
32−import Language.PureScript.Types
33−import Language.PureScript.Comments
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) = do
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, nameKind, _) | nameKind == Value || nameKind == Extern ForeignImport || nameKind == Extern InlineJavascript ->
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) $ M.elems $ 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.hsdeleted−366
@@ -1,366 +0,0 @@
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, ViewPatterns, FlexibleContexts #-}
17−
18−module Language.PureScript.CodeGen.JS (
19− module AST,
20− module Common,
21− moduleToJs
22−) where
23−
24−import Data.List ((\\), delete)
25−import Data.Maybe (mapMaybe)
26−import qualified Data.Traversable as T (traverse)
27−
28−import Control.Applicative
29−import Control.Arrow ((&&&))
30−import Control.Monad (foldM, replicateM, forM)
31−import Control.Monad.Reader (MonadReader, asks, lift)
32−
33−import Language.PureScript.CodeGen.JS.AST as AST
34−import Language.PureScript.CodeGen.JS.Common as Common
35−import Language.PureScript.CoreFn
36−import Language.PureScript.Names
37−import Language.PureScript.CodeGen.JS.Optimizer
38−import Language.PureScript.Options
39−import Language.PureScript.Supply
40−import Language.PureScript.Traversals (sndM)
41−import qualified Language.PureScript.Constants as C
42−
43−-- |
44−-- Generate code in the simplified Javascript intermediate representation for all declarations in a
45−-- module.
46−--
47−moduleToJs :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)
48− => Module Ann -> SupplyT m [JS]
49−moduleToJs (Module name imps exps foreigns decls) = do
50− additional <- lift $ asks optionsAdditional
51− jsImports <- lift . T.traverse importToJs . delete (ModuleName [ProperName C.prim]) . (\\ [name]) $ imps
52− let foreigns' = mapMaybe (\(_, js, _) -> js) foreigns
53− jsDecls <- mapM (bindToJs name) decls
54− optimized <- lift $ T.traverse (T.traverse optimize) jsDecls
55− let isModuleEmpty = null exps
56− let moduleBody = JSStringLiteral "use strict" : jsImports ++ foreigns' ++ concat optimized
57− let exps' = JSObjectLiteral $ map (runIdent &&& JSVar . identToJs) exps
58− return $ case additional of
59− MakeOptions -> moduleBody ++ [JSAssignment (JSAccessor "exports" (JSVar "module")) exps']
60− CompileOptions ns _ _ | not isModuleEmpty ->
61− [ JSVariableIntroduction ns
62− (Just (JSBinary Or (JSVar ns) (JSObjectLiteral [])) )
63− , JSAssignment (JSAccessor (moduleNameToJs name) (JSVar ns))
64− (JSApp (JSFunction Nothing [] (JSBlock (moduleBody ++ [JSReturn exps']))) [])
65− ]
66− _ -> []
67−
68−-- |
69−-- Generates Javascript code for a module import.
70−--
71−importToJs :: (Monad m, MonadReader (Options mode) m) => ModuleName -> m JS
72−importToJs mn = do
73− additional <- asks optionsAdditional
74− let moduleBody = case additional of
75− MakeOptions -> JSApp (JSVar "require") [JSStringLiteral (runModuleName mn)]
76− CompileOptions ns _ _ -> JSAccessor (moduleNameToJs mn) (JSVar ns)
77− return $ JSVariableIntroduction (moduleNameToJs mn) (Just moduleBody)
78−
79−-- |
80−-- Generate code in the simplified Javascript intermediate representation for a declaration
81−--
82−bindToJs :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)
83− => ModuleName -> Bind Ann -> SupplyT m [JS]
84−bindToJs mp (NonRec ident val) = return <$> nonRecToJS mp ident val
85−bindToJs mp (Rec vals) = forM vals (uncurry (nonRecToJS mp))
86−
87−-- |
88−-- Generate code in the simplified Javascript intermediate representation for a single non-recursive
89−-- declaration.
90−--
91−-- The main purpose of this function is to handle code generation for comments.
92−--
93−nonRecToJS :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)
94− => ModuleName -> Ident -> Expr Ann -> SupplyT m JS
95−nonRecToJS m i e@(extractAnn -> (_, com, _, _)) | not (null com) = do
96− withoutComment <- lift $ asks optionsNoComments
97− if withoutComment
98− then nonRecToJS m i (modifyAnn removeComments e)
99− else JSComment com <$> nonRecToJS m i (modifyAnn removeComments e)
100−nonRecToJS mp ident val = do
101− js <- valueToJs mp val
102− return $ JSVariableIntroduction (identToJs ident) (Just js)
103−
104−
105−-- |
106−-- Generate code in the simplified Javascript intermediate representation for a variable based on a
107−-- PureScript identifier.
108−--
109−var :: Ident -> JS
110−var = JSVar . identToJs
111−
112−-- |
113−-- Generate code in the simplified Javascript intermediate representation for an accessor based on
114−-- a PureScript identifier. If the name is not valid in Javascript (symbol based, reserved name) an
115−-- indexer is returned.
116−--
117−accessor :: Ident -> JS -> JS
118−accessor (Ident prop) = accessorString prop
119−accessor (Op op) = JSIndexer (JSStringLiteral op)
120−
121−accessorString :: String -> JS -> JS
122−accessorString prop | identNeedsEscaping prop = JSIndexer (JSStringLiteral prop)
123− | otherwise = JSAccessor prop
124−
125−-- |
126−-- Generate code in the simplified Javascript intermediate representation for a value or expression.
127−--
128−valueToJs :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)
129− => ModuleName -> Expr Ann -> SupplyT m JS
130−valueToJs m (Literal _ l) =
131− literalToValueJS m l
132−valueToJs m (Var (_, _, _, Just (IsConstructor _ [])) name) =
133− return $ JSAccessor "value" $ qualifiedToJS m id name
134−valueToJs m (Var (_, _, _, Just (IsConstructor _ _)) name) =
135− return $ JSAccessor "create" $ qualifiedToJS m id name
136−valueToJs m (Accessor _ prop val) =
137− accessorString prop <$> valueToJs m val
138−valueToJs m (ObjectUpdate _ o ps) = do
139− obj <- valueToJs m o
140− sts <- mapM (sndM $ valueToJs m) ps
141− extendObj obj sts
142−valueToJs _ e@(Abs (_, _, _, Just IsTypeClassConstructor) _ _) =
143− let args = unAbs e
144− in return $ JSFunction Nothing (map identToJs args) (JSBlock $ map assign args)
145− where
146− unAbs :: Expr Ann -> [Ident]
147− unAbs (Abs _ arg val) = arg : unAbs val
148− unAbs _ = []
149− assign :: Ident -> JS
150− assign name = JSAssignment (accessorString (runIdent name) (JSVar "this"))
151− (var name)
152−valueToJs m (Abs _ arg val) = do
153− ret <- valueToJs m val
154− return $ JSFunction Nothing [identToJs arg] (JSBlock [JSReturn ret])
155−valueToJs m e@App{} = do
156− let (f, args) = unApp e []
157− args' <- mapM (valueToJs m) args
158− case f of
159− Var (_, _, _, Just IsNewtype) _ -> return (head args')
160− Var (_, _, _, Just (IsConstructor _ fields)) name | length args == length fields ->
161− return $ JSUnary JSNew $ JSApp (qualifiedToJS m id name) args'
162− Var (_, _, _, Just IsTypeClassConstructor) name ->
163− return $ JSUnary JSNew $ JSApp (qualifiedToJS m id name) args'
164− _ -> flip (foldl (\fn a -> JSApp fn [a])) args' <$> valueToJs m f
165− where
166− unApp :: Expr Ann -> [Expr Ann] -> (Expr Ann, [Expr Ann])
167− unApp (App _ val arg) args = unApp val (arg : args)
168− unApp other args = (other, args)
169−valueToJs m (Var _ ident) =
170− return $ varToJs m ident
171−valueToJs m (Case _ values binders) = do
172− vals <- mapM (valueToJs m) values
173− bindersToJs m binders vals
174−valueToJs m (Let _ ds val) = do
175− decls <- concat <$> mapM (bindToJs m) ds
176− ret <- valueToJs m val
177− return $ JSApp (JSFunction Nothing [] (JSBlock (decls ++ [JSReturn ret]))) []
178−valueToJs _ (Constructor (_, _, _, Just IsNewtype) _ (ProperName ctor) _) =
179− return $ JSVariableIntroduction ctor (Just $
180− JSObjectLiteral [("create",
181− JSFunction Nothing ["value"]
182− (JSBlock [JSReturn $ JSVar "value"]))])
183−valueToJs _ (Constructor _ _ (ProperName ctor) []) =
184− return $ iife ctor [ JSFunction (Just ctor) [] (JSBlock [])
185− , JSAssignment (JSAccessor "value" (JSVar ctor))
186− (JSUnary JSNew $ JSApp (JSVar ctor) []) ]
187−valueToJs _ (Constructor _ _ (ProperName ctor) fields) =
188− return $ iife ctor [ makeConstructor ctor fields
189− , JSAssignment (JSAccessor "create" (JSVar ctor)) (makeCreateFn ctor fields)
190− ]
191− where
192− makeConstructor :: String -> [Ident] -> JS
193− makeConstructor ctorName fs =
194− let body = [ JSAssignment (JSAccessor (identToJs f) (JSVar "this")) (var f) | f <- fs ]
195− in JSFunction (Just ctorName) (identToJs `map` fs) (JSBlock body)
196− makeCreateFn :: String -> [Ident] -> JS
197− makeCreateFn ctorName fs =
198− let body = JSUnary JSNew $ JSApp (JSVar ctorName) (var `map` fs)
199− in foldr (\f inner -> JSFunction Nothing [identToJs f] (JSBlock [JSReturn inner])) body fields
200−iife :: String -> [JS] -> JS
201−iife v exprs = JSApp (JSFunction Nothing [] (JSBlock $ exprs ++ [JSReturn $ JSVar v])) []
202−
203−literalToValueJS :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)
204− => ModuleName -> Literal (Expr Ann) -> SupplyT m JS
205−literalToValueJS _ (NumericLiteral n) = return $ JSNumericLiteral n
206−literalToValueJS _ (StringLiteral s) = return $ JSStringLiteral s
207−literalToValueJS _ (BooleanLiteral b) = return $ JSBooleanLiteral b
208−literalToValueJS m (ArrayLiteral xs) = JSArrayLiteral <$> mapM (valueToJs m) xs
209−literalToValueJS m (ObjectLiteral ps) = JSObjectLiteral <$> mapM (sndM (valueToJs m)) ps
210−
211−-- |
212−-- Shallow copy an object.
213−--
214−extendObj :: (Functor m, Applicative m, Monad m) => JS -> [(String, JS)] -> SupplyT m JS
215−extendObj obj sts = do
216− newObj <- freshName
217− key <- freshName
218− let
219− jsKey = JSVar key
220− jsNewObj = JSVar newObj
221− block = JSBlock (objAssign:copy:extend ++ [JSReturn jsNewObj])
222− objAssign = JSVariableIntroduction newObj (Just $ JSObjectLiteral [])
223− copy = JSForIn key obj $ JSBlock [JSIfElse cond assign Nothing]
224− cond = JSApp (JSAccessor "hasOwnProperty" obj) [jsKey]
225− assign = JSBlock [JSAssignment (JSIndexer jsKey jsNewObj) (JSIndexer jsKey obj)]
226− stToAssign (s, js) = JSAssignment (JSAccessor s jsNewObj) js
227− extend = map stToAssign sts
228− return $ JSApp (JSFunction Nothing [] block) []
229−
230−-- |
231−-- Generate code in the simplified Javascript intermediate representation for a reference to a
232−-- variable.
233−--
234−varToJs :: ModuleName -> Qualified Ident -> JS
235−varToJs _ (Qualified Nothing ident) = var ident
236−varToJs m qual = qualifiedToJS m id qual
237−
238−-- |
239−-- Generate code in the simplified Javascript intermediate representation for a reference to a
240−-- variable that may have a qualified name.
241−--
242−qualifiedToJS :: ModuleName -> (a -> Ident) -> Qualified a -> JS
243−qualifiedToJS _ f (Qualified (Just (ModuleName [ProperName mn])) a) | mn == C.prim = JSVar . runIdent $ f a
244−qualifiedToJS m f (Qualified (Just m') a) | m /= m' = accessor (f a) (JSVar (moduleNameToJs m'))
245−qualifiedToJS _ f (Qualified _ a) = JSVar $ identToJs (f a)
246−
247−-- |
248−-- Generate code in the simplified Javascript intermediate representation for pattern match binders
249−-- and guards.
250−--
251−bindersToJs :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)
252− => ModuleName -> [CaseAlternative Ann] -> [JS] -> SupplyT m JS
253−bindersToJs m binders vals = do
254− valNames <- replicateM (length vals) freshName
255− let assignments = zipWith JSVariableIntroduction valNames (map Just vals)
256− jss <- forM binders $ \(CaseAlternative bs result) -> do
257− ret <- guardsToJs result
258− go valNames ret bs
259− return $ JSApp (JSFunction Nothing [] (JSBlock (assignments ++ concat jss ++ [JSThrow $ JSUnary JSNew $ JSApp (JSVar "Error") [JSStringLiteral "Failed pattern match"]])))
260− []
261− where
262− go :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)
263− => [String] -> [JS] -> [Binder Ann] -> SupplyT m [JS]
264− go _ done [] = return done
265− go (v:vs) done' (b:bs) = do
266− done'' <- go vs done' bs
267− binderToJs m v done'' b
268− go _ _ _ = error "Invalid arguments to bindersToJs"
269−
270− guardsToJs :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)
271− => Either [(Guard Ann, Expr Ann)] (Expr Ann) -> SupplyT m [JS]
272− guardsToJs (Left gs) = forM gs $ \(cond, val) -> do
273− cond' <- valueToJs m cond
274− done <- valueToJs m val
275− return $ JSIfElse cond' (JSBlock [JSReturn done]) Nothing
276− guardsToJs (Right v) = return . JSReturn <$> valueToJs m v
277−
278−-- |
279−-- Generate code in the simplified Javascript intermediate representation for a pattern match
280−-- binder.
281−--
282−binderToJs :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)
283− => ModuleName -> String -> [JS] -> Binder Ann -> SupplyT m [JS]
284−binderToJs _ _ done (NullBinder{}) = return done
285−binderToJs m varName done (LiteralBinder _ l) =
286− literalToBinderJS m varName done l
287−binderToJs _ varName done (VarBinder _ ident) =
288− return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : done)
289−binderToJs m varName done (ConstructorBinder (_, _, _, Just IsNewtype) _ _ [b]) =
290− binderToJs m varName done b
291−binderToJs m varName done (ConstructorBinder (_, _, _, Just (IsConstructor ctorType fields)) _ ctor bs) = do
292− js <- go (zip fields bs) done
293− return $ case ctorType of
294− ProductType -> js
295− SumType ->
296− [JSIfElse (JSInstanceOf (JSVar varName) (qualifiedToJS m (Ident . runProperName) ctor))
297− (JSBlock js)
298− Nothing]
299− where
300− go :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)
301− => [(Ident, Binder Ann)] -> [JS] -> SupplyT m [JS]
302− go [] done' = return done'
303− go ((field, binder) : remain) done' = do
304− argVar <- freshName
305− done'' <- go remain done'
306− js <- binderToJs m argVar done'' binder
307− return (JSVariableIntroduction argVar (Just (JSAccessor (identToJs field) (JSVar varName))) : js)
308−binderToJs m varName done binder@(ConstructorBinder _ _ ctor _) | isCons ctor = do
309− let (headBinders, tailBinder) = uncons [] binder
310− numberOfHeadBinders = fromIntegral $ length headBinders
311− js1 <- foldM (\done' (headBinder, index) -> do
312− headVar <- freshName
313− jss <- binderToJs m headVar done' headBinder
314− return (JSVariableIntroduction headVar (Just (JSIndexer (JSNumericLiteral (Left index)) (JSVar varName))) : jss)) done (zip headBinders [0..])
315− tailVar <- freshName
316− js2 <- binderToJs m tailVar js1 tailBinder
317− return [JSIfElse (JSBinary GreaterThanOrEqualTo (JSAccessor "length" (JSVar varName)) (JSNumericLiteral (Left numberOfHeadBinders))) (JSBlock
318− ( JSVariableIntroduction tailVar (Just (JSApp (JSAccessor "slice" (JSVar varName)) [JSNumericLiteral (Left numberOfHeadBinders)])) :
319− js2
320− )) Nothing]
321− where
322− uncons :: [Binder Ann] -> Binder Ann -> ([Binder Ann], Binder Ann)
323− uncons acc (ConstructorBinder _ _ ctor' [h, t]) | isCons ctor' = uncons (h : acc) t
324− uncons acc tailBinder = (reverse acc, tailBinder)
325−binderToJs _ _ _ b@(ConstructorBinder{}) =
326− error $ "Invalid ConstructorBinder in binderToJs: " ++ show b
327−binderToJs m varName done (NamedBinder _ ident binder) = do
328− js <- binderToJs m varName done binder
329− return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : js)
330−
331−literalToBinderJS :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)
332− => ModuleName -> String -> [JS] -> Literal (Binder Ann) -> SupplyT m [JS]
333−literalToBinderJS _ varName done (NumericLiteral num) =
334− return [JSIfElse (JSBinary EqualTo (JSVar varName) (JSNumericLiteral num)) (JSBlock done) Nothing]
335−literalToBinderJS _ varName done (StringLiteral str) =
336− return [JSIfElse (JSBinary EqualTo (JSVar varName) (JSStringLiteral str)) (JSBlock done) Nothing]
337−literalToBinderJS _ varName done (BooleanLiteral True) =
338− return [JSIfElse (JSVar varName) (JSBlock done) Nothing]
339−literalToBinderJS _ varName done (BooleanLiteral False) =
340− return [JSIfElse (JSUnary Not (JSVar varName)) (JSBlock done) Nothing]
341−literalToBinderJS m varName done (ObjectLiteral bs) = go done bs
342− where
343− go :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)
344− => [JS] -> [(String, Binder Ann)] -> SupplyT m [JS]
345− go done' [] = return done'
346− go done' ((prop, binder):bs') = do
347− propVar <- freshName
348− done'' <- go done' bs'
349− js <- binderToJs m propVar done'' binder
350− return (JSVariableIntroduction propVar (Just (accessorString prop (JSVar varName))) : js)
351−literalToBinderJS m varName done (ArrayLiteral bs) = do
352− js <- go done 0 bs
353− return [JSIfElse (JSBinary EqualTo (JSAccessor "length" (JSVar varName)) (JSNumericLiteral (Left (fromIntegral $ length bs)))) (JSBlock js) Nothing]
354− where
355− go :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m)
356− => [JS] -> Integer -> [Binder Ann] -> SupplyT m [JS]
357− go done' _ [] = return done'
358− go done' index (binder:bs') = do
359− elVar <- freshName
360− done'' <- go done' (index + 1) bs'
361− js <- binderToJs m elVar done'' binder
362− return (JSVariableIntroduction elVar (Just (JSIndexer (JSNumericLiteral (Left index)) (JSVar varName))) : js)
363−
364−isCons :: Qualified ProperName -> Bool
365−isCons (Qualified (Just mn) ctor) = mn == ModuleName [ProperName C.prim] && ctor == ProperName "Array"
366−isCons name = error $ "Unexpected argument in isCons: " ++ show name
src/Language/PureScript/CodeGen/JS/AST.hsdeleted−337
@@ -1,337 +0,0 @@
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 Data.Data
21−
22−import Language.PureScript.Comments
23−
24−-- |
25−-- Built-in unary operators
26−--
27−data UnaryOperator
28− -- |
29− -- Numeric negation
30− --
31− = Negate
32− -- |
33− -- Boolean negation
34− --
35− | Not
36− -- |
37− -- Bitwise negation
38− --
39− | BitwiseNot
40− -- |
41− -- Numeric unary \'plus\'
42− --
43− | Positive
44− -- |
45− -- Constructor
46− --
47− | JSNew deriving (Show, Eq, Data, Typeable)
48−
49−-- |
50−-- Built-in binary operators
51−--
52−data BinaryOperator
53− -- |
54− -- Numeric addition
55− --
56− = Add
57− -- |
58− -- Numeric subtraction
59− --
60− | Subtract
61− -- |
62− -- Numeric multiplication
63− --
64− | Multiply
65− -- |
66− -- Numeric division
67− --
68− | Divide
69− -- |
70− -- Remainder
71− --
72− | Modulus
73− -- |
74− -- Generic equality test
75− --
76− | EqualTo
77− -- |
78− -- Generic inequality test
79− --
80− | NotEqualTo
81− -- |
82− -- Numeric less-than
83− --
84− | LessThan
85− -- |
86− -- Numeric less-than-or-equal
87− --
88− | LessThanOrEqualTo
89− -- |
90− -- Numeric greater-than
91− --
92− | GreaterThan
93− -- |
94− -- Numeric greater-than-or-equal
95− --
96− | GreaterThanOrEqualTo
97− -- |
98− -- Boolean and
99− --
100− | And
101− -- |
102− -- Boolean or
103− --
104− | Or
105− -- |
106− -- Bitwise and
107− --
108− | BitwiseAnd
109− -- |
110− -- Bitwise or
111− --
112− | BitwiseOr
113− -- |
114− -- Bitwise xor
115− --
116− | BitwiseXor
117− -- |
118− -- Bitwise left shift
119− --
120− | ShiftLeft
121− -- |
122− -- Bitwise right shift
123− --
124− | ShiftRight
125− -- |
126− -- Bitwise right shift with zero-fill
127− --
128− | ZeroFillShiftRight deriving (Show, Eq, Data, Typeable)
129−
130−-- |
131−-- Data type for simplified Javascript expressions
132−--
133−data JS
134− -- |
135− -- A numeric literal
136− --
137− = JSNumericLiteral (Either Integer Double)
138− -- |
139− -- A string literal
140− --
141− | JSStringLiteral String
142− -- |
143− -- A boolean literal
144− --
145− | JSBooleanLiteral Bool
146− -- |
147− -- A unary operator application
148− --
149− | JSUnary UnaryOperator JS
150− -- |
151− -- A binary operator application
152− --
153− | JSBinary BinaryOperator JS JS
154− -- |
155− -- An array literal
156− --
157− | JSArrayLiteral [JS]
158− -- |
159− -- An array indexer expression
160− --
161− | JSIndexer JS JS
162− -- |
163− -- An object literal
164− --
165− | JSObjectLiteral [(String, JS)]
166− -- |
167− -- An object property accessor expression
168− --
169− | JSAccessor String JS
170− -- |
171− -- A function introduction (optional name, arguments, body)
172− --
173− | JSFunction (Maybe String) [String] JS
174− -- |
175− -- Function application
176− --
177− | JSApp JS [JS]
178− -- |
179− -- Variable
180− --
181− | JSVar String
182− -- |
183− -- Conditional expression
184− --
185− | JSConditional JS JS JS
186− -- |
187− -- A block of expressions in braces
188− --
189− | JSBlock [JS]
190− -- |
191− -- A variable introduction and optional initialization
192− --
193− | JSVariableIntroduction String (Maybe JS)
194− -- |
195− -- A variable assignment
196− --
197− | JSAssignment JS JS
198− -- |
199− -- While loop
200− --
201− | JSWhile JS JS
202− -- |
203− -- For loop
204− --
205− | JSFor String JS JS JS
206− -- |
207− -- ForIn loop
208− --
209− | JSForIn String JS JS
210− -- |
211− -- If-then-else statement
212− --
213− | JSIfElse JS JS (Maybe JS)
214− -- |
215− -- Return statement
216− --
217− | JSReturn JS
218− -- |
219− -- Throw statement
220− --
221− | JSThrow JS
222− -- |
223− -- Type-Of operator
224− --
225− | JSTypeOf JS
226− -- |
227− -- InstanceOf test
228− --
229− | JSInstanceOf JS JS
230− -- |
231− -- Labelled statement
232− --
233− | JSLabel String JS
234− -- |
235− -- Break statement
236− --
237− | JSBreak String
238− -- |
239− -- Continue statement
240− --
241− | JSContinue String
242− -- |
243− -- Raw Javascript (generated when parsing fails for an inline foreign import declaration)
244− --
245− | JSRaw String
246− -- |
247− -- Commented Javascript
248− --
249− | JSComment [Comment] JS deriving (Show, Eq, Data, Typeable)
250−
251−--
252−-- Traversals
253−--
254−
255−everywhereOnJS :: (JS -> JS) -> JS -> JS
256−everywhereOnJS f = go
257− where
258− go :: JS -> JS
259− go (JSUnary op j) = f (JSUnary op (go j))
260− go (JSBinary op j1 j2) = f (JSBinary op (go j1) (go j2))
261− go (JSArrayLiteral js) = f (JSArrayLiteral (map go js))
262− go (JSIndexer j1 j2) = f (JSIndexer (go j1) (go j2))
263− go (JSObjectLiteral js) = f (JSObjectLiteral (map (fmap go) js))
264− go (JSAccessor prop j) = f (JSAccessor prop (go j))
265− go (JSFunction name args j) = f (JSFunction name args (go j))
266− go (JSApp j js) = f (JSApp (go j) (map go js))
267− go (JSConditional j1 j2 j3) = f (JSConditional (go j1) (go j2) (go j3))
268− go (JSBlock js) = f (JSBlock (map go js))
269− go (JSVariableIntroduction name j) = f (JSVariableIntroduction name (fmap go j))
270− go (JSAssignment j1 j2) = f (JSAssignment (go j1) (go j2))
271− go (JSWhile j1 j2) = f (JSWhile (go j1) (go j2))
272− go (JSFor name j1 j2 j3) = f (JSFor name (go j1) (go j2) (go j3))
273− go (JSForIn name j1 j2) = f (JSForIn name (go j1) (go j2))
274− go (JSIfElse j1 j2 j3) = f (JSIfElse (go j1) (go j2) (fmap go j3))
275− go (JSReturn js) = f (JSReturn (go js))
276− go (JSThrow js) = f (JSThrow (go js))
277− go (JSTypeOf js) = f (JSTypeOf (go js))
278− go (JSLabel name js) = f (JSLabel name (go js))
279− go (JSInstanceOf j1 j2) = f (JSInstanceOf (go j1) (go j2))
280− go (JSComment com j) = f (JSComment com (go j))
281− go other = f other
282−
283−everywhereOnJSTopDown :: (JS -> JS) -> JS -> JS
284−everywhereOnJSTopDown f = go . f
285− where
286− go :: JS -> JS
287− go (JSUnary op j) = JSUnary op (go (f j))
288− go (JSBinary op j1 j2) = JSBinary op (go (f j1)) (go (f j2))
289− go (JSArrayLiteral js) = JSArrayLiteral (map (go . f) js)
290− go (JSIndexer j1 j2) = JSIndexer (go (f j1)) (go (f j2))
291− go (JSObjectLiteral js) = JSObjectLiteral (map (fmap (go . f)) js)
292− go (JSAccessor prop j) = JSAccessor prop (go (f j))
293− go (JSFunction name args j) = JSFunction name args (go (f j))
294− go (JSApp j js) = JSApp (go (f j)) (map (go . f) js)
295− go (JSConditional j1 j2 j3) = JSConditional (go (f j1)) (go (f j2)) (go (f j3))
296− go (JSBlock js) = JSBlock (map (go . f) js)
297− go (JSVariableIntroduction name j) = JSVariableIntroduction name (fmap (go . f) j)
298− go (JSAssignment j1 j2) = JSAssignment (go (f j1)) (go (f j2))
299− go (JSWhile j1 j2) = JSWhile (go (f j1)) (go (f j2))
300− go (JSFor name j1 j2 j3) = JSFor name (go (f j1)) (go (f j2)) (go (f j3))
301− go (JSForIn name j1 j2) = JSForIn name (go (f j1)) (go (f j2))
302− go (JSIfElse j1 j2 j3) = JSIfElse (go (f j1)) (go (f j2)) (fmap (go . f) j3)
303− go (JSReturn j) = JSReturn (go (f j))
304− go (JSThrow j) = JSThrow (go (f j))
305− go (JSTypeOf j) = JSTypeOf (go (f j))
306− go (JSLabel name j) = JSLabel name (go (f j))
307− go (JSInstanceOf j1 j2) = JSInstanceOf (go (f j1)) (go (f j2))
308− go (JSComment com j) = JSComment com (go (f j))
309− go other = f other
310−
311−everythingOnJS :: (r -> r -> r) -> (JS -> r) -> JS -> r
312−everythingOnJS (<>) f = go
313− where
314− go j@(JSUnary _ j1) = f j <> go j1
315− go j@(JSBinary _ j1 j2) = f j <> go j1 <> go j2
316− go j@(JSArrayLiteral js) = foldl (<>) (f j) (map go js)
317− go j@(JSIndexer j1 j2) = f j <> go j1 <> go j2
318− go j@(JSObjectLiteral js) = foldl (<>) (f j) (map (go . snd) js)
319− go j@(JSAccessor _ j1) = f j <> go j1
320− go j@(JSFunction _ _ j1) = f j <> go j1
321− go j@(JSApp j1 js) = foldl (<>) (f j <> go j1) (map go js)
322− go j@(JSConditional j1 j2 j3) = f j <> go j1 <> go j2 <> go j3
323− go j@(JSBlock js) = foldl (<>) (f j) (map go js)
324− go j@(JSVariableIntroduction _ (Just j1)) = f j <> go j1
325− go j@(JSAssignment j1 j2) = f j <> go j1 <> go j2
326− go j@(JSWhile j1 j2) = f j <> go j1 <> go j2
327− go j@(JSFor _ j1 j2 j3) = f j <> go j1 <> go j2 <> go j3
328− go j@(JSForIn _ j1 j2) = f j <> go j1 <> go j2
329− go j@(JSIfElse j1 j2 Nothing) = f j <> go j1 <> go j2
330− go j@(JSIfElse j1 j2 (Just j3)) = f j <> go j1 <> go j2 <> go j3
331− go j@(JSReturn j1) = f j <> go j1
332− go j@(JSThrow j1) = f j <> go j1
333− go j@(JSTypeOf j1) = f j <> go j1
334− go j@(JSLabel _ j1) = f j <> go j1
335− go j@(JSInstanceOf j1 j2) = f j <> go j1 <> go j2
336− go j@(JSComment _ j1) = f j <> go j1
337− go other = f other
src/Language/PureScript/CodeGen/JS/Common.hsdeleted−181
@@ -1,181 +0,0 @@
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.hsdeleted−86
@@ -1,86 +0,0 @@
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.Monad.Reader (MonadReader, ask, asks)
41−
42−import Language.PureScript.CodeGen.JS.AST
43−import Language.PureScript.Options
44−import qualified Language.PureScript.Constants as C
45−
46−import Language.PureScript.CodeGen.JS.Optimizer.Common
47−import Language.PureScript.CodeGen.JS.Optimizer.TCO
48−import Language.PureScript.CodeGen.JS.Optimizer.MagicDo
49−import Language.PureScript.CodeGen.JS.Optimizer.Inliner
50−import Language.PureScript.CodeGen.JS.Optimizer.Unused
51−import Language.PureScript.CodeGen.JS.Optimizer.Blocks
52−
53−-- |
54−-- Apply a series of optimizer passes to simplified Javascript code
55−--
56−optimize :: (Monad m, MonadReader (Options mode) m) => JS -> m JS
57−optimize js = do
58− noOpt <- asks optionsNoOptimizations
59− if noOpt then return js else optimize' js
60−
61−optimize' :: (Monad m, MonadReader (Options mode) m) => JS -> m JS
62−optimize' js = do
63− opts <- ask
64− return $ untilFixedPoint (applyAll
65− [ collapseNestedBlocks
66− , collapseNestedIfs
67− , tco opts
68− , magicDo opts
69− , removeCodeAfterReturnStatements
70− , removeUnusedArg
71− , removeUndefinedApp
72− , unThunk
73− , etaConvert
74− , evaluateIifes
75− , inlineVariables
76− , inlineValues
77− , inlineOperator (C.prelude, (C.$)) $ \f x -> JSApp f [x]
78− , inlineOperator (C.prelude, (C.#)) $ \x f -> JSApp f [x]
79− , inlineOperator (C.preludeUnsafe, C.unsafeIndex) $ flip JSIndexer
80− , inlineCommonOperators ]) js
81−
82−untilFixedPoint :: (Eq a) => (a -> a) -> a -> a
83−untilFixedPoint f = go
84− where
85− go a = let a' = f a in
86− if a' == a then a' else go a'
src/Language/PureScript/CodeGen/JS/Optimizer/Blocks.hsdeleted−42
@@ -1,42 +0,0 @@
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.hsdeleted−77
@@ -1,77 +0,0 @@
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.hsdeleted−201
@@ -1,201 +0,0 @@
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− etaConvert,
22− unThunk,
23− evaluateIifes
24−) where
25−
26−import Data.Maybe (fromMaybe)
27−
28−import Language.PureScript.CodeGen.JS.AST
29−import Language.PureScript.CodeGen.JS.Common
30−import Language.PureScript.Names
31−import Language.PureScript.CodeGen.JS.Optimizer.Common
32−import qualified Language.PureScript.Constants as C
33−
34−shouldInline :: JS -> Bool
35−shouldInline (JSVar _) = True
36−shouldInline (JSNumericLiteral _) = True
37−shouldInline (JSStringLiteral _) = True
38−shouldInline (JSBooleanLiteral _) = True
39−shouldInline (JSAccessor _ val) = shouldInline val
40−shouldInline (JSIndexer index val) = shouldInline index && shouldInline val
41−shouldInline _ = False
42−
43−etaConvert :: JS -> JS
44−etaConvert = everywhereOnJS convert
45− where
46− convert :: JS -> JS
47− convert (JSBlock [JSReturn (JSApp (JSFunction Nothing idents block@(JSBlock body)) args)])
48− | all shouldInline args &&
49− not (any (`isRebound` block) (map JSVar idents)) &&
50− not (any (`isRebound` block) args)
51− = JSBlock (map (replaceIdents (zip idents args)) body)
52− convert (JSFunction Nothing [] (JSBlock [JSReturn (JSApp fn [])])) = fn
53− convert js = js
54−
55−unThunk :: JS -> JS
56−unThunk = everywhereOnJS convert
57− where
58− convert :: JS -> JS
59− convert (JSBlock []) = JSBlock []
60− convert (JSBlock jss) =
61− case last jss of
62− JSReturn (JSApp (JSFunction Nothing [] (JSBlock body)) []) -> JSBlock $ init jss ++ body
63− _ -> JSBlock jss
64− convert js = js
65−
66−evaluateIifes :: JS -> JS
67−evaluateIifes = everywhereOnJS convert
68− where
69− convert :: JS -> JS
70− convert (JSApp (JSFunction Nothing [] (JSBlock [JSReturn ret])) []) = ret
71− convert js = js
72−
73−inlineVariables :: JS -> JS
74−inlineVariables = everywhereOnJS $ removeFromBlock go
75− where
76− go :: [JS] -> [JS]
77− go [] = []
78− go (JSVariableIntroduction var (Just js) : sts)
79− | shouldInline js && not (any (isReassigned var) sts) && not (any (isRebound js) sts) && not (any (isUpdated var) sts) =
80− go (map (replaceIdent var js) sts)
81− go (s:sts) = s : go sts
82−
83−inlineValues :: JS -> JS
84−inlineValues = everywhereOnJS convert
85− where
86− convert :: JS -> JS
87− convert (JSApp fn [dict]) | isPreludeDict C.semiringNumber dict && isPreludeFn C.zero fn = JSNumericLiteral (Left 0)
88− convert (JSApp fn [dict]) | isPreludeDict C.semiringNumber dict && isPreludeFn C.one fn = JSNumericLiteral (Left 1)
89− convert (JSApp (JSApp fn [x]) [y]) | isPreludeFn (C.%) fn = JSBinary Modulus x y
90− convert other = other
91−
92−inlineOperator :: (String, String) -> (JS -> JS -> JS) -> JS -> JS
93−inlineOperator (m, op) f = everywhereOnJS convert
94− where
95− convert :: JS -> JS
96− convert (JSApp (JSApp op' [x]) [y]) | isOp op' = f x y
97− convert other = other
98− isOp (JSAccessor longForm (JSVar m')) = m == m' && longForm == identToJs (Op op)
99− isOp (JSIndexer (JSStringLiteral op') (JSVar m')) = m == m' && op == op'
100− isOp _ = False
101−
102−inlineCommonOperators :: JS -> JS
103−inlineCommonOperators = applyAll $
104− [ binary C.semiringNumber (C.+) Add
105− , binary C.semiringNumber (C.*) Multiply
106− , binary C.ringNumber (C.-) Subtract
107− , unary C.ringNumber C.negate Negate
108− , binary C.moduloSemiringNumber (C./) Divide
109−
110− , binary C.ordNumber (C.<) LessThan
111− , binary C.ordNumber (C.>) GreaterThan
112− , binary C.ordNumber (C.<=) LessThanOrEqualTo
113− , binary C.ordNumber (C.>=) GreaterThanOrEqualTo
114−
115− , binary C.eqNumber (C.==) EqualTo
116− , binary C.eqNumber (C./=) NotEqualTo
117− , binary C.eqString (C.==) EqualTo
118− , binary C.eqString (C./=) NotEqualTo
119− , binary C.eqBoolean (C.==) EqualTo
120− , binary C.eqBoolean (C./=) NotEqualTo
121−
122− , binary C.semigroupString (C.<>) Add
123− , binary C.semigroupString (C.++) Add
124−
125− , binaryFunction C.bitsNumber C.shl ShiftLeft
126− , binaryFunction C.bitsNumber C.shr ShiftRight
127− , binaryFunction C.bitsNumber C.zshr ZeroFillShiftRight
128− , binary C.bitsNumber (C..&.) BitwiseAnd
129− , binary C.bitsNumber (C..|.) BitwiseOr
130− , binary C.bitsNumber (C..^.) BitwiseXor
131− , unary C.bitsNumber C.complement BitwiseNot
132−
133− , binary C.boolLikeBoolean (C.&&) And
134− , binary C.boolLikeBoolean (C.||) Or
135− , unary C.boolLikeBoolean C.not Not
136− ] ++
137− [ fn | i <- [0..10], fn <- [ mkFn i, runFn i ] ]
138− where
139− binary :: String -> String -> BinaryOperator -> JS -> JS
140− binary dictName opString op = everywhereOnJS convert
141− where
142− convert :: JS -> JS
143− convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isPreludeDict dictName dict && isPreludeFn opString fn = JSBinary op x y
144− convert other = other
145− binaryFunction :: String -> String -> BinaryOperator -> JS -> JS
146− binaryFunction dictName fnName op = everywhereOnJS convert
147− where
148− convert :: JS -> JS
149− convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isPreludeFn fnName fn && isPreludeDict dictName dict = JSBinary op x y
150− convert other = other
151− unary :: String -> String -> UnaryOperator -> JS -> JS
152− unary dictName fnName op = everywhereOnJS convert
153− where
154− convert :: JS -> JS
155− convert (JSApp (JSApp fn [dict]) [x]) | isPreludeFn fnName fn && isPreludeDict dictName dict = JSUnary op x
156− convert other = other
157− mkFn :: Int -> JS -> JS
158− mkFn 0 = everywhereOnJS convert
159− where
160− convert :: JS -> JS
161− convert (JSApp mkFnN [JSFunction Nothing [_] (JSBlock js)]) | isNFn C.mkFn 0 mkFnN =
162− JSFunction Nothing [] (JSBlock js)
163− convert other = other
164− mkFn n = everywhereOnJS convert
165− where
166− convert :: JS -> JS
167− convert orig@(JSApp mkFnN [fn]) | isNFn C.mkFn n mkFnN =
168− case collectArgs n [] fn of
169− Just (args, js) -> JSFunction Nothing args (JSBlock js)
170− Nothing -> orig
171− convert other = other
172− collectArgs :: Int -> [String] -> JS -> Maybe ([String], [JS])
173− collectArgs 1 acc (JSFunction Nothing [oneArg] (JSBlock js)) | length acc == n - 1 = Just (reverse (oneArg : acc), js)
174− collectArgs m acc (JSFunction Nothing [oneArg] (JSBlock [JSReturn ret])) = collectArgs (m - 1) (oneArg : acc) ret
175− collectArgs _ _ _ = Nothing
176−
177− isNFn :: String -> Int -> JS -> Bool
178− isNFn prefix n (JSVar name) = name == (prefix ++ show n)
179− isNFn prefix n (JSAccessor name (JSVar dataFunction)) | dataFunction == C.dataFunction = name == (prefix ++ show n)
180− isNFn _ _ _ = False
181−
182− runFn :: Int -> JS -> JS
183− runFn n = everywhereOnJS convert
184− where
185− convert :: JS -> JS
186− convert js = fromMaybe js $ go n [] js
187−
188− go :: Int -> [JS] -> JS -> Maybe JS
189− go 0 acc (JSApp runFnN [fn]) | isNFn C.runFn n runFnN && length acc == n = Just (JSApp fn acc)
190− go m acc (JSApp lhs [arg]) = go (m - 1) (arg : acc) lhs
191− go _ _ _ = Nothing
192−
193−isPreludeDict :: String -> JS -> Bool
194−isPreludeDict dictName (JSAccessor prop (JSVar prelude)) = prelude == C.prelude && prop == dictName
195−isPreludeDict _ _ = False
196−
197−isPreludeFn :: String -> JS -> Bool
198−isPreludeFn fnName (JSAccessor fnName' (JSVar prelude)) = prelude == C.prelude && fnName' == fnName
199−isPreludeFn fnName (JSIndexer (JSStringLiteral fnName') (JSVar prelude)) = prelude == C.prelude && fnName' == fnName
200−isPreludeFn fnName (JSAccessor longForm (JSAccessor prelude (JSVar _))) = prelude == C.prelude && longForm == identToJs (Op fnName)
201−isPreludeFn _ _ = False
src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hsdeleted−165
@@ -1,165 +0,0 @@
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 == identToJs (Op (C.>>=))
85− isBindPoly (JSIndexer (JSStringLiteral bind) (JSVar prelude)) = prelude == C.prelude && 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.hsdeleted−103
@@ -1,103 +0,0 @@
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 Language.PureScript.Options
19−import Language.PureScript.CodeGen.JS.AST
20−
21−-- |
22−-- Eliminate tail calls
23−--
24−tco :: Options mode -> JS -> JS
25−tco opts | optionsNoTco opts = id
26− | otherwise = tco'
27−
28−tco' :: JS -> JS
29−tco' = everywhereOnJS convert
30− where
31− tcoLabel :: String
32− tcoLabel = "tco"
33− tcoVar :: String -> String
34− tcoVar arg = "__tco_" ++ arg
35− copyVar :: String -> String
36− copyVar arg = "__copy_" ++ arg
37− convert :: JS -> JS
38− convert js@(JSVariableIntroduction name (Just fn@JSFunction {})) =
39− let
40− (argss, body', replace) = collectAllFunctionArgs [] id fn
41− in case () of
42− _ | isTailCall name body' ->
43− let
44− allArgs = concat $ reverse argss
45− in
46− JSVariableIntroduction name (Just (replace (toLoop name allArgs body')))
47− | otherwise -> js
48− convert js = js
49− collectAllFunctionArgs :: [[String]] -> (JS -> JS) -> JS -> ([[String]], JS, JS -> JS)
50− collectAllFunctionArgs allArgs f (JSFunction ident args (JSBlock (body@(JSReturn _):_))) =
51− collectAllFunctionArgs (args : allArgs) (\b -> f (JSFunction ident (map copyVar args) (JSBlock [b]))) body
52− collectAllFunctionArgs allArgs f (JSFunction ident args body@(JSBlock _)) =
53− (args : allArgs, body, f . JSFunction ident (map copyVar args))
54− collectAllFunctionArgs allArgs f (JSReturn (JSFunction ident args (JSBlock [body]))) =
55− collectAllFunctionArgs (args : allArgs) (\b -> f (JSReturn (JSFunction ident (map copyVar args) (JSBlock [b])))) body
56− collectAllFunctionArgs allArgs f (JSReturn (JSFunction ident args body@(JSBlock _))) =
57− (args : allArgs, body, f . JSReturn . JSFunction ident (map copyVar args))
58− collectAllFunctionArgs allArgs f body = (allArgs, body, f)
59− isTailCall :: String -> JS -> Bool
60− isTailCall ident js =
61− let
62− numSelfCalls = everythingOnJS (+) countSelfCalls js
63− numSelfCallsInTailPosition = everythingOnJS (+) countSelfCallsInTailPosition js
64− numSelfCallsUnderFunctions = everythingOnJS (+) countSelfCallsUnderFunctions js
65− in
66− numSelfCalls > 0
67− && numSelfCalls == numSelfCallsInTailPosition
68− && numSelfCallsUnderFunctions == 0
69− where
70− countSelfCalls :: JS -> Int
71− countSelfCalls (JSApp (JSVar ident') _) | ident == ident' = 1
72− countSelfCalls _ = 0
73− countSelfCallsInTailPosition :: JS -> Int
74− countSelfCallsInTailPosition (JSReturn ret) | isSelfCall ident ret = 1
75− countSelfCallsInTailPosition _ = 0
76− countSelfCallsUnderFunctions (JSFunction _ _ js') = everythingOnJS (+) countSelfCalls js'
77− countSelfCallsUnderFunctions _ = 0
78− toLoop :: String -> [String] -> JS -> JS
79− toLoop ident allArgs js = JSBlock $
80− map (\arg -> JSVariableIntroduction arg (Just (JSVar (copyVar arg)))) allArgs ++
81− [ JSLabel tcoLabel $ JSWhile (JSBooleanLiteral True) (JSBlock [ everywhereOnJS loopify js ]) ]
82− where
83− loopify :: JS -> JS
84− loopify (JSReturn ret) | isSelfCall ident ret =
85− let
86− allArgumentValues = concat $ collectSelfCallArgs [] ret
87− in
88− JSBlock $ zipWith (\val arg ->
89− JSVariableIntroduction (tcoVar arg) (Just val)) allArgumentValues allArgs
90− ++ map (\arg ->
91− JSAssignment (JSVar arg) (JSVar (tcoVar arg))) allArgs
92− ++ [ JSContinue tcoLabel ]
93− loopify other = other
94− collectSelfCallArgs :: [[JS]] -> JS -> [[JS]]
95− collectSelfCallArgs allArgumentValues (JSApp fn args') = collectSelfCallArgs (args' : allArgumentValues) fn
96− collectSelfCallArgs allArgumentValues _ = allArgumentValues
97− isSelfCall :: String -> JS -> Bool
98− isSelfCall ident (JSApp (JSVar ident') args) | ident == ident' && not (any isFunction args) = True
99− isSelfCall ident (JSApp fn args) | not (any isFunction args) = isSelfCall ident fn
100− isSelfCall _ _ = False
101− isFunction :: JS -> Bool
102− isFunction (JSFunction _ _ _) = True
103− isFunction _ = False
src/Language/PureScript/CodeGen/JS/Optimizer/Unused.hsdeleted−46
@@ -1,46 +0,0 @@
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.hsdeleted−25
@@ -1,25 +0,0 @@
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.hsdeleted−239
@@ -1,239 +0,0 @@
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−-- Prelude 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−(.^.) :: String
75−(.^.) = ".^."
76−
77−(&&) :: String
78−(&&) = "&&"
79−
80−(||) :: String
81−(||) = "||"
82−
83−unsafeIndex :: String
84−unsafeIndex = "unsafeIndex"
85−
86−-- Prelude Operator Functions
87−
88−negate :: String
89−negate = "negate"
90−
91−shl :: String
92−shl = "shl"
93−
94−shr :: String
95−shr = "shr"
96−
97−zshr :: String
98−zshr = "zshr"
99−
100−complement :: String
101−complement = "complement"
102−
103−not :: String
104−not = "not"
105−
106−-- Prelude Values
107−
108−zero :: String
109−zero = "zero"
110−
111−one :: String
112−one = "one"
113−
114−return :: String
115−return = "return"
116−
117−pure' :: String
118−pure' = "pure"
119−
120−returnEscaped :: String
121−returnEscaped = "$return"
122−
123−untilE :: String
124−untilE = "untilE"
125−
126−whileE :: String
127−whileE = "whileE"
128−
129−runST :: String
130−runST = "runST"
131−
132−stRefValue :: String
133−stRefValue = "value"
134−
135−newSTRef :: String
136−newSTRef = "newSTRef"
137−
138−readSTRef :: String
139−readSTRef = "readSTRef"
140−
141−writeSTRef :: String
142−writeSTRef = "writeSTRef"
143−
144−modifySTRef :: String
145−modifySTRef = "modifySTRef"
146−
147−mkFn :: String
148−mkFn = "mkFn"
149−
150−runFn :: String
151−runFn = "runFn"
152−
153−unit :: String
154−unit = "unit"
155−
156−-- Prim values
157−
158−undefined :: String
159−undefined = "undefined"
160−
161−-- Type Class Dictionary Names
162−
163−monadEffDictionary :: String
164−monadEffDictionary = "monadEff"
165−
166−applicativeEffDictionary :: String
167−applicativeEffDictionary = "applicativeEff"
168−
169−bindEffDictionary :: String
170−bindEffDictionary = "bindEff"
171−
172−semiringNumber :: String
173−semiringNumber = "semiringNumber"
174−
175−ringNumber :: String
176−ringNumber = "ringNumber"
177−
178−moduloSemiringNumber :: String
179−moduloSemiringNumber = "moduloSemiringNumber"
180−
181−numNumber :: String
182−numNumber = "numNumber"
183−
184−ordNumber :: String
185−ordNumber = "ordNumber"
186−
187−eqNumber :: String
188−eqNumber = "eqNumber"
189−
190−eqString :: String
191−eqString = "eqString"
192−
193−eqBoolean :: String
194−eqBoolean = "eqBoolean"
195−
196−bitsNumber :: String
197−bitsNumber = "bitsNumber"
198−
199−boolLikeBoolean :: String
200−boolLikeBoolean = "boolLikeBoolean"
201−
202−semigroupString :: String
203−semigroupString = "semigroupString"
204−
205−semigroupoidArr :: String
206−semigroupoidArr = "semigroupoidArr"
207−
208−-- Main module
209−
210−main :: String
211−main = "main"
212−
213−-- Code Generation
214−
215−__superclass_ :: String
216−__superclass_ = "__superclass_"
217−
218−__unused :: String
219−__unused = "__unused"
220−
221−-- Modules
222−
223−prim :: String
224−prim = "Prim"
225−
226−prelude :: String
227−prelude = "Prelude"
228−
229−preludeUnsafe :: String
230−preludeUnsafe = "Prelude_Unsafe"
231−
232−eff :: String
233−eff = "Control_Monad_Eff"
234−
235−st :: String
236−st = "Control_Monad_ST"
237−
238−dataFunction :: String
239−dataFunction = "Data_Function"
src/Language/PureScript/CoreFn.hsdeleted−26
@@ -1,26 +0,0 @@
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.hsdeleted−37
@@ -1,37 +0,0 @@
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.hsdeleted−48
@@ -1,48 +0,0 @@
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.hsdeleted−247
@@ -1,247 +0,0 @@
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 env (A.Module mn decls (Just exps)) =
44− let imports = nub $ mapMaybe importToCoreFn decls ++ findQualModules decls
45− exps' = nub $ concatMap exportToCoreFn exps
46− externs = nub $ mapMaybe externToCoreFn decls
47− decls' = concatMap (declToCoreFn mn env Nothing []) decls
48− in Module mn imports exps' externs decls'
49−moduleToCoreFn _ (A.Module{}) =
50− error "Module exports were not elaborated before moduleToCoreFn"
51−
52−-- |
53−-- Find module names from qualified references to values. This is used to
54−-- ensure instances are imported from any module that is referenced by the
55−-- current module, not just from those that are imported explicitly (#667).
56−--
57−findQualModules :: [A.Declaration] -> [ModuleName]
58−findQualModules decls =
59− let (f, _, _, _, _) = everythingOnValues (++) (const []) fqValues (const []) (const []) (const [])
60− in f `concatMap` decls
61− where
62− fqValues :: A.Expr -> [ModuleName]
63− fqValues (A.Var (Qualified (Just mn) _)) = [mn]
64− fqValues _ = []
65−
66−-- |
67−-- Desugars import declarations from AST to CoreFn representation.
68−--
69−importToCoreFn :: A.Declaration -> Maybe ModuleName
70−importToCoreFn (A.ImportDeclaration name _ _) = Just name
71−importToCoreFn (A.PositionedDeclaration _ _ d) = importToCoreFn d
72−importToCoreFn _ = Nothing
73−
74−-- |
75−-- Desugars foreign declarations from AST to CoreFn representation.
76−--
77−externToCoreFn :: A.Declaration -> Maybe ForeignDecl
78−externToCoreFn (A.ExternDeclaration _ name js ty) = Just (name, js, ty)
79−externToCoreFn (A.ExternInstanceDeclaration name _ _ _) = Just (name, Nothing, tyObject)
80−externToCoreFn (A.PositionedDeclaration _ _ d) = externToCoreFn d
81−externToCoreFn _ = Nothing
82−
83−-- |
84−-- Desugars export declarations references from AST to CoreFn representation.
85−-- CoreFn modules only export values, so all data constructors, class
86−-- constructor, instances and values are flattened into one list.
87−--
88−exportToCoreFn :: A.DeclarationRef -> [Ident]
89−exportToCoreFn (A.TypeRef _ (Just dctors)) = map properToIdent dctors
90−exportToCoreFn (A.ValueRef name) = [name]
91−exportToCoreFn (A.TypeClassRef name) = [properToIdent name]
92−exportToCoreFn (A.TypeInstanceRef name) = [name]
93−exportToCoreFn (A.PositionedDeclarationRef _ _ d) = exportToCoreFn d
94−exportToCoreFn _ = []
95−
96−-- |
97−-- Desugars member declarations from AST to CoreFn representation.
98−--
99−declToCoreFn :: ModuleName -> Environment -> Maybe SourceSpan -> [Comment] -> A.Declaration -> [Bind Ann]
100−declToCoreFn _ _ ss com (A.DataDeclaration Newtype _ _ [(ctor, _)]) =
101− [NonRec (properToIdent ctor) $
102− Abs (ss, com, Nothing, Just IsNewtype) (Ident "x") (Var nullAnn $ Qualified Nothing (Ident "x"))]
103−declToCoreFn _ _ _ _ d@(A.DataDeclaration Newtype _ _ _) =
104− error $ "Found newtype with multiple constructors: " ++ show d
105−declToCoreFn mn env ss com (A.DataDeclaration Data tyName _ ctors) =
106− flip map ctors $ \(ctor, _) ->
107− let (_, _, _, fields) = lookupConstructor env (Qualified (Just mn) ctor)
108− in NonRec (properToIdent ctor) $ Constructor (ss, com, Nothing, Nothing) tyName ctor fields
109−declToCoreFn mn env ss _ (A.DataBindingGroupDeclaration ds) = concatMap (declToCoreFn mn env ss []) ds
110−declToCoreFn mn env ss com (A.ValueDeclaration name _ _ (Right e)) =
111− [NonRec name (exprToCoreFn mn env ss com Nothing e)]
112−declToCoreFn mn env ss _ (A.BindingGroupDeclaration ds) =
113− [Rec $ map (\(name, _, e) -> (name, exprToCoreFn mn env ss [] Nothing e)) ds]
114−declToCoreFn _ _ ss com (A.TypeClassDeclaration name _ supers members) =
115− [NonRec (properToIdent name) $ mkTypeClassConstructor ss com supers members]
116−declToCoreFn mn env _ com (A.PositionedDeclaration ss com1 d) =
117− declToCoreFn mn env (Just ss) (com ++ com1) d
118−declToCoreFn _ _ _ _ _ = []
119−
120−-- |
121−-- Makes a typeclass dictionary constructor function. The returned expression
122−-- is a function that accepts the superclass instances and member
123−-- implementations and returns a record for the instance dictionary.
124−--
125−mkTypeClassConstructor :: Maybe SourceSpan -> [Comment] -> [Constraint] -> [A.Declaration] -> Expr Ann
126−mkTypeClassConstructor ss com [] [] = Literal (ss, com, Nothing, Just IsTypeClassConstructor) (ObjectLiteral [])
127−mkTypeClassConstructor ss com supers members =
128− let args@(a:as) = sort $ map typeClassMemberName members ++ superClassDictionaryNames supers
129− props = [ (arg, Var nullAnn $ Qualified Nothing (Ident arg)) | arg <- args ]
130− dict = Literal nullAnn (ObjectLiteral props)
131− in Abs (ss, com, Nothing, Just IsTypeClassConstructor)
132− (Ident a)
133− (foldr (Abs nullAnn . Ident) dict as)
134−
135−-- |
136−-- Desugars expressions from AST to CoreFn representation.
137−--
138−exprToCoreFn :: ModuleName -> Environment -> Maybe SourceSpan -> [Comment] -> Maybe Type -> A.Expr -> Expr Ann
139−exprToCoreFn _ _ ss com ty (A.NumericLiteral v) =
140− Literal (ss, com, ty, Nothing) (NumericLiteral v)
141−exprToCoreFn _ _ ss com ty (A.StringLiteral v) =
142− Literal (ss, com, ty, Nothing) (StringLiteral v)
143−exprToCoreFn _ _ ss com ty (A.BooleanLiteral v) =
144− Literal (ss, com, ty, Nothing) (BooleanLiteral v)
145−exprToCoreFn mn env ss com ty (A.ArrayLiteral vs) =
146− Literal (ss, com, ty, Nothing) (ArrayLiteral $ map (exprToCoreFn mn env ss [] Nothing) vs)
147−exprToCoreFn mn env ss com ty (A.ObjectLiteral vs) =
148− Literal (ss, com, ty, Nothing) (ObjectLiteral $ map (second (exprToCoreFn mn env ss [] Nothing)) vs)
149−exprToCoreFn mn env ss com ty (A.Accessor name v) =
150− Accessor (ss, com, ty, Nothing) name (exprToCoreFn mn env ss [] Nothing v)
151−exprToCoreFn mn env ss com ty (A.ObjectUpdate obj vs) =
152− ObjectUpdate (ss, com, ty, Nothing) (exprToCoreFn mn env ss [] Nothing obj) $ map (second (exprToCoreFn mn env ss [] Nothing)) vs
153−exprToCoreFn mn env ss com ty (A.Abs (Left name) v) =
154− Abs (ss, com, ty, Nothing) name (exprToCoreFn mn env ss [] Nothing v)
155−exprToCoreFn _ _ _ _ _ (A.Abs _ _) =
156− error "Abs with Binder argument was not desugared before exprToCoreFn mn"
157−exprToCoreFn mn env ss com ty (A.App v1 v2) =
158− App (ss, com, ty, Nothing) (exprToCoreFn mn env ss [] Nothing v1) (exprToCoreFn mn env ss [] Nothing v2)
159−exprToCoreFn _ _ ss com ty (A.Var ident) =
160− Var (ss, com, ty, Nothing) ident
161−exprToCoreFn mn env ss com ty (A.IfThenElse v1 v2 v3) =
162− Case (ss, com, ty, Nothing) [exprToCoreFn mn env ss [] Nothing v1]
163− [ CaseAlternative [LiteralBinder nullAnn $ BooleanLiteral True]
164− (Right $ exprToCoreFn mn env Nothing [] Nothing v2)
165− , CaseAlternative [LiteralBinder nullAnn $ BooleanLiteral False]
166− (Right $ exprToCoreFn mn env Nothing [] Nothing v3) ]
167−exprToCoreFn _ env ss com ty (A.Constructor name) =
168− Var (ss, com, ty, Just $ getConstructorMeta env name) $ fmap properToIdent name
169−exprToCoreFn mn env ss com ty (A.Case vs alts) =
170− Case (ss, com, ty, Nothing) (map (exprToCoreFn mn env ss [] Nothing) vs) (map (altToCoreFn mn env ss) alts)
171−exprToCoreFn mn env ss com _ (A.TypedValue _ v ty) =
172− exprToCoreFn mn env ss com (Just ty) v
173−exprToCoreFn mn env ss com ty (A.Let ds v) =
174− Let (ss, com, ty, Nothing) (concatMap (declToCoreFn mn env ss []) ds) (exprToCoreFn mn env ss [] Nothing v)
175−exprToCoreFn mn env ss com _ (A.TypeClassDictionaryConstructorApp name (A.TypedValue _ (A.ObjectLiteral vs) _)) =
176− let args = map (exprToCoreFn mn env ss [] Nothing . snd) $ sortBy (compare `on` fst) vs
177− ctor = Var (ss, [], Nothing, Just IsTypeClassConstructor) (fmap properToIdent name)
178− in foldl (App (ss, com, Nothing, Nothing)) ctor args
179−exprToCoreFn _ _ ss com ty (A.TypeClassDictionaryAccessor _ ident) =
180− Abs (ss, com, ty, Nothing) (Ident "dict")
181− (Accessor nullAnn (runIdent ident) (Var nullAnn $ Qualified Nothing (Ident "dict")))
182−exprToCoreFn mn env _ com ty (A.PositionedValue ss com1 v) =
183− exprToCoreFn mn env (Just ss) (com ++ com1) ty v
184−exprToCoreFn _ _ _ _ _ e =
185− error $ "Unexpected value in exprToCoreFn mn: " ++ show e
186−
187−-- |
188−-- Desugars case alternatives from AST to CoreFn representation.
189−--
190−altToCoreFn :: ModuleName -> Environment -> Maybe SourceSpan -> A.CaseAlternative -> CaseAlternative Ann
191−altToCoreFn mn env ss (A.CaseAlternative bs vs) = CaseAlternative (map (binderToCoreFn env ss []) bs) (go vs)
192− where
193− go :: Either [(A.Guard, A.Expr)] A.Expr -> Either [(Guard Ann, Expr Ann)] (Expr Ann)
194− go (Left ges) = Left $ map (exprToCoreFn mn env ss [] Nothing *** exprToCoreFn mn env ss [] Nothing) ges
195− go (Right e) = Right (exprToCoreFn mn env ss [] Nothing e)
196−
197−-- |
198−-- Desugars case binders from AST to CoreFn representation.
199−--
200−binderToCoreFn :: Environment -> Maybe SourceSpan -> [Comment] -> A.Binder -> Binder Ann
201−binderToCoreFn _ ss com (A.NullBinder) =
202− NullBinder (ss, com, Nothing, Nothing)
203−binderToCoreFn _ ss com (A.BooleanBinder b) =
204− LiteralBinder (ss, com, Nothing, Nothing) (BooleanLiteral b)
205−binderToCoreFn _ ss com (A.StringBinder s) =
206− LiteralBinder (ss, com, Nothing, Nothing) (StringLiteral s)
207−binderToCoreFn _ ss com (A.NumberBinder n) =
208− LiteralBinder (ss, com, Nothing, Nothing) (NumericLiteral n)
209−binderToCoreFn _ ss com (A.VarBinder name) =
210− VarBinder (ss, com, Nothing, Nothing) name
211−binderToCoreFn env ss com (A.ConstructorBinder dctor@(Qualified mn _) bs) =
212− let (_, tctor, _, _) = lookupConstructor env dctor
213− in ConstructorBinder (ss, com, Nothing, Just $ getConstructorMeta env dctor) (Qualified mn tctor) dctor (map (binderToCoreFn env ss []) bs)
214−binderToCoreFn env ss com (A.ObjectBinder bs) =
215− LiteralBinder (ss, com, Nothing, Nothing) (ObjectLiteral $ map (second (binderToCoreFn env ss [])) bs)
216−binderToCoreFn env ss com (A.ArrayBinder bs) =
217− LiteralBinder (ss, com, Nothing, Nothing) (ArrayLiteral $ map (binderToCoreFn env ss []) bs)
218−binderToCoreFn env ss com (A.ConsBinder b1 b2) =
219− let arrCtor = Qualified (Just $ ModuleName [ProperName "Prim"]) (ProperName "Array")
220− in ConstructorBinder (ss, com, Nothing, Nothing) arrCtor arrCtor $ map (binderToCoreFn env ss []) [b1, b2]
221−binderToCoreFn env ss com (A.NamedBinder name b) =
222− NamedBinder (ss, com, Nothing, Nothing) name (binderToCoreFn env ss [] b)
223−binderToCoreFn env _ com (A.PositionedBinder ss com1 b) =
224− binderToCoreFn env (Just ss) (com ++ com1) b
225−
226−-- |
227−-- Converts a ProperName to an Ident.
228−--
229−properToIdent :: ProperName -> Ident
230−properToIdent = Ident . runProperName
231−
232−-- |
233−-- Gets metadata for data constructors.
234−--
235−getConstructorMeta :: Environment -> Qualified ProperName -> Meta
236−getConstructorMeta env ctor =
237− case lookupConstructor env ctor of
238− (Newtype, _, _, _) -> IsNewtype
239− dc@(Data, _, _, fields) ->
240− let constructorType = if numConstructors (ctor, dc) == 1 then ProductType else SumType
241− in IsConstructor constructorType fields
242− where
243− numConstructors :: (Qualified ProperName, (DataDeclType, ProperName, Type, [Ident])) -> Int
244− numConstructors ty = length $ filter (((==) `on` typeConstructor) ty) $ M.toList $ dataConstructors env
245− typeConstructor :: (Qualified ProperName, (DataDeclType, ProperName, Type, [Ident])) -> (ModuleName, ProperName)
246− typeConstructor (Qualified (Just mn) _, (_, tyCtor, _, _)) = (mn, tyCtor)
247− typeConstructor _ = error "Invalid argument to typeConstructor"
src/Language/PureScript/CoreFn/Expr.hsdeleted−134
@@ -1,134 +0,0 @@
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.hsdeleted−46
@@ -1,46 +0,0 @@
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 boolean literal
37− --
38− | BooleanLiteral Bool
39− -- |
40− -- An array literal
41− --
42− | ArrayLiteral [a]
43− -- |
44− -- An object literal
45− --
46− | ObjectLiteral [(String, a)] deriving (Show, D.Data, D.Typeable, Functor)
src/Language/PureScript/CoreFn/Meta.hsdeleted−51
@@ -1,51 +0,0 @@
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 deriving (Show, D.Data, D.Typeable)
39−
40−-- |
41−-- Data constructor metadata
42−--
43−data ConstructorType
44− -- |
45− -- The constructor is for a type with a single construcor
46− --
47− = ProductType
48− -- |
49− -- The constructor is for a type with multiple construcors
50− --
51− | SumType deriving (Show, D.Data, D.Typeable)
src/Language/PureScript/CoreFn/Module.hsdeleted−30
@@ -1,30 +0,0 @@
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.CodeGen.JS.AST
18−import Language.PureScript.CoreFn.Expr
19−import Language.PureScript.Names
20−import Language.PureScript.Types
21−
22−data Module a = Module
23− { moduleName :: ModuleName
24− , moduleImports :: [ModuleName]
25− , moduleExports :: [Ident]
26− , moduleForeign :: [ForeignDecl]
27− , moduleDecls :: [Bind a]
28− } deriving (Show)
29−
30−type ForeignDecl = (Ident, Maybe JS, Type)
src/Language/PureScript/CoreFn/Traversals.hsdeleted−85
@@ -1,85 +0,0 @@
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.hsdeleted−102
@@ -1,102 +0,0 @@
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 mn imps exps foreigns ds) = Module 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 (name, _, _) = name
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/Environment.hsdeleted−241
@@ -1,241 +0,0 @@
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−
17−module Language.PureScript.Environment where
18−
19−import Data.Data
20−import Data.Maybe (fromMaybe)
21−import qualified Data.Map as M
22−
23−import Language.PureScript.Kinds
24−import Language.PureScript.Names
25−import Language.PureScript.TypeClassDictionaries
26−import Language.PureScript.Types
27−import qualified Language.PureScript.Constants as C
28−
29−-- |
30−-- The @Environment@ defines all values and types which are currently in scope:
31−--
32−data Environment = Environment {
33− -- |
34− -- Value names currently in scope
35− --
36− names :: M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility)
37− -- |
38− -- Type names currently in scope
39− --
40− , types :: M.Map (Qualified ProperName) (Kind, TypeKind)
41− -- |
42− -- Data constructors currently in scope, along with their associated data type constructors
43− --
44− , dataConstructors :: M.Map (Qualified ProperName) (DataDeclType, ProperName, Type, [Ident])
45− -- |
46− -- Type synonyms currently in scope
47− --
48− , typeSynonyms :: M.Map (Qualified ProperName) ([(String, Maybe Kind)], Type)
49− -- |
50− -- Available type class dictionaries
51− --
52− , typeClassDictionaries :: M.Map (Qualified Ident, Maybe ModuleName) TypeClassDictionaryInScope
53− -- |
54− -- Type classes
55− --
56− , typeClasses :: M.Map (Qualified ProperName) ([(String, Maybe Kind)], [(Ident, Type)], [Constraint])
57− } deriving (Show)
58−
59−-- |
60−-- The initial environment with no values and only the default javascript types defined
61−--
62−initEnvironment :: Environment
63−initEnvironment = Environment M.empty primTypes M.empty M.empty M.empty M.empty
64−
65−-- |
66−-- The type of a foreign import
67−--
68−data ForeignImportType
69− -- |
70− -- A regular foreign import
71− --
72− = ForeignImport
73− -- |
74− -- A foreign import which contains inline Javascript as a string literal
75− --
76− | InlineJavascript deriving (Show, Eq, Data, Typeable)
77−
78−-- |
79−-- The visibility of a name in scope
80−--
81−data NameVisibility
82− -- |
83− -- The name is defined in the current binding group, but is not visible
84− --
85− = Undefined
86− -- |
87− -- The name is defined in the another binding group, or has been made visible by a function binder
88− --
89− | Defined deriving (Show, Eq)
90−
91−-- |
92−-- The kind of a name
93−--
94−data NameKind
95− -- |
96− -- A value introduced as a binding in a module
97− --
98− = Value
99− -- |
100− -- A type class dictionary member accessor import, generated during desugaring of type class declarations
101− --
102− | TypeClassAccessorImport
103− -- |
104− -- A foreign import
105− --
106− | Extern ForeignImportType
107− -- |
108− -- A local name introduced using a lambda abstraction, variable introduction or binder
109− --
110− | LocalVariable
111− -- |
112− -- A data constructor
113− --
114− | DataConstructor
115− -- |
116− -- A type class dictionary, generated during desugaring of type class declarations
117− --
118− | TypeInstanceDictionaryValue deriving (Show, Eq, Data, Typeable)
119−
120−-- |
121−-- The kinds of a type
122−--
123−data TypeKind
124− -- |
125− -- Data type
126− --
127− = DataType [(String, Maybe Kind)] [(ProperName, [Type])]
128− -- |
129− -- Type synonym
130− --
131− | TypeSynonym
132− -- |
133− -- Foreign data
134− --
135− | ExternData
136− -- |
137− -- A local type variable
138− --
139− | LocalTypeVariable
140− -- |
141− -- A scoped type variable
142− --
143− | ScopedTypeVar
144− deriving (Show, Eq, Data, Typeable)
145−
146−-- |
147−-- The type ('data' or 'newtype') of a data type declaration
148−--
149−data DataDeclType
150− -- |
151− -- A standard data constructor
152− --
153− = Data
154− -- |
155− -- A newtype constructor
156− --
157− | Newtype deriving (Eq, Ord, Data, Typeable)
158−
159−instance Show DataDeclType where
160− show Data = "data"
161− show Newtype = "newtype"
162−
163−-- |
164−-- Construct a ProperName in the Prim module
165−--
166−primName :: String -> Qualified ProperName
167−primName = Qualified (Just $ ModuleName [ProperName C.prim]) . ProperName
168−
169−-- |
170−-- Construct a type in the Prim module
171−--
172−primTy :: String -> Type
173−primTy = TypeConstructor . primName
174−
175−-- |
176−-- Type constructor for functions
177−--
178−tyFunction :: Type
179−tyFunction = primTy "Function"
180−
181−-- |
182−-- Type constructor for strings
183−--
184−tyString :: Type
185−tyString = primTy "String"
186−
187−-- |
188−-- Type constructor for numbers
189−--
190−tyNumber :: Type
191−tyNumber = primTy "Number"
192−
193−-- |
194−-- Type constructor for booleans
195−--
196−tyBoolean :: Type
197−tyBoolean = primTy "Boolean"
198−
199−-- |
200−-- Type constructor for arrays
201−--
202−tyArray :: Type
203−tyArray = primTy "Array"
204−
205−-- |
206−-- Type constructor for objects
207−--
208−tyObject :: Type
209−tyObject = primTy "Object"
210−
211−-- |
212−-- Smart constructor for function types
213−--
214−function :: Type -> Type -> Type
215−function t1 = TypeApp (TypeApp tyFunction t1)
216−
217−-- |
218−-- The primitive types in the external javascript environment with their associated kinds.
219−--
220−primTypes :: M.Map (Qualified ProperName) (Kind, TypeKind)
221−primTypes = M.fromList [ (primName "Function" , (FunKind Star (FunKind Star Star), ExternData))
222− , (primName "Array" , (FunKind Star Star, ExternData))
223− , (primName "Object" , (FunKind (Row Star) Star, ExternData))
224− , (primName "String" , (Star, ExternData))
225− , (primName "Number" , (Star, ExternData))
226− , (primName "Boolean" , (Star, ExternData)) ]
227−
228−-- |
229−-- Finds information about data constructors from the current environment.
230−--
231−lookupConstructor :: Environment -> Qualified ProperName -> (DataDeclType, ProperName, Type, [Ident])
232−lookupConstructor env ctor =
233− fromMaybe (error "Data constructor not found") $ ctor `M.lookup` dataConstructors env
234−
235−-- |
236−-- Checks whether a data constructor is for a newtype.
237−--
238−isNewtypeConstructor :: Environment -> Qualified ProperName -> Bool
239−isNewtypeConstructor e ctor = case lookupConstructor e ctor of
240− (Newtype, _, _, _) -> True
241− (Data, _, _, _) -> False
src/Language/PureScript/Errors.hsdeleted−140
@@ -1,140 +0,0 @@
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, FlexibleContexts #-}
16−
17−module Language.PureScript.Errors where
18−
19−import Data.Either (lefts, rights)
20−import Data.List (intersperse, intercalate)
21−import Data.Monoid
22−
23−import Control.Monad.Error
24−import Control.Applicative ((<$>))
25−
26−import Language.PureScript.AST
27−import Language.PureScript.Pretty
28−import Language.PureScript.Types
29−
30−-- |
31−-- Type for sources of type checking errors
32−--
33−data ErrorSource
34− -- |
35− -- An error which originated at a Expr
36− --
37− = ExprError Expr
38− -- |
39− -- An error which originated at a Type
40− --
41− | TypeError Type deriving (Show)
42−
43−-- |
44−-- Compilation errors
45−--
46−data CompileError
47− = CompileError
48− { -- |
49− -- Error message
50− --
51− compileErrorMessage :: String
52− -- |
53− -- The value where the error occurred
54− --
55− , compileErrorValue :: Maybe ErrorSource
56− -- |
57− -- Optional source position information
58− --
59− , compileErrorPosition :: Maybe SourceSpan
60− }
61− deriving (Show)
62−
63−-- |
64−-- A stack trace for an error
65−--
66−data ErrorStack
67− = ErrorStack { runErrorStack :: [CompileError] }
68− | MultipleErrors [ErrorStack] deriving (Show)
69−
70−instance Monoid ErrorStack where
71− mempty = ErrorStack []
72− mappend (ErrorStack xs) (ErrorStack ys) = ErrorStack (xs ++ ys)
73− mappend (MultipleErrors es) x = MultipleErrors [ e <> x | e <- es ]
74− mappend x (MultipleErrors es) = MultipleErrors [ x <> e | e <- es ]
75−
76−instance Error ErrorStack where
77− strMsg s = ErrorStack [CompileError s Nothing Nothing]
78− noMsg = ErrorStack []
79−
80−prettyPrintErrorStack :: Bool -> ErrorStack -> String
81−prettyPrintErrorStack printFullStack (ErrorStack es) =
82− case mconcat $ map (Last . compileErrorPosition) es of
83− Last (Just sourcePos) -> "Error at " ++ show sourcePos ++ ": \n" ++ prettyPrintErrorStack'
84− _ -> prettyPrintErrorStack'
85− where
86− prettyPrintErrorStack' :: String
87− prettyPrintErrorStack'
88− | printFullStack = intercalate "\n" (map showError (filter isErrorNonEmpty es))
89− | otherwise =
90− let
91− es' = filter isErrorNonEmpty es
92− in case length es' of
93− 1 -> showError (head es')
94− _ -> showError (head es') ++ "\n" ++ showError (last es')
95−prettyPrintErrorStack printFullStack (MultipleErrors es) =
96− unlines $ intersperse "" $ "Multiple errors:" : map (prettyPrintErrorStack printFullStack) es
97−
98−stringifyErrorStack :: (MonadError String m) => Bool -> Either ErrorStack a -> m a
99−stringifyErrorStack printFullStack = either (throwError . prettyPrintErrorStack printFullStack) return
100−
101−isErrorNonEmpty :: CompileError -> Bool
102−isErrorNonEmpty = not . null . compileErrorMessage
103−
104−showError :: CompileError -> String
105−showError (CompileError msg Nothing _) = msg
106−showError (CompileError msg (Just (ExprError val)) _) = "Error in expression " ++ prettyPrintValue val ++ ":\n" ++ msg
107−showError (CompileError msg (Just (TypeError ty)) _) = "Error in type " ++ prettyPrintType ty ++ ":\n" ++ msg
108−
109−mkErrorStack :: String -> Maybe ErrorSource -> ErrorStack
110−mkErrorStack msg t = ErrorStack [CompileError msg t Nothing]
111−
112−positionError :: SourceSpan -> ErrorStack
113−positionError pos = ErrorStack [CompileError "" Nothing (Just pos)]
114−
115−-- |
116−-- Rethrow an error with a more detailed error message in the case of failure
117−--
118−rethrow :: (MonadError e m) => (e -> e) -> m a -> m a
119−rethrow f = flip catchError $ \e -> throwError (f e)
120−
121−-- |
122−-- Rethrow an error with source position information
123−--
124−rethrowWithPosition :: (MonadError ErrorStack m) => SourceSpan -> m a -> m a
125−rethrowWithPosition pos = rethrow (positionError pos <>)
126−
127−-- |
128−-- Collect errors in in parallel
129−--
130−parU :: (MonadError ErrorStack m, Functor m) => [a] -> (a -> m b) -> m [b]
131−parU xs f = forM xs (withError . f) >>= collectErrors
132− where
133− withError :: (MonadError ErrorStack m, Functor m) => m a -> m (Either ErrorStack a)
134− withError u = catchError (Right <$> u) (return . Left)
135−
136− collectErrors :: (MonadError ErrorStack m, Functor m) => [Either ErrorStack a] -> m [a]
137− collectErrors es = case lefts es of
138− [err] -> throwError err
139− [] -> return $ rights es
140− errs -> throwError $ MultipleErrors errs
src/Language/PureScript/Kinds.hsdeleted−60
@@ -1,60 +0,0 @@
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−
17−module Language.PureScript.Kinds where
18−
19−import Data.Data
20−
21−import Control.Monad.Unify (Unknown)
22−
23−-- |
24−-- The data type of kinds
25−--
26−data Kind
27− -- |
28− -- Unification variable of type Kind
29− --
30− = KUnknown Unknown
31− -- |
32− -- The kind of types
33− --
34− | Star
35− -- |
36− -- The kind of effects
37− --
38− | Bang
39− -- |
40− -- Kinds for labelled, unordered rows without duplicates
41− --
42− | Row Kind
43− -- |
44− -- Function kinds
45− --
46− | FunKind Kind Kind deriving (Show, Eq, Data, Typeable)
47−
48−everywhereOnKinds :: (Kind -> Kind) -> Kind -> Kind
49−everywhereOnKinds f = go
50− where
51− go (Row k1) = f (Row (go k1))
52− go (FunKind k1 k2) = f (FunKind (go k1) (go k2))
53− go other = f other
54−
55−everythingOnKinds :: (r -> r -> r) -> (Kind -> r) -> Kind -> r
56−everythingOnKinds (<>) f = go
57− where
58− go k@(Row k1) = f k <> go k1
59− go k@(FunKind k1 k2) = f k <> go k1 <> go k2
60− go other = f other
src/Language/PureScript/ModuleDependencies.hsdeleted−76
@@ -1,76 +0,0 @@
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
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−
32−-- |
33−-- A list of modules with their dependencies
34−--
35−type ModuleGraph = [(ModuleName, [ModuleName])]
36−
37−-- |
38−-- Sort a collection of modules based on module dependencies.
39−--
40−-- Reports an error if the module graph contains a cycle.
41−--
42−sortModules :: (MonadError String m) => [Module] -> m ([Module], ModuleGraph)
43−sortModules ms = do
44− let verts = map (\m@(Module _ ds _) -> (m, getModuleName m, nub (concatMap usedModules ds))) ms
45− ms' <- mapM toModule $ stronglyConnComp verts
46− let moduleGraph = map (\(_, mn, deps) -> (mn, deps)) verts
47− return (ms', moduleGraph)
48−
49−-- |
50−-- Calculate a list of used modules based on explicit imports and qualified names
51−--
52−usedModules :: Declaration -> [ModuleName]
53−usedModules = let (f, _, _, _, _) = everythingOnValues (++) forDecls forValues (const []) (const []) (const []) in nub . f
54− where
55− forDecls :: Declaration -> [ModuleName]
56− forDecls (ImportDeclaration mn _ _) = [mn]
57− forDecls _ = []
58−
59− forValues :: Expr -> [ModuleName]
60− forValues (Var (Qualified (Just mn) _)) = [mn]
61− forValues (Constructor (Qualified (Just mn) _)) = [mn]
62− forValues (TypedValue _ _ ty) = forTypes ty
63− forValues _ = []
64−
65− forTypes :: Type -> [ModuleName]
66− forTypes (TypeConstructor (Qualified (Just mn) _)) = [mn]
67− forTypes (ConstrainedType cs _) = mapMaybe (\(Qualified mn _, _) -> mn) cs
68− forTypes _ = []
69−
70−-- |
71−-- Convert a strongly connected component of the module graph to a module
72−--
73−toModule :: (MonadError String m) => SCC Module -> m Module
74−toModule (AcyclicSCC m) = return m
75−toModule (CyclicSCC [m]) = return m
76−toModule (CyclicSCC ms) = throwError $ "Cycle in module dependencies: " ++ show (map getModuleName ms)
src/Language/PureScript/Names.hsdeleted−85
@@ -1,85 +0,0 @@
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 #-}
17−
18−module Language.PureScript.Names where
19−
20−import Data.List
21−import Data.Data
22−
23−-- |
24−-- Names for value identifiers
25−--
26−data Ident
27− -- |
28− -- An alphanumeric identifier
29− --
30− = Ident String
31− -- |
32− -- A symbolic name for an infix operator
33− --
34− | Op String deriving (Eq, Ord, Data, Typeable)
35−
36−runIdent :: Ident -> String
37−runIdent (Ident i) = i
38−runIdent (Op op) = op
39−
40−instance Show Ident where
41− show (Ident s) = s
42− show (Op op) = '(':op ++ ")"
43−
44−-- |
45−-- Proper names, i.e. capitalized names for e.g. module names, type//data constructors.
46−--
47−newtype ProperName = ProperName { runProperName :: String } deriving (Eq, Ord, Data, Typeable)
48−
49−instance Show ProperName where
50− show = runProperName
51−
52−-- |
53−-- Module names
54−--
55−data ModuleName = ModuleName [ProperName] deriving (Eq, Ord, Data, Typeable)
56−
57−runModuleName :: ModuleName -> String
58−runModuleName (ModuleName pns) = intercalate "." (runProperName `map` pns)
59−
60−moduleNameFromString :: String -> ModuleName
61−moduleNameFromString = ModuleName . splitProperNames
62− where
63− splitProperNames s = case dropWhile (== '.') s of
64− "" -> []
65− s' -> ProperName w : splitProperNames s''
66− where (w, s'') = break (== '.') s'
67−
68−instance Show ModuleName where
69− show = runModuleName
70−
71−-- |
72−-- A qualified name, i.e. a name with an optional module name
73−--
74−data Qualified a = Qualified (Maybe ModuleName) a deriving (Eq, Ord, Data, Typeable, Functor)
75−
76−instance (Show a) => Show (Qualified a) where
77− show (Qualified Nothing a) = show a
78− show (Qualified (Just name) a) = show name ++ "." ++ show a
79−
80−-- |
81−-- Provide a default module name, if a name is unqualified
82−--
83−qualify :: ModuleName -> Qualified a -> (ModuleName, a)
84−qualify m (Qualified Nothing a) = (m, a)
85−qualify _ (Qualified (Just m) a) = (m, a)
src/Language/PureScript/Options.hsdeleted−92
@@ -1,92 +0,0 @@
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 :: 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−deriving instance Show (ModeOptions mode)
42−
43−-- |
44−-- The data type of compiler options
45−--
46−data Options mode = Options {
47− -- |
48− -- Disable inclusion of the built in Prelude
49− --
50− optionsNoPrelude :: Bool
51− -- |
52− -- Disable tail-call elimination
53− --
54− , optionsNoTco :: Bool
55− -- |
56− -- Disable inlining of calls to return and bind for the Eff monad
57− --
58− , optionsNoMagicDo :: Bool
59− -- |
60− -- When specified, checks the type of `main` in the module, and generate a call to run main
61− -- after the module definitions.
62− --
63− , optionsMain :: Maybe String
64− -- |
65− -- Skip all optimizations
66− --
67− , optionsNoOptimizations :: Bool
68− -- |
69− -- Verbose error message
70− --
71− , optionsVerboseErrors :: Bool
72− -- |
73− -- Remove the comments from the generated js
74− , optionsNoComments :: Bool
75− -- |
76− -- Specify the namespace that PureScript modules will be exported to when running in the
77− -- browser.
78− --
79− , optionsAdditional :: ModeOptions mode
80− } deriving Show
81−
82−-- |
83−-- Default compiler options
84−--
85−defaultCompileOptions :: Options Compile
86−defaultCompileOptions = Options False False False Nothing False False False (CompileOptions "PS" [] [])
87−
88−-- |
89−-- Default make options
90−--
91−defaultMakeOptions :: Options Make
92−defaultMakeOptions = Options False False False Nothing False False False MakeOptions
src/Language/PureScript/Parser.hsdeleted−35
@@ -1,35 +0,0 @@
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
src/Language/PureScript/Parser/Common.hsdeleted−134
@@ -1,134 +0,0 @@
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−properName :: TokenParser ProperName
31−properName = ProperName <$> uname
32−
33−-- |
34−-- Parse a module name
35−--
36−moduleName :: TokenParser ModuleName
37−moduleName = part []
38− where
39− part path = (do name <- ProperName <$> P.try qualifier
40− part (path `snoc` name))
41− <|> (ModuleName . snoc path . ProperName <$> mname)
42− snoc path name = path ++ [name]
43−
44−-- |
45−-- Parse a qualified name, i.e. M.name or just name
46−--
47−parseQualified :: TokenParser a -> TokenParser (Qualified a)
48−parseQualified parser = part []
49− where
50− part path = (do name <- ProperName <$> P.try qualifier
51− part (updatePath path name))
52− <|> (Qualified (qual path) <$> P.try parser)
53− updatePath path name = path ++ [name]
54− qual path = if null path then Nothing else Just $ ModuleName path
55−
56−-- |
57−-- Parse an identifier or parenthesized operator
58−--
59−parseIdent :: TokenParser Ident
60−parseIdent = (Ident <$> identifier) <|> (Op <$> parens symbol)
61−
62−-- |
63−-- Run the first parser, then match the second if possible, applying the specified function on a successful match
64−--
65−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
66−augment p q f = flip (maybe id $ flip f) <$> p <*> P.optionMaybe q
67−
68−-- |
69−-- Run the first parser, then match the second zero or more times, applying the specified function for each match
70−--
71−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
72−fold first more combine = do
73− a <- first
74− bs <- P.many more
75− return $ foldl combine a bs
76−
77−-- |
78−-- Build a parser from a smaller parser and a list of parsers for postfix operators
79−--
80−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
81−buildPostfixParser fs first = do
82− a <- first
83− go a
84− where
85− go a = do
86− maybeA <- P.optionMaybe $ P.choice (map ($ a) fs)
87− case maybeA of
88− Nothing -> return a
89− Just a' -> go a'
90−
91−-- |
92−-- Mark the current indentation level
93−--
94−mark :: P.Parsec s ParseState a -> P.Parsec s ParseState a
95−mark p = do
96− current <- indentationLevel <$> P.getState
97− pos <- P.sourceColumn <$> P.getPosition
98− P.modifyState $ \st -> st { indentationLevel = pos }
99− a <- p
100− P.modifyState $ \st -> st { indentationLevel = current }
101− return a
102−
103−-- |
104−-- Check that the current identation level matches a predicate
105−--
106−checkIndentation :: (P.Column -> P.Column -> Bool) -> P.Parsec s ParseState ()
107−checkIndentation rel = do
108− col <- P.sourceColumn <$> P.getPosition
109− current <- indentationLevel <$> P.getState
110− guard (col `rel` current)
111−
112−-- |
113−-- Check that the current indentation level is past the current mark
114−--
115−indented :: P.Parsec s ParseState ()
116−indented = checkIndentation (>) P.<?> "indentation"
117−
118−-- |
119−-- Check that the current indentation level is at the same indentation as the current mark
120−--
121−same :: P.Parsec s ParseState ()
122−same = checkIndentation (==) P.<?> "no indentation"
123−
124−-- |
125−-- Read the comments from the the next token, without consuming it
126−--
127−readComments :: P.Parsec [PositionedToken] u [Comment]
128−readComments = P.lookAhead $ ptComments <$> P.anyToken
129−
130−-- |
131−-- Run a parser
132−--
133−runTokenParser :: FilePath -> TokenParser a -> [PositionedToken] -> Either P.ParseError a
134−runTokenParser filePath p = P.runParser p (ParseState 0) filePath
src/Language/PureScript/Parser/Declarations.hsdeleted−518
@@ -1,518 +0,0 @@
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 TupleSections #-}
17−
18−module Language.PureScript.Parser.Declarations (
19− parseDeclaration,
20− parseModule,
21− parseModules,
22− parseModulesFromFiles,
23− parseValue,
24− parseGuard,
25− parseBinder,
26− parseBinderNoParens,
27−) where
28−
29−import Prelude hiding (lex)
30−
31−import Data.Maybe (isJust, fromMaybe)
32−import Data.Traversable (forM)
33−
34−import Control.Applicative
35−import Control.Arrow ((+++))
36−
37−import Language.PureScript.Kinds
38−import Language.PureScript.AST
39−import Language.PureScript.Comments
40−import Language.PureScript.Parser.Common
41−import Language.PureScript.Parser.Types
42−import Language.PureScript.Parser.Kinds
43−import Language.PureScript.Parser.Lexer
44−import Language.PureScript.Names
45−import Language.PureScript.CodeGen.JS.AST
46−import Language.PureScript.Environment
47−
48−import qualified Language.PureScript.Parser.Common as C
49−import qualified Text.Parsec as P
50−import qualified Text.Parsec.Expr as P
51−
52−-- |
53−-- Read source position information
54−--
55−withSourceSpan :: (SourceSpan -> [Comment] -> a -> a) -> P.Parsec [PositionedToken] u a -> P.Parsec [PositionedToken] u a
56−withSourceSpan f p = do
57− start <- P.getPosition
58− comments <- C.readComments
59− x <- p
60− end <- P.getPosition
61− let sp = SourceSpan (P.sourceName start) (toSourcePos start) (toSourcePos end)
62− return $ f sp comments x
63− where
64− toSourcePos pos = SourcePos (P.sourceLine pos) (P.sourceColumn pos)
65−
66−kindedIdent :: TokenParser (String, Maybe Kind)
67−kindedIdent = (, Nothing) <$> identifier
68− <|> parens ((,) <$> identifier <*> (Just <$> (indented *> doubleColon *> indented *> parseKind)))
69−
70−parseDataDeclaration :: TokenParser Declaration
71−parseDataDeclaration = do
72− dtype <- (reserved "data" *> return Data) <|> (reserved "newtype" *> return Newtype)
73− name <- indented *> properName
74− tyArgs <- many (indented *> kindedIdent)
75− ctors <- P.option [] $ do
76− indented *> equals
77− P.sepBy1 ((,) <$> properName <*> P.many (indented *> noWildcards parseTypeAtom)) pipe
78− return $ DataDeclaration dtype name tyArgs ctors
79−
80−parseTypeDeclaration :: TokenParser Declaration
81−parseTypeDeclaration =
82− TypeDeclaration <$> P.try (parseIdent <* indented <* doubleColon)
83− <*> parsePolyType
84−
85−parseTypeSynonymDeclaration :: TokenParser Declaration
86−parseTypeSynonymDeclaration =
87− TypeSynonymDeclaration <$> (P.try (reserved "type") *> indented *> properName)
88− <*> many (indented *> kindedIdent)
89− <*> (indented *> equals *> noWildcards parsePolyType)
90−
91−parseValueDeclaration :: TokenParser Declaration
92−parseValueDeclaration = do
93− name <- parseIdent
94− binders <- P.many parseBinderNoParens
95− value <- Left <$> (C.indented *>
96− P.many1 ((,) <$> parseGuard
97− <*> (indented *> equals *> parseValueWithWhereClause)
98− ))
99− <|> Right <$> (indented *> equals *> parseValueWithWhereClause)
100− return $ ValueDeclaration name Value binders value
101− where
102− parseValueWithWhereClause :: TokenParser Expr
103− parseValueWithWhereClause = do
104− value <- parseValue
105− whereClause <- P.optionMaybe $ do
106− C.indented
107− reserved "where"
108− C.indented
109− C.mark $ P.many1 (C.same *> parseLocalDeclaration)
110− return $ maybe value (`Let` value) whereClause
111−
112−parseExternDeclaration :: TokenParser Declaration
113−parseExternDeclaration = P.try (reserved "foreign") *> indented *> reserved "import" *> indented *>
114− (ExternDataDeclaration <$> (P.try (reserved "data") *> indented *> properName)
115− <*> (indented *> doubleColon *> parseKind)
116− <|> (do reserved "instance"
117− name <- parseIdent <* indented <* doubleColon
118− deps <- P.option [] $ do
119− deps <- parens (commaSep1 ((,) <$> parseQualified properName <*> P.many (noWildcards parseTypeAtom)))
120− indented
121− rfatArrow
122− return deps
123− className <- indented *> parseQualified properName
124− tys <- P.many (indented *> noWildcards parseTypeAtom)
125− return $ ExternInstanceDeclaration name deps className tys)
126− <|> (do ident <- parseIdent
127− js <- P.optionMaybe (JSRaw <$> stringLiteral)
128− ty <- indented *> doubleColon *> noWildcards parsePolyType
129− return $ ExternDeclaration (if isJust js then InlineJavascript else ForeignImport) ident js ty))
130−
131−parseAssociativity :: TokenParser Associativity
132−parseAssociativity =
133− (P.try (reserved "infixl") >> return Infixl) <|>
134− (P.try (reserved "infixr") >> return Infixr) <|>
135− (P.try (reserved "infix") >> return Infix)
136−
137−parseFixity :: TokenParser Fixity
138−parseFixity = Fixity <$> parseAssociativity <*> (indented *> natural)
139−
140−parseFixityDeclaration :: TokenParser Declaration
141−parseFixityDeclaration = do
142− fixity <- parseFixity
143− indented
144− name <- symbol
145− return $ FixityDeclaration fixity name
146−
147−parseImportDeclaration :: TokenParser Declaration
148−parseImportDeclaration = do
149− reserved "import"
150− indented
151− qualImport <|> stdImport
152− where
153− stdImport = do
154− moduleName' <- moduleName
155− stdImportHiding moduleName' <|> stdImportQualifying moduleName'
156− where
157− stdImportHiding mn = do
158− reserved "hiding"
159− declType <- importDeclarationType Hiding
160− return $ ImportDeclaration mn declType Nothing
161− stdImportQualifying mn = do
162− declType <- importDeclarationType Qualifying
163− return $ ImportDeclaration mn declType Nothing
164− qualImport = do
165− reserved "qualified"
166− indented
167− moduleName' <- moduleName
168− declType <- importDeclarationType Qualifying
169− reserved "as"
170− asQ <- moduleName
171− return $ ImportDeclaration moduleName' declType (Just asQ)
172− importDeclarationType expectedType = do
173− idents <- P.optionMaybe $ indented *> (parens $ commaSep parseDeclarationRef)
174− return $ fromMaybe Unqualified (expectedType <$> idents)
175−
176−
177−parseDeclarationRef :: TokenParser DeclarationRef
178−parseDeclarationRef = withSourceSpan PositionedDeclarationRef $
179− ValueRef <$> parseIdent
180− <|> do name <- properName
181− dctors <- P.optionMaybe $ parens (symbol' ".." *> pure Nothing <|> Just <$> commaSep properName)
182− return $ maybe (TypeClassRef name) (TypeRef name) dctors
183−
184−parseTypeClassDeclaration :: TokenParser Declaration
185−parseTypeClassDeclaration = do
186− reserved "class"
187− implies <- P.option [] $ do
188− indented
189− implies <- parens (commaSep1 ((,) <$> parseQualified properName <*> P.many (noWildcards parseTypeAtom)))
190− lfatArrow
191− return implies
192− className <- indented *> properName
193− idents <- P.many (indented *> kindedIdent)
194− members <- P.option [] . P.try $ do
195− indented *> reserved "where"
196− mark (P.many (same *> positioned parseTypeDeclaration))
197− return $ TypeClassDeclaration className idents implies members
198−
199−parseTypeInstanceDeclaration :: TokenParser Declaration
200−parseTypeInstanceDeclaration = do
201− reserved "instance"
202− name <- parseIdent <* indented <* doubleColon
203− deps <- P.optionMaybe $ do
204− deps <- parens (commaSep1 ((,) <$> parseQualified properName <*> P.many (noWildcards parseTypeAtom)))
205− indented
206− rfatArrow
207− return deps
208− className <- indented *> parseQualified properName
209− ty <- P.many (indented *> (noWildcards parseTypeAtom))
210− members <- P.option [] . P.try $ do
211− indented *> reserved "where"
212− mark (P.many (same *> positioned parseValueDeclaration))
213− return $ TypeInstanceDeclaration name (fromMaybe [] deps) className ty members
214−
215−positioned :: TokenParser Declaration -> TokenParser Declaration
216−positioned d = withSourceSpan PositionedDeclaration d
217−
218−-- |
219−-- Parse a single declaration
220−--
221−parseDeclaration :: TokenParser Declaration
222−parseDeclaration = positioned (P.choice
223− [ parseDataDeclaration
224− , parseTypeDeclaration
225− , parseTypeSynonymDeclaration
226− , parseValueDeclaration
227− , parseExternDeclaration
228− , parseFixityDeclaration
229− , parseImportDeclaration
230− , parseTypeClassDeclaration
231− , parseTypeInstanceDeclaration
232− ]) P.<?> "declaration"
233−
234−parseLocalDeclaration :: TokenParser Declaration
235−parseLocalDeclaration = positioned (P.choice
236− [ parseTypeDeclaration
237− , parseValueDeclaration
238− ] P.<?> "local declaration")
239−
240−-- |
241−-- Parse a module header and a collection of declarations
242−--
243−parseModule :: TokenParser Module
244−parseModule = do
245− reserved "module"
246− indented
247− name <- moduleName
248− exports <- P.optionMaybe $ parens $ commaSep1 parseDeclarationRef
249− reserved "where"
250− decls <- mark (P.many (same *> parseDeclaration))
251− return $ Module name decls exports
252−
253−-- |
254−-- Parse a collection of modules
255−--
256−parseModulesFromFiles :: (k -> String) -> [(k, String)] -> Either P.ParseError [(k, Module)]
257−parseModulesFromFiles toFilePath input =
258− fmap collect . forM input $ \(k, content) -> do
259− let filename = toFilePath k
260− ts <- lex filename content
261− ms <- runTokenParser filename parseModules ts
262− return (k, ms)
263− where
264− collect :: [(k, [v])] -> [(k, v)]
265− collect vss = [ (k, v) | (k, vs) <- vss, v <- vs ]
266−
267−-- |
268−-- Parse a collection of modules
269−--
270−parseModules :: TokenParser [Module]
271−parseModules = mark (P.many (same *> parseModule)) <* P.eof
272−
273−booleanLiteral :: TokenParser Bool
274−booleanLiteral = (reserved "true" >> return True) P.<|> (reserved "false" >> return False)
275−
276−parseNumericLiteral :: TokenParser Expr
277−parseNumericLiteral = NumericLiteral <$> number
278−
279−parseStringLiteral :: TokenParser Expr
280−parseStringLiteral = StringLiteral <$> stringLiteral
281−
282−parseBooleanLiteral :: TokenParser Expr
283−parseBooleanLiteral = BooleanLiteral <$> booleanLiteral
284−
285−parseArrayLiteral :: TokenParser Expr
286−parseArrayLiteral = ArrayLiteral <$> squares (commaSep parseValue)
287−
288−parseObjectLiteral :: TokenParser Expr
289−parseObjectLiteral = ObjectConstructor <$> braces (commaSep parseIdentifierAndValue)
290−
291−parseIdentifierAndValue :: TokenParser (String, Maybe Expr)
292−parseIdentifierAndValue = (,) <$> (C.indented *> (lname <|> stringLiteral) <* C.indented <* colon)
293− <*> (C.indented *> val)
294− where
295− val = (Just <$> parseValue) <|> (underscore *> pure Nothing)
296−
297−parseAbs :: TokenParser Expr
298−parseAbs = do
299− symbol' "\\"
300− args <- P.many1 (C.indented *> (Abs <$> (Left <$> P.try C.parseIdent <|> Right <$> parseBinderNoParens)))
301− C.indented *> rarrow
302− value <- parseValue
303− return $ toFunction args value
304− where
305− toFunction :: [Expr -> Expr] -> Expr -> Expr
306− toFunction args value = foldr ($) value args
307−
308−parseVar :: TokenParser Expr
309−parseVar = Var <$> C.parseQualified C.parseIdent
310−
311−parseConstructor :: TokenParser Expr
312−parseConstructor = Constructor <$> C.parseQualified C.properName
313−
314−parseCase :: TokenParser Expr
315−parseCase = Case <$> P.between (P.try (reserved "case")) (C.indented *> reserved "of") (return <$> parseValue)
316− <*> (C.indented *> C.mark (P.many (C.same *> C.mark parseCaseAlternative)))
317−
318−parseCaseAlternative :: TokenParser CaseAlternative
319−parseCaseAlternative = CaseAlternative <$> (return <$> parseBinder)
320− <*> (Left <$> (C.indented *>
321− P.many1 ((,) <$> parseGuard
322− <*> (indented *> rarrow *> parseValue)
323− ))
324− <|> Right <$> (indented *> rarrow *> parseValue))
325− P.<?> "case alternative"
326−
327−parseIfThenElse :: TokenParser Expr
328−parseIfThenElse = IfThenElse <$> (P.try (reserved "if") *> C.indented *> parseValue)
329− <*> (C.indented *> reserved "then" *> C.indented *> parseValue)
330− <*> (C.indented *> reserved "else" *> C.indented *> parseValue)
331−
332−parseLet :: TokenParser Expr
333−parseLet = do
334− reserved "let"
335− C.indented
336− ds <- C.mark $ P.many1 (C.same *> parseLocalDeclaration)
337− C.indented
338− reserved "in"
339− result <- parseValue
340− return $ Let ds result
341−
342−parseValueAtom :: TokenParser Expr
343−parseValueAtom = P.choice
344− [ P.try parseNumericLiteral
345− , P.try parseStringLiteral
346− , P.try parseBooleanLiteral
347− , parseArrayLiteral
348− , P.try parseObjectLiteral
349− , P.try parseObjectGetter
350− , parseAbs
351− , P.try parseConstructor
352− , P.try parseVar
353− , parseCase
354− , parseIfThenElse
355− , parseDo
356− , parseLet
357− , P.try $ Parens <$> parens parseValue
358− , parseOperatorSection
359− , P.try parseObjectUpdaterWildcard ]
360−
361−-- |
362−-- Parse an expression in backticks or an operator
363−--
364−parseInfixExpr :: TokenParser Expr
365−parseInfixExpr = P.between tick tick parseValue
366− <|> Var <$> parseQualified (Op <$> symbol)
367−
368−parseOperatorSection :: TokenParser Expr
369−parseOperatorSection = parens $ left <|> right
370− where
371− right = OperatorSection <$> parseInfixExpr <* indented <*> (Right <$> parseValueAtom)
372− left = flip OperatorSection <$> (Left <$> parseValueAtom) <* indented <*> parseInfixExpr
373−
374−parsePropertyUpdate :: TokenParser (String, Maybe Expr)
375−parsePropertyUpdate = do
376− name <- lname <|> stringLiteral
377− _ <- C.indented *> equals
378− value <- C.indented *> (underscore *> pure Nothing) <|> (Just <$> parseValue)
379− return (name, value)
380−
381−parseAccessor :: Expr -> TokenParser Expr
382−parseAccessor (Constructor _) = P.unexpected "constructor"
383−parseAccessor obj = P.try $ Accessor <$> (C.indented *> dot *> C.indented *> (lname <|> stringLiteral)) <*> pure obj
384−
385−parseDo :: TokenParser Expr
386−parseDo = do
387− reserved "do"
388− C.indented
389− Do <$> C.mark (P.many (C.same *> C.mark parseDoNotationElement))
390−
391−parseDoNotationLet :: TokenParser DoNotationElement
392−parseDoNotationLet = DoNotationLet <$> (reserved "let" *> C.indented *> C.mark (P.many1 (C.same *> parseLocalDeclaration)))
393−
394−parseDoNotationBind :: TokenParser DoNotationElement
395−parseDoNotationBind = DoNotationBind <$> parseBinder <*> (C.indented *> larrow *> parseValue)
396−
397−parseDoNotationElement :: TokenParser DoNotationElement
398−parseDoNotationElement = P.choice
399− [ P.try parseDoNotationBind
400− , parseDoNotationLet
401− , P.try (DoNotationValue <$> parseValue) ]
402−
403−parseObjectGetter :: TokenParser Expr
404−parseObjectGetter = ObjectGetter <$> (underscore *> C.indented *> dot *> C.indented *> (lname <|> stringLiteral))
405−
406−-- |
407−-- Parse a value
408−--
409−parseValue :: TokenParser Expr
410−parseValue = withSourceSpan PositionedValue
411− (P.buildExpressionParser operators
412− . C.buildPostfixParser postfixTable2
413− $ indexersAndAccessors) P.<?> "expression"
414− where
415− indexersAndAccessors = C.buildPostfixParser postfixTable1 parseValueAtom
416− postfixTable1 = [ parseAccessor
417− , P.try . parseUpdaterBody . Just ]
418− postfixTable2 = [ \v -> P.try (flip App <$> (C.indented *> indexersAndAccessors)) <*> pure v
419− , \v -> flip (TypedValue True) <$> (P.try (C.indented *> doubleColon) *> parsePolyType) <*> pure v
420− ]
421− operators = [ [ P.Prefix (P.try (C.indented *> symbol' "-") >> return UnaryMinus)
422− ]
423− , [ P.Infix (P.try (C.indented *> parseInfixExpr P.<?> "infix expression") >>= \ident ->
424− return (BinaryNoParens ident)) P.AssocRight
425− ]
426− ]
427−
428−parseUpdaterBody :: Maybe Expr -> TokenParser Expr
429−parseUpdaterBody v = ObjectUpdater v <$> (C.indented *> braces (commaSep1 (C.indented *> parsePropertyUpdate)))
430−
431−parseObjectUpdaterWildcard :: TokenParser Expr
432−parseObjectUpdaterWildcard = underscore *> C.indented *> parseUpdaterBody Nothing
433−
434−parseStringBinder :: TokenParser Binder
435−parseStringBinder = StringBinder <$> stringLiteral
436−
437−parseBooleanBinder :: TokenParser Binder
438−parseBooleanBinder = BooleanBinder <$> booleanLiteral
439−
440−parseNumberBinder :: TokenParser Binder
441−parseNumberBinder = NumberBinder <$> (sign <*> number)
442− where
443− sign :: TokenParser (Either Integer Double -> Either Integer Double)
444− sign = (symbol' "-" >> return (negate +++ negate))
445− <|> (symbol' "+" >> return id)
446− <|> return id
447−
448−parseVarBinder :: TokenParser Binder
449−parseVarBinder = VarBinder <$> C.parseIdent
450−
451−parseNullaryConstructorBinder :: TokenParser Binder
452−parseNullaryConstructorBinder = ConstructorBinder <$> C.parseQualified C.properName <*> pure []
453−
454−parseConstructorBinder :: TokenParser Binder
455−parseConstructorBinder = ConstructorBinder <$> C.parseQualified C.properName <*> many (C.indented *> parseBinderNoParens)
456−
457−parseObjectBinder :: TokenParser Binder
458−parseObjectBinder = ObjectBinder <$> braces (commaSep (C.indented *> parseIdentifierAndBinder))
459−
460−parseArrayBinder :: TokenParser Binder
461−parseArrayBinder = squares $ ArrayBinder <$> commaSep (C.indented *> parseBinder)
462−
463−parseNamedBinder :: TokenParser Binder
464−parseNamedBinder = NamedBinder <$> (C.parseIdent <* C.indented <* at)
465− <*> (C.indented *> parseBinder)
466−
467−parseNullBinder :: TokenParser Binder
468−parseNullBinder = underscore *> return NullBinder
469−
470−parseIdentifierAndBinder :: TokenParser (String, Binder)
471−parseIdentifierAndBinder = do
472− name <- lname <|> stringLiteral
473− C.indented *> (equals <|> colon)
474− binder <- C.indented *> parseBinder
475− return (name, binder)
476−
477−-- |
478−-- Parse a binder
479−--
480−parseBinder :: TokenParser Binder
481−parseBinder = withSourceSpan PositionedBinder (P.buildExpressionParser operators parseBinderAtom P.<?> "expression")
482− where
483− operators = [ [ P.Infix (P.try $ C.indented *> colon *> return ConsBinder) P.AssocRight ] ]
484− parseBinderAtom :: TokenParser Binder
485− parseBinderAtom = P.choice (map P.try
486− [ parseNullBinder
487− , parseStringBinder
488− , parseBooleanBinder
489− , parseNumberBinder
490− , parseNamedBinder
491− , parseVarBinder
492− , parseConstructorBinder
493− , parseObjectBinder
494− , parseArrayBinder
495− , parens parseBinder ]) P.<?> "binder"
496−
497−-- |
498−-- Parse a binder as it would appear in a top level declaration
499−--
500−parseBinderNoParens :: TokenParser Binder
501−parseBinderNoParens = P.choice (map P.try
502− [ parseNullBinder
503− , parseStringBinder
504− , parseBooleanBinder
505− , parseNumberBinder
506− , parseNamedBinder
507− , parseVarBinder
508− , parseNullaryConstructorBinder
509− , parseObjectBinder
510− , parseArrayBinder
511− , parens parseBinder ]) P.<?> "binder"
512−-- |
513−-- Parse a guard
514−--
515−parseGuard :: TokenParser Guard
516−parseGuard = pipe *> C.indented *> parseValue
517−
518−
src/Language/PureScript/Parser/Kinds.hsdeleted−45
@@ -1,45 +0,0 @@
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.hsdeleted−499
@@ -1,499 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.Parser.Lexer
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−-- The first step in the parsing process - turns source code into a list of lexemes
13−--
14−-----------------------------------------------------------------------------
15−
16−{-# LANGUAGE TupleSections #-}
17−
18−module Language.PureScript.Parser.Lexer
19− ( PositionedToken(..)
20− , Token()
21− , TokenParser()
22− , lex
23− , anyToken
24− , token
25− , match
26− , lparen
27− , rparen
28− , parens
29− , lbrace
30− , rbrace
31− , braces
32− , lsquare
33− , rsquare
34− , squares
35− , indent
36− , indentAt
37− , larrow
38− , rarrow
39− , lfatArrow
40− , rfatArrow
41− , colon
42− , doubleColon
43− , equals
44− , pipe
45− , tick
46− , dot
47− , comma
48− , semi
49− , at
50− , underscore
51− , semiSep
52− , semiSep1
53− , commaSep
54− , commaSep1
55− , lname
56− , qualifier
57− , uname
58− , uname'
59− , mname
60− , reserved
61− , symbol
62− , symbol'
63− , identifier
64− , stringLiteral
65− , number
66− , natural
67− , reservedPsNames
68− , reservedTypeNames
69− , opChars
70− )
71− where
72−
73−import Prelude hiding (lex)
74−
75−import Data.Char (isSpace)
76−
77−import Control.Monad (void, guard)
78−import Data.Functor.Identity
79−
80−import Control.Applicative
81−
82−import Language.PureScript.Parser.State
83−import Language.PureScript.Comments
84−
85−import qualified Text.Parsec as P
86−import qualified Text.Parsec.Token as PT
87−
88−data Token
89− = LParen
90− | RParen
91− | LBrace
92− | RBrace
93− | LSquare
94− | RSquare
95− | Indent Int
96− | LArrow
97− | RArrow
98− | LFatArrow
99− | RFatArrow
100− | Colon
101− | DoubleColon
102− | Equals
103− | Pipe
104− | Tick
105− | Dot
106− | Comma
107− | Semi
108− | At
109− | Underscore
110− | LName String
111− | UName String
112− | Qualifier String
113− | Symbol String
114− | StringLiteral String
115− | Number (Either Integer Double)
116− deriving (Show, Eq, Ord)
117−
118−prettyPrintToken :: Token -> String
119−prettyPrintToken LParen = "("
120−prettyPrintToken RParen = ")"
121−prettyPrintToken LBrace = "{"
122−prettyPrintToken RBrace = "}"
123−prettyPrintToken LSquare = "["
124−prettyPrintToken RSquare = "]"
125−prettyPrintToken LArrow = "<-"
126−prettyPrintToken RArrow = "->"
127−prettyPrintToken LFatArrow = "<="
128−prettyPrintToken RFatArrow = "=>"
129−prettyPrintToken Colon = ":"
130−prettyPrintToken DoubleColon = "::"
131−prettyPrintToken Equals = "="
132−prettyPrintToken Pipe = "|"
133−prettyPrintToken Tick = "`"
134−prettyPrintToken Dot = "."
135−prettyPrintToken Comma = ","
136−prettyPrintToken Semi = ";"
137−prettyPrintToken At = "@"
138−prettyPrintToken Underscore = "_"
139−prettyPrintToken (Indent n) = "indentation at level " ++ show n
140−prettyPrintToken (LName s) = show s
141−prettyPrintToken (UName s) = show s
142−prettyPrintToken (Qualifier _) = "qualifier"
143−prettyPrintToken (Symbol s) = s
144−prettyPrintToken (StringLiteral s) = show s
145−prettyPrintToken (Number n) = either show show n
146−
147−data PositionedToken = PositionedToken
148− { ptSourcePos :: P.SourcePos
149− , ptToken :: Token
150− , ptComments :: [Comment]
151− } deriving (Eq)
152−
153−instance Show PositionedToken where
154− show = show . ptToken
155−
156−lex :: FilePath -> String -> Either P.ParseError [PositionedToken]
157−lex filePath input = P.parse parseTokens filePath input
158−
159−parseTokens :: P.Parsec String u [PositionedToken]
160−parseTokens = whitespace *> P.many parsePositionedToken <* P.skipMany parseComment <* P.eof
161−
162−whitespace :: P.Parsec String u ()
163−whitespace = P.skipMany (P.satisfy isSpace)
164−
165−parseComment :: P.Parsec String u Comment
166−parseComment = (BlockComment <$> blockComment <|> LineComment <$> lineComment) <* whitespace
167− where
168− blockComment :: P.Parsec String u String
169− blockComment = P.try $ P.string "{-" *> P.manyTill P.anyChar (P.try (P.string "-}"))
170−
171− lineComment :: P.Parsec String u String
172− lineComment = P.try $ P.string "--" *> P.manyTill P.anyChar (P.try (void (P.char '\n') <|> P.eof))
173−
174−parsePositionedToken :: P.Parsec String u PositionedToken
175−parsePositionedToken = P.try $ do
176− comments <- P.many parseComment
177− pos <- P.getPosition
178− tok <- parseToken
179− return $ PositionedToken pos tok comments
180−
181−parseToken :: P.Parsec String u Token
182−parseToken = P.choice
183− [ P.try $ P.string "<-" *> P.notFollowedBy symbolChar *> pure LArrow
184− , P.try $ P.string "<=" *> P.notFollowedBy symbolChar *> pure LFatArrow
185− , P.try $ P.string "->" *> P.notFollowedBy symbolChar *> pure RArrow
186− , P.try $ P.string "=>" *> P.notFollowedBy symbolChar *> pure RFatArrow
187− , P.try $ P.string "::" *> P.notFollowedBy symbolChar *> pure DoubleColon
188− , P.try $ P.char '(' *> pure LParen
189− , P.try $ P.char ')' *> pure RParen
190− , P.try $ P.char '{' *> pure LBrace
191− , P.try $ P.char '}' *> pure RBrace
192− , P.try $ P.char '[' *> pure LSquare
193− , P.try $ P.char ']' *> pure RSquare
194− , P.try $ P.char '`' *> pure Tick
195− , P.try $ P.char ',' *> pure Comma
196− , P.try $ P.char '=' *> P.notFollowedBy symbolChar *> pure Equals
197− , P.try $ P.char ':' *> P.notFollowedBy symbolChar *> pure Colon
198− , P.try $ P.char '|' *> P.notFollowedBy symbolChar *> pure Pipe
199− , P.try $ P.char '.' *> P.notFollowedBy symbolChar *> pure Dot
200− , P.try $ P.char ';' *> P.notFollowedBy symbolChar *> pure Semi
201− , P.try $ P.char '@' *> P.notFollowedBy symbolChar *> pure At
202− , P.try $ P.char '_' *> P.notFollowedBy identLetter *> pure Underscore
203− , LName <$> parseLName
204− , do uName <- parseUName
205− (guard (validModuleName uName) >> Qualifier uName <$ P.char '.') <|> pure (UName uName)
206− , Symbol <$> parseSymbol
207− , StringLiteral <$> parseStringLiteral
208− , Number <$> parseNumber
209− ] <* whitespace
210−
211− where
212− parseLName :: P.Parsec String u String
213− parseLName = (:) <$> identStart <*> P.many identLetter
214−
215− parseUName :: P.Parsec String u String
216− parseUName = (:) <$> P.upper <*> P.many uidentLetter
217−
218− parseSymbol :: P.Parsec String u String
219− parseSymbol = P.many1 symbolChar
220−
221− identStart :: P.Parsec String u Char
222− identStart = P.lower <|> P.oneOf "_"
223−
224− identLetter :: P.Parsec String u Char
225− identLetter = P.alphaNum <|> P.oneOf "_'"
226−
227− uidentLetter :: P.Parsec String u Char
228− uidentLetter = P.alphaNum <|> P.char '_'
229−
230− symbolChar :: P.Parsec String u Char
231− symbolChar = P.oneOf opChars
232−
233− parseStringLiteral :: P.Parsec String u String
234− parseStringLiteral = blockString <|> PT.stringLiteral tokenParser
235− where
236− delimeter = P.try (P.string "\"\"\"")
237− blockString = delimeter >> P.manyTill P.anyChar delimeter
238−
239− parseNumber :: P.Parsec String u (Either Integer Double)
240− parseNumber = (Right <$> P.try (PT.float tokenParser) <|>
241− Left <$> P.try (PT.natural tokenParser)) P.<?> "number"
242−
243−-- |
244−-- We use Text.Parsec.Token to implement the string and number lexemes
245−--
246−langDef :: PT.GenLanguageDef String u Identity
247−langDef = PT.LanguageDef
248− { PT.reservedNames = []
249− , PT.reservedOpNames = []
250− , PT.commentStart = ""
251− , PT.commentEnd = ""
252− , PT.commentLine = ""
253− , PT.nestedComments = True
254− , PT.identStart = fail "Identifiers not supported"
255− , PT.identLetter = fail "Identifiers not supported"
256− , PT.opStart = fail "Operators not supported"
257− , PT.opLetter = fail "Operators not supported"
258− , PT.caseSensitive = True
259− }
260−
261−-- |
262−-- A token parser based on the language definition
263−--
264−tokenParser :: PT.GenTokenParser String u Identity
265−tokenParser = PT.makeTokenParser langDef
266−
267−type TokenParser a = P.Parsec [PositionedToken] ParseState a
268−
269−anyToken :: TokenParser PositionedToken
270−anyToken = P.token (prettyPrintToken . ptToken) ptSourcePos Just
271−
272−token :: (Token -> Maybe a) -> TokenParser a
273−token f = P.token (prettyPrintToken . ptToken) ptSourcePos (f . ptToken)
274−
275−match :: Token -> TokenParser ()
276−match tok = token (\tok' -> if tok == tok' then Just () else Nothing) P.<?> prettyPrintToken tok
277−
278−lparen :: TokenParser ()
279−lparen = match LParen
280−
281−rparen :: TokenParser ()
282−rparen = match RParen
283−
284−parens :: TokenParser a -> TokenParser a
285−parens = P.between lparen rparen
286−
287−lbrace :: TokenParser ()
288−lbrace = match LBrace
289−
290−rbrace :: TokenParser ()
291−rbrace = match RBrace
292−
293−braces :: TokenParser a -> TokenParser a
294−braces = P.between lbrace rbrace
295−
296−lsquare :: TokenParser ()
297−lsquare = match LSquare
298−
299−rsquare :: TokenParser ()
300−rsquare = match RSquare
301−
302−squares :: TokenParser a -> TokenParser a
303−squares = P.between lsquare rsquare
304−
305−indent :: TokenParser Int
306−indent = token go P.<?> "indentation"
307− where
308− go (Indent n) = Just n
309− go _ = Nothing
310−
311−indentAt :: P.Column -> TokenParser ()
312−indentAt n = token go P.<?> "indentation at level " ++ show n
313− where
314− go (Indent n') | n == n' = Just ()
315− go _ = Nothing
316−
317−larrow :: TokenParser ()
318−larrow = match LArrow
319−
320−rarrow :: TokenParser ()
321−rarrow = match RArrow
322−
323−lfatArrow :: TokenParser ()
324−lfatArrow = match LFatArrow
325−
326−rfatArrow :: TokenParser ()
327−rfatArrow = match RFatArrow
328−
329−colon :: TokenParser ()
330−colon = match Colon
331−
332−doubleColon :: TokenParser ()
333−doubleColon = match DoubleColon
334−
335−equals :: TokenParser ()
336−equals = match Equals
337−
338−pipe :: TokenParser ()
339−pipe = match Pipe
340−
341−tick :: TokenParser ()
342−tick = match Tick
343−
344−dot :: TokenParser ()
345−dot = match Dot
346−
347−comma :: TokenParser ()
348−comma = match Comma
349−
350−semi :: TokenParser ()
351−semi = match Semi
352−
353−at :: TokenParser ()
354−at = match At
355−
356−underscore :: TokenParser ()
357−underscore = match Underscore
358−
359−-- |
360−-- Parse zero or more values separated by semicolons
361−--
362−semiSep :: TokenParser a -> TokenParser [a]
363−semiSep = flip P.sepBy semi
364−
365−-- |
366−-- Parse one or more values separated by semicolons
367−--
368−semiSep1 :: TokenParser a -> TokenParser [a]
369−semiSep1 = flip P.sepBy1 semi
370−
371−-- |
372−-- Parse zero or more values separated by commas
373−--
374−commaSep :: TokenParser a -> TokenParser [a]
375−commaSep = flip P.sepBy comma
376−
377−-- |
378−-- Parse one or more values separated by commas
379−--
380−commaSep1 :: TokenParser a -> TokenParser [a]
381−commaSep1 = flip P.sepBy1 comma
382−
383−lname :: TokenParser String
384−lname = token go P.<?> "identifier"
385− where
386− go (LName s) = Just s
387− go _ = Nothing
388−
389−qualifier :: TokenParser String
390−qualifier = token go P.<?> "qualifier"
391− where
392− go (Qualifier s) = Just s
393− go _ = Nothing
394−
395−reserved :: String -> TokenParser ()
396−reserved s = token go P.<?> show s
397− where
398− go (LName s') | s == s' = Just ()
399− go _ = Nothing
400−
401−uname :: TokenParser String
402−uname = token go P.<?> "proper name"
403− where
404− go (UName s) = Just s
405− go _ = Nothing
406−
407−mname :: TokenParser String
408−mname = token go P.<?> "module name"
409− where
410− go (UName s) | validModuleName s = Just s
411− go _ = Nothing
412−
413−uname' :: String -> TokenParser ()
414−uname' s = token go P.<?> show s
415− where
416− go (UName s') | s == s' = Just ()
417− go _ = Nothing
418−
419−symbol :: TokenParser String
420−symbol = token go P.<?> "symbol"
421− where
422− go (Symbol s) = Just s
423− go Colon = Just ":"
424− go LFatArrow = Just "<="
425− go At = Just "@"
426− go _ = Nothing
427−
428−symbol' :: String -> TokenParser ()
429−symbol' s = token go P.<?> show s
430− where
431− go (Symbol s') | s == s' = Just ()
432− go Colon | s == ":" = Just ()
433− go LFatArrow | s == "<=" = Just ()
434− go _ = Nothing
435−
436−stringLiteral :: TokenParser String
437−stringLiteral = token go P.<?> "string literal"
438− where
439− go (StringLiteral s) = Just s
440− go _ = Nothing
441−
442−number :: TokenParser (Either Integer Double)
443−number = token go P.<?> "number"
444− where
445− go (Number n) = Just n
446− go _ = Nothing
447−
448−natural :: TokenParser Integer
449−natural = token go P.<?> "natural"
450− where
451− go (Number (Left n)) = Just n
452− go _ = Nothing
453−
454−identifier :: TokenParser String
455−identifier = token go P.<?> "identifier"
456− where
457− go (LName s) | s `notElem` reservedPsNames = Just s
458− go _ = Nothing
459−
460−validModuleName :: String -> Bool
461−validModuleName s = not ('_' `elem` s)
462−
463−-- |
464−-- A list of purescript reserved identifiers
465−--
466−reservedPsNames :: [String]
467−reservedPsNames = [ "data"
468− , "newtype"
469− , "type"
470− , "foreign"
471− , "import"
472− , "infixl"
473− , "infixr"
474− , "infix"
475− , "class"
476− , "instance"
477− , "module"
478− , "case"
479− , "of"
480− , "if"
481− , "then"
482− , "else"
483− , "do"
484− , "let"
485− , "true"
486− , "false"
487− , "in"
488− , "where"
489− ]
490−
491−reservedTypeNames :: [String]
492−reservedTypeNames = [ "forall", "where" ]
493−
494−-- |
495−-- The characters allowed for use in operators
496−--
497−opChars :: [Char]
498−opChars = ":!#$%&*+./<=>?@\\^|-~"
499−
src/Language/PureScript/Parser/State.hsdeleted−30
@@ -1,30 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.Parser.State
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−-- State for the parser monad
13−--
14−-----------------------------------------------------------------------------
15−
16−module Language.PureScript.Parser.State where
17−
18−import qualified Text.Parsec as P
19−
20−-- |
21−-- State for the parser monad
22−--
23−data ParseState = ParseState {
24− -- |
25− -- The most recently marked indentation level
26− --
27− indentationLevel :: P.Column
28− } deriving Show
29−
30−
src/Language/PureScript/Parser/Types.hsdeleted−134
@@ -1,134 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.Parser.Types
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 types
13−--
14−-----------------------------------------------------------------------------
15−
16−module Language.PureScript.Parser.Types (
17− parseType,
18− parsePolyType,
19− noWildcards,
20− parseTypeAtom
21−) where
22−
23−import Control.Applicative
24−import Control.Monad (when, unless)
25−
26−import Language.PureScript.Types
27−import Language.PureScript.Parser.Common
28−import Language.PureScript.Parser.Kinds
29−import Language.PureScript.Parser.Lexer
30−import Language.PureScript.Environment
31−
32−import qualified Text.Parsec as P
33−import qualified Text.Parsec.Expr as P
34−
35−parseArray :: TokenParser Type
36−parseArray = squares $ return tyArray
37−
38−parseArrayOf :: TokenParser Type
39−parseArrayOf = squares $ TypeApp tyArray <$> parseType
40−
41−parseFunction :: TokenParser Type
42−parseFunction = parens $ rarrow >> return tyFunction
43−
44−parseObject :: TokenParser Type
45−parseObject = braces $ TypeApp tyObject <$> parseRow
46−
47−parseTypeWildcard :: TokenParser Type
48−parseTypeWildcard = underscore >> return TypeWildcard
49−
50−parseTypeVariable :: TokenParser Type
51−parseTypeVariable = do
52− ident <- identifier
53− when (ident `elem` reservedTypeNames) $ P.unexpected ident
54− return $ TypeVar ident
55−
56−parseTypeConstructor :: TokenParser Type
57−parseTypeConstructor = TypeConstructor <$> parseQualified properName
58−
59−parseForAll :: TokenParser Type
60−parseForAll = mkForAll <$> (P.try (reserved "forall") *> P.many1 (indented *> identifier) <* indented <* dot)
61− <*> parseConstrainedType
62−
63−-- |
64−-- Parse a type as it appears in e.g. a data constructor
65−--
66−parseTypeAtom :: TokenParser Type
67−parseTypeAtom = indented *> P.choice (map P.try
68− [ parseArray
69− , parseArrayOf
70− , parseFunction
71− , parseObject
72− , parseTypeWildcard
73− , parseTypeVariable
74− , parseTypeConstructor
75− , parseForAll
76− , parens parseRow
77− , parens parsePolyType ])
78−
79−parseConstrainedType :: TokenParser Type
80−parseConstrainedType = do
81− constraints <- P.optionMaybe . P.try $ do
82− constraints <- parens . commaSep1 $ do
83− className <- parseQualified properName
84− indented
85− ty <- P.many parseTypeAtom
86− return (className, ty)
87− _ <- rfatArrow
88− return constraints
89− indented
90− ty <- parseType
91− return $ maybe ty (flip ConstrainedType ty) constraints
92−
93−parseAnyType :: TokenParser Type
94−parseAnyType = P.buildExpressionParser operators (buildPostfixParser postfixTable parseTypeAtom) P.<?> "type"
95− where
96− operators = [ [ P.Infix (return TypeApp) P.AssocLeft ]
97− , [ P.Infix (rarrow >> return function) P.AssocRight ] ]
98− postfixTable = [ \t -> KindedType t <$> (P.try (indented *> doubleColon) *> parseKind)
99− ]
100−
101−-- |
102−-- Parse a monotype
103−--
104−parseType :: TokenParser Type
105−parseType = do
106− ty <- parseAnyType
107− unless (isMonoType ty) $ P.unexpected "polymorphic type"
108− return ty
109−
110−-- |
111−-- Parse a polytype
112−--
113−parsePolyType :: TokenParser Type
114−parsePolyType = parseAnyType
115−
116−-- |
117−-- Parse an atomic type with no wildcards
118−--
119−noWildcards :: TokenParser Type -> TokenParser Type
120−noWildcards p = do
121− ty <- p
122− when (containsWildcards ty) $ P.unexpected "type wildcard"
123− return ty
124−
125−parseNameAndType :: TokenParser t -> TokenParser (String, t)
126−parseNameAndType p = (,) <$> (indented *> (lname <|> stringLiteral) <* indented <* doubleColon) <*> p
127−
128−parseRowEnding :: TokenParser Type
129−parseRowEnding = P.option REmpty $ indented *> pipe *> indented *> P.choice (map P.try
130− [ parseTypeWildcard
131− , TypeVar <$> identifier ])
132−
133−parseRow :: TokenParser Type
134−parseRow = (curry rowFromList <$> commaSep (parseNameAndType parsePolyType) <*> parseRowEnding) P.<?> "row"
src/Language/PureScript/Pretty.hsdeleted−32
@@ -1,32 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.Pretty
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 pretty printers for core data types:
13−--
14−-- [@Language.PureScript.Pretty.Kinds@] Pretty printer for kinds
15−--
16−-- [@Language.PureScript.Pretty.Values@] Pretty printer for values
17−--
18−-- [@Language.PureScript.Pretty.Types@] Pretty printer for types
19−--
20−-- [@Language.PureScript.Pretty.JS@] Pretty printer for values, used for code generation
21−--
22−-----------------------------------------------------------------------------
23−
24−module Language.PureScript.Pretty (module P) where
25−
26−import Language.PureScript.Pretty.Kinds as P
27−import Language.PureScript.Pretty.Values as P
28−import Language.PureScript.Pretty.Types as P
29−import Language.PureScript.Pretty.JS as P
30−
31−
32−
src/Language/PureScript/Pretty/Common.hsdeleted−69
@@ -1,69 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.Pretty.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 pretty-printing utility functions
13−--
14−-----------------------------------------------------------------------------
15−
16−module Language.PureScript.Pretty.Common where
17−
18−import Control.Monad.State
19−import Data.List (intercalate)
20−import Language.PureScript.Parser.Lexer (reservedPsNames, opChars)
21−
22−-- |
23−-- Wrap a string in parentheses
24−--
25−parens :: String -> String
26−parens s = ('(':s) ++ ")"
27−
28−newtype PrinterState = PrinterState { indent :: Int } deriving (Show, Eq, Ord)
29−
30−-- |
31−-- Number of characters per identation level
32−--
33−blockIndent :: Int
34−blockIndent = 4
35−
36−-- |
37−-- Pretty print with a new indentation level
38−--
39−withIndent :: StateT PrinterState Maybe String -> StateT PrinterState Maybe String
40−withIndent action = do
41− modify $ \st -> st { indent = indent st + blockIndent }
42− result <- action
43− modify $ \st -> st { indent = indent st - blockIndent }
44− return result
45−
46−-- |
47−-- Get the current indentation level
48−--
49−currentIndent :: StateT PrinterState Maybe String
50−currentIndent = do
51− current <- get
52− return $ replicate (indent current) ' '
53−
54−-- |
55−-- Print many lines
56−--
57−prettyPrintMany :: (a -> StateT PrinterState Maybe String) -> [a] -> StateT PrinterState Maybe String
58−prettyPrintMany f xs = do
59− ss <- mapM f xs
60− indentString <- currentIndent
61− return $ intercalate "\n" $ map (indentString ++) ss
62−
63−-- |
64−-- Prints an object key, escaping reserved names.
65−--
66−prettyPrintObjectKey :: String -> String
67−prettyPrintObjectKey s | s `elem` reservedPsNames = show s
68− | any (`elem` opChars) s = show s
69− | otherwise = s
src/Language/PureScript/Pretty/JS.hsdeleted−301
@@ -1,301 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.Pretty.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−-- Pretty printer for the Javascript AST
13−--
14−-----------------------------------------------------------------------------
15−
16−module Language.PureScript.Pretty.JS (
17− prettyPrintJS
18−) where
19−
20−import Data.List
21−import Data.Maybe (fromMaybe)
22−
23−import Control.Applicative
24−import Control.Arrow ((<+>))
25−import Control.Monad.State
26−import Control.PatternArrows
27−import qualified Control.Arrow as A
28−
29−import Language.PureScript.CodeGen.JS.AST
30−import Language.PureScript.CodeGen.JS.Common
31−import Language.PureScript.Pretty.Common
32−import Language.PureScript.Comments
33−
34−import Numeric
35−
36−literals :: Pattern PrinterState JS String
37−literals = mkPattern' match
38− where
39− match :: JS -> StateT PrinterState Maybe String
40− match (JSNumericLiteral n) = return $ either show show n
41− match (JSStringLiteral s) = return $ string s
42− match (JSBooleanLiteral True) = return "true"
43− match (JSBooleanLiteral False) = return "false"
44− match (JSArrayLiteral xs) = fmap concat $ sequence
45− [ return "[ "
46− , fmap (intercalate ", ") $ forM xs prettyPrintJS'
47− , return " ]"
48− ]
49− match (JSObjectLiteral []) = return "{}"
50− match (JSObjectLiteral ps) = fmap concat $ sequence
51− [ return "{\n"
52− , withIndent $ do
53− jss <- forM ps $ \(key, value) -> fmap ((objectPropertyToString key ++ ": ") ++) . prettyPrintJS' $ value
54− indentString <- currentIndent
55− return $ intercalate ", \n" $ map (indentString ++) jss
56− , return "\n"
57− , currentIndent
58− , return "}"
59− ]
60− where
61− objectPropertyToString :: String -> String
62− objectPropertyToString s | identNeedsEscaping s = show s
63− | otherwise = s
64− match (JSBlock sts) = fmap concat $ sequence
65− [ return "{\n"
66− , withIndent $ prettyStatements sts
67− , return "\n"
68− , currentIndent
69− , return "}"
70− ]
71− match (JSVar ident) = return ident
72− match (JSVariableIntroduction ident value) = fmap concat $ sequence
73− [ return "var "
74− , return ident
75− , maybe (return "") (fmap (" = " ++) . prettyPrintJS') value
76− ]
77− match (JSAssignment target value) = fmap concat $ sequence
78− [ prettyPrintJS' target
79− , return " = "
80− , prettyPrintJS' value
81− ]
82− match (JSWhile cond sts) = fmap concat $ sequence
83− [ return "while ("
84− , prettyPrintJS' cond
85− , return ") "
86− , prettyPrintJS' sts
87− ]
88− match (JSFor ident start end sts) = fmap concat $ sequence
89− [ return $ "for (var " ++ ident ++ " = "
90− , prettyPrintJS' start
91− , return $ "; " ++ ident ++ " < "
92− , prettyPrintJS' end
93− , return $ "; " ++ ident ++ "++) "
94− , prettyPrintJS' sts
95− ]
96− match (JSForIn ident obj sts) = fmap concat $ sequence
97− [ return $ "for (var " ++ ident ++ " in "
98− , prettyPrintJS' obj
99− , return ") "
100− , prettyPrintJS' sts
101− ]
102− match (JSIfElse cond thens elses) = fmap concat $ sequence
103− [ return "if ("
104− , prettyPrintJS' cond
105− , return ") "
106− , prettyPrintJS' thens
107− , maybe (return "") (fmap (" else " ++) . prettyPrintJS') elses
108− ]
109− match (JSReturn value) = fmap concat $ sequence
110− [ return "return "
111− , prettyPrintJS' value
112− ]
113− match (JSThrow value) = fmap concat $ sequence
114− [ return "throw "
115− , prettyPrintJS' value
116− ]
117− match (JSBreak lbl) = return $ "break " ++ lbl
118− match (JSContinue lbl) = return $ "continue " ++ lbl
119− match (JSLabel lbl js) = fmap concat $ sequence
120− [ return $ lbl ++ ": "
121− , prettyPrintJS' js
122− ]
123− match (JSComment com js) = fmap concat $ sequence $
124− [ return "\n"
125− , currentIndent
126− , return "/**\n"
127− ] ++
128− map asLine (concatMap commentLines com) ++
129− [ currentIndent
130− , return " */\n"
131− , currentIndent
132− , prettyPrintJS' js
133− ]
134− where
135− commentLines :: Comment -> [String]
136− commentLines (LineComment s) = [s]
137− commentLines (BlockComment s) = lines s
138−
139− asLine :: String -> StateT PrinterState Maybe String
140− asLine s = do
141− i <- currentIndent
142− return $ i ++ " * " ++ removeComments s ++ "\n"
143−
144− removeComments :: String -> String
145− removeComments ('*' : '/' : s) = removeComments s
146− removeComments (c : s) = c : removeComments s
147−
148− removeComments [] = []
149− match (JSRaw js) = return js
150− match _ = mzero
151−
152−string :: String -> String
153−string s = '"' : concatMap encodeChar s ++ "\""
154− where
155− encodeChar :: Char -> String
156− encodeChar '\b' = "\\b"
157− encodeChar '\t' = "\\t"
158− encodeChar '\n' = "\\n"
159− encodeChar '\v' = "\\v"
160− encodeChar '\f' = "\\f"
161− encodeChar '\r' = "\\r"
162− encodeChar '"' = "\\\""
163− encodeChar '\\' = "\\\\"
164− encodeChar c | fromEnum c > 0xFFF = "\\u" ++ showHex (fromEnum c) ""
165− encodeChar c | fromEnum c > 0xFF = "\\u0" ++ showHex (fromEnum c) ""
166− encodeChar c = [c]
167−
168−conditional :: Pattern PrinterState JS ((JS, JS), JS)
169−conditional = mkPattern match
170− where
171− match (JSConditional cond th el) = Just ((th, el), cond)
172− match _ = Nothing
173−
174−accessor :: Pattern PrinterState JS (String, JS)
175−accessor = mkPattern match
176− where
177− match (JSAccessor prop val) = Just (prop, val)
178− match _ = Nothing
179−
180−indexer :: Pattern PrinterState JS (String, JS)
181−indexer = mkPattern' match
182− where
183− match (JSIndexer index val) = (,) <$> prettyPrintJS' index <*> pure val
184− match _ = mzero
185−
186−lam :: Pattern PrinterState JS ((Maybe String, [String]), JS)
187−lam = mkPattern match
188− where
189− match (JSFunction name args ret) = Just ((name, args), ret)
190− match _ = Nothing
191−
192−app :: Pattern PrinterState JS (String, JS)
193−app = mkPattern' match
194− where
195− match (JSApp val args) = do
196− jss <- mapM prettyPrintJS' args
197− return (intercalate ", " jss, val)
198− match _ = mzero
199−
200−typeOf :: Pattern PrinterState JS ((), JS)
201−typeOf = mkPattern match
202− where
203− match (JSTypeOf val) = Just ((), val)
204− match _ = Nothing
205−
206−instanceOf :: Pattern PrinterState JS (JS, JS)
207−instanceOf = mkPattern match
208− where
209− match (JSInstanceOf val ty) = Just (val, ty)
210− match _ = Nothing
211−
212−unary' :: UnaryOperator -> (JS -> String) -> Operator PrinterState JS String
213−unary' op mkStr = Wrap match (++)
214− where
215− match :: Pattern PrinterState JS (String, JS)
216− match = mkPattern match'
217− where
218− match' (JSUnary op' val) | op' == op = Just (mkStr val, val)
219− match' _ = Nothing
220−
221−unary :: UnaryOperator -> String -> Operator PrinterState JS String
222−unary op str = unary' op (const str)
223−
224−negateOperator :: Operator PrinterState JS String
225−negateOperator = unary' Negate (\v -> if isNegate v then "- " else "-")
226− where
227− isNegate (JSUnary Negate _) = True
228− isNegate _ = False
229−
230−binary :: BinaryOperator -> String -> Operator PrinterState JS String
231−binary op str = AssocL match (\v1 v2 -> v1 ++ " " ++ str ++ " " ++ v2)
232− where
233− match :: Pattern PrinterState JS (JS, JS)
234− match = mkPattern match'
235− where
236− match' (JSBinary op' v1 v2) | op' == op = Just (v1, v2)
237− match' _ = Nothing
238−
239−prettyStatements :: [JS] -> StateT PrinterState Maybe String
240−prettyStatements sts = do
241− jss <- forM sts prettyPrintJS'
242− indentString <- currentIndent
243− return $ intercalate "\n" $ map ((++ ";") . (indentString ++)) jss
244−
245−-- |
246−-- Generate a pretty-printed string representing a Javascript expression
247−--
248−prettyPrintJS1 :: JS -> String
249−prettyPrintJS1 = fromMaybe (error "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyPrintJS'
250−
251−-- |
252−-- Generate a pretty-printed string representing a collection of Javascript expressions at the same indentation level
253−--
254−prettyPrintJS :: [JS] -> String
255−prettyPrintJS = fromMaybe (error "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyStatements
256−
257−-- |
258−-- Generate an indented, pretty-printed string representing a Javascript expression
259−--
260−prettyPrintJS' :: JS -> StateT PrinterState Maybe String
261−prettyPrintJS' = A.runKleisli $ runPattern matchValue
262− where
263− matchValue :: Pattern PrinterState JS String
264− matchValue = buildPrettyPrinter operators (literals <+> fmap parens matchValue)
265− operators :: OperatorTable PrinterState JS String
266− operators =
267− OperatorTable [ [ Wrap accessor $ \prop val -> val ++ "." ++ prop ]
268− , [ Wrap indexer $ \index val -> val ++ "[" ++ index ++ "]" ]
269− , [ Wrap app $ \args val -> val ++ "(" ++ args ++ ")" ]
270− , [ unary JSNew "new " ]
271− , [ Wrap lam $ \(name, args) ret -> "function "
272− ++ fromMaybe "" name
273− ++ "(" ++ intercalate ", " args ++ ") "
274− ++ ret ]
275− , [ binary LessThan "<" ]
276− , [ binary LessThanOrEqualTo "<=" ]
277− , [ binary GreaterThan ">" ]
278− , [ binary GreaterThanOrEqualTo ">=" ]
279− , [ Wrap typeOf $ \_ s -> "typeof " ++ s ]
280− , [ AssocR instanceOf $ \v1 v2 -> v1 ++ " instanceof " ++ v2 ]
281− , [ unary Not "!" ]
282− , [ unary BitwiseNot "~" ]
283− , [ negateOperator ]
284− , [ unary Positive "+" ]
285− , [ binary Multiply "*"
286− , binary Divide "/"
287− , binary Modulus "%" ]
288− , [ binary Add "+"
289− , binary Subtract "-" ]
290− , [ binary ShiftLeft "<<" ]
291− , [ binary ShiftRight ">>" ]
292− , [ binary ZeroFillShiftRight ">>>" ]
293− , [ binary EqualTo "===" ]
294− , [ binary NotEqualTo "!==" ]
295− , [ binary BitwiseAnd "&" ]
296− , [ binary BitwiseXor "^" ]
297− , [ binary BitwiseOr "|" ]
298− , [ binary And "&&" ]
299− , [ binary Or "||" ]
300− , [ Wrap conditional $ \(th, el) cond -> cond ++ " ? " ++ prettyPrintJS1 th ++ " : " ++ prettyPrintJS1 el ]
301− ]
src/Language/PureScript/Pretty/Kinds.hsdeleted−59
@@ -1,59 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.Pretty.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−-- Pretty printer for kinds
13−--
14−-----------------------------------------------------------------------------
15−
16−module Language.PureScript.Pretty.Kinds (
17− prettyPrintKind
18−) where
19−
20−import Data.Maybe (fromMaybe)
21−
22−import Control.Arrow (ArrowPlus(..))
23−import Control.PatternArrows
24−
25−import Language.PureScript.Kinds
26−import Language.PureScript.Pretty.Common
27−
28−typeLiterals :: Pattern () Kind String
29−typeLiterals = mkPattern match
30− where
31− match Star = Just "*"
32− match Bang = Just "!"
33− match (KUnknown u) = Just $ 'u' : show u
34− match _ = Nothing
35−
36−matchRow :: Pattern () Kind ((), Kind)
37−matchRow = mkPattern match
38− where
39− match (Row k) = Just ((), k)
40− match _ = Nothing
41−
42−funKind :: Pattern () Kind (Kind, Kind)
43−funKind = mkPattern match
44− where
45− match (FunKind arg ret) = Just (arg, ret)
46− match _ = Nothing
47−
48−-- |
49−-- Generate a pretty-printed string representing a Kind
50−--
51−prettyPrintKind :: Kind -> String
52−prettyPrintKind = fromMaybe (error "Incomplete pattern") . pattern matchKind ()
53− where
54− matchKind :: Pattern () Kind String
55− matchKind = buildPrettyPrinter operators (typeLiterals <+> fmap parens matchKind)
56− operators :: OperatorTable () Kind String
57− operators =
58− OperatorTable [ [ Wrap matchRow $ \_ k -> "# " ++ k]
59− , [ AssocR funKind $ \arg ret -> arg ++ " -> " ++ ret ] ]
src/Language/PureScript/Pretty/Types.hsdeleted−129
@@ -1,129 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.Pretty.Types
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−-- Pretty printer for Types
13−--
14−-----------------------------------------------------------------------------
15−
16−module Language.PureScript.Pretty.Types (
17− prettyPrintType,
18− prettyPrintTypeAtom,
19− prettyPrintRow
20−) where
21−
22−import Data.Maybe (fromMaybe)
23−import Data.List (intercalate)
24−
25−import Control.Arrow ((<+>))
26−import Control.PatternArrows
27−
28−import Language.PureScript.Types
29−import Language.PureScript.Kinds
30−import Language.PureScript.Pretty.Common
31−import Language.PureScript.Pretty.Kinds
32−import Language.PureScript.Environment
33−
34−typeLiterals :: Pattern () Type String
35−typeLiterals = mkPattern match
36− where
37− match TypeWildcard = Just "_"
38− match (TypeVar var) = Just var
39− match (PrettyPrintObject row) = Just $ "{ " ++ prettyPrintRow row ++ " }"
40− match (PrettyPrintArray ty) = Just $ "[" ++ prettyPrintType ty ++ "]"
41− match (TypeConstructor ctor) = Just $ show ctor
42− match (TUnknown u) = Just $ 'u' : show u
43− match (Skolem name s _) = Just $ name ++ show s
44− match (ConstrainedType deps ty) = Just $ "(" ++ intercalate ", " (map (\(pn, ty') -> show pn ++ " " ++ unwords (map prettyPrintTypeAtom ty')) deps) ++ ") => " ++ prettyPrintType ty
45− match (SaturatedTypeSynonym name args) = Just $ show name ++ "<" ++ intercalate "," (map prettyPrintTypeAtom args) ++ ">"
46− match REmpty = Just "()"
47− match row@RCons{} = Just $ '(' : prettyPrintRow row ++ ")"
48− match _ = Nothing
49−
50−-- |
51−-- Generate a pretty-printed string representing a Row
52−--
53−prettyPrintRow :: Type -> String
54−prettyPrintRow = (\(tys, rest) -> intercalate ", " (map (uncurry nameAndTypeToPs) tys) ++ tailToPs rest) . toList []
55− where
56− nameAndTypeToPs :: String -> Type -> String
57− nameAndTypeToPs name ty = prettyPrintObjectKey name ++ " :: " ++ prettyPrintType ty
58− tailToPs :: Type -> String
59− tailToPs REmpty = ""
60− tailToPs other = " | " ++ prettyPrintType other
61− toList :: [(String, Type)] -> Type -> ([(String, Type)], Type)
62− toList tys (RCons name ty row) = toList ((name, ty):tys) row
63− toList tys r = (tys, r)
64−
65−typeApp :: Pattern () Type (Type, Type)
66−typeApp = mkPattern match
67− where
68− match (TypeApp f x) = Just (f, x)
69− match _ = Nothing
70−
71−appliedFunction :: Pattern () Type (Type, Type)
72−appliedFunction = mkPattern match
73− where
74− match (PrettyPrintFunction arg ret) = Just (arg, ret)
75− match _ = Nothing
76−
77−kinded :: Pattern () Type (Kind, Type)
78−kinded = mkPattern match
79− where
80− match (KindedType t k) = Just (k, t)
81− match _ = Nothing
82−
83−insertPlaceholders :: Type -> Type
84−insertPlaceholders = everywhereOnTypesTopDown convertForAlls . everywhereOnTypes convert
85− where
86− convert (TypeApp (TypeApp f arg) ret) | f == tyFunction = PrettyPrintFunction arg ret
87− convert (TypeApp a el) | a == tyArray = PrettyPrintArray el
88− convert (TypeApp o r) | o == tyObject = PrettyPrintObject r
89− convert other = other
90− convertForAlls (ForAll ident ty _) = go [ident] ty
91− where
92− go idents (ForAll ident' ty' _) = go (ident' : idents) ty'
93− go idents other = PrettyPrintForAll idents other
94− convertForAlls other = other
95−
96−matchTypeAtom :: Pattern () Type String
97−matchTypeAtom = typeLiterals <+> fmap parens matchType
98−
99−matchType :: Pattern () Type String
100−matchType = buildPrettyPrinter operators matchTypeAtom
101− where
102− operators :: OperatorTable () Type String
103− operators =
104− OperatorTable [ [ AssocL typeApp $ \f x -> f ++ " " ++ x ]
105− , [ AssocR appliedFunction $ \arg ret -> arg ++ " -> " ++ ret
106− ]
107− , [ Wrap forall_ $ \idents ty -> "forall " ++ unwords idents ++ ". " ++ ty ]
108− , [ Wrap kinded $ \k ty -> ty ++ " :: " ++ prettyPrintKind k ]
109− ]
110−
111−forall_ :: Pattern () Type ([String], Type)
112−forall_ = mkPattern match
113− where
114− match (PrettyPrintForAll idents ty) = Just (idents, ty)
115− match _ = Nothing
116−
117−-- |
118−-- Generate a pretty-printed string representing a Type, as it should appear inside parentheses
119−--
120−prettyPrintTypeAtom :: Type -> String
121−prettyPrintTypeAtom = fromMaybe (error "Incomplete pattern") . pattern matchTypeAtom () . insertPlaceholders
122−
123−
124−-- |
125−-- Generate a pretty-printed string representing a Type
126−--
127−prettyPrintType :: Type -> String
128−prettyPrintType = fromMaybe (error "Incomplete pattern") . pattern matchType () . insertPlaceholders
129−
src/Language/PureScript/Pretty/Values.hsdeleted−250
@@ -1,250 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.Pretty.Values
4−-- Copyright : Kinds.hs(c) Phil Freeman 2013
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- |
12−-- Pretty printer for values
13−--
14−-----------------------------------------------------------------------------
15−
16−module Language.PureScript.Pretty.Values (
17− prettyPrintValue,
18− prettyPrintBinder
19−) where
20−
21−import Data.Maybe (fromMaybe)
22−import Data.List (intercalate)
23−
24−import Control.Arrow ((<+>), runKleisli, second)
25−import Control.PatternArrows
26−import Control.Monad.State
27−import Control.Applicative
28−
29−import Language.PureScript.AST
30−import Language.PureScript.Names
31−import Language.PureScript.Pretty.Common
32−import Language.PureScript.Pretty.Types (prettyPrintType)
33−
34−literals :: Pattern PrinterState Expr String
35−literals = mkPattern' match
36− where
37− match :: Expr -> StateT PrinterState Maybe String
38− match (NumericLiteral n) = return $ either show show n
39− match (StringLiteral s) = return $ show s
40− match (BooleanLiteral True) = return "true"
41− match (BooleanLiteral False) = return "false"
42− match (ArrayLiteral xs) = concat <$> sequence
43− [ return "[ "
44− , withIndent $ prettyPrintMany prettyPrintValue' xs
45− , return " ]"
46− ]
47− match (ObjectLiteral ps) = prettyPrintObject' $ second Just `map` ps
48− match (ObjectConstructor ps) = prettyPrintObject' ps
49− match (ObjectGetter prop) = return $ "(." ++ prop ++ ")"
50− match (TypeClassDictionaryConstructorApp className ps) = concat <$> sequence
51− [ return (show className ++ "(\n")
52− , match ps
53− , return ")"
54− ]
55− match (Constructor name) = return $ show name
56− match (Case values binders) = concat <$> sequence
57− [ return "case "
58− , unwords <$> forM values prettyPrintValue'
59− , return " of\n"
60− , withIndent $ prettyPrintMany prettyPrintCaseAlternative binders
61− , currentIndent
62− ]
63− match (Let ds val) = concat <$> sequence
64− [ return "let\n"
65− , withIndent $ prettyPrintMany prettyPrintDeclaration ds
66− , return "\n"
67− , currentIndent
68− , return "in "
69− , prettyPrintValue' val
70− ]
71− match (Var ident) = return $ show ident
72− match (Do els) = concat <$> sequence
73− [ return "do "
74− , withIndent $ prettyPrintMany prettyPrintDoNotationElement els
75− , currentIndent
76− ]
77− match (OperatorSection op (Right val)) = return $ "(" ++ prettyPrintValue op ++ " " ++ prettyPrintValue val ++ ")"
78− match (OperatorSection op (Left val)) = return $ "(" ++ prettyPrintValue val ++ " " ++ prettyPrintValue op ++ ")"
79− match (TypeClassDictionary name _ _) = return $ "<<dict " ++ show name ++ ">>"
80− match (SuperClassDictionary name _) = return $ "<<superclass dict " ++ show name ++ ">>"
81− match (TypedValue _ val _) = prettyPrintValue' val
82− match (PositionedValue _ _ val) = prettyPrintValue' val
83− match _ = mzero
84−
85−prettyPrintDeclaration :: Declaration -> StateT PrinterState Maybe String
86−prettyPrintDeclaration (TypeDeclaration ident ty) = return $ show ident ++ " :: " ++ prettyPrintType ty
87−prettyPrintDeclaration (ValueDeclaration ident _ [] (Right val)) = concat <$> sequence
88− [ return $ show ident ++ " = "
89− , prettyPrintValue' val
90− ]
91−prettyPrintDeclaration (PositionedDeclaration _ _ d) = prettyPrintDeclaration d
92−prettyPrintDeclaration _ = error "Invalid argument to prettyPrintDeclaration"
93−
94−prettyPrintCaseAlternative :: CaseAlternative -> StateT PrinterState Maybe String
95−prettyPrintCaseAlternative (CaseAlternative binders result) =
96− concat <$> sequence
97− [ intercalate ", " <$> forM binders prettyPrintBinder'
98− , prettyPrintResult result
99− ]
100− where
101− prettyPrintResult (Left gs) = concat <$> mapM prettyPrintGuardedValue gs
102− prettyPrintResult (Right v) = (" -> " ++) <$> prettyPrintValue' v
103−
104− prettyPrintGuardedValue (grd, val) =
105− concat <$> sequence
106− [ return "| "
107− , prettyPrintValue' grd
108− , return " -> "
109− , prettyPrintValue' val
110− , return "\n"
111− ]
112−
113−prettyPrintDoNotationElement :: DoNotationElement -> StateT PrinterState Maybe String
114−prettyPrintDoNotationElement (DoNotationValue val) =
115− prettyPrintValue' val
116−prettyPrintDoNotationElement (DoNotationBind binder val) =
117− concat <$> sequence
118− [ prettyPrintBinder' binder
119− , return " <- "
120− , prettyPrintValue' val
121− ]
122−prettyPrintDoNotationElement (DoNotationLet ds) =
123− concat <$> sequence
124− [ return "let "
125− , withIndent $ prettyPrintMany prettyPrintDeclaration ds
126− ]
127−prettyPrintDoNotationElement (PositionedDoNotationElement _ _ el) = prettyPrintDoNotationElement el
128−
129−prettyPrintObject' :: [(String, Maybe Expr)] -> StateT PrinterState Maybe String
130−prettyPrintObject' [] = return "{}"
131−prettyPrintObject' ps = concat <$> sequence
132− [ return "{\n"
133− , withIndent $ prettyPrintMany prettyPrintObjectProperty ps
134− , return "\n"
135− , currentIndent
136− , return "}"
137− ]
138−
139−ifThenElse :: Pattern PrinterState Expr ((Expr, Expr), Expr)
140−ifThenElse = mkPattern match
141− where
142− match (IfThenElse cond th el) = Just ((th, el), cond)
143− match _ = Nothing
144−
145−accessor :: Pattern PrinterState Expr (String, Expr)
146−accessor = mkPattern match
147− where
148− match (Accessor prop val) = Just (prop, val)
149− match _ = Nothing
150−
151−objectUpdate :: Pattern PrinterState Expr ([String], Expr)
152−objectUpdate = mkPattern match
153− where
154− match (ObjectUpdate o ps) = Just (flip map ps $ \(key, val) -> key ++ " = " ++ prettyPrintValue val, o)
155− match (ObjectUpdater o ps) = Just (flip map ps $ \(key, val) -> key ++ " = " ++ maybe "_" prettyPrintValue val, fromMaybe (Var (Qualified Nothing $ Ident "_")) o)
156− match _ = Nothing
157−
158−app :: Pattern PrinterState Expr (String, Expr)
159−app = mkPattern match
160− where
161− match (App val arg) = Just (prettyPrintValue arg, val)
162− match _ = Nothing
163−
164−lam :: Pattern PrinterState Expr (String, Expr)
165−lam = mkPattern match
166− where
167− match (Abs (Left arg) val) = Just (show arg, val)
168− match _ = Nothing
169−
170−-- |
171−-- Generate a pretty-printed string representing an expression
172−--
173−prettyPrintValue :: Expr -> String
174−prettyPrintValue = fromMaybe (error "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyPrintValue'
175−
176−prettyPrintValue' :: Expr -> StateT PrinterState Maybe String
177−prettyPrintValue' = runKleisli $ runPattern matchValue
178− where
179− matchValue :: Pattern PrinterState Expr String
180− matchValue = buildPrettyPrinter operators (literals <+> fmap parens matchValue)
181− operators :: OperatorTable PrinterState Expr String
182− operators =
183− OperatorTable [ [ Wrap accessor $ \prop val -> val ++ "." ++ prop ]
184− , [ Wrap objectUpdate $ \ps val -> val ++ "{ " ++ intercalate ", " ps ++ " }" ]
185− , [ Wrap app $ \arg val -> val ++ "(" ++ arg ++ ")" ]
186− , [ Split lam $ \arg val -> "\\" ++ arg ++ " -> " ++ prettyPrintValue val ]
187− , [ Wrap ifThenElse $ \(th, el) cond -> "if " ++ cond ++ " then " ++ prettyPrintValue th ++ " else " ++ prettyPrintValue el ]
188− ]
189−
190−prettyPrintBinderAtom :: Pattern PrinterState Binder String
191−prettyPrintBinderAtom = mkPattern' match
192− where
193− match :: Binder -> StateT PrinterState Maybe String
194− match NullBinder = return "_"
195− match (StringBinder str) = return $ show str
196− match (NumberBinder num) = return $ either show show num
197− match (BooleanBinder True) = return "true"
198− match (BooleanBinder False) = return "false"
199− match (VarBinder ident) = return $ show ident
200− match (ConstructorBinder ctor args) = concat <$> sequence
201− [ return $ show ctor ++ " "
202− , unwords <$> forM args match
203− ]
204− match (ObjectBinder bs) = concat <$> sequence
205− [ return "{\n"
206− , withIndent $ prettyPrintMany prettyPrintObjectPropertyBinder bs
207− , currentIndent
208− , return "}"
209− ]
210− match (ArrayBinder bs) = concat <$> sequence
211− [ return "["
212− , unwords <$> mapM prettyPrintBinder' bs
213− , return "]"
214− ]
215− match (NamedBinder ident binder) = ((show ident ++ "@") ++) <$> prettyPrintBinder' binder
216− match (PositionedBinder _ _ binder) = prettyPrintBinder' binder
217− match _ = mzero
218−
219−-- |
220−-- Generate a pretty-printed string representing a Binder
221−--
222−prettyPrintBinder :: Binder -> String
223−prettyPrintBinder = fromMaybe (error "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyPrintBinder'
224−
225−prettyPrintBinder' :: Binder -> StateT PrinterState Maybe String
226−prettyPrintBinder' = runKleisli $ runPattern matchBinder
227− where
228− matchBinder :: Pattern PrinterState Binder String
229− matchBinder = buildPrettyPrinter operators (prettyPrintBinderAtom <+> fmap parens matchBinder)
230− operators :: OperatorTable PrinterState Binder String
231− operators =
232− OperatorTable [ [ AssocR matchConsBinder (\b1 b2 -> b1 ++ " : " ++ b2) ] ]
233−
234−matchConsBinder :: Pattern PrinterState Binder (Binder, Binder)
235−matchConsBinder = mkPattern match'
236− where
237− match' (ConsBinder b1 b2) = Just (b1, b2)
238− match' _ = Nothing
239−
240−prettyPrintObjectPropertyBinder :: (String, Binder) -> StateT PrinterState Maybe String
241−prettyPrintObjectPropertyBinder (key, binder) = concat <$> sequence
242− [ return $ prettyPrintObjectKey key ++ ": "
243− , prettyPrintBinder' binder
244− ]
245−
246−prettyPrintObjectProperty :: (String, Maybe Expr) -> StateT PrinterState Maybe String
247−prettyPrintObjectProperty (key, value) = concat <$> sequence
248− [ return $ prettyPrintObjectKey key ++ ": "
249− , maybe (pure "_") prettyPrintValue' value
250− ]
src/Language/PureScript/Renamer.hsdeleted−194
@@ -1,194 +0,0 @@
1−-----------------------------------------------------------------------------
2−-----------------------------------------------------------------------------
3−--
4−-- Module : Language.PureScript.Renamer
5−-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
6−-- License : MIT
7−--
8−-- Maintainer : Phil Freeman <paf31@cantab.net>
9−-- Stability : experimental
10−-- Portability :
11−--
12−-- |
13−-- Renaming pass that prevents shadowing of local identifiers.
14−--
15−-----------------------------------------------------------------------------
16−
17−module Language.PureScript.Renamer (renameInModules) where
18−
19−import Control.Applicative
20−import Control.Monad.State
21−
22−import Data.List (find)
23−
24−import qualified Data.Map as M
25−import qualified Data.Set as S
26−
27−import Language.PureScript.CoreFn
28−import Language.PureScript.Names
29−import Language.PureScript.Traversals
30−
31−import qualified Language.PureScript.Constants as C
32−
33−-- |
34−-- The state object used in this module
35−--
36−data RenameState = RenameState {
37− -- |
38− -- A map from names bound (in the input) to their names (in the output)
39− --
40− rsBoundNames :: M.Map Ident Ident
41− -- |
42− -- The set of names which have been used and are in scope in the output
43− --
44− , rsUsedNames :: S.Set Ident
45− }
46−
47−type Rename = State RenameState
48−
49−initState :: [Ident] -> RenameState
50−initState scope = RenameState (M.fromList (zip scope scope)) (S.fromList scope)
51−
52−-- |
53−-- Runs renaming starting with a list of idents for the initial scope.
54−--
55−runRename :: [Ident] -> Rename a -> a
56−runRename scope = flip evalState (initState scope)
57−
58−-- |
59−-- Creates a new renaming scope using the current as a basis. Used to backtrack
60−-- when leaving an Abs.
61−--
62−newScope :: Rename a -> Rename a
63−newScope x = do
64− scope <- get
65− a <- x
66− put scope
67− return a
68−
69−-- |
70−-- Adds a new scope entry for an ident. If the ident is already present, a new
71−-- unique name is generated and stored.
72−--
73−updateScope :: Ident -> Rename Ident
74−updateScope i@(Ident name) | name == C.__unused = return i
75−updateScope name = do
76− scope <- get
77− let name' = case name `S.member` rsUsedNames scope of
78− True ->
79− let
80− newNames = [ Ident (runIdent name ++ "_" ++ show (i :: Int)) | i <- [1..] ]
81− Just newName = find (`S.notMember` rsUsedNames scope) newNames
82− in newName
83− False -> name
84− modify $ \s -> s { rsBoundNames = M.insert name name' (rsBoundNames s)
85− , rsUsedNames = S.insert name' (rsUsedNames s)
86− }
87− return name'
88−
89−-- |
90−-- Finds the new name to use for an ident.
91−--
92−lookupIdent :: Ident -> Rename Ident
93−lookupIdent i@(Ident name) | name == C.__unused = return i
94−lookupIdent name = do
95− name' <- gets $ M.lookup name . rsBoundNames
96− case name' of
97− Just name'' -> return name''
98− Nothing -> error $ "Rename scope is missing ident '" ++ show name ++ "'"
99−
100−-- |
101−-- Finds idents introduced by declarations.
102−--
103−findDeclIdents :: [Bind Ann] -> [Ident]
104−findDeclIdents = concatMap go
105− where
106− go (NonRec ident _) = [ident]
107− go (Rec ds) = map fst ds
108−
109−-- |
110−-- Renames within each declaration in a module.
111−--
112−renameInModules :: [Module Ann] -> [Module Ann]
113−renameInModules = map go
114− where
115− go :: Module Ann -> Module Ann
116− go m@(Module _ _ _ _ decls) = m { moduleDecls = renameInDecl' (findDeclIdents decls) `map` decls }
117− renameInDecl' :: [Ident] -> Bind Ann -> Bind Ann
118− renameInDecl' scope = runRename scope . renameInDecl True
119−
120−-- |
121−-- Renames within a declaration. isTopLevel is used to determine whether the
122−-- declaration is a module member or appearing within a Let. At the top level
123−-- declarations are not renamed or added to the scope (they should already have
124−-- been added), whereas in a Let declarations are renamed if their name shadows
125−-- another in the current scope.
126−--
127−renameInDecl :: Bool -> Bind Ann -> Rename (Bind Ann)
128−renameInDecl isTopLevel (NonRec name val) = do
129− name' <- if isTopLevel then return name else updateScope name
130− NonRec name' <$> renameInValue val
131−renameInDecl isTopLevel (Rec ds) = do
132− ds' <- mapM updateNames ds
133− Rec <$> mapM updateValues ds'
134− where
135− updateNames :: (Ident, Expr Ann) -> Rename (Ident, Expr Ann)
136− updateNames (name, val) = do
137− name' <- if isTopLevel then return name else updateScope name
138− return (name', val)
139− updateValues :: (Ident, Expr Ann) -> Rename (Ident, Expr Ann)
140− updateValues (name, val) = (,) name <$> renameInValue val
141−
142−-- |
143−-- Renames within a value.
144−--
145−renameInValue :: Expr Ann -> Rename (Expr Ann)
146−renameInValue (Literal ann l) =
147− Literal ann <$> renameInLiteral renameInValue l
148−renameInValue c@(Constructor{}) = return c
149−renameInValue (Accessor ann prop v) =
150− Accessor ann prop <$> renameInValue v
151−renameInValue (ObjectUpdate ann obj vs) =
152− ObjectUpdate ann <$> renameInValue obj <*> mapM (\(name, v) -> (,) name <$> renameInValue v) vs
153−renameInValue e@(Abs (_, _, _, Just IsTypeClassConstructor) _ _) = return e
154−renameInValue (Abs ann name v) =
155− newScope $ Abs ann <$> updateScope name <*> renameInValue v
156−renameInValue (App ann v1 v2) =
157− App ann <$> renameInValue v1 <*> renameInValue v2
158−renameInValue (Var ann (Qualified Nothing name)) =
159− Var ann . Qualified Nothing <$> lookupIdent name
160−renameInValue v@(Var{}) = return v
161−renameInValue (Case ann vs alts) =
162− newScope $ Case ann <$> mapM renameInValue vs <*> mapM renameInCaseAlternative alts
163−renameInValue (Let ann ds v) =
164− newScope $ Let ann <$> mapM (renameInDecl False) ds <*> renameInValue v
165−
166−-- |
167−-- Renames within literals.
168−--
169−renameInLiteral :: (a -> Rename a) -> Literal a -> Rename (Literal a)
170−renameInLiteral rename (ArrayLiteral bs) = ArrayLiteral <$> mapM rename bs
171−renameInLiteral rename (ObjectLiteral bs) = ObjectLiteral <$> mapM (sndM rename) bs
172−renameInLiteral _ l = return l
173−
174−-- |
175−-- Renames within case alternatives.
176−--
177−renameInCaseAlternative :: CaseAlternative Ann -> Rename (CaseAlternative Ann)
178−renameInCaseAlternative (CaseAlternative bs v) =
179− CaseAlternative <$> mapM renameInBinder bs
180− <*> eitherM (mapM (pairM renameInValue renameInValue)) renameInValue v
181−
182−-- |
183−-- Renames within binders.
184−--
185−renameInBinder :: Binder a -> Rename (Binder a)
186−renameInBinder n@(NullBinder{}) = return n
187−renameInBinder (LiteralBinder ann b) =
188− LiteralBinder ann <$> renameInLiteral renameInBinder b
189−renameInBinder (VarBinder ann name) =
190− VarBinder ann <$> updateScope name
191−renameInBinder (ConstructorBinder ann tctor dctor bs) =
192− ConstructorBinder ann tctor dctor <$> mapM renameInBinder bs
193−renameInBinder (NamedBinder ann name b) =
194− NamedBinder ann <$> updateScope name <*> renameInBinder b
src/Language/PureScript/Sugar.hsdeleted−68
@@ -1,68 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.Sugar
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−-- Desugaring passes
13−--
14−-----------------------------------------------------------------------------
15−
16−module Language.PureScript.Sugar (desugar, module S) where
17−
18−import Control.Monad
19−import Control.Category ((>>>))
20−import Control.Monad.Trans.Class
21−
22−import Language.PureScript.AST
23−import Language.PureScript.Errors
24−import Language.PureScript.Supply
25−
26−import Language.PureScript.Sugar.BindingGroups as S
27−import Language.PureScript.Sugar.CaseDeclarations as S
28−import Language.PureScript.Sugar.DoNotation as S
29−import Language.PureScript.Sugar.Names as S
30−import Language.PureScript.Sugar.ObjectWildcards as S
31−import Language.PureScript.Sugar.Operators as S
32−import Language.PureScript.Sugar.TypeClasses as S
33−import Language.PureScript.Sugar.TypeDeclarations as S
34−
35−-- |
36−-- The desugaring pipeline proceeds as follows:
37−--
38−-- * Remove signed literals in favour of `negate` applications
39−--
40−-- * Desugar object literals with wildcards into lambdas
41−--
42−-- * Desugar operator sections
43−--
44−-- * Desugar do-notation using the @Prelude.Monad@ type class
45−--
46−-- * Desugar top-level case declarations into explicit case expressions
47−--
48−-- * Desugar type declarations into value declarations with explicit type annotations
49−--
50−-- * Qualify any unqualified names and types
51−--
52−-- * Rebracket user-defined binary operators
53−--
54−-- * Introduce type synonyms for type class dictionaries
55−--
56−-- * Group mutually recursive value and data declarations into binding groups.
57−--
58−desugar :: [Module] -> SupplyT (Either ErrorStack) [Module]
59−desugar = map removeSignedLiterals
60− >>> mapM desugarObjectConstructors
61− >=> mapM desugarOperatorSections
62− >=> mapM desugarDoModule
63− >=> desugarCasesModule
64− >=> lift . (desugarTypeDeclarationsModule
65− >=> desugarImports
66− >=> rebracket)
67− >=> desugarTypeClasses
68− >=> lift . createBindingGroupsModule
src/Language/PureScript/Sugar/BindingGroups.hsdeleted−205
@@ -1,205 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.BindingGroups
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 implements the desugaring pass which creates binding groups from sets of
13−-- mutually-recursive value declarations and mutually-recursive type declarations.
14−--
15−-----------------------------------------------------------------------------
16−
17−module Language.PureScript.Sugar.BindingGroups (
18− createBindingGroups,
19− createBindingGroupsModule,
20− collapseBindingGroups,
21− collapseBindingGroupsModule
22−) where
23−
24−import Data.Graph
25−import Data.List (nub, intersect)
26−import Data.Maybe (isJust, mapMaybe)
27−import Data.Monoid ((<>))
28−import Control.Applicative ((<$>), (<*>), pure)
29−import Control.Monad ((<=<))
30−
31−import qualified Data.Set as S
32−
33−import Language.PureScript.AST
34−import Language.PureScript.Names
35−import Language.PureScript.Types
36−import Language.PureScript.Environment
37−import Language.PureScript.Errors
38−
39−-- |
40−-- Replace all sets of mutually-recursive declarations in a module with binding groups
41−--
42−createBindingGroupsModule :: [Module] -> Either ErrorStack [Module]
43−createBindingGroupsModule = mapM $ \(Module name ds exps) -> Module name <$> createBindingGroups name ds <*> pure exps
44−
45−-- |
46−-- Collapse all binding groups in a module to individual declarations
47−--
48−collapseBindingGroupsModule :: [Module] -> [Module]
49−collapseBindingGroupsModule = map $ \(Module name ds exps) -> Module name (collapseBindingGroups ds) exps
50−
51−createBindingGroups :: ModuleName -> [Declaration] -> Either ErrorStack [Declaration]
52−createBindingGroups moduleName = mapM f <=< handleDecls
53−
54− where
55− (f, _, _) = everywhereOnValuesTopDownM return handleExprs return
56−
57− handleExprs :: Expr -> Either ErrorStack Expr
58− handleExprs (Let ds val) = flip Let val <$> handleDecls ds
59− handleExprs other = return other
60−
61− -- |
62− -- Replace all sets of mutually-recursive declarations with binding groups
63− --
64− handleDecls :: [Declaration] -> Either ErrorStack [Declaration]
65− handleDecls ds = do
66− let values = filter isValueDecl ds
67− dataDecls = filter isDataDecl ds
68− allProperNames = map getProperName dataDecls
69− dataVerts = map (\d -> (d, getProperName d, usedProperNames moduleName d `intersect` allProperNames)) dataDecls
70− dataBindingGroupDecls <- parU (stronglyConnComp dataVerts) toDataBindingGroup
71− let allIdents = map getIdent values
72− valueVerts = map (\d -> (d, getIdent d, usedIdents moduleName d `intersect` allIdents)) values
73− bindingGroupDecls <- parU (stronglyConnComp valueVerts) (toBindingGroup moduleName)
74− return $ filter isImportDecl ds ++
75− filter isExternDataDecl ds ++
76− filter isExternInstanceDecl ds ++
77− dataBindingGroupDecls ++
78− filter isTypeClassDeclaration ds ++
79− filter isFixityDecl ds ++
80− filter isExternDecl ds ++
81− bindingGroupDecls
82−
83−-- |
84−-- Collapse all binding groups to individual declarations
85−--
86−collapseBindingGroups :: [Declaration] -> [Declaration]
87−collapseBindingGroups = let (f, _, _) = everywhereOnValues id collapseBindingGroupsForValue id in map f . concatMap go
88− where
89− go (DataBindingGroupDeclaration ds) = ds
90− go (BindingGroupDeclaration ds) = map (\(ident, nameKind, val) -> ValueDeclaration ident nameKind [] (Right val)) ds
91− go (PositionedDeclaration pos com d) = map (PositionedDeclaration pos com) $ go d
92− go other = [other]
93−
94−collapseBindingGroupsForValue :: Expr -> Expr
95−collapseBindingGroupsForValue (Let ds val) = Let (collapseBindingGroups ds) val
96−collapseBindingGroupsForValue other = other
97−
98−usedIdents :: ModuleName -> Declaration -> [Ident]
99−usedIdents moduleName =
100− let (f, _, _, _, _) = everythingWithContextOnValues S.empty [] (++) def usedNamesE usedNamesB def def
101− in nub . f
102− where
103− def s _ = (s, [])
104−
105− usedNamesE :: S.Set Ident -> Expr -> (S.Set Ident, [Ident])
106− usedNamesE scope (Var (Qualified Nothing name)) | name `S.notMember` scope = (scope, [name])
107− usedNamesE scope (Var (Qualified (Just moduleName') name)) | moduleName == moduleName' && name `S.notMember` scope = (scope, [name])
108− usedNamesE scope (Abs (Left name) _) = (name `S.insert` scope, [])
109− usedNamesE scope _ = (scope, [])
110−
111− usedNamesB :: S.Set Ident -> Binder -> (S.Set Ident, [Ident])
112− usedNamesB scope binder = (scope `S.union` S.fromList (binderNames binder), [])
113−
114−usedImmediateIdents :: ModuleName -> Declaration -> [Ident]
115−usedImmediateIdents moduleName =
116− let (f, _, _, _, _) = everythingWithContextOnValues True [] (++) def usedNamesE def def def
117− in nub . f
118− where
119− def s _ = (s, [])
120−
121− usedNamesE :: Bool -> Expr -> (Bool, [Ident])
122− usedNamesE True (Var (Qualified Nothing name)) = (True, [name])
123− usedNamesE True (Var (Qualified (Just moduleName') name)) | moduleName == moduleName' = (True, [name])
124− usedNamesE True (Abs _ _) = (False, [])
125− usedNamesE scope _ = (scope, [])
126−
127−usedProperNames :: ModuleName -> Declaration -> [ProperName]
128−usedProperNames moduleName =
129− let (f, _, _, _, _) = accumTypes (everythingOnTypes (++) usedNames)
130− in nub . f
131− where
132− usedNames :: Type -> [ProperName]
133− usedNames (ConstrainedType constraints _) = flip mapMaybe constraints $ \qual ->
134− case qual of
135− (Qualified (Just moduleName') name, _) | moduleName == moduleName' -> Just name
136− _ -> Nothing
137− usedNames (TypeConstructor (Qualified (Just moduleName') name)) | moduleName == moduleName' = [name]
138− usedNames _ = []
139−
140−getIdent :: Declaration -> Ident
141−getIdent (ValueDeclaration ident _ _ _) = ident
142−getIdent (PositionedDeclaration _ _ d) = getIdent d
143−getIdent _ = error "Expected ValueDeclaration"
144−
145−getProperName :: Declaration -> ProperName
146−getProperName (DataDeclaration _ pn _ _) = pn
147−getProperName (TypeSynonymDeclaration pn _ _) = pn
148−getProperName (PositionedDeclaration _ _ d) = getProperName d
149−getProperName _ = error "Expected DataDeclaration"
150−
151−-- |
152−-- Convert a group of mutually-recursive dependencies into a BindingGroupDeclaration (or simple ValueDeclaration).
153−--
154−--
155−toBindingGroup :: ModuleName -> SCC Declaration -> Either ErrorStack Declaration
156−toBindingGroup _ (AcyclicSCC d) = return d
157−toBindingGroup _ (CyclicSCC [d]) = return d
158−toBindingGroup moduleName (CyclicSCC ds') =
159− -- Once we have a mutually-recursive group of declarations, we need to sort
160− -- them further by their immediate dependencies (those outside function
161− -- bodies). In particular, this is relevant for type instance dictionaries
162− -- whose members require other type instances (for example, functorEff
163− -- defines (<$>) = liftA1, which depends on applicativeEff). Note that
164− -- superclass references are still inside functions, so don't count here.
165− -- If we discover declarations that still contain mutually-recursive
166− -- immediate references, we're guaranteed to get an undefined reference at
167− -- runtime, so treat this as an error. See also github issue #365.
168− BindingGroupDeclaration <$> mapM toBinding (stronglyConnComp valueVerts)
169− where
170− idents :: [Ident]
171− idents = map (\(_, i, _) -> i) valueVerts
172−
173− valueVerts :: [(Declaration, Ident, [Ident])]
174− valueVerts = map (\d -> (d, getIdent d, usedImmediateIdents moduleName d `intersect` idents)) ds'
175−
176− toBinding :: SCC Declaration -> Either ErrorStack (Ident, NameKind, Expr)
177− toBinding (AcyclicSCC d) = return $ fromValueDecl d
178− toBinding (CyclicSCC ~(d:ds)) = cycleError d ds
179−
180− cycleError :: Declaration -> [Declaration] -> Either ErrorStack a
181− cycleError (PositionedDeclaration p _ d) ds = rethrowWithPosition p $ cycleError d ds
182− cycleError (ValueDeclaration n _ _ (Right e)) [] = Left $
183− mkErrorStack ("Cycle in definition of " ++ show n) (Just (ExprError e))
184− cycleError d ds@(_:_) = rethrow (<> mkErrorStack ("The following are not yet defined here: " ++ unwords (map (show . getIdent) ds)) Nothing) $ cycleError d []
185− cycleError _ _ = error "Expected ValueDeclaration"
186−
187−toDataBindingGroup :: SCC Declaration -> Either ErrorStack Declaration
188−toDataBindingGroup (AcyclicSCC d) = return d
189−toDataBindingGroup (CyclicSCC [d]) = case isTypeSynonym d of
190− Just pn -> Left $ mkErrorStack ("Cycle in type synonym " ++ show pn) Nothing
191− _ -> return d
192−toDataBindingGroup (CyclicSCC ds')
193− | all (isJust . isTypeSynonym) ds' = Left $ mkErrorStack "Cycle in type synonyms" Nothing
194− | otherwise = return $ DataBindingGroupDeclaration ds'
195−
196−isTypeSynonym :: Declaration -> Maybe ProperName
197−isTypeSynonym (TypeSynonymDeclaration pn _ _) = Just pn
198−isTypeSynonym (PositionedDeclaration _ _ d) = isTypeSynonym d
199−isTypeSynonym _ = Nothing
200−
201−fromValueDecl :: Declaration -> (Ident, NameKind, Expr)
202−fromValueDecl (ValueDeclaration ident nameKind [] (Right val)) = (ident, nameKind, val)
203−fromValueDecl ValueDeclaration{} = error "Binders should have been desugared"
204−fromValueDecl (PositionedDeclaration _ _ d) = fromValueDecl d
205−fromValueDecl _ = error "Expected ValueDeclaration"
src/Language/PureScript/Sugar/CaseDeclarations.hsdeleted−127
@@ -1,127 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.CaseDeclarations
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 implements the desugaring pass which replaces top-level binders with
13−-- case expressions.
14−--
15−-----------------------------------------------------------------------------
16−
17−module Language.PureScript.Sugar.CaseDeclarations (
18− desugarCases,
19− desugarCasesModule
20−) where
21−
22−import Data.Monoid ((<>))
23−import Data.List (nub, groupBy)
24−
25−import Control.Applicative
26−import Control.Monad ((<=<), forM, join, unless, replicateM)
27−import Control.Monad.Error.Class
28−
29−import Language.PureScript.Names
30−import Language.PureScript.AST
31−import Language.PureScript.Environment
32−import Language.PureScript.Errors
33−import Language.PureScript.Supply
34−import Language.PureScript.Traversals
35−import Language.PureScript.TypeChecker.Monad (guardWith)
36−
37−-- Data.Either.isLeft (base 4.7)
38−isLeft :: Either a b -> Bool
39−isLeft (Left _) = True
40−isLeft (Right _) = False
41−
42−-- |
43−-- Replace all top-level binders in a module with case expressions.
44−--
45−desugarCasesModule :: [Module] -> SupplyT (Either ErrorStack) [Module]
46−desugarCasesModule ms = forM ms $ \(Module name ds exps) ->
47− rethrow (strMsg ("Error in module " ++ show name) <>) $
48− Module name <$> (desugarCases <=< desugarAbs $ ds) <*> pure exps
49−
50−desugarAbs :: [Declaration] -> SupplyT (Either ErrorStack) [Declaration]
51−desugarAbs = flip parU f
52− where
53− (f, _, _) = everywhereOnValuesM return replace return
54−
55− replace :: Expr -> SupplyT (Either ErrorStack) Expr
56− replace (Abs (Right binder) val) = do
57− ident <- Ident <$> freshName
58− return $ Abs (Left ident) $ Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] (Right val)]
59− replace other = return other
60−
61−-- |
62−-- Replace all top-level binders with case expressions.
63−--
64−desugarCases :: [Declaration] -> SupplyT (Either ErrorStack) [Declaration]
65−desugarCases = desugarRest <=< fmap join . flip parU toDecls . groupBy inSameGroup
66− where
67− desugarRest :: [Declaration] -> SupplyT (Either ErrorStack) [Declaration]
68− desugarRest (TypeInstanceDeclaration name constraints className tys ds : rest) =
69− (:) <$> (TypeInstanceDeclaration name constraints className tys <$> desugarCases ds) <*> desugarRest rest
70− desugarRest (ValueDeclaration name nameKind bs result : rest) =
71− let (_, f, _) = everywhereOnValuesTopDownM return go return
72− f' (Left gs) = Left <$> mapM (pairM return f) gs
73− f' (Right v) = Right <$> f v
74− in (:) <$> (ValueDeclaration name nameKind bs <$> f' result) <*> desugarRest rest
75− where
76− go (Let ds val') = Let <$> desugarCases ds <*> pure val'
77− go other = return other
78− desugarRest (PositionedDeclaration pos com d : ds) = do
79− (d' : ds') <- desugarRest (d : ds)
80− return (PositionedDeclaration pos com d' : ds')
81− desugarRest (d : ds) = (:) d <$> desugarRest ds
82− desugarRest [] = pure []
83−
84−inSameGroup :: Declaration -> Declaration -> Bool
85−inSameGroup (ValueDeclaration ident1 _ _ _) (ValueDeclaration ident2 _ _ _) = ident1 == ident2
86−inSameGroup (PositionedDeclaration _ _ d1) d2 = inSameGroup d1 d2
87−inSameGroup d1 (PositionedDeclaration _ _ d2) = inSameGroup d1 d2
88−inSameGroup _ _ = False
89−
90−toDecls :: [Declaration] -> SupplyT (Either ErrorStack) [Declaration]
91−toDecls [ValueDeclaration ident nameKind bs (Right val)] | all isVarBinder bs = do
92− let args = map (\(VarBinder arg) -> arg) bs
93− body = foldr (Abs . Left) val args
94− guardWith (strMsg "Overlapping function argument names") $ length (nub args) == length args
95− return [ValueDeclaration ident nameKind [] (Right body)]
96−toDecls ds@(ValueDeclaration ident _ bs result : _) = do
97− let tuples = map toTuple ds
98− unless (all ((== length bs) . length . fst) tuples) $
99− throwError $ mkErrorStack ("Argument list lengths differ in declaration " ++ show ident) Nothing
100− unless (not (null bs) || isLeft result) $
101− throwError $ mkErrorStack ("Duplicate value declaration '" ++ show ident ++ "'") Nothing
102− caseDecl <- makeCaseDeclaration ident tuples
103− return [caseDecl]
104−toDecls (PositionedDeclaration pos com d : ds) = do
105− (d' : ds') <- rethrowWithPosition pos $ toDecls (d : ds)
106− return (PositionedDeclaration pos com d' : ds')
107−toDecls ds = return ds
108−
109−isVarBinder :: Binder -> Bool
110−isVarBinder (VarBinder _) = True
111−isVarBinder _ = False
112−
113−toTuple :: Declaration -> ([Binder], Either [(Guard, Expr)] Expr)
114−toTuple (ValueDeclaration _ _ bs result) = (bs, result)
115−toTuple (PositionedDeclaration _ _ d) = toTuple d
116−toTuple _ = error "Not a value declaration"
117−
118−makeCaseDeclaration :: Ident -> [([Binder], Either [(Guard, Expr)] Expr)] -> SupplyT (Either ErrorStack) Declaration
119−makeCaseDeclaration ident alternatives = do
120− let argPattern = length . fst . head $ alternatives
121− args <- map Ident <$> replicateM argPattern freshName
122− let
123− vars = map (Var . Qualified Nothing) args
124− binders = [ CaseAlternative bs result | (bs, result) <- alternatives ]
125− value = foldr (Abs . Left) (Case vars binders) args
126− return $ ValueDeclaration ident Value [] (Right value)
127−
src/Language/PureScript/Sugar/DoNotation.hsdeleted−74
@@ -1,74 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.Sugar.DoNotation
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 implements the desugaring pass which replaces do-notation statements with
13−-- appropriate calls to (>>=) from the Prelude.Monad type class.
14−--
15−-----------------------------------------------------------------------------
16−
17−module Language.PureScript.Sugar.DoNotation (
18− desugarDoModule
19−) where
20−
21−import Language.PureScript.Names
22−import Language.PureScript.AST
23−import Language.PureScript.Errors
24−import Language.PureScript.Supply
25−
26−import qualified Language.PureScript.Constants as C
27−
28−import Control.Applicative
29−import Control.Monad.Trans.Class
30−
31−-- |
32−-- Replace all @DoNotationBind@ and @DoNotationValue@ constructors with applications of the Prelude.(>>=) function,
33−-- and all @DoNotationLet@ constructors with let expressions.
34−--
35−desugarDoModule :: Module -> SupplyT (Either ErrorStack) Module
36−desugarDoModule (Module mn ds exts) = Module mn <$> parU ds desugarDo <*> pure exts
37−
38−desugarDo :: Declaration -> SupplyT (Either ErrorStack) Declaration
39−desugarDo (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> (rethrowWithPosition pos $ desugarDo d)
40−desugarDo d =
41− let (f, _, _) = everywhereOnValuesM return replace return
42− in f d
43− where
44− prelude :: ModuleName
45− prelude = ModuleName [ProperName C.prelude]
46−
47− bind :: Expr
48− bind = Var (Qualified (Just prelude) (Op (C.>>=)))
49−
50− replace :: Expr -> SupplyT (Either ErrorStack) Expr
51− replace (Do els) = go els
52− replace (PositionedValue pos com v) = PositionedValue pos com <$> rethrowWithPosition pos (replace v)
53− replace other = return other
54−
55− go :: [DoNotationElement] -> SupplyT (Either ErrorStack) Expr
56− go [] = error "The impossible happened in desugarDo"
57− go [DoNotationValue val] = return val
58− go (DoNotationValue val : rest) = do
59− rest' <- go rest
60− return $ App (App bind val) (Abs (Left (Ident C.__unused)) rest')
61− go [DoNotationBind _ _] = lift $ Left $ mkErrorStack "Bind statement cannot be the last statement in a do block" Nothing
62− go (DoNotationBind NullBinder val : rest) = go (DoNotationValue val : rest)
63− go (DoNotationBind (VarBinder ident) val : rest) = do
64− rest' <- go rest
65− return $ App (App bind val) (Abs (Left ident) rest')
66− go (DoNotationBind binder val : rest) = do
67− rest' <- go rest
68− ident <- Ident <$> freshName
69− return $ App (App bind val) (Abs (Left ident) (Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] (Right rest')]))
70− go [DoNotationLet _] = lift $ Left $ mkErrorStack "Let statement cannot be the last statement in a do block" Nothing
71− go (DoNotationLet ds : rest) = do
72− rest' <- go rest
73− return $ Let ds rest'
74− go (PositionedDoNotationElement pos com el : rest) = rethrowWithPosition pos $ PositionedValue pos com <$> go (el : rest)
src/Language/PureScript/Sugar/Names.hsdeleted−548
@@ -1,548 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.Sugar.Names
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−module Language.PureScript.Sugar.Names (
16− desugarImports
17−) where
18−
19−import Data.List (nub)
20−import Data.Maybe (fromMaybe, isJust, mapMaybe)
21−import Data.Monoid ((<>))
22−
23−import Control.Applicative (Applicative(..), (<$>), (<*>))
24−import Control.Monad.Error
25−
26−import qualified Data.Map as M
27−
28−import Language.PureScript.AST
29−import Language.PureScript.Names
30−import Language.PureScript.Types
31−import Language.PureScript.Environment
32−import Language.PureScript.Errors
33−import Language.PureScript.Traversals
34−
35−import qualified Language.PureScript.Constants as C
36−
37−-- |
38−-- The global export environment - every declaration exported from every module.
39−--
40−type ExportEnvironment = M.Map ModuleName Exports
41−
42−-- |
43−-- The exported declarations from a module.
44−--
45−data Exports = Exports
46− {
47− -- |
48− -- The types exported from each module
49− --
50− exportedTypes :: [(ProperName, [ProperName])]
51− -- |
52− -- The classes exported from each module
53− --
54− , exportedTypeClasses :: [ProperName]
55− -- |
56− -- The values exported from each module
57− --
58− , exportedValues :: [Ident]
59− } deriving (Show)
60−
61−-- |
62−-- An imported environment for a particular module. This also contains the module's own members.
63−--
64−data ImportEnvironment = ImportEnvironment
65− {
66− -- |
67− -- Local names for types within a module mapped to to their qualified names
68− --
69− importedTypes :: M.Map (Qualified ProperName) (Qualified ProperName)
70− -- |
71− -- Local names for data constructors within a module mapped to to their qualified names
72− --
73− , importedDataConstructors :: M.Map (Qualified ProperName) (Qualified ProperName)
74− -- |
75− -- Local names for classes within a module mapped to to their qualified names
76− --
77− , importedTypeClasses :: M.Map (Qualified ProperName) (Qualified ProperName)
78− -- |
79− -- Local names for values within a module mapped to to their qualified names
80− --
81− , importedValues :: M.Map (Qualified Ident) (Qualified Ident)
82− } deriving (Show)
83−
84−-- |
85−-- Updates the exports for a module from the global environment. If the module was not previously
86−-- present in the global environment, it is created.
87−--
88−updateExportedModule :: ExportEnvironment -> ModuleName -> (Exports -> Either ErrorStack Exports) -> Either ErrorStack ExportEnvironment
89−updateExportedModule env mn update = do
90− let exports = fromMaybe (error "Module was undefined in updateExportedModule") $ mn `M.lookup` env
91− exports' <- update exports
92− return $ M.insert mn exports' env
93−
94−-- |
95−-- Adds an empty module to an ExportEnvironment.
96−--
97−addEmptyModule :: ExportEnvironment -> ModuleName -> Either ErrorStack ExportEnvironment
98−addEmptyModule env name =
99− if name `M.member` env
100− then throwError $ mkErrorStack ("Module '" ++ show name ++ "' has been defined more than once") Nothing
101− else return $ M.insert name (Exports [] [] []) env
102−
103−-- |
104−-- Adds a type belonging to a module to the export environment.
105−--
106−addType :: ExportEnvironment -> ModuleName -> ProperName -> [ProperName] -> Either ErrorStack ExportEnvironment
107−addType env mn name dctors = updateExportedModule env mn $ \m -> do
108− let exTypes = exportedTypes m
109− let exDctors = snd `concatMap` exTypes
110− let exClasses = exportedTypeClasses m
111− when (any ((== name) . fst) exTypes) $ throwMultipleDefError "type" name
112− when (name `elem` exClasses) $ throwConflictingDefError "Type" "type class" name
113− forM_ dctors $ \dctor -> do
114− when (dctor `elem` exDctors) $ throwMultipleDefError "data constructor" dctor
115− when (dctor `elem` exClasses) $ throwConflictingDefError "Data constructor" "type class" dctor
116− return $ m { exportedTypes = (name, dctors) : exTypes }
117−
118−-- |
119−-- Adds a class to the export environment.
120−--
121−addTypeClass :: ExportEnvironment -> ModuleName -> ProperName -> Either ErrorStack ExportEnvironment
122−addTypeClass env mn name = updateExportedModule env mn $ \m -> do
123− let exTypes = exportedTypes m
124− let exDctors = snd `concatMap` exTypes
125− when (any ((== name) . fst) exTypes) $ throwConflictingDefError "Type class" "type" name
126− when (name `elem` exDctors) $ throwConflictingDefError "Type class" "data constructor" name
127− classes <- addExport "type class" (exportedTypeClasses m) name
128− return $ m { exportedTypeClasses = classes }
129−
130−-- |
131−-- Adds a class to the export environment.
132−--
133−addValue :: ExportEnvironment -> ModuleName -> Ident -> Either ErrorStack ExportEnvironment
134−addValue env mn name = updateExportedModule env mn $ \m -> do
135− values <- addExport "value" (exportedValues m) name
136− return $ m { exportedValues = values }
137−
138−-- |
139−-- Adds an entry to a list of exports unless it is already present, in which case an error is
140−-- returned.
141−--
142−addExport :: (Eq a, Show a) => String -> [a] -> a -> Either ErrorStack [a]
143−addExport what exports name =
144− if name `elem` exports
145− then throwMultipleDefError what name
146− else return $ name : exports
147−
148−-- |
149−-- Replaces all local names with qualified names within a set of modules.
150−--
151−desugarImports :: [Module] -> Either ErrorStack [Module]
152−desugarImports modules = do
153− unfilteredExports <- findExports modules
154− exports <- foldM filterModuleExports unfilteredExports modules
155− mapM (renameInModule' unfilteredExports exports) modules
156− where
157−
158− -- Filters the exports for a module in the global exports environment so that only explicitly
159− -- exported members remain. If the module does not explicitly export anything, everything is
160− -- exported.
161− filterModuleExports :: ExportEnvironment -> Module -> Either ErrorStack ExportEnvironment
162− filterModuleExports env (Module mn _ (Just exps)) = filterExports mn exps env
163− filterModuleExports env _ = return env
164−
165− -- Rename and check all the names within a module. We tweak the global exports environment so
166− -- the module has access to an unfiltered list of its own members.
167− renameInModule' :: ExportEnvironment -> ExportEnvironment -> Module -> Either ErrorStack Module
168− renameInModule' unfilteredExports exports m@(Module mn _ _) =
169− rethrow (strMsg ("Error in module " ++ show mn) <>) $ do
170− let env = M.update (\_ -> M.lookup mn unfilteredExports) mn exports
171− let exps = fromMaybe (error "Module is missing in renameInModule'") $ M.lookup mn exports
172− imports <- resolveImports env m
173− elaborateImports <$> renameInModule imports env (elaborateExports exps m)
174−
175−-- |
176−-- Make all exports for a module explicit. This may still effect modules that have an exports list,
177−-- as it will also make all data constructor exports explicit.
178−--
179−elaborateExports :: Exports -> Module -> Module
180−elaborateExports exps (Module mn decls _) = Module mn decls (Just $
181− map (\(ctor, dctors) -> TypeRef ctor (Just dctors)) (exportedTypes exps) ++
182− map TypeClassRef (exportedTypeClasses exps) ++
183− map ValueRef (exportedValues exps))
184−
185−-- |
186−-- Add `import X ()` for any modules where there are only fully qualified references to members.
187−-- This ensures transitive instances are included when using a member from a module.
188−--
189−elaborateImports :: Module -> Module
190−elaborateImports (Module mn decls exps) = Module mn decls' exps
191− where
192− decls' :: [Declaration]
193− decls' =
194− let (f, _, _, _, _) = everythingOnValues (++) (const []) fqValues (const []) (const []) (const [])
195− in mkImport `map` nub (f `concatMap` decls) ++ decls
196− fqValues :: Expr -> [ModuleName]
197− fqValues (Var (Qualified (Just mn') _)) = [mn']
198− fqValues _ = []
199− mkImport :: ModuleName -> Declaration
200− mkImport mn' = ImportDeclaration mn' (Qualifying []) Nothing
201−
202−-- |
203−-- Replaces all local names with qualified names within a module and checks that all existing
204−-- qualified names are valid.
205−--
206−renameInModule :: ImportEnvironment -> ExportEnvironment -> Module -> Either ErrorStack Module
207−renameInModule imports exports (Module mn decls exps) =
208− Module mn <$> parU decls go <*> pure exps
209− where
210− (go, _, _, _, _) = everywhereWithContextOnValuesM (Nothing, []) updateDecl updateValue updateBinder updateCase defS
211−
212− updateDecl :: (Maybe SourceSpan, [Ident]) -> Declaration -> Either ErrorStack ((Maybe SourceSpan, [Ident]), Declaration)
213− updateDecl (_, bound) d@(PositionedDeclaration pos _ _) = return ((Just pos, bound), d)
214− updateDecl (pos, bound) (DataDeclaration dtype name args dctors) =
215− (,) (pos, bound) <$> (DataDeclaration dtype name args <$> mapM (sndM (mapM (updateTypesEverywhere pos))) dctors)
216− updateDecl (pos, bound) (TypeSynonymDeclaration name ps ty) =
217− (,) (pos, bound) <$> (TypeSynonymDeclaration name ps <$> updateTypesEverywhere pos ty)
218− updateDecl (pos, bound) (TypeClassDeclaration className args implies ds) =
219− (,) (pos, bound) <$> (TypeClassDeclaration className args <$> updateConstraints pos implies <*> pure ds)
220− updateDecl (pos, bound) (TypeInstanceDeclaration name cs cn ts ds) =
221− (,) (pos, bound) <$> (TypeInstanceDeclaration name <$> updateConstraints pos cs <*> updateClassName cn pos <*> mapM (updateTypesEverywhere pos) ts <*> pure ds)
222− updateDecl (pos, bound) (ExternInstanceDeclaration name cs cn ts) =
223− (,) (pos, bound) <$> (ExternInstanceDeclaration name <$> updateConstraints pos cs <*> updateClassName cn Nothing <*> mapM (updateTypesEverywhere pos) ts)
224− updateDecl (pos, bound) (TypeDeclaration name ty) =
225− (,) (pos, bound) <$> (TypeDeclaration name <$> updateTypesEverywhere pos ty)
226− updateDecl (pos, bound) (ExternDeclaration fit name js ty) =
227− (,) (pos, name : bound) <$> (ExternDeclaration fit name js <$> updateTypesEverywhere pos ty)
228− updateDecl s d = return (s, d)
229−
230− updateValue :: (Maybe SourceSpan, [Ident]) -> Expr -> Either ErrorStack ((Maybe SourceSpan, [Ident]), Expr)
231− updateValue (_, bound) v@(PositionedValue pos' _ _) = return ((Just pos', bound), v)
232− updateValue (pos, bound) (Abs (Left arg) val') = return ((pos, arg : bound), Abs (Left arg) val')
233− updateValue (pos, bound) (Let ds val') = do
234− let args = mapMaybe letBoundVariable ds
235− unless (length (nub args) == length args) $
236− throwError $ maybe id (\p e -> positionError p <> e) pos $ mkErrorStack ("Overlapping names in let binding.") Nothing
237− return ((pos, args ++ bound), Let ds val')
238− where
239− updateValue (pos, bound) (Var name'@(Qualified Nothing ident)) | ident `notElem` bound =
240− (,) (pos, bound) <$> (Var <$> updateValueName name' pos)
241− updateValue (pos, bound) (Var name'@(Qualified (Just _) _)) =
242− (,) (pos, bound) <$> (Var <$> updateValueName name' pos)
243− updateValue s@(pos, _) (Constructor name) = (,) s <$> (Constructor <$> updateDataConstructorName name pos)
244− updateValue s@(pos, _) (TypedValue check val ty) = (,) s <$> (TypedValue check val <$> updateTypesEverywhere pos ty)
245− updateValue s v = return (s, v)
246−
247− updateBinder :: (Maybe SourceSpan, [Ident]) -> Binder -> Either ErrorStack ((Maybe SourceSpan, [Ident]), Binder)
248− updateBinder (_, bound) v@(PositionedBinder pos _ _) = return ((Just pos, bound), v)
249− updateBinder s@(pos, _) (ConstructorBinder name b) = (,) s <$> (ConstructorBinder <$> updateDataConstructorName name pos <*> pure b)
250− updateBinder s v = return (s, v)
251−
252− updateCase :: (Maybe SourceSpan, [Ident]) -> CaseAlternative -> Either ErrorStack ((Maybe SourceSpan, [Ident]), CaseAlternative)
253− updateCase (pos, bound) c@(CaseAlternative bs _) = return ((pos, concatMap binderNames bs ++ bound), c)
254−
255− letBoundVariable :: Declaration -> Maybe Ident
256− letBoundVariable (ValueDeclaration ident _ _ _) = Just ident
257− letBoundVariable (PositionedDeclaration _ _ d) = letBoundVariable d
258− letBoundVariable _ = Nothing
259−
260− updateTypesEverywhere :: Maybe SourceSpan -> Type -> Either ErrorStack Type
261− updateTypesEverywhere pos0 = everywhereOnTypesM (updateType pos0)
262− where
263− updateType :: Maybe SourceSpan -> Type -> Either ErrorStack Type
264− updateType pos (TypeConstructor name) = TypeConstructor <$> updateTypeName name pos
265− updateType pos (SaturatedTypeSynonym name tys) = SaturatedTypeSynonym <$> updateTypeName name pos <*> pure tys
266− updateType pos (ConstrainedType cs t) = ConstrainedType <$> updateConstraints pos cs <*> pure t
267− updateType _ t = return t
268−
269− updateConstraints pos = mapM (\(name, ts) -> (,) <$> updateClassName name pos <*> mapM (updateTypesEverywhere pos) ts)
270−
271− updateTypeName = update "type" importedTypes (\mes -> isJust . (`lookup` exportedTypes mes))
272− updateClassName = update "type class" importedTypeClasses (flip elem . exportedTypeClasses)
273− updateValueName = update "value" importedValues (flip elem . exportedValues)
274− updateDataConstructorName = update "data constructor" importedDataConstructors (\mes -> flip elem (join $ snd `map` exportedTypes mes))
275−
276− -- Update names so unqualified references become qualified, and locally qualified references
277− -- are replaced with their canoncial qualified names (e.g. M.Map -> Data.Map.Map)
278− update :: (Ord a, Show a) => String
279− -> (ImportEnvironment -> M.Map (Qualified a) (Qualified a))
280− -> (Exports -> a -> Bool)
281− -> Qualified a
282− -> Maybe SourceSpan
283− -> Either ErrorStack (Qualified a)
284− update t getI checkE qname@(Qualified mn' name) pos = positioned $ case (M.lookup qname imports', mn') of
285− (Just qname', _) -> return qname'
286− (Nothing, Just mn'') -> do
287− when (isExplicitQualModule mn'') $ throwError $ mkErrorStack ("Unknown " ++ t ++ " '" ++ show qname ++ "'") Nothing
288− modExports <- getExports mn''
289− if checkE modExports name
290− then return qname
291− else throwError $ mkErrorStack ("Unknown " ++ t ++ " '" ++ show qname ++ "'") Nothing
292− _ -> throwError $ mkErrorStack ("Unknown " ++ t ++ " '" ++ show name ++ "'") Nothing
293− where
294− isExplicitQualModule :: ModuleName -> Bool
295− isExplicitQualModule = flip elem $ mapMaybe (\(Qualified q _) -> q) (M.keys imports')
296− imports' = getI imports
297− positioned err = case pos of
298− Nothing -> err
299− Just pos' -> rethrowWithPosition pos' err
300−
301− -- Gets the exports for a module, or an error message if the module doesn't exist
302− getExports :: ModuleName -> Either ErrorStack Exports
303− getExports mn' = maybe (throwError $ mkErrorStack ("Unknown module '" ++ show mn' ++ "'") Nothing) return $ M.lookup mn' exports
304−
305−-- |
306−-- Finds all exported declarations in a set of modules.
307−--
308−findExports :: [Module] -> Either ErrorStack ExportEnvironment
309−findExports = foldM addModule $ M.singleton (ModuleName [ProperName C.prim]) primExports
310− where
311−
312− -- The exported types from the Prim module
313− primExports = Exports (mkTypeEntry `map` M.keys primTypes) [] []
314− where
315− mkTypeEntry (Qualified _ name) = (name, [])
316−
317− -- Add all of the exported declarations from a module to the global export environment
318− addModule :: ExportEnvironment -> Module -> Either ErrorStack ExportEnvironment
319− addModule env (Module mn ds _) = do
320− env' <- addEmptyModule env mn
321− rethrow (strMsg ("Error in module " ++ show mn) <>) $ foldM (addDecl mn) env' ds
322−
323− -- Add a declaration from a module to the global export environment
324− addDecl :: ModuleName -> ExportEnvironment -> Declaration -> Either ErrorStack ExportEnvironment
325− addDecl mn env (TypeClassDeclaration tcn _ _ ds) = do
326− env' <- addTypeClass env mn tcn
327− foldM go env' ds
328− where
329− go env'' (TypeDeclaration name _) = addValue env'' mn name
330− go env'' (PositionedDeclaration pos _ d) = rethrowWithPosition pos $ go env'' d
331− go _ _ = error "Invalid declaration in TypeClassDeclaration"
332− addDecl mn env (DataDeclaration _ tn _ dcs) = addType env mn tn (map fst dcs)
333− addDecl mn env (TypeSynonymDeclaration tn _ _) = addType env mn tn []
334− addDecl mn env (ExternDataDeclaration tn _) = addType env mn tn []
335− addDecl mn env (ValueDeclaration name _ _ _) = addValue env mn name
336− addDecl mn env (ExternDeclaration _ name _ _) = addValue env mn name
337− addDecl mn env (PositionedDeclaration pos _ d) = rethrowWithPosition pos $ addDecl mn env d
338− addDecl _ env _ = return env
339−
340−-- |
341−-- Filters the exports for a module to ensure only explicit exports are kept in the global exports
342−-- environment.
343−--
344−filterExports :: ModuleName -> [DeclarationRef] -> ExportEnvironment -> Either ErrorStack ExportEnvironment
345−filterExports mn exps env = do
346− let moduleExports = fromMaybe (error "Module is missing") (mn `M.lookup` env)
347− moduleExports' <- rethrow (strMsg ("Error in module " ++ show mn) <>) $ filterModule moduleExports
348− return $ M.insert mn moduleExports' env
349− where
350−
351− -- Filter the exports for the specific module
352− filterModule :: Exports -> Either ErrorStack Exports
353− filterModule exported = do
354− types' <- foldM (filterTypes $ exportedTypes exported) [] exps
355− values <- foldM (filterValues $ exportedValues exported) [] exps
356− classes <- foldM (filterClasses $ exportedTypeClasses exported) [] exps
357− return exported { exportedTypes = types', exportedTypeClasses = classes, exportedValues = values }
358−
359− -- Ensure the exported types and data constructors exist in the module and add them to the set of
360− -- exports
361− filterTypes :: [(ProperName, [ProperName])] -> [(ProperName, [ProperName])] -> DeclarationRef -> Either ErrorStack [(ProperName, [ProperName])]
362− filterTypes expTys result (PositionedDeclarationRef pos _ r) = rethrowWithPosition pos $ filterTypes expTys result r
363− filterTypes expTys result (TypeRef name expDcons) = do
364− dcons <- maybe (throwError $ mkErrorStack ("Cannot export undefined type '" ++ show name ++ "'") Nothing) return $ name `lookup` expTys
365− dcons' <- maybe (return dcons) (foldM (filterDcons name dcons) []) expDcons
366− return $ (name, dcons') : result
367− filterTypes _ result _ = return result
368−
369− -- Ensure the exported data constructors exists for a type and add them to the list of exports
370− filterDcons :: ProperName -> [ProperName] -> [ProperName] -> ProperName -> Either ErrorStack [ProperName]
371− filterDcons tcon exps' result name =
372− if name `elem` exps'
373− then return $ name : result
374− else throwError $ mkErrorStack ("Cannot export undefined data constructor '" ++ show name ++ "' for type '" ++ show tcon ++ "'") Nothing
375−
376− -- Ensure the exported classes exist in the module and add them to the set of exports
377− filterClasses :: [ProperName] -> [ProperName] -> DeclarationRef -> Either ErrorStack [ProperName]
378− filterClasses exps' result (PositionedDeclarationRef pos _ r) = rethrowWithPosition pos $ filterClasses exps' result r
379− filterClasses exps' result (TypeClassRef name) =
380− if name `elem` exps'
381− then return $ name : result
382− else throwError $ mkErrorStack ("Cannot export undefined type class '" ++ show name ++ "'") Nothing
383− filterClasses _ result _ = return result
384−
385− -- Ensure the exported values exist in the module and add them to the set of exports
386− filterValues :: [Ident] -> [Ident] -> DeclarationRef -> Either ErrorStack [Ident]
387− filterValues exps' result (PositionedDeclarationRef pos _ r) = rethrowWithPosition pos $ filterValues exps' result r
388− filterValues exps' result (ValueRef name) =
389− if name `elem` exps'
390− then return $ name : result
391− else throwError $ mkErrorStack ("Cannot export undefined value '" ++ show name ++ "'") Nothing
392− filterValues _ result _ = return result
393−
394−-- |
395−-- Finds the imports within a module, mapping the imported module name to an optional set of
396−-- explicitly imported declarations.
397−--
398−findImports :: [Declaration] -> M.Map ModuleName (Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)
399−findImports = foldl (findImports' Nothing) M.empty
400− where
401− findImports' pos result (ImportDeclaration mn typ qual) = M.insert mn (pos, typ, qual) result
402− findImports' _ result (PositionedDeclaration pos _ d) = findImports' (Just pos) result d
403− findImports' _ result _ = result
404−
405−-- |
406−-- Constructs a local environment for a module.
407−--
408−resolveImports :: ExportEnvironment -> Module -> Either ErrorStack ImportEnvironment
409−resolveImports env (Module currentModule decls _) =
410− foldM resolveImport' (ImportEnvironment M.empty M.empty M.empty M.empty) (M.toList scope)
411− where
412−
413− -- A Map from module name to the source position for the import, the list of imports from that
414− -- module (where Nothing indicates everything is to be imported), and optionally a qualified name
415− -- for the module
416− scope :: M.Map ModuleName (Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)
417− scope = M.insert currentModule (Nothing, Unqualified, Nothing) (findImports decls)
418−
419− resolveImport' :: ImportEnvironment -> (ModuleName, (Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)) -> Either ErrorStack ImportEnvironment
420− resolveImport' imp (mn, (pos, typ, impQual)) = do
421− modExports <- positioned $ maybe (throwError $ mkErrorStack ("Cannot import unknown module '" ++ show mn ++ "'") Nothing) return $ mn `M.lookup` env
422− positioned $ resolveImport currentModule mn modExports imp impQual typ
423− where
424− positioned err = case pos of
425− Nothing -> err
426− Just pos' -> rethrowWithPosition pos' err
427−
428−-- |
429−-- Extends the local environment for a module by resolving an import of another module.
430−--
431−resolveImport :: ModuleName -> ModuleName -> Exports -> ImportEnvironment -> Maybe ModuleName -> ImportDeclarationType -> Either ErrorStack ImportEnvironment
432−resolveImport currentModule importModule exps imps impQual =
433− resolveByType
434− where
435−
436− resolveByType :: ImportDeclarationType -> Either ErrorStack ImportEnvironment
437− resolveByType Unqualified = importAll importExplicit
438− resolveByType (Qualifying explImports) = (checkedRefs >=> foldM importExplicit imps) explImports
439− resolveByType (Hiding hiddenImports) = do
440− hiddenImports' <- checkedRefs hiddenImports
441− importAll (importNonHidden hiddenImports')
442−
443− importNonHidden :: [DeclarationRef] -> ImportEnvironment -> DeclarationRef -> Either ErrorStack ImportEnvironment
444− importNonHidden hidden m ref =
445− if isHidden hidden ref
446− then return m
447− else importExplicit m ref
448−
449− isHidden :: [DeclarationRef] -> DeclarationRef -> Bool
450− isHidden hidden ref@(TypeRef _ _) =
451− let
452− checkTypeRef _ True _ = True
453− checkTypeRef (TypeRef _ Nothing) acc (TypeRef _ (Just _)) = acc
454− checkTypeRef (TypeRef name (Just dctor)) _ (TypeRef name' (Just dctor')) = name == name' && dctor == dctor'
455− checkTypeRef (TypeRef name _) _ (TypeRef name' Nothing) = name == name'
456− checkTypeRef (PositionedDeclarationRef _ _ r) acc hiddenRef = checkTypeRef r acc hiddenRef
457− checkTypeRef _ acc _ = acc
458− in foldl (checkTypeRef ref) False hidden
459− isHidden hidden ref = ref `elem` hidden
460−
461− -- Import all symbols
462− importAll :: (ImportEnvironment -> DeclarationRef -> Either ErrorStack ImportEnvironment) -> Either ErrorStack ImportEnvironment
463− importAll importer = do
464− imp' <- foldM (\m (name, dctors) -> importer m (TypeRef name (Just dctors))) imps (exportedTypes exps)
465− imp'' <- foldM (\m name -> importer m (ValueRef name)) imp' (exportedValues exps)
466− foldM (\m name -> importer m (TypeClassRef name)) imp'' (exportedTypeClasses exps)
467−
468− -- Import something explicitly
469− importExplicit :: ImportEnvironment -> DeclarationRef -> Either ErrorStack ImportEnvironment
470− importExplicit imp (PositionedDeclarationRef pos _ r) = rethrowWithPosition pos $ importExplicit imp r
471− importExplicit imp (ValueRef name) = do
472− values' <- updateImports (importedValues imp) name
473− return $ imp { importedValues = values' }
474− importExplicit imp (TypeRef name dctors) = do
475− types' <- updateImports (importedTypes imp) name
476− let allDctors = allExportedDataConstructors name
477− dctors' <- maybe (return allDctors) (mapM $ checkDctorExists allDctors) dctors
478− dctors'' <- foldM updateImports (importedDataConstructors imp) dctors'
479− return $ imp { importedTypes = types', importedDataConstructors = dctors'' }
480− importExplicit imp (TypeClassRef name) = do
481− typeClasses' <- updateImports (importedTypeClasses imp) name
482− return $ imp { importedTypeClasses = typeClasses' }
483− importExplicit _ _ = error "Invalid argument to importExplicit"
484−
485− -- Check if DeclarationRef points to an existent symbol
486− checkedRefs :: [DeclarationRef] -> Either ErrorStack [DeclarationRef]
487− checkedRefs = mapM check
488− where
489− check (PositionedDeclarationRef pos _ r) =
490− rethrowWithPosition pos $ check r
491− check ref@(ValueRef name) =
492− checkImportExists "value" values name >> return ref
493− check ref@(TypeRef name dctors) = do
494− _ <- checkImportExists "type" availableTypes name
495− let allDctors = allExportedDataConstructors name
496− _ <- maybe (return allDctors) (mapM $ checkDctorExists allDctors) dctors
497− return ref
498− check ref@(TypeClassRef name) =
499− checkImportExists "type class" classes name >> return ref
500− check _ = error "Invalid argument to checkRefIsValid"
501−
502− -- Find all exported data constructors for a given type
503− allExportedDataConstructors :: ProperName -> [ProperName]
504− allExportedDataConstructors name = fromMaybe [] $ name `lookup` exportedTypes exps
505−
506− -- Add something to the ImportEnvironment if it does not already exist there
507− updateImports :: (Ord a, Show a) => M.Map (Qualified a) (Qualified a) -> a -> Either ErrorStack (M.Map (Qualified a) (Qualified a))
508− updateImports m name = case M.lookup (Qualified impQual name) m of
509− Nothing -> return $ M.insert (Qualified impQual name) (Qualified (Just importModule) name) m
510− Just (Qualified Nothing _) -> error "Invalid state in updateImports"
511− Just x@(Qualified (Just mn) _) -> throwError $ mkErrorStack err Nothing
512− where
513− err = if mn == currentModule || importModule == currentModule
514− then "Definition '" ++ show name ++ "' conflicts with import '" ++ show (Qualified (Just mn) name) ++ "'"
515− else "Conflicting imports for '" ++ show name ++ "': '" ++ show x ++ "', '" ++ show (Qualified (Just importModule) name) ++ "'"
516−
517− -- The available values, types, and classes in the module being imported
518− values = exportedValues exps
519− availableTypes = fst `map` exportedTypes exps
520− classes = exportedTypeClasses exps
521−
522− -- Ensure that an explicitly imported data constructor exists for the type it is being imported
523− -- from
524− checkDctorExists :: [ProperName] -> ProperName -> Either ErrorStack ProperName
525− checkDctorExists = checkImportExists "data constructor"
526−
527− -- Check that an explicitly imported item exists in the module it is being imported from
528− checkImportExists :: (Eq a, Show a) => String -> [a] -> a -> Either ErrorStack a
529− checkImportExists t exports item =
530− if item `elem` exports
531− then return item
532− else throwError $ mkErrorStack ("Cannot import unknown " ++ t ++ " '" ++ show item ++ "' from '" ++ show importModule ++ "'") Nothing
533−
534−-- |
535−-- Raises an error for when there is more than one definition for something.
536−--
537−throwMultipleDefError :: (Show a) => String -> a -> Either ErrorStack b
538−throwMultipleDefError what name = throwError $
539− mkErrorStack ("Multiple definitions for " ++ what ++ " '" ++ show name ++ "'") Nothing
540−
541−-- |
542−-- Raises an error for when there is a conflicting definition for something, for example, a type
543−-- class and data constructor of the same name.
544−--
545−throwConflictingDefError :: (Show a) => String -> String -> a -> Either ErrorStack b
546−throwConflictingDefError what1 what2 name = throwError $
547− mkErrorStack (what1 ++ " '" ++ show name ++ "' cannot be defined in the same module as a " ++ what2 ++ " of the same name") Nothing
548−
src/Language/PureScript/Sugar/ObjectWildcards.hsdeleted−61
@@ -1,61 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.Sugar.ObjectWildcards
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−module Language.PureScript.Sugar.ObjectWildcards (
16− desugarObjectConstructors
17−) where
18−
19−import Control.Applicative
20−import Control.Arrow (second)
21−
22−import Data.List (partition)
23−import Data.Maybe (isJust, fromJust, catMaybes)
24−
25−import Language.PureScript.AST
26−import Language.PureScript.Errors
27−import Language.PureScript.Names
28−import Language.PureScript.Supply
29−
30−desugarObjectConstructors :: Module -> SupplyT (Either ErrorStack) Module
31−desugarObjectConstructors (Module mn ds exts) = Module mn <$> mapM desugarDecl ds <*> pure exts
32− where
33−
34− desugarDecl :: Declaration -> SupplyT (Either ErrorStack) Declaration
35− (desugarDecl, _, _) = everywhereOnValuesM return desugarExpr return
36−
37− desugarExpr :: Expr -> SupplyT (Either ErrorStack) Expr
38− desugarExpr (ObjectConstructor ps) = wrapLambda ObjectLiteral ps
39− desugarExpr (ObjectUpdater (Just obj) ps) = wrapLambda (ObjectUpdate obj) ps
40− desugarExpr (ObjectUpdater Nothing ps) = do
41− obj <- Ident <$> freshName
42− Abs (Left obj) <$> wrapLambda (ObjectUpdate (Var (Qualified Nothing obj))) ps
43− desugarExpr (ObjectGetter prop) = do
44− arg <- Ident <$> freshName
45− return $ Abs (Left arg) (Accessor prop (Var (Qualified Nothing arg)))
46− desugarExpr e = return e
47−
48− wrapLambda :: ([(String, Expr)] -> Expr) -> [(String, Maybe Expr)] -> SupplyT (Either ErrorStack) Expr
49− wrapLambda mkVal ps =
50− let (props, args) = partition (isJust . snd) ps
51− in if null args
52− then return . mkVal $ second fromJust `map` props
53− else do
54− (args', ps') <- unzip <$> mapM mkProp ps
55− return $ foldr (Abs . Left) (mkVal ps') (catMaybes args')
56−
57− mkProp :: (String, Maybe Expr) -> SupplyT (Either ErrorStack) (Maybe Ident, (String, Expr))
58− mkProp (name, Just e) = return (Nothing, (name, e))
59− mkProp (name, Nothing) = do
60− arg <- Ident <$> freshName
61− return (Just arg, (name, Var (Qualified Nothing arg)))
src/Language/PureScript/Sugar/Operators.hsdeleted−165
@@ -1,165 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.Sugar.Operators
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 implements the desugaring pass which reapplies binary operators based
13−-- on their fixity data and removes explicit parentheses.
14−--
15−-- The value parser ignores fixity data when parsing binary operator applications, so
16−-- it is necessary to reorder them here.
17−--
18−-----------------------------------------------------------------------------
19−
20−{-# LANGUAGE Rank2Types, FlexibleContexts #-}
21−
22−module Language.PureScript.Sugar.Operators (
23− rebracket,
24− removeSignedLiterals,
25− desugarOperatorSections
26−) where
27−
28−import Language.PureScript.AST
29−import Language.PureScript.Errors
30−import Language.PureScript.Names
31−import Language.PureScript.Supply
32−
33−import Control.Applicative
34−import Control.Monad.State
35−import Control.Monad.Error.Class
36−
37−import Data.Monoid ((<>))
38−import Data.Function (on)
39−import Data.Functor.Identity
40−import Data.List (groupBy, sortBy)
41−
42−import qualified Text.Parsec as P
43−import qualified Text.Parsec.Pos as P
44−import qualified Text.Parsec.Expr as P
45−
46−import qualified Language.PureScript.Constants as C
47−
48−-- |
49−-- Remove explicit parentheses and reorder binary operator applications
50−--
51−rebracket :: [Module] -> Either ErrorStack [Module]
52−rebracket ms = do
53− let fixities = concatMap collectFixities ms
54− ensureNoDuplicates $ map (\(i, pos, _) -> (i, pos)) fixities
55− let opTable = customOperatorTable $ map (\(i, _, f) -> (i, f)) fixities
56− mapM (rebracketModule opTable) ms
57−
58−removeSignedLiterals :: Module -> Module
59−removeSignedLiterals (Module mn ds exts) = Module mn (map f' ds) exts
60− where
61− (f', _, _) = everywhereOnValues id go id
62−
63− go (UnaryMinus val) = App (Var (Qualified (Just (ModuleName [ProperName C.prelude])) (Ident C.negate))) val
64− go other = other
65−
66−rebracketModule :: [[(Qualified Ident, Expr -> Expr -> Expr, Associativity)]] -> Module -> Either ErrorStack Module
67−rebracketModule opTable (Module mn ds exts) =
68− let (f, _, _) = everywhereOnValuesTopDownM return (matchOperators opTable) return
69− in Module mn <$> (map removeParens <$> parU ds f) <*> pure exts
70−
71−removeParens :: Declaration -> Declaration
72−removeParens =
73− let (f, _, _) = everywhereOnValues id go id
74− in f
75− where
76− go (Parens val) = val
77− go val = val
78−
79−collectFixities :: Module -> [(Qualified Ident, SourceSpan, Fixity)]
80−collectFixities (Module moduleName ds _) = concatMap collect ds
81− where
82− collect :: Declaration -> [(Qualified Ident, SourceSpan, Fixity)]
83− collect (PositionedDeclaration pos _ (FixityDeclaration fixity name)) = [(Qualified (Just moduleName) (Op name), pos, fixity)]
84− collect FixityDeclaration{} = error "Fixity without srcpos info"
85− collect _ = []
86−
87−ensureNoDuplicates :: [(Qualified Ident, SourceSpan)] -> Either ErrorStack ()
88−ensureNoDuplicates m = go $ sortBy (compare `on` fst) m
89− where
90− go [] = return ()
91− go [_] = return ()
92− go ((x@(Qualified (Just mn) name), _) : (y, pos) : _) | x == y =
93− rethrow (strMsg ("Error in module " ++ show mn) <>) $
94− rethrowWithPosition pos $
95− throwError $ mkErrorStack ("Redefined fixity for " ++ show name) Nothing
96− go (_ : rest) = go rest
97−
98−customOperatorTable :: [(Qualified Ident, Fixity)] -> [[(Qualified Ident, Expr -> Expr -> Expr, Associativity)]]
99−customOperatorTable fixities =
100− let
101− applyUserOp ident t1 = App (App (Var ident) t1)
102− userOps = map (\(name, Fixity a p) -> (name, applyUserOp name, p, a)) fixities
103− sorted = sortBy (flip compare `on` (\(_, _, p, _) -> p)) userOps
104− groups = groupBy ((==) `on` (\(_, _, p, _) -> p)) sorted
105− in
106− map (map (\(name, f, _, a) -> (name, f, a))) groups
107−
108−type Chain = [Either Expr Expr]
109−
110−matchOperators :: [[(Qualified Ident, Expr -> Expr -> Expr, Associativity)]] -> Expr -> Either ErrorStack Expr
111−matchOperators ops = parseChains
112− where
113− parseChains :: Expr -> Either ErrorStack Expr
114− parseChains b@BinaryNoParens{} = bracketChain (extendChain b)
115− parseChains other = return other
116− extendChain :: Expr -> Chain
117− extendChain (BinaryNoParens op l r) = Left l : Right op : extendChain r
118− extendChain other = [Left other]
119− bracketChain :: Chain -> Either ErrorStack Expr
120− bracketChain = either (Left . (`mkErrorStack` Nothing) . show) Right . P.parse (P.buildExpressionParser opTable parseValue <* P.eof) "operator expression"
121− opTable = [P.Infix (P.try (parseTicks >>= \op -> return (\t1 t2 -> App (App op t1) t2))) P.AssocLeft]
122− : map (map (\(name, f, a) -> P.Infix (P.try (matchOp name) >> return f) (toAssoc a))) ops
123− ++ [[ P.Infix (P.try (parseOp >>= \ident -> return (\t1 t2 -> App (App (Var ident) t1) t2))) P.AssocLeft ]]
124−
125−toAssoc :: Associativity -> P.Assoc
126−toAssoc Infixl = P.AssocLeft
127−toAssoc Infixr = P.AssocRight
128−toAssoc Infix = P.AssocNone
129−
130−token :: (P.Stream s Identity t, Show t) => (t -> Maybe a) -> P.Parsec s u a
131−token = P.token show (const (P.initialPos ""))
132−
133−parseValue :: P.Parsec Chain () Expr
134−parseValue = token (either Just (const Nothing)) P.<?> "expression"
135−
136−parseOp :: P.Parsec Chain () (Qualified Ident)
137−parseOp = token (either (const Nothing) fromOp) P.<?> "operator"
138− where
139− fromOp (Var q@(Qualified _ (Op _))) = Just q
140− fromOp _ = Nothing
141−
142−parseTicks :: P.Parsec Chain () Expr
143−parseTicks = token (either (const Nothing) fromOther) P.<?> "infix function"
144− where
145− fromOther (Var (Qualified _ (Op _))) = Nothing
146− fromOther v = Just v
147−
148−matchOp :: Qualified Ident -> P.Parsec Chain () ()
149−matchOp op = do
150− ident <- parseOp
151− guard $ ident == op
152−
153−desugarOperatorSections :: Module -> SupplyT (Either ErrorStack) Module
154−desugarOperatorSections (Module mn ds exts) = Module mn <$> mapM goDecl ds <*> pure exts
155− where
156−
157− goDecl :: Declaration -> SupplyT (Either ErrorStack) Declaration
158− (goDecl, _, _) = everywhereOnValuesM return goExpr return
159−
160− goExpr :: Expr -> SupplyT (Either ErrorStack) Expr
161− goExpr (OperatorSection op (Left val)) = return $ App op val
162− goExpr (OperatorSection op (Right val)) = do
163− arg <- Ident <$> freshName
164− return $ Abs (Left arg) $ App (App op (Var (Qualified Nothing arg))) val
165− goExpr other = return other
src/Language/PureScript/Sugar/TypeClasses.hsdeleted−291
@@ -1,291 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.Sugar.TypeClasses
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 implements the desugaring pass which creates type synonyms for type class dictionaries
13−-- and dictionary expressions for type class instances.
14−--
15−-----------------------------------------------------------------------------
16−
17−module Language.PureScript.Sugar.TypeClasses
18− ( desugarTypeClasses
19− , typeClassMemberName
20− , superClassDictionaryNames
21− ) where
22−
23−import Language.PureScript.AST hiding (isExported)
24−import Language.PureScript.Environment
25−import Language.PureScript.Errors
26−import Language.PureScript.Kinds
27−import Language.PureScript.Names
28−import Language.PureScript.Pretty.Types (prettyPrintTypeAtom)
29−import Language.PureScript.Sugar.CaseDeclarations
30−import Language.PureScript.Supply
31−import Language.PureScript.Types
32−
33−import qualified Language.PureScript.Constants as C
34−
35−import Control.Applicative
36−import Control.Arrow (first, second)
37−import Control.Monad.Error
38−import Control.Monad.State
39−import Data.List ((\\), find)
40−import Data.Maybe (catMaybes, mapMaybe, isJust)
41−import Data.Monoid ((<>))
42−
43−import qualified Data.Map as M
44−
45−type MemberMap = M.Map (ModuleName, ProperName) Declaration
46−
47−type Desugar = StateT MemberMap (SupplyT (Either ErrorStack))
48−
49−-- |
50−-- Add type synonym declarations for type class dictionary types, and value declarations for type class
51−-- instance dictionary expressions.
52−--
53−desugarTypeClasses :: [Module] -> SupplyT (Either ErrorStack) [Module]
54−desugarTypeClasses = flip evalStateT M.empty . mapM desugarModule
55−
56−desugarModule :: Module -> Desugar Module
57−desugarModule (Module name decls (Just exps)) = do
58− (newExpss, declss) <- unzip <$> parU decls (desugarDecl name exps)
59− return $ Module name (concat declss) $ Just (exps ++ catMaybes newExpss)
60−desugarModule _ = error "Exports should have been elaborated in name desugaring"
61−
62−{- Desugar type class and type class instance declarations
63−--
64−-- Type classes become type synonyms for their dictionaries, and type instances become dictionary declarations.
65−-- Additional values are generated to access individual members of a dictionary, with the appropriate type.
66−--
67−-- E.g. the following
68−--
69−-- module Test where
70−--
71−-- class Foo a where
72−-- foo :: a -> a
73−--
74−-- instance fooString :: Foo String where
75−-- foo s = s ++ s
76−--
77−-- instance fooArray :: (Foo a) => Foo [a] where
78−-- foo = map foo
79−--
80−-- {- Superclasses -}
81−--
82−-- class (Foo a) <= Sub a where
83−-- sub :: a
84−--
85−-- instance subString :: Sub String where
86−-- sub = ""
87−--
88−-- becomes:
89−--
90−-- <TypeClassDeclaration Foo ...>
91−--
92−-- type Foo a = { foo :: a -> a }
93−--
94−-- -- this following type is marked as not needing to be checked so a new Abs
95−-- -- is not introduced around the definition in type checking, but when
96−-- -- called the dictionary value is still passed in for the `dict` argument
97−-- foo :: forall a. (Foo a) => a -> a
98−-- foo dict = dict.foo
99−--
100−-- fooString :: {} -> Foo String
101−-- fooString _ = <TypeClassDictionaryConstructorApp Foo { foo: \s -> s ++ s }>
102−--
103−-- fooArray :: forall a. (Foo a) => Foo [a]
104−-- fooArray = <TypeClassDictionaryConstructorApp Foo { foo: map foo }>
105−--
106−-- {- Superclasses -}
107−--
108−-- <TypeClassDeclaration Sub ...>
109−--
110−-- type Sub a = { sub :: a
111−-- , "__superclass_Foo_0" :: {} -> Foo a
112−-- }
113−--
114−-- -- As with `foo` above, this type is unchecked at the declaration
115−-- sub :: forall a. (Sub a) => a
116−-- sub dict = dict.sub
117−--
118−-- subString :: {} -> Sub String
119−-- subString _ = { sub: "",
120−-- , "__superclass_Foo_0": \_ -> <SuperClassDictionary Foo String>
121−-- }
122−--
123−-- and finally as the generated javascript:
124−--
125−-- function Foo(foo) {
126−-- this.foo = foo;
127−-- };
128−--
129−-- var foo = function (dict) {
130−-- return dict.foo;
131−-- };
132−--
133−-- var fooString = function (_) {
134−-- return new Foo(function (s) {
135−-- return s + s;
136−-- });
137−-- };
138−--
139−-- var fooArray = function (__dict_Foo_15) {
140−-- return new Foo(map(foo(__dict_Foo_15)));
141−-- };
142−--
143−-- function Sub(__superclass_Foo_0, sub) {
144−-- this["__superclass_Foo_0"] = __superclass_Foo_0;
145−-- this.sub = sub;
146−-- };
147−--
148−-- var sub = function (dict) {
149−-- return dict.sub;
150−-- };
151−--
152−-- var subString = function (_) {
153−-- return new Sub(fooString, "");
154−-- };
155−-}
156−desugarDecl :: ModuleName -> [DeclarationRef] -> Declaration -> Desugar (Maybe DeclarationRef, [Declaration])
157−desugarDecl mn exps = go
158− where
159− go d@(TypeClassDeclaration name args implies members) = do
160− modify (M.insert (mn, name) d)
161− return (Nothing, d : typeClassDictionaryDeclaration name args implies members : map (typeClassMemberToDictionaryAccessor mn name args) members)
162− go d@(ExternInstanceDeclaration name _ className tys) = return (expRef name className tys, [d])
163− go d@(TypeInstanceDeclaration name deps className tys members) = do
164− desugared <- lift $ desugarCases members
165− dictDecl <- typeInstanceDictionaryDeclaration name mn deps className tys desugared
166− return (expRef name className tys, [d, dictDecl])
167− go (PositionedDeclaration pos com d) = do
168− (dr, ds) <- rethrowWithPosition pos $ desugarDecl mn exps d
169− return (dr, map (PositionedDeclaration pos com) ds)
170− go other = return (Nothing, [other])
171−
172− expRef :: Ident -> Qualified ProperName -> [Type] -> Maybe DeclarationRef
173− expRef name className tys
174− | isExportedClass className && all isExportedType (getConstructors `concatMap` tys) = Just $ TypeInstanceRef name
175− | otherwise = Nothing
176−
177− isExportedClass :: Qualified ProperName -> Bool
178− isExportedClass = isExported (elem . TypeClassRef)
179−
180− isExportedType :: Qualified ProperName -> Bool
181− isExportedType = isExported $ \pn -> isJust . find (matchesTypeRef pn)
182−
183− isExported :: (ProperName -> [DeclarationRef] -> Bool) -> Qualified ProperName -> Bool
184− isExported test (Qualified (Just mn') pn) = mn /= mn' || test pn exps
185− isExported _ _ = error "Names should have been qualified in name desugaring"
186−
187− matchesTypeRef :: ProperName -> DeclarationRef -> Bool
188− matchesTypeRef pn (TypeRef pn' _) = pn == pn'
189− matchesTypeRef _ _ = False
190−
191− getConstructors :: Type -> [Qualified ProperName]
192− getConstructors = everythingOnTypes (++) getConstructor
193−
194− getConstructor :: Type -> [Qualified ProperName]
195− getConstructor (TypeConstructor tcname) = [tcname]
196− getConstructor _ = []
197−
198−memberToNameAndType :: Declaration -> (Ident, Type)
199−memberToNameAndType (TypeDeclaration ident ty) = (ident, ty)
200−memberToNameAndType (PositionedDeclaration _ _ d) = memberToNameAndType d
201−memberToNameAndType _ = error "Invalid declaration in type class definition"
202−
203−typeClassDictionaryDeclaration :: ProperName -> [(String, Maybe Kind)] -> [Constraint] -> [Declaration] -> Declaration
204−typeClassDictionaryDeclaration name args implies members =
205− let superclassTypes = superClassDictionaryNames implies `zip`
206− [ function unit (foldl TypeApp (TypeConstructor superclass) tyArgs)
207− | (superclass, tyArgs) <- implies
208− ]
209− members' = map (first runIdent . memberToNameAndType) members
210− mtys = members' ++ superclassTypes
211− in TypeSynonymDeclaration name args (TypeApp tyObject $ rowFromList (mtys, REmpty))
212−
213−typeClassMemberToDictionaryAccessor :: ModuleName -> ProperName -> [(String, Maybe Kind)] -> Declaration -> Declaration
214−typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration ident ty) =
215− let className = Qualified (Just mn) name
216− in ValueDeclaration ident TypeClassAccessorImport [] $ Right $
217− TypedValue False (TypeClassDictionaryAccessor className ident) $
218− moveQuantifiersToFront (quantify (ConstrainedType [(className, map (TypeVar . fst) args)] ty))
219−typeClassMemberToDictionaryAccessor mn name args (PositionedDeclaration pos com d) =
220− PositionedDeclaration pos com $ typeClassMemberToDictionaryAccessor mn name args d
221−typeClassMemberToDictionaryAccessor _ _ _ _ = error "Invalid declaration in type class definition"
222−
223−unit :: Type
224−unit = TypeApp tyObject REmpty
225−
226−typeInstanceDictionaryDeclaration :: Ident -> ModuleName -> [Constraint] -> Qualified ProperName -> [Type] -> [Declaration] -> Desugar Declaration
227−typeInstanceDictionaryDeclaration name mn deps className tys decls =
228− rethrow (strMsg ("Error in type class instance " ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys) ++ ":") <>) $ do
229− m <- get
230−
231− -- Lookup the type arguments and member types for the type class
232− (TypeClassDeclaration _ args implies tyDecls) <- lift . lift $
233− maybe (Left $ mkErrorStack ("Type class " ++ show className ++ " is undefined") Nothing) Right $
234− M.lookup (qualify mn className) m
235−
236− case mapMaybe declName tyDecls \\ mapMaybe declName decls of
237− x : _ -> throwError $ mkErrorStack ("Member '" ++ show x ++ "' has not been implemented") Nothing
238− [] -> do
239−
240− let instanceTys = map memberToNameAndType tyDecls
241−
242− -- Replace the type arguments with the appropriate types in the member types
243− let memberTypes = map (second (replaceAllTypeVars (zip (map fst args) tys))) instanceTys
244−
245− -- Create values for the type instance members
246− members <- zip (map typeClassMemberName decls) <$> mapM (memberToValue memberTypes) decls
247−
248− -- Create the type of the dictionary
249− -- The type is an object type, but depending on type instance dependencies, may be constrained.
250− -- The dictionary itself is an object literal.
251− let superclasses = superClassDictionaryNames implies `zip`
252− [ Abs (Left (Ident C.__unused)) (SuperClassDictionary superclass tyArgs)
253− | (superclass, suTyArgs) <- implies
254− , let tyArgs = map (replaceAllTypeVars (zip (map fst args) tys)) suTyArgs
255− ]
256−
257− let props = ObjectLiteral (members ++ superclasses)
258− dictTy = foldl TypeApp (TypeConstructor className) tys
259− constrainedTy = quantify (if null deps then dictTy else ConstrainedType deps dictTy)
260− dict = TypeClassDictionaryConstructorApp className props
261− result = ValueDeclaration name TypeInstanceDictionaryValue [] (Right (TypedValue True dict constrainedTy))
262− return result
263−
264− where
265−
266− declName :: Declaration -> Maybe Ident
267− declName (PositionedDeclaration _ _ d) = declName d
268− declName (ValueDeclaration ident _ _ _) = Just ident
269− declName (TypeDeclaration ident _) = Just ident
270− declName _ = Nothing
271−
272− memberToValue :: [(Ident, Type)] -> Declaration -> Desugar Expr
273− memberToValue tys' (ValueDeclaration ident _ [] (Right val)) = do
274− _ <- lift . lift . maybe (Left $ mkErrorStack ("Type class does not define member '" ++ show ident ++ "'") Nothing) Right $ lookup ident tys'
275− return val
276− memberToValue tys' (PositionedDeclaration pos com d) = rethrowWithPosition pos $ do
277− val <- memberToValue tys' d
278− return (PositionedValue pos com val)
279− memberToValue _ _ = error "Invalid declaration in type instance definition"
280−
281−typeClassMemberName :: Declaration -> String
282−typeClassMemberName (TypeDeclaration ident _) = runIdent ident
283−typeClassMemberName (ValueDeclaration ident _ _ _) = runIdent ident
284−typeClassMemberName (PositionedDeclaration _ _ d) = typeClassMemberName d
285−typeClassMemberName d = error $ "Invalid declaration in type class definition: " ++ show d
286−
287−superClassDictionaryNames :: [Constraint] -> [String]
288−superClassDictionaryNames supers =
289− [ C.__superclass_ ++ show pn ++ "_" ++ show (index :: Integer)
290− | (index, (pn, _)) <- zip [0..] supers
291− ]
src/Language/PureScript/Sugar/TypeDeclarations.hsdeleted−69
@@ -1,69 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.Sugar.TypeDeclarations
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 implements the desugaring pass which replaces top-level type declarations with
13−-- type annotations on the corresponding expression.
14−--
15−-----------------------------------------------------------------------------
16−
17−module Language.PureScript.Sugar.TypeDeclarations (
18− desugarTypeDeclarations,
19− desugarTypeDeclarationsModule
20−) where
21−
22−import Data.Monoid ((<>))
23−
24−import Control.Applicative
25−import Control.Monad.Error.Class
26−import Control.Monad (forM)
27−
28−import Language.PureScript.AST
29−import Language.PureScript.Names
30−import Language.PureScript.Environment
31−import Language.PureScript.Errors
32−import Language.PureScript.Traversals
33−
34−-- |
35−-- Replace all top level type declarations in a module with type annotations
36−--
37−desugarTypeDeclarationsModule :: [Module] -> Either ErrorStack [Module]
38−desugarTypeDeclarationsModule ms = forM ms $ \(Module name ds exps) ->
39− rethrow (strMsg ("Error in module " ++ show name) <>) $
40− Module name <$> desugarTypeDeclarations ds <*> pure exps
41−
42−-- |
43−-- Replace all top level type declarations with type annotations
44−--
45−desugarTypeDeclarations :: [Declaration] -> Either ErrorStack [Declaration]
46−desugarTypeDeclarations (PositionedDeclaration pos com d : ds) = do
47− (d' : ds') <- rethrowWithPosition pos $ desugarTypeDeclarations (d : ds)
48− return (PositionedDeclaration pos com d' : ds')
49−desugarTypeDeclarations (TypeDeclaration name ty : d : rest) = do
50− (_, nameKind, val) <- fromValueDeclaration d
51− desugarTypeDeclarations (ValueDeclaration name nameKind [] (Right (TypedValue True val ty)) : rest)
52− where
53− fromValueDeclaration :: Declaration -> Either ErrorStack (Ident, NameKind, Expr)
54− fromValueDeclaration (ValueDeclaration name' nameKind [] (Right val)) | name == name' = return (name', nameKind, val)
55− fromValueDeclaration (PositionedDeclaration pos com d') = do
56− (ident, nameKind, val) <- rethrowWithPosition pos $ fromValueDeclaration d'
57− return (ident, nameKind, PositionedValue pos com val)
58− fromValueDeclaration _ = throwError $ mkErrorStack ("Orphan type declaration for " ++ show name) Nothing
59−desugarTypeDeclarations (TypeDeclaration name _ : []) = throwError $ mkErrorStack ("Orphan type declaration for " ++ show name) Nothing
60−desugarTypeDeclarations (ValueDeclaration name nameKind bs val : rest) = do
61− let (_, f, _) = everywhereOnValuesTopDownM return go return
62− f' (Left gs) = Left <$> mapM (pairM return f) gs
63− f' (Right v) = Right <$> f v
64− (:) <$> (ValueDeclaration name nameKind bs <$> f' val) <*> desugarTypeDeclarations rest
65− where
66− go (Let ds val') = Let <$> desugarTypeDeclarations ds <*> pure val'
67− go other = return other
68−desugarTypeDeclarations (d:ds) = (:) d <$> desugarTypeDeclarations ds
69−desugarTypeDeclarations [] = return []
src/Language/PureScript/Supply.hsdeleted−56
@@ -1,56 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.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−{-# LANGUAGE FlexibleInstances #-}
18−{-# LANGUAGE MultiParamTypeClasses #-}
19−{-# LANGUAGE UndecidableInstances #-}
20−
21−module Language.PureScript.Supply where
22−
23−import Data.Functor.Identity
24−
25−import Control.Applicative
26−import Control.Monad.State
27−import Control.Monad.Error.Class
28−
29−newtype SupplyT m a = SupplyT { unSupplyT :: StateT Integer m a } deriving (Functor, Applicative, Monad, MonadTrans)
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
44−
45−fresh :: (Monad m) => SupplyT m Integer
46−fresh = SupplyT $ do
47− n <- get
48− put (n + 1)
49− return n
50−
51−freshName :: (Functor m, Monad m) => SupplyT m String
52−freshName = ('_' :) . show <$> fresh
53−
54−instance (MonadError e m) => MonadError e (SupplyT m) where
55− throwError = SupplyT . throwError
56− catchError e f = SupplyT $ catchError (unSupplyT e) (unSupplyT . f)
src/Language/PureScript/Traversals.hsdeleted−41
@@ -1,41 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.Traversals
4−-- Copyright : (c) 2014 Phil Freeman
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- | Common functions for implementing generic traversals
12−--
13−-----------------------------------------------------------------------------
14−
15−module Language.PureScript.Traversals where
16−
17−import Control.Applicative
18−
19−fstM :: (Functor f) => (a -> f c) -> (a, b) -> f (c, b)
20−fstM f (a, b) = flip (,) b <$> f a
21−
22−sndM :: (Functor f) => (b -> f c) -> (a, b) -> f (a, c)
23−sndM f (a, b) = (,) a <$> f b
24−
25−thirdM :: (Functor f) => (c -> f d) -> (a, b, c) -> f (a, b, d)
26−thirdM f (a, b, c) = (,,) a b <$> f c
27−
28−pairM :: (Applicative f) => (a -> f c) -> (b -> f d) -> (a, b) -> f (c, d)
29−pairM f g (a, b) = (,) <$> f a <*> g b
30−
31−maybeM :: (Applicative f) => (a -> f b) -> Maybe a -> f (Maybe b)
32−maybeM _ Nothing = pure Nothing
33−maybeM f (Just a) = Just <$> f a
34−
35−eitherM :: (Applicative f) => (a -> f c) -> (b -> f d) -> Either a b -> f (Either c d)
36−eitherM f _ (Left a) = Left <$> f a
37−eitherM _ g (Right b) = Right <$> g b
38−
39−defS :: (Monad m) => st -> val -> m (st, val)
40−defS s val = return (s, val)
41−
src/Language/PureScript/TypeChecker.hsdeleted−356
@@ -1,356 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.TypeChecker
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 top-level type checker, which checks all declarations in a module.
13−--
14−-----------------------------------------------------------------------------
15−
16−{-# LANGUAGE FlexibleInstances #-}
17−
18−module Language.PureScript.TypeChecker (
19− module T,
20− typeCheckModule
21−) where
22−
23−import Language.PureScript.TypeChecker.Monad as T
24−import Language.PureScript.TypeChecker.Kinds as T
25−import Language.PureScript.TypeChecker.Types as T
26−import Language.PureScript.TypeChecker.Synonyms as T
27−
28−import Data.Maybe
29−import Data.List (nub, (\\), find, intercalate)
30−import Data.Monoid ((<>))
31−import Data.Foldable (for_)
32−import qualified Data.Map as M
33−
34−import Control.Monad.State
35−import Control.Monad.Error
36−
37−import Language.PureScript.Types
38−import Language.PureScript.Names
39−import Language.PureScript.Kinds
40−import Language.PureScript.AST
41−import Language.PureScript.TypeClassDictionaries
42−import Language.PureScript.Environment
43−import Language.PureScript.Errors
44−
45−addDataType :: ModuleName -> DataDeclType -> ProperName -> [(String, Maybe Kind)] -> [(ProperName, [Type])] -> Kind -> Check ()
46−addDataType moduleName dtype name args dctors ctorKind = do
47− env <- getEnv
48− putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (ctorKind, DataType args dctors) (types env) }
49− forM_ dctors $ \(dctor, tys) ->
50− rethrow (strMsg ("Error in data constructor " ++ show dctor) <>) $
51− addDataConstructor moduleName dtype name (map fst args) dctor tys
52−
53−addDataConstructor :: ModuleName -> DataDeclType -> ProperName -> [String] -> ProperName -> [Type] -> Check ()
54−addDataConstructor moduleName dtype name args dctor tys = do
55− env <- getEnv
56− mapM_ checkTypeSynonyms tys
57− let retTy = foldl TypeApp (TypeConstructor (Qualified (Just moduleName) name)) (map TypeVar args)
58− let dctorTy = foldr function retTy tys
59− let polyType = mkForAll args dctorTy
60− let fields = [Ident ("value" ++ show n) | n <- [0..(length tys - 1)]]
61− putEnv $ env { dataConstructors = M.insert (Qualified (Just moduleName) dctor) (dtype, name, polyType, fields) (dataConstructors env) }
62−
63−addTypeSynonym :: ModuleName -> ProperName -> [(String, Maybe Kind)] -> Type -> Kind -> Check ()
64−addTypeSynonym moduleName name args ty kind = do
65− env <- getEnv
66− checkTypeSynonyms ty
67− putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (kind, TypeSynonym) (types env)
68− , typeSynonyms = M.insert (Qualified (Just moduleName) name) (args, ty) (typeSynonyms env) }
69−
70−valueIsNotDefined :: ModuleName -> Ident -> Check ()
71−valueIsNotDefined moduleName name = do
72− env <- getEnv
73− case M.lookup (moduleName, name) (names env) of
74− Just _ -> throwError . strMsg $ show name ++ " is already defined"
75− Nothing -> return ()
76−
77−addValue :: ModuleName -> Ident -> Type -> NameKind -> Check ()
78−addValue moduleName name ty nameKind = do
79− env <- getEnv
80− putEnv (env { names = M.insert (moduleName, name) (ty, nameKind, Defined) (names env) })
81−
82−addTypeClass :: ModuleName -> ProperName -> [(String, Maybe Kind)] -> [Constraint] -> [Declaration] -> Check ()
83−addTypeClass moduleName pn args implies ds =
84− let members = map toPair ds in
85− modify $ \st -> st { checkEnv = (checkEnv st) { typeClasses = M.insert (Qualified (Just moduleName) pn) (args, members, implies) (typeClasses . checkEnv $ st) } }
86− where
87− toPair (TypeDeclaration ident ty) = (ident, ty)
88− toPair (PositionedDeclaration _ _ d) = toPair d
89− toPair _ = error "Invalid declaration in TypeClassDeclaration"
90−
91−addTypeClassDictionaries :: [TypeClassDictionaryInScope] -> Check ()
92−addTypeClassDictionaries entries =
93− let mentries = M.fromList [ ((canonicalizeDictionary entry, mn), entry) | entry@TypeClassDictionaryInScope{ tcdName = Qualified mn _ } <- entries ]
94− in modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = (typeClassDictionaries . checkEnv $ st) `M.union` mentries } }
95−
96−checkDuplicateTypeArguments :: [String] -> Check ()
97−checkDuplicateTypeArguments args = for_ firstDup $ \dup ->
98− throwError . strMsg $ "Duplicate type argument '" ++ dup ++ "'"
99− where
100− firstDup :: Maybe String
101− firstDup = listToMaybe $ args \\ nub args
102−
103−checkTypeClassInstance :: ModuleName -> Type -> Check ()
104−checkTypeClassInstance _ (TypeVar _) = return ()
105−checkTypeClassInstance _ (TypeConstructor ctor) = do
106− env <- getEnv
107− when (ctor `M.member` typeSynonyms env) . throwError . strMsg $ "Type synonym instances are disallowed"
108− return ()
109−checkTypeClassInstance m (TypeApp t1 t2) = checkTypeClassInstance m t1 >> checkTypeClassInstance m t2
110−checkTypeClassInstance _ ty = throwError $ mkErrorStack "Type class instance head is invalid." (Just (TypeError ty))
111−
112−-- |
113−-- Check that type synonyms are fully-applied in a type
114−--
115−checkTypeSynonyms :: Type -> Check ()
116−checkTypeSynonyms = void . replaceAllTypeSynonyms
117−
118−-- |
119−-- Type check all declarations in a module
120−--
121−-- At this point, many declarations will have been desugared, but it is still necessary to
122−--
123−-- * Kind-check all types and add them to the @Environment@
124−--
125−-- * Type-check all values and add them to the @Environment@
126−--
127−-- * Bring type class instances into scope
128−--
129−-- * Process module imports
130−--
131−typeCheckAll :: Maybe ModuleName -> ModuleName -> [DeclarationRef] -> [Declaration] -> Check [Declaration]
132−typeCheckAll mainModuleName moduleName exps = go
133− where
134− go :: [Declaration] -> Check [Declaration]
135− go [] = return []
136− go (DataDeclaration dtype name args dctors : rest) = do
137− rethrow (strMsg ("Error in type constructor " ++ show name) <>) $ do
138− when (dtype == Newtype) $ checkNewtype dctors
139− checkDuplicateTypeArguments $ map fst args
140− ctorKind <- kindsOf True moduleName name args (concatMap snd dctors)
141− let args' = args `withKinds` ctorKind
142− addDataType moduleName dtype name args' dctors ctorKind
143− ds <- go rest
144− return $ DataDeclaration dtype name args dctors : ds
145− where
146− checkNewtype :: [(ProperName, [Type])] -> Check ()
147− checkNewtype [(_, [_])] = return ()
148− checkNewtype [(_, _)] = throwError . strMsg $ "newtypes constructors must have a single argument"
149− checkNewtype _ = throwError . strMsg $ "newtypes must have a single constructor"
150− go (d@(DataBindingGroupDeclaration tys) : rest) = do
151− rethrow (strMsg "Error in data binding group" <>) $ do
152− let syns = mapMaybe toTypeSynonym tys
153− let dataDecls = mapMaybe toDataDecl tys
154− (syn_ks, data_ks) <- kindsOfAll moduleName syns (map (\(_, name, args, dctors) -> (name, args, concatMap snd dctors)) dataDecls)
155− forM_ (zip dataDecls data_ks) $ \((dtype, name, args, dctors), ctorKind) -> do
156− checkDuplicateTypeArguments $ map fst args
157− let args' = args `withKinds` ctorKind
158− addDataType moduleName dtype name args' dctors ctorKind
159− forM_ (zip syns syn_ks) $ \((name, args, ty), kind) -> do
160− checkDuplicateTypeArguments $ map fst args
161− let args' = args `withKinds` kind
162− addTypeSynonym moduleName name args' ty kind
163− ds <- go rest
164− return $ d : ds
165− where
166− toTypeSynonym (TypeSynonymDeclaration nm args ty) = Just (nm, args, ty)
167− toTypeSynonym (PositionedDeclaration _ _ d') = toTypeSynonym d'
168− toTypeSynonym _ = Nothing
169− toDataDecl (DataDeclaration dtype nm args dctors) = Just (dtype, nm, args, dctors)
170− toDataDecl (PositionedDeclaration _ _ d') = toDataDecl d'
171− toDataDecl _ = Nothing
172− go (TypeSynonymDeclaration name args ty : rest) = do
173− rethrow (strMsg ("Error in type synonym " ++ show name) <>) $ do
174− checkDuplicateTypeArguments $ map fst args
175− kind <- kindsOf False moduleName name args [ty]
176− let args' = args `withKinds` kind
177− addTypeSynonym moduleName name args' ty kind
178− ds <- go rest
179− return $ TypeSynonymDeclaration name args ty : ds
180− go (TypeDeclaration _ _ : _) = error "Type declarations should have been removed"
181− go (ValueDeclaration name nameKind [] (Right val) : rest) = do
182− d <- rethrow (strMsg ("Error in declaration " ++ show name) <>) $ do
183− valueIsNotDefined moduleName name
184− [(_, (val', ty))] <- typesOf mainModuleName moduleName [(name, val)]
185− addValue moduleName name ty nameKind
186− return $ ValueDeclaration name nameKind [] $ Right val'
187− ds <- go rest
188− return $ d : ds
189− go (ValueDeclaration{} : _) = error "Binders were not desugared"
190− go (BindingGroupDeclaration vals : rest) = do
191− d <- rethrow (strMsg ("Error in binding group " ++ show (map (\(ident, _, _) -> ident) vals)) <>) $ do
192− forM_ (map (\(ident, _, _) -> ident) vals) $ \name ->
193− valueIsNotDefined moduleName name
194− tys <- typesOf mainModuleName moduleName $ map (\(ident, _, ty) -> (ident, ty)) vals
195− vals' <- forM [ (name, val, nameKind, ty)
196− | (name, nameKind, _) <- vals
197− , (name', (val, ty)) <- tys
198− , name == name'
199− ] $ \(name, val, nameKind, ty) -> do
200− addValue moduleName name ty nameKind
201− return (name, nameKind, val)
202− return $ BindingGroupDeclaration vals'
203− ds <- go rest
204− return $ d : ds
205− go (d@(ExternDataDeclaration name kind) : rest) = do
206− env <- getEnv
207− putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (kind, ExternData) (types env) }
208− ds <- go rest
209− return $ d : ds
210− go (d@(ExternDeclaration importTy name _ ty) : rest) = do
211− rethrow (strMsg ("Error in foreign import declaration " ++ show name) <>) $ do
212− env <- getEnv
213− kind <- kindOf moduleName ty
214− guardWith (strMsg "Expected kind *") $ kind == Star
215− case M.lookup (moduleName, name) (names env) of
216− Just _ -> throwError . strMsg $ show name ++ " is already defined"
217− Nothing -> putEnv (env { names = M.insert (moduleName, name) (ty, Extern importTy, Defined) (names env) })
218− ds <- go rest
219− return $ d : ds
220− go (d@(FixityDeclaration _ name) : rest) = do
221− ds <- go rest
222− env <- getEnv
223− guardWith (strMsg ("Fixity declaration with no binding: " ++ name)) $ M.member (moduleName, Op name) $ names env
224− return $ d : ds
225− go (d@(ImportDeclaration importedModule _ _) : rest) = do
226− tcds <- getTypeClassDictionaries
227− let instances = filter (\tcd -> let Qualified (Just mn) _ = tcdName tcd in importedModule == mn) tcds
228− addTypeClassDictionaries [ tcd { tcdName = Qualified (Just moduleName) ident, tcdType = TCDAlias (canonicalizeDictionary tcd) }
229− | tcd <- instances
230− , tcdExported tcd
231− , let (Qualified _ ident) = tcdName tcd
232− ]
233− ds <- go rest
234− return $ d : ds
235− go (d@(TypeClassDeclaration pn args implies tys) : rest) = do
236− addTypeClass moduleName pn args implies tys
237− ds <- go rest
238− return $ d : ds
239− go (d@(TypeInstanceDeclaration dictName deps className tys _) : rest) = do
240− goInstance d dictName deps className tys rest
241− go (d@(ExternInstanceDeclaration dictName deps className tys) : rest) = do
242− goInstance d dictName deps className tys rest
243− go (PositionedDeclaration pos com d : rest) =
244− rethrowWithPosition pos $ do
245− (d' : rest') <- go (d : rest)
246− return (PositionedDeclaration pos com d' : rest')
247− goInstance :: Declaration -> Ident -> [Constraint] -> Qualified ProperName -> [Type] -> [Declaration] -> Check [Declaration]
248− goInstance d dictName deps className tys rest = do
249− mapM_ (checkTypeClassInstance moduleName) tys
250− forM_ deps $ mapM_ (checkTypeClassInstance moduleName) . snd
251− addTypeClassDictionaries [TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) className tys (Just deps) TCDRegular isInstanceExported]
252− ds <- go rest
253− return $ d : ds
254−
255− where
256−
257− isInstanceExported :: Bool
258− isInstanceExported = any exportsInstance exps
259−
260− exportsInstance :: DeclarationRef -> Bool
261− exportsInstance (TypeInstanceRef name) | name == dictName = True
262− exportsInstance (PositionedDeclarationRef _ _ r) = exportsInstance r
263− exportsInstance _ = False
264−
265− -- |
266− -- This function adds the argument kinds for a type constructor so that they may appear in the externs file,
267− -- extracted from the kind of the type constructor itself.
268− --
269− withKinds :: [(String, Maybe Kind)] -> Kind -> [(String, Maybe Kind)]
270− withKinds [] _ = []
271− withKinds (s@(_, Just _ ):ss) (FunKind _ k) = s : withKinds ss k
272− withKinds ( (s, Nothing):ss) (FunKind k1 k2) = (s, Just k1) : withKinds ss k2
273− withKinds _ _ = error "Invalid arguments to peelKinds"
274−
275−-- |
276−-- Type check an entire module and ensure all types and classes defined within the module that are
277−-- required by exported members are also exported.
278−--
279−typeCheckModule :: Maybe ModuleName -> Module -> Check Module
280−typeCheckModule _ (Module _ _ Nothing) = error "exports should have been elaborated"
281−typeCheckModule mainModuleName (Module mn decls (Just exps)) = do
282− modify (\s -> s { checkCurrentModule = Just mn })
283− decls' <- typeCheckAll mainModuleName mn exps decls
284− forM_ exps $ \e -> do
285− checkTypesAreExported e
286− checkClassMembersAreExported e
287− checkClassesAreExported e
288− return $ Module mn decls' (Just exps)
289− where
290−
291− checkMemberExport :: (Show a) => String -> (Type -> [a]) -> (a -> Bool) -> DeclarationRef -> Check ()
292− checkMemberExport thing extract test (ValueRef name) = do
293− ty <- lookupVariable mn (Qualified (Just mn) name)
294− case find test (extract ty) of
295− Just hiddenType -> throwError . strMsg $
296− "Error in module '" ++ show mn ++ "':\n\
297− \Exporting declaration '" ++ show name ++ "' requires " ++ thing ++ " '" ++ show hiddenType ++ "' to be exported as well"
298− Nothing -> return ()
299− checkMemberExport _ _ _ _ = return ()
300−
301− -- Check that all the type constructors defined in the current module that appear in member types
302− -- have also been exported from the module
303− checkTypesAreExported :: DeclarationRef -> Check ()
304− checkTypesAreExported = checkMemberExport "type" findTcons isTconHidden
305− where
306− findTcons :: Type -> [ProperName]
307− findTcons = everythingOnTypes (++) go
308− where
309− go (TypeConstructor (Qualified (Just mn') name)) | mn' == mn = [name]
310− go _ = []
311− isTconHidden :: ProperName -> Bool
312− isTconHidden tyName = all go exps
313− where
314− go (TypeRef tyName' _) = tyName' /= tyName
315− go _ = True
316−
317− -- Check that all the classes defined in the current module that appear in member types have also
318− -- been exported from the module
319− checkClassesAreExported :: DeclarationRef -> Check ()
320− checkClassesAreExported = checkMemberExport "class" findClasses isClassHidden
321− where
322− findClasses :: Type -> [ProperName]
323− findClasses = everythingOnTypes (++) go
324− where
325− go (ConstrainedType cs _) = mapMaybe (extractCurrentModuleClass . fst) cs
326− go _ = []
327− extractCurrentModuleClass :: Qualified ProperName -> Maybe ProperName
328− extractCurrentModuleClass (Qualified (Just mn') name) | mn == mn' = Just name
329− extractCurrentModuleClass _ = Nothing
330− isClassHidden :: ProperName -> Bool
331− isClassHidden clsName = all go exps
332− where
333− go (TypeClassRef clsName') = clsName' /= clsName
334− go _ = True
335−
336− checkClassMembersAreExported :: DeclarationRef -> Check ()
337− checkClassMembersAreExported (TypeClassRef name) = do
338− let members = ValueRef `map` head (mapMaybe findClassMembers decls)
339− let missingMembers = members \\ exps
340− unless (null missingMembers) $
341− throwError . strMsg $
342− "Error in module '" ++ show mn ++ "':\n\
343− \Class '" ++ show name ++ "' is exported but is missing member exports for '" ++ intercalate "', '" (map (show . runValueRef) missingMembers) ++ "'"
344− where
345− runValueRef :: DeclarationRef -> Ident
346− runValueRef (ValueRef refName) = refName
347− runValueRef _ = error "non-ValueRef passed to runValueRef"
348− findClassMembers :: Declaration -> Maybe [Ident]
349− findClassMembers (TypeClassDeclaration name' _ _ ds) | name == name' = Just $ map extractMemberName ds
350− findClassMembers (PositionedDeclaration _ _ d) = findClassMembers d
351− findClassMembers _ = Nothing
352− extractMemberName :: Declaration -> Ident
353− extractMemberName (PositionedDeclaration _ _ d) = extractMemberName d
354− extractMemberName (TypeDeclaration memberName _) = memberName
355− extractMemberName _ = error "Unexpected declaration in typeclass member list"
356− checkClassMembersAreExported _ = return ()
src/Language/PureScript/TypeChecker/Entailment.hsdeleted−237
@@ -1,237 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.TypeChecker.Entailment
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−-- Type class entailment
13−--
14−-----------------------------------------------------------------------------
15−
16−module Language.PureScript.TypeChecker.Entailment (
17− entails
18−) where
19−
20−import Data.Function (on)
21−import Data.List
22−import Data.Maybe (maybeToList)
23−import Data.Foldable (foldMap)
24−import qualified Data.Map as M
25−
26−import Control.Applicative
27−import Control.Arrow (Arrow(..))
28−import Control.Monad.Error
29−
30−import Language.PureScript.AST
31−import Language.PureScript.Environment
32−import Language.PureScript.Names
33−import Language.PureScript.Pretty
34−import Language.PureScript.TypeChecker.Monad
35−import Language.PureScript.TypeChecker.Synonyms
36−import Language.PureScript.TypeChecker.Unify
37−import Language.PureScript.TypeClassDictionaries
38−import Language.PureScript.Types
39−import qualified Language.PureScript.Constants as C
40−
41−-- |
42−-- A simplified representation of expressions which are used to represent type
43−-- class dictionaries at runtime, which can be compared for equality
44−--
45−data DictionaryValue
46− -- |
47− -- A dictionary which is brought into scope by a local constraint
48− --
49− = LocalDictionaryValue (Qualified Ident)
50− -- |
51− -- A dictionary which is brought into scope by an instance declaration
52− --
53− | GlobalDictionaryValue (Qualified Ident)
54− -- |
55− -- A dictionary which depends on other dictionaries
56− --
57− | DependentDictionaryValue (Qualified Ident) [DictionaryValue]
58− -- |
59− -- A subclass dictionary
60− --
61− | SubclassDictionaryValue DictionaryValue (Qualified ProperName) Integer
62− deriving (Show, Ord, Eq)
63−
64−-- |
65−-- Check that the current set of type class dictionaries entail the specified type class goal, and, if so,
66−-- return a type class dictionary reference.
67−--
68−entails :: Environment -> ModuleName -> [TypeClassDictionaryInScope] -> Constraint -> Bool -> Check Expr
69−entails env moduleName context = solve (sortedNubBy canonicalizeDictionary (filter filterModule context))
70− where
71− sortedNubBy :: (Ord k) => (v -> k) -> [v] -> [v]
72− sortedNubBy f vs = M.elems (M.fromList (map (f &&& id) vs))
73−
74− -- Filter out type dictionaries which are in scope in the current module
75− filterModule :: TypeClassDictionaryInScope -> Bool
76− filterModule (TypeClassDictionaryInScope { tcdName = Qualified (Just mn) _ }) | mn == moduleName = True
77− filterModule (TypeClassDictionaryInScope { tcdName = Qualified Nothing _ }) = True
78− filterModule _ = False
79−
80− solve context' (className, tys) trySuperclasses =
81− checkOverlaps $ go trySuperclasses className tys
82− where
83− go trySuperclasses' className' tys' =
84− -- Look for regular type instances
85− [ mkDictionary (canonicalizeDictionary tcd) args
86− | tcd <- context'
87− -- Make sure the type class name matches the one we are trying to satisfy
88− , className' == tcdClassName tcd
89− -- Make sure the type unifies with the type in the type instance definition
90− , subst <- maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName env) tys' (tcdInstanceTypes tcd)
91− -- Solve any necessary subgoals
92− , args <- solveSubgoals subst (tcdDependencies tcd) ] ++
93−
94− -- Look for implementations via superclasses
95− [ SubclassDictionaryValue suDict superclass index
96− | trySuperclasses'
97− , (subclassName, (args, _, implies)) <- M.toList (typeClasses env)
98− -- Try each superclass
99− , (index, (superclass, suTyArgs)) <- zip [0..] implies
100− -- Make sure the type class name matches the superclass name
101− , className' == superclass
102− -- Make sure the types unify with the types in the superclass implication
103− , subst <- maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName env) tys' suTyArgs
104− -- Finally, satisfy the subclass constraint
105− , args' <- maybeToList $ mapM ((`lookup` subst) . fst) args
106− , suDict <- go True subclassName args' ]
107−
108− -- Create dictionaries for subgoals which still need to be solved by calling go recursively
109− -- E.g. the goal (Show a, Show b) => Show (Either a b) can be satisfied if the current type
110− -- unifies with Either a b, and we can satisfy the subgoals Show a and Show b recursively.
111− solveSubgoals :: [(String, Type)] -> Maybe [Constraint] -> [Maybe [DictionaryValue]]
112− solveSubgoals _ Nothing = return Nothing
113− solveSubgoals subst (Just subgoals) = do
114− dict <- mapM (uncurry (go True) . second (map (replaceAllTypeVars subst))) subgoals
115− return $ Just dict
116− -- Make a dictionary from subgoal dictionaries by applying the correct function
117− mkDictionary :: Qualified Ident -> Maybe [DictionaryValue] -> DictionaryValue
118− mkDictionary fnName Nothing = LocalDictionaryValue fnName
119− mkDictionary fnName (Just []) = GlobalDictionaryValue fnName
120− mkDictionary fnName (Just dicts) = DependentDictionaryValue fnName dicts
121− -- Turn a DictionaryValue into a Expr
122− dictionaryValueToValue :: DictionaryValue -> Expr
123− dictionaryValueToValue (LocalDictionaryValue fnName) = Var fnName
124− dictionaryValueToValue (GlobalDictionaryValue fnName) = Var fnName
125− dictionaryValueToValue (DependentDictionaryValue fnName dicts) = foldl App (Var fnName) (map dictionaryValueToValue dicts)
126− dictionaryValueToValue (SubclassDictionaryValue dict superclassName index) =
127− App (Accessor (C.__superclass_ ++ show superclassName ++ "_" ++ show index)
128− (dictionaryValueToValue dict))
129− valUndefined
130− -- Ensure that a substitution is valid
131− verifySubstitution :: [(String, Type)] -> Maybe [(String, Type)]
132− verifySubstitution subst = do
133− let grps = groupBy ((==) `on` fst) subst
134− guard (all (pairwise (unifiesWith env) . map snd) grps)
135− return $ map head grps
136− -- |
137− -- Check for overlapping instances
138− --
139− checkOverlaps :: [DictionaryValue] -> Check Expr
140− checkOverlaps dicts =
141− case [ (d1, d2) | d1 <- dicts, d2 <- dicts, d1 `overlapping` d2 ] of
142− (d1, d2) : _ -> throwError . strMsg $ unlines
143− [ "Overlapping instances found for " ++ show className ++ " " ++ unwords (map prettyPrintType tys) ++ "."
144− , "For example:"
145− , prettyPrintDictionaryValue d1
146− , "and:"
147− , prettyPrintDictionaryValue d2
148− ]
149− _ -> case chooseSimplestDictionaries dicts of
150− [] -> throwError . strMsg $
151− "No instance found for " ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys)
152− d : _ -> return $ dictionaryValueToValue d
153− -- Choose the simplest DictionaryValues from a list of candidates
154− -- The reason for this function is as follows:
155− -- When considering overlapping instances, we don't want to consider the same dictionary
156− -- to be an overlap of itself when obtained as a superclass of another class.
157− -- Observing that we probably don't want to select a superclass instance when an instance
158− -- is available directly, and that there is no way for a superclass instance to actually
159− -- introduce an overlap that wouldn't have been there already, we simply remove dictionaries
160− -- obtained as superclass instances if there are simpler instances available.
161− chooseSimplestDictionaries :: [DictionaryValue] -> [DictionaryValue]
162− chooseSimplestDictionaries ds = case filter isSimpleDictionaryValue ds of
163− [] -> ds
164− simple -> simple
165− isSimpleDictionaryValue SubclassDictionaryValue{} = False
166− isSimpleDictionaryValue (DependentDictionaryValue _ ds) = all isSimpleDictionaryValue ds
167− isSimpleDictionaryValue _ = True
168− -- |
169− -- Check if two dictionaries are overlapping
170− --
171− -- Dictionaries which are subclass dictionaries cannot overlap, since otherwise the overlap would have
172− -- been caught when constructing superclass dictionaries.
173− --
174− overlapping :: DictionaryValue -> DictionaryValue -> Bool
175− overlapping (LocalDictionaryValue nm1) (LocalDictionaryValue nm2) | nm1 == nm2 = False
176− overlapping (GlobalDictionaryValue nm1) (GlobalDictionaryValue nm2) | nm1 == nm2 = False
177− overlapping (DependentDictionaryValue nm1 ds1) (DependentDictionaryValue nm2 ds2)
178− | nm1 == nm2 = or $ zipWith overlapping ds1 ds2
179− overlapping SubclassDictionaryValue{} _ = False
180− overlapping _ SubclassDictionaryValue{} = False
181− overlapping _ _ = True
182− -- |
183− -- Render a DictionaryValue fit for human consumption in error messages
184− --
185− prettyPrintDictionaryValue :: DictionaryValue -> String
186− prettyPrintDictionaryValue = unlines . indented 0
187− where
188− indented n (LocalDictionaryValue _) = [spaces n ++ "Dictionary in scope"]
189− indented n (GlobalDictionaryValue nm) = [spaces n ++ show nm]
190− indented n (DependentDictionaryValue nm args) = (spaces n ++ show nm ++ " via") : concatMap (indented (n + 2)) args
191− indented n (SubclassDictionaryValue sup nm _) = (spaces n ++ show nm ++ " via superclass") : indented (n + 2) sup
192−
193− spaces n = replicate n ' ' ++ "- "
194−
195− valUndefined :: Expr
196− valUndefined = Var (Qualified (Just (ModuleName [ProperName C.prim])) (Ident C.undefined))
197−
198−-- |
199−-- Check whether the type heads of two types are equal (for the purposes of type class dictionary lookup),
200−-- and return a substitution from type variables to types which makes the type heads unify.
201−--
202−typeHeadsAreEqual :: ModuleName -> Environment -> Type -> Type -> Maybe [(String, Type)]
203−typeHeadsAreEqual _ _ (Skolem _ s1 _) (Skolem _ s2 _) | s1 == s2 = Just []
204−typeHeadsAreEqual _ _ t (TypeVar v) = Just [(v, t)]
205−typeHeadsAreEqual _ _ (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = Just []
206−typeHeadsAreEqual m e (TypeApp h1 t1) (TypeApp h2 t2) = (++) <$> typeHeadsAreEqual m e h1 h2
207− <*> typeHeadsAreEqual m e t1 t2
208−typeHeadsAreEqual m e (SaturatedTypeSynonym name args) t2 = case expandTypeSynonym' e name args of
209− Left _ -> Nothing
210− Right t1 -> typeHeadsAreEqual m e t1 t2
211−typeHeadsAreEqual _ _ REmpty REmpty = Just []
212−typeHeadsAreEqual m e r1@(RCons _ _ _) r2@(RCons _ _ _) =
213− let (s1, r1') = rowToList r1
214− (s2, r2') = rowToList r2
215−
216− int = [ (t1, t2) | (name, t1) <- s1, (name', t2) <- s2, name == name' ]
217− sd1 = [ (name, t1) | (name, t1) <- s1, name `notElem` map fst s2 ]
218− sd2 = [ (name, t2) | (name, t2) <- s2, name `notElem` map fst s1 ]
219− in (++) <$> foldMap (\(t1, t2) -> typeHeadsAreEqual m e t1 t2) int
220− <*> go sd1 r1' sd2 r2'
221− where
222− go :: [(String, Type)] -> Type -> [(String, Type)] -> Type -> Maybe [(String, Type)]
223− go [] REmpty [] REmpty = Just []
224− go [] (TUnknown _) _ _ = Just []
225− go [] (TypeVar v1) [] (TypeVar v2) | v1 == v2 = Just []
226− go [] (Skolem _ s1 _) [] (Skolem _ s2 _) | s1 == s2 = Just []
227− go sd r [] (TypeVar v) = Just [(v, rowFromList (sd, r))]
228− go _ _ _ _ = Nothing
229−typeHeadsAreEqual _ _ _ _ = Nothing
230−
231−-- |
232−-- Check all values in a list pairwise match a predicate
233−--
234−pairwise :: (a -> a -> Bool) -> [a] -> Bool
235−pairwise _ [] = True
236−pairwise _ [_] = True
237−pairwise p (x : xs) = all (p x) xs && pairwise p xs
src/Language/PureScript/TypeChecker/Kinds.hsdeleted−219

This diff is too big to show here.

src/Language/PureScript/TypeChecker/Monad.hsdeleted−241

This diff is too big to show here.

src/Language/PureScript/TypeChecker/Rows.hsdeleted−66

This diff is too big to show here.

src/Language/PureScript/TypeChecker/Skolems.hsdeleted−115

This diff is too big to show here.

src/Language/PureScript/TypeChecker/Subsumption.hsdeleted−103

This diff is too big to show here.

src/Language/PureScript/TypeChecker/Synonyms.hsdeleted−110

This diff is too big to show here.

src/Language/PureScript/TypeChecker/Types.hsdeleted−677

This diff is too big to show here.

src/Language/PureScript/TypeChecker/Unify.hsdeleted−205

This diff is too big to show here.

src/Language/PureScript/TypeClassDictionaries.hsdeleted−73

This diff is too big to show here.

src/Language/PureScript/Types.hsdeleted−314

This diff is too big to show here.

src/Tests.hsnew file+141

This diff is too big to show here.

stack.nixnew file+23

This diff is too big to show here.

stack.yamlnew file+24

This diff is too big to show here.

support/ffi-loader.gonew file+30

This diff is too big to show here.

support/go.mod.ffi-loadernew file+2

This diff is too big to show here.

support/go.mod.outputnew file+2

This diff is too big to show here.

support/go.mod.workingnew file+1

This diff is too big to show here.

test/Spec.hsnew file+2

This diff is too big to show here.

tests/Main.hsdeleted−108

This diff is too big to show here.

travis-after-script.shdeleted−7

This diff is too big to show here.

travis-script.shdeleted−11

This diff is too big to show here.