git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
swap
355eb9b2320 ahead, 0 behind
323 files changed+2728−19739
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−236 psc-make/Main.hs−177 psc/Main.hs−209 psci/Commands.hs−87 psci/Main.hs−661 psci/Parser.hs−82 psgo.cabal+145 purescript.cabal−180 src/CodeGen/IL.hs+321 src/CodeGen/IL/Common.hs+196 src/CodeGen/IL/Optimizer.hs+81 src/CodeGen/IL/Optimizer/Common.hs+18 src/CodeGen/IL/Optimizer/Inliner.hs+435 src/CodeGen/IL/Optimizer/MagicDo.hs+146 src/CodeGen/IL/Optimizer/TCO.hs+141 src/CodeGen/IL/Printer.hs+527 src/Control/Monad/Supply.hs−43 src/Control/Monad/Supply/Class.hs−36 src/Control/Monad/Unify.hs−155 src/Language/PureScript.hs−269 src/Language/PureScript/AST.hs−23 src/Language/PureScript/AST/Binders.hs−87 src/Language/PureScript/AST/Declarations.hs−447 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−362 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−249 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−32 src/Language/PureScript/CoreFn/Traversals.hs−85 src/Language/PureScript/DeadCodeElimination.hs−102 src/Language/PureScript/Environment.hs−241 src/Language/PureScript/Errors.hs−153 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−519 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−71 src/Language/PureScript/Sugar/BindingGroups.hs−207 src/Language/PureScript/Sugar/CaseDeclarations.hs−129 src/Language/PureScript/Sugar/DoNotation.hs−77 src/Language/PureScript/Sugar/Names.hs−551 src/Language/PureScript/Sugar/ObjectWildcards.hs−65 src/Language/PureScript/Sugar/Operators.hs−166 src/Language/PureScript/Sugar/TypeClasses.hs−292 src/Language/PureScript/Sugar/TypeDeclarations.hs−70 src/Language/PureScript/Traversals.hs−41 src/Language/PureScript/TypeChecker.hs−355 src/Language/PureScript/TypeChecker/Entailment.hs−238 src/Language/PureScript/TypeChecker/Kinds.hs−218 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−102 src/Language/PureScript/TypeChecker/Synonyms.hs−111 src/Language/PureScript/TypeChecker/Types.hs−677 src/Language/PureScript/TypeChecker/Unify.hs−204 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−236
@@ -1,236 +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.List
22−import Data.Maybe (fromMaybe)
23−import Data.Version (showVersion)
24−import Data.Foldable (traverse_)
25−
26−import Options.Applicative
27−
28−import qualified Language.PureScript as P
29−import qualified Paths_purescript as Paths
30−import System.Exit (exitSuccess, exitFailure)
31−import System.IO (hPutStrLn, stderr)
32−
33−data PSCDocsOptions = PSCDocsOptions
34− { pscdInputFiles :: [FilePath]
35− }
36−
37−docgen :: PSCDocsOptions -> IO ()
38−docgen (PSCDocsOptions input) = do
39− e <- P.parseModulesFromFiles (fromMaybe "") <$> mapM (fmap (first Just) . parseFile) (nub input)
40− case e of
41− Left err -> do
42− hPutStrLn stderr $ show err
43− exitFailure
44− Right ms -> do
45− putStrLn . runDocs $ renderModules (map snd ms)
46− exitSuccess
47−
48−parseFile :: FilePath -> IO (FilePath, String)
49−parseFile input = (,) input <$> readFile input
50−
51−type Docs = Writer [String] ()
52−
53−runDocs :: Docs -> String
54−runDocs = unlines . execWriter
55−
56−spacer :: Docs
57−spacer = tell [""]
58−
59−headerLevel :: Int -> String -> Docs
60−headerLevel level hdr = tell [replicate level '#' ++ ' ' : hdr]
61−
62−withIndent :: Int -> Docs -> Docs
63−withIndent indent = censor (map (replicate indent ' ' ++ ))
64−
65−atIndent :: Int -> String -> Docs
66−atIndent indent text =
67− let ls = lines text in
68− withIndent indent (tell ls)
69−
70−fenced :: String -> Docs
71−fenced text = fencedBlock (tell $ lines text)
72−
73−fencedBlock :: Docs -> Docs
74−fencedBlock inner = do
75− tell ["``` purescript"]
76− inner
77− tell ["```"]
78−
79−ticks :: String -> String
80−ticks = ("`" ++) . (++ "`")
81−
82−renderModules :: [P.Module] -> Docs
83−renderModules ms = do
84− headerLevel 1 "Module Documentation"
85− spacer
86− mapM_ renderModule ms
87−
88−renderModule :: P.Module -> Docs
89−renderModule mdl@(P.Module coms moduleName _ exps) = do
90− headerLevel 2 $ "Module " ++ P.runModuleName moduleName
91− spacer
92− renderComments coms
93− spacer
94− renderTopLevel exps (P.exportedDeclarations mdl)
95− spacer
96−
97−renderTopLevel :: Maybe [P.DeclarationRef] -> [P.Declaration] -> Docs
98−renderTopLevel exps decls = forM_ decls $ \decl ->
99− when (canRenderDecl decl) $ do
100− traverse_ (headerLevel 4) (ticks `fmap` getDeclarationTitle decl)
101− spacer
102− renderDeclaration exps decl
103− spacer
104−
105−renderTypeclassImage :: P.ModuleName -> Docs
106−renderTypeclassImage name =
107− let name' = P.runModuleName name
108− in tell ["![" ++ name' ++ "](images/" ++ name' ++ ".png)"]
109−
110−getDeclarationTitle :: P.Declaration -> Maybe String
111−getDeclarationTitle (P.TypeDeclaration name _) = Just (show name)
112−getDeclarationTitle (P.ExternDeclaration _ name _ _) = Just (show name)
113−getDeclarationTitle (P.DataDeclaration _ name _ _) = Just (show name)
114−getDeclarationTitle (P.ExternDataDeclaration name _) = Just (show name)
115−getDeclarationTitle (P.TypeSynonymDeclaration name _ _) = Just (show name)
116−getDeclarationTitle (P.TypeClassDeclaration name _ _ _) = Just (show name)
117−getDeclarationTitle (P.TypeInstanceDeclaration name _ _ _ _) = Just (show name)
118−getDeclarationTitle (P.PositionedDeclaration _ _ d) = getDeclarationTitle d
119−getDeclarationTitle _ = Nothing
120−
121−renderDeclaration :: Maybe [P.DeclarationRef] -> P.Declaration -> Docs
122−renderDeclaration _ (P.TypeDeclaration ident ty) =
123− fenced $ show ident ++ " :: " ++ prettyPrintType' ty
124−renderDeclaration _ (P.ExternDeclaration _ ident _ ty) =
125− fenced $ show ident ++ " :: " ++ prettyPrintType' ty
126−renderDeclaration exps (P.DataDeclaration dtype name args ctors) = do
127− let
128− typeApp = foldl P.TypeApp (P.TypeConstructor (P.Qualified Nothing name)) (map toTypeVar args)
129− typeName = prettyPrintType' typeApp
130− exported = filter (P.isDctorExported name exps . fst) ctors
131− fencedBlock $ do
132− tell [show dtype ++ " " ++ typeName]
133− zipWithM_ (\isFirst (ctor, tys) ->
134− atIndent 2 $ (if isFirst then "= " else "| ") ++ P.runProperName ctor ++ " " ++ unwords (map P.prettyPrintTypeAtom tys))
135− (True : repeat False) exported
136−renderDeclaration _ (P.ExternDataDeclaration name kind) =
137− fenced $ "data " ++ P.runProperName name ++ " :: " ++ P.prettyPrintKind kind
138−renderDeclaration _ (P.TypeSynonymDeclaration name args ty) = do
139− let
140− typeApp = foldl P.TypeApp (P.TypeConstructor (P.Qualified Nothing name)) (map toTypeVar args)
141− typeName = prettyPrintType' typeApp
142− fenced $ "type " ++ typeName ++ " = " ++ prettyPrintType' ty
143−renderDeclaration _ (P.TypeClassDeclaration name args implies ds) = do
144− let impliesText = case implies of
145− [] -> ""
146− is -> "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map P.prettyPrintTypeAtom tys')) is) ++ ") <= "
147− classApp = foldl P.TypeApp (P.TypeConstructor (P.Qualified Nothing name)) (map toTypeVar args)
148− className = prettyPrintType' classApp
149− fencedBlock $ do
150− tell ["class " ++ impliesText ++ className ++ " where"]
151− mapM_ renderClassMember ds
152− where
153− renderClassMember (P.PositionedDeclaration _ _ d) = renderClassMember d
154− renderClassMember (P.TypeDeclaration ident ty) = atIndent 2 $ show ident ++ " :: " ++ prettyPrintType' ty
155− renderClassMember _ = error "Invalid argument to renderClassMember."
156−renderDeclaration _ (P.TypeInstanceDeclaration name constraints className tys _) = do
157− let constraintsText = case constraints of
158− [] -> ""
159− cs -> "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map P.prettyPrintTypeAtom tys')) cs) ++ ") => "
160− fenced $ "instance " ++ show name ++ " :: " ++ constraintsText ++ show className ++ " " ++ unwords (map P.prettyPrintTypeAtom tys)
161−renderDeclaration exps (P.PositionedDeclaration _ com d) = do
162− renderDeclaration exps d
163− renderComments com
164−renderDeclaration _ _ = return ()
165−
166−renderComments :: [P.Comment] -> Docs
167−renderComments cs = do
168− let raw = concatMap toLines cs
169− when (all hasPipe raw) $ do
170− spacer
171− atIndent 0 . unlines . map stripPipes $ raw
172− where
173−
174− toLines (P.LineComment s) = [s]
175− toLines (P.BlockComment s) = lines s
176−
177− hasPipe s = case dropWhile (== ' ') s of { ('|':_) -> True; _ -> False }
178−
179− stripPipes = dropPipe . dropWhile (== ' ')
180−
181− dropPipe ('|':' ':s) = s
182− dropPipe ('|':s) = s
183− dropPipe s = s
184−
185−toTypeVar :: (String, Maybe P.Kind) -> P.Type
186−toTypeVar (s, Nothing) = P.TypeVar s
187−toTypeVar (s, Just k) = P.KindedType (P.TypeVar s) k
188−
189−prettyPrintType' :: P.Type -> String
190−prettyPrintType' = P.prettyPrintType . P.everywhereOnTypes dePrim
191− where
192− dePrim ty@(P.TypeConstructor (P.Qualified _ name))
193− | ty == P.tyBoolean || ty == P.tyNumber || ty == P.tyString =
194− P.TypeConstructor $ P.Qualified Nothing name
195− dePrim other = other
196−
197−getName :: P.Declaration -> String
198−getName (P.TypeDeclaration ident _) = show ident
199−getName (P.ExternDeclaration _ ident _ _) = show ident
200−getName (P.DataDeclaration _ name _ _) = P.runProperName name
201−getName (P.ExternDataDeclaration name _) = P.runProperName name
202−getName (P.TypeSynonymDeclaration name _ _) = P.runProperName name
203−getName (P.TypeClassDeclaration name _ _ _) = P.runProperName name
204−getName (P.TypeInstanceDeclaration name _ _ _ _) = show name
205−getName (P.PositionedDeclaration _ _ d) = getName d
206−getName _ = error "Invalid argument to getName"
207−
208−canRenderDecl :: P.Declaration -> Bool
209−canRenderDecl P.TypeDeclaration{} = True
210−canRenderDecl P.ExternDeclaration{} = True
211−canRenderDecl P.DataDeclaration{} = True
212−canRenderDecl P.ExternDataDeclaration{} = True
213−canRenderDecl P.TypeSynonymDeclaration{} = True
214−canRenderDecl P.TypeClassDeclaration{} = True
215−canRenderDecl P.TypeInstanceDeclaration{} = True
216−canRenderDecl (P.PositionedDeclaration _ _ d) = canRenderDecl d
217−canRenderDecl _ = False
218−
219−inputFile :: Parser FilePath
220−inputFile = strArgument $
221− metavar "FILE"
222− <> help "The input .purs file(s)"
223−
224−pscDocsOptions :: Parser PSCDocsOptions
225−pscDocsOptions = PSCDocsOptions <$> many inputFile
226−
227−main :: IO ()
228−main = execParser opts >>= docgen
229− where
230− opts = info (version <*> helper <*> pscDocsOptions) infoModList
231− infoModList = fullDesc <> headerInfo <> footerInfo
232− headerInfo = header "psc-docs - Generate Markdown documentation from PureScript extern files"
233− footerInfo = footer $ "psc-docs " ++ showVersion Paths.version
234−
235− version :: Parser (a -> a)
236− 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.Except
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) (ExceptT 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 = runExceptT . flip runReaderT opts . unMake
60−
61−makeIO :: IO a -> Make a
62−makeIO = Make . lift . ExceptT . 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.Except
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−661
@@ -1,661 +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 #-}
17−{-# LANGUAGE DoAndIfThenElse #-}
18−{-# LANGUAGE FlexibleContexts #-}
19−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
20−{-# LANGUAGE RecordWildCards #-}
21−
22−module Main where
23−
24−import Data.Foldable (traverse_)
25−import Data.List (intercalate, isPrefixOf, nub, sortBy, sort)
26−import Data.Maybe (mapMaybe)
27−import Data.Traversable (traverse)
28−import Data.Version (showVersion)
29−import Data.Char (isSpace)
30−import qualified Data.Map as M
31−
32−import Control.Applicative
33−import Control.Monad
34−import Control.Monad.Except (ExceptT(..), MonadError, runExceptT)
35−import Control.Monad.Reader (MonadReader, ReaderT, runReaderT)
36−import Control.Monad.Trans.Class
37−import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
38−import Control.Monad.Trans.State.Strict
39−import qualified Control.Monad.Trans.State.Lazy as L
40−
41−import Options.Applicative as Opts
42−
43−import System.Console.Haskeline
44−import System.Directory (createDirectoryIfMissing, getModificationTime, doesFileExist, findExecutable, getHomeDirectory, getCurrentDirectory)
45−import System.Exit
46−import System.FilePath (pathSeparator, takeDirectory, (</>), isPathSeparator)
47−import System.IO.Error (tryIOError)
48−import System.Process (readProcessWithExitCode)
49−
50−import qualified Text.Parsec as Par (ParseError)
51−
52−import qualified Language.PureScript as P
53−import qualified Language.PureScript.AST as D
54−import qualified Language.PureScript.Names as N
55−import qualified Paths_purescript as Paths
56−
57−import Commands as C
58−import Parser
59−
60−data PSCiOptions = PSCiOptions
61− { psciMultiLineMode :: Bool
62− , psciInputFile :: [FilePath]
63− , psciInputNodeFlags :: [String]
64− }
65−
66−-- |
67−-- The PSCI state.
68−-- Holds a list of imported modules, loaded files, and partial let bindings.
69−-- The let bindings are partial,
70−-- because it makes more sense to apply the binding to the final evaluated expression.
71−--
72−data PSCiState = PSCiState
73− { psciImportedFilenames :: [FilePath]
74− , psciImportedModuleNames :: [P.ModuleName]
75− , psciLoadedModules :: [(Either P.RebuildPolicy FilePath, P.Module)]
76− , psciLetBindings :: [P.Declaration]
77− , psciNodeFlags :: [String]
78− }
79−
80−-- State helpers
81−
82−-- |
83−-- Updates the state to have more imported modules.
84−--
85−updateImportedFiles :: FilePath -> PSCiState -> PSCiState
86−updateImportedFiles filename st = st { psciImportedFilenames = filename : psciImportedFilenames st }
87−
88−-- |
89−-- Updates the state to have more imported modules.
90−--
91−updateImports :: P.ModuleName -> PSCiState -> PSCiState
92−updateImports name st = st { psciImportedModuleNames = name : psciImportedModuleNames st }
93−
94−-- |
95−-- Updates the state to have more loaded files.
96−--
97−updateModules :: [(Either P.RebuildPolicy FilePath, P.Module)] -> PSCiState -> PSCiState
98−updateModules modules st = st { psciLoadedModules = psciLoadedModules st ++ modules }
99−
100−-- |
101−-- Updates the state to have more let bindings.
102−--
103−updateLets :: [P.Declaration] -> PSCiState -> PSCiState
104−updateLets ds st = st { psciLetBindings = psciLetBindings st ++ ds }
105−
106−-- File helpers
107−-- |
108−-- Load the necessary modules.
109−--
110−defaultImports :: [P.ModuleName]
111−defaultImports = [P.ModuleName [P.ProperName "Prelude"]]
112−
113−-- |
114−-- Locates the node executable.
115−-- Checks for either @nodejs@ or @node@.
116−--
117−findNodeProcess :: IO (Maybe String)
118−findNodeProcess = runMaybeT . msum $ map (MaybeT . findExecutable) names
119− where names = ["nodejs", "node"]
120−
121−-- |
122−-- Grabs the filename where the history is stored.
123−--
124−getHistoryFilename :: IO FilePath
125−getHistoryFilename = do
126− home <- getHomeDirectory
127− let filename = home </> ".purescript" </> "psci_history"
128− mkdirp filename
129− return filename
130−
131−-- |
132−-- Loads a file for use with imports.
133−--
134−loadModule :: FilePath -> IO (Either String [P.Module])
135−loadModule filename = do
136− content <- readFile filename
137− return $ either (Left . show) (Right . map snd) $ P.parseModulesFromFiles id [(filename, content)]
138−
139−-- |
140−-- Load all modules, including the Prelude
141−--
142−loadAllModules :: [FilePath] -> IO (Either Par.ParseError [(Either P.RebuildPolicy FilePath, P.Module)])
143−loadAllModules files = do
144− filesAndContent <- forM files $ \filename -> do
145− content <- readFile filename
146− return (Right filename, content)
147− return $ P.parseModulesFromFiles (either (const "") id) $ (Left P.RebuildNever, P.prelude) : filesAndContent
148−
149−-- |
150−-- Load all modules, updating the application state
151−--
152−loadAllImportedModules :: PSCI ()
153−loadAllImportedModules = do
154− files <- PSCI . lift $ fmap psciImportedFilenames get
155− modulesOrFirstError <- psciIO $ loadAllModules files
156− case modulesOrFirstError of
157− Left err -> psciIO $ print err
158− Right modules -> PSCI . lift . modify $ \st -> st { psciLoadedModules = modules }
159−
160−-- |
161−-- Expands tilde in path.
162−--
163−expandTilde :: FilePath -> IO FilePath
164−expandTilde ('~':p:rest) | isPathSeparator p = (</> rest) <$> getHomeDirectory
165−expandTilde p = return p
166−-- Messages
167−
168−-- |
169−-- The help message.
170−--
171−helpMessage :: String
172−helpMessage = "The following commands are available:\n\n " ++
173− intercalate "\n " (map line C.help)
174− where line :: (String, String, String) -> String
175− line (cmd, arg, desc) = intercalate " " [cmd, arg, replicate (11 - length arg) ' ', desc]
176−
177−-- |
178−-- The welcome prologue.
179−--
180−prologueMessage :: String
181−prologueMessage = intercalate "\n"
182− [ " ____ ____ _ _ "
183− , "| _ \\ _ _ _ __ ___/ ___| ___ _ __(_)_ __ | |_ "
184− , "| |_) | | | | '__/ _ \\___ \\ / __| '__| | '_ \\| __|"
185− , "| __/| |_| | | | __/___) | (__| | | | |_) | |_ "
186− , "|_| \\__,_|_| \\___|____/ \\___|_| |_| .__/ \\__|"
187− , " |_| "
188− , ""
189− , ":? shows help"
190− ]
191−
192−-- |
193−-- The quit message.
194−--
195−quitMessage :: String
196−quitMessage = "See ya!"
197−
198−-- Haskeline completions
199−
200−data CompletionContext = Command String | FilePath String | Module | Identifier
201− | Type | Fixed [String] | Multiple [CompletionContext]
202− deriving (Show)
203−
204−-- |
205−-- Decide what kind of completion we need based on input.
206−completionContext :: String -> String -> Maybe CompletionContext
207−completionContext cmd@"" _ = Just $ Multiple [Command cmd, Identifier]
208−completionContext cmd@(':' : _ ) _
209− | cmd `elem` C.commands || cmd == ":" = Just $ Command cmd
210−completionContext (':' : c : _) word = case c of
211− 'i' -> Just Module
212− 'b' -> Just Module
213− 'm' -> Just $ FilePath word
214− 'q' -> Nothing
215− 'r' -> Nothing
216− '?' -> Nothing
217− 's' -> Just $ Fixed ["import", "loaded"]
218− 't' -> Just Identifier
219− 'k' -> Just Type
220− _ -> Nothing
221−completionContext _ _ = Just Identifier
222−
223−-- |
224−-- Loads module, function, and file completions.
225−--
226−completion :: CompletionFunc (StateT PSCiState IO)
227−completion = completeWordWithPrev Nothing " \t\n\r" findCompletions
228− where
229− findCompletions :: String -> String -> StateT PSCiState IO [Completion]
230− findCompletions prev word = do
231− let ctx = completionContext ((dropWhile isSpace (reverse prev)) ++ word) word
232− completions <- case ctx of
233− Nothing -> return []
234− (Just c) -> (mapMaybe $ either (\cand -> if word `isPrefixOf` cand
235− then Just $ simpleCompletion cand
236− else Nothing) Just)
237− <$> getCompletion c
238− return $ sortBy sorter completions
239−
240− getCompletion :: CompletionContext -> StateT PSCiState IO [Either String Completion]
241− getCompletion (Command s) = return $ (map Left) $ nub $ filter (isPrefixOf s) C.commands
242− getCompletion (FilePath f) = (map Right) <$> listFiles f
243− getCompletion Module = (map Left) <$> getModuleNames
244− getCompletion Identifier = (map Left) <$> ((++) <$> getIdentNames <*> getDctorNames)
245− getCompletion Type = (map Left) <$> getTypeNames
246− getCompletion (Fixed list) = return $ (map Left) list
247− getCompletion (Multiple contexts) = concat <$> mapM getCompletion contexts
248−
249− getLoadedModules :: StateT PSCiState IO [P.Module]
250− getLoadedModules = map snd . psciLoadedModules <$> get
251−
252− getModuleNames :: StateT PSCiState IO [String]
253− getModuleNames = moduleNames <$> getLoadedModules
254−
255− mapLoadedModulesAndQualify :: (Show a) => (P.Module -> [a]) -> StateT PSCiState IO [String]
256− mapLoadedModulesAndQualify f = do
257− ms <- getLoadedModules
258− q <- sequence [qualifyIfNeeded m (f m) | m <- ms]
259− return $ concat q
260−
261− getIdentNames :: StateT PSCiState IO [String]
262− getIdentNames = mapLoadedModulesAndQualify identNames
263−
264− getDctorNames :: StateT PSCiState IO [String]
265− getDctorNames = mapLoadedModulesAndQualify dctorNames
266−
267− getTypeNames :: StateT PSCiState IO [String]
268− getTypeNames = mapLoadedModulesAndQualify typeDecls
269−
270− qualifyIfNeeded :: (Show a) => P.Module -> [a] -> StateT PSCiState IO [String]
271− qualifyIfNeeded m decls = do
272− let name = P.getModuleName m
273− imported <- psciImportedModuleNames <$> get
274− let qualified = map (P.Qualified $ Just name) decls
275− if name `elem` imported then
276− return $ map show $ qualified ++ (map (P.Qualified Nothing) decls)
277− else
278− return $ map show qualified
279−
280− typeDecls :: P.Module -> [N.ProperName]
281− typeDecls m = mapMaybe getTypeName $ filter P.isDataDecl (P.exportedDeclarations m)
282− where getTypeName :: P.Declaration -> Maybe N.ProperName
283− getTypeName (P.TypeSynonymDeclaration name _ _) = Just name
284− getTypeName (P.DataDeclaration _ name _ _) = Just name
285− getTypeName (P.PositionedDeclaration _ _ d) = getTypeName d
286− getTypeName _ = Nothing
287−
288− identNames :: P.Module -> [N.Ident]
289− identNames (P.Module _ _ ds exports) = nub [ ident | ident <- mapMaybe (getDeclName exports) (D.flattenDecls ds) ]
290− where getDeclName :: Maybe [P.DeclarationRef] -> P.Declaration -> Maybe P.Ident
291− getDeclName exts decl@(P.ValueDeclaration ident _ _ _) | P.isExported exts decl = Just ident
292− getDeclName exts decl@(P.ExternDeclaration _ ident _ _) | P.isExported exts decl = Just ident
293− getDeclName exts (P.PositionedDeclaration _ _ d) = getDeclName exts d
294− getDeclName _ _ = Nothing
295−
296− dctorNames :: P.Module -> [N.ProperName]
297− dctorNames m = nub $ concat $ map (P.exportedDctors m) dnames
298− where getDataDeclName :: P.Declaration -> Maybe N.ProperName
299− getDataDeclName (P.DataDeclaration _ name _ _) = Just name
300− getDataDeclName (P.PositionedDeclaration _ _ d) = getDataDeclName d
301− getDataDeclName _ = Nothing
302−
303− dnames :: [N.ProperName]
304− dnames = (mapMaybe getDataDeclName onlyDataDecls)
305−
306− onlyDataDecls :: [P.Declaration]
307− onlyDataDecls = (filter P.isDataDecl (P.exportedDeclarations m))
308−
309− moduleNames :: [P.Module] -> [String]
310− moduleNames ms = nub [show moduleName | P.Module _ moduleName _ _ <- ms]
311−
312− sorter :: Completion -> Completion -> Ordering
313− sorter (Completion _ d1 _) (Completion _ d2 _) = if ":" `isPrefixOf` d1 then LT else compare d1 d2
314−
315−-- Compilation
316−
317−-- | Compilation options.
318−--
319−options :: P.Options P.Make
320−options = P.Options False False False Nothing False False False P.MakeOptions
321−
322−-- |
323−-- PSCI monad
324−--
325−newtype PSCI a = PSCI { runPSCI :: InputT (StateT PSCiState IO) a } deriving (Functor, Applicative, Monad)
326−
327−psciIO :: IO a -> PSCI a
328−psciIO io = PSCI . lift $ lift io
329−
330−newtype Make a = Make { unMake :: ReaderT (P.Options P.Make) (ExceptT String IO) a }
331− deriving (Functor, Applicative, Monad, MonadError String, MonadReader (P.Options P.Make))
332−
333−runMake :: Make a -> IO (Either String a)
334−runMake = runExceptT . flip runReaderT options . unMake
335−
336−makeIO :: IO a -> Make a
337−makeIO = Make . lift . ExceptT . fmap (either (Left . show) Right) . tryIOError
338−
339−instance P.MonadMake Make where
340− getTimestamp path = makeIO $ do
341− exists <- doesFileExist path
342− traverse (const $ getModificationTime path) $ guard exists
343− readTextFile path = makeIO $ readFile path
344− writeTextFile path text = makeIO $ do
345− mkdirp path
346− writeFile path text
347− progress s = unless (s == "Compiling $PSCI") $ makeIO . putStrLn $ s
348−
349−mkdirp :: FilePath -> IO ()
350−mkdirp = createDirectoryIfMissing True . takeDirectory
351−
352−-- |
353−-- Makes a volatile module to execute the current expression.
354−--
355−createTemporaryModule :: Bool -> PSCiState -> P.Expr -> P.Module
356−createTemporaryModule exec PSCiState{psciImportedModuleNames = imports, psciLetBindings = lets} val =
357− let
358− moduleName = P.ModuleName [P.ProperName "$PSCI"]
359− importDecl m = P.ImportDeclaration m P.Unqualified Nothing
360− traceModule = P.ModuleName [P.ProperName "Debug", P.ProperName "Trace"]
361− trace = P.Var (P.Qualified (Just traceModule) (P.Ident "print"))
362− mainValue = P.App trace (P.Var (P.Qualified Nothing (P.Ident "it")))
363− itDecl = P.ValueDeclaration (P.Ident "it") P.Value [] $ Right val
364− mainDecl = P.ValueDeclaration (P.Ident "main") P.Value [] $ Right mainValue
365− decls = if exec then [itDecl, mainDecl] else [itDecl]
366− in
367− P.Module [] moduleName ((importDecl `map` imports) ++ lets ++ decls) Nothing
368−
369−
370−-- |
371−-- Makes a volatile module to hold a non-qualified type synonym for a fully-qualified data type declaration.
372−--
373−createTemporaryModuleForKind :: PSCiState -> P.Type -> P.Module
374−createTemporaryModuleForKind PSCiState{psciImportedModuleNames = imports} typ =
375− let
376− moduleName = P.ModuleName [P.ProperName "$PSCI"]
377− importDecl m = P.ImportDeclaration m P.Unqualified Nothing
378− itDecl = P.TypeSynonymDeclaration (P.ProperName "IT") [] typ
379− in
380− P.Module [] moduleName ((importDecl `map` imports) ++ [itDecl]) Nothing
381−
382−-- |
383−-- Makes a volatile module to execute the current imports.
384−--
385−createTemporaryModuleForImports :: PSCiState -> P.Module
386−createTemporaryModuleForImports PSCiState{psciImportedModuleNames = imports} =
387− let
388− moduleName = P.ModuleName [P.ProperName "$PSCI"]
389− importDecl m = P.ImportDeclaration m P.Unqualified Nothing
390− in
391− P.Module [] moduleName (importDecl `map` imports) Nothing
392−
393−modulesDir :: FilePath
394−modulesDir = ".psci_modules" ++ pathSeparator : "node_modules"
395−
396−indexFile :: FilePath
397−indexFile = ".psci_modules" ++ pathSeparator : "index.js"
398−
399−-- |
400−-- Takes a value declaration and evaluates it with the current state.
401−--
402−handleDeclaration :: P.Expr -> PSCI ()
403−handleDeclaration val = do
404− st <- PSCI $ lift get
405− let m = createTemporaryModule True st val
406− let nodeArgs = psciNodeFlags st ++ [indexFile]
407− e <- psciIO . runMake $ P.make modulesDir (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) []
408− case e of
409− Left err -> PSCI $ outputStrLn err
410− Right _ -> do
411− psciIO $ writeFile indexFile "require('$PSCI').main();"
412− process <- psciIO findNodeProcess
413− result <- psciIO $ traverse (\node -> readProcessWithExitCode node nodeArgs "") process
414− case result of
415− Just (ExitSuccess, out, _) -> PSCI $ outputStrLn out
416− Just (ExitFailure _, _, err) -> PSCI $ outputStrLn err
417− Nothing -> PSCI $ outputStrLn "Couldn't find node.js"
418−
419−-- |
420−-- Takes a let declaration and updates the environment, then run a make. If the declaration fails,
421−-- restore the pre-let environment.
422−--
423−handleLet :: [P.Declaration] -> PSCI ()
424−handleLet ds = do
425− st <- PSCI $ lift get
426− let st' = updateLets ds st
427− let m = createTemporaryModule False st' (P.ObjectLiteral [])
428− e <- psciIO . runMake $ P.make modulesDir (psciLoadedModules st' ++ [(Left P.RebuildAlways, m)]) []
429− case e of
430− Left err -> PSCI $ outputStrLn err
431− Right _ -> PSCI $ lift (put st')
432−
433−-- |
434−-- Show actual loaded modules in psci.
435−--
436−handleShowLoadedModules :: PSCI ()
437−handleShowLoadedModules = do
438− PSCiState { psciLoadedModules = loadedModules } <- PSCI $ lift get
439− psciIO $ readModules loadedModules >>= putStrLn
440− return ()
441− where readModules = return . unlines . sort . nub . map toModuleName
442− toModuleName = N.runModuleName . (\ (D.Module _ mdName _ _) -> mdName) . snd
443−
444−-- |
445−-- Show the imported modules in psci.
446−--
447−handleShowImportedModules :: PSCI ()
448−handleShowImportedModules = do
449− PSCiState { psciImportedModuleNames = importedModuleNames } <- PSCI $ lift get
450− psciIO $ readModules importedModuleNames >>= putStrLn
451− return ()
452− where readModules = return . unlines . sort . map N.runModuleName
453−
454−-- |
455−-- Imports a module, preserving the initial state on failure.
456−--
457−handleImport :: P.ModuleName -> PSCI ()
458−handleImport moduleName = do
459− st <- updateImports moduleName <$> PSCI (lift get)
460− let m = createTemporaryModuleForImports st
461− e <- psciIO . runMake $ P.make modulesDir (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) []
462− case e of
463− Left err -> PSCI $ outputStrLn err
464− Right _ -> do
465− PSCI $ lift $ put st
466− return ()
467−
468−-- |
469−-- Takes a value and prints its type
470−--
471−handleTypeOf :: P.Expr -> PSCI ()
472−handleTypeOf val = do
473− st <- PSCI $ lift get
474− let m = createTemporaryModule False st val
475− e <- psciIO . runMake $ P.make modulesDir (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) []
476− case e of
477− Left err -> PSCI $ outputStrLn err
478− Right env' ->
479− case M.lookup (P.ModuleName [P.ProperName "$PSCI"], P.Ident "it") (P.names env') of
480− Just (ty, _, _) -> PSCI . outputStrLn . P.prettyPrintType $ ty
481− Nothing -> PSCI $ outputStrLn "Could not find type"
482−
483−-- |
484−-- Pretty print a module's signatures
485−--
486−printModuleSignatures :: P.ModuleName -> P.Environment -> PSCI ()
487−printModuleSignatures moduleName env =
488− PSCI $ let namesEnv = P.names env
489− moduleNamesIdent = (filter ((== moduleName) . fst) . M.keys) namesEnv
490− in case moduleNamesIdent of
491− [] -> outputStrLn $ "This module '"++ P.runModuleName moduleName ++"' does not export functions."
492− _ -> ( outputStrLn
493− . unlines
494− . sort
495− . map (showType . findType namesEnv)) moduleNamesIdent
496− 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))
497− findType envNames m@(_, mIdent) = (mIdent, M.lookup m envNames)
498− showType :: (P.Ident, Maybe (P.Type, P.NameKind, P.NameVisibility)) -> String
499− showType (mIdent, Just (mType, _, _)) = show mIdent ++ " :: " ++ P.prettyPrintType mType
500− showType _ = error "The impossible happened in printModuleSignatures."
501−
502−-- |
503−-- Browse a module and displays its signature (if module exists).
504−--
505−handleBrowse :: P.ModuleName -> PSCI ()
506−handleBrowse moduleName = do
507− st <- PSCI $ lift get
508− let loadedModules = psciLoadedModules st
509− env <- psciIO . runMake $ P.make modulesDir loadedModules []
510− case env of
511− Left err -> PSCI $ outputStrLn err
512− Right env' ->
513− if moduleName `notElem` (nub . map ((\ (P.Module _ modName _ _ ) -> modName) . snd)) loadedModules
514− then PSCI $ outputStrLn $ "Module '" ++ N.runModuleName moduleName ++ "' is not valid."
515− else printModuleSignatures moduleName env'
516−
517−-- |
518−-- Takes a value and prints its kind
519−--
520−handleKindOf :: P.Type -> PSCI ()
521−handleKindOf typ = do
522− st <- PSCI $ lift get
523− let m = createTemporaryModuleForKind st typ
524− mName = P.ModuleName [P.ProperName "$PSCI"]
525− e <- psciIO . runMake $ P.make modulesDir (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) []
526− case e of
527− Left err -> PSCI $ outputStrLn err
528− Right env' ->
529− case M.lookup (P.Qualified (Just mName) $ P.ProperName "IT") (P.typeSynonyms env') of
530− Just (_, typ') -> do
531− let chk = P.CheckState env' 0 0 (Just mName)
532− k = L.runStateT (P.unCheck (P.kindOf mName typ')) chk
533− case k of
534− Left errStack -> PSCI . outputStrLn . P.prettyPrintErrorStack False $ errStack
535− Right (kind, _) -> PSCI . outputStrLn . P.prettyPrintKind $ kind
536− Nothing -> PSCI $ outputStrLn "Could not find kind"
537−
538−-- Commands
539−
540−-- |
541−-- Parses the input and returns either a Metacommand or an expression.
542−--
543−getCommand :: Bool -> InputT (StateT PSCiState IO) (Either String (Maybe Command))
544−getCommand singleLineMode = do
545− firstLine <- getInputLine "> "
546− case firstLine of
547− Nothing -> return (Right Nothing)
548− Just "" -> return (Right Nothing)
549− Just s | singleLineMode || head s == ':' -> return . either Left (Right . Just) $ parseCommand s
550− Just s -> either Left (Right . Just) . parseCommand <$> go [s]
551− where
552− go :: [String] -> InputT (StateT PSCiState IO) String
553− go ls = maybe (return . unlines $ reverse ls) (go . (:ls)) =<< getInputLine " "
554−
555−-- |
556−-- Performs an action for each meta-command given, and also for expressions..
557−--
558−handleCommand :: Command -> PSCI ()
559−handleCommand (Expression val) = handleDeclaration val
560−handleCommand Help = PSCI $ outputStrLn helpMessage
561−handleCommand (Import moduleName) = handleImport moduleName
562−handleCommand (Let l) = handleLet l
563−handleCommand (LoadFile filePath) = do
564− absPath <- psciIO $ expandTilde filePath
565− exists <- psciIO $ doesFileExist absPath
566− if exists then do
567− PSCI . lift $ modify (updateImportedFiles absPath)
568− m <- psciIO $ loadModule absPath
569− case m of
570− Left err -> PSCI $ outputStrLn err
571− Right mods -> PSCI . lift $ modify (updateModules (map ((,) (Right absPath)) mods))
572− else
573− PSCI . outputStrLn $ "Couldn't locate: " ++ filePath
574−handleCommand Reset = do
575− files <- psciImportedFilenames <$> PSCI (lift get)
576− PSCI . lift . modify $ \st -> st
577− { psciImportedFilenames = files
578− , psciImportedModuleNames = defaultImports
579− , psciLetBindings = []
580− }
581− loadAllImportedModules
582−handleCommand (TypeOf val) = handleTypeOf val
583−handleCommand (KindOf typ) = handleKindOf typ
584−handleCommand (Browse moduleName) = handleBrowse moduleName
585−handleCommand (Show "loaded") = handleShowLoadedModules
586−handleCommand (Show "import") = handleShowImportedModules
587−handleCommand _ = PSCI $ outputStrLn "Unknown command"
588−
589−loadUserConfig :: IO (Maybe [Command])
590−loadUserConfig = do
591− configFile <- (</> ".psci") <$> getCurrentDirectory
592− exists <- doesFileExist configFile
593− if exists
594− then do
595− ls <- lines <$> readFile configFile
596− case mapM parseCommand ls of
597− Left err -> print err >> exitFailure
598− Right cs -> return $ Just cs
599− else
600− return Nothing
601−
602−-- |
603−-- The PSCI main loop.
604−--
605−loop :: PSCiOptions -> IO ()
606−loop PSCiOptions{..} = do
607− config <- loadUserConfig
608− modulesOrFirstError <- loadAllModules psciInputFile
609− case modulesOrFirstError of
610− Left err -> print err >> exitFailure
611− Right modules -> do
612− historyFilename <- getHistoryFilename
613− let settings = defaultSettings { historyFile = Just historyFilename }
614− flip evalStateT (PSCiState psciInputFile defaultImports modules [] psciInputNodeFlags) . runInputT (setComplete completion settings) $ do
615− outputStrLn prologueMessage
616− traverse_ (mapM_ (runPSCI . handleCommand)) config
617− go
618− where
619− go :: InputT (StateT PSCiState IO) ()
620− go = do
621− c <- getCommand (not psciMultiLineMode)
622− case c of
623− Left err -> outputStrLn err >> go
624− Right Nothing -> go
625− Right (Just Quit) -> outputStrLn quitMessage
626− Right (Just c') -> runPSCI (loadAllImportedModules >> handleCommand c') >> go
627−
628−multiLineMode :: Parser Bool
629−multiLineMode = switch $
630− long "multi-line-mode"
631− <> short 'm'
632− <> Opts.help "Run in multi-line mode (use ^D to terminate commands)"
633−
634−inputFile :: Parser FilePath
635−inputFile = strArgument $
636− metavar "FILE"
637− <> Opts.help "Optional .purs files to load on start"
638−
639−nodeFlagsFlag :: Parser [String]
640−nodeFlagsFlag = option parser $
641− long "node-opts"
642− <> metavar "NODE_OPTS"
643− <> Opts.help "Flags to pass to node, separated by spaces"
644− where
645− parser = words <$> str
646−
647−psciOptions :: Parser PSCiOptions
648−psciOptions = PSCiOptions <$> multiLineMode
649− <*> many inputFile
650− <*> nodeFlagsFlag
651−
652−main :: IO ()
653−main = execParser opts >>= loop
654− where
655− opts = info (version <*> helper <*> psciOptions) infoModList
656− infoModList = fullDesc <> headerInfo <> footerInfo
657− headerInfo = header "psci - Interactive mode for PureScript"
658− footerInfo = footer $ "psci " ++ showVersion Paths.version
659−
660− version :: Parser (a -> a)
661− 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−180
@@ -1,180 +0,0 @@
1−name: purescript
2−version: 0.6.8
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.4.0 && < 0.5,
35− utf8-string >= 1 && < 2,
36− pattern-arrows >= 0.0.2 && < 0.1,
37− file-embed >= 0.0.7 && < 0.0.8,
38− time -any
39− exposed-modules: Language.PureScript
40− Language.PureScript.AST
41− Language.PureScript.AST.Binders
42− Language.PureScript.AST.Declarations
43− Language.PureScript.AST.Operators
44− Language.PureScript.AST.SourcePos
45− Language.PureScript.AST.Traversals
46− Language.PureScript.CodeGen
47− Language.PureScript.CodeGen.Externs
48− Language.PureScript.CodeGen.JS
49− Language.PureScript.CodeGen.JS.AST
50− Language.PureScript.CodeGen.JS.Common
51− Language.PureScript.CodeGen.JS.Optimizer
52− Language.PureScript.CodeGen.JS.Optimizer.Blocks
53− Language.PureScript.CodeGen.JS.Optimizer.Common
54− Language.PureScript.CodeGen.JS.Optimizer.Inliner
55− Language.PureScript.CodeGen.JS.Optimizer.MagicDo
56− Language.PureScript.CodeGen.JS.Optimizer.TCO
57− Language.PureScript.CodeGen.JS.Optimizer.Unused
58− Language.PureScript.Constants
59− Language.PureScript.CoreFn
60− Language.PureScript.CoreFn.Ann
61− Language.PureScript.CoreFn.Binders
62− Language.PureScript.CoreFn.Desugar
63− Language.PureScript.CoreFn.Expr
64− Language.PureScript.CoreFn.Literals
65− Language.PureScript.CoreFn.Meta
66− Language.PureScript.CoreFn.Module
67− Language.PureScript.CoreFn.Traversals
68− Language.PureScript.Comments
69− Language.PureScript.DeadCodeElimination
70− Language.PureScript.Environment
71− Language.PureScript.Errors
72− Language.PureScript.Kinds
73− Language.PureScript.ModuleDependencies
74− Language.PureScript.Names
75− Language.PureScript.Options
76− Language.PureScript.Parser
77− Language.PureScript.Parser.Lexer
78− Language.PureScript.Parser.Common
79− Language.PureScript.Parser.Declarations
80− Language.PureScript.Parser.Kinds
81− Language.PureScript.Parser.State
82− Language.PureScript.Parser.Types
83− Language.PureScript.Pretty
84− Language.PureScript.Pretty.Common
85− Language.PureScript.Pretty.JS
86− Language.PureScript.Pretty.Kinds
87− Language.PureScript.Pretty.Types
88− Language.PureScript.Pretty.Values
89− Language.PureScript.Renamer
90− Language.PureScript.Sugar
91− Language.PureScript.Sugar.BindingGroups
92− Language.PureScript.Sugar.CaseDeclarations
93− Language.PureScript.Sugar.DoNotation
94− Language.PureScript.Sugar.Names
95− Language.PureScript.Sugar.ObjectWildcards
96− Language.PureScript.Sugar.Operators
97− Language.PureScript.Sugar.TypeClasses
98− Language.PureScript.Sugar.TypeDeclarations
99− Language.PureScript.Traversals
100− Language.PureScript.TypeChecker
101− Language.PureScript.TypeChecker.Entailment
102− Language.PureScript.TypeChecker.Kinds
103− Language.PureScript.TypeChecker.Monad
104− Language.PureScript.TypeChecker.Rows
105− Language.PureScript.TypeChecker.Skolems
106− Language.PureScript.TypeChecker.Subsumption
107− Language.PureScript.TypeChecker.Synonyms
108− Language.PureScript.TypeChecker.Types
109− Language.PureScript.TypeChecker.Unify
110− Language.PureScript.TypeClassDictionaries
111− Language.PureScript.Types
112−
113− Control.Monad.Unify
114− Control.Monad.Supply
115− Control.Monad.Supply.Class
116− exposed: True
117− buildable: True
118− hs-source-dirs: src
119− other-modules: Paths_purescript
120− ghc-options: -Wall -O2
121−
122−executable psc
123− build-depends: base >=4 && <5, containers -any, directory -any, filepath -any,
124− mtl -any, optparse-applicative >= 0.10.0, parsec -any, purescript -any,
125− transformers -any
126− main-is: Main.hs
127− buildable: True
128− hs-source-dirs: psc
129− other-modules:
130− ghc-options: -Wall -O2 -fno-warn-unused-do-bind
131−
132−executable psc-make
133− build-depends: base >=4 && <5, containers -any, directory -any, filepath -any,
134− mtl -any, optparse-applicative >= 0.10.0, parsec -any, purescript -any,
135− transformers -any
136− main-is: Main.hs
137− buildable: True
138− hs-source-dirs: psc-make
139− other-modules:
140− ghc-options: -Wall -O2 -fno-warn-unused-do-bind
141−
142−executable psci
143− build-depends: base >=4 && <5, containers -any, directory -any, filepath -any,
144− mtl -any, optparse-applicative >= 0.10.0, parsec -any,
145− haskeline >= 0.7.0.0, purescript -any, transformers -any,
146− process -any
147−
148− main-is: Main.hs
149− buildable: True
150− hs-source-dirs: psci
151− other-modules: Commands
152− Parser
153− ghc-options: -Wall -O2
154−
155−executable psc-docs
156− build-depends: base >=4 && <5, purescript -any,
157− optparse-applicative >= 0.10.0, process -any, mtl -any
158− main-is: Main.hs
159− buildable: True
160− hs-source-dirs: psc-docs
161− other-modules:
162− ghc-options: -Wall -O2
163−
164−executable psc-hierarchy
165− build-depends: base >=4 && <5, purescript -any, optparse-applicative >= 0.10.0,
166− process -any, mtl -any, parsec -any, filepath -any, directory -any
167− main-is: Main.hs
168− buildable: True
169− hs-source-dirs: hierarchy
170− other-modules:
171− ghc-options: -Wall -O2
172−
173−test-suite tests
174− build-depends: base >=4 && <5, containers -any, directory -any,
175− filepath -any, mtl -any, parsec -any, purescript -any,
176− transformers -any, process -any
177− type: exitcode-stdio-1.0
178− main-is: Main.hs
179− buildable: True
180− 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/Control/Monad/Supply.hsdeleted−43
@@ -1,43 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Control.Monad.Supply
4−-- Copyright : (c) Phil Freeman 2014
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- |
12−-- Fresh variable supply
13−--
14−-----------------------------------------------------------------------------
15−
16−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
17−
18−module Control.Monad.Supply where
19−
20−import Data.Functor.Identity
21−
22−import Control.Applicative
23−import Control.Monad.State
24−import Control.Monad.Except
25−import Control.Monad.Reader
26−import Control.Monad.Writer
27−
28−newtype SupplyT m a = SupplyT { unSupplyT :: StateT Integer m a }
29− deriving (Functor, Applicative, Monad, MonadTrans, MonadError e, MonadWriter w, MonadReader r)
30−
31−runSupplyT :: Integer -> SupplyT m a -> m (a, Integer)
32−runSupplyT n = flip runStateT n . unSupplyT
33−
34−evalSupplyT :: (Functor m) => Integer -> SupplyT m a -> m a
35−evalSupplyT n = fmap fst . runSupplyT n
36−
37−type Supply = SupplyT Identity
38−
39−runSupply :: Integer -> Supply a -> (a, Integer)
40−runSupply n = runIdentity . runSupplyT n
41−
42−evalSupply :: Integer -> Supply a -> a
43−evalSupply n = runIdentity . evalSupplyT n
src/Control/Monad/Supply/Class.hsdeleted−36
@@ -1,36 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Control.Monad.Supply.Class
4−-- Copyright : (c) PureScript 2015
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- |
12−-- A class for monads supporting a supply of fresh names
13−--
14−-----------------------------------------------------------------------------
15−
16−{-# LANGUAGE MultiParamTypeClasses #-}
17−
18−module Control.Monad.Supply.Class where
19−
20−import Control.Monad.Supply
21−import Control.Monad.State
22−
23−class (Monad m) => MonadSupply m where
24− fresh :: m Integer
25−
26−instance (Monad m) => MonadSupply (SupplyT m) where
27− fresh = SupplyT $ do
28− n <- get
29− put (n + 1)
30− return n
31−
32−instance (MonadSupply m) => MonadSupply (StateT s m) where
33− fresh = lift fresh
34−
35−freshName :: (MonadSupply m) => m String
36−freshName = liftM (('_' :) . show) fresh
src/Control/Monad/Unify.hsdeleted−155
@@ -1,155 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Control.Monad.Unify
4−-- Copyright : (c) Phil Freeman 2013
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- |
12−--
13−--
14−-----------------------------------------------------------------------------
15−
16−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
17−{-# LANGUAGE FlexibleInstances #-}
18−{-# LANGUAGE FlexibleContexts #-}
19−{-# LANGUAGE DeriveDataTypeable #-}
20−{-# LANGUAGE MultiParamTypeClasses #-}
21−{-# LANGUAGE FunctionalDependencies #-}
22−{-# LANGUAGE UndecidableInstances #-}
23−{-# LANGUAGE OverloadedStrings #-}
24−
25−module Control.Monad.Unify where
26−
27−import Data.String (IsString)
28−import Data.Monoid
29−
30−import Control.Applicative
31−import Control.Monad.State
32−import Control.Monad.Error.Class
33−
34−import Data.HashMap.Strict as M
35−
36−-- |
37−-- Untyped unification variables
38−--
39−type Unknown = Int
40−
41−-- |
42−-- A type which can contain unification variables
43−--
44−class Partial t where
45− unknown :: Unknown -> t
46− isUnknown :: t -> Maybe Unknown
47− unknowns :: t -> [Unknown]
48− ($?) :: Substitution t -> t -> t
49−
50−-- |
51−-- Identifies types which support unification
52−--
53−class (Partial t) => Unifiable m t | t -> m where
54− (=?=) :: t -> t -> UnifyT t m ()
55−
56−-- |
57−-- A substitution maintains a mapping from unification variables to their values
58−--
59−data Substitution t = Substitution { runSubstitution :: M.HashMap Int t }
60−
61−instance (Partial t) => Monoid (Substitution t) where
62− mempty = Substitution M.empty
63− s1 `mappend` s2 = Substitution $
64− M.map (s2 $?) (runSubstitution s1) `M.union`
65− M.map (s1 $?) (runSubstitution s2)
66−
67−-- |
68−-- State required for type checking
69−--
70−data UnifyState t = UnifyState {
71− -- |
72− -- The next fresh unification variable
73− --
74− unifyNextVar :: Int
75− -- |
76− -- The current substitution
77− --
78− , unifyCurrentSubstitution :: Substitution t
79− }
80−
81−-- |
82−-- An empty @UnifyState@
83−--
84−defaultUnifyState :: (Partial t) => UnifyState t
85−defaultUnifyState = UnifyState 0 mempty
86−
87−-- |
88−-- The type checking monad, which provides the state of the type checker, and error reporting capabilities
89−--
90−newtype UnifyT t m a = UnifyT { unUnify :: (StateT (UnifyState t) m) a }
91− deriving (Functor, Monad, Applicative, Alternative, MonadPlus)
92−
93−instance (MonadState s m) => MonadState s (UnifyT t m) where
94− get = UnifyT . lift $ get
95− put = UnifyT . lift . put
96−
97−instance (MonadError e m) => MonadError e (UnifyT t m) where
98− throwError = UnifyT . throwError
99− catchError e f = UnifyT $ catchError (unUnify e) (unUnify . f)
100−
101−-- |
102−-- Run a computation in the Unify monad, failing with an error, or succeeding with a return value and the new next unification variable
103−--
104−runUnify :: UnifyState t -> UnifyT t m a -> m (a, UnifyState t)
105−runUnify s = flip runStateT s . unUnify
106−
107−-- |
108−-- Substitute a single unification variable
109−--
110−substituteOne :: (Partial t) => Unknown -> t -> Substitution t
111−substituteOne u t = Substitution $ M.singleton u t
112−
113−-- |
114−-- Replace a unification variable with the specified value in the current substitution
115−--
116−(=:=) :: (IsString e, Monad m, MonadError e m, Unifiable m t) => Unknown -> t -> UnifyT t m ()
117−(=:=) u t' = do
118− st <- UnifyT get
119− let sub = unifyCurrentSubstitution st
120− let t = sub $? t'
121− occursCheck u t
122− let current = sub $? unknown u
123− case isUnknown current of
124− Just u1 | u1 == u -> return ()
125− _ -> current =?= t
126− UnifyT $ modify $ \s -> s { unifyCurrentSubstitution = substituteOne u t <> unifyCurrentSubstitution s }
127−
128−-- |
129−-- Perform the occurs check, to make sure a unification variable does not occur inside a value
130−--
131−occursCheck :: (IsString e, Monad m, MonadError e m, Partial t) => Unknown -> t -> UnifyT t m ()
132−occursCheck u t =
133− case isUnknown t of
134− Nothing -> when (u `elem` unknowns t) $ UnifyT . lift . throwError $ "Occurs check fails"
135− _ -> return ()
136−
137−-- |
138−-- Generate a fresh untyped unification variable
139−--
140−fresh' :: (Monad m) => UnifyT t m Unknown
141−fresh' = do
142− st <- UnifyT get
143− UnifyT $ modify $ \s -> s { unifyNextVar = succ (unifyNextVar s) }
144− return $ unifyNextVar st
145−
146−-- |
147−-- Generate a fresh unification variable at a specific type
148−--
149−fresh :: (Monad m, Partial t) => UnifyT t m t
150−fresh = do
151− u <- fresh'
152− return $ unknown u
153−
154−
155−
src/Language/PureScript.hsdeleted−269
@@ -1,269 +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 #-}
17−{-# LANGUAGE QuasiQuotes #-}
18−{-# LANGUAGE TemplateHaskell #-}
19−{-# LANGUAGE FlexibleContexts #-}
20−{-# LANGUAGE ScopedTypeVariables #-}
21−
22−module Language.PureScript
23− ( module P
24− , compile
25− , compile'
26− , RebuildPolicy(..)
27− , MonadMake(..)
28− , make
29− , prelude
30− ) where
31−
32−import Data.FileEmbed (embedFile)
33−import Data.Function (on)
34−import Data.List (sortBy, groupBy, intercalate)
35−import Data.Maybe (fromMaybe)
36−import Data.Time.Clock
37−import qualified Data.Traversable as T (traverse)
38−import qualified Data.ByteString.UTF8 as BU
39−import qualified Data.Map as M
40−import qualified Data.Set as S
41−
42−import Control.Applicative
43−import Control.Arrow ((&&&))
44−import Control.Monad.Except
45−import Control.Monad.Reader
46−
47−import System.FilePath ((</>))
48−
49−import Language.PureScript.AST as P
50−import Language.PureScript.Comments as P
51−import Language.PureScript.CodeGen as P
52−import Language.PureScript.DeadCodeElimination as P
53−import Language.PureScript.Environment as P
54−import Language.PureScript.Errors as P
55−import Language.PureScript.Kinds as P
56−import Language.PureScript.ModuleDependencies as P
57−import Language.PureScript.Names as P
58−import Language.PureScript.Options as P
59−import Language.PureScript.Parser as P
60−import Language.PureScript.Pretty as P
61−import Language.PureScript.Renamer as P
62−import Language.PureScript.Sugar as P
63−import Control.Monad.Supply as P
64−import Language.PureScript.TypeChecker as P
65−import Language.PureScript.Types as P
66−import qualified Language.PureScript.CoreFn as CoreFn
67−import qualified Language.PureScript.Constants as C
68−
69−-- |
70−-- Compile a collection of modules
71−--
72−-- The compilation pipeline proceeds as follows:
73−--
74−-- * Sort the modules based on module dependencies, checking for cyclic dependencies.
75−--
76−-- * Perform a set of desugaring passes.
77−--
78−-- * Type check, and elaborate values to include type annotations and type class dictionaries.
79−--
80−-- * Regroup values to take into account new value dependencies introduced by elaboration.
81−--
82−-- * Eliminate dead code.
83−--
84−-- * Generate Javascript, and perform optimization passes.
85−--
86−-- * Pretty-print the generated Javascript
87−--
88−compile :: (Functor m, Applicative m, MonadError String m, MonadReader (Options Compile) m)
89− => [Module] -> [String] -> m (String, String, Environment)
90−compile = compile' initEnvironment
91−
92−compile' :: (Functor m, Applicative m, MonadError String m, MonadReader (Options Compile) m)
93− => Environment -> [Module] -> [String] -> m (String, String, Environment)
94−compile' env ms prefix = do
95− noPrelude <- asks optionsNoPrelude
96− additional <- asks optionsAdditional
97− mainModuleIdent <- asks (fmap moduleNameFromString . optionsMain)
98− (sorted, _) <- sortModules $ map importPrim $ if noPrelude then ms else map importPrelude ms
99− (desugared, nextVar) <- stringifyErrorStack True $ runSupplyT 0 $ desugar sorted
100− (elaborated, env') <- runCheck' env $ forM desugared $ typeCheckModule mainModuleIdent
101− regrouped <- stringifyErrorStack True $ createBindingGroupsModule . collapseBindingGroupsModule $ elaborated
102− let corefn = map (CoreFn.moduleToCoreFn env') regrouped
103− let entryPoints = moduleNameFromString `map` entryPointModules additional
104− let elim = if null entryPoints then corefn else eliminateDeadCode entryPoints corefn
105− let renamed = renameInModules elim
106− let codeGenModuleNames = moduleNameFromString `map` codeGenModules additional
107− let modulesToCodeGen = if null codeGenModuleNames then renamed else filter (\(CoreFn.Module _ mn _ _ _ _) -> mn `elem` codeGenModuleNames) renamed
108− js <- concat <$> (evalSupplyT nextVar $ T.traverse moduleToJs modulesToCodeGen)
109− let exts = intercalate "\n" . map (`moduleToPs` env') $ regrouped
110− js' <- generateMain env' js
111− let pjs = unlines $ map ("// " ++) prefix ++ [prettyPrintJS js']
112− return (pjs, exts, env')
113−
114−generateMain :: (MonadError String m, MonadReader (Options Compile) m) => Environment -> [JS] -> m [JS]
115−generateMain env js = do
116− main <- asks optionsMain
117− additional <- asks optionsAdditional
118− case moduleNameFromString <$> main of
119− Just mmi -> do
120− when ((mmi, Ident C.main) `M.notMember` names env) $
121− throwError $ show mmi ++ "." ++ C.main ++ " is undefined"
122− return $ js ++ [JSApp (JSAccessor C.main (JSAccessor (moduleNameToJs mmi) (JSVar (browserNamespace additional)))) []]
123− _ -> return js
124−
125−-- |
126−-- A type class which collects the IO actions we need to be able to run in "make" mode
127−--
128−class (MonadReader (P.Options P.Make) m, MonadError String m) => MonadMake m where
129− -- |
130− -- Get a file timestamp
131− --
132− getTimestamp :: FilePath -> m (Maybe UTCTime)
133−
134− -- |
135− -- Read a file as a string
136− --
137− readTextFile :: FilePath -> m String
138−
139− -- |
140− -- Write a text file
141− --
142− writeTextFile :: FilePath -> String -> m ()
143−
144− -- |
145− -- Respond to a progress update
146− --
147− progress :: String -> m ()
148−
149−-- |
150−-- Determines when to rebuild a module
151−--
152−data RebuildPolicy
153− -- | Never rebuild this module
154− = RebuildNever
155− -- | Always rebuild this module
156− | RebuildAlways deriving (Show, Eq, Ord)
157−
158−-- Traverse (Either e) instance (base 4.7)
159−traverseEither :: Applicative f => (a -> f b) -> Either e a -> f (Either e b)
160−traverseEither _ (Left x) = pure (Left x)
161−traverseEither f (Right y) = Right <$> f y
162−
163−-- |
164−-- Compiles in "make" mode, compiling each module separately to a js files and an externs file
165−--
166−-- If timestamps have not changed, the externs file can be used to provide the module's types without
167−-- having to typecheck the module again.
168−--
169−make :: forall m. (Functor m, Applicative m, Monad m, MonadMake m)
170− => FilePath -> [(Either RebuildPolicy FilePath, Module)] -> [String] -> m Environment
171−make outputDir ms prefix = do
172− noPrelude <- asks optionsNoPrelude
173− let filePathMap = M.fromList (map (\(fp, Module _ mn _ _) -> (mn, fp)) ms)
174−
175− (sorted, graph) <- sortModules $ map importPrim $ if noPrelude then map snd ms else map (importPrelude . snd) ms
176−
177− toRebuild <- foldM (\s (Module _ moduleName' _ _) -> do
178− let filePath = runModuleName moduleName'
179−
180− jsFile = outputDir </> filePath </> "index.js"
181− externsFile = outputDir </> filePath </> "externs.purs"
182− inputFile = fromMaybe (error "Module has no filename in 'make'") $ M.lookup moduleName' filePathMap
183−
184− jsTimestamp <- getTimestamp jsFile
185− externsTimestamp <- getTimestamp externsFile
186− inputTimestamp <- traverseEither getTimestamp inputFile
187−
188− return $ case (inputTimestamp, jsTimestamp, externsTimestamp) of
189− (Right (Just t1), Just t2, Just t3) | t1 < min t2 t3 -> s
190− (Left RebuildNever, Just _, Just _) -> s
191− _ -> S.insert moduleName' s) S.empty sorted
192−
193− marked <- rebuildIfNecessary (reverseDependencies graph) toRebuild sorted
194−
195− (desugared, nextVar) <- stringifyErrorStack True $ runSupplyT 0 $ zip (map fst marked) <$> desugar (map snd marked)
196−
197− evalSupplyT nextVar $ go initEnvironment desugared
198−
199− where
200− go :: Environment -> [(Bool, Module)] -> SupplyT m Environment
201− go env [] = return env
202− go env ((False, m) : ms') = do
203− (_, env') <- lift . runCheck' env $ typeCheckModule Nothing m
204−
205− go env' ms'
206− go env ((True, m@(Module coms moduleName' _ exps)) : ms') = do
207− let filePath = runModuleName moduleName'
208− jsFile = outputDir </> filePath </> "index.js"
209− externsFile = outputDir </> filePath </> "externs.purs"
210−
211− lift . progress $ "Compiling " ++ runModuleName moduleName'
212−
213− (Module _ _ elaborated _, env') <- lift . runCheck' env $ typeCheckModule Nothing m
214−
215− regrouped <- stringifyErrorStack True . createBindingGroups moduleName' . collapseBindingGroups $ elaborated
216−
217− let mod' = Module coms moduleName' regrouped exps
218− let corefn = CoreFn.moduleToCoreFn env' mod'
219− let [renamed] = renameInModules [corefn]
220−
221− pjs <- prettyPrintJS <$> moduleToJs renamed
222− let js = unlines $ map ("// " ++) prefix ++ [pjs]
223− let exts = unlines $ map ("-- " ++) prefix ++ [moduleToPs mod' env']
224−
225− lift $ writeTextFile jsFile js
226− lift $ writeTextFile externsFile exts
227−
228− go env' ms'
229−
230− rebuildIfNecessary :: M.Map ModuleName [ModuleName] -> S.Set ModuleName -> [Module] -> m [(Bool, Module)]
231− rebuildIfNecessary _ _ [] = return []
232− rebuildIfNecessary graph toRebuild (m@(Module _ moduleName' _ _) : ms') | moduleName' `S.member` toRebuild = do
233− let deps = fromMaybe [] $ moduleName' `M.lookup` graph
234− toRebuild' = toRebuild `S.union` S.fromList deps
235− (:) (True, m) <$> rebuildIfNecessary graph toRebuild' ms'
236− rebuildIfNecessary graph toRebuild (Module _ moduleName' _ _ : ms') = do
237− let externsFile = outputDir </> runModuleName moduleName' </> "externs.purs"
238− externs <- readTextFile externsFile
239− externsModules <- fmap (map snd) . either (throwError . show) return $ P.parseModulesFromFiles id [(externsFile, externs)]
240− case externsModules of
241− [m'@(Module _ moduleName'' _ _)] | moduleName'' == moduleName' -> (:) (False, m') <$> rebuildIfNecessary graph toRebuild ms'
242− _ -> throwError $ "Externs file " ++ externsFile ++ " was invalid"
243−
244−reverseDependencies :: ModuleGraph -> M.Map ModuleName [ModuleName]
245−reverseDependencies g = combine [ (dep, mn) | (mn, deps) <- g, dep <- deps ]
246− where
247− combine :: (Ord a) => [(a, b)] -> M.Map a [b]
248− combine = M.fromList . map ((fst . head) &&& map snd) . groupBy ((==) `on` fst) . sortBy (compare `on` fst)
249−
250−-- |
251−-- Add an import declaration for a module if it does not already explicitly import it.
252−--
253−addDefaultImport :: ModuleName -> Module -> Module
254−addDefaultImport toImport m@(Module coms mn decls exps) =
255− if isExistingImport `any` decls || mn == toImport then m
256− else Module coms mn (ImportDeclaration toImport Unqualified Nothing : decls) exps
257− where
258− isExistingImport (ImportDeclaration mn' _ _) | mn' == toImport = True
259− isExistingImport (PositionedDeclaration _ _ d) = isExistingImport d
260− isExistingImport _ = False
261−
262−importPrim :: Module -> Module
263−importPrim = addDefaultImport (ModuleName [ProperName C.prim])
264−
265−importPrelude :: Module -> Module
266−importPrelude = addDefaultImport (ModuleName [ProperName C.prelude])
267−
268−prelude :: String
269−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−447
@@ -1,447 +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 comments about the module, a module name,
34−-- a list of declarations, and a list of the declarations that are
35−-- explicitly exported. If the export list is Nothing, everything is exported.
36−--
37−data Module = Module [Comment] ModuleName [Declaration] (Maybe [DeclarationRef]) deriving (Show, D.Data, D.Typeable)
38−
39−-- | Return a module's name.
40−getModuleName :: Module -> ModuleName
41−getModuleName (Module _ name _ _) = name
42−
43−-- |
44−-- Test if a declaration is exported, given a module's export list.
45−--
46−isExported :: Maybe [DeclarationRef] -> Declaration -> Bool
47−isExported Nothing _ = True
48−isExported _ TypeInstanceDeclaration{} = True
49−isExported exps (PositionedDeclaration _ _ d) = isExported exps d
50−isExported (Just exps) decl = any (matches decl) exps
51− where
52− matches (TypeDeclaration ident _) (ValueRef ident') = ident == ident'
53− matches (ValueDeclaration ident _ _ _) (ValueRef ident') = ident == ident'
54− matches (ExternDeclaration _ ident _ _) (ValueRef ident') = ident == ident'
55− matches (DataDeclaration _ ident _ _) (TypeRef ident' _) = ident == ident'
56− matches (ExternDataDeclaration ident _) (TypeRef ident' _) = ident == ident'
57− matches (TypeSynonymDeclaration ident _ _) (TypeRef ident' _) = ident == ident'
58− matches (TypeClassDeclaration ident _ _ _) (TypeClassRef ident') = ident == ident'
59− matches (PositionedDeclaration _ _ d) r = d `matches` r
60− matches d (PositionedDeclarationRef _ _ r) = d `matches` r
61− matches _ _ = False
62−
63−exportedDeclarations :: Module -> [Declaration]
64−exportedDeclarations (Module _ _ decls exps) = filter (isExported exps) (flattenDecls decls)
65−
66−-- |
67−-- Test if a data constructor for a given type is exported, given a module's export list.
68−--
69−isDctorExported :: ProperName -> Maybe [DeclarationRef] -> ProperName -> Bool
70−isDctorExported _ Nothing _ = True
71−isDctorExported ident (Just exps) ctor = test `any` exps
72− where
73− test (PositionedDeclarationRef _ _ d) = test d
74− test (TypeRef ident' Nothing) = ident == ident'
75− test (TypeRef ident' (Just ctors)) = ident == ident' && ctor `elem` ctors
76− test _ = False
77−
78−-- |
79−-- Return the exported data constructors for a given type.
80−--
81−exportedDctors :: Module -> ProperName -> [ProperName]
82−exportedDctors (Module _ _ decls exps) ident =
83− filter (isDctorExported ident exps) dctors
84− where
85− dctors = concatMap getDctors (flattenDecls decls)
86− getDctors (DataDeclaration _ _ _ ctors) = map fst ctors
87− getDctors (PositionedDeclaration _ _ d) = getDctors d
88− getDctors _ = []
89−
90−-- |
91−-- An item in a list of explicit imports or exports
92−--
93−data DeclarationRef
94− -- |
95− -- A type constructor with data constructors
96− --
97− = TypeRef ProperName (Maybe [ProperName])
98− -- |
99− -- A value
100− --
101− | ValueRef Ident
102− -- |
103− -- A type class
104− --
105− | TypeClassRef ProperName
106− -- |
107− -- A type class instance, created during typeclass desugaring (name, class name, instance types)
108− --
109− | TypeInstanceRef Ident
110− -- |
111− -- A declaration reference with source position information
112− --
113− | PositionedDeclarationRef SourceSpan [Comment] DeclarationRef
114− deriving (Show, D.Data, D.Typeable)
115−
116−instance Eq DeclarationRef where
117− (TypeRef name dctors) == (TypeRef name' dctors') = name == name' && dctors == dctors'
118− (ValueRef name) == (ValueRef name') = name == name'
119− (TypeClassRef name) == (TypeClassRef name') = name == name'
120− (TypeInstanceRef name) == (TypeInstanceRef name') = name == name'
121− (PositionedDeclarationRef _ _ r) == r' = r == r'
122− r == (PositionedDeclarationRef _ _ r') = r == r'
123− _ == _ = False
124−
125−-- |
126−-- The data type which specifies type of import declaration
127−--
128−data ImportDeclarationType
129− -- |
130− -- Unqualified import
131− --
132− = Unqualified
133− -- |
134− -- Qualified import with a list of references to import
135− --
136− | Qualifying [DeclarationRef]
137− -- |
138− -- Import with hiding clause with a list of references to hide
139− --
140− | Hiding [DeclarationRef]
141− deriving (Show, D.Data, D.Typeable)
142−
143−-- |
144−-- The data type of declarations
145−--
146−data Declaration
147− -- |
148− -- A data type declaration (data or newtype, name, arguments, data constructors)
149− --
150− = DataDeclaration DataDeclType ProperName [(String, Maybe Kind)] [(ProperName, [Type])]
151− -- |
152− -- A minimal mutually recursive set of data type declarations
153− --
154− | DataBindingGroupDeclaration [Declaration]
155− -- |
156− -- A type synonym declaration (name, arguments, type)
157− --
158− | TypeSynonymDeclaration ProperName [(String, Maybe Kind)] Type
159− -- |
160− -- A type declaration for a value (name, ty)
161− --
162− | TypeDeclaration Ident Type
163− -- |
164− -- A value declaration (name, top-level binders, optional guard, value)
165− --
166− | ValueDeclaration Ident NameKind [Binder] (Either [(Guard, Expr)] Expr)
167− -- |
168− -- A minimal mutually recursive set of value declarations
169− --
170− | BindingGroupDeclaration [(Ident, NameKind, Expr)]
171− -- |
172− -- A foreign import declaration (type, name, optional inline Javascript, type)
173− --
174− | ExternDeclaration ForeignImportType Ident (Maybe JS) Type
175− -- |
176− -- A data type foreign import (name, kind)
177− --
178− | ExternDataDeclaration ProperName Kind
179− -- |
180− -- A type class instance foreign import
181− --
182− | ExternInstanceDeclaration Ident [Constraint] (Qualified ProperName) [Type]
183− -- |
184− -- A fixity declaration (fixity data, operator name)
185− --
186− | FixityDeclaration Fixity String
187− -- |
188− -- A module import (module name, qualified/unqualified/hiding, optional "qualified as" name)
189− --
190− | ImportDeclaration ModuleName ImportDeclarationType (Maybe ModuleName)
191− -- |
192− -- A type class declaration (name, argument, implies, member declarations)
193− --
194− | TypeClassDeclaration ProperName [(String, Maybe Kind)] [Constraint] [Declaration]
195− -- |
196− -- A type instance declaration (name, dependencies, class name, instance types, member
197− -- declarations)
198− --
199− | TypeInstanceDeclaration Ident [Constraint] (Qualified ProperName) [Type] [Declaration]
200− -- |
201− -- A declaration with source position information
202− --
203− | PositionedDeclaration SourceSpan [Comment] Declaration
204− deriving (Show, D.Data, D.Typeable)
205−
206−-- |
207−-- Test if a declaration is a value declaration
208−--
209−isValueDecl :: Declaration -> Bool
210−isValueDecl ValueDeclaration{} = True
211−isValueDecl (PositionedDeclaration _ _ d) = isValueDecl d
212−isValueDecl _ = False
213−
214−-- |
215−-- Test if a declaration is a data type or type synonym declaration
216−--
217−isDataDecl :: Declaration -> Bool
218−isDataDecl DataDeclaration{} = True
219−isDataDecl TypeSynonymDeclaration{} = True
220−isDataDecl (PositionedDeclaration _ _ d) = isDataDecl d
221−isDataDecl _ = False
222−
223−-- |
224−-- Test if a declaration is a module import
225−--
226−isImportDecl :: Declaration -> Bool
227−isImportDecl ImportDeclaration{} = True
228−isImportDecl (PositionedDeclaration _ _ d) = isImportDecl d
229−isImportDecl _ = False
230−
231−-- |
232−-- Test if a declaration is a data type foreign import
233−--
234−isExternDataDecl :: Declaration -> Bool
235−isExternDataDecl ExternDataDeclaration{} = True
236−isExternDataDecl (PositionedDeclaration _ _ d) = isExternDataDecl d
237−isExternDataDecl _ = False
238−
239−-- |
240−-- Test if a declaration is a type class instance foreign import
241−--
242−isExternInstanceDecl :: Declaration -> Bool
243−isExternInstanceDecl ExternInstanceDeclaration{} = True
244−isExternInstanceDecl (PositionedDeclaration _ _ d) = isExternInstanceDecl d
245−isExternInstanceDecl _ = False
246−
247−-- |
248−-- Test if a declaration is a fixity declaration
249−--
250−isFixityDecl :: Declaration -> Bool
251−isFixityDecl FixityDeclaration{} = True
252−isFixityDecl (PositionedDeclaration _ _ d) = isFixityDecl d
253−isFixityDecl _ = False
254−
255−-- |
256−-- Test if a declaration is a foreign import
257−--
258−isExternDecl :: Declaration -> Bool
259−isExternDecl ExternDeclaration{} = True
260−isExternDecl (PositionedDeclaration _ _ d) = isExternDecl d
261−isExternDecl _ = False
262−
263−-- |
264−-- Test if a declaration is a type class or instance declaration
265−--
266−isTypeClassDeclaration :: Declaration -> Bool
267−isTypeClassDeclaration TypeClassDeclaration{} = True
268−isTypeClassDeclaration TypeInstanceDeclaration{} = True
269−isTypeClassDeclaration (PositionedDeclaration _ _ d) = isTypeClassDeclaration d
270−isTypeClassDeclaration _ = False
271−
272−-- |
273−-- Recursively flatten data binding groups in the list of declarations
274−flattenDecls :: [Declaration] -> [Declaration]
275−flattenDecls = concatMap flattenOne
276− where flattenOne :: Declaration -> [Declaration]
277− flattenOne (DataBindingGroupDeclaration decls) = concatMap flattenOne decls
278− flattenOne d = [d]
279−
280−-- |
281−-- A guard is just a boolean-valued expression that appears alongside a set of binders
282−--
283−type Guard = Expr
284−
285−-- |
286−-- Data type for expressions and terms
287−--
288−data Expr
289− -- |
290− -- A numeric literal
291− --
292− = NumericLiteral (Either Integer Double)
293− -- |
294− -- A string literal
295− --
296− | StringLiteral String
297− -- |
298− -- A boolean literal
299− --
300− | BooleanLiteral Bool
301− -- |
302− -- A prefix -, will be desugared
303− --
304− | UnaryMinus Expr
305− -- |
306− -- Binary operator application. During the rebracketing phase of desugaring, this data constructor
307− -- will be removed.
308− --
309− | BinaryNoParens Expr Expr Expr
310− -- |
311− -- Explicit parentheses. During the rebracketing phase of desugaring, this data constructor
312− -- will be removed.
313− --
314− | Parens Expr
315− -- |
316− -- Operator section. This will be removed during desugaring and replaced with a partially applied
317− -- operator or lambda to flip the arguments.
318− --
319− | OperatorSection Expr (Either Expr Expr)
320− -- |
321− -- An array literal
322− --
323− | ArrayLiteral [Expr]
324− -- |
325− -- An object literal
326− --
327− | ObjectLiteral [(String, Expr)]
328− -- |
329− -- An object constructor (object literal with underscores). This will be removed during
330− -- desugaring and expanded into a lambda that returns an object literal.
331− --
332− | ObjectConstructor [(String, Maybe Expr)]
333− -- |
334− -- An object property getter (e.g. `_.x`). This will be removed during
335− -- desugaring and expanded into a lambda that reads a property from an object.
336− --
337− | ObjectGetter String
338− -- |
339− -- An record property accessor expression
340− --
341− | Accessor String Expr
342− -- |
343− -- Partial record update
344− --
345− | ObjectUpdate Expr [(String, Expr)]
346− -- |
347− -- Partial record updater. This will be removed during desugaring and
348− -- expanded into a lambda that returns an object update.
349− --
350− | ObjectUpdater (Maybe Expr) [(String, Maybe Expr)]
351− -- |
352− -- Function introduction
353− --
354− | Abs (Either Ident Binder) Expr
355− -- |
356− -- Function application
357− --
358− | App Expr Expr
359− -- |
360− -- Variable
361− --
362− | Var (Qualified Ident)
363− -- |
364− -- Conditional (if-then-else expression)
365− --
366− | IfThenElse Expr Expr Expr
367− -- |
368− -- A data constructor
369− --
370− | Constructor (Qualified ProperName)
371− -- |
372− -- A case expression. During the case expansion phase of desugaring, top-level binders will get
373− -- desugared into case expressions, hence the need for guards and multiple binders per branch here.
374− --
375− | Case [Expr] [CaseAlternative]
376− -- |
377− -- A value with a type annotation
378− --
379− | TypedValue Bool Expr Type
380− -- |
381− -- A let binding
382− --
383− | Let [Declaration] Expr
384− -- |
385− -- A do-notation block
386− --
387− | Do [DoNotationElement]
388− -- |
389− -- An application of a typeclass dictionary constructor. The value should be
390− -- an ObjectLiteral.
391− --
392− | TypeClassDictionaryConstructorApp (Qualified ProperName) Expr
393− -- |
394− -- A placeholder for a type class dictionary to be inserted later. At the end of type checking, these
395− -- placeholders will be replaced with actual expressions representing type classes dictionaries which
396− -- can be evaluated at runtime. The constructor arguments represent (in order): whether or not to look
397− -- at superclass implementations when searching for a dictionary, the type class name and
398− -- instance type, and the type class dictionaries in scope.
399− --
400− | TypeClassDictionary Bool Constraint [TypeClassDictionaryInScope]
401− -- |
402− -- A typeclass dictionary accessor, the implementation is left unspecified until CoreFn desugaring.
403− --
404− | TypeClassDictionaryAccessor (Qualified ProperName) Ident
405− -- |
406− -- A placeholder for a superclass dictionary to be turned into a TypeClassDictionary during typechecking
407− --
408− | SuperClassDictionary (Qualified ProperName) [Type]
409− -- |
410− -- A value with source position information
411− --
412− | PositionedValue SourceSpan [Comment] Expr deriving (Show, D.Data, D.Typeable)
413−
414−-- |
415−-- An alternative in a case statement
416−--
417−data CaseAlternative = CaseAlternative
418− { -- |
419− -- A collection of binders with which to match the inputs
420− --
421− caseAlternativeBinders :: [Binder]
422− -- |
423− -- The result expression or a collect of guarded expressions
424− --
425− , caseAlternativeResult :: Either [(Guard, Expr)] Expr
426− } deriving (Show, D.Data, D.Typeable)
427−
428−-- |
429−-- A statement in a do-notation block
430−--
431−data DoNotationElement
432− -- |
433− -- A monadic value without a binder
434− --
435− = DoNotationValue Expr
436− -- |
437− -- A monadic value with a binder
438− --
439− | DoNotationBind Binder Expr
440− -- |
441− -- A let statement, i.e. a pure value with a binder
442− --
443− | DoNotationLet [Declaration]
444− -- |
445− -- A do notation element with source position information
446− --
447− | 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−362
@@ -1,362 +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 #-}
17−{-# LANGUAGE ViewPatterns #-}
18−{-# LANGUAGE FlexibleContexts #-}
19−{-# LANGUAGE ScopedTypeVariables #-}
20−
21−module Language.PureScript.CodeGen.JS (
22− module AST,
23− module Common,
24− moduleToJs
25−) where
26−
27−import Data.List ((\\), delete)
28−import Data.Maybe (mapMaybe)
29−import qualified Data.Traversable as T (traverse)
30−
31−import Control.Applicative
32−import Control.Arrow ((&&&))
33−import Control.Monad (foldM, replicateM, forM)
34−import Control.Monad.Reader (MonadReader, asks)
35−import Control.Monad.Supply.Class
36−
37−import Language.PureScript.CodeGen.JS.AST as AST
38−import Language.PureScript.CodeGen.JS.Common as Common
39−import Language.PureScript.CoreFn
40−import Language.PureScript.Names
41−import Language.PureScript.CodeGen.JS.Optimizer
42−import Language.PureScript.Options
43−import Language.PureScript.Traversals (sndM)
44−import qualified Language.PureScript.Constants as C
45−
46−-- |
47−-- Generate code in the simplified Javascript intermediate representation for all declarations in a
48−-- module.
49−--
50−moduleToJs :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m, MonadSupply m)
51− => Module Ann -> m [JS]
52−moduleToJs (Module coms name imps exps foreigns decls) = do
53− additional <- asks optionsAdditional
54− jsImports <- T.traverse importToJs . delete (ModuleName [ProperName C.prim]) . (\\ [name]) $ imps
55− let foreigns' = mapMaybe (\(_, js, _) -> js) foreigns
56− jsDecls <- mapM (bindToJs name) decls
57− optimized <- T.traverse (T.traverse optimize) jsDecls
58− let isModuleEmpty = null exps
59− let moduleBody = JSComment coms (JSStringLiteral "use strict") : jsImports ++ foreigns' ++ concat optimized
60− let exps' = JSObjectLiteral $ map (runIdent &&& JSVar . identToJs) exps
61− return $ case additional of
62− MakeOptions -> moduleBody ++ [JSAssignment (JSAccessor "exports" (JSVar "module")) exps']
63− CompileOptions ns _ _ | not isModuleEmpty ->
64− [ JSVariableIntroduction ns
65− (Just (JSBinary Or (JSVar ns) (JSObjectLiteral [])) )
66− , JSAssignment (JSAccessor (moduleNameToJs name) (JSVar ns))
67− (JSApp (JSFunction Nothing [] (JSBlock (moduleBody ++ [JSReturn exps']))) [])
68− ]
69− _ -> []
70−
71−-- |
72−-- Generates Javascript code for a module import.
73−--
74−importToJs :: (Monad m, MonadReader (Options mode) m) => ModuleName -> m JS
75−importToJs mn = do
76− additional <- asks optionsAdditional
77− let moduleBody = case additional of
78− MakeOptions -> JSApp (JSVar "require") [JSStringLiteral (runModuleName mn)]
79− CompileOptions ns _ _ -> JSAccessor (moduleNameToJs mn) (JSVar ns)
80− return $ JSVariableIntroduction (moduleNameToJs mn) (Just moduleBody)
81−
82−-- |
83−-- Generate code in the simplified Javascript intermediate representation for a declaration
84−--
85−bindToJs :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m, MonadSupply m)
86− => ModuleName -> Bind Ann -> m [JS]
87−bindToJs mp (NonRec ident val) = return <$> nonRecToJS mp ident val
88−bindToJs mp (Rec vals) = forM vals (uncurry (nonRecToJS mp))
89−
90−-- |
91−-- Generate code in the simplified Javascript intermediate representation for a single non-recursive
92−-- declaration.
93−--
94−-- The main purpose of this function is to handle code generation for comments.
95−--
96−nonRecToJS :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m, MonadSupply m)
97− => ModuleName -> Ident -> Expr Ann -> m JS
98−nonRecToJS m i e@(extractAnn -> (_, com, _, _)) | not (null com) = do
99− withoutComment <- asks optionsNoComments
100− if withoutComment
101− then nonRecToJS m i (modifyAnn removeComments e)
102− else JSComment com <$> nonRecToJS m i (modifyAnn removeComments e)
103−nonRecToJS mp ident val = do
104− js <- valueToJs mp val
105− return $ JSVariableIntroduction (identToJs ident) (Just js)
106−
107−
108−-- |
109−-- Generate code in the simplified Javascript intermediate representation for a variable based on a
110−-- PureScript identifier.
111−--
112−var :: Ident -> JS
113−var = JSVar . identToJs
114−
115−-- |
116−-- Generate code in the simplified Javascript intermediate representation for an accessor based on
117−-- a PureScript identifier. If the name is not valid in Javascript (symbol based, reserved name) an
118−-- indexer is returned.
119−--
120−accessor :: Ident -> JS -> JS
121−accessor (Ident prop) = accessorString prop
122−accessor (Op op) = JSIndexer (JSStringLiteral op)
123−
124−accessorString :: String -> JS -> JS
125−accessorString prop | identNeedsEscaping prop = JSIndexer (JSStringLiteral prop)
126− | otherwise = JSAccessor prop
127−
128−-- |
129−-- Generate code in the simplified Javascript intermediate representation for a value or expression.
130−--
131−valueToJs :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m, MonadSupply m)
132− => ModuleName -> Expr Ann -> m JS
133−valueToJs m (Literal _ l) =
134− literalToValueJS m l
135−valueToJs m (Var (_, _, _, Just (IsConstructor _ [])) name) =
136− return $ JSAccessor "value" $ qualifiedToJS m id name
137−valueToJs m (Var (_, _, _, Just (IsConstructor _ _)) name) =
138− return $ JSAccessor "create" $ qualifiedToJS m id name
139−valueToJs m (Accessor _ prop val) =
140− accessorString prop <$> valueToJs m val
141−valueToJs m (ObjectUpdate _ o ps) = do
142− obj <- valueToJs m o
143− sts <- mapM (sndM $ valueToJs m) ps
144− extendObj obj sts
145−valueToJs _ e@(Abs (_, _, _, Just IsTypeClassConstructor) _ _) =
146− let args = unAbs e
147− in return $ JSFunction Nothing (map identToJs args) (JSBlock $ map assign args)
148− where
149− unAbs :: Expr Ann -> [Ident]
150− unAbs (Abs _ arg val) = arg : unAbs val
151− unAbs _ = []
152− assign :: Ident -> JS
153− assign name = JSAssignment (accessorString (runIdent name) (JSVar "this"))
154− (var name)
155−valueToJs m (Abs _ arg val) = do
156− ret <- valueToJs m val
157− return $ JSFunction Nothing [identToJs arg] (JSBlock [JSReturn ret])
158−valueToJs m e@App{} = do
159− let (f, args) = unApp e []
160− args' <- mapM (valueToJs m) args
161− case f of
162− Var (_, _, _, Just IsNewtype) _ -> return (head args')
163− Var (_, _, _, Just (IsConstructor _ fields)) name | length args == length fields ->
164− return $ JSUnary JSNew $ JSApp (qualifiedToJS m id name) args'
165− Var (_, _, _, Just IsTypeClassConstructor) name ->
166− return $ JSUnary JSNew $ JSApp (qualifiedToJS m id name) args'
167− _ -> flip (foldl (\fn a -> JSApp fn [a])) args' <$> valueToJs m f
168− where
169− unApp :: Expr Ann -> [Expr Ann] -> (Expr Ann, [Expr Ann])
170− unApp (App _ val arg) args = unApp val (arg : args)
171− unApp other args = (other, args)
172−valueToJs m (Var _ ident) =
173− return $ varToJs m ident
174−valueToJs m (Case _ values binders) = do
175− vals <- mapM (valueToJs m) values
176− bindersToJs m binders vals
177−valueToJs m (Let _ ds val) = do
178− decls <- concat <$> mapM (bindToJs m) ds
179− ret <- valueToJs m val
180− return $ JSApp (JSFunction Nothing [] (JSBlock (decls ++ [JSReturn ret]))) []
181−valueToJs _ (Constructor (_, _, _, Just IsNewtype) _ (ProperName ctor) _) =
182− return $ JSVariableIntroduction ctor (Just $
183− JSObjectLiteral [("create",
184− JSFunction Nothing ["value"]
185− (JSBlock [JSReturn $ JSVar "value"]))])
186−valueToJs _ (Constructor _ _ (ProperName ctor) []) =
187− return $ iife ctor [ JSFunction (Just ctor) [] (JSBlock [])
188− , JSAssignment (JSAccessor "value" (JSVar ctor))
189− (JSUnary JSNew $ JSApp (JSVar ctor) []) ]
190−valueToJs _ (Constructor _ _ (ProperName ctor) fields) =
191− let constructor =
192− let body = [ JSAssignment (JSAccessor (identToJs f) (JSVar "this")) (var f) | f <- fields ]
193− in JSFunction (Just ctor) (identToJs `map` fields) (JSBlock body)
194− createFn =
195− let body = JSUnary JSNew $ JSApp (JSVar ctor) (var `map` fields)
196− in foldr (\f inner -> JSFunction Nothing [identToJs f] (JSBlock [JSReturn inner])) body fields
197− in return $ iife ctor [ constructor
198− , JSAssignment (JSAccessor "create" (JSVar ctor)) createFn
199− ]
200−
201−iife :: String -> [JS] -> JS
202−iife v exprs = JSApp (JSFunction Nothing [] (JSBlock $ exprs ++ [JSReturn $ JSVar v])) []
203−
204−literalToValueJS :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m, MonadSupply m)
205− => ModuleName -> Literal (Expr Ann) -> m JS
206−literalToValueJS _ (NumericLiteral n) = return $ JSNumericLiteral n
207−literalToValueJS _ (StringLiteral s) = return $ JSStringLiteral s
208−literalToValueJS _ (BooleanLiteral b) = return $ JSBooleanLiteral b
209−literalToValueJS m (ArrayLiteral xs) = JSArrayLiteral <$> mapM (valueToJs m) xs
210−literalToValueJS m (ObjectLiteral ps) = JSObjectLiteral <$> mapM (sndM (valueToJs m)) ps
211−
212−-- |
213−-- Shallow copy an object.
214−--
215−extendObj :: (Applicative m, Monad m, MonadSupply m) => JS -> [(String, JS)] -> m JS
216−extendObj obj sts = do
217− newObj <- freshName
218− key <- freshName
219− let
220− jsKey = JSVar key
221− jsNewObj = JSVar newObj
222− block = JSBlock (objAssign:copy:extend ++ [JSReturn jsNewObj])
223− objAssign = JSVariableIntroduction newObj (Just $ JSObjectLiteral [])
224− copy = JSForIn key obj $ JSBlock [JSIfElse cond assign Nothing]
225− cond = JSApp (JSAccessor "hasOwnProperty" obj) [jsKey]
226− assign = JSBlock [JSAssignment (JSIndexer jsKey jsNewObj) (JSIndexer jsKey obj)]
227− stToAssign (s, js) = JSAssignment (JSAccessor s jsNewObj) js
228− extend = map stToAssign sts
229− return $ JSApp (JSFunction Nothing [] block) []
230−
231−-- |
232−-- Generate code in the simplified Javascript intermediate representation for a reference to a
233−-- variable.
234−--
235−varToJs :: ModuleName -> Qualified Ident -> JS
236−varToJs _ (Qualified Nothing ident) = var ident
237−varToJs m qual = qualifiedToJS m id qual
238−
239−-- |
240−-- Generate code in the simplified Javascript intermediate representation for a reference to a
241−-- variable that may have a qualified name.
242−--
243−qualifiedToJS :: ModuleName -> (a -> Ident) -> Qualified a -> JS
244−qualifiedToJS _ f (Qualified (Just (ModuleName [ProperName mn])) a) | mn == C.prim = JSVar . runIdent $ f a
245−qualifiedToJS m f (Qualified (Just m') a) | m /= m' = accessor (f a) (JSVar (moduleNameToJs m'))
246−qualifiedToJS _ f (Qualified _ a) = JSVar $ identToJs (f a)
247−
248−-- |
249−-- Generate code in the simplified Javascript intermediate representation for pattern match binders
250−-- and guards.
251−--
252−bindersToJs :: forall m mode. (Functor m, Applicative m, Monad m, MonadReader (Options mode) m, MonadSupply m)
253− => ModuleName -> [CaseAlternative Ann] -> [JS] -> m JS
254−bindersToJs m binders vals = do
255− valNames <- replicateM (length vals) freshName
256− let assignments = zipWith JSVariableIntroduction valNames (map Just vals)
257− jss <- forM binders $ \(CaseAlternative bs result) -> do
258− ret <- guardsToJs result
259− go valNames ret bs
260− return $ JSApp (JSFunction Nothing [] (JSBlock (assignments ++ concat jss ++ [JSThrow $ JSUnary JSNew $ JSApp (JSVar "Error") [JSStringLiteral "Failed pattern match"]])))
261− []
262− where
263− go :: [String] -> [JS] -> [Binder Ann] -> 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 :: Either [(Guard Ann, Expr Ann)] (Expr Ann) -> m [JS]
271− guardsToJs (Left gs) = forM gs $ \(cond, val) -> do
272− cond' <- valueToJs m cond
273− done <- valueToJs m val
274− return $ JSIfElse cond' (JSBlock [JSReturn done]) Nothing
275− guardsToJs (Right v) = return . JSReturn <$> valueToJs m v
276−
277−-- |
278−-- Generate code in the simplified Javascript intermediate representation for a pattern match
279−-- binder.
280−--
281−binderToJs :: forall m mode. (Functor m, Applicative m, Monad m, MonadReader (Options mode) m, MonadSupply m)
282− => ModuleName -> String -> [JS] -> Binder Ann -> m [JS]
283−binderToJs _ _ done (NullBinder{}) = return done
284−binderToJs m varName done (LiteralBinder _ l) =
285− literalToBinderJS m varName done l
286−binderToJs _ varName done (VarBinder _ ident) =
287− return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : done)
288−binderToJs m varName done (ConstructorBinder (_, _, _, Just IsNewtype) _ _ [b]) =
289− binderToJs m varName done b
290−binderToJs m varName done (ConstructorBinder (_, _, _, Just (IsConstructor ctorType fields)) _ ctor bs) = do
291− js <- go (zip fields bs) done
292− return $ case ctorType of
293− ProductType -> js
294− SumType ->
295− [JSIfElse (JSInstanceOf (JSVar varName) (qualifiedToJS m (Ident . runProperName) ctor))
296− (JSBlock js)
297− Nothing]
298− where
299− go :: [(Ident, Binder Ann)] -> [JS] -> m [JS]
300− go [] done' = return done'
301− go ((field, binder) : remain) done' = do
302− argVar <- freshName
303− done'' <- go remain done'
304− js <- binderToJs m argVar done'' binder
305− return (JSVariableIntroduction argVar (Just (JSAccessor (identToJs field) (JSVar varName))) : js)
306−binderToJs m varName done binder@(ConstructorBinder _ _ ctor _) | isCons ctor = do
307− let (headBinders, tailBinder) = uncons [] binder
308− numberOfHeadBinders = fromIntegral $ length headBinders
309− js1 <- foldM (\done' (headBinder, index) -> do
310− headVar <- freshName
311− jss <- binderToJs m headVar done' headBinder
312− return (JSVariableIntroduction headVar (Just (JSIndexer (JSNumericLiteral (Left index)) (JSVar varName))) : jss)) done (zip headBinders [0..])
313− tailVar <- freshName
314− js2 <- binderToJs m tailVar js1 tailBinder
315− return [JSIfElse (JSBinary GreaterThanOrEqualTo (JSAccessor "length" (JSVar varName)) (JSNumericLiteral (Left numberOfHeadBinders))) (JSBlock
316− ( JSVariableIntroduction tailVar (Just (JSApp (JSAccessor "slice" (JSVar varName)) [JSNumericLiteral (Left numberOfHeadBinders)])) :
317− js2
318− )) Nothing]
319− where
320− uncons :: [Binder Ann] -> Binder Ann -> ([Binder Ann], Binder Ann)
321− uncons acc (ConstructorBinder _ _ ctor' [h, t]) | isCons ctor' = uncons (h : acc) t
322− uncons acc tailBinder = (reverse acc, tailBinder)
323−binderToJs _ _ _ b@(ConstructorBinder{}) =
324− error $ "Invalid ConstructorBinder in binderToJs: " ++ show b
325−binderToJs m varName done (NamedBinder _ ident binder) = do
326− js <- binderToJs m varName done binder
327− return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : js)
328−
329−literalToBinderJS :: forall m mode. (Functor m, Applicative m, Monad m, MonadReader (Options mode) m, MonadSupply m)
330− => ModuleName -> String -> [JS] -> Literal (Binder Ann) -> m [JS]
331−literalToBinderJS _ varName done (NumericLiteral num) =
332− return [JSIfElse (JSBinary EqualTo (JSVar varName) (JSNumericLiteral num)) (JSBlock done) Nothing]
333−literalToBinderJS _ varName done (StringLiteral str) =
334− return [JSIfElse (JSBinary EqualTo (JSVar varName) (JSStringLiteral str)) (JSBlock done) Nothing]
335−literalToBinderJS _ varName done (BooleanLiteral True) =
336− return [JSIfElse (JSVar varName) (JSBlock done) Nothing]
337−literalToBinderJS _ varName done (BooleanLiteral False) =
338− return [JSIfElse (JSUnary Not (JSVar varName)) (JSBlock done) Nothing]
339−literalToBinderJS m varName done (ObjectLiteral bs) = go done bs
340− where
341− go :: [JS] -> [(String, Binder Ann)] -> m [JS]
342− go done' [] = return done'
343− go done' ((prop, binder):bs') = do
344− propVar <- freshName
345− done'' <- go done' bs'
346− js <- binderToJs m propVar done'' binder
347− return (JSVariableIntroduction propVar (Just (accessorString prop (JSVar varName))) : js)
348−literalToBinderJS m varName done (ArrayLiteral bs) = do
349− js <- go done 0 bs
350− return [JSIfElse (JSBinary EqualTo (JSAccessor "length" (JSVar varName)) (JSNumericLiteral (Left (fromIntegral $ length bs)))) (JSBlock js) Nothing]
351− where
352− go :: [JS] -> Integer -> [Binder Ann] -> m [JS]
353− go done' _ [] = return done'
354− go done' index (binder:bs') = do
355− elVar <- freshName
356− done'' <- go done' (index + 1) bs'
357− js <- binderToJs m elVar done'' binder
358− return (JSVariableIntroduction elVar (Just (JSIndexer (JSNumericLiteral (Left index)) (JSVar varName))) : js)
359−
360−isCons :: Qualified ProperName -> Bool
361−isCons (Qualified (Just mn) ctor) = mn == ModuleName [ProperName C.prim] && ctor == ProperName "Array"
362−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−249
@@ -1,249 +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 _ (A.Module _ _ _ Nothing) =
44− error "Module exports were not elaborated before moduleToCoreFn"
45−moduleToCoreFn env (A.Module coms mn decls (Just exps)) =
46− let imports = nub $ mapMaybe importToCoreFn decls ++ findQualModules decls
47− exps' = nub $ concatMap exportToCoreFn exps
48− externs = nub $ mapMaybe externToCoreFn decls
49− decls' = concatMap (declToCoreFn Nothing []) decls
50− in Module coms mn imports exps' externs decls'
51−
52− where
53−
54− -- |
55− -- Desugars member declarations from AST to CoreFn representation.
56− --
57− declToCoreFn :: Maybe SourceSpan -> [Comment] -> A.Declaration -> [Bind Ann]
58− declToCoreFn ss com (A.DataDeclaration Newtype _ _ [(ctor, _)]) =
59− [NonRec (properToIdent ctor) $
60− Abs (ss, com, Nothing, Just IsNewtype) (Ident "x") (Var nullAnn $ Qualified Nothing (Ident "x"))]
61− declToCoreFn _ _ d@(A.DataDeclaration Newtype _ _ _) =
62− error $ "Found newtype with multiple constructors: " ++ show d
63− declToCoreFn ss com (A.DataDeclaration Data tyName _ ctors) =
64− flip map ctors $ \(ctor, _) ->
65− let (_, _, _, fields) = lookupConstructor env (Qualified (Just mn) ctor)
66− in NonRec (properToIdent ctor) $ Constructor (ss, com, Nothing, Nothing) tyName ctor fields
67− declToCoreFn ss _ (A.DataBindingGroupDeclaration ds) = concatMap (declToCoreFn ss []) ds
68− declToCoreFn ss com (A.ValueDeclaration name _ _ (Right e)) =
69− [NonRec name (exprToCoreFn ss com Nothing e)]
70− declToCoreFn ss _ (A.BindingGroupDeclaration ds) =
71− [Rec $ map (\(name, _, e) -> (name, exprToCoreFn ss [] Nothing e)) ds]
72− declToCoreFn ss com (A.TypeClassDeclaration name _ supers members) =
73− [NonRec (properToIdent name) $ mkTypeClassConstructor ss com supers members]
74− declToCoreFn _ com (A.PositionedDeclaration ss com1 d) =
75− declToCoreFn (Just ss) (com ++ com1) d
76− declToCoreFn _ _ _ = []
77−
78− -- |
79− -- Desugars expressions from AST to CoreFn representation.
80− --
81− exprToCoreFn :: Maybe SourceSpan -> [Comment] -> Maybe Type -> A.Expr -> Expr Ann
82− exprToCoreFn ss com ty (A.NumericLiteral v) =
83− Literal (ss, com, ty, Nothing) (NumericLiteral v)
84− exprToCoreFn ss com ty (A.StringLiteral v) =
85− Literal (ss, com, ty, Nothing) (StringLiteral v)
86− exprToCoreFn ss com ty (A.BooleanLiteral v) =
87− Literal (ss, com, ty, Nothing) (BooleanLiteral v)
88− exprToCoreFn ss com ty (A.ArrayLiteral vs) =
89− Literal (ss, com, ty, Nothing) (ArrayLiteral $ map (exprToCoreFn ss [] Nothing) vs)
90− exprToCoreFn ss com ty (A.ObjectLiteral vs) =
91− Literal (ss, com, ty, Nothing) (ObjectLiteral $ map (second (exprToCoreFn ss [] Nothing)) vs)
92− exprToCoreFn ss com ty (A.Accessor name v) =
93− Accessor (ss, com, ty, Nothing) name (exprToCoreFn ss [] Nothing v)
94− exprToCoreFn ss com ty (A.ObjectUpdate obj vs) =
95− ObjectUpdate (ss, com, ty, Nothing) (exprToCoreFn ss [] Nothing obj) $ map (second (exprToCoreFn ss [] Nothing)) vs
96− exprToCoreFn ss com ty (A.Abs (Left name) v) =
97− Abs (ss, com, ty, Nothing) name (exprToCoreFn ss [] Nothing v)
98− exprToCoreFn _ _ _ (A.Abs _ _) =
99− error "Abs with Binder argument was not desugared before exprToCoreFn mn"
100− exprToCoreFn ss com ty (A.App v1 v2) =
101− App (ss, com, ty, Nothing) (exprToCoreFn ss [] Nothing v1) (exprToCoreFn ss [] Nothing v2)
102− exprToCoreFn ss com ty (A.Var ident) =
103− Var (ss, com, ty, Nothing) ident
104− exprToCoreFn ss com ty (A.IfThenElse v1 v2 v3) =
105− Case (ss, com, ty, Nothing) [exprToCoreFn ss [] Nothing v1]
106− [ CaseAlternative [LiteralBinder nullAnn $ BooleanLiteral True]
107− (Right $ exprToCoreFn Nothing [] Nothing v2)
108− , CaseAlternative [LiteralBinder nullAnn $ BooleanLiteral False]
109− (Right $ exprToCoreFn Nothing [] Nothing v3) ]
110− exprToCoreFn ss com ty (A.Constructor name) =
111− Var (ss, com, ty, Just $ getConstructorMeta name) $ fmap properToIdent name
112− exprToCoreFn ss com ty (A.Case vs alts) =
113− Case (ss, com, ty, Nothing) (map (exprToCoreFn ss [] Nothing) vs) (map (altToCoreFn ss) alts)
114− exprToCoreFn ss com _ (A.TypedValue _ v ty) =
115− exprToCoreFn ss com (Just ty) v
116− exprToCoreFn ss com ty (A.Let ds v) =
117− Let (ss, com, ty, Nothing) (concatMap (declToCoreFn ss []) ds) (exprToCoreFn ss [] Nothing v)
118− exprToCoreFn ss com _ (A.TypeClassDictionaryConstructorApp name (A.TypedValue _ (A.ObjectLiteral vs) _)) =
119− let args = map (exprToCoreFn ss [] Nothing . snd) $ sortBy (compare `on` fst) vs
120− ctor = Var (ss, [], Nothing, Just IsTypeClassConstructor) (fmap properToIdent name)
121− in foldl (App (ss, com, Nothing, Nothing)) ctor args
122− exprToCoreFn ss com ty (A.TypeClassDictionaryAccessor _ ident) =
123− Abs (ss, com, ty, Nothing) (Ident "dict")
124− (Accessor nullAnn (runIdent ident) (Var nullAnn $ Qualified Nothing (Ident "dict")))
125− exprToCoreFn _ com ty (A.PositionedValue ss com1 v) =
126− exprToCoreFn (Just ss) (com ++ com1) ty v
127− exprToCoreFn _ _ _ e =
128− error $ "Unexpected value in exprToCoreFn mn: " ++ show e
129−
130− -- |
131− -- Desugars case alternatives from AST to CoreFn representation.
132− --
133− altToCoreFn :: Maybe SourceSpan -> A.CaseAlternative -> CaseAlternative Ann
134− altToCoreFn ss (A.CaseAlternative bs vs) = CaseAlternative (map (binderToCoreFn ss []) bs) (go vs)
135− where
136− go :: Either [(A.Guard, A.Expr)] A.Expr -> Either [(Guard Ann, Expr Ann)] (Expr Ann)
137− go (Left ges) = Left $ map (exprToCoreFn ss [] Nothing *** exprToCoreFn ss [] Nothing) ges
138− go (Right e) = Right (exprToCoreFn ss [] Nothing e)
139−
140− -- |
141− -- Desugars case binders from AST to CoreFn representation.
142− --
143− binderToCoreFn :: Maybe SourceSpan -> [Comment] -> A.Binder -> Binder Ann
144− binderToCoreFn ss com (A.NullBinder) =
145− NullBinder (ss, com, Nothing, Nothing)
146− binderToCoreFn ss com (A.BooleanBinder b) =
147− LiteralBinder (ss, com, Nothing, Nothing) (BooleanLiteral b)
148− binderToCoreFn ss com (A.StringBinder s) =
149− LiteralBinder (ss, com, Nothing, Nothing) (StringLiteral s)
150− binderToCoreFn ss com (A.NumberBinder n) =
151− LiteralBinder (ss, com, Nothing, Nothing) (NumericLiteral n)
152− binderToCoreFn ss com (A.VarBinder name) =
153− VarBinder (ss, com, Nothing, Nothing) name
154− binderToCoreFn ss com (A.ConstructorBinder dctor@(Qualified mn' _) bs) =
155− let (_, tctor, _, _) = lookupConstructor env dctor
156− in ConstructorBinder (ss, com, Nothing, Just $ getConstructorMeta dctor) (Qualified mn' tctor) dctor (map (binderToCoreFn ss []) bs)
157− binderToCoreFn ss com (A.ObjectBinder bs) =
158− LiteralBinder (ss, com, Nothing, Nothing) (ObjectLiteral $ map (second (binderToCoreFn ss [])) bs)
159− binderToCoreFn ss com (A.ArrayBinder bs) =
160− LiteralBinder (ss, com, Nothing, Nothing) (ArrayLiteral $ map (binderToCoreFn ss []) bs)
161− binderToCoreFn ss com (A.ConsBinder b1 b2) =
162− let arrCtor = Qualified (Just $ ModuleName [ProperName "Prim"]) (ProperName "Array")
163− in ConstructorBinder (ss, com, Nothing, Nothing) arrCtor arrCtor $ map (binderToCoreFn ss []) [b1, b2]
164− binderToCoreFn ss com (A.NamedBinder name b) =
165− NamedBinder (ss, com, Nothing, Nothing) name (binderToCoreFn ss [] b)
166− binderToCoreFn _ com (A.PositionedBinder ss com1 b) =
167− binderToCoreFn (Just ss) (com ++ com1) b
168−
169− -- |
170− -- Gets metadata for data constructors.
171− --
172− getConstructorMeta :: Qualified ProperName -> Meta
173− getConstructorMeta ctor =
174− case lookupConstructor env ctor of
175− (Newtype, _, _, _) -> IsNewtype
176− dc@(Data, _, _, fields) ->
177− let constructorType = if numConstructors (ctor, dc) == 1 then ProductType else SumType
178− in IsConstructor constructorType fields
179− where
180− numConstructors :: (Qualified ProperName, (DataDeclType, ProperName, Type, [Ident])) -> Int
181− numConstructors ty = length $ filter (((==) `on` typeConstructor) ty) $ M.toList $ dataConstructors env
182− typeConstructor :: (Qualified ProperName, (DataDeclType, ProperName, Type, [Ident])) -> (ModuleName, ProperName)
183− typeConstructor (Qualified (Just mn') _, (_, tyCtor, _, _)) = (mn', tyCtor)
184− typeConstructor _ = error "Invalid argument to typeConstructor"
185−
186−-- |
187−-- Find module names from qualified references to values. This is used to
188−-- ensure instances are imported from any module that is referenced by the
189−-- current module, not just from those that are imported explicitly (#667).
190−--
191−findQualModules :: [A.Declaration] -> [ModuleName]
192−findQualModules decls =
193− let (f, _, _, _, _) = everythingOnValues (++) (const []) fqValues (const []) (const []) (const [])
194− in f `concatMap` decls
195− where
196− fqValues :: A.Expr -> [ModuleName]
197− fqValues (A.Var (Qualified (Just mn) _)) = [mn]
198− fqValues _ = []
199−
200−-- |
201−-- Desugars import declarations from AST to CoreFn representation.
202−--
203−importToCoreFn :: A.Declaration -> Maybe ModuleName
204−importToCoreFn (A.ImportDeclaration name _ _) = Just name
205−importToCoreFn (A.PositionedDeclaration _ _ d) = importToCoreFn d
206−importToCoreFn _ = Nothing
207−
208−-- |
209−-- Desugars foreign declarations from AST to CoreFn representation.
210−--
211−externToCoreFn :: A.Declaration -> Maybe ForeignDecl
212−externToCoreFn (A.ExternDeclaration _ name js ty) = Just (name, js, ty)
213−externToCoreFn (A.ExternInstanceDeclaration name _ _ _) = Just (name, Nothing, tyObject)
214−externToCoreFn (A.PositionedDeclaration _ _ d) = externToCoreFn d
215−externToCoreFn _ = Nothing
216−
217−-- |
218−-- Desugars export declarations references from AST to CoreFn representation.
219−-- CoreFn modules only export values, so all data constructors, class
220−-- constructor, instances and values are flattened into one list.
221−--
222−exportToCoreFn :: A.DeclarationRef -> [Ident]
223−exportToCoreFn (A.TypeRef _ (Just dctors)) = map properToIdent dctors
224−exportToCoreFn (A.ValueRef name) = [name]
225−exportToCoreFn (A.TypeClassRef name) = [properToIdent name]
226−exportToCoreFn (A.TypeInstanceRef name) = [name]
227−exportToCoreFn (A.PositionedDeclarationRef _ _ d) = exportToCoreFn d
228−exportToCoreFn _ = []
229−
230−-- |
231−-- Makes a typeclass dictionary constructor function. The returned expression
232−-- is a function that accepts the superclass instances and member
233−-- implementations and returns a record for the instance dictionary.
234−--
235−mkTypeClassConstructor :: Maybe SourceSpan -> [Comment] -> [Constraint] -> [A.Declaration] -> Expr Ann
236−mkTypeClassConstructor ss com [] [] = Literal (ss, com, Nothing, Just IsTypeClassConstructor) (ObjectLiteral [])
237−mkTypeClassConstructor ss com supers members =
238− let args@(a:as) = sort $ map typeClassMemberName members ++ superClassDictionaryNames supers
239− props = [ (arg, Var nullAnn $ Qualified Nothing (Ident arg)) | arg <- args ]
240− dict = Literal nullAnn (ObjectLiteral props)
241− in Abs (ss, com, Nothing, Just IsTypeClassConstructor)
242− (Ident a)
243− (foldr (Abs nullAnn . Ident) dict as)
244−
245−-- |
246−-- Converts a ProperName to an Ident.
247−--
248−properToIdent :: ProperName -> Ident
249−properToIdent = Ident . runProperName
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−32
@@ -1,32 +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.Comments
19−import Language.PureScript.CoreFn.Expr
20−import Language.PureScript.Names
21−import Language.PureScript.Types
22−
23−data Module a = Module
24− { moduleComments :: [Comment]
25− , moduleName :: ModuleName
26− , moduleImports :: [ModuleName]
27− , moduleExports :: [Ident]
28− , moduleForeign :: [ForeignDecl]
29− , moduleDecls :: [Bind a]
30− } deriving (Show)
31−
32−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 coms mn imps exps foreigns ds) = Module coms mn imps exps' foreigns' ds'
33− where
34− ds' = filter (isUsed mn graph vertexFor entryPointVertices) ds
35− foreigns' = filter (isUsed' mn graph vertexFor entryPointVertices . foreignIdent) foreigns
36− names = concatMap bindIdents ds' ++ map foreignIdent foreigns'
37− exps' = filter (`elem` names) exps
38− declarations = concatMap declarationsByModule ms
39− (graph, _, vertexFor) = graphFromEdges $ map (\(key, deps) -> (key, key, deps)) declarations
40− entryPointVertices = mapMaybe (vertexFor . fst) . filter (\((mn, _), _) -> mn `elem` entryPoints) $ declarations
41−
42−-- |
43−-- Extract declaration names for a binding group.
44−--
45−bindIdents :: Bind a -> [Ident]
46−bindIdents (NonRec name _) = [name]
47−bindIdents (Rec names) = map fst names
48−
49−-- |
50−-- Extract the ident for a foreign declaration.
51−--
52−foreignIdent :: ForeignDecl -> Ident
53−foreignIdent (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−153
@@ -1,153 +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.String (IsString(..))
21−import Data.List (intersperse, intercalate)
22−import Data.Monoid
23−
24−import Control.Monad.Except
25−import Control.Applicative ((<$>))
26−
27−import Language.PureScript.AST
28−import Language.PureScript.Pretty
29−import Language.PureScript.Types
30−
31−-- |
32−-- Type for sources of type checking errors
33−--
34−data ErrorSource
35− -- |
36− -- An error which originated at a Expr
37− --
38− = ExprError Expr
39− -- |
40− -- An error which originated at a Type
41− --
42− | TypeError Type deriving (Show)
43−
44−-- |
45−-- Compilation errors
46−--
47−data CompileError
48− = CompileError
49− { -- |
50− -- Error message
51− --
52− compileErrorMessage :: String
53− -- |
54− -- The value where the error occurred
55− --
56− , compileErrorValue :: Maybe ErrorSource
57− -- |
58− -- Optional source position information
59− --
60− , compileErrorPosition :: Maybe SourceSpan
61− }
62− deriving (Show)
63−
64−-- |
65−-- A stack trace for an error
66−--
67−data ErrorStack
68− = ErrorStack { runErrorStack :: [CompileError] }
69− | MultipleErrors [ErrorStack] deriving (Show)
70−
71−-- TODO: Remove strMsg, the IsString instance, and unnecessary
72−-- OverloadedStrings pragmas. See #745
73−-- | Create an ErrorStack from a string
74−strMsg :: String -> ErrorStack
75−strMsg s = ErrorStack [CompileError s Nothing Nothing]
76−
77−instance IsString ErrorStack where
78− fromString = strMsg
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 [mkCompileError msg t]
111−
112−mkCompileError :: String -> Maybe ErrorSource -> CompileError
113−mkCompileError msg t = CompileError msg t Nothing
114−
115−positionError :: SourceSpan -> CompileError
116−positionError pos = CompileError "" Nothing (Just pos)
117−
118−-- |
119−-- Rethrow an error with a more detailed error message in the case of failure
120−--
121−rethrow :: (MonadError e m) => (e -> e) -> m a -> m a
122−rethrow f = flip catchError $ \e -> throwError (f e)
123−
124−-- |
125−-- Rethrow an error with source position information
126−--
127−rethrowWithPosition :: (MonadError ErrorStack m) => SourceSpan -> m a -> m a
128−rethrowWithPosition pos = rethrow (positionError pos `combineErrors`)
129−
130−-- |
131−-- Collect errors in in parallel
132−--
133−parU :: (MonadError ErrorStack m, Functor m) => [a] -> (a -> m b) -> m [b]
134−parU xs f = forM xs (withError . f) >>= collectErrors
135− where
136− withError :: (MonadError ErrorStack m, Functor m) => m a -> m (Either ErrorStack a)
137− withError u = catchError (Right <$> u) (return . Left)
138−
139− collectErrors :: (MonadError ErrorStack m, Functor m) => [Either ErrorStack a] -> m [a]
140− collectErrors es = case lefts es of
141− [err] -> throwError err
142− [] -> return $ rights es
143− errs -> throwError $ MultipleErrors errs
144−
145−-- |
146−-- Add an extra error string onto the top of each error stack in a list of possibly many errors
147−--
148−combineErrors :: CompileError -> ErrorStack -> ErrorStack
149−combineErrors ce err = go (ErrorStack [ce]) err
150− where
151− go (ErrorStack xs) (ErrorStack ys) = ErrorStack (xs ++ ys)
152− go (MultipleErrors es) x = MultipleErrors [ go e x | e <- es ]
153− go x (MultipleErrors es) = MultipleErrors [ go x e | e <- es ]
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.Except
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−519
@@ -1,519 +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− comments <- C.readComments
246− reserved "module"
247− indented
248− name <- moduleName
249− exports <- P.optionMaybe $ parens $ commaSep1 parseDeclarationRef
250− reserved "where"
251− decls <- mark (P.many (same *> parseDeclaration))
252− return $ Module comments name decls exports
253−
254−-- |
255−-- Parse a collection of modules
256−--
257−parseModulesFromFiles :: (k -> String) -> [(k, String)] -> Either P.ParseError [(k, Module)]
258−parseModulesFromFiles toFilePath input =
259− fmap collect . forM input $ \(k, content) -> do
260− let filename = toFilePath k
261− ts <- lex filename content
262− ms <- runTokenParser filename parseModules ts
263− return (k, ms)
264− where
265− collect :: [(k, [v])] -> [(k, v)]
266− collect vss = [ (k, v) | (k, vs) <- vss, v <- vs ]
267−
268−-- |
269−-- Parse a collection of modules
270−--
271−parseModules :: TokenParser [Module]
272−parseModules = mark (P.many (same *> parseModule)) <* P.eof
273−
274−booleanLiteral :: TokenParser Bool
275−booleanLiteral = (reserved "true" >> return True) P.<|> (reserved "false" >> return False)
276−
277−parseNumericLiteral :: TokenParser Expr
278−parseNumericLiteral = NumericLiteral <$> number
279−
280−parseStringLiteral :: TokenParser Expr
281−parseStringLiteral = StringLiteral <$> stringLiteral
282−
283−parseBooleanLiteral :: TokenParser Expr
284−parseBooleanLiteral = BooleanLiteral <$> booleanLiteral
285−
286−parseArrayLiteral :: TokenParser Expr
287−parseArrayLiteral = ArrayLiteral <$> squares (commaSep parseValue)
288−
289−parseObjectLiteral :: TokenParser Expr
290−parseObjectLiteral = ObjectConstructor <$> braces (commaSep parseIdentifierAndValue)
291−
292−parseIdentifierAndValue :: TokenParser (String, Maybe Expr)
293−parseIdentifierAndValue = (,) <$> (C.indented *> (lname <|> stringLiteral) <* C.indented <* colon)
294− <*> (C.indented *> val)
295− where
296− val = (Just <$> parseValue) <|> (underscore *> pure Nothing)
297−
298−parseAbs :: TokenParser Expr
299−parseAbs = do
300− symbol' "\\"
301− args <- P.many1 (C.indented *> (Abs <$> (Left <$> P.try C.parseIdent <|> Right <$> parseBinderNoParens)))
302− C.indented *> rarrow
303− value <- parseValue
304− return $ toFunction args value
305− where
306− toFunction :: [Expr -> Expr] -> Expr -> Expr
307− toFunction args value = foldr ($) value args
308−
309−parseVar :: TokenParser Expr
310−parseVar = Var <$> C.parseQualified C.parseIdent
311−
312−parseConstructor :: TokenParser Expr
313−parseConstructor = Constructor <$> C.parseQualified C.properName
314−
315−parseCase :: TokenParser Expr
316−parseCase = Case <$> P.between (P.try (reserved "case")) (C.indented *> reserved "of") (return <$> parseValue)
317− <*> (C.indented *> C.mark (P.many (C.same *> C.mark parseCaseAlternative)))
318−
319−parseCaseAlternative :: TokenParser CaseAlternative
320−parseCaseAlternative = CaseAlternative <$> (return <$> parseBinder)
321− <*> (Left <$> (C.indented *>
322− P.many1 ((,) <$> parseGuard
323− <*> (indented *> rarrow *> parseValue)
324− ))
325− <|> Right <$> (indented *> rarrow *> parseValue))
326− P.<?> "case alternative"
327−
328−parseIfThenElse :: TokenParser Expr
329−parseIfThenElse = IfThenElse <$> (P.try (reserved "if") *> C.indented *> parseValue)
330− <*> (C.indented *> reserved "then" *> C.indented *> parseValue)
331− <*> (C.indented *> reserved "else" *> C.indented *> parseValue)
332−
333−parseLet :: TokenParser Expr
334−parseLet = do
335− reserved "let"
336− C.indented
337− ds <- C.mark $ P.many1 (C.same *> parseLocalDeclaration)
338− C.indented
339− reserved "in"
340− result <- parseValue
341− return $ Let ds result
342−
343−parseValueAtom :: TokenParser Expr
344−parseValueAtom = P.choice
345− [ P.try parseNumericLiteral
346− , P.try parseStringLiteral
347− , P.try parseBooleanLiteral
348− , parseArrayLiteral
349− , P.try parseObjectLiteral
350− , P.try parseObjectGetter
351− , parseAbs
352− , P.try parseConstructor
353− , P.try parseVar
354− , parseCase
355− , parseIfThenElse
356− , parseDo
357− , parseLet
358− , P.try $ Parens <$> parens parseValue
359− , parseOperatorSection
360− , P.try parseObjectUpdaterWildcard ]
361−
362−-- |
363−-- Parse an expression in backticks or an operator
364−--
365−parseInfixExpr :: TokenParser Expr
366−parseInfixExpr = P.between tick tick parseValue
367− <|> Var <$> parseQualified (Op <$> symbol)
368−
369−parseOperatorSection :: TokenParser Expr
370−parseOperatorSection = parens $ left <|> right
371− where
372− right = OperatorSection <$> parseInfixExpr <* indented <*> (Right <$> parseValueAtom)
373− left = flip OperatorSection <$> (Left <$> parseValueAtom) <* indented <*> parseInfixExpr
374−
375−parsePropertyUpdate :: TokenParser (String, Maybe Expr)
376−parsePropertyUpdate = do
377− name <- lname <|> stringLiteral
378− _ <- C.indented *> equals
379− value <- C.indented *> (underscore *> pure Nothing) <|> (Just <$> parseValue)
380− return (name, value)
381−
382−parseAccessor :: Expr -> TokenParser Expr
383−parseAccessor (Constructor _) = P.unexpected "constructor"
384−parseAccessor obj = P.try $ Accessor <$> (C.indented *> dot *> C.indented *> (lname <|> stringLiteral)) <*> pure obj
385−
386−parseDo :: TokenParser Expr
387−parseDo = do
388− reserved "do"
389− C.indented
390− Do <$> C.mark (P.many (C.same *> C.mark parseDoNotationElement))
391−
392−parseDoNotationLet :: TokenParser DoNotationElement
393−parseDoNotationLet = DoNotationLet <$> (reserved "let" *> C.indented *> C.mark (P.many1 (C.same *> parseLocalDeclaration)))
394−
395−parseDoNotationBind :: TokenParser DoNotationElement
396−parseDoNotationBind = DoNotationBind <$> parseBinder <*> (C.indented *> larrow *> parseValue)
397−
398−parseDoNotationElement :: TokenParser DoNotationElement
399−parseDoNotationElement = P.choice
400− [ P.try parseDoNotationBind
401− , parseDoNotationLet
402− , P.try (DoNotationValue <$> parseValue) ]
403−
404−parseObjectGetter :: TokenParser Expr
405−parseObjectGetter = ObjectGetter <$> (underscore *> C.indented *> dot *> C.indented *> (lname <|> stringLiteral))
406−
407−-- |
408−-- Parse a value
409−--
410−parseValue :: TokenParser Expr
411−parseValue = withSourceSpan PositionedValue
412− (P.buildExpressionParser operators
413− . C.buildPostfixParser postfixTable2
414− $ indexersAndAccessors) P.<?> "expression"
415− where
416− indexersAndAccessors = C.buildPostfixParser postfixTable1 parseValueAtom
417− postfixTable1 = [ parseAccessor
418− , P.try . parseUpdaterBody . Just ]
419− postfixTable2 = [ \v -> P.try (flip App <$> (C.indented *> indexersAndAccessors)) <*> pure v
420− , \v -> flip (TypedValue True) <$> (P.try (C.indented *> doubleColon) *> parsePolyType) <*> pure v
421− ]
422− operators = [ [ P.Prefix (P.try (C.indented *> symbol' "-") >> return UnaryMinus)
423− ]
424− , [ P.Infix (P.try (C.indented *> parseInfixExpr P.<?> "infix expression") >>= \ident ->
425− return (BinaryNoParens ident)) P.AssocRight
426− ]
427− ]
428−
429−parseUpdaterBody :: Maybe Expr -> TokenParser Expr
430−parseUpdaterBody v = ObjectUpdater v <$> (C.indented *> braces (commaSep1 (C.indented *> parsePropertyUpdate)))
431−
432−parseObjectUpdaterWildcard :: TokenParser Expr
433−parseObjectUpdaterWildcard = underscore *> C.indented *> parseUpdaterBody Nothing
434−
435−parseStringBinder :: TokenParser Binder
436−parseStringBinder = StringBinder <$> stringLiteral
437−
438−parseBooleanBinder :: TokenParser Binder
439−parseBooleanBinder = BooleanBinder <$> booleanLiteral
440−
441−parseNumberBinder :: TokenParser Binder
442−parseNumberBinder = NumberBinder <$> (sign <*> number)
443− where
444− sign :: TokenParser (Either Integer Double -> Either Integer Double)
445− sign = (symbol' "-" >> return (negate +++ negate))
446− <|> (symbol' "+" >> return id)
447− <|> return id
448−
449−parseVarBinder :: TokenParser Binder
450−parseVarBinder = VarBinder <$> C.parseIdent
451−
452−parseNullaryConstructorBinder :: TokenParser Binder
453−parseNullaryConstructorBinder = ConstructorBinder <$> C.parseQualified C.properName <*> pure []
454−
455−parseConstructorBinder :: TokenParser Binder
456−parseConstructorBinder = ConstructorBinder <$> C.parseQualified C.properName <*> many (C.indented *> parseBinderNoParens)
457−
458−parseObjectBinder :: TokenParser Binder
459−parseObjectBinder = ObjectBinder <$> braces (commaSep (C.indented *> parseIdentifierAndBinder))
460−
461−parseArrayBinder :: TokenParser Binder
462−parseArrayBinder = squares $ ArrayBinder <$> commaSep (C.indented *> parseBinder)
463−
464−parseNamedBinder :: TokenParser Binder
465−parseNamedBinder = NamedBinder <$> (C.parseIdent <* C.indented <* at)
466− <*> (C.indented *> parseBinder)
467−
468−parseNullBinder :: TokenParser Binder
469−parseNullBinder = underscore *> return NullBinder
470−
471−parseIdentifierAndBinder :: TokenParser (String, Binder)
472−parseIdentifierAndBinder = do
473− name <- lname <|> stringLiteral
474− C.indented *> (equals <|> colon)
475− binder <- C.indented *> parseBinder
476− return (name, binder)
477−
478−-- |
479−-- Parse a binder
480−--
481−parseBinder :: TokenParser Binder
482−parseBinder = withSourceSpan PositionedBinder (P.buildExpressionParser operators parseBinderAtom P.<?> "expression")
483− where
484− operators = [ [ P.Infix (P.try $ C.indented *> colon *> return ConsBinder) P.AssocRight ] ]
485− parseBinderAtom :: TokenParser Binder
486− parseBinderAtom = P.choice (map P.try
487− [ parseNullBinder
488− , parseStringBinder
489− , parseBooleanBinder
490− , parseNumberBinder
491− , parseNamedBinder
492− , parseVarBinder
493− , parseConstructorBinder
494− , parseObjectBinder
495− , parseArrayBinder
496− , parens parseBinder ]) P.<?> "binder"
497−
498−-- |
499−-- Parse a binder as it would appear in a top level declaration
500−--
501−parseBinderNoParens :: TokenParser Binder
502−parseBinderNoParens = P.choice (map P.try
503− [ parseNullBinder
504− , parseStringBinder
505− , parseBooleanBinder
506− , parseNumberBinder
507− , parseNamedBinder
508− , parseVarBinder
509− , parseNullaryConstructorBinder
510− , parseObjectBinder
511− , parseArrayBinder
512− , parens parseBinder ]) P.<?> "binder"
513−-- |
514−-- Parse a guard
515−--
516−parseGuard :: TokenParser Guard
517−parseGuard = pipe *> C.indented *> parseValue
518−
519−
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−71
@@ -1,71 +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−{-# LANGUAGE FlexibleContexts #-}
17−
18−module Language.PureScript.Sugar (desugar, module S) where
19−
20−import Control.Monad
21−import Control.Category ((>>>))
22−import Control.Applicative
23−import Control.Monad.Error.Class
24−import Control.Monad.Supply.Class
25−
26−import Language.PureScript.AST
27−import Language.PureScript.Errors
28−
29−import Language.PureScript.Sugar.BindingGroups as S
30−import Language.PureScript.Sugar.CaseDeclarations as S
31−import Language.PureScript.Sugar.DoNotation as S
32−import Language.PureScript.Sugar.Names as S
33−import Language.PureScript.Sugar.ObjectWildcards as S
34−import Language.PureScript.Sugar.Operators as S
35−import Language.PureScript.Sugar.TypeClasses as S
36−import Language.PureScript.Sugar.TypeDeclarations as S
37−
38−-- |
39−-- The desugaring pipeline proceeds as follows:
40−--
41−-- * Remove signed literals in favour of `negate` applications
42−--
43−-- * Desugar object literals with wildcards into lambdas
44−--
45−-- * Desugar operator sections
46−--
47−-- * Desugar do-notation using the @Prelude.Monad@ type class
48−--
49−-- * Desugar top-level case declarations into explicit case expressions
50−--
51−-- * Desugar type declarations into value declarations with explicit type annotations
52−--
53−-- * Qualify any unqualified names and types
54−--
55−-- * Rebracket user-defined binary operators
56−--
57−-- * Introduce type synonyms for type class dictionaries
58−--
59−-- * Group mutually recursive value and data declarations into binding groups.
60−--
61−desugar :: (Applicative m, MonadSupply m, MonadError ErrorStack m) => [Module] -> m [Module]
62−desugar = map removeSignedLiterals
63− >>> mapM desugarObjectConstructors
64− >=> mapM desugarOperatorSections
65− >=> mapM desugarDoModule
66− >=> desugarCasesModule
67− >=> desugarTypeDeclarationsModule
68− >=> desugarImports
69− >=> rebracket
70− >=> desugarTypeClasses
71− >=> createBindingGroupsModule
src/Language/PureScript/Sugar/BindingGroups.hsdeleted−207
@@ -1,207 +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−{-# LANGUAGE FlexibleContexts #-}
18−
19−module Language.PureScript.Sugar.BindingGroups (
20− createBindingGroups,
21− createBindingGroupsModule,
22− collapseBindingGroups,
23− collapseBindingGroupsModule
24−) where
25−
26−import Data.Graph
27−import Data.List (nub, intersect)
28−import Data.Maybe (isJust, mapMaybe)
29−import Control.Applicative
30−import Control.Monad ((<=<))
31−import Control.Monad.Error.Class
32−
33−import qualified Data.Set as S
34−
35−import Language.PureScript.AST
36−import Language.PureScript.Names
37−import Language.PureScript.Types
38−import Language.PureScript.Environment
39−import Language.PureScript.Errors
40−
41−-- |
42−-- Replace all sets of mutually-recursive declarations in a module with binding groups
43−--
44−createBindingGroupsModule :: (Functor m, Applicative m, MonadError ErrorStack m) => [Module] -> m [Module]
45−createBindingGroupsModule = mapM $ \(Module coms name ds exps) -> Module coms name <$> createBindingGroups name ds <*> pure exps
46−
47−-- |
48−-- Collapse all binding groups in a module to individual declarations
49−--
50−collapseBindingGroupsModule :: [Module] -> [Module]
51−collapseBindingGroupsModule = map $ \(Module coms name ds exps) -> Module coms name (collapseBindingGroups ds) exps
52−
53−createBindingGroups :: (Functor m, Applicative m, MonadError ErrorStack m) => ModuleName -> [Declaration] -> m [Declaration]
54−createBindingGroups moduleName = mapM f <=< handleDecls
55−
56− where
57− (f, _, _) = everywhereOnValuesTopDownM return handleExprs return
58−
59− handleExprs :: (Functor m, MonadError ErrorStack m) => Expr -> m Expr
60− handleExprs (Let ds val) = flip Let val <$> handleDecls ds
61− handleExprs other = return other
62−
63− -- |
64− -- Replace all sets of mutually-recursive declarations with binding groups
65− --
66− handleDecls :: (Functor m, MonadError ErrorStack m) => [Declaration] -> m [Declaration]
67− handleDecls ds = do
68− let values = filter isValueDecl ds
69− dataDecls = filter isDataDecl ds
70− allProperNames = map getProperName dataDecls
71− dataVerts = map (\d -> (d, getProperName d, usedProperNames moduleName d `intersect` allProperNames)) dataDecls
72− dataBindingGroupDecls <- parU (stronglyConnComp dataVerts) toDataBindingGroup
73− let allIdents = map getIdent values
74− valueVerts = map (\d -> (d, getIdent d, usedIdents moduleName d `intersect` allIdents)) values
75− bindingGroupDecls <- parU (stronglyConnComp valueVerts) (toBindingGroup moduleName)
76− return $ filter isImportDecl ds ++
77− filter isExternDataDecl ds ++
78− filter isExternInstanceDecl ds ++
79− dataBindingGroupDecls ++
80− filter isTypeClassDeclaration ds ++
81− filter isFixityDecl ds ++
82− filter isExternDecl ds ++
83− bindingGroupDecls
84−
85−-- |
86−-- Collapse all binding groups to individual declarations
87−--
88−collapseBindingGroups :: [Declaration] -> [Declaration]
89−collapseBindingGroups = let (f, _, _) = everywhereOnValues id collapseBindingGroupsForValue id in map f . concatMap go
90− where
91− go (DataBindingGroupDeclaration ds) = ds
92− go (BindingGroupDeclaration ds) = map (\(ident, nameKind, val) -> ValueDeclaration ident nameKind [] (Right val)) ds
93− go (PositionedDeclaration pos com d) = map (PositionedDeclaration pos com) $ go d
94− go other = [other]
95−
96−collapseBindingGroupsForValue :: Expr -> Expr
97−collapseBindingGroupsForValue (Let ds val) = Let (collapseBindingGroups ds) val
98−collapseBindingGroupsForValue other = other
99−
100−usedIdents :: ModuleName -> Declaration -> [Ident]
101−usedIdents moduleName =
102− let (f, _, _, _, _) = everythingWithContextOnValues S.empty [] (++) def usedNamesE usedNamesB def def
103− in nub . f
104− where
105− def s _ = (s, [])
106−
107− usedNamesE :: S.Set Ident -> Expr -> (S.Set Ident, [Ident])
108− usedNamesE scope (Var (Qualified Nothing name)) | name `S.notMember` scope = (scope, [name])
109− usedNamesE scope (Var (Qualified (Just moduleName') name)) | moduleName == moduleName' && name `S.notMember` scope = (scope, [name])
110− usedNamesE scope (Abs (Left name) _) = (name `S.insert` scope, [])
111− usedNamesE scope _ = (scope, [])
112−
113− usedNamesB :: S.Set Ident -> Binder -> (S.Set Ident, [Ident])
114− usedNamesB scope binder = (scope `S.union` S.fromList (binderNames binder), [])
115−
116−usedImmediateIdents :: ModuleName -> Declaration -> [Ident]
117−usedImmediateIdents moduleName =
118− let (f, _, _, _, _) = everythingWithContextOnValues True [] (++) def usedNamesE def def def
119− in nub . f
120− where
121− def s _ = (s, [])
122−
123− usedNamesE :: Bool -> Expr -> (Bool, [Ident])
124− usedNamesE True (Var (Qualified Nothing name)) = (True, [name])
125− usedNamesE True (Var (Qualified (Just moduleName') name)) | moduleName == moduleName' = (True, [name])
126− usedNamesE True (Abs _ _) = (False, [])
127− usedNamesE scope _ = (scope, [])
128−
129−usedProperNames :: ModuleName -> Declaration -> [ProperName]
130−usedProperNames moduleName =
131− let (f, _, _, _, _) = accumTypes (everythingOnTypes (++) usedNames)
132− in nub . f
133− where
134− usedNames :: Type -> [ProperName]
135− usedNames (ConstrainedType constraints _) = flip mapMaybe constraints $ \qual ->
136− case qual of
137− (Qualified (Just moduleName') name, _) | moduleName == moduleName' -> Just name
138− _ -> Nothing
139− usedNames (TypeConstructor (Qualified (Just moduleName') name)) | moduleName == moduleName' = [name]
140− usedNames _ = []
141−
142−getIdent :: Declaration -> Ident
143−getIdent (ValueDeclaration ident _ _ _) = ident
144−getIdent (PositionedDeclaration _ _ d) = getIdent d
145−getIdent _ = error "Expected ValueDeclaration"
146−
147−getProperName :: Declaration -> ProperName
148−getProperName (DataDeclaration _ pn _ _) = pn
149−getProperName (TypeSynonymDeclaration pn _ _) = pn
150−getProperName (PositionedDeclaration _ _ d) = getProperName d
151−getProperName _ = error "Expected DataDeclaration"
152−
153−-- |
154−-- Convert a group of mutually-recursive dependencies into a BindingGroupDeclaration (or simple ValueDeclaration).
155−--
156−--
157−toBindingGroup :: (Functor m, MonadError ErrorStack m) => ModuleName -> SCC Declaration -> m Declaration
158−toBindingGroup _ (AcyclicSCC d) = return d
159−toBindingGroup _ (CyclicSCC [d]) = return d
160−toBindingGroup moduleName (CyclicSCC ds') =
161− -- Once we have a mutually-recursive group of declarations, we need to sort
162− -- them further by their immediate dependencies (those outside function
163− -- bodies). In particular, this is relevant for type instance dictionaries
164− -- whose members require other type instances (for example, functorEff
165− -- defines (<$>) = liftA1, which depends on applicativeEff). Note that
166− -- superclass references are still inside functions, so don't count here.
167− -- If we discover declarations that still contain mutually-recursive
168− -- immediate references, we're guaranteed to get an undefined reference at
169− -- runtime, so treat this as an error. See also github issue #365.
170− BindingGroupDeclaration <$> mapM toBinding (stronglyConnComp valueVerts)
171− where
172− idents :: [Ident]
173− idents = map (\(_, i, _) -> i) valueVerts
174−
175− valueVerts :: [(Declaration, Ident, [Ident])]
176− valueVerts = map (\d -> (d, getIdent d, usedImmediateIdents moduleName d `intersect` idents)) ds'
177−
178− toBinding :: (MonadError ErrorStack m) => SCC Declaration -> m (Ident, NameKind, Expr)
179− toBinding (AcyclicSCC d) = return $ fromValueDecl d
180− toBinding (CyclicSCC ~(d:ds)) = cycleError d ds
181−
182− cycleError :: (MonadError ErrorStack m) => Declaration -> [Declaration] -> m a
183− cycleError (PositionedDeclaration p _ d) ds = rethrowWithPosition p $ cycleError d ds
184− cycleError (ValueDeclaration n _ _ (Right e)) [] = throwError $
185− mkErrorStack ("Cycle in definition of " ++ show n) (Just (ExprError e))
186− cycleError d ds@(_:_) = rethrow (mkCompileError ("The following are not yet defined here: " ++ unwords (map (show . getIdent) ds)) Nothing `combineErrors`) $ cycleError d []
187− cycleError _ _ = error "Expected ValueDeclaration"
188−
189−toDataBindingGroup :: (MonadError ErrorStack m) => SCC Declaration -> m Declaration
190−toDataBindingGroup (AcyclicSCC d) = return d
191−toDataBindingGroup (CyclicSCC [d]) = case isTypeSynonym d of
192− Just pn -> throwError $ mkErrorStack ("Cycle in type synonym " ++ show pn) Nothing
193− _ -> return d
194−toDataBindingGroup (CyclicSCC ds')
195− | all (isJust . isTypeSynonym) ds' = throwError $ mkErrorStack "Cycle in type synonyms" Nothing
196− | otherwise = return $ DataBindingGroupDeclaration ds'
197−
198−isTypeSynonym :: Declaration -> Maybe ProperName
199−isTypeSynonym (TypeSynonymDeclaration pn _ _) = Just pn
200−isTypeSynonym (PositionedDeclaration _ _ d) = isTypeSynonym d
201−isTypeSynonym _ = Nothing
202−
203−fromValueDecl :: Declaration -> (Ident, NameKind, Expr)
204−fromValueDecl (ValueDeclaration ident nameKind [] (Right val)) = (ident, nameKind, val)
205−fromValueDecl ValueDeclaration{} = error "Binders should have been desugared"
206−fromValueDecl (PositionedDeclaration _ _ d) = fromValueDecl d
207−fromValueDecl _ = error "Expected ValueDeclaration"
src/Language/PureScript/Sugar/CaseDeclarations.hsdeleted−129
@@ -1,129 +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−{-# LANGUAGE FlexibleContexts #-}
18−
19−module Language.PureScript.Sugar.CaseDeclarations (
20− desugarCases,
21− desugarCasesModule
22−) where
23−
24−import Data.List (nub, groupBy)
25−
26−import Control.Applicative
27−import Control.Monad ((<=<), forM, join, unless, replicateM)
28−import Control.Monad.Except (throwError)
29−import Control.Monad.Error.Class (MonadError)
30−import Control.Monad.Supply.Class
31−
32−import Language.PureScript.Names
33−import Language.PureScript.AST
34−import Language.PureScript.Environment
35−import Language.PureScript.Errors
36−import Language.PureScript.Traversals
37−import Language.PureScript.TypeChecker.Monad (guardWith)
38−
39−-- Data.Either.isLeft (base 4.7)
40−isLeft :: Either a b -> Bool
41−isLeft (Left _) = True
42−isLeft (Right _) = False
43−
44−-- |
45−-- Replace all top-level binders in a module with case expressions.
46−--
47−desugarCasesModule :: (Functor m, Applicative m, MonadSupply m, MonadError ErrorStack m) => [Module] -> m [Module]
48−desugarCasesModule ms = forM ms $ \(Module coms name ds exps) ->
49− rethrow (mkCompileError ("Error in module " ++ show name) Nothing `combineErrors`) $
50− Module coms name <$> (desugarCases <=< desugarAbs $ ds) <*> pure exps
51−
52−desugarAbs :: (Functor m, Applicative m, MonadSupply m, MonadError ErrorStack m) => [Declaration] -> m [Declaration]
53−desugarAbs = flip parU f
54− where
55− (f, _, _) = everywhereOnValuesM return replace return
56−
57− replace :: (Functor m, Applicative m, MonadSupply m, MonadError ErrorStack m) => Expr -> m Expr
58− replace (Abs (Right binder) val) = do
59− ident <- Ident <$> freshName
60− return $ Abs (Left ident) $ Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] (Right val)]
61− replace other = return other
62−
63−-- |
64−-- Replace all top-level binders with case expressions.
65−--
66−desugarCases :: (Functor m, Applicative m, MonadSupply m, MonadError ErrorStack m) => [Declaration] -> m [Declaration]
67−desugarCases = desugarRest <=< fmap join . flip parU toDecls . groupBy inSameGroup
68− where
69− desugarRest :: (Functor m, Applicative m, MonadSupply m, MonadError ErrorStack m) => [Declaration] -> m [Declaration]
70− desugarRest (TypeInstanceDeclaration name constraints className tys ds : rest) =
71− (:) <$> (TypeInstanceDeclaration name constraints className tys <$> desugarCases ds) <*> desugarRest rest
72− desugarRest (ValueDeclaration name nameKind bs result : rest) =
73− let (_, f, _) = everywhereOnValuesTopDownM return go return
74− f' (Left gs) = Left <$> mapM (pairM return f) gs
75− f' (Right v) = Right <$> f v
76− in (:) <$> (ValueDeclaration name nameKind bs <$> f' result) <*> desugarRest rest
77− where
78− go (Let ds val') = Let <$> desugarCases ds <*> pure val'
79− go other = return other
80− desugarRest (PositionedDeclaration pos com d : ds) = do
81− (d' : ds') <- desugarRest (d : ds)
82− return (PositionedDeclaration pos com d' : ds')
83− desugarRest (d : ds) = (:) d <$> desugarRest ds
84− desugarRest [] = pure []
85−
86−inSameGroup :: Declaration -> Declaration -> Bool
87−inSameGroup (ValueDeclaration ident1 _ _ _) (ValueDeclaration ident2 _ _ _) = ident1 == ident2
88−inSameGroup (PositionedDeclaration _ _ d1) d2 = inSameGroup d1 d2
89−inSameGroup d1 (PositionedDeclaration _ _ d2) = inSameGroup d1 d2
90−inSameGroup _ _ = False
91−
92−toDecls :: (Functor m, Applicative m, MonadSupply m, MonadError ErrorStack m) => [Declaration] -> m [Declaration]
93−toDecls [ValueDeclaration ident nameKind bs (Right val)] | all isVarBinder bs = do
94− let args = map (\(VarBinder arg) -> arg) bs
95− body = foldr (Abs . Left) val args
96− guardWith (strMsg "Overlapping function argument names") $ length (nub args) == length args
97− return [ValueDeclaration ident nameKind [] (Right body)]
98−toDecls ds@(ValueDeclaration ident _ bs result : _) = do
99− let tuples = map toTuple ds
100− unless (all ((== length bs) . length . fst) tuples) $
101− throwError $ mkErrorStack ("Argument list lengths differ in declaration " ++ show ident) Nothing
102− unless (not (null bs) || isLeft result) $
103− throwError $ mkErrorStack ("Duplicate value declaration '" ++ show ident ++ "'") Nothing
104− caseDecl <- makeCaseDeclaration ident tuples
105− return [caseDecl]
106−toDecls (PositionedDeclaration pos com d : ds) = do
107− (d' : ds') <- rethrowWithPosition pos $ toDecls (d : ds)
108− return (PositionedDeclaration pos com d' : ds')
109−toDecls ds = return ds
110−
111−isVarBinder :: Binder -> Bool
112−isVarBinder (VarBinder _) = True
113−isVarBinder _ = False
114−
115−toTuple :: Declaration -> ([Binder], Either [(Guard, Expr)] Expr)
116−toTuple (ValueDeclaration _ _ bs result) = (bs, result)
117−toTuple (PositionedDeclaration _ _ d) = toTuple d
118−toTuple _ = error "Not a value declaration"
119−
120−makeCaseDeclaration :: (Functor m, Applicative m, MonadSupply m, MonadError ErrorStack m) => Ident -> [([Binder], Either [(Guard, Expr)] Expr)] -> m Declaration
121−makeCaseDeclaration ident alternatives = do
122− let argPattern = length . fst . head $ alternatives
123− args <- map Ident <$> replicateM argPattern freshName
124− let
125− vars = map (Var . Qualified Nothing) args
126− binders = [ CaseAlternative bs result | (bs, result) <- alternatives ]
127− value = foldr (Abs . Left) (Case vars binders) args
128− return $ ValueDeclaration ident Value [] (Right value)
129−
src/Language/PureScript/Sugar/DoNotation.hsdeleted−77
@@ -1,77 +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−{-# LANGUAGE FlexibleContexts #-}
18−{-# LANGUAGE ScopedTypeVariables #-}
19−
20−module Language.PureScript.Sugar.DoNotation (
21− desugarDoModule
22−) where
23−
24−import Language.PureScript.Names
25−import Language.PureScript.AST
26−import Language.PureScript.Errors
27−
28−import qualified Language.PureScript.Constants as C
29−
30−import Control.Applicative
31−import Control.Monad.Error.Class
32−import Control.Monad.Supply.Class
33−
34−-- |
35−-- Replace all @DoNotationBind@ and @DoNotationValue@ constructors with applications of the Prelude.(>>=) function,
36−-- and all @DoNotationLet@ constructors with let expressions.
37−--
38−desugarDoModule :: forall m. (Applicative m, MonadSupply m, MonadError ErrorStack m) => Module -> m Module
39−desugarDoModule (Module coms mn ds exts) = Module coms mn <$> parU ds desugarDo <*> pure exts
40−
41−desugarDo :: forall m. (Applicative m, MonadSupply m, MonadError ErrorStack m) => Declaration -> m Declaration
42−desugarDo (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> (rethrowWithPosition pos $ desugarDo d)
43−desugarDo d =
44− let (f, _, _) = everywhereOnValuesM return replace return
45− in f d
46− where
47− prelude :: ModuleName
48− prelude = ModuleName [ProperName C.prelude]
49−
50− bind :: Expr
51− bind = Var (Qualified (Just prelude) (Op (C.>>=)))
52−
53− replace :: Expr -> m Expr
54− replace (Do els) = go els
55− replace (PositionedValue pos com v) = PositionedValue pos com <$> rethrowWithPosition pos (replace v)
56− replace other = return other
57−
58− go :: [DoNotationElement] -> m Expr
59− go [] = error "The impossible happened in desugarDo"
60− go [DoNotationValue val] = return val
61− go (DoNotationValue val : rest) = do
62− rest' <- go rest
63− return $ App (App bind val) (Abs (Left (Ident C.__unused)) rest')
64− go [DoNotationBind _ _] = throwError $ mkErrorStack "Bind statement cannot be the last statement in a do block" Nothing
65− go (DoNotationBind NullBinder val : rest) = go (DoNotationValue val : rest)
66− go (DoNotationBind (VarBinder ident) val : rest) = do
67− rest' <- go rest
68− return $ App (App bind val) (Abs (Left ident) rest')
69− go (DoNotationBind binder val : rest) = do
70− rest' <- go rest
71− ident <- Ident <$> freshName
72− return $ App (App bind val) (Abs (Left ident) (Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] (Right rest')]))
73− go [DoNotationLet _] = throwError $ mkErrorStack "Let statement cannot be the last statement in a do block" Nothing
74− go (DoNotationLet ds : rest) = do
75− rest' <- go rest
76− return $ Let ds rest'
77− go (PositionedDoNotationElement pos com el : rest) = rethrowWithPosition pos $ PositionedValue pos com <$> go (el : rest)
src/Language/PureScript/Sugar/Names.hsdeleted−551
@@ -1,551 +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−{-# LANGUAGE FlexibleContexts #-}
16−{-# LANGUAGE ScopedTypeVariables #-}
17−
18−module Language.PureScript.Sugar.Names (
19− desugarImports
20−) where
21−
22−import Data.List (nub)
23−import Data.Maybe (fromMaybe, isJust, mapMaybe)
24−
25−import Control.Applicative (Applicative(..), (<$>), (<*>))
26−import Control.Monad.Except
27−
28−import qualified Data.Map as M
29−
30−import Language.PureScript.AST
31−import Language.PureScript.Names
32−import Language.PureScript.Types
33−import Language.PureScript.Environment
34−import Language.PureScript.Errors
35−import Language.PureScript.Traversals
36−
37−import qualified Language.PureScript.Constants as C
38−
39−-- |
40−-- The global export environment - every declaration exported from every module.
41−--
42−type ExportEnvironment = M.Map ModuleName Exports
43−
44−-- |
45−-- The exported declarations from a module.
46−--
47−data Exports = Exports
48− {
49− -- |
50− -- The types exported from each module
51− --
52− exportedTypes :: [(ProperName, [ProperName])]
53− -- |
54− -- The classes exported from each module
55− --
56− , exportedTypeClasses :: [ProperName]
57− -- |
58− -- The values exported from each module
59− --
60− , exportedValues :: [Ident]
61− } deriving (Show)
62−
63−-- |
64−-- An imported environment for a particular module. This also contains the module's own members.
65−--
66−data ImportEnvironment = ImportEnvironment
67− {
68− -- |
69− -- Local names for types within a module mapped to to their qualified names
70− --
71− importedTypes :: M.Map (Qualified ProperName) (Qualified ProperName)
72− -- |
73− -- Local names for data constructors within a module mapped to to their qualified names
74− --
75− , importedDataConstructors :: M.Map (Qualified ProperName) (Qualified ProperName)
76− -- |
77− -- Local names for classes within a module mapped to to their qualified names
78− --
79− , importedTypeClasses :: M.Map (Qualified ProperName) (Qualified ProperName)
80− -- |
81− -- Local names for values within a module mapped to to their qualified names
82− --
83− , importedValues :: M.Map (Qualified Ident) (Qualified Ident)
84− } deriving (Show)
85−
86−-- |
87−-- Updates the exports for a module from the global environment. If the module was not previously
88−-- present in the global environment, it is created.
89−--
90−updateExportedModule :: (Applicative m, MonadError ErrorStack m) => ExportEnvironment -> ModuleName -> (Exports -> m Exports) -> m ExportEnvironment
91−updateExportedModule env mn update = do
92− let exports = fromMaybe (error "Module was undefined in updateExportedModule") $ mn `M.lookup` env
93− exports' <- update exports
94− return $ M.insert mn exports' env
95−
96−-- |
97−-- Adds an empty module to an ExportEnvironment.
98−--
99−addEmptyModule :: (Applicative m, MonadError ErrorStack m) => ExportEnvironment -> ModuleName -> m ExportEnvironment
100−addEmptyModule env name =
101− if name `M.member` env
102− then throwError $ mkErrorStack ("Module '" ++ show name ++ "' has been defined more than once") Nothing
103− else return $ M.insert name (Exports [] [] []) env
104−
105−-- |
106−-- Adds a type belonging to a module to the export environment.
107−--
108−addType :: (Applicative m, MonadError ErrorStack m) => ExportEnvironment -> ModuleName -> ProperName -> [ProperName] -> m ExportEnvironment
109−addType env mn name dctors = updateExportedModule env mn $ \m -> do
110− let exTypes = exportedTypes m
111− let exDctors = snd `concatMap` exTypes
112− let exClasses = exportedTypeClasses m
113− when (any ((== name) . fst) exTypes) $ throwMultipleDefError "type" name
114− when (name `elem` exClasses) $ throwConflictingDefError "Type" "type class" name
115− forM_ dctors $ \dctor -> do
116− when (dctor `elem` exDctors) $ throwMultipleDefError "data constructor" dctor
117− when (dctor `elem` exClasses) $ throwConflictingDefError "Data constructor" "type class" dctor
118− return $ m { exportedTypes = (name, dctors) : exTypes }
119−
120−-- |
121−-- Adds a class to the export environment.
122−--
123−addTypeClass :: (Applicative m, MonadError ErrorStack m) => ExportEnvironment -> ModuleName -> ProperName -> m ExportEnvironment
124−addTypeClass env mn name = updateExportedModule env mn $ \m -> do
125− let exTypes = exportedTypes m
126− let exDctors = snd `concatMap` exTypes
127− when (any ((== name) . fst) exTypes) $ throwConflictingDefError "Type class" "type" name
128− when (name `elem` exDctors) $ throwConflictingDefError "Type class" "data constructor" name
129− classes <- addExport "type class" (exportedTypeClasses m) name
130− return $ m { exportedTypeClasses = classes }
131−
132−-- |
133−-- Adds a class to the export environment.
134−--
135−addValue :: (Applicative m, MonadError ErrorStack m) => ExportEnvironment -> ModuleName -> Ident -> m ExportEnvironment
136−addValue env mn name = updateExportedModule env mn $ \m -> do
137− values <- addExport "value" (exportedValues m) name
138− return $ m { exportedValues = values }
139−
140−-- |
141−-- Adds an entry to a list of exports unless it is already present, in which case an error is
142−-- returned.
143−--
144−addExport :: (Applicative m, MonadError ErrorStack m, Eq a, Show a) => String -> [a] -> a -> m [a]
145−addExport what exports name =
146− if name `elem` exports
147− then throwMultipleDefError what name
148− else return $ name : exports
149−
150−-- |
151−-- Replaces all local names with qualified names within a set of modules.
152−--
153−desugarImports :: forall m. (Applicative m, MonadError ErrorStack m) => [Module] -> m [Module]
154−desugarImports modules = do
155− unfilteredExports <- findExports modules
156− exports <- foldM filterModuleExports unfilteredExports modules
157− mapM (renameInModule' unfilteredExports exports) modules
158− where
159−
160− -- Filters the exports for a module in the global exports environment so that only explicitly
161− -- exported members remain. If the module does not explicitly export anything, everything is
162− -- exported.
163− filterModuleExports :: ExportEnvironment -> Module -> m ExportEnvironment
164− filterModuleExports env (Module _ mn _ (Just exps)) = filterExports mn exps env
165− filterModuleExports env _ = return env
166−
167− -- Rename and check all the names within a module. We tweak the global exports environment so
168− -- the module has access to an unfiltered list of its own members.
169− renameInModule' :: ExportEnvironment -> ExportEnvironment -> Module -> m Module
170− renameInModule' unfilteredExports exports m@(Module _ mn _ _) =
171− rethrow (mkCompileError ("Error in module " ++ show mn) Nothing `combineErrors`) $ do
172− let env = M.update (\_ -> M.lookup mn unfilteredExports) mn exports
173− let exps = fromMaybe (error "Module is missing in renameInModule'") $ M.lookup mn exports
174− imports <- resolveImports env m
175− elaborateImports <$> renameInModule imports env (elaborateExports exps m)
176−
177−-- |
178−-- Make all exports for a module explicit. This may still effect modules that have an exports list,
179−-- as it will also make all data constructor exports explicit.
180−--
181−elaborateExports :: Exports -> Module -> Module
182−elaborateExports exps (Module coms mn decls _) = Module coms mn decls (Just $
183− map (\(ctor, dctors) -> TypeRef ctor (Just dctors)) (exportedTypes exps) ++
184− map TypeClassRef (exportedTypeClasses exps) ++
185− map ValueRef (exportedValues exps))
186−
187−-- |
188−-- Add `import X ()` for any modules where there are only fully qualified references to members.
189−-- This ensures transitive instances are included when using a member from a module.
190−--
191−elaborateImports :: Module -> Module
192−elaborateImports (Module coms mn decls exps) = Module coms mn decls' exps
193− where
194− decls' :: [Declaration]
195− decls' =
196− let (f, _, _, _, _) = everythingOnValues (++) (const []) fqValues (const []) (const []) (const [])
197− in mkImport `map` nub (f `concatMap` decls) ++ decls
198− fqValues :: Expr -> [ModuleName]
199− fqValues (Var (Qualified (Just mn') _)) = [mn']
200− fqValues _ = []
201− mkImport :: ModuleName -> Declaration
202− mkImport mn' = ImportDeclaration mn' (Qualifying []) Nothing
203−
204−-- |
205−-- Replaces all local names with qualified names within a module and checks that all existing
206−-- qualified names are valid.
207−--
208−renameInModule :: forall m. (Applicative m, MonadError ErrorStack m) => ImportEnvironment -> ExportEnvironment -> Module -> m Module
209−renameInModule imports exports (Module coms mn decls exps) =
210− Module coms mn <$> parU decls go <*> pure exps
211− where
212− (go, _, _, _, _) = everywhereWithContextOnValuesM (Nothing, []) updateDecl updateValue updateBinder updateCase defS
213−
214− updateDecl :: (Maybe SourceSpan, [Ident]) -> Declaration -> m ((Maybe SourceSpan, [Ident]), Declaration)
215− updateDecl (_, bound) d@(PositionedDeclaration pos _ _) = return ((Just pos, bound), d)
216− updateDecl (pos, bound) (DataDeclaration dtype name args dctors) =
217− (,) (pos, bound) <$> (DataDeclaration dtype name args <$> mapM (sndM (mapM (updateTypesEverywhere pos))) dctors)
218− updateDecl (pos, bound) (TypeSynonymDeclaration name ps ty) =
219− (,) (pos, bound) <$> (TypeSynonymDeclaration name ps <$> updateTypesEverywhere pos ty)
220− updateDecl (pos, bound) (TypeClassDeclaration className args implies ds) =
221− (,) (pos, bound) <$> (TypeClassDeclaration className args <$> updateConstraints pos implies <*> pure ds)
222− updateDecl (pos, bound) (TypeInstanceDeclaration name cs cn ts ds) =
223− (,) (pos, bound) <$> (TypeInstanceDeclaration name <$> updateConstraints pos cs <*> updateClassName cn pos <*> mapM (updateTypesEverywhere pos) ts <*> pure ds)
224− updateDecl (pos, bound) (ExternInstanceDeclaration name cs cn ts) =
225− (,) (pos, bound) <$> (ExternInstanceDeclaration name <$> updateConstraints pos cs <*> updateClassName cn Nothing <*> mapM (updateTypesEverywhere pos) ts)
226− updateDecl (pos, bound) (TypeDeclaration name ty) =
227− (,) (pos, bound) <$> (TypeDeclaration name <$> updateTypesEverywhere pos ty)
228− updateDecl (pos, bound) (ExternDeclaration fit name js ty) =
229− (,) (pos, name : bound) <$> (ExternDeclaration fit name js <$> updateTypesEverywhere pos ty)
230− updateDecl s d = return (s, d)
231−
232− updateValue :: (Maybe SourceSpan, [Ident]) -> Expr -> m ((Maybe SourceSpan, [Ident]), Expr)
233− updateValue (_, bound) v@(PositionedValue pos' _ _) = return ((Just pos', bound), v)
234− updateValue (pos, bound) (Abs (Left arg) val') = return ((pos, arg : bound), Abs (Left arg) val')
235− updateValue (pos, bound) (Let ds val') = do
236− let args = mapMaybe letBoundVariable ds
237− unless (length (nub args) == length args) $
238− maybe id rethrowWithPosition pos $
239− throwError $ mkErrorStack ("Overlapping names in let binding.") Nothing
240− return ((pos, args ++ bound), Let ds val')
241− where
242− updateValue (pos, bound) (Var name'@(Qualified Nothing ident)) | ident `notElem` bound =
243− (,) (pos, bound) <$> (Var <$> updateValueName name' pos)
244− updateValue (pos, bound) (Var name'@(Qualified (Just _) _)) =
245− (,) (pos, bound) <$> (Var <$> updateValueName name' pos)
246− updateValue s@(pos, _) (Constructor name) = (,) s <$> (Constructor <$> updateDataConstructorName name pos)
247− updateValue s@(pos, _) (TypedValue check val ty) = (,) s <$> (TypedValue check val <$> updateTypesEverywhere pos ty)
248− updateValue s v = return (s, v)
249−
250− updateBinder :: (Maybe SourceSpan, [Ident]) -> Binder -> m ((Maybe SourceSpan, [Ident]), Binder)
251− updateBinder (_, bound) v@(PositionedBinder pos _ _) = return ((Just pos, bound), v)
252− updateBinder s@(pos, _) (ConstructorBinder name b) = (,) s <$> (ConstructorBinder <$> updateDataConstructorName name pos <*> pure b)
253− updateBinder s v = return (s, v)
254−
255− updateCase :: (Maybe SourceSpan, [Ident]) -> CaseAlternative -> m ((Maybe SourceSpan, [Ident]), CaseAlternative)
256− updateCase (pos, bound) c@(CaseAlternative bs _) = return ((pos, concatMap binderNames bs ++ bound), c)
257−
258− letBoundVariable :: Declaration -> Maybe Ident
259− letBoundVariable (ValueDeclaration ident _ _ _) = Just ident
260− letBoundVariable (PositionedDeclaration _ _ d) = letBoundVariable d
261− letBoundVariable _ = Nothing
262−
263− updateTypesEverywhere :: Maybe SourceSpan -> Type -> m Type
264− updateTypesEverywhere pos0 = everywhereOnTypesM (updateType pos0)
265− where
266− updateType :: Maybe SourceSpan -> Type -> m Type
267− updateType pos (TypeConstructor name) = TypeConstructor <$> updateTypeName name pos
268− updateType pos (SaturatedTypeSynonym name tys) = SaturatedTypeSynonym <$> updateTypeName name pos <*> pure tys
269− updateType pos (ConstrainedType cs t) = ConstrainedType <$> updateConstraints pos cs <*> pure t
270− updateType _ t = return t
271−
272− updateConstraints pos = mapM (\(name, ts) -> (,) <$> updateClassName name pos <*> mapM (updateTypesEverywhere pos) ts)
273−
274− updateTypeName = update "type" importedTypes (\mes -> isJust . (`lookup` exportedTypes mes))
275− updateClassName = update "type class" importedTypeClasses (flip elem . exportedTypeClasses)
276− updateValueName = update "value" importedValues (flip elem . exportedValues)
277− updateDataConstructorName = update "data constructor" importedDataConstructors (\mes -> flip elem (join $ snd `map` exportedTypes mes))
278−
279− -- Update names so unqualified references become qualified, and locally qualified references
280− -- are replaced with their canoncial qualified names (e.g. M.Map -> Data.Map.Map)
281− update :: (Ord a, Show a) => String
282− -> (ImportEnvironment -> M.Map (Qualified a) (Qualified a))
283− -> (Exports -> a -> Bool)
284− -> Qualified a
285− -> Maybe SourceSpan
286− -> m (Qualified a)
287− update t getI checkE qname@(Qualified mn' name) pos = positioned $ case (M.lookup qname imports', mn') of
288− (Just qname', _) -> return qname'
289− (Nothing, Just mn'') -> do
290− when (isExplicitQualModule mn'') $ throwError $ mkErrorStack ("Unknown " ++ t ++ " '" ++ show qname ++ "'") Nothing
291− modExports <- getExports mn''
292− if checkE modExports name
293− then return qname
294− else throwError $ mkErrorStack ("Unknown " ++ t ++ " '" ++ show qname ++ "'") Nothing
295− _ -> throwError $ mkErrorStack ("Unknown " ++ t ++ " '" ++ show name ++ "'") Nothing
296− where
297− isExplicitQualModule :: ModuleName -> Bool
298− isExplicitQualModule = flip elem $ mapMaybe (\(Qualified q _) -> q) (M.keys imports')
299− imports' = getI imports
300− positioned err = case pos of
301− Nothing -> err
302− Just pos' -> rethrowWithPosition pos' err
303−
304− -- Gets the exports for a module, or an error message if the module doesn't exist
305− getExports :: ModuleName -> m Exports
306− getExports mn' = maybe (throwError $ mkErrorStack ("Unknown module '" ++ show mn' ++ "'") Nothing) return $ M.lookup mn' exports
307−
308−-- |
309−-- Finds all exported declarations in a set of modules.
310−--
311−findExports :: forall m. (Applicative m, MonadError ErrorStack m) => [Module] -> m ExportEnvironment
312−findExports = foldM addModule $ M.singleton (ModuleName [ProperName C.prim]) primExports
313− where
314−
315− -- The exported types from the Prim module
316− primExports = Exports (mkTypeEntry `map` M.keys primTypes) [] []
317− where
318− mkTypeEntry (Qualified _ name) = (name, [])
319−
320− -- Add all of the exported declarations from a module to the global export environment
321− addModule :: ExportEnvironment -> Module -> m ExportEnvironment
322− addModule env (Module _ mn ds _) = do
323− env' <- addEmptyModule env mn
324− rethrow (mkCompileError ("Error in module " ++ show mn) Nothing `combineErrors`) $ foldM (addDecl mn) env' ds
325−
326− -- Add a declaration from a module to the global export environment
327− addDecl :: ModuleName -> ExportEnvironment -> Declaration -> m ExportEnvironment
328− addDecl mn env (TypeClassDeclaration tcn _ _ ds) = do
329− env' <- addTypeClass env mn tcn
330− foldM go env' ds
331− where
332− go env'' (TypeDeclaration name _) = addValue env'' mn name
333− go env'' (PositionedDeclaration pos _ d) = rethrowWithPosition pos $ go env'' d
334− go _ _ = error "Invalid declaration in TypeClassDeclaration"
335− addDecl mn env (DataDeclaration _ tn _ dcs) = addType env mn tn (map fst dcs)
336− addDecl mn env (TypeSynonymDeclaration tn _ _) = addType env mn tn []
337− addDecl mn env (ExternDataDeclaration tn _) = addType env mn tn []
338− addDecl mn env (ValueDeclaration name _ _ _) = addValue env mn name
339− addDecl mn env (ExternDeclaration _ name _ _) = addValue env mn name
340− addDecl mn env (PositionedDeclaration pos _ d) = rethrowWithPosition pos $ addDecl mn env d
341− addDecl _ env _ = return env
342−
343−-- |
344−-- Filters the exports for a module to ensure only explicit exports are kept in the global exports
345−-- environment.
346−--
347−filterExports :: forall m. (Applicative m, MonadError ErrorStack m) => ModuleName -> [DeclarationRef] -> ExportEnvironment -> m ExportEnvironment
348−filterExports mn exps env = do
349− let moduleExports = fromMaybe (error "Module is missing") (mn `M.lookup` env)
350− moduleExports' <- rethrow (mkCompileError ("Error in module " ++ show mn) Nothing `combineErrors`) $ filterModule moduleExports
351− return $ M.insert mn moduleExports' env
352− where
353−
354− -- Filter the exports for the specific module
355− filterModule :: Exports -> m Exports
356− filterModule exported = do
357− types' <- foldM (filterTypes $ exportedTypes exported) [] exps
358− values <- foldM (filterValues $ exportedValues exported) [] exps
359− classes <- foldM (filterClasses $ exportedTypeClasses exported) [] exps
360− return exported { exportedTypes = types', exportedTypeClasses = classes, exportedValues = values }
361−
362− -- Ensure the exported types and data constructors exist in the module and add them to the set of
363− -- exports
364− filterTypes :: [(ProperName, [ProperName])] -> [(ProperName, [ProperName])] -> DeclarationRef -> m [(ProperName, [ProperName])]
365− filterTypes expTys result (PositionedDeclarationRef pos _ r) = rethrowWithPosition pos $ filterTypes expTys result r
366− filterTypes expTys result (TypeRef name expDcons) = do
367− dcons <- maybe (throwError $ mkErrorStack ("Cannot export undefined type '" ++ show name ++ "'") Nothing) return $ name `lookup` expTys
368− dcons' <- maybe (return dcons) (foldM (filterDcons name dcons) []) expDcons
369− return $ (name, dcons') : result
370− filterTypes _ result _ = return result
371−
372− -- Ensure the exported data constructors exists for a type and add them to the list of exports
373− filterDcons :: ProperName -> [ProperName] -> [ProperName] -> ProperName -> m [ProperName]
374− filterDcons tcon exps' result name =
375− if name `elem` exps'
376− then return $ name : result
377− else throwError $ mkErrorStack ("Cannot export undefined data constructor '" ++ show name ++ "' for type '" ++ show tcon ++ "'") Nothing
378−
379− -- Ensure the exported classes exist in the module and add them to the set of exports
380− filterClasses :: [ProperName] -> [ProperName] -> DeclarationRef -> m [ProperName]
381− filterClasses exps' result (PositionedDeclarationRef pos _ r) = rethrowWithPosition pos $ filterClasses exps' result r
382− filterClasses exps' result (TypeClassRef name) =
383− if name `elem` exps'
384− then return $ name : result
385− else throwError $ mkErrorStack ("Cannot export undefined type class '" ++ show name ++ "'") Nothing
386− filterClasses _ result _ = return result
387−
388− -- Ensure the exported values exist in the module and add them to the set of exports
389− filterValues :: [Ident] -> [Ident] -> DeclarationRef -> m [Ident]
390− filterValues exps' result (PositionedDeclarationRef pos _ r) = rethrowWithPosition pos $ filterValues exps' result r
391− filterValues exps' result (ValueRef name) =
392− if name `elem` exps'
393− then return $ name : result
394− else throwError $ mkErrorStack ("Cannot export undefined value '" ++ show name ++ "'") Nothing
395− filterValues _ result _ = return result
396−
397−-- |
398−-- Finds the imports within a module, mapping the imported module name to an optional set of
399−-- explicitly imported declarations.
400−--
401−findImports :: [Declaration] -> M.Map ModuleName (Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)
402−findImports = foldl (findImports' Nothing) M.empty
403− where
404− findImports' pos result (ImportDeclaration mn typ qual) = M.insert mn (pos, typ, qual) result
405− findImports' _ result (PositionedDeclaration pos _ d) = findImports' (Just pos) result d
406− findImports' _ result _ = result
407−
408−-- |
409−-- Constructs a local environment for a module.
410−--
411−resolveImports :: forall m. (Applicative m, MonadError ErrorStack m) => ExportEnvironment -> Module -> m ImportEnvironment
412−resolveImports env (Module _ currentModule decls _) =
413− foldM resolveImport' (ImportEnvironment M.empty M.empty M.empty M.empty) (M.toList scope)
414− where
415−
416− -- A Map from module name to the source position for the import, the list of imports from that
417− -- module (where Nothing indicates everything is to be imported), and optionally a qualified name
418− -- for the module
419− scope :: M.Map ModuleName (Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)
420− scope = M.insert currentModule (Nothing, Unqualified, Nothing) (findImports decls)
421−
422− resolveImport' :: ImportEnvironment -> (ModuleName, (Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)) -> m ImportEnvironment
423− resolveImport' imp (mn, (pos, typ, impQual)) = do
424− modExports <- positioned $ maybe (throwError $ mkErrorStack ("Cannot import unknown module '" ++ show mn ++ "'") Nothing) return $ mn `M.lookup` env
425− positioned $ resolveImport currentModule mn modExports imp impQual typ
426− where
427− positioned err = case pos of
428− Nothing -> err
429− Just pos' -> rethrowWithPosition pos' err
430−
431−-- |
432−-- Extends the local environment for a module by resolving an import of another module.
433−--
434−resolveImport :: forall m. (Applicative m, MonadError ErrorStack m) => ModuleName -> ModuleName -> Exports -> ImportEnvironment -> Maybe ModuleName -> ImportDeclarationType -> m ImportEnvironment
435−resolveImport currentModule importModule exps imps impQual =
436− resolveByType
437− where
438−
439− resolveByType :: ImportDeclarationType -> m ImportEnvironment
440− resolveByType Unqualified = importAll importExplicit
441− resolveByType (Qualifying explImports) = (checkedRefs >=> foldM importExplicit imps) explImports
442− resolveByType (Hiding hiddenImports) = do
443− hiddenImports' <- checkedRefs hiddenImports
444− importAll (importNonHidden hiddenImports')
445−
446− importNonHidden :: [DeclarationRef] -> ImportEnvironment -> DeclarationRef -> m ImportEnvironment
447− importNonHidden hidden m ref =
448− if isHidden hidden ref
449− then return m
450− else importExplicit m ref
451−
452− isHidden :: [DeclarationRef] -> DeclarationRef -> Bool
453− isHidden hidden ref@(TypeRef _ _) =
454− let
455− checkTypeRef _ True _ = True
456− checkTypeRef (TypeRef _ Nothing) acc (TypeRef _ (Just _)) = acc
457− checkTypeRef (TypeRef name (Just dctor)) _ (TypeRef name' (Just dctor')) = name == name' && dctor == dctor'
458− checkTypeRef (TypeRef name _) _ (TypeRef name' Nothing) = name == name'
459− checkTypeRef (PositionedDeclarationRef _ _ r) acc hiddenRef = checkTypeRef r acc hiddenRef
460− checkTypeRef _ acc _ = acc
461− in foldl (checkTypeRef ref) False hidden
462− isHidden hidden ref = ref `elem` hidden
463−
464− -- Import all symbols
465− importAll :: (ImportEnvironment -> DeclarationRef -> m ImportEnvironment) -> m ImportEnvironment
466− importAll importer = do
467− imp' <- foldM (\m (name, dctors) -> importer m (TypeRef name (Just dctors))) imps (exportedTypes exps)
468− imp'' <- foldM (\m name -> importer m (ValueRef name)) imp' (exportedValues exps)
469− foldM (\m name -> importer m (TypeClassRef name)) imp'' (exportedTypeClasses exps)
470−
471− -- Import something explicitly
472− importExplicit :: ImportEnvironment -> DeclarationRef -> m ImportEnvironment
473− importExplicit imp (PositionedDeclarationRef pos _ r) = rethrowWithPosition pos $ importExplicit imp r
474− importExplicit imp (ValueRef name) = do
475− values' <- updateImports (importedValues imp) name
476− return $ imp { importedValues = values' }
477− importExplicit imp (TypeRef name dctors) = do
478− types' <- updateImports (importedTypes imp) name
479− let allDctors = allExportedDataConstructors name
480− dctors' <- maybe (return allDctors) (mapM $ checkDctorExists allDctors) dctors
481− dctors'' <- foldM updateImports (importedDataConstructors imp) dctors'
482− return $ imp { importedTypes = types', importedDataConstructors = dctors'' }
483− importExplicit imp (TypeClassRef name) = do
484− typeClasses' <- updateImports (importedTypeClasses imp) name
485− return $ imp { importedTypeClasses = typeClasses' }
486− importExplicit _ _ = error "Invalid argument to importExplicit"
487−
488− -- Check if DeclarationRef points to an existent symbol
489− checkedRefs :: [DeclarationRef] -> m [DeclarationRef]
490− checkedRefs = mapM check
491− where
492− check (PositionedDeclarationRef pos _ r) =
493− rethrowWithPosition pos $ check r
494− check ref@(ValueRef name) =
495− checkImportExists "value" values name >> return ref
496− check ref@(TypeRef name dctors) = do
497− _ <- checkImportExists "type" availableTypes name
498− let allDctors = allExportedDataConstructors name
499− _ <- maybe (return allDctors) (mapM $ checkDctorExists allDctors) dctors
500− return ref
501− check ref@(TypeClassRef name) =
502− checkImportExists "type class" classes name >> return ref
503− check _ = error "Invalid argument to checkRefIsValid"
504−
505− -- Find all exported data constructors for a given type
506− allExportedDataConstructors :: ProperName -> [ProperName]
507− allExportedDataConstructors name = fromMaybe [] $ name `lookup` exportedTypes exps
508−
509− -- Add something to the ImportEnvironment if it does not already exist there
510− updateImports :: (Ord a, Show a) => M.Map (Qualified a) (Qualified a) -> a -> m (M.Map (Qualified a) (Qualified a))
511− updateImports m name = case M.lookup (Qualified impQual name) m of
512− Nothing -> return $ M.insert (Qualified impQual name) (Qualified (Just importModule) name) m
513− Just (Qualified Nothing _) -> error "Invalid state in updateImports"
514− Just x@(Qualified (Just mn) _) -> throwError $ mkErrorStack err Nothing
515− where
516− err = if mn == currentModule || importModule == currentModule
517− then "Definition '" ++ show name ++ "' conflicts with import '" ++ show (Qualified (Just mn) name) ++ "'"
518− else "Conflicting imports for '" ++ show name ++ "': '" ++ show x ++ "', '" ++ show (Qualified (Just importModule) name) ++ "'"
519−
520− -- The available values, types, and classes in the module being imported
521− values = exportedValues exps
522− availableTypes = fst `map` exportedTypes exps
523− classes = exportedTypeClasses exps
524−
525− -- Ensure that an explicitly imported data constructor exists for the type it is being imported
526− -- from
527− checkDctorExists :: [ProperName] -> ProperName -> m ProperName
528− checkDctorExists = checkImportExists "data constructor"
529−
530− -- Check that an explicitly imported item exists in the module it is being imported from
531− checkImportExists :: (Eq a, Show a) => String -> [a] -> a -> m a
532− checkImportExists t exports item =
533− if item `elem` exports
534− then return item
535− else throwError $ mkErrorStack ("Cannot import unknown " ++ t ++ " '" ++ show item ++ "' from '" ++ show importModule ++ "'") Nothing
536−
537−-- |
538−-- Raises an error for when there is more than one definition for something.
539−--
540−throwMultipleDefError :: (Applicative m, MonadError ErrorStack m, Show a) => String -> a -> m b
541−throwMultipleDefError what name = throwError $
542− mkErrorStack ("Multiple definitions for " ++ what ++ " '" ++ show name ++ "'") Nothing
543−
544−-- |
545−-- Raises an error for when there is a conflicting definition for something, for example, a type
546−-- class and data constructor of the same name.
547−--
548−throwConflictingDefError :: (Applicative m, MonadError ErrorStack m, Show a) => String -> String -> a -> m b
549−throwConflictingDefError what1 what2 name = throwError $
550− mkErrorStack (what1 ++ " '" ++ show name ++ "' cannot be defined in the same module as a " ++ what2 ++ " of the same name") Nothing
551−
src/Language/PureScript/Sugar/ObjectWildcards.hsdeleted−65
@@ -1,65 +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−{-# LANGUAGE FlexibleContexts #-}
16−{-# LANGUAGE ScopedTypeVariables #-}
17−
18−module Language.PureScript.Sugar.ObjectWildcards (
19− desugarObjectConstructors
20−) where
21−
22−import Control.Applicative
23−import Control.Arrow (second)
24−import Control.Monad.Error.Class
25−import Control.Monad.Supply.Class
26−
27−import Data.List (partition)
28−import Data.Maybe (isJust, fromJust, catMaybes)
29−
30−import Language.PureScript.AST
31−import Language.PureScript.Errors
32−import Language.PureScript.Names
33−
34−desugarObjectConstructors :: forall m. (Applicative m, MonadSupply m, MonadError ErrorStack m) => Module -> m Module
35−desugarObjectConstructors (Module coms mn ds exts) = Module coms mn <$> mapM desugarDecl ds <*> pure exts
36− where
37−
38− desugarDecl :: Declaration -> m Declaration
39− (desugarDecl, _, _) = everywhereOnValuesM return desugarExpr return
40−
41− desugarExpr :: Expr -> m Expr
42− desugarExpr (ObjectConstructor ps) = wrapLambda ObjectLiteral ps
43− desugarExpr (ObjectUpdater (Just obj) ps) = wrapLambda (ObjectUpdate obj) ps
44− desugarExpr (ObjectUpdater Nothing ps) = do
45− obj <- Ident <$> freshName
46− Abs (Left obj) <$> wrapLambda (ObjectUpdate (Var (Qualified Nothing obj))) ps
47− desugarExpr (ObjectGetter prop) = do
48− arg <- Ident <$> freshName
49− return $ Abs (Left arg) (Accessor prop (Var (Qualified Nothing arg)))
50− desugarExpr e = return e
51−
52− wrapLambda :: ([(String, Expr)] -> Expr) -> [(String, Maybe Expr)] -> m Expr
53− wrapLambda mkVal ps =
54− let (props, args) = partition (isJust . snd) ps
55− in if null args
56− then return . mkVal $ second fromJust `map` props
57− else do
58− (args', ps') <- unzip <$> mapM mkProp ps
59− return $ foldr (Abs . Left) (mkVal ps') (catMaybes args')
60−
61− mkProp :: (String, Maybe Expr) -> m (Maybe Ident, (String, Expr))
62− mkProp (name, Just e) = return (Nothing, (name, e))
63− mkProp (name, Nothing) = do
64− arg <- Ident <$> freshName
65− return (Just arg, (name, Var (Qualified Nothing arg)))
src/Language/PureScript/Sugar/Operators.hsdeleted−166
@@ -1,166 +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 #-}
21−{-# LANGUAGE FlexibleContexts #-}
22−{-# LANGUAGE ScopedTypeVariables #-}
23−
24−module Language.PureScript.Sugar.Operators (
25− rebracket,
26− removeSignedLiterals,
27− desugarOperatorSections
28−) where
29−
30−import Language.PureScript.AST
31−import Language.PureScript.Errors
32−import Language.PureScript.Names
33−
34−import Control.Applicative
35−import Control.Monad.State
36−import Control.Monad.Except
37−import Control.Monad.Supply.Class
38−
39−import Data.Function (on)
40−import Data.Functor.Identity
41−import Data.List (groupBy, sortBy)
42−
43−import qualified Text.Parsec as P
44−import qualified Text.Parsec.Pos as P
45−import qualified Text.Parsec.Expr as P
46−
47−import qualified Language.PureScript.Constants as C
48−
49−-- |
50−-- Remove explicit parentheses and reorder binary operator applications
51−--
52−rebracket :: (Applicative m, MonadError ErrorStack m) => [Module] -> m [Module]
53−rebracket ms = do
54− let fixities = concatMap collectFixities ms
55− ensureNoDuplicates $ map (\(i, pos, _) -> (i, pos)) fixities
56− let opTable = customOperatorTable $ map (\(i, _, f) -> (i, f)) fixities
57− mapM (rebracketModule opTable) ms
58−
59−removeSignedLiterals :: Module -> Module
60−removeSignedLiterals (Module coms mn ds exts) = Module coms mn (map f' ds) exts
61− where
62− (f', _, _) = everywhereOnValues id go id
63−
64− go (UnaryMinus val) = App (Var (Qualified (Just (ModuleName [ProperName C.prelude])) (Ident C.negate))) val
65− go other = other
66−
67−rebracketModule :: (Applicative m, MonadError ErrorStack m) => [[(Qualified Ident, Expr -> Expr -> Expr, Associativity)]] -> Module -> m Module
68−rebracketModule opTable (Module coms mn ds exts) =
69− let (f, _, _) = everywhereOnValuesTopDownM return (matchOperators opTable) return
70− in Module coms mn <$> (map removeParens <$> parU ds f) <*> pure exts
71−
72−removeParens :: Declaration -> Declaration
73−removeParens =
74− let (f, _, _) = everywhereOnValues id go id
75− in f
76− where
77− go (Parens val) = val
78− go val = val
79−
80−collectFixities :: Module -> [(Qualified Ident, SourceSpan, Fixity)]
81−collectFixities (Module _ moduleName ds _) = concatMap collect ds
82− where
83− collect :: Declaration -> [(Qualified Ident, SourceSpan, Fixity)]
84− collect (PositionedDeclaration pos _ (FixityDeclaration fixity name)) = [(Qualified (Just moduleName) (Op name), pos, fixity)]
85− collect FixityDeclaration{} = error "Fixity without srcpos info"
86− collect _ = []
87−
88−ensureNoDuplicates :: (MonadError ErrorStack m) => [(Qualified Ident, SourceSpan)] -> m ()
89−ensureNoDuplicates m = go $ sortBy (compare `on` fst) m
90− where
91− go [] = return ()
92− go [_] = return ()
93− go ((x@(Qualified (Just mn) name), _) : (y, pos) : _) | x == y =
94− rethrow (mkCompileError ("Error in module " ++ show mn) Nothing `combineErrors`) $
95− rethrowWithPosition pos $
96− throwError $ mkErrorStack ("Redefined fixity for " ++ show name) Nothing
97− go (_ : rest) = go rest
98−
99−customOperatorTable :: [(Qualified Ident, Fixity)] -> [[(Qualified Ident, Expr -> Expr -> Expr, Associativity)]]
100−customOperatorTable fixities =
101− let
102− applyUserOp ident t1 = App (App (Var ident) t1)
103− userOps = map (\(name, Fixity a p) -> (name, applyUserOp name, p, a)) fixities
104− sorted = sortBy (flip compare `on` (\(_, _, p, _) -> p)) userOps
105− groups = groupBy ((==) `on` (\(_, _, p, _) -> p)) sorted
106− in
107− map (map (\(name, f, _, a) -> (name, f, a))) groups
108−
109−type Chain = [Either Expr Expr]
110−
111−matchOperators :: forall m. (MonadError ErrorStack m) => [[(Qualified Ident, Expr -> Expr -> Expr, Associativity)]] -> Expr -> m Expr
112−matchOperators ops = parseChains
113− where
114− parseChains :: Expr -> m Expr
115− parseChains b@BinaryNoParens{} = bracketChain (extendChain b)
116− parseChains other = return other
117− extendChain :: Expr -> Chain
118− extendChain (BinaryNoParens op l r) = Left l : Right op : extendChain r
119− extendChain other = [Left other]
120− bracketChain :: Chain -> m Expr
121− bracketChain = either (throwError . (`mkErrorStack` Nothing) . show) return . P.parse (P.buildExpressionParser opTable parseValue <* P.eof) "operator expression"
122− opTable = [P.Infix (P.try (parseTicks >>= \op -> return (\t1 t2 -> App (App op t1) t2))) P.AssocLeft]
123− : map (map (\(name, f, a) -> P.Infix (P.try (matchOp name) >> return f) (toAssoc a))) ops
124− ++ [[ P.Infix (P.try (parseOp >>= \ident -> return (\t1 t2 -> App (App (Var ident) t1) t2))) P.AssocLeft ]]
125−
126−toAssoc :: Associativity -> P.Assoc
127−toAssoc Infixl = P.AssocLeft
128−toAssoc Infixr = P.AssocRight
129−toAssoc Infix = P.AssocNone
130−
131−token :: (P.Stream s Identity t, Show t) => (t -> Maybe a) -> P.Parsec s u a
132−token = P.token show (const (P.initialPos ""))
133−
134−parseValue :: P.Parsec Chain () Expr
135−parseValue = token (either Just (const Nothing)) P.<?> "expression"
136−
137−parseOp :: P.Parsec Chain () (Qualified Ident)
138−parseOp = token (either (const Nothing) fromOp) P.<?> "operator"
139− where
140− fromOp (Var q@(Qualified _ (Op _))) = Just q
141− fromOp _ = Nothing
142−
143−parseTicks :: P.Parsec Chain () Expr
144−parseTicks = token (either (const Nothing) fromOther) P.<?> "infix function"
145− where
146− fromOther (Var (Qualified _ (Op _))) = Nothing
147− fromOther v = Just v
148−
149−matchOp :: Qualified Ident -> P.Parsec Chain () ()
150−matchOp op = do
151− ident <- parseOp
152− guard $ ident == op
153−
154−desugarOperatorSections :: forall m. (Applicative m, MonadSupply m, MonadError ErrorStack m) => Module -> m Module
155−desugarOperatorSections (Module coms mn ds exts) = Module coms mn <$> mapM goDecl ds <*> pure exts
156− where
157−
158− goDecl :: Declaration -> m Declaration
159− (goDecl, _, _) = everywhereOnValuesM return goExpr return
160−
161− goExpr :: Expr -> m Expr
162− goExpr (OperatorSection op (Left val)) = return $ App op val
163− goExpr (OperatorSection op (Right val)) = do
164− arg <- Ident <$> freshName
165− return $ Abs (Left arg) $ App (App op (Var (Qualified Nothing arg))) val
166− goExpr other = return other
src/Language/PureScript/Sugar/TypeClasses.hsdeleted−292
@@ -1,292 +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−{-# LANGUAGE FlexibleContexts #-}
18−
19−module Language.PureScript.Sugar.TypeClasses
20− ( desugarTypeClasses
21− , typeClassMemberName
22− , superClassDictionaryNames
23− ) where
24−
25−import Language.PureScript.AST hiding (isExported)
26−import Language.PureScript.Environment
27−import Language.PureScript.Errors
28−import Language.PureScript.Kinds
29−import Language.PureScript.Names
30−import Language.PureScript.Pretty.Types (prettyPrintTypeAtom)
31−import Language.PureScript.Sugar.CaseDeclarations
32−import Control.Monad.Supply.Class
33−import Language.PureScript.Types
34−
35−import qualified Language.PureScript.Constants as C
36−
37−import Control.Applicative
38−import Control.Arrow (first, second)
39−import Control.Monad.Except
40−import Control.Monad.State
41−import Data.List ((\\), find)
42−import Data.Maybe (catMaybes, mapMaybe, isJust)
43−
44−import qualified Data.Map as M
45−
46−type MemberMap = M.Map (ModuleName, ProperName) Declaration
47−
48−type Desugar = StateT MemberMap
49−
50−-- |
51−-- Add type synonym declarations for type class dictionary types, and value declarations for type class
52−-- instance dictionary expressions.
53−--
54−desugarTypeClasses :: (Functor m, Applicative m, MonadSupply m, MonadError ErrorStack m) => [Module] -> m [Module]
55−desugarTypeClasses = flip evalStateT M.empty . mapM desugarModule
56−
57−desugarModule :: (Functor m, Applicative m, MonadSupply m, MonadError ErrorStack m) => Module -> Desugar m Module
58−desugarModule (Module coms name decls (Just exps)) = do
59− (newExpss, declss) <- unzip <$> parU decls (desugarDecl name exps)
60− return $ Module coms name (concat declss) $ Just (exps ++ catMaybes newExpss)
61−desugarModule _ = error "Exports should have been elaborated in name desugaring"
62−
63−{- Desugar type class and type class instance declarations
64−--
65−-- Type classes become type synonyms for their dictionaries, and type instances become dictionary declarations.
66−-- Additional values are generated to access individual members of a dictionary, with the appropriate type.
67−--
68−-- E.g. the following
69−--
70−-- module Test where
71−--
72−-- class Foo a where
73−-- foo :: a -> a
74−--
75−-- instance fooString :: Foo String where
76−-- foo s = s ++ s
77−--
78−-- instance fooArray :: (Foo a) => Foo [a] where
79−-- foo = map foo
80−--
81−-- {- Superclasses -}
82−--
83−-- class (Foo a) <= Sub a where
84−-- sub :: a
85−--
86−-- instance subString :: Sub String where
87−-- sub = ""
88−--
89−-- becomes:
90−--
91−-- <TypeClassDeclaration Foo ...>
92−--
93−-- type Foo a = { foo :: a -> a }
94−--
95−-- -- this following type is marked as not needing to be checked so a new Abs
96−-- -- is not introduced around the definition in type checking, but when
97−-- -- called the dictionary value is still passed in for the `dict` argument
98−-- foo :: forall a. (Foo a) => a -> a
99−-- foo dict = dict.foo
100−--
101−-- fooString :: {} -> Foo String
102−-- fooString _ = <TypeClassDictionaryConstructorApp Foo { foo: \s -> s ++ s }>
103−--
104−-- fooArray :: forall a. (Foo a) => Foo [a]
105−-- fooArray = <TypeClassDictionaryConstructorApp Foo { foo: map foo }>
106−--
107−-- {- Superclasses -}
108−--
109−-- <TypeClassDeclaration Sub ...>
110−--
111−-- type Sub a = { sub :: a
112−-- , "__superclass_Foo_0" :: {} -> Foo a
113−-- }
114−--
115−-- -- As with `foo` above, this type is unchecked at the declaration
116−-- sub :: forall a. (Sub a) => a
117−-- sub dict = dict.sub
118−--
119−-- subString :: {} -> Sub String
120−-- subString _ = { sub: "",
121−-- , "__superclass_Foo_0": \_ -> <SuperClassDictionary Foo String>
122−-- }
123−--
124−-- and finally as the generated javascript:
125−--
126−-- function Foo(foo) {
127−-- this.foo = foo;
128−-- };
129−--
130−-- var foo = function (dict) {
131−-- return dict.foo;
132−-- };
133−--
134−-- var fooString = function (_) {
135−-- return new Foo(function (s) {
136−-- return s + s;
137−-- });
138−-- };
139−--
140−-- var fooArray = function (__dict_Foo_15) {
141−-- return new Foo(map(foo(__dict_Foo_15)));
142−-- };
143−--
144−-- function Sub(__superclass_Foo_0, sub) {
145−-- this["__superclass_Foo_0"] = __superclass_Foo_0;
146−-- this.sub = sub;
147−-- };
148−--
149−-- var sub = function (dict) {
150−-- return dict.sub;
151−-- };
152−--
153−-- var subString = function (_) {
154−-- return new Sub(fooString, "");
155−-- };
156−-}
157−desugarDecl :: (Functor m, Applicative m, MonadSupply m, MonadError ErrorStack m) => ModuleName -> [DeclarationRef] -> Declaration -> Desugar m (Maybe DeclarationRef, [Declaration])
158−desugarDecl mn exps = go
159− where
160− go d@(TypeClassDeclaration name args implies members) = do
161− modify (M.insert (mn, name) d)
162− return (Nothing, d : typeClassDictionaryDeclaration name args implies members : map (typeClassMemberToDictionaryAccessor mn name args) members)
163− go d@(ExternInstanceDeclaration name _ className tys) = return (expRef name className tys, [d])
164− go d@(TypeInstanceDeclaration name deps className tys members) = do
165− desugared <- desugarCases members
166− dictDecl <- typeInstanceDictionaryDeclaration name mn deps className tys desugared
167− return (expRef name className tys, [d, dictDecl])
168− go (PositionedDeclaration pos com d) = do
169− (dr, ds) <- rethrowWithPosition pos $ desugarDecl mn exps d
170− return (dr, map (PositionedDeclaration pos com) ds)
171− go other = return (Nothing, [other])
172−
173− expRef :: Ident -> Qualified ProperName -> [Type] -> Maybe DeclarationRef
174− expRef name className tys
175− | isExportedClass className && all isExportedType (getConstructors `concatMap` tys) = Just $ TypeInstanceRef name
176− | otherwise = Nothing
177−
178− isExportedClass :: Qualified ProperName -> Bool
179− isExportedClass = isExported (elem . TypeClassRef)
180−
181− isExportedType :: Qualified ProperName -> Bool
182− isExportedType = isExported $ \pn -> isJust . find (matchesTypeRef pn)
183−
184− isExported :: (ProperName -> [DeclarationRef] -> Bool) -> Qualified ProperName -> Bool
185− isExported test (Qualified (Just mn') pn) = mn /= mn' || test pn exps
186− isExported _ _ = error "Names should have been qualified in name desugaring"
187−
188− matchesTypeRef :: ProperName -> DeclarationRef -> Bool
189− matchesTypeRef pn (TypeRef pn' _) = pn == pn'
190− matchesTypeRef _ _ = False
191−
192− getConstructors :: Type -> [Qualified ProperName]
193− getConstructors = everythingOnTypes (++) getConstructor
194−
195− getConstructor :: Type -> [Qualified ProperName]
196− getConstructor (TypeConstructor tcname) = [tcname]
197− getConstructor _ = []
198−
199−memberToNameAndType :: Declaration -> (Ident, Type)
200−memberToNameAndType (TypeDeclaration ident ty) = (ident, ty)
201−memberToNameAndType (PositionedDeclaration _ _ d) = memberToNameAndType d
202−memberToNameAndType _ = error "Invalid declaration in type class definition"
203−
204−typeClassDictionaryDeclaration :: ProperName -> [(String, Maybe Kind)] -> [Constraint] -> [Declaration] -> Declaration
205−typeClassDictionaryDeclaration name args implies members =
206− let superclassTypes = superClassDictionaryNames implies `zip`
207− [ function unit (foldl TypeApp (TypeConstructor superclass) tyArgs)
208− | (superclass, tyArgs) <- implies
209− ]
210− members' = map (first runIdent . memberToNameAndType) members
211− mtys = members' ++ superclassTypes
212− in TypeSynonymDeclaration name args (TypeApp tyObject $ rowFromList (mtys, REmpty))
213−
214−typeClassMemberToDictionaryAccessor :: ModuleName -> ProperName -> [(String, Maybe Kind)] -> Declaration -> Declaration
215−typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration ident ty) =
216− let className = Qualified (Just mn) name
217− in ValueDeclaration ident TypeClassAccessorImport [] $ Right $
218− TypedValue False (TypeClassDictionaryAccessor className ident) $
219− moveQuantifiersToFront (quantify (ConstrainedType [(className, map (TypeVar . fst) args)] ty))
220−typeClassMemberToDictionaryAccessor mn name args (PositionedDeclaration pos com d) =
221− PositionedDeclaration pos com $ typeClassMemberToDictionaryAccessor mn name args d
222−typeClassMemberToDictionaryAccessor _ _ _ _ = error "Invalid declaration in type class definition"
223−
224−unit :: Type
225−unit = TypeApp tyObject REmpty
226−
227−typeInstanceDictionaryDeclaration :: (Functor m, Applicative m, MonadSupply m, MonadError ErrorStack m) => Ident -> ModuleName -> [Constraint] -> Qualified ProperName -> [Type] -> [Declaration] -> Desugar m Declaration
228−typeInstanceDictionaryDeclaration name mn deps className tys decls =
229− rethrow (mkCompileError ("Error in type class instance " ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys) ++ ":") Nothing `combineErrors`) $ do
230− m <- get
231−
232− -- Lookup the type arguments and member types for the type class
233− (TypeClassDeclaration _ args implies tyDecls) <-
234− maybe (throwError $ mkErrorStack ("Type class " ++ show className ++ " is undefined") Nothing) return $
235− M.lookup (qualify mn className) m
236−
237− case mapMaybe declName tyDecls \\ mapMaybe declName decls of
238− x : _ -> throwError $ mkErrorStack ("Member '" ++ show x ++ "' has not been implemented") Nothing
239− [] -> do
240−
241− let instanceTys = map memberToNameAndType tyDecls
242−
243− -- Replace the type arguments with the appropriate types in the member types
244− let memberTypes = map (second (replaceAllTypeVars (zip (map fst args) tys))) instanceTys
245−
246− -- Create values for the type instance members
247− members <- zip (map typeClassMemberName decls) <$> mapM (memberToValue memberTypes) decls
248−
249− -- Create the type of the dictionary
250− -- The type is an object type, but depending on type instance dependencies, may be constrained.
251− -- The dictionary itself is an object literal.
252− let superclasses = superClassDictionaryNames implies `zip`
253− [ Abs (Left (Ident C.__unused)) (SuperClassDictionary superclass tyArgs)
254− | (superclass, suTyArgs) <- implies
255− , let tyArgs = map (replaceAllTypeVars (zip (map fst args) tys)) suTyArgs
256− ]
257−
258− let props = ObjectLiteral (members ++ superclasses)
259− dictTy = foldl TypeApp (TypeConstructor className) tys
260− constrainedTy = quantify (if null deps then dictTy else ConstrainedType deps dictTy)
261− dict = TypeClassDictionaryConstructorApp className props
262− result = ValueDeclaration name TypeInstanceDictionaryValue [] (Right (TypedValue True dict constrainedTy))
263− return result
264−
265− where
266−
267− declName :: Declaration -> Maybe Ident
268− declName (PositionedDeclaration _ _ d) = declName d
269− declName (ValueDeclaration ident _ _ _) = Just ident
270− declName (TypeDeclaration ident _) = Just ident
271− declName _ = Nothing
272−
273− memberToValue :: (Functor m, Applicative m, MonadSupply m, MonadError ErrorStack m) => [(Ident, Type)] -> Declaration -> Desugar m Expr
274− memberToValue tys' (ValueDeclaration ident _ [] (Right val)) = do
275− _ <- maybe (throwError $ mkErrorStack ("Type class does not define member '" ++ show ident ++ "'") Nothing) return $ lookup ident tys'
276− return val
277− memberToValue tys' (PositionedDeclaration pos com d) = rethrowWithPosition pos $ do
278− val <- memberToValue tys' d
279− return (PositionedValue pos com val)
280− memberToValue _ _ = error "Invalid declaration in type instance definition"
281−
282−typeClassMemberName :: Declaration -> String
283−typeClassMemberName (TypeDeclaration ident _) = runIdent ident
284−typeClassMemberName (ValueDeclaration ident _ _ _) = runIdent ident
285−typeClassMemberName (PositionedDeclaration _ _ d) = typeClassMemberName d
286−typeClassMemberName d = error $ "Invalid declaration in type class definition: " ++ show d
287−
288−superClassDictionaryNames :: [Constraint] -> [String]
289−superClassDictionaryNames supers =
290− [ C.__superclass_ ++ show pn ++ "_" ++ show (index :: Integer)
291− | (index, (pn, _)) <- zip [0..] supers
292− ]
src/Language/PureScript/Sugar/TypeDeclarations.hsdeleted−70
@@ -1,70 +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−{-# LANGUAGE FlexibleContexts #-}
18−
19−module Language.PureScript.Sugar.TypeDeclarations (
20− desugarTypeDeclarations,
21− desugarTypeDeclarationsModule
22−) where
23−
24−import Control.Applicative
25−import Control.Monad (forM)
26−import Control.Monad.Except (throwError)
27−import Control.Monad.Error.Class (MonadError)
28−
29−import Language.PureScript.AST
30−import Language.PureScript.Names
31−import Language.PureScript.Environment
32−import Language.PureScript.Errors
33−import Language.PureScript.Traversals
34−
35−-- |
36−-- Replace all top level type declarations in a module with type annotations
37−--
38−desugarTypeDeclarationsModule :: (Functor m, Applicative m, MonadError ErrorStack m) => [Module] -> m [Module]
39−desugarTypeDeclarationsModule ms = forM ms $ \(Module coms name ds exps) ->
40− rethrow (mkCompileError ("Error in module " ++ show name) Nothing `combineErrors`) $
41− Module coms name <$> desugarTypeDeclarations ds <*> pure exps
42−
43−-- |
44−-- Replace all top level type declarations with type annotations
45−--
46−desugarTypeDeclarations :: (Functor m, Applicative m, MonadError ErrorStack m) => [Declaration] -> m [Declaration]
47−desugarTypeDeclarations (PositionedDeclaration pos com d : ds) = do
48− (d' : ds') <- rethrowWithPosition pos $ desugarTypeDeclarations (d : ds)
49− return (PositionedDeclaration pos com d' : ds')
50−desugarTypeDeclarations (TypeDeclaration name ty : d : rest) = do
51− (_, nameKind, val) <- fromValueDeclaration d
52− desugarTypeDeclarations (ValueDeclaration name nameKind [] (Right (TypedValue True val ty)) : rest)
53− where
54− fromValueDeclaration :: (Functor m, Applicative m, MonadError ErrorStack m) => Declaration -> m (Ident, NameKind, Expr)
55− fromValueDeclaration (ValueDeclaration name' nameKind [] (Right val)) | name == name' = return (name', nameKind, val)
56− fromValueDeclaration (PositionedDeclaration pos com d') = do
57− (ident, nameKind, val) <- rethrowWithPosition pos $ fromValueDeclaration d'
58− return (ident, nameKind, PositionedValue pos com val)
59− fromValueDeclaration _ = throwError $ mkErrorStack ("Orphan type declaration for " ++ show name) Nothing
60−desugarTypeDeclarations (TypeDeclaration name _ : []) = throwError $ mkErrorStack ("Orphan type declaration for " ++ show name) Nothing
61−desugarTypeDeclarations (ValueDeclaration name nameKind bs val : rest) = do
62− let (_, f, _) = everywhereOnValuesTopDownM return go return
63− f' (Left gs) = Left <$> mapM (pairM return f) gs
64− f' (Right v) = Right <$> f v
65− (:) <$> (ValueDeclaration name nameKind bs <$> f' val) <*> desugarTypeDeclarations rest
66− where
67− go (Let ds val') = Let <$> desugarTypeDeclarations ds <*> pure val'
68− go other = return other
69−desugarTypeDeclarations (d:ds) = (:) d <$> desugarTypeDeclarations ds
70−desugarTypeDeclarations [] = return []
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−355
@@ -1,355 +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.Foldable (for_)
31−import qualified Data.Map as M
32−
33−import Control.Monad.State
34−import Control.Monad.Except
35−
36−import Language.PureScript.Types
37−import Language.PureScript.Names
38−import Language.PureScript.Kinds
39−import Language.PureScript.AST
40−import Language.PureScript.TypeClassDictionaries
41−import Language.PureScript.Environment
42−import Language.PureScript.Errors
43−
44−addDataType :: ModuleName -> DataDeclType -> ProperName -> [(String, Maybe Kind)] -> [(ProperName, [Type])] -> Kind -> Check ()
45−addDataType moduleName dtype name args dctors ctorKind = do
46− env <- getEnv
47− putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (ctorKind, DataType args dctors) (types env) }
48− forM_ dctors $ \(dctor, tys) ->
49− rethrow (mkCompileError ("Error in data constructor " ++ show dctor) Nothing `combineErrors`) $
50− addDataConstructor moduleName dtype name (map fst args) dctor tys
51−
52−addDataConstructor :: ModuleName -> DataDeclType -> ProperName -> [String] -> ProperName -> [Type] -> Check ()
53−addDataConstructor moduleName dtype name args dctor tys = do
54− env <- getEnv
55− mapM_ checkTypeSynonyms tys
56− let retTy = foldl TypeApp (TypeConstructor (Qualified (Just moduleName) name)) (map TypeVar args)
57− let dctorTy = foldr function retTy tys
58− let polyType = mkForAll args dctorTy
59− let fields = [Ident ("value" ++ show n) | n <- [0..(length tys - 1)]]
60− putEnv $ env { dataConstructors = M.insert (Qualified (Just moduleName) dctor) (dtype, name, polyType, fields) (dataConstructors env) }
61−
62−addTypeSynonym :: ModuleName -> ProperName -> [(String, Maybe Kind)] -> Type -> Kind -> Check ()
63−addTypeSynonym moduleName name args ty kind = do
64− env <- getEnv
65− checkTypeSynonyms ty
66− putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (kind, TypeSynonym) (types env)
67− , typeSynonyms = M.insert (Qualified (Just moduleName) name) (args, ty) (typeSynonyms env) }
68−
69−valueIsNotDefined :: ModuleName -> Ident -> Check ()
70−valueIsNotDefined moduleName name = do
71− env <- getEnv
72− case M.lookup (moduleName, name) (names env) of
73− Just _ -> throwError . strMsg $ show name ++ " is already defined"
74− Nothing -> return ()
75−
76−addValue :: ModuleName -> Ident -> Type -> NameKind -> Check ()
77−addValue moduleName name ty nameKind = do
78− env <- getEnv
79− putEnv (env { names = M.insert (moduleName, name) (ty, nameKind, Defined) (names env) })
80−
81−addTypeClass :: ModuleName -> ProperName -> [(String, Maybe Kind)] -> [Constraint] -> [Declaration] -> Check ()
82−addTypeClass moduleName pn args implies ds =
83− let members = map toPair ds in
84− modify $ \st -> st { checkEnv = (checkEnv st) { typeClasses = M.insert (Qualified (Just moduleName) pn) (args, members, implies) (typeClasses . checkEnv $ st) } }
85− where
86− toPair (TypeDeclaration ident ty) = (ident, ty)
87− toPair (PositionedDeclaration _ _ d) = toPair d
88− toPair _ = error "Invalid declaration in TypeClassDeclaration"
89−
90−addTypeClassDictionaries :: [TypeClassDictionaryInScope] -> Check ()
91−addTypeClassDictionaries entries =
92− let mentries = M.fromList [ ((canonicalizeDictionary entry, mn), entry) | entry@TypeClassDictionaryInScope{ tcdName = Qualified mn _ } <- entries ]
93− in modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = (typeClassDictionaries . checkEnv $ st) `M.union` mentries } }
94−
95−checkDuplicateTypeArguments :: [String] -> Check ()
96−checkDuplicateTypeArguments args = for_ firstDup $ \dup ->
97− throwError . strMsg $ "Duplicate type argument '" ++ dup ++ "'"
98− where
99− firstDup :: Maybe String
100− firstDup = listToMaybe $ args \\ nub args
101−
102−checkTypeClassInstance :: ModuleName -> Type -> Check ()
103−checkTypeClassInstance _ (TypeVar _) = return ()
104−checkTypeClassInstance _ (TypeConstructor ctor) = do
105− env <- getEnv
106− when (ctor `M.member` typeSynonyms env) . throwError . strMsg $ "Type synonym instances are disallowed"
107− return ()
108−checkTypeClassInstance m (TypeApp t1 t2) = checkTypeClassInstance m t1 >> checkTypeClassInstance m t2
109−checkTypeClassInstance _ ty = throwError $ mkErrorStack "Type class instance head is invalid." (Just (TypeError ty))
110−
111−-- |
112−-- Check that type synonyms are fully-applied in a type
113−--
114−checkTypeSynonyms :: Type -> Check ()
115−checkTypeSynonyms = void . replaceAllTypeSynonyms
116−
117−-- |
118−-- Type check all declarations in a module
119−--
120−-- At this point, many declarations will have been desugared, but it is still necessary to
121−--
122−-- * Kind-check all types and add them to the @Environment@
123−--
124−-- * Type-check all values and add them to the @Environment@
125−--
126−-- * Bring type class instances into scope
127−--
128−-- * Process module imports
129−--
130−typeCheckAll :: Maybe ModuleName -> ModuleName -> [DeclarationRef] -> [Declaration] -> Check [Declaration]
131−typeCheckAll mainModuleName moduleName exps = go
132− where
133− go :: [Declaration] -> Check [Declaration]
134− go [] = return []
135− go (DataDeclaration dtype name args dctors : rest) = do
136− rethrow (mkCompileError ("Error in type constructor " ++ show name) Nothing `combineErrors`) $ do
137− when (dtype == Newtype) $ checkNewtype dctors
138− checkDuplicateTypeArguments $ map fst args
139− ctorKind <- kindsOf True moduleName name args (concatMap snd dctors)
140− let args' = args `withKinds` ctorKind
141− addDataType moduleName dtype name args' dctors ctorKind
142− ds <- go rest
143− return $ DataDeclaration dtype name args dctors : ds
144− where
145− checkNewtype :: [(ProperName, [Type])] -> Check ()
146− checkNewtype [(_, [_])] = return ()
147− checkNewtype [(_, _)] = throwError . strMsg $ "newtypes constructors must have a single argument"
148− checkNewtype _ = throwError . strMsg $ "newtypes must have a single constructor"
149− go (d@(DataBindingGroupDeclaration tys) : rest) = do
150− rethrow (mkCompileError "Error in data binding group" Nothing `combineErrors`) $ do
151− let syns = mapMaybe toTypeSynonym tys
152− let dataDecls = mapMaybe toDataDecl tys
153− (syn_ks, data_ks) <- kindsOfAll moduleName syns (map (\(_, name, args, dctors) -> (name, args, concatMap snd dctors)) dataDecls)
154− forM_ (zip dataDecls data_ks) $ \((dtype, name, args, dctors), ctorKind) -> do
155− checkDuplicateTypeArguments $ map fst args
156− let args' = args `withKinds` ctorKind
157− addDataType moduleName dtype name args' dctors ctorKind
158− forM_ (zip syns syn_ks) $ \((name, args, ty), kind) -> do
159− checkDuplicateTypeArguments $ map fst args
160− let args' = args `withKinds` kind
161− addTypeSynonym moduleName name args' ty kind
162− ds <- go rest
163− return $ d : ds
164− where
165− toTypeSynonym (TypeSynonymDeclaration nm args ty) = Just (nm, args, ty)
166− toTypeSynonym (PositionedDeclaration _ _ d') = toTypeSynonym d'
167− toTypeSynonym _ = Nothing
168− toDataDecl (DataDeclaration dtype nm args dctors) = Just (dtype, nm, args, dctors)
169− toDataDecl (PositionedDeclaration _ _ d') = toDataDecl d'
170− toDataDecl _ = Nothing
171− go (TypeSynonymDeclaration name args ty : rest) = do
172− rethrow (mkCompileError ("Error in type synonym " ++ show name) Nothing `combineErrors`) $ do
173− checkDuplicateTypeArguments $ map fst args
174− kind <- kindsOf False moduleName name args [ty]
175− let args' = args `withKinds` kind
176− addTypeSynonym moduleName name args' ty kind
177− ds <- go rest
178− return $ TypeSynonymDeclaration name args ty : ds
179− go (TypeDeclaration _ _ : _) = error "Type declarations should have been removed"
180− go (ValueDeclaration name nameKind [] (Right val) : rest) = do
181− d <- rethrow (mkCompileError ("Error in declaration " ++ show name) Nothing `combineErrors`) $ do
182− valueIsNotDefined moduleName name
183− [(_, (val', ty))] <- typesOf mainModuleName moduleName [(name, val)]
184− addValue moduleName name ty nameKind
185− return $ ValueDeclaration name nameKind [] $ Right val'
186− ds <- go rest
187− return $ d : ds
188− go (ValueDeclaration{} : _) = error "Binders were not desugared"
189− go (BindingGroupDeclaration vals : rest) = do
190− d <- rethrow (mkCompileError ("Error in binding group " ++ show (map (\(ident, _, _) -> ident) vals)) Nothing `combineErrors`) $ do
191− forM_ (map (\(ident, _, _) -> ident) vals) $ \name ->
192− valueIsNotDefined moduleName name
193− tys <- typesOf mainModuleName moduleName $ map (\(ident, _, ty) -> (ident, ty)) vals
194− vals' <- forM [ (name, val, nameKind, ty)
195− | (name, nameKind, _) <- vals
196− , (name', (val, ty)) <- tys
197− , name == name'
198− ] $ \(name, val, nameKind, ty) -> do
199− addValue moduleName name ty nameKind
200− return (name, nameKind, val)
201− return $ BindingGroupDeclaration vals'
202− ds <- go rest
203− return $ d : ds
204− go (d@(ExternDataDeclaration name kind) : rest) = do
205− env <- getEnv
206− putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (kind, ExternData) (types env) }
207− ds <- go rest
208− return $ d : ds
209− go (d@(ExternDeclaration importTy name _ ty) : rest) = do
210− rethrow (mkCompileError ("Error in foreign import declaration " ++ show name) Nothing `combineErrors`) $ do
211− env <- getEnv
212− kind <- kindOf moduleName ty
213− guardWith (strMsg "Expected kind *") $ kind == Star
214− case M.lookup (moduleName, name) (names env) of
215− Just _ -> throwError . strMsg $ show name ++ " is already defined"
216− Nothing -> putEnv (env { names = M.insert (moduleName, name) (ty, Extern importTy, Defined) (names env) })
217− ds <- go rest
218− return $ d : ds
219− go (d@(FixityDeclaration _ name) : rest) = do
220− ds <- go rest
221− env <- getEnv
222− guardWith (strMsg ("Fixity declaration with no binding: " ++ name)) $ M.member (moduleName, Op name) $ names env
223− return $ d : ds
224− go (d@(ImportDeclaration importedModule _ _) : rest) = do
225− tcds <- getTypeClassDictionaries
226− let instances = filter (\tcd -> let Qualified (Just mn) _ = tcdName tcd in importedModule == mn) tcds
227− addTypeClassDictionaries [ tcd { tcdName = Qualified (Just moduleName) ident, tcdType = TCDAlias (canonicalizeDictionary tcd) }
228− | tcd <- instances
229− , tcdExported tcd
230− , let (Qualified _ ident) = tcdName tcd
231− ]
232− ds <- go rest
233− return $ d : ds
234− go (d@(TypeClassDeclaration pn args implies tys) : rest) = do
235− addTypeClass moduleName pn args implies tys
236− ds <- go rest
237− return $ d : ds
238− go (d@(TypeInstanceDeclaration dictName deps className tys _) : rest) = do
239− goInstance d dictName deps className tys rest
240− go (d@(ExternInstanceDeclaration dictName deps className tys) : rest) = do
241− goInstance d dictName deps className tys rest
242− go (PositionedDeclaration pos com d : rest) =
243− rethrowWithPosition pos $ do
244− (d' : rest') <- go (d : rest)
245− return (PositionedDeclaration pos com d' : rest')
246− goInstance :: Declaration -> Ident -> [Constraint] -> Qualified ProperName -> [Type] -> [Declaration] -> Check [Declaration]
247− goInstance d dictName deps className tys rest = do
248− mapM_ (checkTypeClassInstance moduleName) tys
249− forM_ deps $ mapM_ (checkTypeClassInstance moduleName) . snd
250− addTypeClassDictionaries [TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) className tys (Just deps) TCDRegular isInstanceExported]
251− ds <- go rest
252− return $ d : ds
253−
254− where
255−
256− isInstanceExported :: Bool
257− isInstanceExported = any exportsInstance exps
258−
259− exportsInstance :: DeclarationRef -> Bool
260− exportsInstance (TypeInstanceRef name) | name == dictName = True
261− exportsInstance (PositionedDeclarationRef _ _ r) = exportsInstance r
262− exportsInstance _ = False
263−
264− -- |
265− -- This function adds the argument kinds for a type constructor so that they may appear in the externs file,
266− -- extracted from the kind of the type constructor itself.
267− --
268− withKinds :: [(String, Maybe Kind)] -> Kind -> [(String, Maybe Kind)]
269− withKinds [] _ = []
270− withKinds (s@(_, Just _ ):ss) (FunKind _ k) = s : withKinds ss k
271− withKinds ( (s, Nothing):ss) (FunKind k1 k2) = (s, Just k1) : withKinds ss k2
272− withKinds _ _ = error "Invalid arguments to peelKinds"
273−
274−-- |
275−-- Type check an entire module and ensure all types and classes defined within the module that are
276−-- required by exported members are also exported.
277−--
278−typeCheckModule :: Maybe ModuleName -> Module -> Check Module
279−typeCheckModule _ (Module _ _ _ Nothing) = error "exports should have been elaborated"
280−typeCheckModule mainModuleName (Module coms mn decls (Just exps)) = do
281− modify (\s -> s { checkCurrentModule = Just mn })
282− decls' <- typeCheckAll mainModuleName mn exps decls
283− forM_ exps $ \e -> do
284− checkTypesAreExported e
285− checkClassMembersAreExported e
286− checkClassesAreExported e
287− return $ Module coms mn decls' (Just exps)
288− where
289−
290− checkMemberExport :: (Show a) => String -> (Type -> [a]) -> (a -> Bool) -> DeclarationRef -> Check ()
291− checkMemberExport thing extract test (ValueRef name) = do
292− ty <- lookupVariable mn (Qualified (Just mn) name)
293− case find test (extract ty) of
294− Just hiddenType -> throwError . strMsg $
295− "Error in module '" ++ show mn ++ "':\n\
296− \Exporting declaration '" ++ show name ++ "' requires " ++ thing ++ " '" ++ show hiddenType ++ "' to be exported as well"
297− Nothing -> return ()
298− checkMemberExport _ _ _ _ = return ()
299−
300− -- Check that all the type constructors defined in the current module that appear in member types
301− -- have also been exported from the module
302− checkTypesAreExported :: DeclarationRef -> Check ()
303− checkTypesAreExported = checkMemberExport "type" findTcons isTconHidden
304− where
305− findTcons :: Type -> [ProperName]
306− findTcons = everythingOnTypes (++) go
307− where
308− go (TypeConstructor (Qualified (Just mn') name)) | mn' == mn = [name]
309− go _ = []
310− isTconHidden :: ProperName -> Bool
311− isTconHidden tyName = all go exps
312− where
313− go (TypeRef tyName' _) = tyName' /= tyName
314− go _ = True
315−
316− -- Check that all the classes defined in the current module that appear in member types have also
317− -- been exported from the module
318− checkClassesAreExported :: DeclarationRef -> Check ()
319− checkClassesAreExported = checkMemberExport "class" findClasses isClassHidden
320− where
321− findClasses :: Type -> [ProperName]
322− findClasses = everythingOnTypes (++) go
323− where
324− go (ConstrainedType cs _) = mapMaybe (extractCurrentModuleClass . fst) cs
325− go _ = []
326− extractCurrentModuleClass :: Qualified ProperName -> Maybe ProperName
327− extractCurrentModuleClass (Qualified (Just mn') name) | mn == mn' = Just name
328− extractCurrentModuleClass _ = Nothing
329− isClassHidden :: ProperName -> Bool
330− isClassHidden clsName = all go exps
331− where
332− go (TypeClassRef clsName') = clsName' /= clsName
333− go _ = True
334−
335− checkClassMembersAreExported :: DeclarationRef -> Check ()
336− checkClassMembersAreExported (TypeClassRef name) = do
337− let members = ValueRef `map` head (mapMaybe findClassMembers decls)
338− let missingMembers = members \\ exps
339− unless (null missingMembers) $
340− throwError . strMsg $
341− "Error in module '" ++ show mn ++ "':\n\
342− \Class '" ++ show name ++ "' is exported but is missing member exports for '" ++ intercalate "', '" (map (show . runValueRef) missingMembers) ++ "'"
343− where
344− runValueRef :: DeclarationRef -> Ident
345− runValueRef (ValueRef refName) = refName
346− runValueRef _ = error "non-ValueRef passed to runValueRef"
347− findClassMembers :: Declaration -> Maybe [Ident]
348− findClassMembers (TypeClassDeclaration name' _ _ ds) | name == name' = Just $ map extractMemberName ds
349− findClassMembers (PositionedDeclaration _ _ d) = findClassMembers d
350− findClassMembers _ = Nothing
351− extractMemberName :: Declaration -> Ident
352− extractMemberName (PositionedDeclaration _ _ d) = extractMemberName d
353− extractMemberName (TypeDeclaration memberName _) = memberName
354− extractMemberName _ = error "Unexpected declaration in typeclass member list"
355− checkClassMembersAreExported _ = return ()
src/Language/PureScript/TypeChecker/Entailment.hsdeleted−238
@@ -1,238 +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.Except
29−
30−import Language.PureScript.AST
31−import Language.PureScript.Errors
32−import Language.PureScript.Environment
33−import Language.PureScript.Names
34−import Language.PureScript.Pretty
35−import Language.PureScript.TypeChecker.Monad
36−import Language.PureScript.TypeChecker.Synonyms
37−import Language.PureScript.TypeChecker.Unify
38−import Language.PureScript.TypeClassDictionaries
39−import Language.PureScript.Types
40−import qualified Language.PureScript.Constants as C
41−
42−-- |
43−-- A simplified representation of expressions which are used to represent type
44−-- class dictionaries at runtime, which can be compared for equality
45−--
46−data DictionaryValue
47− -- |
48− -- A dictionary which is brought into scope by a local constraint
49− --
50− = LocalDictionaryValue (Qualified Ident)
51− -- |
52− -- A dictionary which is brought into scope by an instance declaration
53− --
54− | GlobalDictionaryValue (Qualified Ident)
55− -- |
56− -- A dictionary which depends on other dictionaries
57− --
58− | DependentDictionaryValue (Qualified Ident) [DictionaryValue]
59− -- |
60− -- A subclass dictionary
61− --
62− | SubclassDictionaryValue DictionaryValue (Qualified ProperName) Integer
63− deriving (Show, Ord, Eq)
64−
65−-- |
66−-- Check that the current set of type class dictionaries entail the specified type class goal, and, if so,
67−-- return a type class dictionary reference.
68−--
69−entails :: Environment -> ModuleName -> [TypeClassDictionaryInScope] -> Constraint -> Bool -> Check Expr
70−entails env moduleName context = solve (sortedNubBy canonicalizeDictionary (filter filterModule context))
71− where
72− sortedNubBy :: (Ord k) => (v -> k) -> [v] -> [v]
73− sortedNubBy f vs = M.elems (M.fromList (map (f &&& id) vs))
74−
75− -- Filter out type dictionaries which are in scope in the current module
76− filterModule :: TypeClassDictionaryInScope -> Bool
77− filterModule (TypeClassDictionaryInScope { tcdName = Qualified (Just mn) _ }) | mn == moduleName = True
78− filterModule (TypeClassDictionaryInScope { tcdName = Qualified Nothing _ }) = True
79− filterModule _ = False
80−
81− solve context' (className, tys) trySuperclasses =
82− checkOverlaps $ go trySuperclasses className tys
83− where
84− go trySuperclasses' className' tys' =
85− -- Look for regular type instances
86− [ mkDictionary (canonicalizeDictionary tcd) args
87− | tcd <- context'
88− -- Make sure the type class name matches the one we are trying to satisfy
89− , className' == tcdClassName tcd
90− -- Make sure the type unifies with the type in the type instance definition
91− , subst <- maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName env) tys' (tcdInstanceTypes tcd)
92− -- Solve any necessary subgoals
93− , args <- solveSubgoals subst (tcdDependencies tcd) ] ++
94−
95− -- Look for implementations via superclasses
96− [ SubclassDictionaryValue suDict superclass index
97− | trySuperclasses'
98− , (subclassName, (args, _, implies)) <- M.toList (typeClasses env)
99− -- Try each superclass
100− , (index, (superclass, suTyArgs)) <- zip [0..] implies
101− -- Make sure the type class name matches the superclass name
102− , className' == superclass
103− -- Make sure the types unify with the types in the superclass implication
104− , subst <- maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName env) tys' suTyArgs
105− -- Finally, satisfy the subclass constraint
106− , args' <- maybeToList $ mapM ((`lookup` subst) . fst) args
107− , suDict <- go True subclassName args' ]
108−
109− -- Create dictionaries for subgoals which still need to be solved by calling go recursively
110− -- E.g. the goal (Show a, Show b) => Show (Either a b) can be satisfied if the current type
111− -- unifies with Either a b, and we can satisfy the subgoals Show a and Show b recursively.
112− solveSubgoals :: [(String, Type)] -> Maybe [Constraint] -> [Maybe [DictionaryValue]]
113− solveSubgoals _ Nothing = return Nothing
114− solveSubgoals subst (Just subgoals) = do
115− dict <- mapM (uncurry (go True) . second (map (replaceAllTypeVars subst))) subgoals
116− return $ Just dict
117− -- Make a dictionary from subgoal dictionaries by applying the correct function
118− mkDictionary :: Qualified Ident -> Maybe [DictionaryValue] -> DictionaryValue
119− mkDictionary fnName Nothing = LocalDictionaryValue fnName
120− mkDictionary fnName (Just []) = GlobalDictionaryValue fnName
121− mkDictionary fnName (Just dicts) = DependentDictionaryValue fnName dicts
122− -- Turn a DictionaryValue into a Expr
123− dictionaryValueToValue :: DictionaryValue -> Expr
124− dictionaryValueToValue (LocalDictionaryValue fnName) = Var fnName
125− dictionaryValueToValue (GlobalDictionaryValue fnName) = Var fnName
126− dictionaryValueToValue (DependentDictionaryValue fnName dicts) = foldl App (Var fnName) (map dictionaryValueToValue dicts)
127− dictionaryValueToValue (SubclassDictionaryValue dict superclassName index) =
128− App (Accessor (C.__superclass_ ++ show superclassName ++ "_" ++ show index)
129− (dictionaryValueToValue dict))
130− valUndefined
131− -- Ensure that a substitution is valid
132− verifySubstitution :: [(String, Type)] -> Maybe [(String, Type)]
133− verifySubstitution subst = do
134− let grps = groupBy ((==) `on` fst) subst
135− guard (all (pairwise (unifiesWith env) . map snd) grps)
136− return $ map head grps
137− -- |
138− -- Check for overlapping instances
139− --
140− checkOverlaps :: [DictionaryValue] -> Check Expr
141− checkOverlaps dicts =
142− case [ (d1, d2) | d1 <- dicts, d2 <- dicts, d1 `overlapping` d2 ] of
143− (d1, d2) : _ -> throwError . strMsg $ unlines
144− [ "Overlapping instances found for " ++ show className ++ " " ++ unwords (map prettyPrintType tys) ++ "."
145− , "For example:"
146− , prettyPrintDictionaryValue d1
147− , "and:"
148− , prettyPrintDictionaryValue d2
149− ]
150− _ -> case chooseSimplestDictionaries dicts of
151− [] -> throwError . strMsg $
152− "No instance found for " ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys)
153− d : _ -> return $ dictionaryValueToValue d
154− -- Choose the simplest DictionaryValues from a list of candidates
155− -- The reason for this function is as follows:
156− -- When considering overlapping instances, we don't want to consider the same dictionary
157− -- to be an overlap of itself when obtained as a superclass of another class.
158− -- Observing that we probably don't want to select a superclass instance when an instance
159− -- is available directly, and that there is no way for a superclass instance to actually
160− -- introduce an overlap that wouldn't have been there already, we simply remove dictionaries
161− -- obtained as superclass instances if there are simpler instances available.
162− chooseSimplestDictionaries :: [DictionaryValue] -> [DictionaryValue]
163− chooseSimplestDictionaries ds = case filter isSimpleDictionaryValue ds of
164− [] -> ds
165− simple -> simple
166− isSimpleDictionaryValue SubclassDictionaryValue{} = False
167− isSimpleDictionaryValue (DependentDictionaryValue _ ds) = all isSimpleDictionaryValue ds
168− isSimpleDictionaryValue _ = True
169− -- |
170− -- Check if two dictionaries are overlapping
171− --
172− -- Dictionaries which are subclass dictionaries cannot overlap, since otherwise the overlap would have
173− -- been caught when constructing superclass dictionaries.
174− --
175− overlapping :: DictionaryValue -> DictionaryValue -> Bool
176− overlapping (LocalDictionaryValue nm1) (LocalDictionaryValue nm2) | nm1 == nm2 = False
177− overlapping (GlobalDictionaryValue nm1) (GlobalDictionaryValue nm2) | nm1 == nm2 = False
178− overlapping (DependentDictionaryValue nm1 ds1) (DependentDictionaryValue nm2 ds2)
179− | nm1 == nm2 = or $ zipWith overlapping ds1 ds2
180− overlapping SubclassDictionaryValue{} _ = False
181− overlapping _ SubclassDictionaryValue{} = False
182− overlapping _ _ = True
183− -- |
184− -- Render a DictionaryValue fit for human consumption in error messages
185− --
186− prettyPrintDictionaryValue :: DictionaryValue -> String
187− prettyPrintDictionaryValue = unlines . indented 0
188− where
189− indented n (LocalDictionaryValue _) = [spaces n ++ "Dictionary in scope"]
190− indented n (GlobalDictionaryValue nm) = [spaces n ++ show nm]
191− indented n (DependentDictionaryValue nm args) = (spaces n ++ show nm ++ " via") : concatMap (indented (n + 2)) args
192− indented n (SubclassDictionaryValue sup nm _) = (spaces n ++ show nm ++ " via superclass") : indented (n + 2) sup
193−
194− spaces n = replicate n ' ' ++ "- "
195−
196− valUndefined :: Expr
197− valUndefined = Var (Qualified (Just (ModuleName [ProperName C.prim])) (Ident C.undefined))
198−
199−-- |
200−-- Check whether the type heads of two types are equal (for the purposes of type class dictionary lookup),
201−-- and return a substitution from type variables to types which makes the type heads unify.
202−--
203−typeHeadsAreEqual :: ModuleName -> Environment -> Type -> Type -> Maybe [(String, Type)]
204−typeHeadsAreEqual _ _ (Skolem _ s1 _) (Skolem _ s2 _) | s1 == s2 = Just []
205−typeHeadsAreEqual _ _ t (TypeVar v) = Just [(v, t)]
206−typeHeadsAreEqual _ _ (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = Just []
207−typeHeadsAreEqual m e (TypeApp h1 t1) (TypeApp h2 t2) = (++) <$> typeHeadsAreEqual m e h1 h2
208− <*> typeHeadsAreEqual m e t1 t2
209−typeHeadsAreEqual m e (SaturatedTypeSynonym name args) t2 = case expandTypeSynonym' e name args of
210− Left _ -> Nothing
211− Right t1 -> typeHeadsAreEqual m e t1 t2
212−typeHeadsAreEqual _ _ REmpty REmpty = Just []
213−typeHeadsAreEqual m e r1@(RCons _ _ _) r2@(RCons _ _ _) =
214− let (s1, r1') = rowToList r1
215− (s2, r2') = rowToList r2
216−
217− int = [ (t1, t2) | (name, t1) <- s1, (name', t2) <- s2, name == name' ]
218− sd1 = [ (name, t1) | (name, t1) <- s1, name `notElem` map fst s2 ]
219− sd2 = [ (name, t2) | (name, t2) <- s2, name `notElem` map fst s1 ]
220− in (++) <$> foldMap (\(t1, t2) -> typeHeadsAreEqual m e t1 t2) int
221− <*> go sd1 r1' sd2 r2'
222− where
223− go :: [(String, Type)] -> Type -> [(String, Type)] -> Type -> Maybe [(String, Type)]
224− go [] REmpty [] REmpty = Just []
225− go [] (TUnknown _) _ _ = Just []
226− go [] (TypeVar v1) [] (TypeVar v2) | v1 == v2 = Just []
227− go [] (Skolem _ s1 _) [] (Skolem _ s2 _) | s1 == s2 = Just []
228− go sd r [] (TypeVar v) = Just [(v, rowFromList (sd, r))]
229− go _ _ _ _ = Nothing
230−typeHeadsAreEqual _ _ _ _ = Nothing
231−
232−-- |
233−-- Check all values in a list pairwise match a predicate
234−--
235−pairwise :: (a -> a -> Bool) -> [a] -> Bool
236−pairwise _ [] = True
237−pairwise _ [_] = True
238−pairwise p (x : xs) = all (p x) xs && pairwise p xs
src/Language/PureScript/TypeChecker/Kinds.hsdeleted−218

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−102

This diff is too big to show here.

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

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−204

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.