git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
swap
355eb9b2495 ahead, 0 behind
307 files changed+2725−18071
since splitsnapshots
unifiedsplit
.gitignore+12 .travis.yml−19 CONTRIBUTING.md−18 ChangeLog.md+3 LICENSE+30−622 README-go.md+48 README.md+38−11 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/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/failing/UnknownValue.purs−25 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/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−16 examples/passing/BindingGroups.purs−8 examples/passing/BlockString.purs−12 examples/passing/CaseInDo.purs−20 examples/passing/CheckSynonymBug.purs−14 examples/passing/CheckTypeClass.purs−16 examples/passing/Church.purs−18 examples/passing/Collatz.purs−18 examples/passing/Comparisons.purs−23 examples/passing/Conditional.purs−9 examples/passing/Console.purs−13 examples/passing/DataAndType.purs−7 examples/passing/DeepArrayBinder.purs−16 examples/passing/DeepCase.purs−14 examples/passing/Do.purs−67 examples/passing/Dollar.purs−16 examples/passing/Eff.purs−25 examples/passing/EmptyDataDecls.purs−30 examples/passing/EmptyRow.purs−8 examples/passing/EmptyTypeClass.purs−12 examples/passing/EqOrd.purs−14 examples/passing/ExternData.purs−13 examples/passing/ExternRaw.purs−13 examples/passing/FFI.purs−11 examples/passing/Fib.purs−15 examples/passing/FinalTagless.purs−22 examples/passing/ForeignInstance.purs−20 examples/passing/FunctionScope.purs−17 examples/passing/Functions.purs−15 examples/passing/Functions2.purs−17 examples/passing/Guards.purs−29 examples/passing/HoistError.purs−17 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/ObjectSynonym.purs−13 examples/passing/ObjectUpdate.purs−18 examples/passing/ObjectUpdate2.purs−14 examples/passing/Objects.purs−35 examples/passing/OneConstructor.purs−7 examples/passing/OperatorAssociativity.purs−15 examples/passing/Operators.purs−84 examples/passing/OptimizerBug.purs−9 examples/passing/PartialFunction.purs−17 examples/passing/Patterns.purs−28 examples/passing/Person.purs−16 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/RuntimeScopeIssue.purs−19 examples/passing/Sequence.purs−12 examples/passing/ShadowedRename.purs−19 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/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−114 package.yaml+86 prelude/README.md−375 prelude/images/Prelude.png prelude/prelude.purs−919 prelude/updateDocs.sh−11 psc-docs/Main.hs−228 psc-make/Main.hs−171 psc/Main.hs−202 psci/Commands.hs−87 psci/Main.hs−607 psci/Parser.hs−82 psgo.cabal+145 purescript.cabal−176 src/CodeGen/IL.hs+321 src/CodeGen/IL/Common.hs+196 src/CodeGen/IL/Optimizer.hs+81 src/CodeGen/IL/Optimizer/Common.hs+18 src/CodeGen/IL/Optimizer/Inliner.hs+435 src/CodeGen/IL/Optimizer/MagicDo.hs+146 src/CodeGen/IL/Optimizer/TCO.hs+141 src/CodeGen/IL/Printer.hs+527 src/Language/PureScript.hs−252 src/Language/PureScript/AST.hs−23 src/Language/PureScript/AST/Binders.hs−86 src/Language/PureScript/AST/Declarations.hs−407 src/Language/PureScript/AST/Operators.hs−39 src/Language/PureScript/AST/SourcePos.hs−53 src/Language/PureScript/AST/Traversals.hs−383 src/Language/PureScript/CodeGen.hs−25 src/Language/PureScript/CodeGen/Externs.hs−109 src/Language/PureScript/CodeGen/JS.hs−344 src/Language/PureScript/CodeGen/JS/AST.hs−328 src/Language/PureScript/CodeGen/JS/Common.hs−141 src/Language/PureScript/CodeGen/JS/Optimizer.hs−76 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−191 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/Constants.hs−224 src/Language/PureScript/CoreFn.hs−26 src/Language/PureScript/CoreFn/Ann.hs−30 src/Language/PureScript/CoreFn/Binders.hs−47 src/Language/PureScript/CoreFn/Desugar.hs−242 src/Language/PureScript/CoreFn/Expr.hs−97 src/Language/PureScript/CoreFn/Literals.hs−45 src/Language/PureScript/CoreFn/Meta.hs−54 src/Language/PureScript/CoreFn/Module.hs−30 src/Language/PureScript/CoreFn/Traversals.hs−85 src/Language/PureScript/DeadCodeElimination.hs−102 src/Language/PureScript/Environment.hs−236 src/Language/PureScript/Errors.hs−140 src/Language/PureScript/Kinds.hs−60 src/Language/PureScript/ModuleDependencies.hs−76 src/Language/PureScript/Names.hs−85 src/Language/PureScript/Options.hs−89 src/Language/PureScript/Parser.hs−35 src/Language/PureScript/Parser/Common.hs−133 src/Language/PureScript/Parser/Declarations.hs−488 src/Language/PureScript/Parser/Kinds.hs−45 src/Language/PureScript/Parser/Lexer.hs−489 src/Language/PureScript/Parser/State.hs−30 src/Language/PureScript/Parser/Types.hs−132 src/Language/PureScript/Pretty.hs−32 src/Language/PureScript/Pretty/Common.hs−69 src/Language/PureScript/Pretty/JS.hs−265 src/Language/PureScript/Pretty/Kinds.hs−59 src/Language/PureScript/Pretty/Types.hs−129 src/Language/PureScript/Pretty/Values.hs−241 src/Language/PureScript/Renamer.hs−194 src/Language/PureScript/Sugar.hs−59 src/Language/PureScript/Sugar/BindingGroups.hs−205 src/Language/PureScript/Sugar/CaseDeclarations.hs−127 src/Language/PureScript/Sugar/DoNotation.hs−74 src/Language/PureScript/Sugar/Names.hs−522 src/Language/PureScript/Sugar/Operators.hs−152 src/Language/PureScript/Sugar/TypeClasses.hs−290 src/Language/PureScript/Sugar/TypeDeclarations.hs−69 src/Language/PureScript/Supply.hs−56 src/Language/PureScript/Traversals.hs−41 src/Language/PureScript/TypeChecker.hs−355 src/Language/PureScript/TypeChecker/Entailment.hs−217 src/Language/PureScript/TypeChecker/Kinds.hs−192 src/Language/PureScript/TypeChecker/Monad.hs−232 src/Language/PureScript/TypeChecker/Rows.hs−66 src/Language/PureScript/TypeChecker/Skolems.hs−114 src/Language/PureScript/TypeChecker/Subsumption.hs−103 src/Language/PureScript/TypeChecker/Synonyms.hs−110 src/Language/PureScript/TypeChecker/Types.hs−678 src/Language/PureScript/TypeChecker/Unify.hs−184 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+38−11
@@ -1,14 +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)
1+[![PureScript](https://raw.githubusercontent.com/purescript/purescript/master/logo.png)](http://purescript.org)
32
4−PureScript is a small strongly, statically typed programming language with expressive types, written in and inspired by Haskell, and compiling to Javascript.
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.
54
6−## Resources
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).
76
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−- [Try PureScript!](http://try.purescript.org/)
13−- [Release Notes](https://github.com/purescript/purescript/blob/master/RELEASE-0.6.md)
14−- [Contributing to PureScript](https://github.com/purescript/purescript/blob/master/CONTRIBUTING.md)
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/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/failing/UnknownValue.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−test = runSTArray (do
9− a <- newSTArray 2 0
10− pokeSTArray a 0 1
11− pokeSTArray a 1 2
12− return a)
13−
14−fromTo lo hi = runSTArray (do
15− arr <- newSTArray (hi - lo + 1) 0
16− (let
17− go lo hi _ arr | lo > hi = return arr
18− go lo hi i arr = do
19− pokeSTArray arrr i lo
20− go (lo + 1) hi (i + 1) arr
21− in go lo hi 0 arr))
22−
23−main = do
24− let t1 = runPure (fromTo 10 20)
25− trace "Done"
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/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−16
@@ -1,16 +0,0 @@
1−module Main where
2−
3−import Prelude
4−
5−tail = \(_:xs) -> xs
6−
7−foreign import error
8− "function error(msg) {\
9− \ throw msg;\
10− \}" :: forall a. String -> a
11−
12−main =
13− let ts = tail [1, 2, 3] in
14− if ts == [2, 3]
15− then Debug.Trace.trace "Done"
16− 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/CheckSynonymBug.pursdeleted−14
@@ -1,14 +0,0 @@
1−module Main where
2−
3− import Prelude
4−
5− type Foo a = [a]
6−
7− foreign import length
8− "function length(a) {\
9− \ return a.length;\
10− \}" :: forall a. [a] -> Number
11−
12− foo _ = length ([] :: Foo Number)
13−
14− 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−23
@@ -1,23 +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− "function assert(x) {\
10− \ return function () {\
11− \ if (!x) throw new Error('assertion failed');\
12− \ return {};\
13− \ };\
14− \};" :: forall e. Boolean -> Eff (assert :: Assert | e) Unit
15−
16−main = do
17− assert (1 < 2)
18− assert (2 == 2)
19− assert (3 > 1)
20− assert ("a" < "b")
21− assert ("a" == "a")
22− assert ("z" > "a")
23− 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−16
@@ -1,16 +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− "function explode() {\
11− \ throw new Error('Incorrect result');\
12− \}" :: forall eff a. Eff eff a
13−
14−main = case match2 [1, 2, 3, 4, 5, 6, 7, 8, 9] of
15− 100 -> Debug.Trace.trace "Done"
16− _ -> 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−30
@@ -1,30 +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− "function concat(l1) {\
15− \ return function (l2) {\
16− \ return l1.concat(l2);\
17− \ };\
18− \}" :: forall a. [a] -> [a] -> [a]
19−
20−cons' :: forall a n. a -> ArrayBox n a -> ArrayBox (S n) a
21−cons' x (ArrayBox xs) = ArrayBox $ concat [x] xs
22−
23−foreign import error
24− "function error(msg) {\
25− \ throw msg;\
26− \}" :: forall a. String -> a
27−
28−main = case cons' 1 $ cons' 2 $ cons' 3 nil of
29− ArrayBox [1, 2, 3] -> Debug.Trace.trace "Done"
30− _ -> 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/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−13
@@ -1,13 +0,0 @@
1−module Main where
2−
3−foreign import first "function first(xs) { return xs[0]; }" :: forall a. [a] -> a
4−
5−foreign import loop "function loop() { while (true) {} }" :: forall a. a
6−
7−foreign import concat "function concat(xs) { \
8− \ return function(ys) { \
9− \ return xs.concat(ys); \
10− \ };\
11− \}" :: forall a. [a] -> [a] -> [a]
12−
13−main = Debug.Trace.trace "Done"
examples/passing/FFI.pursdeleted−11
@@ -1,11 +0,0 @@
1−module Main where
2−
3−foreign import foo
4− "function foo(s) {\
5− \ return s;\
6− \}" :: String -> String
7−
8−bar :: String -> String
9−bar _ = foo "test"
10−
11−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−17
@@ -1,17 +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− "function error(msg) {\
10− \ throw msg;\
11− \}" :: forall a. String -> a
12−
13− main = do
14− let value = mkValue 1
15− if value == 1
16− then Debug.Trace.trace "Done"
17− 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−17
@@ -1,17 +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− "function error(msg) {\
10− \ throw msg;\
11− \}" :: forall a. String -> a
12−
13− main = do
14− let value = test "Done" {}
15− if value == "Done"
16− then Debug.Trace.trace "Done"
17− 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−17
@@ -1,17 +0,0 @@
1−module Main where
2−
3−import Control.Monad.Eff
4−import Debug.Trace
5−
6−foreign import f
7− "function f(x) {\
8− \ return function () {\
9− \ if (x !== 0) throw new Error('x is not 0');\
10− \ }\
11− \}" :: forall e. Number -> Eff e Number
12−
13−main = do
14− let x = 0
15− f x
16− let x = 1 + 1
17− 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/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/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−15
@@ -1,15 +0,0 @@
1−module Main where
2−
3−import Control.Monad.Eff
4−
5−bug :: Number -> Number -> Number
6−bug a b = 0 - (a - b)
7−
8−foreign import explode
9− "function explode() {\
10− \ throw new Error('Assertion failed!');\
11− \}":: forall eff a. Eff eff a
12−
13−main = case bug 0 2 of
14− 2 -> Debug.Trace.trace "Done!"
15− _ -> explode
examples/passing/Operators.pursdeleted−84
@@ -1,84 +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− main = do
68− let t1 = test1 1 2 (\x y -> x + y)
69− let t2 = test2
70− let t3 = test3
71− let t4 = test4
72− let t5 = test5
73− let t6 = test6
74− let t7 = test7
75− let t8 = test8
76− let t9 = test9
77− let t10 = test10
78− let t11 = test11
79− let t12 = test12 k 1 2
80− let t13 = test13 k 1 2
81− let t14 = test14 1 2
82− let t15 = test15 1 2
83− let t16 = test16 1 2
84− 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−17
@@ -1,17 +0,0 @@
1−module Main where
2−
3−foreign import testError
4− "function testError(f) {\
5− \ try {\
6− \ return f();\
7− \ } catch (e) {\
8− \ if (e instanceof Error) return 'success';\
9− \ throw new Error('Pattern match failure is not Error');\
10− \ }\
11− \}" :: (Unit -> Number) -> String
12−
13−fn :: Number -> Number
14−fn 0 = 0
15−fn 1 = 2
16−
17−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−16
@@ -1,16 +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− "function itoa(n) {\
9− \ return n.toString();\
10− \}" :: Number -> String
11−
12− showPerson :: Person -> String
13− showPerson = \p -> case p of
14− Person o -> o.name ++ ", aged " ++ itoa(o.age)
15−
16− 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/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/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−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− "function f(x) {\
8− \ return function () {\
9− \ if (x !== 2) throw new Error('x is not 2');\
10− \ }\
11− \}" :: forall e. Number -> Eff e Number
12−
13−foo foo = let foo_1 = \_ -> foo
14− foo_2 = foo_1 unit + 1
15− in foo_2
16−
17−main = do
18− f (foo 1)
19− 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/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−114
@@ -1,114 +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 (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−import qualified System.IO.UTF8 as U
35−
36−
37−data HierarchyOptions = HierarchyOptions
38− { hierachyInput :: FilePath
39− , hierarchyOutput :: Maybe FilePath
40− }
41−
42−newtype SuperMap = SuperMap { unSuperMap :: Either P.ProperName (P.ProperName, P.ProperName) }
43− deriving Eq
44−
45−instance Show SuperMap where
46− show (SuperMap (Left sub)) = show sub
47− show (SuperMap (Right (super, sub))) = show super ++ " -> " ++ show sub
48−
49−instance Ord SuperMap where
50− compare (SuperMap s) (SuperMap s') = getCls s `compare` getCls s'
51− where
52− getCls = either id snd
53−
54−runModuleName :: P.ModuleName -> String
55−runModuleName (P.ModuleName pns) = intercalate "_" (P.runProperName `map` pns)
56−
57−readInput :: FilePath -> IO (Either Par.ParseError [P.Module])
58−readInput filename = do
59− content <- U.readFile filename
60− return $ fmap (map snd) $ P.parseModulesFromFiles id [(filename, content)]
61−
62−compile :: HierarchyOptions -> IO ()
63−compile (HierarchyOptions input mOutput) = do
64− modules <- readInput input
65− case modules of
66− Left err -> U.hPutStr stderr (show err) >> exitFailure
67− Right ms -> do
68− for_ ms $ \(P.Module moduleName decls _) ->
69− let name = runModuleName moduleName
70− tcs = filter P.isTypeClassDeclaration decls
71− supers = sort . nub . filter (not . null) $ fmap superClasses tcs
72− prologue = "digraph " ++ name ++ " {\n"
73− body = intercalate "\n" (concatMap (fmap (\s -> " " ++ show s ++ ";")) supers)
74− epilogue = "\n}"
75− hier = prologue ++ body ++ epilogue
76− in unless (null supers) $ case mOutput of
77− Just output -> do
78− createDirectoryIfMissing True output
79− U.writeFile (output </> name) hier
80− Nothing -> U.putStrLn hier
81− exitSuccess
82−
83−superClasses :: P.Declaration -> [SuperMap]
84−superClasses (P.TypeClassDeclaration sub _ supers@(_:_) _) =
85− fmap (\(P.Qualified _ super, _) -> SuperMap (Right (super, sub))) supers
86−superClasses (P.TypeClassDeclaration sub _ _ _) = [SuperMap (Left sub)]
87−superClasses (P.PositionedDeclaration _ decl) = superClasses decl
88−superClasses _ = []
89−
90−inputFile :: Parser FilePath
91−inputFile = strArgument $
92− metavar "FILE"
93− <> value "main.purs"
94− <> showDefault
95− <> help "The input file to generate a hierarchy from"
96−
97−outputFile :: Parser (Maybe FilePath)
98−outputFile = optional . strOption $
99− short 'o'
100− <> long "output"
101− <> help "The output directory"
102−
103−pscOptions :: Parser HierarchyOptions
104−pscOptions = HierarchyOptions <$> inputFile
105− <*> outputFile
106−
107−main :: IO ()
108−main = execParser opts >>= compile
109− where
110− opts = info (helper <*> pscOptions) infoModList
111− infoModList = fullDesc <> headerInfo <> footerInfo
112− headerInfo = header "hierarchy - Creates a GraphViz directed graph of PureScript TypeClasses"
113− footerInfo = footer $ "hierarchy " ++ showVersion Paths.version
114−
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−375
@@ -1,375 +0,0 @@
1−# Module Documentation
2−
3−## Module Prelude
4−
5−### Types
6−
7− data Ordering where
8− LT :: Ordering
9− GT :: Ordering
10− EQ :: Ordering
11−
12− newtype Unit where
13− Unit :: { } -> Unit
14−
15−
16−### Type Classes
17−
18−![Prelude](images/Prelude.png)
19−
20− class (Apply f) <= Applicative f where
21− pure :: forall a. a -> f a
22−
23− class (Functor f) <= Apply f where
24− (<*>) :: forall a b. f (a -> b) -> f a -> f b
25−
26− class (Apply m) <= Bind m where
27− (>>=) :: forall a b. m a -> (a -> m b) -> m b
28−
29− class Bits b where
30− (.&.) :: b -> b -> b
31− (.|.) :: b -> b -> b
32− (.^.) :: b -> b -> b
33− shl :: b -> Number -> b
34− shr :: b -> Number -> b
35− zshr :: b -> Number -> b
36− complement :: b -> b
37−
38− class BoolLike b where
39− (&&) :: b -> b -> b
40− (||) :: b -> b -> b
41− not :: b -> b
42−
43− class (Semigroupoid a) <= Category a where
44− id :: forall t. a t t
45−
46− class Eq a where
47− (==) :: a -> a -> Boolean
48− (/=) :: a -> a -> Boolean
49−
50− class Functor f where
51− (<$>) :: forall a b. (a -> b) -> f a -> f b
52−
53− class (Applicative m, Bind m) <= Monad m where
54−
55− class Num a where
56− (+) :: a -> a -> a
57− (-) :: a -> a -> a
58− (*) :: a -> a -> a
59− (/) :: a -> a -> a
60− (%) :: a -> a -> a
61− negate :: a -> a
62−
63− class (Eq a) <= Ord a where
64− compare :: a -> a -> Ordering
65−
66− class Semigroup a where
67− (<>) :: a -> a -> a
68−
69− class Semigroupoid a where
70− (<<<) :: forall b c d. a c d -> a b c -> a b d
71−
72− class Show a where
73− show :: a -> String
74−
75−
76−### Type Class Instances
77−
78− instance applicativeArr :: Applicative (Prim.Function r)
79−
80− instance applyArr :: Apply (Prim.Function r)
81−
82− instance bindArr :: Bind (Prim.Function r)
83−
84− instance bitsNumber :: Bits Number
85−
86− instance boolLikeBoolean :: BoolLike Boolean
87−
88− instance categoryArr :: Category Prim.Function
89−
90− instance eqArray :: (Eq a) => Eq [a]
91−
92− instance eqBoolean :: Eq Boolean
93−
94− instance eqNumber :: Eq Number
95−
96− instance eqOrdering :: Eq Ordering
97−
98− instance eqString :: Eq String
99−
100− instance eqUnit :: Eq Unit
101−
102− instance functorArr :: Functor (Prim.Function r)
103−
104− instance monadArr :: Monad (Prim.Function r)
105−
106− instance numNumber :: Num Number
107−
108− instance ordArray :: (Ord a) => Ord [a]
109−
110− instance ordBoolean :: Ord Boolean
111−
112− instance ordNumber :: Ord Number
113−
114− instance ordString :: Ord String
115−
116− instance ordUnit :: Ord Unit
117−
118− instance semigroupArr :: (Semigroup s') => Semigroup (s -> s')
119−
120− instance semigroupString :: Semigroup String
121−
122− instance semigroupUnit :: Semigroup Unit
123−
124− instance semigroupoidArr :: Semigroupoid Prim.Function
125−
126− instance showArray :: (Show a) => Show [a]
127−
128− instance showBoolean :: Show Boolean
129−
130− instance showNumber :: Show Number
131−
132− instance showOrdering :: Show Ordering
133−
134− instance showString :: Show String
135−
136− instance showUnit :: Show Unit
137−
138−
139−### Values
140−
141− (#) :: forall a b. a -> (a -> b) -> b
142−
143− ($) :: forall a b. (a -> b) -> a -> b
144−
145− (++) :: forall s. (Semigroup s) => s -> s -> s
146−
147− (:) :: forall a. a -> [a] -> [a]
148−
149− (<#>) :: forall f a b. (Functor f) => f a -> (a -> b) -> f b
150−
151− (<) :: forall a. (Ord a) => a -> a -> Boolean
152−
153− (<=) :: forall a. (Ord a) => a -> a -> Boolean
154−
155− (>) :: forall a. (Ord a) => a -> a -> Boolean
156−
157− (>=) :: forall a. (Ord a) => a -> a -> Boolean
158−
159− (>>>) :: forall a b c d. (Semigroupoid a) => a b c -> a c d -> a b d
160−
161− ap :: forall m a b. (Monad m) => m (a -> b) -> m a -> m b
162−
163− asTypeOf :: forall a. a -> a -> a
164−
165− cons :: forall a. a -> [a] -> [a]
166−
167− const :: forall a b. a -> b -> a
168−
169− flip :: forall a b c. (a -> b -> c) -> b -> a -> c
170−
171− liftA1 :: forall f a b. (Applicative f) => (a -> b) -> f a -> f b
172−
173− liftM1 :: forall m a b. (Monad m) => (a -> b) -> m a -> m b
174−
175− otherwise :: Boolean
176−
177− refEq :: forall a. a -> a -> Boolean
178−
179− refIneq :: forall a. a -> a -> Boolean
180−
181− return :: forall m a. (Monad m) => a -> m a
182−
183− unit :: Unit
184−
185− void :: forall f a. (Functor f) => f a -> f Unit
186−
187−
188−## Module Data.Function
189−
190−### Types
191−
192− data Fn0 :: * -> *
193−
194− data Fn1 :: * -> * -> *
195−
196− data Fn10 :: * -> * -> * -> * -> * -> * -> * -> * -> * -> * -> * -> *
197−
198− data Fn2 :: * -> * -> * -> *
199−
200− data Fn3 :: * -> * -> * -> * -> *
201−
202− data Fn4 :: * -> * -> * -> * -> * -> *
203−
204− data Fn5 :: * -> * -> * -> * -> * -> * -> *
205−
206− data Fn6 :: * -> * -> * -> * -> * -> * -> * -> *
207−
208− data Fn7 :: * -> * -> * -> * -> * -> * -> * -> * -> *
209−
210− data Fn8 :: * -> * -> * -> * -> * -> * -> * -> * -> * -> *
211−
212− data Fn9 :: * -> * -> * -> * -> * -> * -> * -> * -> * -> * -> *
213−
214−
215−### Values
216−
217− mkFn0 :: forall a. (Unit -> a) -> Fn0 a
218−
219− mkFn1 :: forall a b. (a -> b) -> Fn1 a b
220−
221− 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
222−
223− mkFn2 :: forall a b c. (a -> b -> c) -> Fn2 a b c
224−
225− mkFn3 :: forall a b c d. (a -> b -> c -> d) -> Fn3 a b c d
226−
227− mkFn4 :: forall a b c d e. (a -> b -> c -> d -> e) -> Fn4 a b c d e
228−
229− mkFn5 :: forall a b c d e f. (a -> b -> c -> d -> e -> f) -> Fn5 a b c d e f
230−
231− mkFn6 :: forall a b c d e f g. (a -> b -> c -> d -> e -> f -> g) -> Fn6 a b c d e f g
232−
233− 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
234−
235− 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
236−
237− 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
238−
239− on :: forall a b c. (b -> b -> c) -> (a -> b) -> a -> a -> c
240−
241− runFn0 :: forall a. Fn0 a -> a
242−
243− runFn1 :: forall a b. Fn1 a b -> a -> b
244−
245− 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
246−
247− runFn2 :: forall a b c. Fn2 a b c -> a -> b -> c
248−
249− runFn3 :: forall a b c d. Fn3 a b c d -> a -> b -> c -> d
250−
251− runFn4 :: forall a b c d e. Fn4 a b c d e -> a -> b -> c -> d -> e
252−
253− runFn5 :: forall a b c d e f. Fn5 a b c d e f -> a -> b -> c -> d -> e -> f
254−
255− runFn6 :: forall a b c d e f g. Fn6 a b c d e f g -> a -> b -> c -> d -> e -> f -> g
256−
257− 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
258−
259− 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
260−
261− 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
262−
263−
264−## Module Data.Eq
265−
266−### Types
267−
268− newtype Ref a where
269− Ref :: a -> Ref a
270−
271−
272−### Type Class Instances
273−
274− instance eqRef :: Eq (Ref a)
275−
276− instance functorRef :: Functor Ref
277−
278−
279−### Values
280−
281− liftRef :: forall a b. (a -> a -> b) -> Ref a -> Ref a -> b
282−
283−
284−## Module Prelude.Unsafe
285−
286−### Values
287−
288− unsafeIndex :: forall a. [a] -> Number -> a
289−
290−
291−## Module Control.Monad.Eff
292−
293−### Types
294−
295− data Eff :: # ! -> * -> *
296−
297− type Pure a = forall e. Eff e a
298−
299−
300−### Type Class Instances
301−
302− instance applicativeEff :: Applicative (Eff e)
303−
304− instance applyEff :: Apply (Eff e)
305−
306− instance bindEff :: Bind (Eff e)
307−
308− instance functorEff :: Functor (Eff e)
309−
310− instance monadEff :: Monad (Eff e)
311−
312−
313−### Values
314−
315− bindE :: forall e a b. Eff e a -> (a -> Eff e b) -> Eff e b
316−
317− forE :: forall e. Number -> Number -> (Number -> Eff e Unit) -> Eff e Unit
318−
319− foreachE :: forall e a. [a] -> (a -> Eff e Unit) -> Eff e Unit
320−
321− returnE :: forall e a. a -> Eff e a
322−
323− runPure :: forall a. Pure a -> a
324−
325− untilE :: forall e. Eff e Boolean -> Eff e Unit
326−
327− whileE :: forall e a. Eff e Boolean -> Eff e a -> Eff e Unit
328−
329−
330−## Module Control.Monad.Eff.Unsafe
331−
332−### Values
333−
334− unsafeInterleaveEff :: forall eff1 eff2 a. Eff eff1 a -> Eff eff2 a
335−
336−
337−## Module Debug.Trace
338−
339−### Types
340−
341− data Trace :: !
342−
343−
344−### Values
345−
346− print :: forall a r. (Show a) => a -> Eff (trace :: Trace | r) Unit
347−
348− trace :: forall r. String -> Eff (trace :: Trace | r) Unit
349−
350−
351−## Module Control.Monad.ST
352−
353−### Types
354−
355− data ST :: * -> !
356−
357− data STRef :: * -> * -> *
358−
359−
360−### Values
361−
362− modifySTRef :: forall a h r. STRef h a -> (a -> a) -> Eff (st :: ST h | r) a
363−
364− newSTRef :: forall a h r. a -> Eff (st :: ST h | r) (STRef h a)
365−
366− pureST :: forall a. (forall h r. Eff (st :: ST h | r) a) -> a
367−
368− readSTRef :: forall a h r. STRef h a -> Eff (st :: ST h | r) a
369−
370− runST :: forall a r. (forall h. Eff (st :: ST h | r) a) -> Eff r a
371−
372− writeSTRef :: forall a h r. STRef h a -> a -> Eff (st :: ST h | r) a
373−
374−
375−
prelude/images/Prelude.pngdeleted

Binary file not shown.

prelude/prelude.pursdeleted−919
@@ -1,919 +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− , Num, (+), (-), (*), (/), (%)
17− , negate
18− , Eq, (==), (/=), refEq, refIneq
19− , Ord, Ordering(..), compare, (<), (>), (<=), (>=)
20− , Bits, (.&.), (.|.), (.^.), shl, shr, zshr, complement
21− , BoolLike, (&&), (||)
22− , not
23− , Semigroup, (<>), (++)
24− , Unit(..), unit
25− ) where
26−
27− otherwise :: Boolean
28− otherwise = true
29−
30− flip :: forall a b c. (a -> b -> c) -> b -> a -> c
31− flip f b a = f a b
32−
33− const :: forall a b. a -> b -> a
34− const a _ = a
35−
36− asTypeOf :: forall a. a -> a -> a
37− asTypeOf x _ = x
38−
39− infixr 9 >>>
40− infixr 9 <<<
41−
42− class Semigroupoid a where
43− (<<<) :: forall b c d. a c d -> a b c -> a b d
44−
45− instance semigroupoidArr :: Semigroupoid (->) where
46− (<<<) f g x = f (g x)
47−
48− (>>>) :: forall a b c d. (Semigroupoid a) => a b c -> a c d -> a b d
49− (>>>) f g = g <<< f
50−
51− class (Semigroupoid a) <= Category a where
52− id :: forall t. a t t
53−
54− instance categoryArr :: Category (->) where
55− id x = x
56−
57− infixr 0 $
58− infixl 0 #
59−
60− ($) :: forall a b. (a -> b) -> a -> b
61− ($) f x = f x
62−
63− (#) :: forall a b. a -> (a -> b) -> b
64− (#) x f = f x
65−
66− infixr 6 :
67−
68− (:) :: forall a. a -> [a] -> [a]
69− (:) = cons
70−
71− foreign import cons
72− "function cons(e) {\
73− \ return function(l) {\
74− \ return [e].concat(l);\
75− \ };\
76− \}" :: forall a. a -> [a] -> [a]
77−
78− class Show a where
79− show :: a -> String
80−
81− foreign import showStringImpl
82− "function showStringImpl(s) {\
83− \ return JSON.stringify(s);\
84− \}" :: String -> String
85−
86− instance showUnit :: Show Unit where
87− show (Unit {}) = "Unit {}"
88−
89− instance showString :: Show String where
90− show = showStringImpl
91−
92− instance showBoolean :: Show Boolean where
93− show true = "true"
94− show false = "false"
95−
96− foreign import showNumberImpl "function showNumberImpl(n) {\
97− \ return n.toString();\
98− \}" :: Number -> String
99−
100− instance showNumber :: Show Number where
101− show = showNumberImpl
102−
103− foreign import showArrayImpl
104− "function showArrayImpl(f) {\
105− \ return function(xs) {\
106− \ var ss = [];\
107− \ for (var i = 0, l = xs.length; i < l; i++) {\
108− \ ss[i] = f(xs[i]);\
109− \ }\
110− \ return '[' + ss.join(',') + ']';\
111− \ };\
112− \}" :: forall a. (a -> String) -> [a] -> String
113−
114− instance showArray :: (Show a) => Show [a] where
115− show = showArrayImpl show
116−
117− infixl 4 <$>
118− infixl 1 <#>
119−
120− class Functor f where
121− (<$>) :: forall a b. (a -> b) -> f a -> f b
122−
123− (<#>) :: forall f a b. (Functor f) => f a -> (a -> b) -> f b
124− (<#>) fa f = f <$> fa
125−
126− void :: forall f a. (Functor f) => f a -> f Unit
127− void fa = const unit <$> fa
128−
129− infixl 4 <*>
130−
131− class (Functor f) <= Apply f where
132− (<*>) :: forall a b. f (a -> b) -> f a -> f b
133−
134− class (Apply f) <= Applicative f where
135− pure :: forall a. a -> f a
136−
137− liftA1 :: forall f a b. (Applicative f) => (a -> b) -> f a -> f b
138− liftA1 f a = pure f <*> a
139−
140− infixl 1 >>=
141−
142− class (Apply m) <= Bind m where
143− (>>=) :: forall a b. m a -> (a -> m b) -> m b
144−
145− class (Applicative m, Bind m) <= Monad m
146−
147− return :: forall m a. (Monad m) => a -> m a
148− return = pure
149−
150− liftM1 :: forall m a b. (Monad m) => (a -> b) -> m a -> m b
151− liftM1 f a = do
152− a' <- a
153− return (f a')
154−
155− ap :: forall m a b. (Monad m) => m (a -> b) -> m a -> m b
156− ap f a = do
157− f' <- f
158− a' <- a
159− return (f' a')
160−
161− instance functorArr :: Functor ((->) r) where
162− (<$>) = (<<<)
163−
164− instance applyArr :: Apply ((->) r) where
165− (<*>) f g x = f x (g x)
166−
167− instance applicativeArr :: Applicative ((->) r) where
168− pure = const
169−
170− instance bindArr :: Bind ((->) r) where
171− (>>=) m f x = f (m x) x
172−
173− instance monadArr :: Monad ((->) r)
174−
175− infixl 7 *
176− infixl 7 /
177− infixl 7 %
178−
179− infixl 6 -
180− infixl 6 +
181−
182− class Num a where
183− (+) :: a -> a -> a
184− (-) :: a -> a -> a
185− (*) :: a -> a -> a
186− (/) :: a -> a -> a
187− (%) :: a -> a -> a
188− negate :: a -> a
189−
190− foreign import numAdd "function numAdd(n1) {\
191− \ return function(n2) {\
192− \ return n1 + n2;\
193− \ };\
194− \}" :: Number -> Number -> Number
195−
196− foreign import numSub "function numSub(n1) {\
197− \ return function(n2) {\
198− \ return n1 - n2;\
199− \ };\
200− \}" :: Number -> Number -> Number
201−
202− foreign import numMul "function numMul(n1) {\
203− \ return function(n2) {\
204− \ return n1 * n2;\
205− \ };\
206− \}" :: Number -> Number -> Number
207−
208− foreign import numDiv "function numDiv(n1) {\
209− \ return function(n2) {\
210− \ return n1 / n2;\
211− \ };\
212− \}" :: Number -> Number -> Number
213−
214− foreign import numMod "function numMod(n1) {\
215− \ return function(n2) {\
216− \ return n1 % n2;\
217− \ };\
218− \}" :: Number -> Number -> Number
219−
220− foreign import numNegate "function numNegate(n) {\
221− \ return -n;\
222− \}" :: Number -> Number
223−
224− instance numNumber :: Num Number where
225− (+) = numAdd
226− (-) = numSub
227− (*) = numMul
228− (/) = numDiv
229− (%) = numMod
230− negate = numNegate
231−
232− newtype Unit = Unit {}
233−
234− unit :: Unit
235− unit = Unit {}
236−
237− infix 4 ==
238− infix 4 /=
239−
240− class Eq a where
241− (==) :: a -> a -> Boolean
242− (/=) :: a -> a -> Boolean
243−
244− foreign import refEq
245− "function refEq(r1) {\
246− \ return function(r2) {\
247− \ return r1 === r2;\
248− \ };\
249− \}" :: forall a. a -> a -> Boolean
250−
251− foreign import refIneq
252− "function refIneq(r1) {\
253− \ return function(r2) {\
254− \ return r1 !== r2;\
255− \ };\
256− \}" :: forall a. a -> a -> Boolean
257−
258− instance eqUnit :: Eq Unit where
259− (==) (Unit {}) (Unit {}) = true
260− (/=) (Unit {}) (Unit {}) = false
261−
262− instance eqString :: Eq String where
263− (==) = refEq
264− (/=) = refIneq
265−
266− instance eqNumber :: Eq Number where
267− (==) = refEq
268− (/=) = refIneq
269−
270− instance eqBoolean :: Eq Boolean where
271− (==) = refEq
272− (/=) = refIneq
273−
274− foreign import eqArrayImpl
275− "function eqArrayImpl(f) {\
276− \ return function(xs) {\
277− \ return function(ys) {\
278− \ if (xs.length !== ys.length) return false;\
279− \ for (var i = 0; i < xs.length; i++) {\
280− \ if (!f(xs[i])(ys[i])) return false;\
281− \ }\
282− \ return true;\
283− \ };\
284− \ };\
285− \}" :: forall a. (a -> a -> Boolean) -> [a] -> [a] -> Boolean
286−
287− instance eqArray :: (Eq a) => Eq [a] where
288− (==) xs ys = eqArrayImpl (==) xs ys
289− (/=) xs ys = not (xs == ys)
290−
291− data Ordering = LT | GT | EQ
292−
293− instance eqOrdering :: Eq Ordering where
294− (==) LT LT = true
295− (==) GT GT = true
296− (==) EQ EQ = true
297− (==) _ _ = false
298− (/=) x y = not (x == y)
299−
300− instance showOrdering :: Show Ordering where
301− show LT = "LT"
302− show GT = "GT"
303− show EQ = "EQ"
304−
305− class (Eq a) <= Ord a where
306− compare :: a -> a -> Ordering
307−
308− infixl 4 <
309−
310− (<) :: forall a. (Ord a) => a -> a -> Boolean
311− (<) a1 a2 = case a1 `compare` a2 of
312− LT -> true
313− _ -> false
314−
315− infixl 4 >
316−
317− (>) :: forall a. (Ord a) => a -> a -> Boolean
318− (>) a1 a2 = case a1 `compare` a2 of
319− GT -> true
320− _ -> false
321−
322− infixl 4 <=
323−
324− (<=) :: forall a. (Ord a) => a -> a -> Boolean
325− (<=) a1 a2 = case a1 `compare` a2 of
326− GT -> false
327− _ -> true
328−
329− infixl 4 >=
330−
331− (>=) :: forall a. (Ord a) => a -> a -> Boolean
332− (>=) a1 a2 = case a1 `compare` a2 of
333− LT -> false
334− _ -> true
335−
336− foreign import unsafeCompareImpl
337− "function unsafeCompareImpl(lt) {\
338− \ return function(eq) {\
339− \ return function(gt) {\
340− \ return function(x) {\
341− \ return function(y) {\
342− \ return x < y ? lt : x > y ? gt : eq;\
343− \ };\
344− \ };\
345− \ };\
346− \ };\
347− \}" :: forall a. Ordering -> Ordering -> Ordering -> a -> a -> Ordering
348−
349− unsafeCompare :: forall a. a -> a -> Ordering
350− unsafeCompare = unsafeCompareImpl LT EQ GT
351−
352− instance ordUnit :: Ord Unit where
353− compare (Unit {}) (Unit {}) = EQ
354−
355− instance ordBoolean :: Ord Boolean where
356− compare false false = EQ
357− compare false true = LT
358− compare true true = EQ
359− compare true false = GT
360−
361− instance ordNumber :: Ord Number where
362− compare = unsafeCompare
363−
364− instance ordString :: Ord String where
365− compare = unsafeCompare
366−
367− instance ordArray :: (Ord a) => Ord [a] where
368− compare [] [] = EQ
369− compare [] _ = LT
370− compare _ [] = GT
371− compare (x:xs) (y:ys) = case compare x y of
372− EQ -> compare xs ys
373− other -> other
374−
375− infixl 10 .&.
376− infixl 10 .|.
377− infixl 10 .^.
378−
379− class Bits b where
380− (.&.) :: b -> b -> b
381− (.|.) :: b -> b -> b
382− (.^.) :: b -> b -> b
383− shl :: b -> Number -> b
384− shr :: b -> Number -> b
385− zshr :: b -> Number -> b
386− complement :: b -> b
387−
388− foreign import numShl "function numShl(n1) {\
389− \ return function(n2) {\
390− \ return n1 << n2;\
391− \ };\
392− \}" :: Number -> Number -> Number
393−
394− foreign import numShr "function numShr(n1) {\
395− \ return function(n2) {\
396− \ return n1 >> n2;\
397− \ };\
398− \}" :: Number -> Number -> Number
399−
400− foreign import numZshr "function numZshr(n1) {\
401− \ return function(n2) {\
402− \ return n1 >>> n2;\
403− \ };\
404− \}" :: Number -> Number -> Number
405−
406− foreign import numAnd "function numAnd(n1) {\
407− \ return function(n2) {\
408− \ return n1 & n2;\
409− \ };\
410− \}" :: Number -> Number -> Number
411−
412− foreign import numOr "function numOr(n1) {\
413− \ return function(n2) {\
414− \ return n1 | n2;\
415− \ };\
416− \}" :: Number -> Number -> Number
417−
418− foreign import numXor "function numXor(n1) {\
419− \ return function(n2) {\
420− \ return n1 ^ n2;\
421− \ };\
422− \}" :: Number -> Number -> Number
423−
424− foreign import numComplement "function numComplement(n) {\
425− \ return ~n;\
426− \}" :: Number -> Number
427−
428− instance bitsNumber :: Bits Number where
429− (.&.) = numAnd
430− (.|.) = numOr
431− (.^.) = numXor
432− shl = numShl
433− shr = numShr
434− zshr = numZshr
435− complement = numComplement
436−
437− infixr 2 ||
438− infixr 3 &&
439−
440− class BoolLike b where
441− (&&) :: b -> b -> b
442− (||) :: b -> b -> b
443− not :: b -> b
444−
445− foreign import boolAnd "function boolAnd(b1) {\
446− \ return function(b2) {\
447− \ return b1 && b2;\
448− \ };\
449− \}" :: Boolean -> Boolean -> Boolean
450−
451− foreign import boolOr "function boolOr(b1) {\
452− \ return function(b2) {\
453− \ return b1 || b2;\
454− \ };\
455− \}" :: Boolean -> Boolean -> Boolean
456−
457− foreign import boolNot "function boolNot(b) {\
458− \ return !b;\
459− \}" :: Boolean -> Boolean
460−
461− instance boolLikeBoolean :: BoolLike Boolean where
462− (&&) = boolAnd
463− (||) = boolOr
464− not = boolNot
465−
466− infixr 5 <>
467−
468− class Semigroup a where
469− (<>) :: a -> a -> a
470−
471− foreign import concatString
472− "function concatString(s1) {\
473− \ return function(s2) {\
474− \ return s1 + s2;\
475− \ };\
476− \}" :: String -> String -> String
477−
478− instance semigroupUnit :: Semigroup Unit where
479− (<>) (Unit {}) (Unit {}) = Unit {}
480−
481− instance semigroupString :: Semigroup String where
482− (<>) = concatString
483−
484− instance semigroupArr :: (Semigroup s') => Semigroup (s -> s') where
485− (<>) f g = \x -> f x <> g x
486−
487− infixr 5 ++
488−
489− (++) :: forall s. (Semigroup s) => s -> s -> s
490− (++) = (<>)
491−
492−module Data.Function where
493−
494− on :: forall a b c. (b -> b -> c) -> (a -> b) -> a -> a -> c
495− on f g x y = g x `f` g y
496−
497− foreign import data Fn0 :: * -> *
498− foreign import data Fn1 :: * -> * -> *
499− foreign import data Fn2 :: * -> * -> * -> *
500− foreign import data Fn3 :: * -> * -> * -> * -> *
501− foreign import data Fn4 :: * -> * -> * -> * -> * -> *
502− foreign import data Fn5 :: * -> * -> * -> * -> * -> * -> *
503− foreign import data Fn6 :: * -> * -> * -> * -> * -> * -> * -> *
504− foreign import data Fn7 :: * -> * -> * -> * -> * -> * -> * -> * -> *
505− foreign import data Fn8 :: * -> * -> * -> * -> * -> * -> * -> * -> * -> *
506− foreign import data Fn9 :: * -> * -> * -> * -> * -> * -> * -> * -> * -> * -> *
507− foreign import data Fn10 :: * -> * -> * -> * -> * -> * -> * -> * -> * -> * -> * -> *
508−
509− foreign import mkFn0
510− "function mkFn0(fn) {\
511− \ return function() {\
512− \ return fn({});\
513− \ };\
514− \}" :: forall a. (Unit -> a) -> Fn0 a
515−
516− foreign import mkFn1
517− "function mkFn1(fn) {\
518− \ return function(a) {\
519− \ return fn(a);\
520− \ };\
521− \}" :: forall a b. (a -> b) -> Fn1 a b
522−
523− foreign import mkFn2
524− "function mkFn2(fn) {\
525− \ return function(a, b) {\
526− \ return fn(a)(b);\
527− \ };\
528− \}" :: forall a b c. (a -> b -> c) -> Fn2 a b c
529−
530− foreign import mkFn3
531− "function mkFn3(fn) {\
532− \ return function(a, b, c) {\
533− \ return fn(a)(b)(c);\
534− \ };\
535− \}" :: forall a b c d. (a -> b -> c -> d) -> Fn3 a b c d
536−
537− foreign import mkFn4
538− "function mkFn4(fn) {\
539− \ return function(a, b, c, d) {\
540− \ return fn(a)(b)(c)(d);\
541− \ };\
542− \}" :: forall a b c d e. (a -> b -> c -> d -> e) -> Fn4 a b c d e
543−
544− foreign import mkFn5
545− "function mkFn5(fn) {\
546− \ return function(a, b, c, d, e) {\
547− \ return fn(a)(b)(c)(d)(e);\
548− \ };\
549− \}" :: forall a b c d e f. (a -> b -> c -> d -> e -> f) -> Fn5 a b c d e f
550−
551− foreign import mkFn6
552− "function mkFn6(fn) {\
553− \ return function(a, b, c, d, e, f) {\
554− \ return fn(a)(b)(c)(d)(e)(f);\
555− \ };\
556− \}" :: forall a b c d e f g. (a -> b -> c -> d -> e -> f -> g) -> Fn6 a b c d e f g
557−
558− foreign import mkFn7
559− "function mkFn7(fn) {\
560− \ return function(a, b, c, d, e, f, g) {\
561− \ return fn(a)(b)(c)(d)(e)(f)(g);\
562− \ };\
563− \}" :: 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
564−
565− foreign import mkFn8
566− "function mkFn8(fn) {\
567− \ return function(a, b, c, d, e, f, g, h) {\
568− \ return fn(a)(b)(c)(d)(e)(f)(g)(h);\
569− \ };\
570− \}" :: 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
571−
572− foreign import mkFn9
573− "function mkFn9(fn) {\
574− \ return function(a, b, c, d, e, f, g, h, i) {\
575− \ return fn(a)(b)(c)(d)(e)(f)(g)(h)(i);\
576− \ };\
577− \}" :: 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
578−
579− foreign import mkFn10
580− "function mkFn10(fn) {\
581− \ return function(a, b, c, d, e, f, g, h, i, j) {\
582− \ return fn(a)(b)(c)(d)(e)(f)(g)(h)(i)(j);\
583− \ };\
584− \}" :: 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
585−
586− foreign import runFn0
587− "function runFn0(fn) {\
588− \ return fn();\
589− \}" :: forall a. Fn0 a -> a
590−
591− foreign import runFn1
592− "function runFn1(fn) {\
593− \ return function(a) {\
594− \ return fn(a);\
595− \ };\
596− \}" :: forall a b. Fn1 a b -> a -> b
597−
598− foreign import runFn2
599− "function runFn2(fn) {\
600− \ return function(a) {\
601− \ return function(b) {\
602− \ return fn(a, b);\
603− \ };\
604− \ };\
605− \}" :: forall a b c. Fn2 a b c -> a -> b -> c
606−
607− foreign import runFn3
608− "function runFn3(fn) {\
609− \ return function(a) {\
610− \ return function(b) {\
611− \ return function(c) {\
612− \ return fn(a, b, c);\
613− \ };\
614− \ };\
615− \ };\
616− \}" :: forall a b c d. Fn3 a b c d -> a -> b -> c -> d
617−
618− foreign import runFn4
619− "function runFn4(fn) {\
620− \ return function(a) {\
621− \ return function(b) {\
622− \ return function(c) {\
623− \ return function(d) {\
624− \ return fn(a, b, c, d);\
625− \ };\
626− \ };\
627− \ };\
628− \ };\
629− \}" :: forall a b c d e. Fn4 a b c d e -> a -> b -> c -> d -> e
630−
631− foreign import runFn5
632− "function runFn5(fn) {\
633− \ return function(a) {\
634− \ return function(b) {\
635− \ return function(c) {\
636− \ return function(d) {\
637− \ return function(e) {\
638− \ return fn(a, b, c, d, e);\
639− \ };\
640− \ };\
641− \ };\
642− \ };\
643− \ };\
644− \}" :: forall a b c d e f. Fn5 a b c d e f -> a -> b -> c -> d -> e -> f
645−
646− foreign import runFn6
647− "function runFn6(fn) {\
648− \ return function(a) {\
649− \ return function(b) {\
650− \ return function(c) {\
651− \ return function(d) {\
652− \ return function(e) {\
653− \ return function(f) {\
654− \ return fn(a, b, c, d, e, f);\
655− \ };\
656− \ };\
657− \ };\
658− \ };\
659− \ };\
660− \ };\
661− \}" :: forall a b c d e f g. Fn6 a b c d e f g -> a -> b -> c -> d -> e -> f -> g
662−
663− foreign import runFn7
664− "function runFn7(fn) {\
665− \ return function(a) {\
666− \ return function(b) {\
667− \ return function(c) {\
668− \ return function(d) {\
669− \ return function(e) {\
670− \ return function(f) {\
671− \ return function(g) {\
672− \ return fn(a, b, c, d, e, f, g);\
673− \ };\
674− \ };\
675− \ };\
676− \ };\
677− \ };\
678− \ };\
679− \ };\
680− \}" :: 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
681−
682− foreign import runFn8
683− "function runFn8(fn) {\
684− \ return function(a) {\
685− \ return function(b) {\
686− \ return function(c) {\
687− \ return function(d) {\
688− \ return function(e) {\
689− \ return function(f) {\
690− \ return function(g) {\
691− \ return function(h) {\
692− \ return fn(a, b, c, d, e, f, g, h);\
693− \ };\
694− \ };\
695− \ };\
696− \ };\
697− \ };\
698− \ };\
699− \ };\
700− \ };\
701− \}" :: 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
702−
703− foreign import runFn9
704− "function runFn9(fn) {\
705− \ return function(a) {\
706− \ return function(b) {\
707− \ return function(c) {\
708− \ return function(d) {\
709− \ return function(e) {\
710− \ return function(f) {\
711− \ return function(g) {\
712− \ return function(h) {\
713− \ return function(i) {\
714− \ return fn(a, b, c, d, e, f, g, h, i);\
715− \ };\
716− \ };\
717− \ };\
718− \ };\
719− \ };\
720− \ };\
721− \ };\
722− \ };\
723− \ };\
724− \}" :: 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
725−
726− foreign import runFn10
727− "function runFn10(fn) {\
728− \ return function(a) {\
729− \ return function(b) {\
730− \ return function(c) {\
731− \ return function(d) {\
732− \ return function(e) {\
733− \ return function(f) {\
734− \ return function(g) {\
735− \ return function(h) {\
736− \ return function(i) {\
737− \ return function(j) {\
738− \ return fn(a, b, c, d, e, f, g, h, i, j);\
739− \ };\
740− \ };\
741− \ };\
742− \ };\
743− \ };\
744− \ };\
745− \ };\
746− \ };\
747− \ };\
748− \ };\
749− \}" :: 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
750−
751−module Data.Eq where
752−
753− newtype Ref a = Ref a
754−
755− liftRef :: forall a b. (a -> a -> b) -> Ref a -> Ref a -> b
756− liftRef f (Ref x) (Ref y) = f x y
757−
758− instance eqRef :: Eq (Ref a) where
759− (==) = liftRef refEq
760− (/=) = liftRef refIneq
761−
762− instance functorRef :: Functor Ref where
763− (<$>) f (Ref x) = Ref (f x)
764−
765−module Prelude.Unsafe where
766−
767− foreign import unsafeIndex
768− "function unsafeIndex(xs) {\
769− \ return function(n) {\
770− \ return xs[n];\
771− \ };\
772− \}" :: forall a. [a] -> Number -> a
773−
774−module Control.Monad.Eff where
775−
776− foreign import data Eff :: # ! -> * -> *
777−
778− foreign import returnE "function returnE(a) {\
779− \ return function() {\
780− \ return a;\
781− \ };\
782− \}" :: forall e a. a -> Eff e a
783−
784− foreign import bindE "function bindE(a) {\
785− \ return function(f) {\
786− \ return function() {\
787− \ return f(a())();\
788− \ };\
789− \ };\
790− \}" :: forall e a b. Eff e a -> (a -> Eff e b) -> Eff e b
791−
792− type Pure a = forall e. Eff e a
793−
794− foreign import runPure "function runPure(f) {\
795− \ return f();\
796− \}" :: forall a. Pure a -> a
797−
798− instance functorEff :: Functor (Eff e) where
799− (<$>) = liftA1
800−
801− instance applyEff :: Apply (Eff e) where
802− (<*>) = ap
803−
804− instance applicativeEff :: Applicative (Eff e) where
805− pure = returnE
806−
807− instance bindEff :: Bind (Eff e) where
808− (>>=) = bindE
809−
810− instance monadEff :: Monad (Eff e)
811−
812− foreign import untilE "function untilE(f) {\
813− \ return function() {\
814− \ while (!f());\
815− \ return {};\
816− \ };\
817− \}" :: forall e. Eff e Boolean -> Eff e Unit
818−
819− foreign import whileE "function whileE(f) {\
820− \ return function(a) {\
821− \ return function() {\
822− \ while (f()) {\
823− \ a();\
824− \ }\
825− \ return {};\
826− \ };\
827− \ };\
828− \}" :: forall e a. Eff e Boolean -> Eff e a -> Eff e Unit
829−
830− foreign import forE "function forE(lo) {\
831− \ return function(hi) {\
832− \ return function(f) {\
833− \ return function() {\
834− \ for (var i = lo; i < hi; i++) {\
835− \ f(i)();\
836− \ }\
837− \ };\
838− \ };\
839− \ };\
840− \}" :: forall e. Number -> Number -> (Number -> Eff e Unit) -> Eff e Unit
841−
842−
843− foreign import foreachE "function foreachE(as) {\
844− \ return function(f) {\
845− \ return function() {\
846− \ for (var i = 0; i < as.length; i++) {\
847− \ f(as[i])();\
848− \ }\
849− \ };\
850− \ };\
851− \}" :: forall e a. [a] -> (a -> Eff e Unit) -> Eff e Unit
852−
853−module Control.Monad.Eff.Unsafe where
854−
855− import Control.Monad.Eff
856−
857− foreign import unsafeInterleaveEff
858− "function unsafeInterleaveEff(f) {\
859− \ return f;\
860− \}" :: forall eff1 eff2 a. Eff eff1 a -> Eff eff2 a
861−
862−module Debug.Trace where
863−
864− import Control.Monad.Eff
865−
866− foreign import data Trace :: !
867−
868− foreign import trace "function trace(s) {\
869− \ return function() {\
870− \ console.log(s);\
871− \ return {};\
872− \ };\
873− \}" :: forall r. String -> Eff (trace :: Trace | r) Unit
874−
875− print :: forall a r. (Show a) => a -> Eff (trace :: Trace | r) Unit
876− print o = trace (show o)
877−
878−module Control.Monad.ST where
879−
880− import Control.Monad.Eff
881−
882− foreign import data ST :: * -> !
883−
884− foreign import data STRef :: * -> * -> *
885−
886− foreign import newSTRef "function newSTRef(val) {\
887− \ return function() {\
888− \ return { value: val };\
889− \ };\
890− \}" :: forall a h r. a -> Eff (st :: ST h | r) (STRef h a)
891−
892− foreign import readSTRef "function readSTRef(ref) {\
893− \ return function() {\
894− \ return ref.value;\
895− \ };\
896− \}" :: forall a h r. STRef h a -> Eff (st :: ST h | r) a
897−
898− foreign import modifySTRef "function modifySTRef(ref) {\
899− \ return function(f) {\
900− \ return function() {\
901− \ return ref.value = f(ref.value);\
902− \ };\
903− \ };\
904− \}" :: forall a h r. STRef h a -> (a -> a) -> Eff (st :: ST h | r) a
905−
906− foreign import writeSTRef "function writeSTRef(ref) {\
907− \ return function(a) {\
908− \ return function() {\
909− \ return ref.value = a;\
910− \ };\
911− \ };\
912− \}" :: forall a h r. STRef h a -> a -> Eff (st :: ST h | r) a
913−
914− foreign import runST "function runST(f) {\
915− \ return f;\
916− \}" :: forall a r. (forall h. Eff (st :: ST h | r) a) -> Eff r a
917−
918− pureST :: forall a. (forall h r. Eff (st :: ST h | r) a) -> a
919− 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/hierarchy/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−228
@@ -1,228 +0,0 @@
1−----------------------------------------------------------------------------
2−--
3−-- Module : Main
4−-- Copyright : (c) Phil Freeman 2013
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- |
12−--
13−-----------------------------------------------------------------------------
14−
15−module Main where
16−
17−import Control.Applicative
18−import Control.Monad
19−import Control.Monad.Writer
20−import Control.Arrow (first)
21−import Data.Function (on)
22−import Data.List
23−import Data.Maybe (fromMaybe)
24−import Data.Version (showVersion)
25−
26−import Options.Applicative
27−
28−import qualified Language.PureScript as P
29−import qualified Paths_purescript as Paths
30−import qualified System.IO.UTF8 as U
31−import System.Exit (exitSuccess, exitFailure)
32−import System.IO (stderr)
33−
34−
35−data PSCDocsOptions = PSCDocsOptions
36− { pscdIncludeHeir :: Bool
37− , pscdInputFiles :: [FilePath]
38− }
39−
40−
41−docgen :: PSCDocsOptions -> IO ()
42−docgen (PSCDocsOptions showHierarchy input) = do
43− e <- P.parseModulesFromFiles (fromMaybe "") <$> mapM (fmap (first Just) . parseFile) (nub input)
44− case e of
45− Left err -> do
46− U.hPutStr stderr $ show err
47− exitFailure
48− Right ms -> do
49− U.putStrLn . runDocs $ (renderModules showHierarchy) (map snd ms)
50− exitSuccess
51−
52−parseFile :: FilePath -> IO (FilePath, String)
53−parseFile input = (,) input <$> U.readFile input
54−
55−type Docs = Writer [String] ()
56−
57−runDocs :: Docs -> String
58−runDocs = unlines . execWriter
59−
60−spacer :: Docs
61−spacer = tell [""]
62−
63−headerLevel :: Int -> String -> Docs
64−headerLevel level hdr = tell [replicate level '#' ++ ' ' : hdr]
65−
66−atIndent :: Int -> String -> Docs
67−atIndent indent text =
68− let ls = lines text in
69− forM_ ls $ \l -> tell [replicate indent ' ' ++ l]
70−
71−renderModules :: Bool -> [P.Module] -> Docs
72−renderModules showHierarchy ms = do
73− headerLevel 1 "Module Documentation"
74− spacer
75− mapM_ (renderModule showHierarchy) ms
76−
77−renderModule :: Bool -> P.Module -> Docs
78−renderModule showHierarchy mdl@(P.Module moduleName _ exps) =
79− let ds = P.exportedDeclarations mdl
80− hasTypes = any isTypeDeclaration ds
81− hasTypeclasses = any isTypeClassDeclaration ds
82− hasTypeclassInstances = any isTypeInstanceDeclaration ds
83− hasValues = any isValueDeclaration ds
84− in do
85− headerLevel 2 $ "Module " ++ P.runModuleName moduleName
86− spacer
87− when hasTypes $ do
88− headerLevel 3 "Types"
89− spacer
90− renderTopLevel exps (filter isTypeDeclaration ds)
91− spacer
92− when hasTypeclasses $ do
93− headerLevel 3 "Type Classes"
94− spacer
95− when showHierarchy $ do
96− renderTypeclassImage moduleName
97− spacer
98− renderTopLevel exps (filter isTypeClassDeclaration ds)
99− spacer
100− when hasTypeclassInstances $ do
101− headerLevel 3 "Type Class Instances"
102− spacer
103− renderTopLevel exps (filter isTypeInstanceDeclaration ds)
104− spacer
105− when hasValues $ do
106− headerLevel 3 "Values"
107− spacer
108− renderTopLevel exps (filter isValueDeclaration ds)
109− spacer
110−
111−renderTopLevel :: Maybe [P.DeclarationRef] -> [P.Declaration] -> Docs
112−renderTopLevel exps decls = forM_ (sortBy (compare `on` getName) decls) $ \decl -> do
113− renderDeclaration 4 exps decl
114− spacer
115−
116−renderTypeclassImage :: P.ModuleName -> Docs
117−renderTypeclassImage name =
118− let name' = P.runModuleName name
119− in tell ["![" ++ name' ++ "](images/" ++ name' ++ ".png)"]
120−
121−renderDeclaration :: Int -> Maybe [P.DeclarationRef] -> P.Declaration -> Docs
122−renderDeclaration n _ (P.TypeDeclaration ident ty) =
123− atIndent n $ show ident ++ " :: " ++ prettyPrintType' ty
124−renderDeclaration n _ (P.ExternDeclaration _ ident _ ty) =
125− atIndent n $ show ident ++ " :: " ++ prettyPrintType' ty
126−renderDeclaration n 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− atIndent n $ show dtype ++ " " ++ typeName ++ (if null exported then "" else " where")
132− forM_ exported $ \(ctor, tys) ->
133− let ctorTy = foldr P.function typeApp tys
134− in atIndent (n + 2) $ P.runProperName ctor ++ " :: " ++ prettyPrintType' ctorTy
135−renderDeclaration n _ (P.ExternDataDeclaration name kind) =
136− atIndent n $ "data " ++ P.runProperName name ++ " :: " ++ P.prettyPrintKind kind
137−renderDeclaration n _ (P.TypeSynonymDeclaration name args ty) = do
138− let
139− typeApp = foldl P.TypeApp (P.TypeConstructor (P.Qualified Nothing name)) (map toTypeVar args)
140− typeName = prettyPrintType' typeApp
141− atIndent n $ "type " ++ typeName ++ " = " ++ prettyPrintType' ty
142−renderDeclaration n exps (P.TypeClassDeclaration name args implies ds) = do
143− let impliesText = case implies of
144− [] -> ""
145− is -> "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map P.prettyPrintTypeAtom tys')) is) ++ ") <= "
146− classApp = foldl P.TypeApp (P.TypeConstructor (P.Qualified Nothing name)) (map toTypeVar args)
147− className = prettyPrintType' classApp
148− atIndent n $ "class " ++ impliesText ++ className ++ " where"
149− mapM_ (renderDeclaration (n + 2) exps) ds
150−renderDeclaration n _ (P.TypeInstanceDeclaration name constraints className tys _) = do
151− let constraintsText = case constraints of
152− [] -> ""
153− cs -> "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map P.prettyPrintTypeAtom tys')) cs) ++ ") => "
154− atIndent n $ "instance " ++ show name ++ " :: " ++ constraintsText ++ show className ++ " " ++ unwords (map P.prettyPrintTypeAtom tys)
155−renderDeclaration n exps (P.PositionedDeclaration _ d) =
156− renderDeclaration n exps d
157−renderDeclaration _ _ _ = return ()
158−
159−toTypeVar :: (String, Maybe P.Kind) -> P.Type
160−toTypeVar (s, Nothing) = P.TypeVar s
161−toTypeVar (s, Just k) = P.KindedType (P.TypeVar s) k
162−
163−prettyPrintType' :: P.Type -> String
164−prettyPrintType' = P.prettyPrintType . P.everywhereOnTypes dePrim
165− where
166− dePrim ty@(P.TypeConstructor (P.Qualified _ name))
167− | ty == P.tyBoolean || ty == P.tyNumber || ty == P.tyString =
168− P.TypeConstructor $ P.Qualified Nothing name
169− dePrim other = other
170−
171−getName :: P.Declaration -> String
172−getName (P.TypeDeclaration ident _) = show ident
173−getName (P.ExternDeclaration _ ident _ _) = show ident
174−getName (P.DataDeclaration _ name _ _) = P.runProperName name
175−getName (P.ExternDataDeclaration name _) = P.runProperName name
176−getName (P.TypeSynonymDeclaration name _ _) = P.runProperName name
177−getName (P.TypeClassDeclaration name _ _ _) = P.runProperName name
178−getName (P.TypeInstanceDeclaration name _ _ _ _) = show name
179−getName (P.PositionedDeclaration _ d) = getName d
180−getName _ = error "Invalid argument to getName"
181−
182−isValueDeclaration :: P.Declaration -> Bool
183−isValueDeclaration P.TypeDeclaration{} = True
184−isValueDeclaration P.ExternDeclaration{} = True
185−isValueDeclaration (P.PositionedDeclaration _ d) = isValueDeclaration d
186−isValueDeclaration _ = False
187−
188−isTypeDeclaration :: P.Declaration -> Bool
189−isTypeDeclaration P.DataDeclaration{} = True
190−isTypeDeclaration P.ExternDataDeclaration{} = True
191−isTypeDeclaration P.TypeSynonymDeclaration{} = True
192−isTypeDeclaration (P.PositionedDeclaration _ d) = isTypeDeclaration d
193−isTypeDeclaration _ = False
194−
195−isTypeClassDeclaration :: P.Declaration -> Bool
196−isTypeClassDeclaration P.TypeClassDeclaration{} = True
197−isTypeClassDeclaration (P.PositionedDeclaration _ d) = isTypeClassDeclaration d
198−isTypeClassDeclaration _ = False
199−
200−isTypeInstanceDeclaration :: P.Declaration -> Bool
201−isTypeInstanceDeclaration P.TypeInstanceDeclaration{} = True
202−isTypeInstanceDeclaration (P.PositionedDeclaration _ d) = isTypeInstanceDeclaration d
203−isTypeInstanceDeclaration _ = False
204−
205−inputFile :: Parser FilePath
206−inputFile = strArgument $
207− metavar "FILE"
208− <> help "The input .ps file(s)"
209−
210−includeHeirarcy :: Parser Bool
211−includeHeirarcy = switch $
212− long "hierarchy-images"
213− <> help "Include markdown for type class hierarchy images in the output."
214−
215−pscDocsOptions :: Parser PSCDocsOptions
216−pscDocsOptions = PSCDocsOptions <$> includeHeirarcy
217− <*> many inputFile
218−
219−main :: IO ()
220−main = execParser opts >>= docgen
221− where
222− opts = info (version <*> helper <*> pscDocsOptions) infoModList
223− infoModList = fullDesc <> headerInfo <> footerInfo
224− headerInfo = header "psc-docs - Generate Markdown documentation from PureScript extern files"
225− footerInfo = footer $ "psc-docs " ++ showVersion Paths.version
226−
227− version :: Parser (a -> a)
228− version = abortOption (InfoMsg (showVersion Paths.version)) $ long "version" <> help "Show the version number" <> hidden
psc-make/Main.hsdeleted−171
@@ -1,171 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Main
4−-- Copyright : (c) Phil Freeman 2013
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- |
12−--
13−-----------------------------------------------------------------------------
14−
15−{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, TupleSections, RecordWildCards #-}
16−
17−module Main where
18−
19−import Control.Applicative
20−import Control.Monad.Error
21−
22−import Data.Version (showVersion)
23−
24−import Options.Applicative as Opts
25−
26−import System.Directory
27− (doesFileExist, getModificationTime, createDirectoryIfMissing)
28−import System.FilePath (takeDirectory)
29−import System.Exit (exitSuccess, exitFailure)
30−import System.IO.Error (tryIOError)
31−
32−import qualified Language.PureScript as P
33−import qualified Paths_purescript as Paths
34−import qualified System.IO.UTF8 as U
35−
36−
37−data PSCMakeOptions = PSCMakeOptions
38− { pscmInput :: [FilePath]
39− , pscmOutputDir :: FilePath
40− , pscmOpts :: P.Options P.Make
41− , pscmUsePrefix :: Bool
42− }
43−
44−data InputOptions = InputOptions
45− { ioNoPrelude :: Bool
46− , ioInputFiles :: [FilePath]
47− }
48−
49−readInput :: InputOptions -> IO [(Either P.RebuildPolicy FilePath, String)]
50−readInput InputOptions{..} = do
51− content <- forM ioInputFiles $ \inFile -> (Right inFile, ) <$> U.readFile inFile
52− return (if ioNoPrelude then content else (Left P.RebuildNever, P.prelude) : content)
53−
54−newtype Make a = Make { unMake :: ErrorT String IO a } deriving (Functor, Applicative, Monad, MonadIO, MonadError String)
55−
56−runMake :: Make a -> IO (Either String a)
57−runMake = runErrorT . unMake
58−
59−makeIO :: IO a -> Make a
60−makeIO = Make . ErrorT . fmap (either (Left . show) Right) . tryIOError
61−
62−instance P.MonadMake Make where
63− getTimestamp path = makeIO $ do
64− exists <- doesFileExist path
65− case exists of
66− True -> Just <$> getModificationTime path
67− False -> return Nothing
68− readTextFile path = makeIO $ do
69− U.putStrLn $ "Reading " ++ path
70− U.readFile path
71− writeTextFile path text = makeIO $ do
72− mkdirp path
73− U.putStrLn $ "Writing " ++ path
74− U.writeFile path text
75− liftError = either throwError return
76− progress = makeIO . U.putStrLn
77−
78−compile :: PSCMakeOptions -> IO ()
79−compile (PSCMakeOptions input outputDir opts usePrefix) = do
80− modules <- P.parseModulesFromFiles (either (const "") id) <$> readInput (InputOptions (P.optionsNoPrelude opts) input)
81− case modules of
82− Left err -> do
83− U.print err
84− exitFailure
85− Right ms -> do
86− e <- runMake $ P.make outputDir opts ms prefix
87− case e of
88− Left err -> do
89− U.putStrLn err
90− exitFailure
91− Right _ -> do
92− exitSuccess
93− where
94− prefix = if usePrefix
95− then ["Generated by psc-make version " ++ showVersion Paths.version]
96− else []
97−
98−mkdirp :: FilePath -> IO ()
99−mkdirp = createDirectoryIfMissing True . takeDirectory
100−
101−inputFile :: Parser FilePath
102−inputFile = strArgument $
103− metavar "FILE"
104− <> help "The input .ps file(s)"
105−
106−outputDirectory :: Parser FilePath
107−outputDirectory = strOption $
108− short 'o'
109− <> long "output"
110− <> Opts.value "output"
111− <> showDefault
112− <> help "The output directory"
113−
114−noTco :: Parser Bool
115−noTco = switch $
116− long "no-tco"
117− <> help "Disable tail call optimizations"
118−
119−noPrelude :: Parser Bool
120−noPrelude = switch $
121− long "no-prelude"
122− <> help "Omit the Prelude"
123−
124−noMagicDo :: Parser Bool
125−noMagicDo = switch $
126− long "no-magic-do"
127− <> help "Disable the optimization that overloads the do keyword to generate efficient code specifically for the Eff monad."
128−
129−noOpts :: Parser Bool
130−noOpts = switch $
131− long "verbose-errors"
132− <> help "Skip the optimization phase."
133−
134−verboseErrors :: Parser Bool
135−verboseErrors = switch $
136− short 'v'
137− <> long "no-opts"
138− <> help "Display verbose error messages"
139−
140−noPrefix :: Parser Bool
141−noPrefix = switch $
142− short 'p'
143− <> long "no-prefix"
144− <> help "Do not include comment header"
145−
146−
147−options :: Parser (P.Options P.Make)
148−options = P.Options <$> noPrelude
149− <*> noTco
150− <*> noMagicDo
151− <*> pure Nothing
152− <*> noOpts
153− <*> verboseErrors
154− <*> pure P.MakeOptions
155−
156−pscMakeOptions :: Parser PSCMakeOptions
157−pscMakeOptions = PSCMakeOptions <$> many inputFile
158− <*> outputDirectory
159− <*> options
160− <*> (not <$> noPrefix)
161−
162−main :: IO ()
163−main = execParser opts >>= compile
164− where
165− opts = info (version <*> helper <*> pscMakeOptions) infoModList
166− infoModList = fullDesc <> headerInfo <> footerInfo
167− headerInfo = header "psc-make - Compiles PureScript to Javascript"
168− footerInfo = footer $ "psc-make " ++ showVersion Paths.version
169−
170− version :: Parser (a -> a)
171− version = abortOption (InfoMsg (showVersion Paths.version)) $ long "version" <> help "Show the version number" <> hidden
psc/Main.hsdeleted−202
@@ -1,202 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Main
4−-- Copyright : (c) Phil Freeman 2013
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- |
12−--
13−-----------------------------------------------------------------------------
14−
15−{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, TupleSections, RecordWildCards #-}
16−
17−module Main where
18−
19−import Control.Applicative
20−import Control.Monad.Error
21−
22−import Data.Maybe (fromMaybe)
23−import Data.Version (showVersion)
24−
25−import Options.Applicative as Opts
26−import System.Directory (createDirectoryIfMissing)
27−import System.FilePath (takeDirectory)
28−import System.Exit (exitSuccess, exitFailure)
29−import System.IO (stderr)
30−
31−import qualified Language.PureScript as P
32−import qualified Paths_purescript as Paths
33−import qualified System.IO.UTF8 as U
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, ) <$> U.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− U.hPutStr stderr $ show err
63− exitFailure
64− Right ms -> do
65− case P.compile opts (map snd ms) prefix of
66− Left err -> do
67− U.hPutStrLn stderr err
68− exitFailure
69− Right (js, exts, _) -> do
70− case output of
71− Just path -> mkdirp path >> U.writeFile path js
72− Nothing -> U.putStrLn js
73− case externs of
74− Just path -> mkdirp path >> U.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−useStdIn :: Parser Bool
142−useStdIn = switch $
143− short 's'
144− <> long "stdin"
145− <> help "Read from standard input"
146−
147−inputFile :: Parser FilePath
148−inputFile = strArgument $
149− metavar "FILE"
150− <> help "The input .ps file(s)"
151−
152−outputFile :: Parser (Maybe FilePath)
153−outputFile = optional . strOption $
154− short 'o'
155− <> long "output"
156− <> help "The output .js file"
157−
158−externsFile :: Parser (Maybe FilePath)
159−externsFile = optional . strOption $
160− short 'e'
161− <> long "externs"
162− <> help "The output .e.ps file"
163−
164−noPrefix :: Parser Bool
165−noPrefix = switch $
166− short 'p'
167− <> long "no-prefix"
168− <> help "Do not include comment header"
169−
170−options :: Parser (P.Options P.Compile)
171−options = P.Options <$> noPrelude
172− <*> noTco
173− <*> noMagicDo
174− <*> runMain
175− <*> noOpts
176− <*> verboseErrors
177− <*> additionalOptions
178− where
179− additionalOptions =
180− P.CompileOptions <$> browserNamespace
181− <*> many dceModule
182− <*> many codeGenModule
183−
184−pscOptions :: Parser PSCOptions
185−pscOptions = PSCOptions <$> many inputFile
186− <*> options
187− <*> useStdIn
188− <*> outputFile
189− <*> externsFile
190− <*> (not <$> noPrefix)
191−
192−main :: IO ()
193−main = execParser opts >>= compile
194− where
195− opts = info (version <*> helper <*> pscOptions) infoModList
196− infoModList = fullDesc <> headerInfo <> footerInfo
197− headerInfo = header "psc - Compiles PureScript to Javascript"
198− footerInfo = footer $ "psc " ++ showVersion Paths.version
199−
200− version :: Parser (a -> a)
201− version = abortOption (InfoMsg (showVersion Paths.version)) $ long "version" <> help "Show the version number" <> hidden
202−
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 (Expr -> Expr)
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−607
@@ -1,607 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Main
4−-- Copyright : (c) Phil Freeman 2013
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- |
12−-- PureScript Compiler Interactive.
13−--
14−-----------------------------------------------------------------------------
15−
16−{-# LANGUAGE DataKinds, DoAndIfThenElse, FlexibleContexts, GeneralizedNewtypeDeriving #-}
17−
18−module Main where
19−
20−import Data.Foldable (traverse_)
21−import Data.List (intercalate, isPrefixOf, nub, sortBy, sort)
22−import Data.Maybe (mapMaybe)
23−import Data.Traversable (traverse)
24−import Data.Version (showVersion)
25−import Data.Char (isSpace)
26−import qualified Data.Map as M
27−
28−import Control.Applicative
29−import Control.Monad
30−import Control.Monad.Error (ErrorT(..), MonadError)
31−import Control.Monad.Error.Class (MonadError(..))
32−import Control.Monad.Trans.Class
33−import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
34−import Control.Monad.Trans.State.Strict
35−import qualified Control.Monad.Trans.State.Lazy as L
36−
37−import Options.Applicative as Opts
38−
39−import System.Console.Haskeline
40−import System.Directory (createDirectoryIfMissing, getModificationTime, doesFileExist, findExecutable, getHomeDirectory, getCurrentDirectory)
41−import System.Exit
42−import System.FilePath (pathSeparator, takeDirectory, (</>), isPathSeparator)
43−import System.IO.Error (tryIOError)
44−import System.Process (readProcessWithExitCode)
45−import qualified System.IO.UTF8 as U (writeFile, putStrLn, print, readFile)
46−
47−import qualified Text.Parsec as Par (ParseError)
48−
49−import qualified Language.PureScript as P
50−import qualified Language.PureScript.AST as D
51−import qualified Language.PureScript.Names as N
52−import qualified Paths_purescript as Paths
53−
54−import Commands as C
55−import Parser
56−
57−
58−data PSCiOptions = PSCiOptions
59− { psciSingleLineFlag :: Bool
60− , psciInputFile :: [FilePath]
61− }
62−
63−-- |
64−-- The PSCI state.
65−-- Holds a list of imported modules, loaded files, and partial let bindings.
66−-- The let bindings are partial,
67−-- because it makes more sense to apply the binding to the final evaluated expression.
68−--
69−data PSCiState = PSCiState
70− { psciImportedFilenames :: [FilePath]
71− , psciImportedModuleNames :: [P.ModuleName]
72− , psciLoadedModules :: [(Either P.RebuildPolicy FilePath, P.Module)]
73− , psciLetBindings :: [P.Expr -> P.Expr]
74− }
75−
76−-- State helpers
77−
78−-- |
79−-- Updates the state to have more imported modules.
80−--
81−updateImportedFiles :: FilePath -> PSCiState -> PSCiState
82−updateImportedFiles filename st = st { psciImportedFilenames = filename : psciImportedFilenames st }
83−
84−-- |
85−-- Updates the state to have more imported modules.
86−--
87−updateImports :: P.ModuleName -> PSCiState -> PSCiState
88−updateImports name st = st { psciImportedModuleNames = name : psciImportedModuleNames st }
89−
90−-- |
91−-- Updates the state to have more loaded files.
92−--
93−updateModules :: [(Either P.RebuildPolicy FilePath, P.Module)] -> PSCiState -> PSCiState
94−updateModules modules st = st { psciLoadedModules = psciLoadedModules st ++ modules }
95−
96−-- |
97−-- Updates the state to have more let bindings.
98−--
99−updateLets :: (P.Expr -> P.Expr) -> PSCiState -> PSCiState
100−updateLets name st = st { psciLetBindings = name : psciLetBindings st }
101−
102−-- File helpers
103−-- |
104−-- Load the necessary modules.
105−--
106−defaultImports :: [P.ModuleName]
107−defaultImports = [P.ModuleName [P.ProperName "Prelude"]]
108−
109−-- |
110−-- Locates the node executable.
111−-- Checks for either @nodejs@ or @node@.
112−--
113−findNodeProcess :: IO (Maybe String)
114−findNodeProcess = runMaybeT . msum $ map (MaybeT . findExecutable) names
115− where names = ["nodejs", "node"]
116−
117−-- |
118−-- Grabs the filename where the history is stored.
119−--
120−getHistoryFilename :: IO FilePath
121−getHistoryFilename = do
122− home <- getHomeDirectory
123− let filename = home </> ".purescript" </> "psci_history"
124− mkdirp filename
125− return filename
126−
127−-- |
128−-- Loads a file for use with imports.
129−--
130−loadModule :: FilePath -> IO (Either String [P.Module])
131−loadModule filename = do
132− content <- U.readFile filename
133− return $ either (Left . show) (Right . map snd) $ P.parseModulesFromFiles id [(filename, content)]
134−
135−-- |
136−-- Load all modules, including the Prelude
137−--
138−loadAllModules :: [FilePath] -> IO (Either Par.ParseError [(Either P.RebuildPolicy FilePath, P.Module)])
139−loadAllModules files = do
140− filesAndContent <- forM files $ \filename -> do
141− content <- U.readFile filename
142− return (Right filename, content)
143− return $ P.parseModulesFromFiles (either (const "") id) $ (Left P.RebuildNever, P.prelude) : filesAndContent
144−
145−
146−-- |
147−-- Expands tilde in path.
148−--
149−expandTilde :: FilePath -> IO FilePath
150−expandTilde ('~':p:rest) | isPathSeparator p = (</> rest) <$> getHomeDirectory
151−expandTilde p = return p
152−-- Messages
153−
154−-- |
155−-- The help message.
156−--
157−helpMessage :: String
158−helpMessage = "The following commands are available:\n\n " ++
159− intercalate "\n " (map line C.help)
160− where line :: (String, String, String) -> String
161− line (cmd, arg, desc) = intercalate " " [cmd, arg, replicate (11 - length arg) ' ', desc]
162−
163−-- |
164−-- The welcome prologue.
165−--
166−prologueMessage :: String
167−prologueMessage = intercalate "\n"
168− [ " ____ ____ _ _ "
169− , "| _ \\ _ _ _ __ ___/ ___| ___ _ __(_)_ __ | |_ "
170− , "| |_) | | | | '__/ _ \\___ \\ / __| '__| | '_ \\| __|"
171− , "| __/| |_| | | | __/___) | (__| | | | |_) | |_ "
172− , "|_| \\__,_|_| \\___|____/ \\___|_| |_| .__/ \\__|"
173− , " |_| "
174− , ""
175− , ":? shows help"
176− , ""
177− , "Expressions are terminated using Ctrl+D"
178− ]
179−
180−-- |
181−-- The quit message.
182−--
183−quitMessage :: String
184−quitMessage = "See ya!"
185−
186−-- Haskeline completions
187−
188−data CompletionContext = Command String | FilePath | Module | Identifier | Fixed [String] | Multiple [CompletionContext]
189− deriving (Show)
190−
191−-- |
192−-- Decide what kind of completion we need based on input.
193−completionContext :: String -> Maybe CompletionContext
194−completionContext cmd@"" = Just $ Multiple [Command cmd, Identifier]
195−completionContext cmd@(':' : _ )
196− | cmd `elem` C.commands || cmd == ":" = Just $ Command cmd
197−completionContext (':' : c : _) = case c of
198− 'i' -> Just Module
199− 'b' -> Just Module
200− 'm' -> Just FilePath
201− 'q' -> Nothing
202− 'r' -> Nothing
203− '?' -> Nothing
204− 's' -> Just $ Fixed ["import", "loaded"]
205− 't' -> Just Identifier
206− 'k' -> Just Identifier
207− _ -> Nothing
208−completionContext _ = Just Identifier
209−
210−-- |
211−-- Loads module, function, and file completions.
212−--
213−completion :: CompletionFunc (StateT PSCiState IO)
214−completion = completeWordWithPrev Nothing " \t\n\r" findCompletions
215− where
216− findCompletions :: String -> String -> StateT PSCiState IO [Completion]
217− findCompletions prev word = do
218− let ctx = completionContext $ (dropWhile isSpace (reverse prev)) ++ word
219− completions <- case ctx of
220− Nothing -> return []
221− (Just c) -> (mapMaybe $ either (\cand -> if word `isPrefixOf` cand
222− then Just $ simpleCompletion cand
223− else Nothing) Just)
224− <$> getCompletion c word
225− return $ sortBy sorter completions
226−
227− getCompletion :: CompletionContext -> String -> StateT PSCiState IO [Either String Completion]
228− getCompletion (Command s) _ = return $ (map Left) $ nub $ filter (isPrefixOf s) C.commands
229− getCompletion FilePath f = (map Right) <$> listFiles f
230− getCompletion Module _ = (map Left) <$> getModuleNames
231− getCompletion Identifier _ = (map Left) <$> getIdentNames
232− getCompletion (Fixed list) _ = return $ (map Left) list
233− getCompletion (Multiple contexts) f = concat <$> mapM (flip getCompletion $ f) contexts
234−
235− getLoadedModules :: StateT PSCiState IO [P.Module]
236− getLoadedModules = map snd . psciLoadedModules <$> get
237−
238− getModuleNames :: StateT PSCiState IO [String]
239− getModuleNames = moduleNames <$> getLoadedModules
240−
241− getIdentNames :: StateT PSCiState IO [String]
242− getIdentNames = identNames <$> getLoadedModules
243−
244− getDeclName :: Maybe [P.DeclarationRef] -> P.Declaration -> Maybe P.Ident
245− getDeclName exts (P.ValueDeclaration ident _ _ _) | isExported ident exts = Just ident
246− getDeclName exts (P.ExternDeclaration _ ident _ _) | isExported ident exts = Just ident
247− getDeclName exts (P.PositionedDeclaration _ d) = getDeclName exts d
248− getDeclName _ _ = Nothing
249−
250− isExported :: N.Ident -> Maybe [P.DeclarationRef] -> Bool
251− isExported ident = maybe True (any exports)
252− where
253− exports :: P.DeclarationRef -> Bool
254− exports (P.ValueRef ident') = ident == ident'
255− exports (P.PositionedDeclarationRef _ r) = exports r
256− exports _ = False
257−
258− identNames :: [P.Module] -> [String]
259− identNames ms = nub [ show qual
260− | P.Module moduleName ds exts <- ms
261− , ident <- mapMaybe (getDeclName exts) ds
262− , qual <- [ P.Qualified Nothing ident
263− , P.Qualified (Just moduleName) ident]
264− ]
265− moduleNames :: [P.Module] -> [String]
266− moduleNames ms = nub [show moduleName | P.Module moduleName _ _ <- ms]
267−
268− sorter :: Completion -> Completion -> Ordering
269− sorter (Completion _ d1 _) (Completion _ d2 _) = if ":" `isPrefixOf` d1 then LT else compare d1 d2
270−
271−-- Compilation
272−
273−-- | Compilation options.
274−--
275−options :: P.Options P.Make
276−options = P.Options False False False Nothing False False P.MakeOptions
277−
278−-- |
279−-- PSCI monad
280−--
281−newtype PSCI a = PSCI { runPSCI :: InputT (StateT PSCiState IO) a } deriving (Functor, Applicative, Monad)
282−
283−psciIO :: IO a -> PSCI a
284−psciIO io = PSCI (lift (lift io))
285−
286−newtype Make a = Make { unMake :: ErrorT String IO a } deriving (Functor, Applicative, Monad, MonadError String)
287−
288−runMake :: Make a -> IO (Either String a)
289−runMake = runErrorT . unMake
290−
291−makeIO :: IO a -> Make a
292−makeIO = Make . ErrorT . fmap (either (Left . show) Right) . tryIOError
293−
294−instance P.MonadMake Make where
295− getTimestamp path = makeIO $ do
296− exists <- doesFileExist path
297− if exists
298− then Just <$> getModificationTime path
299− else return Nothing
300− readTextFile path = makeIO $ U.readFile path
301− writeTextFile path text = makeIO $ do
302− mkdirp path
303− U.writeFile path text
304− liftError = either throwError return
305− progress s = unless (s == "Compiling $PSCI") $ makeIO . U.putStrLn $ s
306−
307−mkdirp :: FilePath -> IO ()
308−mkdirp = createDirectoryIfMissing True . takeDirectory
309−
310−-- |
311−-- Makes a volatile module to execute the current expression.
312−--
313−createTemporaryModule :: Bool -> PSCiState -> P.Expr -> P.Module
314−createTemporaryModule exec PSCiState{psciImportedModuleNames = imports, psciLetBindings = lets} val =
315− let
316− moduleName = P.ModuleName [P.ProperName "$PSCI"]
317− importDecl m = P.ImportDeclaration m P.Unqualified Nothing
318− traceModule = P.ModuleName [P.ProperName "Debug", P.ProperName "Trace"]
319− trace = P.Var (P.Qualified (Just traceModule) (P.Ident "print"))
320− itValue = foldl (\x f -> f x) val lets
321− mainValue = P.App trace (P.Var (P.Qualified Nothing (P.Ident "it")))
322− itDecl = P.ValueDeclaration (P.Ident "it") P.Value [] $ Right itValue
323− mainDecl = P.ValueDeclaration (P.Ident "main") P.Value [] $ Right mainValue
324− decls = if exec then [itDecl, mainDecl] else [itDecl]
325− in
326− P.Module moduleName ((importDecl `map` imports) ++ decls) Nothing
327−
328−-- |
329−-- Makes a volatile module to hold a non-qualified type synonym for a fully-qualified data type declaration.
330−--
331−createTemporaryModuleForKind :: PSCiState -> P.Type -> P.Module
332−createTemporaryModuleForKind PSCiState{psciImportedModuleNames = imports} typ =
333− let
334− moduleName = P.ModuleName [P.ProperName "$PSCI"]
335− importDecl m = P.ImportDeclaration m P.Unqualified Nothing
336− itDecl = P.TypeSynonymDeclaration (P.ProperName "IT") [] typ
337− in
338− P.Module moduleName ((importDecl `map` imports) ++ [itDecl]) Nothing
339−
340−-- |
341−-- Makes a volatile module to execute the current imports.
342−--
343−createTemporaryModuleForImports :: PSCiState -> P.Module
344−createTemporaryModuleForImports PSCiState{psciImportedModuleNames = imports} =
345− let
346− moduleName = P.ModuleName [P.ProperName "$PSCI"]
347− importDecl m = P.ImportDeclaration m P.Unqualified Nothing
348− in
349− P.Module moduleName (importDecl `map` imports) Nothing
350−
351−modulesDir :: FilePath
352−modulesDir = ".psci_modules" ++ pathSeparator : "node_modules"
353−
354−indexFile :: FilePath
355−indexFile = ".psci_modules" ++ pathSeparator : "index.js"
356−
357−-- |
358−-- Takes a value declaration and evaluates it with the current state.
359−--
360−handleDeclaration :: P.Expr -> PSCI ()
361−handleDeclaration val = do
362− st <- PSCI $ lift get
363− let m = createTemporaryModule True st val
364− e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) []
365− case e of
366− Left err -> PSCI $ outputStrLn err
367− Right _ -> do
368− psciIO $ writeFile indexFile "require('$PSCI').main();"
369− process <- psciIO findNodeProcess
370− result <- psciIO $ traverse (\node -> readProcessWithExitCode node [indexFile] "") process
371− case result of
372− Just (ExitSuccess, out, _) -> PSCI $ outputStrLn out
373− Just (ExitFailure _, _, err) -> PSCI $ outputStrLn err
374− Nothing -> PSCI $ outputStrLn "Couldn't find node.js"
375−
376−-- |
377−-- Takes a let declaration and updates the environment, then run a make. If the declaration fails,
378−-- restore the pre-let environment.
379−--
380−handleLet :: (P.Expr -> P.Expr) -> PSCI ()
381−handleLet l = do
382− st <- PSCI $ lift get
383− let st' = updateLets l st
384− let m = createTemporaryModule False st' (P.ObjectLiteral [])
385− e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules st' ++ [(Left P.RebuildAlways, m)]) []
386− case e of
387− Left err -> PSCI $ outputStrLn err
388− Right _ -> PSCI $ lift (put st')
389−
390−-- |
391−-- Show actual loaded modules in psci.
392−--
393−handleShowLoadedModules :: PSCI ()
394−handleShowLoadedModules = do
395− PSCiState { psciLoadedModules = loadedModules } <- PSCI $ lift get
396− psciIO $ readModules loadedModules >>= putStrLn
397− return ()
398− where readModules = return . unlines . sort . nub . map toModuleName
399− toModuleName = N.runModuleName . (\ (D.Module mdName _ _) -> mdName) . snd
400−
401−-- |
402−-- Show the imported modules in psci.
403−--
404−handleShowImportedModules :: PSCI ()
405−handleShowImportedModules = do
406− PSCiState { psciImportedModuleNames = importedModuleNames } <- PSCI $ lift get
407− psciIO $ readModules importedModuleNames >>= putStrLn
408− return ()
409− where readModules = return . unlines . sort . map N.runModuleName
410−
411−-- |
412−-- Imports a module, preserving the initial state on failure.
413−--
414−handleImport :: P.ModuleName -> PSCI ()
415−handleImport moduleName = do
416− st <- updateImports moduleName <$> PSCI (lift get)
417− let m = createTemporaryModuleForImports st
418− e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) []
419− case e of
420− Left err -> PSCI $ outputStrLn err
421− Right _ -> do
422− PSCI $ lift $ put st
423− return ()
424−
425−-- |
426−-- Takes a value and prints its type
427−--
428−handleTypeOf :: P.Expr -> PSCI ()
429−handleTypeOf val = do
430− st <- PSCI $ lift get
431− let m = createTemporaryModule False st val
432− e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) []
433− case e of
434− Left err -> PSCI $ outputStrLn err
435− Right env' ->
436− case M.lookup (P.ModuleName [P.ProperName "$PSCI"], P.Ident "it") (P.names env') of
437− Just (ty, _, _) -> PSCI . outputStrLn . P.prettyPrintType $ ty
438− Nothing -> PSCI $ outputStrLn "Could not find type"
439−
440−-- |
441−-- Pretty print a module's signatures
442−--
443−printModuleSignatures :: P.ModuleName -> P.Environment -> PSCI ()
444−printModuleSignatures moduleName env =
445− PSCI $ let namesEnv = P.names env
446− moduleNamesIdent = (filter ((== moduleName) . fst) . M.keys) namesEnv
447− in case moduleNamesIdent of
448− [] -> outputStrLn $ "This module '"++ P.runModuleName moduleName ++"' does not export functions."
449− _ -> ( outputStrLn
450− . unlines
451− . sort
452− . map (showType . findType namesEnv)) moduleNamesIdent
453− 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))
454− findType envNames m@(_, mIdent) = (mIdent, M.lookup m envNames)
455− showType :: (P.Ident, Maybe (P.Type, P.NameKind, P.NameVisibility)) -> String
456− showType (mIdent, Just (mType, _, _)) = show mIdent ++ " :: " ++ P.prettyPrintType mType
457− showType _ = error "The impossible happened in printModuleSignatures."
458−
459−-- |
460−-- Browse a module and displays its signature (if module exists).
461−--
462−handleBrowse :: P.ModuleName -> PSCI ()
463−handleBrowse moduleName = do
464− st <- PSCI $ lift get
465− let loadedModules = psciLoadedModules st
466− env <- psciIO . runMake $ P.make modulesDir options loadedModules []
467− case env of
468− Left err -> PSCI $ outputStrLn err
469− Right env' ->
470− if moduleName `notElem` (nub . map ((\ (P.Module modName _ _ ) -> modName) . snd)) loadedModules
471− then PSCI $ outputStrLn $ "Module '" ++ N.runModuleName moduleName ++ "' is not valid."
472− else printModuleSignatures moduleName env'
473−
474−-- |
475−-- Takes a value and prints its kind
476−--
477−handleKindOf :: P.Type -> PSCI ()
478−handleKindOf typ = do
479− st <- PSCI $ lift get
480− let m = createTemporaryModuleForKind st typ
481− mName = P.ModuleName [P.ProperName "$PSCI"]
482− e <- psciIO . runMake $ P.make modulesDir options (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) []
483− case e of
484− Left err -> PSCI $ outputStrLn err
485− Right env' ->
486− case M.lookup (P.Qualified (Just mName) $ P.ProperName "IT") (P.typeSynonyms env') of
487− Just (_, typ') -> do
488− let chk = P.CheckState env' 0 0 (Just mName)
489− k = L.runStateT (P.unCheck (P.kindOf mName typ')) chk
490− case k of
491− Left errStack -> PSCI . outputStrLn . P.prettyPrintErrorStack False $ errStack
492− Right (kind, _) -> PSCI . outputStrLn . P.prettyPrintKind $ kind
493− Nothing -> PSCI $ outputStrLn "Could not find kind"
494−
495−-- Commands
496−
497−-- |
498−-- Parses the input and returns either a Metacommand or an expression.
499−--
500−getCommand :: Bool -> InputT (StateT PSCiState IO) (Either String (Maybe Command))
501−getCommand singleLineMode = do
502− firstLine <- getInputLine "> "
503− case firstLine of
504− Nothing -> return (Right Nothing)
505− Just "" -> return (Right Nothing)
506− Just s | singleLineMode || head s == ':' -> return . either Left (Right . Just) $ parseCommand s
507− Just s -> either Left (Right . Just) . parseCommand <$> go [s]
508− where
509− go :: [String] -> InputT (StateT PSCiState IO) String
510− go ls = maybe (return . unlines $ reverse ls) (go . (:ls)) =<< getInputLine " "
511−
512−-- |
513−-- Performs an action for each meta-command given, and also for expressions..
514−--
515−handleCommand :: Command -> PSCI ()
516−handleCommand (Expression val) = handleDeclaration val
517−handleCommand Help = PSCI $ outputStrLn helpMessage
518−handleCommand (Import moduleName) = handleImport moduleName
519−handleCommand (Let l) = handleLet l
520−handleCommand (LoadFile filePath) = do
521− absPath <- psciIO $ expandTilde filePath
522− exists <- psciIO $ doesFileExist absPath
523− if exists then do
524− PSCI . lift $ modify (updateImportedFiles absPath)
525− m <- psciIO $ loadModule absPath
526− case m of
527− Left err -> PSCI $ outputStrLn err
528− Right mods -> PSCI . lift $ modify (updateModules (map ((,) (Right absPath)) mods))
529− else
530− PSCI . outputStrLn $ "Couldn't locate: " ++ filePath
531−handleCommand Reset = do
532− files <- psciImportedFilenames <$> PSCI (lift get)
533− modulesOrFirstError <- psciIO $ loadAllModules files
534− case modulesOrFirstError of
535− Left err -> psciIO $ print err >> exitFailure
536− Right modules -> PSCI . lift $ put (PSCiState files defaultImports modules [])
537−handleCommand (TypeOf val) = handleTypeOf val
538−handleCommand (KindOf typ) = handleKindOf typ
539−handleCommand (Browse moduleName) = handleBrowse moduleName
540−handleCommand (Show "loaded") = handleShowLoadedModules
541−handleCommand (Show "import") = handleShowImportedModules
542−handleCommand _ = PSCI $ outputStrLn "Unknown command"
543−
544−loadUserConfig :: IO (Maybe [Command])
545−loadUserConfig = do
546− configFile <- (</> ".psci") <$> getCurrentDirectory
547− exists <- doesFileExist configFile
548− if exists
549− then do
550− ls <- lines <$> U.readFile configFile
551− case mapM parseCommand ls of
552− Left err -> U.print err >> exitFailure
553− Right cs -> return $ Just cs
554− else
555− return Nothing
556−
557−-- |
558−-- The PSCI main loop.
559−--
560−loop :: PSCiOptions -> IO ()
561−loop (PSCiOptions singleLineMode files) = do
562− config <- loadUserConfig
563− modulesOrFirstError <- loadAllModules files
564− case modulesOrFirstError of
565− Left err -> print err >> exitFailure
566− Right modules -> do
567− historyFilename <- getHistoryFilename
568− let settings = defaultSettings { historyFile = Just historyFilename }
569− flip evalStateT (PSCiState files defaultImports modules []) . runInputT (setComplete completion settings) $ do
570− outputStrLn prologueMessage
571− traverse_ (mapM_ (runPSCI . handleCommand)) config
572− go
573− where
574− go :: InputT (StateT PSCiState IO) ()
575− go = do
576− c <- getCommand singleLineMode
577− case c of
578− Left err -> outputStrLn err >> go
579− Right Nothing -> go
580− Right (Just Quit) -> outputStrLn quitMessage
581− Right (Just c') -> runPSCI (handleCommand c') >> go
582−
583−singleLineFlag :: Parser Bool
584−singleLineFlag = switch $
585− long "single-line-mode"
586− <> Opts.help "Run in single-line mode"
587−
588−inputFile :: Parser FilePath
589−inputFile = strArgument $
590− metavar "FILE"
591− <> Opts.help "Optional .purs files to load on start"
592−
593−psciOptions :: Parser PSCiOptions
594−psciOptions = PSCiOptions <$> singleLineFlag
595− <*> many inputFile
596−
597−main :: IO ()
598−main = execParser opts >>= loop
599− where
600− opts = info (version <*> helper <*> psciOptions) infoModList
601− infoModList = fullDesc <> headerInfo <> footerInfo
602− headerInfo = header "psci - Interactive mode for PureScript"
603− footerInfo = footer $ "psci " ++ showVersion Paths.version
604−
605− version :: Parser (a -> a)
606− version = abortOption (InfoMsg (showVersion Paths.version)) $ long "version" <> Opts.help "Show the version number" <> hidden
607−
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.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−176
@@ -1,176 +0,0 @@
1−name: purescript
2−version: 0.6.2
3−cabal-version: >=1.8
4−build-type: Simple
5−license: MIT
6−license-file: LICENSE
7−copyright: (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
8−maintainer: Phil Freeman <paf31@cantab.net>
9−stability: experimental
10−synopsis: PureScript Programming Language Compiler
11−description: A small strongly, statically typed programming language with expressive types, inspired by Haskell and compiling to Javascript.
12−category: Language
13−Homepage: http://www.purescript.org/
14−author: Phil Freeman <paf31@cantab.net>,
15− Gary Burgess <gary.burgess@gmail.com>,
16− Hardy Jones <jones3.hardy@gmail.com>
17−
18−extra-source-files: prelude/prelude.purs
19− , examples/passing/*.purs
20− , examples/failing/*.purs
21−
22−source-repository head
23− type: git
24− location: https://github.com/purescript/purescript.git
25−
26−library
27− build-depends: base >=4.6 && <5,
28− containers -any,
29− unordered-containers -any,
30− directory >= 1.2,
31− filepath -any,
32− mtl >= 2.1.0 && < 2.3.0,
33− parsec -any,
34− transformers >= 0.3 && < 0.5,
35− utf8-string -any,
36− pattern-arrows >= 0.0.2 && < 0.1,
37− monad-unify >= 0.2.2 && < 0.3,
38− file-embed >= 0.0.7 && < 0.0.8,
39− time -any
40− exposed-modules: Language.PureScript
41− Language.PureScript.AST
42− Language.PureScript.AST.Binders
43− Language.PureScript.AST.Declarations
44− Language.PureScript.AST.Operators
45− Language.PureScript.AST.SourcePos
46− Language.PureScript.AST.Traversals
47− Language.PureScript.CodeGen
48− Language.PureScript.CodeGen.Externs
49− Language.PureScript.CodeGen.JS
50− Language.PureScript.CodeGen.JS.AST
51− Language.PureScript.CodeGen.JS.Common
52− Language.PureScript.CodeGen.JS.Optimizer
53− Language.PureScript.CodeGen.JS.Optimizer.Blocks
54− Language.PureScript.CodeGen.JS.Optimizer.Common
55− Language.PureScript.CodeGen.JS.Optimizer.Inliner
56− Language.PureScript.CodeGen.JS.Optimizer.MagicDo
57− Language.PureScript.CodeGen.JS.Optimizer.TCO
58− Language.PureScript.CodeGen.JS.Optimizer.Unused
59− Language.PureScript.Constants
60− Language.PureScript.CoreFn
61− Language.PureScript.CoreFn.Ann
62− Language.PureScript.CoreFn.Binders
63− Language.PureScript.CoreFn.Desugar
64− Language.PureScript.CoreFn.Expr
65− Language.PureScript.CoreFn.Literals
66− Language.PureScript.CoreFn.Meta
67− Language.PureScript.CoreFn.Module
68− Language.PureScript.CoreFn.Traversals
69− Language.PureScript.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.Operators
96− Language.PureScript.Sugar.TypeClasses
97− Language.PureScript.Sugar.TypeDeclarations
98− Language.PureScript.Supply
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− exposed: True
113− buildable: True
114− hs-source-dirs: src
115− other-modules: Paths_purescript
116− ghc-options: -Wall -fno-warn-warnings-deprecations -O2
117−
118−executable psc
119− build-depends: base >=4 && <5, containers -any, directory -any, filepath -any,
120− mtl -any, optparse-applicative >= 0.10.0, parsec -any, purescript -any,
121− transformers -any, utf8-string -any
122− main-is: Main.hs
123− buildable: True
124− hs-source-dirs: psc
125− other-modules:
126− ghc-options: -Wall -fno-warn-warnings-deprecations -O2 -fno-warn-unused-do-bind
127−
128−executable psc-make
129− build-depends: base >=4 && <5, containers -any, directory -any, filepath -any,
130− mtl -any, optparse-applicative >= 0.10.0, parsec -any, purescript -any,
131− transformers -any, utf8-string -any
132− main-is: Main.hs
133− buildable: True
134− hs-source-dirs: psc-make
135− other-modules:
136− ghc-options: -Wall -fno-warn-warnings-deprecations -O2 -fno-warn-unused-do-bind
137−
138−executable psci
139− build-depends: base >=4 && <5, containers -any, directory -any, filepath -any,
140− mtl -any, optparse-applicative >= 0.10.0, parsec -any,
141− haskeline >= 0.7.0.0, purescript -any, transformers -any,
142− utf8-string -any, process -any
143−
144− main-is: Main.hs
145− buildable: True
146− hs-source-dirs: psci
147− other-modules: Commands
148− Parser
149− ghc-options: -Wall -fno-warn-warnings-deprecations -O2
150−
151−executable psc-docs
152− build-depends: base >=4 && <5, purescript -any, utf8-string -any,
153− optparse-applicative >= 0.10.0, process -any, mtl -any
154− main-is: Main.hs
155− buildable: True
156− hs-source-dirs: psc-docs
157− other-modules:
158− ghc-options: -Wall -fno-warn-warnings-deprecations -O2
159−
160−executable hierarchy
161− build-depends: base >=4 && <5, purescript -any, utf8-string -any, optparse-applicative >= 0.10.0,
162− process -any, mtl -any, parsec -any, filepath -any, directory -any
163− main-is: Main.hs
164− buildable: True
165− hs-source-dirs: hierarchy
166− other-modules:
167− ghc-options: -Wall -fno-warn-warnings-deprecations -O2
168−
169−test-suite tests
170− build-depends: base >=4 && <5, containers -any, directory -any,
171− filepath -any, mtl -any, parsec -any, purescript -any,
172− transformers -any, utf8-string -any, process -any
173− type: exitcode-stdio-1.0
174− main-is: Main.hs
175− buildable: True
176− hs-source-dirs: tests
src/CodeGen/IL.hsnew file+321
@@ -0,0 +1,321 @@
1+-- | This module generates code in the core imperative representation from
2+-- elaborated PureScript code.
3+module CodeGen.IL
4+ ( module AST
5+ , module Common
6+ , moduleToIL
7+ ) where
8+
9+import Prelude.Compat
10+import Protolude (ordNub)
11+
12+import Control.Arrow ((&&&))
13+import Control.Monad (forM, liftM, replicateM, void)
14+import Control.Monad.Supply.Class
15+
16+import Data.List ((\\), delete, intersect, nub)
17+import qualified Data.Foldable as F
18+import qualified Data.Map as M
19+import Data.Maybe (fromMaybe, isNothing, mapMaybe)
20+import Data.Monoid ((<>))
21+import Data.String (fromString)
22+import Data.Text (Text)
23+import qualified Data.Text as T
24+
25+import Language.PureScript.AST.SourcePos
26+import Language.PureScript.CoreImp.AST (AST)
27+import qualified Language.PureScript.CoreImp.AST as AST
28+import Language.PureScript.CoreFn
29+import Language.PureScript.Crash
30+import Language.PureScript.Names
31+import Language.PureScript.Options
32+import Language.PureScript.PSString (PSString, mkString)
33+import Language.PureScript.Traversals (sndM)
34+import qualified Language.PureScript.Constants as C
35+
36+import System.FilePath.Posix ((</>))
37+
38+import CodeGen.IL.Common as Common
39+import CodeGen.IL.Optimizer
40+import CodeGen.IL.Printer
41+
42+data DeclType = ModuleDecl | LetDecl | RecLetDecl deriving (Eq)
43+
44+-- | Generate code in the simplified intermediate representation for all declarations in a
45+-- module.
46+moduleToIL
47+ :: forall m
48+ -- . (Monad m, MonadReader Options m, MonadSupply m, MonadError MultipleErrors m)
49+ . (Monad m, MonadSupply m)
50+ => Module Ann
51+ -> Text
52+ -> m (Text, [Text], [AST], Text, Text)
53+moduleToIL (Module _ coms mn _ imps _ foreigns decls) project =
54+ do
55+ ilDecls <- mapM (bindToIL ModuleDecl) decls
56+ optimized <- traverse (traverse (optimize modName')) ilDecls
57+ let optimized' = concat optimized
58+ values = annotValue <$> optimized'
59+ foreigns' = moduleIdentToIL <$> foreigns
60+ interface = interfaceSource modName values foreigns
61+ imports = nub . concat $ importToIL <$> optimized'
62+ implHeader = implHeaderSource modName imports project
63+ implFooter = implFooterSource (runModuleName mn) foreigns
64+ return $ (interface, foreigns', optimized', implHeader, implFooter)
65+ where
66+ modName = moduleNameToIL mn
67+ modName' = AST.Var Nothing modName
68+
69+ annotValue :: AST -> (Text, Bool)
70+ annotValue (AST.Function _ (Just name) [] (AST.Block _ [AST.Return _ ret]))
71+ | isLiteral ret = (name, True)
72+ annotValue (AST.Function _ (Just name) [] _) = (name, False)
73+ annotValue _ = error "Unexpected top-level value form"
74+
75+ -- | Extracts all declaration names from a binding group.
76+ getNames :: Bind Ann -> [Ident]
77+ getNames (NonRec _ ident _) = [ident]
78+ getNames (Rec vals) = map (snd . fst) vals
79+
80+ -- | Generates IL code for a module import
81+ --
82+ importToIL :: AST -> [Text]
83+ importToIL = AST.everything (++) modRef
84+ where
85+ modRef (AST.Indexer _ (AST.Var _ _) (AST.Var _ mname))
86+ | not $ T.null mname = [extract mname]
87+ modRef _ = []
88+ extract :: Text -> Text
89+ extract = T.replace "_" "." . T.dropWhileEnd (=='_')
90+
91+ -- |
92+ -- Generate code in the simplified intermediate representation for a declaration
93+ --
94+ bindToIL :: DeclType -> Bind Ann -> m [AST]
95+ bindToIL dt (NonRec ann ident val) = return <$> nonRecToIL dt ann ident val
96+ bindToIL dt (Rec vals) = forM vals (uncurry . uncurry $ nonRecToIL dt')
97+ where
98+ dt' = if dt == LetDecl then RecLetDecl else dt
99+
100+ -- | Generate code in the simplified intermediate representation for a single non-recursive
101+ -- declaration.
102+ --
103+ -- The main purpose of this function is to handle code generation for comments.
104+ nonRecToIL :: DeclType -> Ann -> Ident -> Expr Ann -> m AST
105+ nonRecToIL dt a i e@(extractAnn -> (_, com, _, _)) | not (null com) = do
106+ -- withoutComment <- asks optionsNoComments
107+ let withoutComment = False
108+ if withoutComment
109+ then nonRecToIL dt a i (modifyAnn removeComments e)
110+ else AST.Comment Nothing com <$> nonRecToIL dt a i (modifyAnn removeComments e)
111+ nonRecToIL ModuleDecl (ss, _, _, _) ident val = do
112+ il <- valueToIL val
113+ pure $ AST.Function Nothing (Just $ moduleIdentToIL ident) [] (AST.Block Nothing [AST.Return Nothing il])
114+ nonRecToIL RecLetDecl (ss, _, _, _) ident val = do
115+ ilExpr <- valueToIL val
116+ pure $ AST.Assignment Nothing (AST.Var Nothing $ identToIL ident) ilExpr
117+ nonRecToIL _ (ss, _, _, _) ident val = do
118+ il <- valueToIL val
119+ pure $ AST.VariableIntroduction Nothing (identToIL ident) (Just il)
120+
121+ -- | Generate code in the simplified intermediate representation for a variable based on a
122+ -- PureScript identifier.
123+ var :: Ident -> AST
124+ var = AST.Var Nothing . identToIL
125+
126+ accessorString :: PSString -> AST -> AST
127+ accessorString prop = AST.Indexer Nothing (AST.StringLiteral Nothing prop)
128+
129+ -- | Generate code in the simplified intermediate representation for a value or expression.
130+
131+ valueToIL :: Expr Ann -> m AST
132+ valueToIL (Literal (pos, _, _, _) l) = literalToValueIL pos l
133+ valueToIL (Accessor _ prop val) =
134+ accessorString prop <$> valueToIL val
135+ valueToIL (ObjectUpdate _ o ps) = do
136+ obj <- valueToIL o
137+ updates <- mapM (sndM valueToIL) ps
138+ obj' <- freshName'
139+ let objVar = AST.Var Nothing obj'
140+ copy = AST.VariableIntroduction Nothing obj' (Just $ copyDict obj)
141+ assign (k, v) = AST.Assignment Nothing (accessorString k objVar) v
142+ sts = copy : (assign <$> updates) ++ [AST.Return Nothing objVar]
143+ return $ AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing sts)) []
144+ valueToIL (Abs _ arg val) = do
145+ ret <- valueToIL val
146+ let ilArg = case arg of
147+ UnusedIdent -> []
148+ _ -> [identToIL arg]
149+ return $ AST.Function Nothing Nothing ilArg (AST.Block Nothing [AST.Return Nothing ret])
150+ valueToIL e@App{} = do
151+ let (f, args) = unApp e []
152+ args' <- mapM valueToIL args
153+ fn <- valueToIL f
154+ case f of
155+ Var (_, _, _, Just IsNewtype) _ -> return (head args')
156+ _ -> flip (foldl (\fn a -> AST.App Nothing fn [a])) args' <$> valueToIL f
157+ where
158+ unApp :: Expr Ann -> [Expr Ann] -> (Expr Ann, [Expr Ann])
159+ unApp (App _ val arg) args = unApp val (arg : args)
160+ unApp other args = (other, args)
161+ valueToIL (Var _ ident) = return $ varToIL ident
162+ valueToIL (Case (ss, _, _, _) values binders) = do
163+ vals <- mapM valueToIL values
164+ bindersToIL ss binders vals
165+ valueToIL (Let _ ds val) = do
166+ let recurs = concatMap getNames $ filter isRec ds
167+ recurDs = (\v -> AST.VariableIntroduction Nothing (identToIL v) Nothing) <$> recurs
168+ ds' <- concat <$> mapM (bindToIL LetDecl) ds
169+ ret <- valueToIL val
170+ return $ AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing (recurDs ++ ds' ++ [AST.Return Nothing ret]))) []
171+ where
172+ isRec :: Bind Ann -> Bool
173+ isRec (Rec _) = True
174+ isRec _ = False
175+ valueToIL (Constructor (_, _, _, Just IsNewtype) _ (ProperName ctor) _) = error "IsNewtype"
176+ valueToIL (Constructor _ _ (ProperName ctor) fields) =
177+ let body = AST.ObjectLiteral Nothing $ (mkString ctor, AST.BooleanLiteral Nothing True) :
178+ ((\field -> (mkString (identToIL field), var field)) `map` fields)
179+ fn = foldr (\f inner -> AST.Function Nothing Nothing [identToIL f] (AST.Block Nothing [AST.Return Nothing inner])) body fields
180+ in return fn
181+
182+
183+ iife :: Text -> [AST] -> AST
184+ iife v exprs = AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing $ exprs ++ [AST.Return Nothing $ AST.Var Nothing v])) []
185+
186+ literalToValueIL :: SourceSpan -> Literal (Expr Ann) -> m AST
187+ literalToValueIL ss (NumericLiteral (Left i)) = return $ AST.NumericLiteral (Just ss) (Left i)
188+ literalToValueIL ss (NumericLiteral (Right n)) = return $ AST.NumericLiteral (Just ss) (Right n)
189+ literalToValueIL ss (StringLiteral s) = return $ AST.StringLiteral (Just ss) s
190+ literalToValueIL ss (CharLiteral c) = return $ AST.StringLiteral (Just ss) (fromString [c])
191+ literalToValueIL ss (BooleanLiteral b) = return $ AST.BooleanLiteral (Just ss) b
192+ literalToValueIL ss (ArrayLiteral xs) = AST.ArrayLiteral (Just ss) <$> mapM valueToIL xs
193+ literalToValueIL ss (ObjectLiteral ps) = AST.ObjectLiteral (Just ss) <$> mapM (sndM valueToIL) ps
194+
195+ -- | Generate code in the simplified intermediate representation for a reference to a
196+ -- variable.
197+ varToIL :: Qualified Ident -> AST
198+ varToIL (Qualified Nothing ident) = var ident
199+ varToIL qual = qualifiedToIL id qual
200+
201+ -- | Generate code in the simplified intermediate representation for a reference to a
202+ -- variable that may have a qualified name.
203+ qualifiedToIL :: (a -> Ident) -> Qualified a -> AST
204+ qualifiedToIL f (Qualified (Just (ModuleName mn')) a) | mn' == C.prim = AST.Var Nothing . moduleIdentToIL $ f a
205+ qualifiedToIL f (Qualified (Just mn') a) | mn /= mn' = AST.Indexer Nothing (AST.Var Nothing . moduleIdentToIL $ f a) (AST.Var Nothing (moduleNameToIL mn'))
206+ qualifiedToIL f (Qualified _ a) = AST.Indexer Nothing (AST.Var Nothing . moduleIdentToIL $ f a) (AST.Var Nothing "")
207+
208+ -- foreignIdent :: Ident -> AST
209+ -- foreignIdent ident = accessorString (mkString $ runIdent ident) (AST.Var Nothing "$foreign")
210+
211+ -- | Generate code in the simplified intermediate representation for pattern match binders
212+ -- and guards.
213+ bindersToIL :: SourceSpan -> [CaseAlternative Ann] -> [AST] -> m AST
214+ bindersToIL ss binders vals = do
215+ valNames <- replicateM (length vals) freshName'
216+ let assignments = zipWith (AST.VariableIntroduction Nothing) valNames (map Just vals)
217+ ils <- forM binders $ \(CaseAlternative bs result) -> do
218+ ret <- guardsToIL result
219+ go valNames ret bs
220+ return $ AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing (assignments ++ concat ils ++ [AST.Throw Nothing (AST.StringLiteral Nothing $ mkString failedPatternMessage)])))
221+ []
222+ where
223+ go :: [Text] -> [AST] -> [Binder Ann] -> m [AST]
224+ go _ done [] = return done
225+ go (v:vs) done' (b:bs) = do
226+ done'' <- go vs done' bs
227+ binderToIL v done'' b
228+ go _ _ _ = internalError "Invalid arguments to bindersToIL"
229+
230+ failedPatternMessage :: Text
231+ failedPatternMessage = "Failed pattern match at " <> runModuleName mn <> " " <> displayStartEndPos ss
232+
233+ guardsToIL :: Either [(Guard Ann, Expr Ann)] (Expr Ann) -> m [AST]
234+ guardsToIL (Left gs) = traverse genGuard gs where
235+ genGuard (cond, val) = do
236+ cond' <- valueToIL cond
237+ val' <- valueToIL val
238+ return
239+ (AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo cond' (AST.BooleanLiteral Nothing True))
240+ (AST.Block Nothing [AST.Return Nothing val']) Nothing)
241+
242+ guardsToIL (Right v) = return . AST.Return Nothing <$> valueToIL v
243+
244+ -- | Generate code in the simplified intermediate representation for a pattern match
245+ -- binder.
246+ binderToIL :: Text -> [AST] -> Binder Ann -> m [AST]
247+ binderToIL _ done NullBinder{} = return done
248+ binderToIL varName done (LiteralBinder _ l) =
249+ literalToBinderIL varName done l
250+ binderToIL varName done (VarBinder _ ident) =
251+ return (AST.VariableIntroduction Nothing (identToIL ident) (Just (AST.Var Nothing varName)) : done)
252+ binderToIL varName done (ConstructorBinder (_, _, _, Just IsNewtype) _ _ [b]) =
253+ binderToIL varName done b
254+ binderToIL varName done (ConstructorBinder (_, _, _, Just (IsConstructor ctorType fields)) _ (Qualified _ (ProperName ctor)) bs) = do
255+ il <- go (zip fields bs) done
256+ return $ case ctorType of
257+ ProductType -> il
258+ SumType ->
259+ [AST.IfElse Nothing (AST.InstanceOf Nothing (AST.Var Nothing varName) (AST.StringLiteral Nothing (mkString ctor)))
260+ (AST.Block Nothing il)
261+ Nothing]
262+ where
263+ go :: [(Ident, Binder Ann)] -> [AST] -> m [AST]
264+ go [] done' = return done'
265+ go ((field, binder) : remain) done' = do
266+ argVar <- freshName'
267+ done'' <- go remain done'
268+ il <- binderToIL argVar done'' binder
269+ return (AST.VariableIntroduction Nothing argVar (Just $ accessorString (mkString $ identToIL field) $ AST.Var Nothing varName) : il)
270+
271+ binderToIL _ _ ConstructorBinder{} =
272+ internalError "binderToIL: Invalid ConstructorBinder in binderToIL"
273+ binderToIL varName done (NamedBinder _ ident binder) = do
274+ il <- binderToIL varName done binder
275+ return (AST.VariableIntroduction Nothing (identToIL ident) (Just (AST.Var Nothing varName)) : il)
276+
277+ literalToBinderIL :: Text -> [AST] -> Literal (Binder Ann) -> m [AST]
278+ literalToBinderIL varName done (NumericLiteral num) =
279+ return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.NumericLiteral Nothing num)) (AST.Block Nothing done) Nothing]
280+ literalToBinderIL varName done (CharLiteral c) =
281+ return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.StringLiteral Nothing (fromString [c]))) (AST.Block Nothing done) Nothing]
282+ literalToBinderIL varName done (StringLiteral str) =
283+ return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.StringLiteral Nothing str)) (AST.Block Nothing done) Nothing]
284+ literalToBinderIL varName done (BooleanLiteral True) =
285+ return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.BooleanLiteral Nothing True)) (AST.Block Nothing done) Nothing]
286+ literalToBinderIL varName done (BooleanLiteral False) =
287+ return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.BooleanLiteral Nothing False)) (AST.Block Nothing done) Nothing]
288+ -- return [AST.IfElse Nothing (AST.Unary Nothing AST.Not (AST.Var Nothing varName)) (AST.Block Nothing done) Nothing]
289+ literalToBinderIL varName done (ObjectLiteral bs) = go done bs
290+ where
291+ go :: [AST] -> [(PSString, Binder Ann)] -> m [AST]
292+ go done' [] = return done'
293+ go done' ((prop, binder):bs') = do
294+ propVar <- freshName'
295+ done'' <- go done' bs'
296+ il <- binderToIL propVar done'' binder
297+ return (AST.VariableIntroduction Nothing propVar (Just (accessorString prop (AST.Var Nothing varName))) : il)
298+ literalToBinderIL varName done (ArrayLiteral bs) = do
299+ il <- go done 0 bs
300+ return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo
301+ (arrayLength $ AST.Var Nothing varName)
302+ (AST.NumericLiteral Nothing (Left (fromIntegral $ length bs))))
303+ (AST.Block Nothing il) Nothing]
304+ where
305+ go :: [AST] -> Integer -> [Binder Ann] -> m [AST]
306+ go done' _ [] = return done'
307+ go done' index (binder:bs') = do
308+ elVar <- freshName'
309+ done'' <- go done' (index + 1) bs'
310+ il <- binderToIL elVar done'' binder
311+ return (AST.VariableIntroduction Nothing elVar (Just (AST.Indexer Nothing (AST.NumericLiteral Nothing (Left index)) (AST.Var Nothing varName))) : il)
312+
313+emptyAnn :: Ann
314+emptyAnn = (SourceSpan "" (SourcePos 0 0) (SourcePos 0 0), [], Nothing, Nothing)
315+
316+arrayLength :: AST -> AST
317+arrayLength a = AST.App Nothing (AST.Var Nothing arrayLengthFn) [a]
318+-- arrayLength a = AST.Var Nothing (arrayLengthFn <> "(" <> prettyPrintIL1 a <> ")")
319+
320+copyDict :: AST -> AST
321+copyDict a = AST.App Nothing (AST.Var Nothing copyDictFn) [a]
src/CodeGen/IL/Common.hsnew file+196
@@ -0,0 +1,196 @@
1+-- | Common code generation utility functions
2+module CodeGen.IL.Common where
3+
4+import Prelude.Compat
5+
6+import Control.Monad.Supply.Class (MonadSupply, freshName)
7+import Data.Char
8+import Data.Maybe (maybe)
9+import Data.Monoid ((<>))
10+import Data.Text (Text)
11+import qualified Data.Text as T
12+
13+import Language.PureScript.Crash
14+import Language.PureScript.Names
15+
16+import qualified Language.PureScript.Constants as C
17+
18+moduleNameToIL :: ModuleName -> Text
19+moduleNameToIL (ModuleName mn) =
20+ let name = T.replace "." "_" mn
21+ in if nameIsILBuiltIn name then (name <> moduleRenamerMarker) else name
22+
23+moduleNameToIL' :: ModuleName -> Text
24+moduleNameToIL' (ModuleName mn) = T.replace "_" "." mn
25+
26+-- | Convert an 'Ident' into a valid IL identifier:
27+--
28+-- * Alphanumeric characters are kept unmodified.
29+--
30+-- * Reserved IL identifiers are wrapped with '_'.
31+--
32+identToIL :: Ident -> Text
33+identToIL UnusedIdent = unusedName
34+identToIL (Ident "$__unused") = unusedName
35+identToIL (Ident name) | name == C.undefined = undefinedName -- Note: done in Printer.hs too
36+identToIL (Ident name) = properToIL name
37+identToIL (GenIdent _ _) = internalError "GenIdent in identToIL"
38+
39+moduleIdentToIL :: Ident -> Text
40+moduleIdentToIL UnusedIdent = unusedName
41+moduleIdentToIL (Ident name) | name == C.undefined = undefinedName
42+moduleIdentToIL (Ident name) = moduleProperToIL name
43+moduleIdentToIL (GenIdent _ _) = internalError "GenIdent in identToIL"
44+
45+undefinedName :: Text
46+undefinedName = "Undefined"
47+
48+unusedName :: Text
49+unusedName = "_"
50+
51+properToIL :: Text -> Text
52+properToIL name
53+ | nameIsILReserved name = "ˉ" <> name
54+ | otherwise = T.concatMap identCharToText name
55+
56+-- | Attempts to find a human-readable name for a symbol, if none has been specified returns the
57+-- ordinal value.
58+identCharToText :: Char -> Text
59+identCharToText 'ṩ' = "_ṩ"
60+identCharToText c | isAlphaNum c = T.singleton c
61+identCharToText '_' = "_"
62+identCharToText '\'' = "ꞌ" -- lowercase saltillo
63+identCharToText c = error (show (ord c)) -- TODO: should never occur now(?)
64+
65+moduleProperToIL :: Text -> Text
66+moduleProperToIL = T.concatMap identCharToText
67+
68+-- | Checks whether an identifier name is reserved in IL.
69+nameIsILReserved :: Text -> Bool
70+nameIsILReserved name =
71+ name `elem` ilAnyReserved
72+
73+-- | Checks whether a name matches a built-in value in IL.
74+nameIsILBuiltIn :: Text -> Bool
75+nameIsILBuiltIn name =
76+ name `elem`
77+ [ "Any"
78+ , "Apply"
79+ , "Contains"
80+ , "CopyDict"
81+ , "Dict"
82+ , "EffFn"
83+ , "Fn"
84+ , "Foreign"
85+ , "Get"
86+ , "Index"
87+ , "Is"
88+ , "Length"
89+ , "Once"
90+ , "Run"
91+ , "Undefined"
92+ ]
93+
94+ilAnyReserved :: [Text]
95+ilAnyReserved =
96+ concat
97+ [ ilKeywords
98+ , ilLiterals
99+ ]
100+
101+ilKeywords :: [Text]
102+ilKeywords =
103+ [ "break"
104+ , "case"
105+ , "chan"
106+ , "const"
107+ , "continue"
108+ , "default"
109+ , "defer"
110+ , "else"
111+ , "fallthrough"
112+ , "for"
113+ , "func"
114+ , "go"
115+ , "goto"
116+ , "if"
117+ , "import"
118+ , "interface"
119+ , "map"
120+ , "package"
121+ , "range"
122+ , "return"
123+ , "select"
124+ , "struct"
125+ , "switch"
126+ , "type"
127+ , "var"
128+ ]
129+
130+ilLiterals :: [Text]
131+ilLiterals =
132+ [ "init"
133+ , "nil"
134+ , "int"
135+ , "int8"
136+ , "int16"
137+ , "int32"
138+ , "int64"
139+ , "uint"
140+ , "uint8"
141+ , "uint16"
142+ , "uint32"
143+ , "uint64"
144+ , "uintptr"
145+ , "float32"
146+ , "float64"
147+ , "complex64"
148+ , "complex128"
149+ , "byte"
150+ , "rune"
151+ , "string"
152+ ]
153+
154+withPrefix :: Text -> Text
155+withPrefix s = "Ꞌ" <> s -- uppercase saltillo
156+
157+anyType :: Text
158+anyType = "Any"
159+
160+dictType :: Text
161+dictType = "Dict"
162+
163+arrayType :: Text
164+arrayType = "[]" <> anyType
165+
166+uncurriedFnType :: Int -> Text
167+uncurriedFnType i = "Fn" <> (T.pack . show $ i)
168+
169+int :: Text
170+int = "int"
171+
172+float :: Text
173+float = "float64"
174+
175+bool :: Text
176+bool = "bool"
177+
178+string :: Text
179+string = "string"
180+
181+arrayLengthFn :: Text
182+arrayLengthFn = "Length"
183+
184+indexFn :: Text
185+indexFn = "Index"
186+
187+copyDictFn :: Text
188+copyDictFn = "CopyDict"
189+
190+freshName' :: MonadSupply m => m Text
191+freshName' = do
192+ name <- freshName
193+ return $ T.replace "$" "ṩ" name
194+
195+moduleRenamerMarker :: Text
196+moduleRenamerMarker = "__"
src/CodeGen/IL/Optimizer.hsnew file+81
@@ -0,0 +1,81 @@
1+-- | This module optimizes code in the intermediate representation.
2+module CodeGen.IL.Optimizer (optimize) where
3+
4+import Prelude.Compat
5+
6+import Control.Monad.Supply.Class (MonadSupply)
7+import Data.Text (Text)
8+import Language.PureScript.CoreImp.AST
9+import Language.PureScript.CoreImp.Optimizer.Blocks
10+import Language.PureScript.CoreImp.Optimizer.Common hiding (isDict)
11+import Language.PureScript.CoreImp.Optimizer.Inliner (etaConvert, evaluateIifes, inlineVariables, unThunk)
12+import Language.PureScript.CoreImp.Optimizer.Unused
13+
14+import CodeGen.IL.Common (unusedName)
15+import CodeGen.IL.Optimizer.Inliner
16+import CodeGen.IL.Optimizer.MagicDo
17+import CodeGen.IL.Optimizer.TCO
18+
19+import qualified Language.PureScript.Constants as C
20+
21+-- | Apply a series of optimizer passes to simplified IL code
22+optimize :: MonadSupply m => AST -> AST -> m AST
23+optimize mn il = do
24+ il' <- untilFixedPoint (inlineFnComposition . inlineUnsafeCoerce . inlineUnsafePartial . tidyUp) il
25+ il'' <- untilFixedPoint (return . ignoreUnusedResults . inlineCommonValues . inlineCommonOperators . tidyUp) . tco mn . inlineST
26+ =<< untilFixedPoint (return . magicDoST)
27+ =<< untilFixedPoint (return . magicDoEff)
28+ =<< untilFixedPoint (return . magicDoEffect) il'
29+ untilFixedPoint (return . collapseVarDeclarations) il''
30+ where
31+ tidyUp :: AST -> AST
32+ tidyUp = applyAll
33+ [ collapseNestedBlocks
34+ , collapseNestedIfs
35+ , collapseIfChecks
36+ , removeCodeAfterReturnStatements
37+ , unThunk
38+ , etaConvert
39+ , evaluateIifes
40+ , inlineVariables
41+ ]
42+
43+untilFixedPoint :: (Monad m, Eq a) => (a -> m a) -> a -> m a
44+untilFixedPoint f = go
45+ where
46+ go a = do
47+ a' <- f a
48+ if a' == a then return a' else go a'
49+
50+collapseIfChecks :: AST -> AST
51+collapseIfChecks = everywhere collapse where
52+ collapse :: AST -> AST
53+ collapse (IfElse _ (Binary _ EqualTo (BooleanLiteral _ True) (BooleanLiteral _ True)) (Block _ [exprs]) _) = exprs
54+ collapse (IfElse _ (Binary _ EqualTo (Indexer _ (Var _ prop) (Var _ val)) (BooleanLiteral _ True)) (Block _ [exprs]) _)
55+ | prop == "otherwise" && val == "Data_Boolean" = exprs
56+ collapse exprs = exprs
57+
58+collapseVarDeclarations :: AST -> AST
59+collapseVarDeclarations = everywhere collapse where
60+ collapse :: AST -> AST
61+ collapse (Block ss sts) = Block ss (go Nothing sts)
62+ collapse s = s
63+
64+ go :: Maybe Text -> [AST] -> [AST]
65+ go _ [] = []
66+ go Nothing (decl@(VariableIntroduction _ var (Just _)) : sts) = decl : go (Just var) (go Nothing sts)
67+ go (Just var') ((VariableIntroduction ss var (Just val)) : sts)
68+ | var == var' = (Assignment ss (Var Nothing var) val) : go (Just var') sts
69+ go var' (s:sts) = s : go var' sts
70+
71+ignoreUnusedResults :: AST -> AST
72+ignoreUnusedResults = everywhere $ removeFromBlock go
73+ where
74+ go :: [AST] -> [AST]
75+ go [] = []
76+ go (VariableIntroduction ss var (Just s) : sts)
77+ | not $ any (everything (||) (isUsed var)) sts = sts'
78+ where
79+ sts' | App{} <- s = s : (go sts)
80+ | otherwise = go sts
81+ go (s:sts) = s : go sts
src/CodeGen/IL/Optimizer/Common.hsnew file+18
@@ -0,0 +1,18 @@
1+-- | Common functions used by the various optimizer phases
2+module CodeGen.IL.Optimizer.Common where
3+
4+import Prelude.Compat
5+
6+import Data.Text (Text)
7+
8+import Language.PureScript.CoreImp.AST
9+import Language.PureScript.PSString (PSString, decodeString)
10+
11+isDict :: (Text, PSString) -> AST -> Bool
12+isDict (moduleName, dictName) (Indexer _ (Var _ x) (Var _ y)) =
13+ Just x == decodeString dictName && y == moduleName
14+isDict _ _ = False
15+
16+isDict' :: [(Text, PSString)] -> AST -> Bool
17+isDict' xs il = any (`isDict` il) xs
18+
src/CodeGen/IL/Optimizer/Inliner.hsnew file+435
@@ -0,0 +1,435 @@
1+-- | This module performs basic inlining of known functions
2+module CodeGen.IL.Optimizer.Inliner
3+ ( inlineCommonValues
4+ , inlineCommonOperators
5+ , inlineFnComposition
6+ , inlineUnsafeCoerce
7+ , inlineUnsafePartial
8+ ) where
9+
10+import Prelude.Compat
11+
12+import Control.Monad.Supply.Class (MonadSupply)
13+
14+import Data.Either (rights)
15+import Data.Maybe (fromMaybe)
16+import Data.String (IsString, fromString)
17+import Data.Text (Text)
18+import qualified Data.Text as T
19+
20+import Language.PureScript.PSString (PSString, decodeString, mkString)
21+import Language.PureScript.CoreImp.AST
22+import Language.PureScript.CoreImp.Optimizer.Common hiding (isDict, isDict')
23+import Language.PureScript.AST (SourceSpan(..))
24+import qualified Language.PureScript.Constants as C
25+
26+import CodeGen.IL.Common
27+import CodeGen.IL.Optimizer.Common
28+
29+-- TODO: Potential bug:
30+-- Shouldn't just inline this case: { var x = 0; x.toFixed(10); }
31+-- Needs to be: { 0..toFixed(10); }
32+-- Probably needs to be fixed in pretty-printer instead.
33+shouldInline :: AST -> Bool
34+shouldInline (Var _ _) = True
35+shouldInline (NumericLiteral _ _) = True
36+shouldInline (StringLiteral _ _) = True
37+shouldInline (BooleanLiteral _ _) = True
38+shouldInline (Indexer _ index val) = shouldInline index && shouldInline val
39+shouldInline _ = False
40+
41+inlineCommonValues :: AST -> AST
42+inlineCommonValues = everywhere convert
43+ where
44+ convert :: AST -> AST
45+ convert (App ss fn [dict])
46+ | isDict' [semiringNumber, semiringInt] dict && isDict fnZero fn = NumericLiteral ss (Left 0)
47+ | isDict' [semiringNumber, semiringInt] dict && isDict fnOne fn = NumericLiteral ss (Left 1)
48+ | isDict boundedBoolean dict && isDict fnBottom fn = BooleanLiteral ss False
49+ | isDict boundedBoolean dict && isDict fnTop fn = BooleanLiteral ss True
50+ convert (App ss (App _ fn [dict]) [x])
51+ | isDict ringInt dict && isDict fnNegate fn = Unary ss Negate (unbox x $ snd ringInt)
52+ convert (App ss (App _ (App _ fn [dict]) [x]) [y])
53+ | isDict semiringInt dict && isDict fnAdd fn = intOp ss Add semiringInt x y
54+ | isDict semiringInt dict && isDict fnMultiply fn = intOp ss Multiply semiringInt x y
55+ | isDict ringInt dict && isDict fnSubtract fn = intOp ss Subtract ringInt x y
56+ convert other = other
57+ fnZero = (C.dataSemiring, C.zero)
58+ fnOne = (C.dataSemiring, C.one)
59+ fnBottom = (C.dataBounded, C.bottom)
60+ fnTop = (C.dataBounded, C.top)
61+ fnAdd = (C.dataSemiring, C.add)
62+ fnMultiply = (C.dataSemiring, C.mul)
63+ fnSubtract = (C.dataRing, C.sub)
64+ fnNegate = (C.dataRing, C.negate)
65+ intOp ss op (_, d) x y = Binary ss op (unbox x d) (unbox y d)
66+
67+inlineCommonOperators :: AST -> AST
68+inlineCommonOperators = everywhereTopDown $ applyAll $
69+ [ binary semiringNumber opAdd Add
70+ , binary semiringNumber opMul Multiply
71+
72+ , binary ringNumber opSub Subtract
73+ , unary ringNumber opNegate Negate
74+
75+ , binary euclideanRingNumber opDiv Divide
76+
77+ -- , binary eqNumber opEq EqualTo
78+ -- , binary eqNumber opNotEq NotEqualTo
79+ , binary eqInt opEq EqualTo
80+ , binary eqInt opNotEq NotEqualTo
81+ , binary eqString opEq EqualTo
82+ , binary eqString opNotEq NotEqualTo
83+ , binary eqChar opEq EqualTo
84+ , binary eqChar opNotEq NotEqualTo
85+ , binary eqBoolean opEq EqualTo
86+ , binary eqBoolean opNotEq NotEqualTo
87+
88+ , binary ordBoolean opLessThan LessThan
89+ , binary ordBoolean opLessThanOrEq LessThanOrEqualTo
90+ , binary ordBoolean opGreaterThan GreaterThan
91+ , binary ordBoolean opGreaterThanOrEq GreaterThanOrEqualTo
92+ , binary ordChar opLessThan LessThan
93+ , binary ordChar opLessThanOrEq LessThanOrEqualTo
94+ , binary ordChar opGreaterThan GreaterThan
95+ , binary ordChar opGreaterThanOrEq GreaterThanOrEqualTo
96+ , binary ordInt opLessThan LessThan
97+ , binary ordInt opLessThanOrEq LessThanOrEqualTo
98+ , binary ordInt opGreaterThan GreaterThan
99+ , binary ordInt opGreaterThanOrEq GreaterThanOrEqualTo
100+ , binary ordNumber opLessThan LessThan
101+ , binary ordNumber opLessThanOrEq LessThanOrEqualTo
102+ , binary ordNumber opGreaterThan GreaterThan
103+ , binary ordNumber opGreaterThanOrEq GreaterThanOrEqualTo
104+ , binary ordString opLessThan LessThan
105+ , binary ordString opLessThanOrEq LessThanOrEqualTo
106+ , binary ordString opGreaterThan GreaterThan
107+ , binary ordString opGreaterThanOrEq GreaterThanOrEqualTo
108+
109+ , binary semigroupString opAppend Add
110+
111+ , binary heytingAlgebraBoolean opConj And
112+ , binary heytingAlgebraBoolean opDisj Or
113+ , unary heytingAlgebraBoolean opNot Not
114+
115+ , binary' C.dataIntBits C.or BitwiseOr
116+ , binary' C.dataIntBits C.and BitwiseAnd
117+ , binary' C.dataIntBits C.xor BitwiseXor
118+ , binary' C.dataIntBits C.shl ShiftLeft
119+ , binary' C.dataIntBits C.shr ShiftRight
120+ , unary' C.dataIntBits C.complement BitwiseNot
121+
122+ , inlineNonClassFunction (isModFn (C.dataFunction, C.apply)) $ \f x -> App Nothing f [x]
123+ , inlineNonClassFunction (isModFn (C.dataFunction, C.applyFlipped)) $ \x f -> App Nothing f [x]
124+ , inlineUnsafeIndex (isModFnWithDict (C.dataArray, C.unsafeIndex)) $ flip (Indexer Nothing)
125+ ] ++
126+ [ fn | i <- [0..10], fn <- [ mkFn i, runFn i ] ] ++
127+ [ fn | i <- [0..10], fn <- [ mkEffFn C.controlMonadEffUncurried C.mkEffFn i, runEffFn C.controlMonadEffUncurried C.runEffFn i ] ] ++
128+ [ fn | i <- [0..10], fn <- [ mkEffFn C.effectUncurried C.mkEffectFn i, runEffFn C.effectUncurried C.runEffectFn i ] ]
129+ where
130+ binary :: (Text, PSString) -> (Text, PSString) -> BinaryOperator -> AST -> AST
131+ binary dict@(_, d) fns op = convert where
132+ convert :: AST -> AST
133+ convert (App ss (App _ (App _ fn [dict']) [x]) [y])
134+ | isDict dict dict' && isDict fns fn = Binary ss op (unbox x d) (unbox y d)
135+ convert other = other
136+ binary' :: Text -> PSString -> BinaryOperator -> AST -> AST
137+ binary' moduleName opString op = convert where
138+ convert :: AST -> AST
139+ convert (App ss (App _ fn [x]) [y]) | isDict (moduleName, opString) fn = Binary ss op (unbox x mn) (unbox y mn)
140+ convert other = other
141+ mn :: PSString
142+ mn = mkString moduleName
143+ unary :: (Text, PSString) -> (Text, PSString) -> UnaryOperator -> AST -> AST
144+ unary dicts@(_, d) fns op = convert where
145+ convert :: AST -> AST
146+ convert (App ss (App _ fn [dict']) [x]) | isDict dicts dict' && isDict fns fn = Unary ss op (unbox x d)
147+ convert other = other
148+ unary' :: Text -> PSString -> UnaryOperator -> AST -> AST
149+ unary' moduleName fnName op = convert where
150+ convert :: AST -> AST
151+ convert (App ss fn [x]) | isDict (moduleName, fnName) fn = Unary ss op (unbox x fnName)
152+ convert other = other
153+
154+ mkFn :: Int -> AST -> AST
155+ mkFn = mkFn' C.dataFunctionUncurried C.mkFn $ \ss1 ss2 ss3 args il ->
156+ Function ss1 Nothing args (Block ss2 [Return ss3 il])
157+
158+ mkEffFn :: Text -> Text -> Int -> AST -> AST
159+ mkEffFn modName fnName = mkFn' modName fnName $ \ss1 ss2 ss3 args il ->
160+ Function ss1 Nothing args (Block ss2 [Return ss3 (App ss3 il [])])
161+
162+ mkFn' :: Text -> Text -> (Maybe SourceSpan -> Maybe SourceSpan -> Maybe SourceSpan -> [Text] -> AST -> AST) -> Int -> AST -> AST
163+ mkFn' modName fnName res 0 = convert where
164+ convert :: AST -> AST
165+ convert (App _ mkFnN [Function s1 Nothing [_] (Block s2 [Return s3 il])]) | isNFn modName fnName 0 mkFnN =
166+ res s1 s2 s3 [] il
167+ convert other = other
168+ mkFn' modName fnName res n = convert where
169+ convert :: AST -> AST
170+ convert orig@(App ss mkFnN [fn]) | isNFn modName fnName n mkFnN =
171+ case collectArgs n [] fn of
172+ Just (args, [Return ss' ret]) -> res ss ss ss' args ret
173+ _ -> orig
174+ convert other = other
175+ collectArgs :: Int -> [Text] -> AST -> Maybe ([Text], [AST])
176+ collectArgs 1 acc (Function _ Nothing [oneArg] (Block _ il)) | length acc == n - 1 = Just (reverse (oneArg : acc), il)
177+ collectArgs m acc (Function _ Nothing [oneArg] (Block _ [Return _ ret])) = collectArgs (m - 1) (oneArg : acc) ret
178+ collectArgs _ _ _ = Nothing
179+
180+ isNFn :: Text -> Text -> Int -> AST -> Bool
181+ isNFn expectMod prefix n (Indexer _ (Var _ name) (Var _ modName)) | modName == expectMod =
182+ name == fromString (T.unpack prefix <> show n)
183+ isNFn _ _ _ _ = False
184+
185+ runFn :: Int -> AST -> AST
186+ runFn = runFn' C.dataFunctionUncurried C.runFn (\ss f args ->
187+ let len = length args
188+ typ = mkString $ uncurriedFnType len in
189+ if len > 0
190+ then App ss (App Nothing (StringLiteral Nothing typ) [f]) args
191+ else App ss f args)
192+ runEffFn :: Text -> Text -> Int -> AST -> AST
193+ runEffFn modName fnName = runFn' modName fnName $ \ss fn acc ->
194+ let typ = mkString . uncurriedFnType $ length acc in
195+ Function ss Nothing [] (Block ss [Return ss (App ss (App Nothing (StringLiteral Nothing typ) [fn]) acc)])
196+
197+ runFn' :: Text -> Text -> (Maybe SourceSpan -> AST -> [AST] -> AST) -> Int -> AST -> AST
198+ runFn' modName runFnName res n = convert where
199+ convert :: AST -> AST
200+ convert il = fromMaybe il $ go n [] il
201+
202+ go :: Int -> [AST] -> AST -> Maybe AST
203+ go 0 acc (App ss runFnN [fn]) | isNFn modName runFnName n runFnN && length acc == n =
204+ Just $ res ss fn acc
205+ go m acc (App _ lhs [arg]) = go (m - 1) (arg : acc) lhs
206+ go _ _ _ = Nothing
207+
208+ inlineNonClassFunction :: (AST -> Bool) -> (AST -> AST -> AST) -> AST -> AST
209+ inlineNonClassFunction p f = convert where
210+ convert :: AST -> AST
211+ convert (App _ (App _ op' [x]) [y]) | p op' = f x y
212+ convert other = other
213+
214+ inlineUnsafeIndex :: (AST -> Bool) -> (AST -> AST -> AST) -> AST -> AST
215+ inlineUnsafeIndex p _ = convert where
216+ convert :: AST -> AST
217+ convert (App _ (App ss op' [x]) [y@NumericLiteral{}])
218+ | p op' = Indexer ss y x
219+ convert (App _ (App ss op' [x]) [y])
220+ | p op' = App ss (Var Nothing indexFn) [x, y]
221+ convert other = other
222+
223+ isModFn :: (Text, PSString) -> AST -> Bool
224+ isModFn (m, op) (Indexer _ (Var _ op') (Var _ m')) =
225+ m == m' && decodeString op == Just op'
226+ isModFn _ _ = False
227+
228+ isModFnWithDict :: (Text, PSString) -> AST -> Bool
229+ isModFnWithDict (m, op) (App _ (Indexer _ (Var _ op') (Var _ m')) [Var _ _]) =
230+ m == m' && decodeString op == Just op'
231+ isModFnWithDict _ _ = False
232+
233+-- (f <<< g $ x) = f (g x)
234+-- (f <<< g) = \x -> f (g x)
235+inlineFnComposition :: forall m. MonadSupply m => AST -> m AST
236+inlineFnComposition = everywhereTopDownM convert where
237+ convert :: AST -> m AST
238+ convert (App s1 (App s2 (App _ (App _ fn [dict']) [x]) [y]) [z])
239+ | isFnCompose dict' fn = return $ App s1 x [App s2 y [z]]
240+ | isFnComposeFlipped dict' fn = return $ App s2 y [App s1 x [z]]
241+ convert app@(App ss (App _ (App _ fn [dict']) _) _)
242+ | isFnCompose dict' fn || isFnComposeFlipped dict' fn = mkApps ss <$> goApps app <*> freshName'
243+ convert other = return other
244+
245+ mkApps :: Maybe SourceSpan -> [Either AST (Text, AST)] -> Text -> AST
246+ mkApps ss fns a = App ss (Function ss Nothing [] (Block ss $ vars <> [Return Nothing comp])) []
247+ where
248+ vars = uncurry (VariableIntroduction ss) . fmap Just <$> rights fns
249+ comp = Function ss Nothing [a] (Block ss [Return Nothing apps])
250+ apps = foldr (\fn acc -> App ss (mkApp fn) [acc]) (Var ss a) fns
251+
252+ mkApp :: Either AST (Text, AST) -> AST
253+ mkApp = either id $ \(name, arg) -> Var (getSourceSpan arg) name
254+
255+ goApps :: AST -> m [Either AST (Text, AST)]
256+ goApps (App _ (App _ (App _ fn [dict']) [x]) [y])
257+ | isFnCompose dict' fn = mappend <$> goApps x <*> goApps y
258+ | isFnComposeFlipped dict' fn = mappend <$> goApps y <*> goApps x
259+ goApps app@(App {}) = pure . Right . (,app) <$> freshName'
260+ goApps other = pure [Left other]
261+
262+ isFnCompose :: AST -> AST -> Bool
263+ isFnCompose dict' fn = isDict semigroupoidFn dict' && isDict fnCompose fn
264+
265+ isFnComposeFlipped :: AST -> AST -> Bool
266+ isFnComposeFlipped dict' fn = isDict semigroupoidFn dict' && isDict fnComposeFlipped fn
267+
268+ fnCompose :: forall a b. (IsString a, IsString b) => (a, b)
269+ fnCompose = (C.controlSemigroupoid, C.compose)
270+
271+ fnComposeFlipped :: forall a b. (IsString a, IsString b) => (a, b)
272+ fnComposeFlipped = (C.controlSemigroupoid, C.composeFlipped)
273+
274+inlineUnsafeCoerce :: AST -> AST
275+inlineUnsafeCoerce = everywhereTopDown convert where
276+ convert (App _ (Indexer _ (Var _ unsafeCoerceFn) (Var _ unsafeCoerce)) [ comp ])
277+ | unsafeCoerceFn == C.unsafeCoerceFn && unsafeCoerce == C.unsafeCoerce
278+ = comp
279+ convert other = other
280+
281+inlineUnsafePartial :: AST -> AST
282+inlineUnsafePartial = everywhereTopDown convert where
283+ convert (App ss fn [ comp ])
284+ | isDict fnUnsafePartial fn
285+ = App ss comp []
286+ where
287+ fnUnsafePartial :: forall a b. (IsString a, IsString b) => (a, b)
288+ fnUnsafePartial = (C.partialUnsafe, C.unsafePartial)
289+ convert other = other
290+
291+semiringNumber :: forall a b. (IsString a, IsString b) => (a, b)
292+semiringNumber = (C.dataSemiring, C.semiringNumber)
293+
294+semiringInt :: forall a b. (IsString a, IsString b) => (a, b)
295+semiringInt = (C.dataSemiring, C.semiringInt)
296+
297+ringNumber :: forall a b. (IsString a, IsString b) => (a, b)
298+ringNumber = (C.dataRing, C.ringNumber)
299+
300+ringInt :: forall a b. (IsString a, IsString b) => (a, b)
301+ringInt = (C.dataRing, C.ringInt)
302+
303+euclideanRingNumber :: forall a b. (IsString a, IsString b) => (a, b)
304+euclideanRingNumber = (C.dataEuclideanRing, C.euclideanRingNumber)
305+
306+-- eqNumber :: forall a b. (IsString a, IsString b) => (a, b)
307+-- eqNumber = (C.dataEq, C.eqNumber)
308+
309+eqInt :: forall a b. (IsString a, IsString b) => (a, b)
310+eqInt = (C.dataEq, C.eqInt)
311+
312+eqString :: forall a b. (IsString a, IsString b) => (a, b)
313+eqString = (C.dataEq, C.eqString)
314+
315+eqChar :: forall a b. (IsString a, IsString b) => (a, b)
316+eqChar = (C.dataEq, C.eqChar)
317+
318+eqBoolean :: forall a b. (IsString a, IsString b) => (a, b)
319+eqBoolean = (C.dataEq, C.eqBoolean)
320+
321+ordBoolean :: forall a b. (IsString a, IsString b) => (a, b)
322+ordBoolean = (C.dataOrd, C.ordBoolean)
323+
324+ordNumber :: forall a b. (IsString a, IsString b) => (a, b)
325+ordNumber = (C.dataOrd, C.ordNumber)
326+
327+ordInt :: forall a b. (IsString a, IsString b) => (a, b)
328+ordInt = (C.dataOrd, C.ordInt)
329+
330+ordString :: forall a b. (IsString a, IsString b) => (a, b)
331+ordString = (C.dataOrd, C.ordString)
332+
333+ordChar :: forall a b. (IsString a, IsString b) => (a, b)
334+ordChar = (C.dataOrd, C.ordChar)
335+
336+semigroupString :: forall a b. (IsString a, IsString b) => (a, b)
337+semigroupString = (C.dataSemigroup, C.semigroupString)
338+
339+boundedBoolean :: forall a b. (IsString a, IsString b) => (a, b)
340+boundedBoolean = (C.dataBounded, C.boundedBoolean)
341+
342+heytingAlgebraBoolean :: forall a b. (IsString a, IsString b) => (a, b)
343+heytingAlgebraBoolean = (C.dataHeytingAlgebra, C.heytingAlgebraBoolean)
344+
345+semigroupoidFn :: forall a b. (IsString a, IsString b) => (a, b)
346+semigroupoidFn = (C.controlSemigroupoid, C.semigroupoidFn)
347+
348+opAdd :: forall a b. (IsString a, IsString b) => (a, b)
349+opAdd = (C.dataSemiring, C.add)
350+
351+opMul :: forall a b. (IsString a, IsString b) => (a, b)
352+opMul = (C.dataSemiring, C.mul)
353+
354+opEq :: forall a b. (IsString a, IsString b) => (a, b)
355+opEq = (C.dataEq, C.eq)
356+
357+opNotEq :: forall a b. (IsString a, IsString b) => (a, b)
358+opNotEq = (C.dataEq, C.notEq)
359+
360+opLessThan :: forall a b. (IsString a, IsString b) => (a, b)
361+opLessThan = (C.dataOrd, C.lessThan)
362+
363+opLessThanOrEq :: forall a b. (IsString a, IsString b) => (a, b)
364+opLessThanOrEq = (C.dataOrd, C.lessThanOrEq)
365+
366+opGreaterThan :: forall a b. (IsString a, IsString b) => (a, b)
367+opGreaterThan = (C.dataOrd, C.greaterThan)
368+
369+opGreaterThanOrEq :: forall a b. (IsString a, IsString b) => (a, b)
370+opGreaterThanOrEq = (C.dataOrd, C.greaterThanOrEq)
371+
372+opAppend :: forall a b. (IsString a, IsString b) => (a, b)
373+opAppend = (C.dataSemigroup, C.append)
374+
375+opSub :: forall a b. (IsString a, IsString b) => (a, b)
376+opSub = (C.dataRing, C.sub)
377+
378+opNegate :: forall a b. (IsString a, IsString b) => (a, b)
379+opNegate = (C.dataRing, C.negate)
380+
381+opDiv :: forall a b. (IsString a, IsString b) => (a, b)
382+opDiv = (C.dataEuclideanRing, C.div)
383+
384+opConj :: forall a b. (IsString a, IsString b) => (a, b)
385+opConj = (C.dataHeytingAlgebra, C.conj)
386+
387+opDisj :: forall a b. (IsString a, IsString b) => (a, b)
388+opDisj = (C.dataHeytingAlgebra, C.disj)
389+
390+opNot :: forall a b. (IsString a, IsString b) => (a, b)
391+opNot = (C.dataHeytingAlgebra, C.not)
392+
393+unbox :: AST -> PSString -> AST
394+unbox e d = select . inlineCommonValues $ inlineCommonOperators e
395+ where
396+ select :: AST -> AST
397+ select e' =
398+ case e' of
399+ Var{} -> unbox' e'
400+ App{} -> unbox' e'
401+ Indexer{} -> unbox' e'
402+ _ -> e'
403+ unbox' :: AST -> AST
404+ unbox' e' = maybe e' (\t -> App Nothing (StringLiteral Nothing t) [e']) $ unboxType d
405+
406+unboxType :: PSString -> Maybe PSString
407+unboxType s = do
408+ t <- decodeString s
409+ t' <- unboxType' t
410+ return $ mkString t'
411+ where
412+ unboxType' :: Text -> Maybe Text
413+ unboxType' t
414+ | t == C.eqInt ||
415+ t == C.semiringInt ||
416+ t == C.ringInt ||
417+ t == C.ordInt ||
418+ t == C.dataIntBits
419+ = Just int
420+ | t == C.semiringNumber ||
421+ t == C.ringNumber ||
422+ t == C.ordNumber ||
423+ t == C.euclideanRingNumber
424+ = Just float
425+ | t == C.eqBoolean ||
426+ t == C.ordBoolean ||
427+ t == C.heytingAlgebraBoolean
428+ = Just bool
429+ | t == C.eqChar ||
430+ t == C.eqString ||
431+ t == C.ordChar ||
432+ t == C.ordString ||
433+ t == C.semigroupString
434+ = Just string
435+ | otherwise = Nothing
src/CodeGen/IL/Optimizer/MagicDo.hsnew file+146
@@ -0,0 +1,146 @@
1+-- | This module implements the "Magic Do" optimization, which inlines calls to return
2+-- and bind for the Eff monad, as well as some of its actions.
3+module CodeGen.IL.Optimizer.MagicDo (magicDoEffect, magicDoEff, magicDoST, inlineST) where
4+
5+import Prelude.Compat
6+import Protolude (ordNub)
7+
8+import Data.Maybe (fromJust, isJust)
9+import Data.Text (Text)
10+
11+import Language.PureScript.CoreImp.AST
12+import Language.PureScript.CoreImp.Optimizer.Common hiding (isDict)
13+import Language.PureScript.PSString (PSString, decodeString, mkString)
14+import qualified Language.PureScript.Constants as C
15+
16+import CodeGen.IL.Common (undefinedName, unusedName)
17+import CodeGen.IL.Optimizer.Common
18+
19+-- | Inline type class dictionaries for >>= and return for the Eff monad
20+--
21+-- E.g.
22+--
23+-- Prelude[">>="](dict)(m1)(function(x) {
24+-- return ...;
25+-- })
26+--
27+-- becomes
28+--
29+-- function __do {
30+-- var x = m1();
31+-- ...
32+-- }
33+magicDoEff :: AST -> AST
34+magicDoEff = magicDo C.eff C.effDictionaries
35+
36+magicDoEffect :: AST -> AST
37+magicDoEffect = magicDo C.effect C.effectDictionaries
38+
39+magicDoST :: AST -> AST
40+magicDoST = magicDo C.st C.stDictionaries
41+
42+magicDo :: Text -> C.EffectDictionaries -> AST -> AST
43+magicDo effectModule C.EffectDictionaries{..} = everywhereTopDown convert
44+ where
45+ -- Desugar monomorphic calls to >>= and return for the Eff monad
46+ convert :: AST -> AST
47+ -- Desugar pure
48+ convert (App _ (App _ pure' [val]) []) | isPure pure' = val
49+ -- Desugar discard
50+ convert (App _ (App _ bind [m]) [Function s1 Nothing [unused] (Block s2 il)]) | isDiscard bind && unused == unusedName =
51+ Function s1 Nothing [] $ Block s2 (App s2 m [] : map applyReturns il )
52+ -- Desugar bind
53+ convert (App _ (App _ bind [m]) [Function s1 Nothing [arg] (Block s2 il)]) | isBind bind =
54+ Function s1 Nothing [] $ Block s2 (VariableIntroduction s2 arg (Just (App s2 m [])) : map applyReturns il)
55+ -- Desugar untilE
56+ convert (App s1 (App _ f [arg]) []) | isEffFunc edUntil f =
57+ App s1 (Function s1 Nothing [] (Block s1 [ While s1 (Unary s1 Not (App s1 arg [])) (Block s1 []), Return s1 $ ObjectLiteral s1 []])) []
58+ -- Desugar whileE
59+ convert (App _ (App _ (App s1 f [arg1]) [arg2]) []) | isEffFunc edWhile f =
60+ App s1 (Function s1 Nothing [] (Block s1 [ While s1 (App s1 arg1 []) (Block s1 [ App s1 arg2 [] ]), Return s1 $ ObjectLiteral s1 []])) []
61+ -- -- Inline __do returns
62+ -- convert (Return _ (App _ (Function _ (Just ident) [] body) [])) | ident == fnName = body
63+ -- Inline double applications
64+ convert (App _ (App s1 (Function s2 Nothing [] (Block ss body)) []) []) =
65+ App s1 (Function s2 Nothing [] (Block ss (applyReturns `fmap` body))) []
66+ convert other = other
67+ -- Check if an expression represents a monomorphic call to >>= for the Eff monad
68+ isBind (App _ fn [dict]) | isDict (effectModule, edBindDict) dict && isBindPoly fn = True
69+ isBind _ = False
70+ -- Check if an expression represents a call to @discard@
71+ isDiscard (App _ (App _ fn [dict1]) [dict2])
72+ | isDict (C.controlBind, C.discardUnitDictionary) dict1 &&
73+ isDict (effectModule, edBindDict) dict2 &&
74+ isDiscardPoly fn = True
75+ isDiscard _ = False
76+
77+ -- Check if an expression represents a monomorphic call to pure or return for the Eff applicative
78+ isPure (App _ fn [dict]) | isDict (effectModule, edApplicativeDict) dict && isPurePoly fn = True
79+ isPure _ = False
80+ -- Check if an expression represents the polymorphic >>= function
81+ isBindPoly = isDict (C.controlBind, C.bind)
82+ -- Check if an expression represents the polymorphic pure function
83+ isPurePoly = isDict (C.controlApplicative, C.pure')
84+ -- Check if an expression represents the polymorphic discard function
85+ isDiscardPoly = isDict (C.controlBind, C.discard)
86+ -- Check if an expression represents a function in the Effect module
87+ isEffFunc name (Indexer _ (StringLiteral _ name') (Var _ eff)) = eff == effectModule && name == name'
88+ isEffFunc _ _ = False
89+
90+ applyReturns :: AST -> AST
91+ applyReturns (Return ss ret) = Return ss (App ss ret [])
92+ applyReturns (Block ss ils) = Block ss (map applyReturns ils)
93+ applyReturns (While ss cond il) = While ss cond (applyReturns il)
94+ applyReturns (For ss v lo hi il) = For ss v lo hi (applyReturns il)
95+ applyReturns (ForIn ss v xs il) = ForIn ss v xs (applyReturns il)
96+ applyReturns (IfElse ss cond t f) = IfElse ss cond (applyReturns t) (applyReturns `fmap` f)
97+ applyReturns other = other
98+
99+-- | Inline functions in the ST module
100+inlineST :: AST -> AST
101+inlineST = everywhere convertBlock
102+ where
103+ -- Look for runST blocks and inline the STRefs there.
104+ -- If all STRefs are used in the scope of the same runST, only using { read, write, modify }STRef then
105+ -- we can be more aggressive about inlining, and actually turn STRefs into local variables.
106+ convertBlock (App s1 f [arg]) | isSTFunc C.runST f =
107+ let refs = ordNub . findSTRefsIn $ arg
108+ usages = findAllSTUsagesIn arg
109+ allUsagesAreLocalVars = all (\u -> let v = toVar u in isJust v && fromJust v `elem` refs) usages
110+ localVarsDoNotEscape = all (\r -> length (r `appearingIn` arg) == length (filter (\u -> let v = toVar u in v == Just r) usages)) refs
111+ in App s1 (everywhere (convert (allUsagesAreLocalVars && localVarsDoNotEscape)) arg) []
112+ convertBlock other = other
113+ -- Convert a block in a safe way, preserving object wrappers of references,
114+ -- or in a more aggressive way, turning wrappers into local variables depending on the
115+ -- agg(ressive) parameter.
116+ convert agg (App s1 f [arg]) | isSTFunc C.newSTRef f =
117+ Function s1 Nothing [] (Block s1 [Return s1 $ if agg then arg else ObjectLiteral s1 [(mkString C.stRefValue, arg)]])
118+ convert agg (App _ (App s1 f [ref]) []) | isSTFunc C.readSTRef f =
119+ if agg then ref else Indexer s1 (StringLiteral s1 C.stRefValue) ref
120+ convert agg (App _ (App _ (App s1 f [arg]) [ref]) []) | isSTFunc C.writeSTRef f =
121+ if agg then Assignment s1 ref arg else Assignment s1 (Indexer s1 (StringLiteral s1 C.stRefValue) ref) arg
122+ convert agg (App _ (App _ (App s1 f [func]) [ref]) []) | isSTFunc C.modifySTRef f =
123+ if agg then Assignment s1 ref (App s1 func [ref]) else Assignment s1 (Indexer s1 (StringLiteral s1 C.stRefValue) ref) (App s1 func [Indexer s1 (StringLiteral s1 C.stRefValue) ref])
124+ convert _ other = other
125+ -- Check if an expression represents a function in the ST module
126+ isSTFunc name (Indexer _ (StringLiteral _ name') (Var _ st)) = st == C.st && name == name'
127+ isSTFunc _ _ = False
128+ -- Find all ST Refs initialized in this block
129+ findSTRefsIn = everything (++) isSTRef
130+ where
131+ isSTRef (VariableIntroduction _ ident (Just (App _ (App _ f [_]) []))) | isSTFunc C.newSTRef f = [ident]
132+ isSTRef _ = []
133+ -- Find all STRefs used as arguments to readSTRef, writeSTRef, modifySTRef
134+ findAllSTUsagesIn = everything (++) isSTUsage
135+ where
136+ isSTUsage (App _ (App _ f [ref]) []) | isSTFunc C.readSTRef f = [ref]
137+ isSTUsage (App _ (App _ (App _ f [_]) [ref]) []) | isSTFunc C.writeSTRef f || isSTFunc C.modifySTRef f = [ref]
138+ isSTUsage _ = []
139+ -- Find all uses of a variable
140+ appearingIn ref = everything (++) isVar
141+ where
142+ isVar e@(Var _ v) | v == ref = [e]
143+ isVar _ = []
144+ -- Convert a AST value to a String if it is a Var
145+ toVar (Var _ v) = Just v
146+ toVar _ = Nothing
src/CodeGen/IL/Optimizer/TCO.hsnew file+141
@@ -0,0 +1,141 @@
1+module CodeGen.IL.Optimizer.TCO (tco, tcoLoop) where
2+
3+import Prelude.Compat
4+
5+import Data.Text (Text)
6+import Data.Monoid ((<>))
7+import Language.PureScript.CoreImp.AST
8+import Language.PureScript.AST.SourcePos (SourceSpan)
9+import Safe (headDef, tailSafe)
10+import CodeGen.IL.Common
11+
12+import qualified Language.PureScript.Constants as C
13+
14+tcoLoop :: Text
15+tcoLoop = "ṩtco_loop"
16+
17+tco :: AST -> AST -> AST
18+tco mn = everywhere convert where
19+ tcoVar :: Text -> Text
20+ tcoVar arg = "ṩtco_var_" <> arg
21+
22+ copyVar :: Text -> Text
23+ copyVar arg = "ṩcopy_" <> arg
24+
25+ tcoDone :: Text
26+ tcoDone = "ṩtco_done"
27+
28+ tcoResult :: Text
29+ tcoResult = "ṩtco_result"
30+
31+ convert :: AST -> AST
32+ convert fn@(Function ss (Just name) args _)
33+ | isTailRecursive name body'
34+ = replace (toLoop name outerArgs innerArgs body')
35+ where
36+ innerArgs = headDef [] argss
37+ outerArgs = concat . reverse $ tailSafe argss
38+ (argss, body', replace) = collectAllFunctionArgs [] id fn
39+ convert (Assignment ss (Var _ name) fn@(Function _ Nothing _ _))
40+ | isTailRecursive name body'
41+ = Assignment ss (Var ss name) (replace (toLoop name outerArgs innerArgs body'))
42+ where
43+ innerArgs = headDef [] argss
44+ outerArgs = concat . reverse $ tailSafe argss
45+ (argss, body', replace) = collectAllFunctionArgs [] id fn
46+ convert js = js
47+
48+ collectAllFunctionArgs :: [[Text]] -> (AST -> AST) -> AST -> ([[Text]], AST, AST -> AST)
49+ collectAllFunctionArgs allArgs f (Function s1 ident args (Block s2 (body@(Return _ _):_))) =
50+ collectAllFunctionArgs (args : allArgs) (\b -> f (Function s1 ident (map copyVar args) (Block s2 [b]))) body
51+ collectAllFunctionArgs allArgs f (Function ss ident args body@(Block _ _)) =
52+ (args : allArgs, body, f . Function ss ident (map copyVar args))
53+ collectAllFunctionArgs allArgs f (Return s1 (Function s2 ident args (Block s3 [body]))) =
54+ collectAllFunctionArgs (args : allArgs) (\b -> f (Return s1 (Function s2 ident (map copyVar args) (Block s3 [b])))) body
55+ collectAllFunctionArgs allArgs f (Return s1 (Function s2 ident args body@(Block _ _))) =
56+ (args : allArgs, body, f . Return s1 . Function s2 ident (map copyVar args))
57+ collectAllFunctionArgs allArgs f body = (allArgs, body, f)
58+
59+ isTailRecursive :: Text -> AST -> Bool
60+ isTailRecursive ident js = countSelfReferences js > 0 && allInTailPosition js where
61+ countSelfReferences = everything (+) match where
62+ match :: AST -> Int
63+ match (Var _ ident') | ident == ident' = 1
64+ match _ = 0
65+
66+ allInTailPosition (Return _ expr)
67+ | isSelfCall ident expr = countSelfReferences expr == 1
68+ | otherwise = countSelfReferences expr == 0
69+ allInTailPosition (While _ js1 body)
70+ = countSelfReferences js1 == 0 && allInTailPosition body
71+ allInTailPosition (For _ _ js1 js2 body)
72+ = countSelfReferences js1 == 0 && countSelfReferences js2 == 0 && allInTailPosition body
73+ allInTailPosition (ForIn _ _ js1 body)
74+ = countSelfReferences js1 == 0 && allInTailPosition body
75+ allInTailPosition (IfElse _ js1 body el)
76+ = countSelfReferences js1 == 0 && allInTailPosition body && all allInTailPosition el
77+ allInTailPosition (Block _ body)
78+ = all allInTailPosition body
79+ allInTailPosition (Throw _ js1)
80+ = countSelfReferences js1 == 0
81+ allInTailPosition (ReturnNoResult _)
82+ = True
83+ allInTailPosition (VariableIntroduction _ _ js1)
84+ = all ((== 0) . countSelfReferences) js1
85+ allInTailPosition (Assignment _ _ js1)
86+ = countSelfReferences js1 == 0
87+ allInTailPosition (Comment _ _ js1)
88+ = allInTailPosition js1
89+ allInTailPosition _
90+ = False
91+
92+ toLoop :: Text -> [Text] -> [Text] -> AST -> AST
93+ toLoop ident outerArgs innerArgs js =
94+ Block rootSS $
95+ concatMap (\arg -> [ VariableIntroduction rootSS (tcoVar arg) . Just $
96+ Var rootSS (copyVar arg) ]) (outerArgs ++ innerArgs) ++
97+ [ Assignment rootSS (Var rootSS $ "var " <> tcoDone) $ BooleanLiteral Nothing False
98+ , VariableIntroduction rootSS tcoResult Nothing
99+ , Assignment rootSS (Var rootSS $ "var " <> tcoLoop) (Function rootSS (Just tcoLoop) (outerArgs ++ innerArgs) (Block rootSS [loopify js]))
100+ , While rootSS (Unary Nothing Not (Var rootSS tcoDone))
101+ (Block rootSS
102+ [(Assignment rootSS (Var rootSS tcoResult) (App rootSS (Var rootSS tcoLoop) ((map (Var rootSS . tcoVar) outerArgs) ++ (map (Var rootSS . copyVar) innerArgs))))])
103+ , Return rootSS (Var rootSS tcoResult)
104+ ]
105+ where
106+ rootSS = Nothing
107+
108+ loopify :: AST -> AST
109+ loopify (Return ss ret)
110+ | isSelfCall ident ret =
111+ let
112+ allArgumentValues = concat $ collectArgs [] ret
113+ in
114+ Block ss $
115+ zipWith (\val arg ->
116+ Assignment ss (Var ss (tcoVar arg)) val) allArgumentValues outerArgs
117+ ++ zipWith (\val arg ->
118+ Assignment ss (Var ss (copyVar arg)) val) (drop (length outerArgs) allArgumentValues) innerArgs
119+ ++ [ ReturnNoResult ss ]
120+ | otherwise = Block ss [ markDone ss, Return ss ret ]
121+ loopify (ReturnNoResult ss) = Block ss [ markDone ss, ReturnNoResult ss ]
122+ loopify (While ss cond body) = While ss cond (loopify body)
123+ loopify (For ss i js1 js2 body) = For ss i js1 js2 (loopify body)
124+ loopify (ForIn ss i js1 body) = ForIn ss i js1 (loopify body)
125+ loopify (IfElse ss cond body el) = IfElse ss cond (loopify body) (fmap loopify el)
126+ loopify (Block ss body) = Block ss (map loopify body)
127+ loopify other = other
128+
129+ markDone :: Maybe SourceSpan -> AST
130+ markDone ss = Assignment ss (Var ss tcoDone) (BooleanLiteral ss True)
131+
132+ collectArgs :: [[AST]] -> AST -> [[AST]]
133+ collectArgs acc (App _ fn args') = collectArgs (args' : acc) fn
134+ collectArgs acc _ = acc
135+
136+ isSelfCall :: Text -> AST -> Bool
137+ isSelfCall ident (App _ (Var _ ident') _) = ident == ident'
138+ isSelfCall ident (App _ (Indexer _ (Var _ ident') (Var _ mn')) _) = mn' == "" && ident == ident'
139+ isSelfCall ident (App _ (Indexer _ (Var _ ident') mn') _) = mn' == mn && ident == ident'
140+ isSelfCall ident (App _ fn _) = isSelfCall ident fn
141+ isSelfCall _ _ = False
src/CodeGen/IL/Printer.hsnew file+527
@@ -0,0 +1,527 @@
1+-- | Pretty printer for the AST
2+module CodeGen.IL.Printer
3+ ( prettyPrintIL
4+ , prettyPrintIL1
5+ , prettyPrintILWithSourceMaps
6+ , interfaceSource
7+ , implHeaderSource
8+ , implFooterSource
9+ , isLiteral
10+ , modLabel
11+ , modPrefix
12+ , ffiLoader
13+ ) where
14+
15+import Prelude.Compat
16+
17+import Control.Arrow ((<+>))
18+import Control.Monad (forM, mzero)
19+import Control.Monad.State (StateT, evalStateT)
20+import Control.PatternArrows
21+import Data.List (filter, (\\))
22+import qualified Control.Arrow as A
23+
24+import Data.Maybe (fromMaybe)
25+import Data.Monoid ((<>))
26+import Data.Text (Text)
27+import qualified Data.Text as T
28+
29+import Language.PureScript.AST (SourceSpan(..))
30+import Language.PureScript.CoreImp.AST
31+import Language.PureScript.Comments
32+import Language.PureScript.Crash
33+import Language.PureScript.Names (Ident, runIdent)
34+import Language.PureScript.Pretty.Common
35+import Language.PureScript.PSString (PSString, decodeString, mkString)
36+
37+import CodeGen.IL.Common
38+import CodeGen.IL.Optimizer.TCO (tcoLoop)
39+
40+import qualified Language.PureScript.Constants as C
41+
42+-- TODO (Christoph): Get rid of T.unpack / pack
43+
44+literals :: (Emit gen) => Pattern PrinterState AST gen
45+literals = mkPattern' match'
46+ where
47+ match' :: (Emit gen) => AST -> StateT PrinterState Maybe gen
48+ match' il = (addMapping' (getSourceSpan il) <>) <$> match il
49+
50+ match :: (Emit gen) => AST -> StateT PrinterState Maybe gen
51+ match (NumericLiteral _ n) = return $ emit $ T.pack $ either show show n
52+ match (StringLiteral _ s) = return $ emit $ stringLiteral s
53+ match (BooleanLiteral _ True) = return $ emit "true"
54+ match (BooleanLiteral _ False) = return $ emit "false"
55+ match (ArrayLiteral _ xs) = mconcat <$> sequence
56+ [ return . emit $ arrayType <> "{"
57+ , intercalate (emit ", ") <$> forM xs prettyPrintIL'
58+ , return $ emit "}"
59+ ]
60+ -- match (ObjectLiteral _ []) = return $ emit "std::initializer_list<std::pair<const string, boxed>>{}"
61+ match (ObjectLiteral _ ps) = mconcat <$> sequence
62+ [ return . emit $ dictType <> "{"
63+ , withIndent $ do
64+ ils <- forM ps $ \(key, value) -> do
65+ value' <- prettyPrintIL' value
66+ return $ objectPropertyToString key <> value'
67+ return $ intercalate (emit " ") $ map (<> emit ",") ils
68+ , return $ emit "}"
69+ ]
70+ where
71+ objectPropertyToString :: (Emit gen) => PSString -> gen
72+ objectPropertyToString s = emit $ stringLiteral s <> ": "
73+ match (Block _ sts) = mconcat <$> sequence
74+ [ return $ emit "{\n"
75+ , withIndent $ prettyStatements sts
76+ , return $ emit "\n"
77+ , currentIndent
78+ , return $ emit "}"
79+ ]
80+ match (Var _ ident) | ident == C.undefined = return $ emit undefinedName
81+ match (Var _ ident) = return $ emit ident
82+ match (VariableIntroduction _ ident value) = mconcat <$> sequence
83+ [ return . emit $ varDecl <> " " <> ident <> " " <> anyType
84+ , maybe (return mempty) (fmap (emit " = " <>) . prettyPrintIL') value
85+ ]
86+ match (Assignment _ target value) = mconcat <$> sequence
87+ [ prettyPrintIL' target
88+ , return $ emit " = "
89+ , prettyPrintIL' value
90+ ]
91+ match (App _ val []) = mconcat <$> sequence
92+ [ return $ emit "Run("
93+ , prettyPrintIL' val
94+ , return $ emit ")"
95+ ]
96+ match (App _ (StringLiteral _ u) [arg])
97+ | Just ty <- decodeString u = mconcat <$> sequence
98+ [ prettyPrintIL' arg
99+ , return $ emit ".("
100+ , return $ emit ty
101+ , return $ emit ")"
102+ ]
103+ match (App _ (Var _ fn) [arg]) | fn == arrayLengthFn = mconcat <$> sequence
104+ [ return $ emit fn
105+ , return $ emit "("
106+ , prettyPrintIL' arg
107+ , return $ emit ")"
108+ ]
109+ match (App _ (Var _ fn) args) | fn == indexFn = mconcat <$> sequence
110+ [ return $ emit fn
111+ , return $ emit "("
112+ , intercalate (emit ", ") <$> forM args prettyPrintIL'
113+ , return $ emit ")"
114+ ]
115+ match (App _ (Var _ fn) args) | fn == tcoLoop = mconcat <$> sequence
116+ [ return $ emit fn
117+ , return $ emit "("
118+ , intercalate (emit ", ") <$> forM args prettyPrintIL'
119+ , return $ emit ")"
120+ ]
121+ match (App _ (App Nothing (StringLiteral Nothing fnx) [fn@Function{}]) args)
122+ | Just ftype <- decodeString fnx
123+ , "Fn" `T.isPrefixOf` ftype = mconcat <$> sequence
124+ [ prettyPrintIL' fn
125+ , return $ emit "("
126+ , intercalate (emit ", ") <$> forM args prettyPrintIL'
127+ , return $ emit ")"
128+ ]
129+ match (App _ (App Nothing (StringLiteral Nothing fnx) [fn]) args)
130+ | Just ftype <- decodeString fnx
131+ , "Fn" `T.isPrefixOf` ftype = mconcat <$> sequence
132+ [ prettyPrintIL' fn
133+ , return $ emit ".("
134+ , return $ emit ftype
135+ , return $ emit ")("
136+ , intercalate (emit ", ") <$> forM args prettyPrintIL'
137+ , return $ emit ")"
138+ ]
139+ match app@(App{})
140+ | (val, args) <- unApp app []
141+ , length args > 1
142+ = mconcat <$> sequence
143+ [ return $ emit "Apply("
144+ , prettyPrintIL' val
145+ , return $ emit ", "
146+ , intercalate (emit ", ") <$> forM args prettyPrintIL'
147+ , return $ emit ")"
148+ ]
149+ match (App _ val args) = mconcat <$> sequence
150+ [ return $ emit "Apply("
151+ , prettyPrintIL' val
152+ , return $ emit ", "
153+ , intercalate (emit ", ") <$> forM args prettyPrintIL'
154+ , return $ emit ")"
155+ ]
156+ match (Function _ (Just name) [] (Block _ [Return _ ret]))
157+ | isComplexLiteral ret = mconcat <$> sequence
158+ [ return $ emit "\n"
159+ , return . emit $ varDecl <> " " <> initName name <> " Once\n"
160+ , prettyPrintIL' $ VariableIntroduction Nothing (valueName name) Nothing
161+ , return $ emit "\n\n"
162+ , return $ emit "func "
163+ , return . emit $ withPrefix name
164+ , return . emit $ "() " <> anyType <> " "
165+ , return $ emit "{\n"
166+ , withIndent $ do
167+ indentString <- currentIndent
168+ return $ indentString <> (emit $ initName name <> ".Do(func() {\n") <>
169+ indentString <> indentString <> (emit $ valueName name <> " = ")
170+ , withIndent $ do
171+ case ret of
172+ Function _ Nothing args body -> mconcat <$> sequence
173+ [ return $ emit "func("
174+ , return . emit $ intercalate ", " (renderArg anyType <$> args)
175+ , return . emit $ ") " <> anyType <> " "
176+ , prettyPrintIL' body
177+ ]
178+ _ -> do
179+ prettyPrintIL' ret
180+ , return $ emit "\n"
181+ , withIndent $ do
182+ indentString <- currentIndent
183+ return $ indentString <> (emit $ "})\n" <> "return " <> valueName name <>"\n")
184+ , return $ emit "}\n\n"
185+ ]
186+ match (Function _ (Just name) [] ret) = mconcat <$> sequence
187+ [ return $ emit "func "
188+ , return . emit $ withPrefix name
189+ , return . emit $ "() " <> anyType <> " "
190+ , prettyPrintIL' ret
191+ ]
192+ match (Function _ _ args ret) = mconcat <$> sequence
193+ [ return $ emit "func("
194+ , return . emit $ intercalate ", " (renderArg anyType <$> args)
195+ , return . emit $ ") " <> anyType <> " "
196+ , prettyPrintIL' ret
197+ ]
198+ match (Indexer _ (Var _ name) (Var _ "")) = mconcat <$> sequence
199+ [ prettyPrintIL' (Var Nothing $ withPrefix name)
200+ , return $ emit "()"
201+ ]
202+ match (Indexer _ (Var _ name) val) = mconcat <$> sequence
203+ [ prettyPrintIL' val
204+ , return $ emit "."
205+ , prettyPrintIL' (Var Nothing $ withPrefix name)
206+ , return $ emit "()"
207+ ]
208+ match (Indexer _ prop@StringLiteral{} val@ObjectLiteral{}) = mconcat <$> sequence
209+ [ prettyPrintIL' val
210+ , return $ emit "["
211+ , prettyPrintIL' prop
212+ , return $ emit "]"
213+ ]
214+ match (Indexer _ prop@StringLiteral{} val) = mconcat <$> sequence
215+ [ prettyPrintIL' val
216+ , return $ emit ".("
217+ , return $ emit dictType
218+ , return $ emit ")["
219+ , prettyPrintIL' prop
220+ , return $ emit "]"
221+ ]
222+ match (Indexer _ index val@ArrayLiteral{}) = mconcat <$> sequence
223+ [ prettyPrintIL' val
224+ , return $ emit "["
225+ , prettyPrintIL' index
226+ , return $ emit "]"
227+ ]
228+ match (Indexer _ index val) = mconcat <$> sequence
229+ [ prettyPrintIL' val
230+ , return $ emit ".("
231+ , return $ emit arrayType
232+ , return $ emit ")["
233+ , prettyPrintIL' index
234+ , return $ emit "]"
235+ ]
236+ match (InstanceOf _ val ty) = mconcat <$> sequence
237+ [ return $ emit "Is("
238+ , prettyPrintIL' val
239+ , return $ emit ", "
240+ , prettyPrintIL' ty
241+ , return $ emit ")"
242+ ]
243+ match (While _ cond sts) = mconcat <$> sequence
244+ [ return $ emit "for "
245+ , prettyPrintIL' cond
246+ , return $ emit " "
247+ , prettyPrintIL' sts
248+ ]
249+ match (For _ ident start end sts) = mconcat <$> sequence
250+ [ return $ emit $ "for var " <> ident <> " = "
251+ , prettyPrintIL' start
252+ , return $ emit $ "; " <> ident <> " < "
253+ , prettyPrintIL' end
254+ , return $ emit $ "; " <> ident <> "++ "
255+ , prettyPrintIL' sts
256+ ]
257+ match (ForIn _ ident obj sts) = mconcat <$> sequence
258+ [ return $ emit $ "for var " <> ident <> " in "
259+ , prettyPrintIL' obj
260+ , return $ emit " "
261+ , prettyPrintIL' sts
262+ ]
263+ match (IfElse _ (Binary _ EqualTo cond@Binary{} (BooleanLiteral Nothing True)) thens elses) = mconcat <$> sequence
264+ [ return $ emit "if "
265+ , prettyPrintIL' cond
266+ , return $ emit " "
267+ , prettyPrintIL' thens
268+ , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintIL') elses
269+ ]
270+ match (IfElse _ (Binary _ EqualTo cond@Binary{} (BooleanLiteral Nothing False)) thens elses) = mconcat <$> sequence
271+ [ return $ emit "if !("
272+ , prettyPrintIL' cond
273+ , return $ emit ") "
274+ , prettyPrintIL' thens
275+ , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintIL') elses
276+ ]
277+ match (IfElse _ cond thens elses) = mconcat <$> sequence
278+ [ return $ emit "if "
279+ , prettyPrintIL' cond
280+ , return $ emit " "
281+ , prettyPrintIL' thens
282+ , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintIL') elses
283+ ]
284+ match (Return _ value) = mconcat <$> sequence
285+ [ return $ emit "return "
286+ , prettyPrintIL' value
287+ ]
288+ match (ReturnNoResult _) = return . emit $ "return " <> undefinedName
289+ -- match (Throw _ _) = return mempty
290+ match (Throw _ value) = mconcat <$> sequence
291+ [ return $ emit "panic("
292+ , prettyPrintIL' value
293+ , return $ emit ")"
294+ ]
295+ match (Comment _ com il) = mconcat <$> sequence
296+ [ return $ emit "\n"
297+ , mconcat <$> forM com comment
298+ , prettyPrintIL' il
299+ ]
300+ match _ = mzero
301+
302+ comment :: (Emit gen) => Comment -> StateT PrinterState Maybe gen
303+ comment (LineComment com) = fmap mconcat $ sequence $
304+ [ currentIndent
305+ , return $ emit "//" <> emit com <> emit "\n"
306+ ]
307+ comment (BlockComment com) = fmap mconcat $ sequence $
308+ [ currentIndent
309+ , return $ emit "/**\n"
310+ ] ++
311+ map asLine (T.lines com) ++
312+ [ currentIndent
313+ , return $ emit " */\n"
314+ , currentIndent
315+ ]
316+ where
317+ asLine :: (Emit gen) => Text -> StateT PrinterState Maybe gen
318+ asLine s = do
319+ i <- currentIndent
320+ return $ i <> emit " * " <> (emit . removeComments) s <> emit "\n"
321+
322+ removeComments :: Text -> Text
323+ removeComments t =
324+ case T.stripPrefix "*/" t of
325+ Just rest -> removeComments rest
326+ Nothing -> case T.uncons t of
327+ Just (x, xs) -> x `T.cons` removeComments xs
328+ Nothing -> ""
329+
330+unary' :: (Emit gen) => UnaryOperator -> (AST -> Text) -> Operator PrinterState AST gen
331+unary' op mkStr = Wrap match (<>)
332+ where
333+ match :: (Emit gen) => Pattern PrinterState AST (gen, AST)
334+ match = mkPattern match'
335+ where
336+ match' (Unary _ op' val) | op' == op = Just (emit $ mkStr val, val)
337+ match' _ = Nothing
338+
339+unary :: (Emit gen) => UnaryOperator -> Text -> Operator PrinterState AST gen
340+unary op str = unary' op (const str)
341+
342+negateOperator :: (Emit gen) => Operator PrinterState AST gen
343+negateOperator = unary' Negate (\v -> if isNegate v then "- " else "-")
344+ where
345+ isNegate (Unary _ Negate _) = True
346+ isNegate _ = False
347+
348+binary :: (Emit gen) => BinaryOperator -> Text -> Operator PrinterState AST gen
349+binary op str = AssocL match (\v1 v2 -> v1 <> emit (" " <> str <> " ") <> v2)
350+ where
351+ match :: Pattern PrinterState AST (AST, AST)
352+ match = mkPattern match'
353+ where
354+ match' (Binary _ op' v1 v2) | op' == op = Just (v1, v2)
355+ match' _ = Nothing
356+
357+isLiteral :: AST -> Bool
358+isLiteral Function{} = True
359+isLiteral NumericLiteral{} = True
360+isLiteral StringLiteral{} = True
361+isLiteral BooleanLiteral{} = True
362+isLiteral ObjectLiteral{} = True
363+isLiteral ArrayLiteral{} = True
364+isLiteral _ = False
365+
366+isComplexLiteral :: AST -> Bool
367+-- isComplexLiteral Function{} = True
368+isComplexLiteral ObjectLiteral{} = True
369+isComplexLiteral ArrayLiteral{} = True
370+isComplexLiteral _ = False
371+
372+unApp :: AST -> [AST] -> (AST, [AST])
373+unApp (App _ val [arg]) args = unApp val (arg : args)
374+unApp other args = (other, args)
375+
376+prettyStatements :: (Emit gen) => [AST] -> StateT PrinterState Maybe gen
377+prettyStatements sts = do
378+ ils <- forM sts prettyPrintIL'
379+ indentString <- currentIndent
380+ return $ intercalate (emit "\n") $ map (indentString <>) ils
381+
382+-- | Generate a pretty-printed string representing a collection of C++ expressions at the same indentation level
383+prettyPrintILWithSourceMaps :: [AST] -> (Text, [SMap])
384+prettyPrintILWithSourceMaps il =
385+ let StrPos (_, s, mp) = (fromMaybe (internalError "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyStatements) il
386+ in (s, mp)
387+
388+prettyPrintIL :: [AST] -> Text
389+prettyPrintIL = maybe (internalError "Incomplete pattern") runPlainString . flip evalStateT (PrinterState 0) . prettyStatements
390+
391+-- | Generate an indented, pretty-printed string representing a C++ expression
392+prettyPrintIL' :: (Emit gen) => AST -> StateT PrinterState Maybe gen
393+prettyPrintIL' = A.runKleisli $ runPattern matchValue
394+ where
395+ matchValue :: (Emit gen) => Pattern PrinterState AST gen
396+ matchValue = buildPrettyPrinter operators (literals <+> fmap parensPos matchValue)
397+ operators :: (Emit gen) => OperatorTable PrinterState AST gen
398+ operators =
399+ OperatorTable [ [ unary New "?" ]
400+ , [ unary Not "!"
401+ , unary BitwiseNot "~"
402+ , unary Positive "+"
403+ , negateOperator ]
404+ , [ binary Multiply "*"
405+ , binary Divide "/"
406+ , binary Modulus "%" ]
407+ , [ binary Add "+"
408+ , binary Subtract "-" ]
409+ , [ binary ShiftLeft "<<"
410+ , binary ShiftRight ">>" ]
411+ , [ binary LessThan "<"
412+ , binary LessThanOrEqualTo "<="
413+ , binary GreaterThan ">"
414+ , binary GreaterThanOrEqualTo ">=" ]
415+ , [ binary EqualTo "=="
416+ , binary NotEqualTo "!=" ]
417+ , [ binary BitwiseAnd "&" ]
418+ , [ binary BitwiseXor "^" ]
419+ , [ binary BitwiseOr "|" ]
420+ , [ binary And "&&" ]
421+ , [ binary Or "||" ]
422+ ]
423+
424+prettyPrintIL1 :: AST -> Text
425+prettyPrintIL1 = maybe (internalError "Incomplete pattern") runPlainString . flip evalStateT (PrinterState 0) . prettyPrintIL'
426+
427+stringLiteral :: PSString -> Text
428+stringLiteral pss | Just s <- decodeString pss = stringLiteral' s
429+ where
430+ stringLiteral' :: Text -> Text
431+ stringLiteral' s = "\"" <> T.concatMap encodeChar s <> "\""
432+ encodeChar :: Char -> Text
433+ encodeChar '\0' = "\\x00"
434+ encodeChar '\b' = "\\b"
435+ encodeChar '\t' = "\\t"
436+ encodeChar '\n' = "\\n"
437+ encodeChar '\v' = "\\v"
438+ encodeChar '\f' = "\\f"
439+ encodeChar '\r' = "\\r"
440+ encodeChar '"' = "\\\""
441+ encodeChar '\\' = "\\\\"
442+ encodeChar c = T.singleton $ c
443+stringLiteral _ = "\"\\uFFFD\""
444+
445+interfaceSource :: Text -> [(Text,Bool)] -> [Ident] -> Text
446+interfaceSource _ _ _ = ""
447+
448+implHeaderSource :: Text -> [Text] -> Text -> Text
449+implHeaderSource mn imports otherPrefix =
450+ "// Code generated by psgo. DO NOT EDIT.\n\n" <>
451+ "package " <> (if mn == "Main" || mn == "Test_Main" then "main" else mn) <> "\n\n" <>
452+ "import . \"" <> runtime <> "\"\n" <>
453+ (if mn == "Main" || mn == "Test_Main"
454+ then "import _ \"" <> otherPrefix <> "/" <> ffiLoader <> "\"\n"
455+ else "\n") <>
456+ "import (\n" <>
457+ (T.concat $ formatImport <$> imports) <> ")\n\n" <>
458+ "type _ = Any\n\n"
459+ where
460+ formatImport :: Text -> Text
461+ formatImport s =
462+ "\t\"" <> otherPrefix <> "/" <> modPrefix <> "/" <> moduleRenamer s <> "\"\n"
463+ moduleRenamer :: Text -> Text
464+ moduleRenamer s
465+ | (s', sfx) <- T.breakOn moduleRenamerMarker s,
466+ not $ T.null sfx = s'
467+ moduleRenamer s = s
468+
469+implFooterSource :: Text -> [Ident] -> Text
470+implFooterSource mn foreigns =
471+ "\n\n\n" <>
472+ (if null foreigns
473+ then ""
474+ else ("// Foreign values\n\n" <>
475+ "var " <> foreignDict <> " = "<> foreignMod <> "(\"" <> mn <> "\")\n\n" <>
476+ (T.concat $ (\foreign' ->
477+ let name = moduleIdentToIL foreign' in
478+ varDecl <> " " <> initName name <> " Once\n" <>
479+ varDecl <> " " <> valueName name <> " " <> anyType <> "\n\n" <>
480+ "func " <>
481+ withPrefix name <>
482+ "() Any { \n" <>
483+ " " <> initName name <> ".Do(func() {\n" <>
484+ " " <> valueName name <> " = " <>
485+ "Get(" <> foreignDict <> ", " <>
486+ (stringLiteral . mkString $ runIdent foreign') <> ")\n" <>
487+ " })\n" <>
488+ " return " <> valueName name <> "\n" <>
489+ "}\n\n") <$> foreigns))) <>
490+ if mn == "Main" || mn == "Test.Main" then mainSource else "\n"
491+ where
492+ mainSource :: Text
493+ mainSource = "\
494+ \func main() {\n\
495+ \ Run(Ꞌmain())\n\
496+ \}\n\n\
497+ \"
498+
499+varDecl :: Text
500+varDecl = "var"
501+
502+renderArg :: Text -> Text -> Text
503+renderArg decl arg = arg <> " " <> decl
504+
505+foreignMod :: Text
506+foreignMod = "Foreign"
507+
508+foreignDict :: Text
509+foreignDict = "foreign"
510+
511+modLabel :: Text
512+modLabel = "purescript-native"
513+
514+modPrefix :: Text
515+modPrefix = modLabel <> "/output"
516+
517+runtime :: Text
518+runtime = "github.com/" <> modLabel <> "/go-runtime"
519+
520+ffiLoader :: Text
521+ffiLoader = modLabel <> "/ffi-loader"
522+
523+initName :: Text -> Text
524+initName s = "ᛌ" <> s <> "_once"
525+
526+valueName :: Text -> Text
527+valueName s = "ᛧ" <> s
src/Language/PureScript.hsdeleted−252
@@ -1,252 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript
4−-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- |
12−-- The main compiler module
13−--
14−-----------------------------------------------------------------------------
15−
16−{-# LANGUAGE DataKinds, QuasiQuotes, TemplateHaskell #-}
17−
18−module Language.PureScript (module P, compile, compile', RebuildPolicy(..), MonadMake(..), make, prelude) where
19−
20−import Data.FileEmbed (embedFile)
21−import Data.Function (on)
22−import Data.List (sortBy, groupBy, intercalate)
23−import Data.Maybe (fromMaybe)
24−import Data.Time.Clock
25−import qualified Data.ByteString.UTF8 as BU
26−import qualified Data.Map as M
27−import qualified Data.Set as S
28−
29−import Control.Applicative
30−import Control.Arrow ((&&&))
31−import Control.Monad.Error
32−
33−import System.FilePath ((</>))
34−
35−import Language.PureScript.AST as P
36−import Language.PureScript.CodeGen as P
37−import Language.PureScript.DeadCodeElimination as P
38−import Language.PureScript.Environment as P
39−import Language.PureScript.Errors as P
40−import Language.PureScript.Kinds as P
41−import Language.PureScript.ModuleDependencies as P
42−import Language.PureScript.Names as P
43−import Language.PureScript.Options as P
44−import Language.PureScript.Parser as P
45−import Language.PureScript.Pretty as P
46−import Language.PureScript.Renamer as P
47−import Language.PureScript.Sugar as P
48−import Language.PureScript.Supply as P
49−import Language.PureScript.TypeChecker as P
50−import Language.PureScript.Types as P
51−import qualified Language.PureScript.CoreFn as CoreFn
52−import qualified Language.PureScript.Constants as C
53−
54−-- |
55−-- Compile a collection of modules
56−--
57−-- The compilation pipeline proceeds as follows:
58−--
59−-- * Sort the modules based on module dependencies, checking for cyclic dependencies.
60−--
61−-- * Perform a set of desugaring passes.
62−--
63−-- * Type check, and elaborate values to include type annotations and type class dictionaries.
64−--
65−-- * Regroup values to take into account new value dependencies introduced by elaboration.
66−--
67−-- * Eliminate dead code.
68−--
69−-- * Generate Javascript, and perform optimization passes.
70−--
71−-- * Pretty-print the generated Javascript
72−--
73−compile :: Options Compile -> [Module] -> [String] -> Either String (String, String, Environment)
74−compile = compile' initEnvironment
75−
76−compile' :: Environment -> Options Compile -> [Module] -> [String] -> Either String (String, String, Environment)
77−compile' env opts ms prefix = do
78− (sorted, _) <- sortModules $ map importPrim $ if optionsNoPrelude opts then ms else map importPrelude ms
79− (desugared, nextVar) <- stringifyErrorStack True $ runSupplyT 0 $ desugar sorted
80− (elaborated, env') <- runCheck' opts env $ forM desugared $ typeCheckModule mainModuleIdent
81− regrouped <- stringifyErrorStack True $ createBindingGroupsModule . collapseBindingGroupsModule $ elaborated
82− let corefn = map (CoreFn.moduleToCoreFn env') regrouped
83− let entryPoints = moduleNameFromString `map` entryPointModules (optionsAdditional opts)
84− let elim = if null entryPoints then corefn else eliminateDeadCode entryPoints corefn
85− let renamed = renameInModules elim
86− let codeGenModuleNames = moduleNameFromString `map` codeGenModules (optionsAdditional opts)
87− let modulesToCodeGen = if null codeGenModuleNames then renamed else filter (\(CoreFn.Module mn _ _ _ _) -> mn `elem` codeGenModuleNames) renamed
88− let js = evalSupply nextVar $ concat <$> mapM (moduleToJs opts) modulesToCodeGen
89− let exts = intercalate "\n" . map (`moduleToPs` env') $ regrouped
90− js' <- generateMain env' opts js
91− let pjs = unlines $ map ("// " ++) prefix ++ [prettyPrintJS js']
92− return (pjs, exts, env')
93− where
94− mainModuleIdent = moduleNameFromString <$> optionsMain opts
95−
96−generateMain :: Environment -> Options Compile -> [JS] -> Either String [JS]
97−generateMain env opts js =
98− case moduleNameFromString <$> optionsMain opts of
99− Just mmi -> do
100− when ((mmi, Ident C.main) `M.notMember` names env) $
101− Left $ show mmi ++ "." ++ C.main ++ " is undefined"
102− return $ js ++ [JSApp (JSAccessor C.main (JSAccessor (moduleNameToJs mmi) (JSVar (browserNamespace (optionsAdditional opts))))) []]
103− _ -> return js
104−
105−-- |
106−-- A type class which collects the IO actions we need to be able to run in "make" mode
107−--
108−class MonadMake m where
109− -- |
110− -- Get a file timestamp
111− --
112− getTimestamp :: FilePath -> m (Maybe UTCTime)
113−
114− -- |
115− -- Read a file as a string
116− --
117− readTextFile :: FilePath -> m String
118−
119− -- |
120− -- Write a text file
121− --
122− writeTextFile :: FilePath -> String -> m ()
123−
124− -- |
125− -- Report an error
126− --
127− liftError :: Either String a -> m a
128−
129− -- |
130− -- Respond to a progress update
131− --
132− progress :: String -> m ()
133−
134−-- |
135−-- Determines when to rebuild a module
136−--
137−data RebuildPolicy
138− -- | Never rebuild this module
139− = RebuildNever
140− -- | Always rebuild this module
141− | RebuildAlways deriving (Show, Eq, Ord)
142−
143−-- Traverse (Either e) instance (base 4.7)
144−traverseEither :: Applicative f => (a -> f b) -> Either e a -> f (Either e b)
145−traverseEither _ (Left x) = pure (Left x)
146−traverseEither f (Right y) = Right <$> f y
147−
148−-- |
149−-- Compiles in "make" mode, compiling each module separately to a js files and an externs file
150−--
151−-- If timestamps have not changed, the externs file can be used to provide the module's types without
152−-- having to typecheck the module again.
153−--
154−make :: (Functor m, Applicative m, Monad m, MonadMake m) => FilePath -> Options Make -> [(Either RebuildPolicy FilePath, Module)] -> [String] -> m Environment
155−make outputDir opts ms prefix = do
156− let filePathMap = M.fromList (map (\(fp, Module mn _ _) -> (mn, fp)) ms)
157−
158− (sorted, graph) <- liftError $ sortModules $ map importPrim $ if optionsNoPrelude opts then map snd ms else map (importPrelude . snd) ms
159−
160− toRebuild <- foldM (\s (Module moduleName' _ _) -> do
161− let filePath = runModuleName moduleName'
162−
163− jsFile = outputDir </> filePath </> "index.js"
164− externsFile = outputDir </> filePath </> "externs.purs"
165− inputFile = fromMaybe (error "Module has no filename in 'make'") $ M.lookup moduleName' filePathMap
166−
167− jsTimestamp <- getTimestamp jsFile
168− externsTimestamp <- getTimestamp externsFile
169− inputTimestamp <- traverseEither getTimestamp inputFile
170−
171− return $ case (inputTimestamp, jsTimestamp, externsTimestamp) of
172− (Right (Just t1), Just t2, Just t3) | t1 < min t2 t3 -> s
173− (Left RebuildNever, Just _, Just _) -> s
174− _ -> S.insert moduleName' s) S.empty sorted
175−
176− marked <- rebuildIfNecessary (reverseDependencies graph) toRebuild sorted
177−
178− (desugared, nextVar) <- liftError $ stringifyErrorStack True $ runSupplyT 0 $ zip (map fst marked) <$> desugar (map snd marked)
179−
180− evalSupplyT nextVar (go initEnvironment desugared)
181−
182− where
183− go :: (Functor m, Applicative m, Monad m, MonadMake m) => Environment -> [(Bool, Module)] -> SupplyT m Environment
184− go env [] = return env
185− go env ((False, m) : ms') = do
186− (_, env') <- lift . liftError . runCheck' opts env $ typeCheckModule Nothing m
187−
188− go env' ms'
189− go env ((True, m@(Module moduleName' _ exps)) : ms') = do
190− let filePath = runModuleName moduleName'
191− jsFile = outputDir </> filePath </> "index.js"
192− externsFile = outputDir </> filePath </> "externs.purs"
193−
194− lift . progress $ "Compiling " ++ runModuleName moduleName'
195−
196− (Module _ elaborated _, env') <- lift . liftError . runCheck' opts env $ typeCheckModule Nothing m
197−
198− regrouped <- lift . liftError . stringifyErrorStack True . createBindingGroups moduleName' . collapseBindingGroups $ elaborated
199−
200− let mod' = Module moduleName' regrouped exps
201− let corefn = CoreFn.moduleToCoreFn env' mod'
202− let [renamed] = renameInModules [corefn]
203−
204− pjs <- prettyPrintJS <$> moduleToJs opts renamed
205− let js = unlines $ map ("// " ++) prefix ++ [pjs]
206− let exts = unlines $ map ("-- " ++) prefix ++ [moduleToPs mod' env']
207−
208− lift $ writeTextFile jsFile js
209− lift $ writeTextFile externsFile exts
210−
211− go env' ms'
212−
213− rebuildIfNecessary :: (Functor m, Monad m, MonadMake m) => M.Map ModuleName [ModuleName] -> S.Set ModuleName -> [Module] -> m [(Bool, Module)]
214− rebuildIfNecessary _ _ [] = return []
215− rebuildIfNecessary graph toRebuild (m@(Module moduleName' _ _) : ms') | moduleName' `S.member` toRebuild = do
216− let deps = fromMaybe [] $ moduleName' `M.lookup` graph
217− toRebuild' = toRebuild `S.union` S.fromList deps
218− (:) (True, m) <$> rebuildIfNecessary graph toRebuild' ms'
219− rebuildIfNecessary graph toRebuild (Module moduleName' _ _ : ms') = do
220− let externsFile = outputDir </> runModuleName moduleName' </> "externs.purs"
221− externs <- readTextFile externsFile
222− externsModules <- liftError . fmap (map snd) . either (Left . show) Right $ P.parseModulesFromFiles id [(externsFile, externs)]
223− case externsModules of
224− [m'@(Module moduleName'' _ _)] | moduleName'' == moduleName' -> (:) (False, m') <$> rebuildIfNecessary graph toRebuild ms'
225− _ -> liftError . Left $ "Externs file " ++ externsFile ++ " was invalid"
226−
227−reverseDependencies :: ModuleGraph -> M.Map ModuleName [ModuleName]
228−reverseDependencies g = combine [ (dep, mn) | (mn, deps) <- g, dep <- deps ]
229− where
230− combine :: (Ord a) => [(a, b)] -> M.Map a [b]
231− combine = M.fromList . map ((fst . head) &&& map snd) . groupBy ((==) `on` fst) . sortBy (compare `on` fst)
232−
233−-- |
234−-- Add an import declaration for a module if it does not already explicitly import it.
235−--
236−addDefaultImport :: ModuleName -> Module -> Module
237−addDefaultImport toImport m@(Module mn decls exps) =
238− if isExistingImport `any` decls || mn == toImport then m
239− else Module mn (ImportDeclaration toImport Unqualified Nothing : decls) exps
240− where
241− isExistingImport (ImportDeclaration mn' _ _) | mn' == toImport = True
242− isExistingImport (PositionedDeclaration _ d) = isExistingImport d
243− isExistingImport _ = False
244−
245−importPrim :: Module -> Module
246−importPrim = addDefaultImport (ModuleName [ProperName C.prim])
247−
248−importPrelude :: Module -> Module
249−importPrelude = addDefaultImport (ModuleName [ProperName C.prelude])
250−
251−prelude :: String
252−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−86
@@ -1,86 +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−
24−-- |
25−-- Data type for binders
26−--
27−data Binder
28− -- |
29− -- Wildcard binder
30− --
31− = NullBinder
32− -- |
33− -- A binder which matches a boolean literal
34− --
35− | BooleanBinder Bool
36− -- |
37− -- A binder which matches a string literal
38− --
39− | StringBinder String
40− -- |
41− -- A binder which matches a numeric literal
42− --
43− | NumberBinder (Either Integer Double)
44− -- |
45− -- A binder which binds an identifier
46− --
47− | VarBinder Ident
48− -- |
49− -- A binder which matches a data constructor
50− --
51− | ConstructorBinder (Qualified ProperName) [Binder]
52− -- |
53− -- A binder which matches a record and binds its properties
54− --
55− | ObjectBinder [(String, Binder)]
56− -- |
57− -- A binder which matches an array and binds its elements
58− --
59− | ArrayBinder [Binder]
60− -- |
61− -- A binder which matches an array and binds its head and tail
62− --
63− | ConsBinder Binder Binder
64− -- |
65− -- A binder which binds its input to an identifier
66− --
67− | NamedBinder Ident Binder
68− -- |
69− -- A binder with source position information
70− --
71− | PositionedBinder SourceSpan Binder deriving (Show, D.Data, D.Typeable)
72−
73−-- |
74−-- Collect all names introduced in binders in an expression
75−--
76−binderNames :: Binder -> [Ident]
77−binderNames = go []
78− where
79− go ns (VarBinder name) = name : ns
80− go ns (ConstructorBinder _ bs) = foldl go ns bs
81− go ns (ObjectBinder bs) = foldl go ns (map snd bs)
82− go ns (ArrayBinder bs) = foldl go ns bs
83− go ns (ConsBinder b1 b2) = go (go ns b1) b2
84− go ns (NamedBinder name b) = go (name : ns) b
85− go ns (PositionedBinder _ b) = go ns b
86− go ns _ = ns
src/Language/PureScript/AST/Declarations.hsdeleted−407
@@ -1,407 +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.CodeGen.JS.AST
29−import Language.PureScript.Environment
30−
31−-- |
32−-- A module declaration, consisting of a module name, a list of declarations, and a list of the
33−-- declarations that are explicitly exported. If the export list is Nothing, everything is exported.
34−--
35−data Module = Module ModuleName [Declaration] (Maybe [DeclarationRef]) deriving (Show, D.Data, D.Typeable)
36−
37−-- |
38−-- Test if a declaration is exported, given a module's export list.
39−--
40−isExported :: Maybe [DeclarationRef] -> Declaration -> Bool
41−isExported Nothing _ = True
42−isExported _ TypeInstanceDeclaration{} = True
43−isExported exps (PositionedDeclaration _ d) = isExported exps d
44−isExported (Just exps) decl = any (matches decl) exps
45− where
46− matches (TypeDeclaration ident _) (ValueRef ident') = ident == ident'
47− matches (ExternDeclaration _ ident _ _) (ValueRef ident') = ident == ident'
48− matches (DataDeclaration _ ident _ _) (TypeRef ident' _) = ident == ident'
49− matches (ExternDataDeclaration ident _) (TypeRef ident' _) = ident == ident'
50− matches (TypeSynonymDeclaration ident _ _) (TypeRef ident' _) = ident == ident'
51− matches (TypeClassDeclaration ident _ _ _) (TypeClassRef ident') = ident == ident'
52− matches (PositionedDeclaration _ d) r = d `matches` r
53− matches d (PositionedDeclarationRef _ r) = d `matches` r
54− matches _ _ = False
55−
56−exportedDeclarations :: Module -> [Declaration]
57−exportedDeclarations (Module _ decls exps) = filter (isExported exps) decls
58−
59−-- |
60−-- Test if a data constructor for a given type is exported, given a module's export list.
61−--
62−isDctorExported :: ProperName -> Maybe [DeclarationRef] -> ProperName -> Bool
63−isDctorExported _ Nothing _ = True
64−isDctorExported ident (Just exps) ctor = test `any` exps
65− where
66− test (PositionedDeclarationRef _ d) = test d
67− test (TypeRef ident' Nothing) = ident == ident'
68− test (TypeRef ident' (Just ctors)) = ident == ident' && ctor `elem` ctors
69− test _ = False
70−
71−-- |
72−-- Return the exported data constructors for a given type.
73−--
74−exportedDctors :: Module -> ProperName -> [ProperName]
75−exportedDctors (Module _ decls exps) ident =
76− filter (isDctorExported ident exps) dctors
77− where
78− dctors = concatMap getDctors decls
79− getDctors (DataDeclaration _ _ _ ctors) = map fst ctors
80− getDctors _ = []
81−
82−-- |
83−-- An item in a list of explicit imports or exports
84−--
85−data DeclarationRef
86− -- |
87− -- A type constructor with data constructors
88− --
89− = TypeRef ProperName (Maybe [ProperName])
90− -- |
91− -- A value
92− --
93− | ValueRef Ident
94− -- |
95− -- A type class
96− --
97− | TypeClassRef ProperName
98− -- |
99− -- A type class instance, created during typeclass desugaring (name, class name, instance types)
100− --
101− | TypeInstanceRef Ident
102− -- |
103− -- A declaration reference with source position information
104− --
105− | PositionedDeclarationRef SourceSpan DeclarationRef
106− deriving (Show, D.Data, D.Typeable)
107−
108−instance Eq DeclarationRef where
109− (TypeRef name dctors) == (TypeRef name' dctors') = name == name' && dctors == dctors'
110− (ValueRef name) == (ValueRef name') = name == name'
111− (TypeClassRef name) == (TypeClassRef name') = name == name'
112− (TypeInstanceRef name) == (TypeInstanceRef name') = name == name'
113− (PositionedDeclarationRef _ r) == r' = r == r'
114− r == (PositionedDeclarationRef _ r') = r == r'
115− _ == _ = False
116−
117−-- |
118−-- The data type which specifies type of import declaration
119−--
120−data ImportDeclarationType
121− -- |
122− -- Unqualified import
123− --
124− = Unqualified
125− -- |
126− -- Qualified import with a list of references to import
127− --
128− | Qualifying [DeclarationRef]
129− -- |
130− -- Import with hiding clause with a list of references to hide
131− --
132− | Hiding [DeclarationRef]
133− deriving (Show, D.Data, D.Typeable)
134−
135−-- |
136−-- The data type of declarations
137−--
138−data Declaration
139− -- |
140− -- A data type declaration (data or newtype, name, arguments, data constructors)
141− --
142− = DataDeclaration DataDeclType ProperName [(String, Maybe Kind)] [(ProperName, [Type])]
143− -- |
144− -- A minimal mutually recursive set of data type declarations
145− --
146− | DataBindingGroupDeclaration [Declaration]
147− -- |
148− -- A type synonym declaration (name, arguments, type)
149− --
150− | TypeSynonymDeclaration ProperName [(String, Maybe Kind)] Type
151− -- |
152− -- A type declaration for a value (name, ty)
153− --
154− | TypeDeclaration Ident Type
155− -- |
156− -- A value declaration (name, top-level binders, optional guard, value)
157− --
158− | ValueDeclaration Ident NameKind [Binder] (Either [(Guard, Expr)] Expr)
159− -- |
160− -- A minimal mutually recursive set of value declarations
161− --
162− | BindingGroupDeclaration [(Ident, NameKind, Expr)]
163− -- |
164− -- A foreign import declaration (type, name, optional inline Javascript, type)
165− --
166− | ExternDeclaration ForeignImportType Ident (Maybe JS) Type
167− -- |
168− -- A data type foreign import (name, kind)
169− --
170− | ExternDataDeclaration ProperName Kind
171− -- |
172− -- A type class instance foreign import
173− --
174− | ExternInstanceDeclaration Ident [Constraint] (Qualified ProperName) [Type]
175− -- |
176− -- A fixity declaration (fixity data, operator name)
177− --
178− | FixityDeclaration Fixity String
179− -- |
180− -- A module import (module name, qualified/unqualified/hiding, optional "qualified as" name)
181− --
182− | ImportDeclaration ModuleName ImportDeclarationType (Maybe ModuleName)
183− -- |
184− -- A type class declaration (name, argument, implies, member declarations)
185− --
186− | TypeClassDeclaration ProperName [(String, Maybe Kind)] [Constraint] [Declaration]
187− -- |
188− -- A type instance declaration (name, dependencies, class name, instance types, member
189− -- declarations)
190− --
191− | TypeInstanceDeclaration Ident [Constraint] (Qualified ProperName) [Type] [Declaration]
192− -- |
193− -- A declaration with source position information
194− --
195− | PositionedDeclaration SourceSpan Declaration
196− deriving (Show, D.Data, D.Typeable)
197−
198−-- |
199−-- Test if a declaration is a value declaration
200−--
201−isValueDecl :: Declaration -> Bool
202−isValueDecl ValueDeclaration{} = True
203−isValueDecl (PositionedDeclaration _ d) = isValueDecl d
204−isValueDecl _ = False
205−
206−-- |
207−-- Test if a declaration is a data type or type synonym declaration
208−--
209−isDataDecl :: Declaration -> Bool
210−isDataDecl DataDeclaration{} = True
211−isDataDecl TypeSynonymDeclaration{} = True
212−isDataDecl (PositionedDeclaration _ d) = isDataDecl d
213−isDataDecl _ = False
214−
215−-- |
216−-- Test if a declaration is a module import
217−--
218−isImportDecl :: Declaration -> Bool
219−isImportDecl ImportDeclaration{} = True
220−isImportDecl (PositionedDeclaration _ d) = isImportDecl d
221−isImportDecl _ = False
222−
223−-- |
224−-- Test if a declaration is a data type foreign import
225−--
226−isExternDataDecl :: Declaration -> Bool
227−isExternDataDecl ExternDataDeclaration{} = True
228−isExternDataDecl (PositionedDeclaration _ d) = isExternDataDecl d
229−isExternDataDecl _ = False
230−
231−-- |
232−-- Test if a declaration is a type class instance foreign import
233−--
234−isExternInstanceDecl :: Declaration -> Bool
235−isExternInstanceDecl ExternInstanceDeclaration{} = True
236−isExternInstanceDecl (PositionedDeclaration _ d) = isExternInstanceDecl d
237−isExternInstanceDecl _ = False
238−
239−-- |
240−-- Test if a declaration is a fixity declaration
241−--
242−isFixityDecl :: Declaration -> Bool
243−isFixityDecl FixityDeclaration{} = True
244−isFixityDecl (PositionedDeclaration _ d) = isFixityDecl d
245−isFixityDecl _ = False
246−
247−-- |
248−-- Test if a declaration is a foreign import
249−--
250−isExternDecl :: Declaration -> Bool
251−isExternDecl ExternDeclaration{} = True
252−isExternDecl (PositionedDeclaration _ d) = isExternDecl d
253−isExternDecl _ = False
254−
255−-- |
256−-- Test if a declaration is a type class or instance declaration
257−--
258−isTypeClassDeclaration :: Declaration -> Bool
259−isTypeClassDeclaration TypeClassDeclaration{} = True
260−isTypeClassDeclaration TypeInstanceDeclaration{} = True
261−isTypeClassDeclaration (PositionedDeclaration _ d) = isTypeClassDeclaration d
262−isTypeClassDeclaration _ = False
263−
264−-- |
265−-- A guard is just a boolean-valued expression that appears alongside a set of binders
266−--
267−type Guard = Expr
268−
269−-- |
270−-- Data type for expressions and terms
271−--
272−data Expr
273− -- |
274− -- A numeric literal
275− --
276− = NumericLiteral (Either Integer Double)
277− -- |
278− -- A string literal
279− --
280− | StringLiteral String
281− -- |
282− -- A boolean literal
283− --
284− | BooleanLiteral Bool
285− -- |
286− -- A prefix -, will be desugared
287− --
288− | UnaryMinus Expr
289− -- |
290− -- Binary operator application. During the rebracketing phase of desugaring, this data constructor
291− -- will be removed.
292− --
293− | BinaryNoParens (Qualified Ident) Expr Expr
294− -- |
295− -- Explicit parentheses. During the rebracketing phase of desugaring, this data constructor
296− -- will be removed.
297− --
298− | Parens Expr
299− -- |
300− -- An array literal
301− --
302− | ArrayLiteral [Expr]
303− -- |
304− -- An object literal
305− --
306− | ObjectLiteral [(String, Expr)]
307− -- |
308− -- An record property accessor expression
309− --
310− | Accessor String Expr
311− -- |
312− -- Partial record update
313− --
314− | ObjectUpdate Expr [(String, Expr)]
315− -- |
316− -- Function introduction
317− --
318− | Abs (Either Ident Binder) Expr
319− -- |
320− -- Function application
321− --
322− | App Expr Expr
323− -- |
324− -- Variable
325− --
326− | Var (Qualified Ident)
327− -- |
328− -- Conditional (if-then-else expression)
329− --
330− | IfThenElse Expr Expr Expr
331− -- |
332− -- A data constructor
333− --
334− | Constructor (Qualified ProperName)
335− -- |
336− -- A case expression. During the case expansion phase of desugaring, top-level binders will get
337− -- desugared into case expressions, hence the need for guards and multiple binders per branch here.
338− --
339− | Case [Expr] [CaseAlternative]
340− -- |
341− -- A value with a type annotation
342− --
343− | TypedValue Bool Expr Type
344− -- |
345− -- A let binding
346− --
347− | Let [Declaration] Expr
348− -- |
349− -- A do-notation block
350− --
351− | Do [DoNotationElement]
352− -- |
353− -- An application of a typeclass dictionary constructor. The value should be
354− -- an ObjectLiteral.
355− --
356− | TypeClassDictionaryConstructorApp (Qualified ProperName) Expr
357− -- |
358− -- A placeholder for a type class dictionary to be inserted later. At the end of type checking, these
359− -- placeholders will be replaced with actual expressions representing type classes dictionaries which
360− -- can be evaluated at runtime. The constructor arguments represent (in order): whether or not to look
361− -- at superclass implementations when searching for a dictionary, the type class name and
362− -- instance type, and the type class dictionaries in scope.
363− --
364− | TypeClassDictionary Bool Constraint [TypeClassDictionaryInScope]
365− -- |
366− -- A placeholder for a superclass dictionary to be turned into a TypeClassDictionary during typechecking
367− --
368− | SuperClassDictionary (Qualified ProperName) [Type]
369− -- |
370− -- A value with source position information
371− --
372− | PositionedValue SourceSpan Expr deriving (Show, D.Data, D.Typeable)
373−
374−-- |
375−-- An alternative in a case statement
376−--
377−data CaseAlternative = CaseAlternative
378− { -- |
379− -- A collection of binders with which to match the inputs
380− --
381− caseAlternativeBinders :: [Binder]
382− -- |
383− -- The result expression or a collect of guarded expressions
384− --
385− , caseAlternativeResult :: Either [(Guard, Expr)] Expr
386− } deriving (Show, D.Data, D.Typeable)
387−
388−-- |
389−-- A statement in a do-notation block
390−--
391−data DoNotationElement
392− -- |
393− -- A monadic value without a binder
394− --
395− = DoNotationValue Expr
396− -- |
397− -- A monadic value with a binder
398− --
399− | DoNotationBind Binder Expr
400− -- |
401− -- A let statement, i.e. a pure value with a binder
402− --
403− | DoNotationLet [Declaration]
404− -- |
405− -- A do notation element with source position information
406− --
407− | PositionedDoNotationElement SourceSpan 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−383
@@ -1,383 +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−
19−import Control.Applicative
20−import Control.Monad
21−import Control.Arrow ((***), (+++))
22−
23−import Language.PureScript.AST.Binders
24−import Language.PureScript.AST.Declarations
25−import Language.PureScript.Types
26−import Language.PureScript.Traversals
27−
28−everywhereOnValues :: (Declaration -> Declaration) ->
29− (Expr -> Expr) ->
30− (Binder -> Binder) ->
31− (Declaration -> Declaration, Expr -> Expr, Binder -> Binder)
32−everywhereOnValues f g h = (f', g', h')
33− where
34− f' :: Declaration -> Declaration
35− f' (DataBindingGroupDeclaration ds) = f (DataBindingGroupDeclaration (map f' ds))
36− f' (ValueDeclaration name nameKind bs val) = f (ValueDeclaration name nameKind (map h' bs) ((map (g' *** g') +++ g') val))
37− f' (BindingGroupDeclaration ds) = f (BindingGroupDeclaration (map (\(name, nameKind, val) -> (name, nameKind, g' val)) ds))
38− f' (TypeClassDeclaration name args implies ds) = f (TypeClassDeclaration name args implies (map f' ds))
39− f' (TypeInstanceDeclaration name cs className args ds) = f (TypeInstanceDeclaration name cs className args (map f' ds))
40− f' (PositionedDeclaration pos d) = f (PositionedDeclaration pos (f' d))
41− f' other = f other
42−
43− g' :: Expr -> Expr
44− g' (UnaryMinus v) = g (UnaryMinus (g' v))
45− g' (BinaryNoParens op v1 v2) = g (BinaryNoParens op (g' v1) (g' v2))
46− g' (Parens v) = g (Parens (g' v))
47− g' (ArrayLiteral vs) = g (ArrayLiteral (map g' vs))
48− g' (ObjectLiteral vs) = g (ObjectLiteral (map (fmap g') vs))
49− g' (TypeClassDictionaryConstructorApp name v) = g (TypeClassDictionaryConstructorApp name (g' v))
50− g' (Accessor prop v) = g (Accessor prop (g' v))
51− g' (ObjectUpdate obj vs) = g (ObjectUpdate (g' obj) (map (fmap g') vs))
52− g' (Abs name v) = g (Abs name (g' v))
53− g' (App v1 v2) = g (App (g' v1) (g' v2))
54− g' (IfThenElse v1 v2 v3) = g (IfThenElse (g' v1) (g' v2) (g' v3))
55− g' (Case vs alts) = g (Case (map g' vs) (map handleCaseAlternative alts))
56− g' (TypedValue check v ty) = g (TypedValue check (g' v) ty)
57− g' (Let ds v) = g (Let (map f' ds) (g' v))
58− g' (Do es) = g (Do (map handleDoNotationElement es))
59− g' (PositionedValue pos v) = g (PositionedValue pos (g' v))
60− g' other = g other
61−
62− h' :: Binder -> Binder
63− h' (ConstructorBinder ctor bs) = h (ConstructorBinder ctor (map h' bs))
64− h' (ObjectBinder bs) = h (ObjectBinder (map (fmap h') bs))
65− h' (ArrayBinder bs) = h (ArrayBinder (map h' bs))
66− h' (ConsBinder b1 b2) = h (ConsBinder (h' b1) (h' b2))
67− h' (NamedBinder name b) = h (NamedBinder name (h' b))
68− h' (PositionedBinder pos b) = h (PositionedBinder pos (h' b))
69− h' other = h other
70−
71− handleCaseAlternative :: CaseAlternative -> CaseAlternative
72− handleCaseAlternative ca =
73− ca { caseAlternativeBinders = map h' (caseAlternativeBinders ca)
74− , caseAlternativeResult = (map (g' *** g') +++ g') (caseAlternativeResult ca)
75− }
76−
77− handleDoNotationElement :: DoNotationElement -> DoNotationElement
78− handleDoNotationElement (DoNotationValue v) = DoNotationValue (g' v)
79− handleDoNotationElement (DoNotationBind b v) = DoNotationBind (h' b) (g' v)
80− handleDoNotationElement (DoNotationLet ds) = DoNotationLet (map f' ds)
81− handleDoNotationElement (PositionedDoNotationElement pos e) = PositionedDoNotationElement pos (handleDoNotationElement e)
82−
83−
84−everywhereOnValuesTopDownM :: (Functor m, Applicative m, Monad m) =>
85− (Declaration -> m Declaration) ->
86− (Expr -> m Expr) ->
87− (Binder -> m Binder) ->
88− (Declaration -> m Declaration, Expr -> m Expr, Binder -> m Binder)
89−everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h)
90− where
91− f' (DataBindingGroupDeclaration ds) = DataBindingGroupDeclaration <$> mapM (f' <=< f) ds
92− f' (ValueDeclaration name nameKind bs val) = ValueDeclaration name nameKind <$> mapM (h' <=< h) bs <*> eitherM (mapM (pairM (g' <=< g) (g' <=< g))) (g' <=< g) val
93− f' (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> mapM (\(name, nameKind, val) -> (,,) name nameKind <$> (g val >>= g')) ds
94− f' (TypeClassDeclaration name args implies ds) = TypeClassDeclaration name args implies <$> mapM (f' <=< f) ds
95− f' (TypeInstanceDeclaration name cs className args ds) = TypeInstanceDeclaration name cs className args <$> mapM (f' <=< f) ds
96− f' (PositionedDeclaration pos d) = PositionedDeclaration pos <$> (f d >>= f')
97− f' other = f other
98−
99− g' (UnaryMinus v) = UnaryMinus <$> (g v >>= g')
100− g' (BinaryNoParens op v1 v2) = BinaryNoParens op <$> (g v1 >>= g') <*> (g v2 >>= g')
101− g' (Parens v) = Parens <$> (g v >>= g')
102− g' (ArrayLiteral vs) = ArrayLiteral <$> mapM (g' <=< g) vs
103− g' (ObjectLiteral vs) = ObjectLiteral <$> mapM (sndM (g' <=< g)) vs
104− g' (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> (g v >>= g')
105− g' (Accessor prop v) = Accessor prop <$> (g v >>= g')
106− g' (ObjectUpdate obj vs) = ObjectUpdate <$> (g obj >>= g') <*> mapM (sndM (g' <=< g)) vs
107− g' (Abs name v) = Abs name <$> (g v >>= g')
108− g' (App v1 v2) = App <$> (g v1 >>= g') <*> (g v2 >>= g')
109− g' (IfThenElse v1 v2 v3) = IfThenElse <$> (g v1 >>= g') <*> (g v2 >>= g') <*> (g v3 >>= g')
110− g' (Case vs alts) = Case <$> mapM (g' <=< g) vs <*> mapM handleCaseAlternative alts
111− g' (TypedValue check v ty) = TypedValue check <$> (g v >>= g') <*> pure ty
112− g' (Let ds v) = Let <$> mapM (f' <=< f) ds <*> (g v >>= g')
113− g' (Do es) = Do <$> mapM handleDoNotationElement es
114− g' (PositionedValue pos v) = PositionedValue pos <$> (g v >>= g')
115− g' other = g other
116−
117− h' (ConstructorBinder ctor bs) = ConstructorBinder ctor <$> mapM (h' <=< h) bs
118− h' (ObjectBinder bs) = ObjectBinder <$> mapM (sndM (h' <=< h)) bs
119− h' (ArrayBinder bs) = ArrayBinder <$> mapM (h' <=< h) bs
120− h' (ConsBinder b1 b2) = ConsBinder <$> (h b1 >>= h') <*> (h b2 >>= h')
121− h' (NamedBinder name b) = NamedBinder name <$> (h b >>= h')
122− h' (PositionedBinder pos b) = PositionedBinder pos <$> (h b >>= h')
123− h' other = h other
124−
125− handleCaseAlternative (CaseAlternative bs val) = CaseAlternative <$> mapM (h' <=< h) bs
126− <*> eitherM (mapM (pairM (g' <=< g) (g' <=< g))) (g' <=< g) val
127−
128− handleDoNotationElement (DoNotationValue v) = DoNotationValue <$> (g' <=< g) v
129− handleDoNotationElement (DoNotationBind b v) = DoNotationBind <$> (h' <=< h) b <*> (g' <=< g) v
130− handleDoNotationElement (DoNotationLet ds) = DoNotationLet <$> mapM (f' <=< f) ds
131− handleDoNotationElement (PositionedDoNotationElement pos e) = PositionedDoNotationElement pos <$> handleDoNotationElement e
132−
133−everywhereOnValuesM :: (Functor m, Applicative m, Monad m) =>
134− (Declaration -> m Declaration) ->
135− (Expr -> m Expr) ->
136− (Binder -> m Binder) ->
137− (Declaration -> m Declaration, Expr -> m Expr, Binder -> m Binder)
138−everywhereOnValuesM f g h = (f', g', h')
139− where
140− f' (DataBindingGroupDeclaration ds) = (DataBindingGroupDeclaration <$> mapM f' ds) >>= f
141− f' (ValueDeclaration name nameKind bs val) = (ValueDeclaration name nameKind <$> mapM h' bs <*> eitherM (mapM (pairM g' g')) g' val) >>= f
142− f' (BindingGroupDeclaration ds) = (BindingGroupDeclaration <$> mapM (\(name, nameKind, val) -> (,,) name nameKind <$> g' val) ds) >>= f
143− f' (TypeClassDeclaration name args implies ds) = (TypeClassDeclaration name args implies <$> mapM f' ds) >>= f
144− f' (TypeInstanceDeclaration name cs className args ds) = (TypeInstanceDeclaration name cs className args <$> mapM f' ds) >>= f
145− f' (PositionedDeclaration pos d) = (PositionedDeclaration pos <$> f' d) >>= f
146− f' other = f other
147−
148− g' (UnaryMinus v) = (UnaryMinus <$> g' v) >>= g
149− g' (BinaryNoParens op v1 v2) = (BinaryNoParens op <$> g' v1 <*> g' v2) >>= g
150− g' (Parens v) = (Parens <$> g' v) >>= g
151− g' (ArrayLiteral vs) = (ArrayLiteral <$> mapM g' vs) >>= g
152− g' (ObjectLiteral vs) = (ObjectLiteral <$> mapM (sndM g') vs) >>= g
153− g' (TypeClassDictionaryConstructorApp name v) = (TypeClassDictionaryConstructorApp name <$> g' v) >>= g
154− g' (Accessor prop v) = (Accessor prop <$> g' v) >>= g
155− g' (ObjectUpdate obj vs) = (ObjectUpdate <$> g' obj <*> mapM (sndM g') vs) >>= g
156− g' (Abs name v) = (Abs name <$> g' v) >>= g
157− g' (App v1 v2) = (App <$> g' v1 <*> g' v2) >>= g
158− g' (IfThenElse v1 v2 v3) = (IfThenElse <$> g' v1 <*> g' v2 <*> g' v3) >>= g
159− g' (Case vs alts) = (Case <$> mapM g' vs <*> mapM handleCaseAlternative alts) >>= g
160− g' (TypedValue check v ty) = (TypedValue check <$> g' v <*> pure ty) >>= g
161− g' (Let ds v) = (Let <$> mapM f' ds <*> g' v) >>= g
162− g' (Do es) = (Do <$> mapM handleDoNotationElement es) >>= g
163− g' (PositionedValue pos v) = (PositionedValue pos <$> g' v) >>= g
164− g' other = g other
165−
166− h' (ConstructorBinder ctor bs) = (ConstructorBinder ctor <$> mapM h' bs) >>= h
167− h' (ObjectBinder bs) = (ObjectBinder <$> mapM (sndM h') bs) >>= h
168− h' (ArrayBinder bs) = (ArrayBinder <$> mapM h' bs) >>= h
169− h' (ConsBinder b1 b2) = (ConsBinder <$> h' b1 <*> h' b2) >>= h
170− h' (NamedBinder name b) = (NamedBinder name <$> h' b) >>= h
171− h' (PositionedBinder pos b) = (PositionedBinder pos <$> h' b) >>= h
172− h' other = h other
173−
174− handleCaseAlternative (CaseAlternative bs val) = CaseAlternative <$> mapM h' bs
175− <*> eitherM (mapM (pairM g' g')) g' val
176−
177− handleDoNotationElement (DoNotationValue v) = DoNotationValue <$> g' v
178− handleDoNotationElement (DoNotationBind b v) = DoNotationBind <$> h' b <*> g' v
179− handleDoNotationElement (DoNotationLet ds) = DoNotationLet <$> mapM f' ds
180− handleDoNotationElement (PositionedDoNotationElement pos e) = PositionedDoNotationElement pos <$> handleDoNotationElement e
181−
182−everythingOnValues :: (r -> r -> r) ->
183− (Declaration -> r) ->
184− (Expr -> r) ->
185− (Binder -> r) ->
186− (CaseAlternative -> r) ->
187− (DoNotationElement -> r) ->
188− (Declaration -> r, Expr -> r, Binder -> r, CaseAlternative -> r, DoNotationElement -> r)
189−everythingOnValues (<>) f g h i j = (f', g', h', i', j')
190− where
191− f' d@(DataBindingGroupDeclaration ds) = foldl (<>) (f d) (map f' ds)
192− f' d@(ValueDeclaration _ _ bs (Right val)) = foldl (<>) (f d) (map h' bs) <> g' val
193− f' d@(ValueDeclaration _ _ bs (Left gs)) = foldl (<>) (f d) (map h' bs ++ concatMap (\(grd, val) -> [g' grd, g' val]) gs)
194− f' d@(BindingGroupDeclaration ds) = foldl (<>) (f d) (map (\(_, _, val) -> g' val) ds)
195− f' d@(TypeClassDeclaration _ _ _ ds) = foldl (<>) (f d) (map f' ds)
196− f' d@(TypeInstanceDeclaration _ _ _ _ ds) = foldl (<>) (f d) (map f' ds)
197− f' d@(PositionedDeclaration _ d1) = f d <> f' d1
198− f' d = f d
199−
200− g' v@(UnaryMinus v1) = g v <> g' v1
201− g' v@(BinaryNoParens _ v1 v2) = g v <> g' v1 <> g' v2
202− g' v@(Parens v1) = g v <> g' v1
203− g' v@(ArrayLiteral vs) = foldl (<>) (g v) (map g' vs)
204− g' v@(ObjectLiteral vs) = foldl (<>) (g v) (map (g' . snd) vs)
205− g' v@(TypeClassDictionaryConstructorApp _ v1) = g v <> g' v1
206− g' v@(Accessor _ v1) = g v <> g' v1
207− g' v@(ObjectUpdate obj vs) = foldl (<>) (g v <> g' obj) (map (g' . snd) vs)
208− g' v@(Abs _ v1) = g v <> g' v1
209− g' v@(App v1 v2) = g v <> g' v1 <> g' v2
210− g' v@(IfThenElse v1 v2 v3) = g v <> g' v1 <> g' v2 <> g' v3
211− g' v@(Case vs alts) = foldl (<>) (foldl (<>) (g v) (map g' vs)) (map i' alts)
212− g' v@(TypedValue _ v1 _) = g v <> g' v1
213− g' v@(Let ds v1) = foldl (<>) (g v) (map f' ds) <> g' v1
214− g' v@(Do es) = foldl (<>) (g v) (map j' es)
215− g' v@(PositionedValue _ v1) = g v <> g' v1
216− g' v = g v
217−
218− h' b@(ConstructorBinder _ bs) = foldl (<>) (h b) (map h' bs)
219− h' b@(ObjectBinder bs) = foldl (<>) (h b) (map (h' . snd) bs)
220− h' b@(ArrayBinder bs) = foldl (<>) (h b) (map h' bs)
221− h' b@(ConsBinder b1 b2) = h b <> h' b1 <> h' b2
222− h' b@(NamedBinder _ b1) = h b <> h' b1
223− h' b@(PositionedBinder _ b1) = h b <> h' b1
224− h' b = h b
225−
226− i' ca@(CaseAlternative bs (Right val)) = foldl (<>) (i ca) (map h' bs) <> g' val
227− i' ca@(CaseAlternative bs (Left gs)) = foldl (<>) (i ca) (map h' bs ++ concatMap (\(grd, val) -> [g' grd, g' val]) gs)
228−
229− j' e@(DoNotationValue v) = j e <> g' v
230− j' e@(DoNotationBind b v) = j e <> h' b <> g' v
231− j' e@(DoNotationLet ds) = foldl (<>) (j e) (map f' ds)
232− j' e@(PositionedDoNotationElement _ e1) = j e <> j' e1
233−
234−everythingWithContextOnValues ::
235− s ->
236− r ->
237− (r -> r -> r) ->
238− (s -> Declaration -> (s, r)) ->
239− (s -> Expr -> (s, r)) ->
240− (s -> Binder -> (s, r)) ->
241− (s -> CaseAlternative -> (s, r)) ->
242− (s -> DoNotationElement -> (s, r)) ->
243− ( Declaration -> r
244− , Expr -> r
245− , Binder -> r
246− , CaseAlternative -> r
247− , DoNotationElement -> r)
248−everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j'' s0)
249− where
250− f'' s d = let (s', r) = f s d in r <> f' s' d
251−
252− f' s (DataBindingGroupDeclaration ds) = foldl (<>) r0 (map (f'' s) ds)
253− f' s (ValueDeclaration _ _ bs (Right val)) = foldl (<>) r0 (map (h'' s) bs) <> g'' s val
254− f' s (ValueDeclaration _ _ bs (Left gs)) = foldl (<>) r0 (map (h'' s) bs ++ concatMap (\(grd, val) -> [g'' s grd, g'' s val]) gs)
255− f' s (BindingGroupDeclaration ds) = foldl (<>) r0 (map (\(_, _, val) -> g'' s val) ds)
256− f' s (TypeClassDeclaration _ _ _ ds) = foldl (<>) r0 (map (f'' s) ds)
257− f' s (TypeInstanceDeclaration _ _ _ _ ds) = foldl (<>) r0 (map (f'' s) ds)
258− f' s (PositionedDeclaration _ d1) = f'' s d1
259− f' _ _ = r0
260−
261− g'' s v = let (s', r) = g s v in r <> g' s' v
262−
263− g' s (UnaryMinus v1) = g'' s v1
264− g' s (BinaryNoParens _ v1 v2) = g'' s v1 <> g'' s v2
265− g' s (Parens v1) = g'' s v1
266− g' s (ArrayLiteral vs) = foldl (<>) r0 (map (g'' s) vs)
267− g' s (ObjectLiteral vs) = foldl (<>) r0 (map (g'' s . snd) vs)
268− g' s (TypeClassDictionaryConstructorApp _ v1) = g'' s v1
269− g' s (Accessor _ v1) = g'' s v1
270− g' s (ObjectUpdate obj vs) = foldl (<>) (g'' s obj) (map (g'' s . snd) vs)
271− g' s (Abs _ v1) = g'' s v1
272− g' s (App v1 v2) = g'' s v1 <> g'' s v2
273− g' s (IfThenElse v1 v2 v3) = g'' s v1 <> g'' s v2 <> g'' s v3
274− g' s (Case vs alts) = foldl (<>) (foldl (<>) r0 (map (g'' s) vs)) (map (i'' s) alts)
275− g' s (TypedValue _ v1 _) = g'' s v1
276− g' s (Let ds v1) = foldl (<>) r0 (map (f'' s) ds) <> g'' s v1
277− g' s (Do es) = foldl (<>) r0 (map (j'' s) es)
278− g' s (PositionedValue _ v1) = g'' s v1
279− g' _ _ = r0
280−
281− h'' s b = let (s', r) = h s b in r <> h' s' b
282−
283− h' s (ConstructorBinder _ bs) = foldl (<>) r0 (map (h'' s) bs)
284− h' s (ObjectBinder bs) = foldl (<>) r0 (map (h'' s . snd) bs)
285− h' s (ArrayBinder bs) = foldl (<>) r0 (map (h'' s) bs)
286− h' s (ConsBinder b1 b2) = h'' s b1 <> h'' s b2
287− h' s (NamedBinder _ b1) = h'' s b1
288− h' s (PositionedBinder _ b1) = h'' s b1
289− h' _ _ = r0
290−
291− i'' s ca = let (s', r) = i s ca in r <> i' s' ca
292−
293− i' s (CaseAlternative bs (Right val)) = foldl (<>) r0 (map (h'' s) bs) <> g'' s val
294− i' s (CaseAlternative bs (Left gs)) = foldl (<>) r0 (map (h'' s) bs ++ concatMap (\(grd, val) -> [g'' s grd, g'' s val]) gs)
295−
296− j'' s e = let (s', r) = j s e in r <> j' s' e
297−
298− j' s (DoNotationValue v) = g'' s v
299− j' s (DoNotationBind b v) = h'' s b <> g'' s v
300− j' s (DoNotationLet ds) = foldl (<>) r0 (map (f'' s) ds)
301− j' s (PositionedDoNotationElement _ e1) = j'' s e1
302−
303−everywhereWithContextOnValuesM :: (Functor m, Applicative m, Monad m) =>
304− s ->
305− (s -> Declaration -> m (s, Declaration)) ->
306− (s -> Expr -> m (s, Expr)) ->
307− (s -> Binder -> m (s, Binder)) ->
308− (s -> CaseAlternative -> m (s, CaseAlternative)) ->
309− (s -> DoNotationElement -> m (s, DoNotationElement)) ->
310− ( Declaration -> m Declaration
311− , Expr -> m Expr
312− , Binder -> m Binder
313− , CaseAlternative -> m CaseAlternative
314− , DoNotationElement -> m DoNotationElement)
315−everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j'' s0)
316− where
317− f'' s = uncurry f' <=< f s
318−
319− f' s (DataBindingGroupDeclaration ds) = DataBindingGroupDeclaration <$> mapM (f'' s) ds
320− f' s (ValueDeclaration name nameKind bs val) = ValueDeclaration name nameKind <$> mapM (h'' s) bs <*> eitherM (mapM (pairM (g'' s) (g'' s))) (g'' s) val
321− f' s (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> mapM (thirdM (g'' s)) ds
322− f' s (TypeClassDeclaration name args implies ds) = TypeClassDeclaration name args implies <$> mapM (f'' s) ds
323− f' s (TypeInstanceDeclaration name cs className args ds) = TypeInstanceDeclaration name cs className args <$> mapM (f'' s) ds
324− f' s (PositionedDeclaration pos d1) = PositionedDeclaration pos <$> f'' s d1
325− f' _ other = return other
326−
327− g'' s = uncurry g' <=< g s
328−
329− g' s (UnaryMinus v) = UnaryMinus <$> g'' s v
330− g' s (BinaryNoParens op v1 v2) = BinaryNoParens op <$> g'' s v1 <*> g'' s v2
331− g' s (Parens v) = Parens <$> g'' s v
332− g' s (ArrayLiteral vs) = ArrayLiteral <$> mapM (g'' s) vs
333− g' s (ObjectLiteral vs) = ObjectLiteral <$> mapM (sndM (g'' s)) vs
334− g' s (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> g'' s v
335− g' s (Accessor prop v) = Accessor prop <$> g'' s v
336− g' s (ObjectUpdate obj vs) = ObjectUpdate <$> g'' s obj <*> mapM (sndM (g'' s)) vs
337− g' s (Abs name v) = Abs name <$> g'' s v
338− g' s (App v1 v2) = App <$> g'' s v1 <*> g'' s v2
339− g' s (IfThenElse v1 v2 v3) = IfThenElse <$> g'' s v1 <*> g'' s v2 <*> g'' s v3
340− g' s (Case vs alts) = Case <$> mapM (g'' s) vs <*> mapM (i'' s) alts
341− g' s (TypedValue check v ty) = TypedValue check <$> g'' s v <*> pure ty
342− g' s (Let ds v) = Let <$> mapM (f'' s) ds <*> g'' s v
343− g' s (Do es) = Do <$> mapM (j'' s) es
344− g' s (PositionedValue pos v) = PositionedValue pos <$> g'' s v
345− g' _ other = return other
346−
347− h'' s = uncurry h' <=< h s
348−
349− h' s (ConstructorBinder ctor bs) = ConstructorBinder ctor <$> mapM (h'' s) bs
350− h' s (ObjectBinder bs) = ObjectBinder <$> mapM (sndM (h'' s)) bs
351− h' s (ArrayBinder bs) = ArrayBinder <$> mapM (h'' s) bs
352− h' s (ConsBinder b1 b2) = ConsBinder <$> h'' s b1 <*> h'' s b2
353− h' s (NamedBinder name b) = NamedBinder name <$> h'' s b
354− h' s (PositionedBinder pos b) = PositionedBinder pos <$> h'' s b
355− h' _ other = return other
356−
357− i'' s = uncurry i' <=< i s
358−
359− i' s (CaseAlternative bs val) = CaseAlternative <$> mapM (h'' s) bs <*> eitherM (mapM (pairM (g'' s) (g'' s))) (g'' s) val
360−
361− j'' s = uncurry j' <=< j s
362−
363− j' s (DoNotationValue v) = DoNotationValue <$> g'' s v
364− j' s (DoNotationBind b v) = DoNotationBind <$> h'' s b <*> g'' s v
365− j' s (DoNotationLet ds) = DoNotationLet <$> mapM (f'' s) ds
366− j' s (PositionedDoNotationElement pos e1) = PositionedDoNotationElement pos <$> j'' s e1
367−
368−accumTypes :: (Monoid r) => (Type -> r) -> (Declaration -> r, Expr -> r, Binder -> r, CaseAlternative -> r, DoNotationElement -> r)
369−accumTypes f = everythingOnValues mappend forDecls forValues (const mempty) (const mempty) (const mempty)
370− where
371− forDecls (DataDeclaration _ _ _ dctors) = mconcat (concatMap (map f . snd) dctors)
372− forDecls (ExternDeclaration _ _ _ ty) = f ty
373− forDecls (ExternInstanceDeclaration _ cs _ tys) = mconcat (concatMap (map f . snd) cs) `mappend` mconcat (map f tys)
374− forDecls (TypeClassDeclaration _ _ implies _) = mconcat (concatMap (map f . snd) implies)
375− forDecls (TypeInstanceDeclaration _ cs _ tys _) = mconcat (concatMap (map f . snd) cs) `mappend` mconcat (map f tys)
376− forDecls (TypeSynonymDeclaration _ _ ty) = f ty
377− forDecls (TypeDeclaration _ ty) = f ty
378− forDecls _ = mempty
379−
380− forValues (TypeClassDictionary _ (_, cs) _) = mconcat (map f cs)
381− forValues (SuperClassDictionary _ tys) = mconcat (map f tys)
382− forValues (TypedValue _ _ ty) = f ty
383− 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−109
@@ -1,109 +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−
34−-- |
35−-- Generate foreign imports for all declarations in a module
36−--
37−moduleToPs :: Module -> Environment -> String
38−moduleToPs (Module _ _ Nothing) _ = error "Module exports were not elaborated in moduleToPs"
39−moduleToPs (Module moduleName ds (Just exts)) env = intercalate "\n" . execWriter $ do
40− tell [ "module " ++ runModuleName moduleName ++ " where"]
41− mapM_ declToPs ds
42− mapM_ exportToPs exts
43− where
44−
45− declToPs :: Declaration -> Writer [String] ()
46− declToPs (ImportDeclaration mn _ _) = tell ["import " ++ show mn ++ " ()"]
47− declToPs (FixityDeclaration (Fixity assoc prec) ident) =
48− tell [ unwords [ show assoc, show prec, ident ] ]
49− declToPs (PositionedDeclaration _ d) = declToPs d
50− declToPs _ = return ()
51−
52− exportToPs :: DeclarationRef -> Writer [String] ()
53− exportToPs (PositionedDeclarationRef _ r) = exportToPs r
54− exportToPs (TypeRef pn dctors) = do
55− case Qualified (Just moduleName) pn `M.lookup` types env of
56− Nothing -> error $ show pn ++ " has no kind in exportToPs"
57− Just (kind, ExternData) ->
58− tell ["foreign import data " ++ show pn ++ " :: " ++ prettyPrintKind kind]
59− Just (_, DataType args tys) -> do
60− let dctors' = fromMaybe (map fst tys) dctors
61− printDctor dctor = case dctor `lookup` tys of
62− Nothing -> Nothing
63− Just tyArgs -> Just $ show dctor ++ " " ++ unwords (map prettyPrintTypeAtom tyArgs)
64− let dtype = if length dctors' == 1 && isNewtypeConstructor env (Qualified (Just moduleName) $ head dctors')
65− then "newtype"
66− else "data"
67− typeName = prettyPrintType $ foldl TypeApp (TypeConstructor (Qualified Nothing pn)) (map toTypeVar args)
68− tell [dtype ++ " " ++ typeName ++ (if null dctors' then "" else " = " ++ intercalate " | " (mapMaybe printDctor dctors'))]
69− Just (_, TypeSynonym) ->
70− case Qualified (Just moduleName) pn `M.lookup` typeSynonyms env of
71− Nothing -> error $ show pn ++ " has no type synonym info in exportToPs"
72− Just (args, synTy) ->
73− let
74− typeName = prettyPrintType $ foldl TypeApp (TypeConstructor (Qualified Nothing pn)) (map toTypeVar args)
75− in tell ["type " ++ typeName ++ " = " ++ prettyPrintType synTy]
76− _ -> error "Invalid input in exportToPs"
77−
78− exportToPs (ValueRef ident) =
79− case (moduleName, ident) `M.lookup` names env of
80− Nothing -> error $ show ident ++ " has no type in exportToPs"
81− Just (ty, nameKind, _) | nameKind == Value || nameKind == Extern ForeignImport || nameKind == Extern InlineJavascript ->
82− tell ["foreign import " ++ show ident ++ " :: " ++ prettyPrintType ty]
83− _ -> return ()
84− exportToPs (TypeClassRef className) =
85− case Qualified (Just moduleName) className `M.lookup` typeClasses env of
86− Nothing -> error $ show className ++ " has no type class definition in exportToPs"
87− Just (args, members, implies) -> do
88− let impliesString = if null implies
89− then ""
90− else "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map prettyPrintTypeAtom tys')) implies) ++ ") <= "
91− typeName = prettyPrintType $ foldl TypeApp (TypeConstructor (Qualified Nothing className)) (map toTypeVar args)
92− tell ["class " ++ impliesString ++ typeName ++ " where"]
93− forM_ (filter (isValueExported . fst) members) $ \(member ,ty) ->
94− tell [ " " ++ show member ++ " :: " ++ prettyPrintType ty ]
95−
96− exportToPs (TypeInstanceRef ident) = do
97− let TypeClassDictionaryInScope { tcdClassName = className, tcdInstanceTypes = tys, tcdDependencies = deps} =
98− 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
99− let constraintsText = case fromMaybe [] deps of
100− [] -> ""
101− cs -> "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map prettyPrintTypeAtom tys')) cs) ++ ") => "
102− tell ["foreign import instance " ++ show ident ++ " :: " ++ constraintsText ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys)]
103−
104− toTypeVar :: (String, Maybe Kind) -> Type
105− toTypeVar (s, Nothing) = TypeVar s
106− toTypeVar (s, Just k) = KindedType (TypeVar s) k
107−
108− isValueExported :: Ident -> Bool
109− isValueExported ident = ValueRef ident `elem` exts
src/Language/PureScript/CodeGen/JS.hsdeleted−344
@@ -1,344 +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−
18−module Language.PureScript.CodeGen.JS (
19− module AST,
20− module Common,
21− bindToJs,
22− moduleToJs
23−) where
24−
25−import Data.Function (on)
26−import Data.List ((\\), delete, sortBy)
27−import Data.Maybe (catMaybes, mapMaybe)
28−
29−import Control.Applicative
30−import Control.Arrow ((&&&))
31−import Control.Monad (foldM, replicateM, forM)
32−
33−import Language.PureScript.CodeGen.JS.AST as AST
34−import Language.PureScript.CodeGen.JS.Common as Common
35−import Language.PureScript.CoreFn
36−import Language.PureScript.Names
37−import Language.PureScript.CodeGen.JS.Optimizer
38−import Language.PureScript.Options
39−import Language.PureScript.Supply
40−import Language.PureScript.Traversals (sndM)
41−import qualified Language.PureScript.Constants as C
42−
43−-- |
44−-- Generate code in the simplified Javascript intermediate representation for all declarations in a
45−-- module.
46−--
47−moduleToJs :: (Functor m, Applicative m, Monad m) => Options mode -> Module Ann -> SupplyT m [JS]
48−moduleToJs opts (Module name imps exps foreigns decls) = do
49− let jsImports = map (importToJs opts) . delete (ModuleName [ProperName C.prim]) . (\\ [name]) $ imps
50− let foreigns' = mapMaybe (\(_, js, _) -> js) foreigns
51− jsDecls <- mapM (bindToJs name) decls
52− let optimized = concatMap (map $ optimize opts) $ catMaybes jsDecls
53− let isModuleEmpty = null exps
54− let moduleBody = JSStringLiteral "use strict" : jsImports ++ foreigns' ++ optimized
55− let exps' = JSObjectLiteral $ map (runIdent &&& JSVar . identToJs) exps
56− return $ case optionsAdditional opts of
57− MakeOptions -> moduleBody ++ [JSAssignment (JSAccessor "exports" (JSVar "module")) exps']
58− CompileOptions ns _ _ | not isModuleEmpty ->
59− [ JSVariableIntroduction ns
60− (Just (JSBinary Or (JSVar ns) (JSObjectLiteral [])) )
61− , JSAssignment (JSAccessor (moduleNameToJs name) (JSVar ns))
62− (JSApp (JSFunction Nothing [] (JSBlock (moduleBody ++ [JSReturn exps']))) [])
63− ]
64− _ -> []
65−
66−-- |
67−-- Generates Javascript code for a module import.
68−--
69−importToJs :: Options mode -> ModuleName -> JS
70−importToJs opts mn =
71− JSVariableIntroduction (moduleNameToJs mn) (Just moduleBody)
72− where
73− moduleBody = case optionsAdditional opts of
74− MakeOptions -> JSApp (JSVar "require") [JSStringLiteral (runModuleName mn)]
75− CompileOptions ns _ _ -> JSAccessor (moduleNameToJs mn) (JSVar ns)
76−
77−-- |
78−-- Generate code in the simplified Javascript intermediate representation for a declaration
79−--
80−bindToJs :: (Functor m, Applicative m, Monad m) => ModuleName -> Bind Ann -> SupplyT m (Maybe [JS])
81−bindToJs mp (NonRec ident val) = do
82− js <- valueToJs mp val
83− return $ Just [JSVariableIntroduction (identToJs ident) (Just js)]
84−bindToJs mp (Rec vals) = do
85− jss <- forM vals $ \(ident, val) -> do
86− js <- valueToJs mp val
87− return $ JSVariableIntroduction (identToJs ident) (Just js)
88− return $ Just jss
89−
90−-- |
91−-- Generate code in the simplified Javascript intermediate representation for a variable based on a
92−-- PureScript identifier.
93−--
94−var :: Ident -> JS
95−var = JSVar . identToJs
96−
97−-- |
98−-- Generate code in the simplified Javascript intermediate representation for an accessor based on
99−-- a PureScript identifier. If the name is not valid in Javascript (symbol based, reserved name) an
100−-- indexer is returned.
101−--
102−accessor :: Ident -> JS -> JS
103−accessor (Ident prop) = accessorString prop
104−accessor (Op op) = JSIndexer (JSStringLiteral op)
105−
106−accessorString :: String -> JS -> JS
107−accessorString prop | identNeedsEscaping prop = JSIndexer (JSStringLiteral prop)
108− | otherwise = JSAccessor prop
109−
110−-- |
111−-- Generate code in the simplified Javascript intermediate representation for a value or expression.
112−--
113−valueToJs :: (Functor m, Applicative m, Monad m) => ModuleName -> Expr Ann -> SupplyT m JS
114−valueToJs m (Literal _ l) =
115− literalToValueJS m l
116−valueToJs m (Var (_, _, Just (IsConstructor _ 0)) name) =
117− return $ JSAccessor "value" $ qualifiedToJS m id name
118−valueToJs m (Var (_, _, Just (IsConstructor _ _)) name) =
119− return $ JSAccessor "create" $ qualifiedToJS m id name
120−valueToJs m (Accessor _ prop val) =
121− accessorString prop <$> valueToJs m val
122−valueToJs m (ObjectUpdate _ o ps) = do
123− obj <- valueToJs m o
124− sts <- mapM (sndM (valueToJs m)) ps
125− extendObj obj sts
126−valueToJs _ e@(Abs (_, _, Just IsTypeClassConstructor) _ val) =
127− let args = unAbs e
128− in return $ JSFunction Nothing (map identToJs args) (JSBlock $ map assign args)
129− where
130− unAbs :: Expr Ann -> [Ident]
131− unAbs (Abs _ arg val) = arg : unAbs val
132− unAbs _ = []
133− assign :: Ident -> JS
134− assign name = JSAssignment (accessorString (runIdent name) (JSVar "this"))
135− (var name)
136−valueToJs m (Abs _ arg val) = do
137− ret <- valueToJs m val
138− return $ JSFunction Nothing [identToJs arg] (JSBlock [JSReturn ret])
139−valueToJs m e@App{} = do
140− let (f, args) = unApp e []
141− args' <- mapM (valueToJs m) args
142− case f of
143− Var (_, _, Just IsNewtype) _ -> return (head args')
144− Var (_, _, Just (IsConstructor _ arity)) name | arity == length args ->
145− return $ JSUnary JSNew $ JSApp (qualifiedToJS m id name) args'
146− Var (_, _, Just IsTypeClassConstructor) name ->
147− return $ JSUnary JSNew $ JSApp (qualifiedToJS m id name) args'
148− _ -> flip (foldl (\fn a -> JSApp fn [a])) args' <$> valueToJs m f
149− where
150− unApp :: Expr Ann -> [Expr Ann] -> (Expr Ann, [Expr Ann])
151− unApp (App _ val arg) args = unApp val (arg : args)
152− unApp other args = (other, args)
153−valueToJs m (Var _ ident) =
154− return $ varToJs m ident
155−valueToJs m (Case _ values binders) = do
156− vals <- mapM (valueToJs m) values
157− bindersToJs m binders vals
158−valueToJs m (Let _ ds val) = do
159− decls <- concat . catMaybes <$> mapM (bindToJs m) ds
160− ret <- valueToJs m val
161− return $ JSApp (JSFunction Nothing [] (JSBlock (decls ++ [JSReturn ret]))) []
162−valueToJs _ (Constructor (_, _, Just IsNewtype) _ (ProperName ctor) _) =
163− return $ JSVariableIntroduction ctor (Just $
164− JSObjectLiteral [("create",
165− JSFunction Nothing ["value"]
166− (JSBlock [JSReturn $ JSVar "value"]))])
167−valueToJs _ (Constructor _ _ (ProperName ctor) 0) =
168− return $ iife ctor [ JSFunction (Just ctor) [] (JSBlock [])
169− , JSAssignment (JSAccessor "value" (JSVar ctor))
170− (JSUnary JSNew $ JSApp (JSVar ctor) []) ]
171−valueToJs _ (Constructor _ _ (ProperName ctor) arity) =
172− return $ iife ctor [ makeConstructor ctor arity
173− , JSAssignment (JSAccessor "create" (JSVar ctor)) (go ctor 0 arity [])
174− ]
175− where
176− makeConstructor :: String -> Int -> JS
177− makeConstructor ctorName n =
178− let args = [ "value" ++ show index | index <- [0..n-1] ]
179− body = [ JSAssignment (JSAccessor arg (JSVar "this")) (JSVar arg) | arg <- args ]
180− in JSFunction (Just ctorName) args (JSBlock body)
181− go :: String -> Int -> Int -> [JS] -> JS
182− go pn _ 0 values = JSUnary JSNew $ JSApp (JSVar pn) (reverse values)
183− go pn index n values =
184− JSFunction Nothing ["value" ++ show index]
185− (JSBlock [JSReturn (go pn (index + 1) (n - 1) (JSVar ("value" ++ show index) : values))])
186−
187−iife :: String -> [JS] -> JS
188−iife v exprs = JSApp (JSFunction Nothing [] (JSBlock $ exprs ++ [JSReturn $ JSVar v])) []
189−
190−literalToValueJS :: (Functor m, Applicative m, Monad m) => ModuleName -> Literal (Expr Ann) -> SupplyT m JS
191−literalToValueJS _ (NumericLiteral n) = return $ JSNumericLiteral n
192−literalToValueJS _ (StringLiteral s) = return $ JSStringLiteral s
193−literalToValueJS _ (BooleanLiteral b) = return $ JSBooleanLiteral b
194−literalToValueJS m (ArrayLiteral xs) = JSArrayLiteral <$> mapM (valueToJs m) xs
195−literalToValueJS m (ObjectLiteral ps) = JSObjectLiteral <$> mapM (sndM (valueToJs m)) ps
196−
197−-- |
198−-- Shallow copy an object.
199−--
200−extendObj :: (Functor m, Applicative m, Monad m) => JS -> [(String, JS)] -> SupplyT m JS
201−extendObj obj sts = do
202− newObj <- freshName
203− key <- freshName
204− let
205− jsKey = JSVar key
206− jsNewObj = JSVar newObj
207− block = JSBlock (objAssign:copy:extend ++ [JSReturn jsNewObj])
208− objAssign = JSVariableIntroduction newObj (Just $ JSObjectLiteral [])
209− copy = JSForIn key obj $ JSBlock [JSIfElse cond assign Nothing]
210− cond = JSApp (JSAccessor "hasOwnProperty" obj) [jsKey]
211− assign = JSBlock [JSAssignment (JSIndexer jsKey jsNewObj) (JSIndexer jsKey obj)]
212− stToAssign (s, js) = JSAssignment (JSAccessor s jsNewObj) js
213− extend = map stToAssign sts
214− return $ JSApp (JSFunction Nothing [] block) []
215−
216−-- |
217−-- Generate code in the simplified Javascript intermediate representation for a reference to a
218−-- variable.
219−--
220−varToJs :: ModuleName -> Qualified Ident -> JS
221−varToJs _ (Qualified Nothing ident) = var ident
222−varToJs m qual = qualifiedToJS m id qual
223−
224−-- |
225−-- Generate code in the simplified Javascript intermediate representation for a reference to a
226−-- variable that may have a qualified name.
227−--
228−qualifiedToJS :: ModuleName -> (a -> Ident) -> Qualified a -> JS
229−qualifiedToJS _ f (Qualified (Just (ModuleName [ProperName mn])) a) | mn == C.prim = JSVar . runIdent $ f a
230−qualifiedToJS m f (Qualified (Just m') a) | m /= m' = accessor (f a) (JSVar (moduleNameToJs m'))
231−qualifiedToJS _ f (Qualified _ a) = JSVar $ identToJs (f a)
232−
233−-- |
234−-- Generate code in the simplified Javascript intermediate representation for pattern match binders
235−-- and guards.
236−--
237−bindersToJs :: (Functor m, Applicative m, Monad m) => ModuleName -> [CaseAlternative Ann] -> [JS] -> SupplyT m JS
238−bindersToJs m binders vals = do
239− valNames <- replicateM (length vals) freshName
240− let assignments = zipWith JSVariableIntroduction valNames (map Just vals)
241− jss <- forM binders $ \(CaseAlternative bs result) -> do
242− ret <- guardsToJs result
243− go valNames ret bs
244− return $ JSApp (JSFunction Nothing [] (JSBlock (assignments ++ concat jss ++ [JSThrow $ JSUnary JSNew $ JSApp (JSVar "Error") [JSStringLiteral "Failed pattern match"]])))
245− []
246− where
247− go :: (Functor m, Applicative m, Monad m) => [String] -> [JS] -> [Binder Ann] -> SupplyT m [JS]
248− go _ done [] = return done
249− go (v:vs) done' (b:bs) = do
250− done'' <- go vs done' bs
251− binderToJs m v done'' b
252− go _ _ _ = error "Invalid arguments to bindersToJs"
253−
254− guardsToJs :: (Functor m, Applicative m, Monad m) => Either [(Guard Ann, Expr Ann)] (Expr Ann) -> SupplyT m [JS]
255− guardsToJs (Left gs) = forM gs $ \(cond, val) -> do
256− cond' <- valueToJs m cond
257− done <- valueToJs m val
258− return $ JSIfElse cond' (JSBlock [JSReturn done]) Nothing
259− guardsToJs (Right v) = return . JSReturn <$> valueToJs m v
260−
261−-- |
262−-- Generate code in the simplified Javascript intermediate representation for a pattern match
263−-- binder.
264−--
265−binderToJs :: (Functor m, Applicative m, Monad m) => ModuleName -> String -> [JS] -> Binder Ann -> SupplyT m [JS]
266−binderToJs _ _ done (NullBinder{}) = return done
267−binderToJs m varName done (LiteralBinder _ l) =
268− literalToBinderJS m varName done l
269−binderToJs _ varName done (VarBinder _ ident) =
270− return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : done)
271−binderToJs m varName done (ConstructorBinder (_, _, Just IsNewtype) _ _ [b]) =
272− binderToJs m varName done b
273−binderToJs m varName done (ConstructorBinder (_, _, Just (IsConstructor ctorType _)) _ ctor bs) = do
274− js <- go 0 done bs
275− return $ case ctorType of
276− ProductType -> js
277− SumType ->
278− [JSIfElse (JSInstanceOf (JSVar varName) (qualifiedToJS m (Ident . runProperName) ctor))
279− (JSBlock js)
280− Nothing]
281− where
282− go :: (Functor m, Applicative m, Monad m) => Integer -> [JS] -> [Binder Ann] -> SupplyT m [JS]
283− go _ done' [] = return done'
284− go index done' (binder:bs') = do
285− argVar <- freshName
286− done'' <- go (index + 1) done' bs'
287− js <- binderToJs m argVar done'' binder
288− return (JSVariableIntroduction argVar (Just (JSAccessor ("value" ++ show index) (JSVar varName))) : js)
289−binderToJs m varName done binder@(ConstructorBinder _ _ ctor _) | isCons ctor = do
290− let (headBinders, tailBinder) = uncons [] binder
291− numberOfHeadBinders = fromIntegral $ length headBinders
292− js1 <- foldM (\done' (headBinder, index) -> do
293− headVar <- freshName
294− jss <- binderToJs m headVar done' headBinder
295− return (JSVariableIntroduction headVar (Just (JSIndexer (JSNumericLiteral (Left index)) (JSVar varName))) : jss)) done (zip headBinders [0..])
296− tailVar <- freshName
297− js2 <- binderToJs m tailVar js1 tailBinder
298− return [JSIfElse (JSBinary GreaterThanOrEqualTo (JSAccessor "length" (JSVar varName)) (JSNumericLiteral (Left numberOfHeadBinders))) (JSBlock
299− ( JSVariableIntroduction tailVar (Just (JSApp (JSAccessor "slice" (JSVar varName)) [JSNumericLiteral (Left numberOfHeadBinders)])) :
300− js2
301− )) Nothing]
302− where
303− uncons :: [Binder Ann] -> Binder Ann -> ([Binder Ann], Binder Ann)
304− uncons acc (ConstructorBinder _ _ ctor' [h, t]) | isCons ctor' = uncons (h : acc) t
305− uncons acc tailBinder = (reverse acc, tailBinder)
306−binderToJs _ _ _ b@(ConstructorBinder{}) =
307− error $ "Invalid ConstructorBinder in binderToJs: " ++ show b
308−binderToJs m varName done (NamedBinder _ ident binder) = do
309− js <- binderToJs m varName done binder
310− return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : js)
311−
312−literalToBinderJS :: (Functor m, Applicative m, Monad m) => ModuleName -> String -> [JS] -> Literal (Binder Ann) -> SupplyT m [JS]
313−literalToBinderJS _ varName done (NumericLiteral num) =
314− return [JSIfElse (JSBinary EqualTo (JSVar varName) (JSNumericLiteral num)) (JSBlock done) Nothing]
315−literalToBinderJS _ varName done (StringLiteral str) =
316− return [JSIfElse (JSBinary EqualTo (JSVar varName) (JSStringLiteral str)) (JSBlock done) Nothing]
317−literalToBinderJS _ varName done (BooleanLiteral True) =
318− return [JSIfElse (JSVar varName) (JSBlock done) Nothing]
319−literalToBinderJS _ varName done (BooleanLiteral False) =
320− return [JSIfElse (JSUnary Not (JSVar varName)) (JSBlock done) Nothing]
321−literalToBinderJS m varName done (ObjectLiteral bs) = go done bs
322− where
323− go :: (Functor m, Applicative m, Monad m) => [JS] -> [(String, Binder Ann)] -> SupplyT m [JS]
324− go done' [] = return done'
325− go done' ((prop, binder):bs') = do
326− propVar <- freshName
327− done'' <- go done' bs'
328− js <- binderToJs m propVar done'' binder
329− return (JSVariableIntroduction propVar (Just (accessorString prop (JSVar varName))) : js)
330−literalToBinderJS m varName done (ArrayLiteral bs) = do
331− js <- go done 0 bs
332− return [JSIfElse (JSBinary EqualTo (JSAccessor "length" (JSVar varName)) (JSNumericLiteral (Left (fromIntegral $ length bs)))) (JSBlock js) Nothing]
333− where
334− go :: (Functor m, Applicative m, Monad m) => [JS] -> Integer -> [Binder Ann] -> SupplyT m [JS]
335− go done' _ [] = return done'
336− go done' index (binder:bs') = do
337− elVar <- freshName
338− done'' <- go done' (index + 1) bs'
339− js <- binderToJs m elVar done'' binder
340− return (JSVariableIntroduction elVar (Just (JSIndexer (JSNumericLiteral (Left index)) (JSVar varName))) : js)
341−
342−isCons :: Qualified ProperName -> Bool
343−isCons (Qualified (Just mn) ctor) = mn == ModuleName [ProperName C.prim] && ctor == ProperName "Array"
344−isCons name = error $ "Unexpected argument in isCons: " ++ show name
src/Language/PureScript/CodeGen/JS/AST.hsdeleted−328
@@ -1,328 +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−-- |
23−-- Built-in unary operators
24−--
25−data UnaryOperator
26− -- |
27− -- Numeric negation
28− --
29− = Negate
30− -- |
31− -- Boolean negation
32− --
33− | Not
34− -- |
35− -- Bitwise negation
36− --
37− | BitwiseNot
38− -- |
39− -- Numeric unary \'plus\'
40− --
41− | Positive
42− -- |
43− -- Constructor
44− --
45− | JSNew deriving (Show, Eq, Data, Typeable)
46−
47−-- |
48−-- Built-in binary operators
49−--
50−data BinaryOperator
51− -- |
52− -- Numeric addition
53− --
54− = Add
55− -- |
56− -- Numeric subtraction
57− --
58− | Subtract
59− -- |
60− -- Numeric multiplication
61− --
62− | Multiply
63− -- |
64− -- Numeric division
65− --
66− | Divide
67− -- |
68− -- Remainder
69− --
70− | Modulus
71− -- |
72− -- Generic equality test
73− --
74− | EqualTo
75− -- |
76− -- Generic inequality test
77− --
78− | NotEqualTo
79− -- |
80− -- Numeric less-than
81− --
82− | LessThan
83− -- |
84− -- Numeric less-than-or-equal
85− --
86− | LessThanOrEqualTo
87− -- |
88− -- Numeric greater-than
89− --
90− | GreaterThan
91− -- |
92− -- Numeric greater-than-or-equal
93− --
94− | GreaterThanOrEqualTo
95− -- |
96− -- Boolean and
97− --
98− | And
99− -- |
100− -- Boolean or
101− --
102− | Or
103− -- |
104− -- Bitwise and
105− --
106− | BitwiseAnd
107− -- |
108− -- Bitwise or
109− --
110− | BitwiseOr
111− -- |
112− -- Bitwise xor
113− --
114− | BitwiseXor
115− -- |
116− -- Bitwise left shift
117− --
118− | ShiftLeft
119− -- |
120− -- Bitwise right shift
121− --
122− | ShiftRight
123− -- |
124− -- Bitwise right shift with zero-fill
125− --
126− | ZeroFillShiftRight deriving (Show, Eq, Data, Typeable)
127−
128−-- |
129−-- Data type for simplified Javascript expressions
130−--
131−data JS
132− -- |
133− -- A numeric literal
134− --
135− = JSNumericLiteral (Either Integer Double)
136− -- |
137− -- A string literal
138− --
139− | JSStringLiteral String
140− -- |
141− -- A boolean literal
142− --
143− | JSBooleanLiteral Bool
144− -- |
145− -- A unary operator application
146− --
147− | JSUnary UnaryOperator JS
148− -- |
149− -- A binary operator application
150− --
151− | JSBinary BinaryOperator JS JS
152− -- |
153− -- An array literal
154− --
155− | JSArrayLiteral [JS]
156− -- |
157− -- An array indexer expression
158− --
159− | JSIndexer JS JS
160− -- |
161− -- An object literal
162− --
163− | JSObjectLiteral [(String, JS)]
164− -- |
165− -- An object property accessor expression
166− --
167− | JSAccessor String JS
168− -- |
169− -- A function introduction (optional name, arguments, body)
170− --
171− | JSFunction (Maybe String) [String] JS
172− -- |
173− -- Function application
174− --
175− | JSApp JS [JS]
176− -- |
177− -- Variable
178− --
179− | JSVar String
180− -- |
181− -- Conditional expression
182− --
183− | JSConditional JS JS JS
184− -- |
185− -- A block of expressions in braces
186− --
187− | JSBlock [JS]
188− -- |
189− -- A variable introduction and optional initialization
190− --
191− | JSVariableIntroduction String (Maybe JS)
192− -- |
193− -- A variable assignment
194− --
195− | JSAssignment JS JS
196− -- |
197− -- While loop
198− --
199− | JSWhile JS JS
200− -- |
201− -- For loop
202− --
203− | JSFor String JS JS JS
204− -- |
205− -- ForIn loop
206− --
207− | JSForIn String JS JS
208− -- |
209− -- If-then-else statement
210− --
211− | JSIfElse JS JS (Maybe JS)
212− -- |
213− -- Return statement
214− --
215− | JSReturn JS
216− -- |
217− -- Throw statement
218− --
219− | JSThrow JS
220− -- |
221− -- Type-Of operator
222− --
223− | JSTypeOf JS
224− -- |
225− -- InstanceOf test
226− --
227− | JSInstanceOf JS JS
228− -- |
229− -- Labelled statement
230− --
231− | JSLabel String JS
232− -- |
233− -- Break statement
234− --
235− | JSBreak String
236− -- |
237− -- Continue statement
238− --
239− | JSContinue String
240− -- |
241− -- Raw Javascript (generated when parsing fails for an inline foreign import declaration)
242− --
243− | JSRaw String deriving (Show, Eq, Data, Typeable)
244−
245−--
246−-- Traversals
247−--
248−
249−everywhereOnJS :: (JS -> JS) -> JS -> JS
250−everywhereOnJS f = go
251− where
252− go :: JS -> JS
253− go (JSUnary op j) = f (JSUnary op (go j))
254− go (JSBinary op j1 j2) = f (JSBinary op (go j1) (go j2))
255− go (JSArrayLiteral js) = f (JSArrayLiteral (map go js))
256− go (JSIndexer j1 j2) = f (JSIndexer (go j1) (go j2))
257− go (JSObjectLiteral js) = f (JSObjectLiteral (map (fmap go) js))
258− go (JSAccessor prop j) = f (JSAccessor prop (go j))
259− go (JSFunction name args j) = f (JSFunction name args (go j))
260− go (JSApp j js) = f (JSApp (go j) (map go js))
261− go (JSConditional j1 j2 j3) = f (JSConditional (go j1) (go j2) (go j3))
262− go (JSBlock js) = f (JSBlock (map go js))
263− go (JSVariableIntroduction name j) = f (JSVariableIntroduction name (fmap go j))
264− go (JSAssignment j1 j2) = f (JSAssignment (go j1) (go j2))
265− go (JSWhile j1 j2) = f (JSWhile (go j1) (go j2))
266− go (JSFor name j1 j2 j3) = f (JSFor name (go j1) (go j2) (go j3))
267− go (JSForIn name j1 j2) = f (JSForIn name (go j1) (go j2))
268− go (JSIfElse j1 j2 j3) = f (JSIfElse (go j1) (go j2) (fmap go j3))
269− go (JSReturn js) = f (JSReturn (go js))
270− go (JSThrow js) = f (JSThrow (go js))
271− go (JSTypeOf js) = f (JSTypeOf (go js))
272− go (JSLabel name js) = f (JSLabel name (go js))
273− go (JSInstanceOf j1 j2) = f (JSInstanceOf (go j1) (go j2))
274− go other = f other
275−
276−everywhereOnJSTopDown :: (JS -> JS) -> JS -> JS
277−everywhereOnJSTopDown f = go . f
278− where
279− go :: JS -> JS
280− go (JSUnary op j) = JSUnary op (go (f j))
281− go (JSBinary op j1 j2) = JSBinary op (go (f j1)) (go (f j2))
282− go (JSArrayLiteral js) = JSArrayLiteral (map (go . f) js)
283− go (JSIndexer j1 j2) = JSIndexer (go (f j1)) (go (f j2))
284− go (JSObjectLiteral js) = JSObjectLiteral (map (fmap (go . f)) js)
285− go (JSAccessor prop j) = JSAccessor prop (go (f j))
286− go (JSFunction name args j) = JSFunction name args (go (f j))
287− go (JSApp j js) = JSApp (go (f j)) (map (go . f) js)
288− go (JSConditional j1 j2 j3) = JSConditional (go (f j1)) (go (f j2)) (go (f j3))
289− go (JSBlock js) = JSBlock (map (go . f) js)
290− go (JSVariableIntroduction name j) = JSVariableIntroduction name (fmap (go . f) j)
291− go (JSAssignment j1 j2) = JSAssignment (go (f j1)) (go (f j2))
292− go (JSWhile j1 j2) = JSWhile (go (f j1)) (go (f j2))
293− go (JSFor name j1 j2 j3) = JSFor name (go (f j1)) (go (f j2)) (go (f j3))
294− go (JSForIn name j1 j2) = JSForIn name (go (f j1)) (go (f j2))
295− go (JSIfElse j1 j2 j3) = JSIfElse (go (f j1)) (go (f j2)) (fmap (go . f) j3)
296− go (JSReturn j) = JSReturn (go (f j))
297− go (JSThrow j) = JSThrow (go (f j))
298− go (JSTypeOf j) = JSTypeOf (go (f j))
299− go (JSLabel name j) = JSLabel name (go (f j))
300− go (JSInstanceOf j1 j2) = JSInstanceOf (go (f j1)) (go (f j2))
301− go other = f other
302−
303−everythingOnJS :: (r -> r -> r) -> (JS -> r) -> JS -> r
304−everythingOnJS (<>) f = go
305− where
306− go j@(JSUnary _ j1) = f j <> go j1
307− go j@(JSBinary _ j1 j2) = f j <> go j1 <> go j2
308− go j@(JSArrayLiteral js) = foldl (<>) (f j) (map go js)
309− go j@(JSIndexer j1 j2) = f j <> go j1 <> go j2
310− go j@(JSObjectLiteral js) = foldl (<>) (f j) (map (go . snd) js)
311− go j@(JSAccessor _ j1) = f j <> go j1
312− go j@(JSFunction _ _ j1) = f j <> go j1
313− go j@(JSApp j1 js) = foldl (<>) (f j <> go j1) (map go js)
314− go j@(JSConditional j1 j2 j3) = f j <> go j1 <> go j2 <> go j3
315− go j@(JSBlock js) = foldl (<>) (f j) (map go js)
316− go j@(JSVariableIntroduction _ (Just j1)) = f j <> go j1
317− go j@(JSAssignment j1 j2) = f j <> go j1 <> go j2
318− go j@(JSWhile j1 j2) = f j <> go j1 <> go j2
319− go j@(JSFor _ j1 j2 j3) = f j <> go j1 <> go j2 <> go j3
320− go j@(JSForIn _ j1 j2) = f j <> go j1 <> go j2
321− go j@(JSIfElse j1 j2 Nothing) = f j <> go j1 <> go j2
322− go j@(JSIfElse j1 j2 (Just j3)) = f j <> go j1 <> go j2 <> go j3
323− go j@(JSReturn j1) = f j <> go j1
324− go j@(JSThrow j1) = f j <> go j1
325− go j@(JSTypeOf j1) = f j <> go j1
326− go j@(JSLabel _ j1) = f j <> go j1
327− go j@(JSInstanceOf j1 j2) = f j <> go j1 <> go j2
328− go other = f other
src/Language/PureScript/CodeGen/JS/Common.hsdeleted−141
@@ -1,141 +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" ]
139−
140−moduleNameToJs :: ModuleName -> String
141−moduleNameToJs (ModuleName pns) = intercalate "_" (runProperName `map` pns)
src/Language/PureScript/CodeGen/JS/Optimizer.hsdeleted−76
@@ -1,76 +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−module Language.PureScript.CodeGen.JS.Optimizer (
35− optimize
36−) where
37−
38−import Language.PureScript.CodeGen.JS.AST
39−import Language.PureScript.Options
40−import qualified Language.PureScript.Constants as C
41−
42−import Language.PureScript.CodeGen.JS.Optimizer.Common
43−import Language.PureScript.CodeGen.JS.Optimizer.TCO
44−import Language.PureScript.CodeGen.JS.Optimizer.MagicDo
45−import Language.PureScript.CodeGen.JS.Optimizer.Inliner
46−import Language.PureScript.CodeGen.JS.Optimizer.Unused
47−import Language.PureScript.CodeGen.JS.Optimizer.Blocks
48−
49−-- |
50−-- Apply a series of optimizer passes to simplified Javascript code
51−--
52−optimize :: Options mode -> JS -> JS
53−optimize opts | optionsNoOptimizations opts = id
54− | otherwise = untilFixedPoint (applyAll
55− [ collapseNestedBlocks
56− , collapseNestedIfs
57− , tco opts
58− , magicDo opts
59− , removeCodeAfterReturnStatements
60− , removeUnusedArg
61− , removeUndefinedApp
62− , unThunk
63− , etaConvert
64− , evaluateIifes
65− , inlineVariables
66− , inlineOperator (C.prelude, (C.$)) $ \f x -> JSApp f [x]
67− , inlineOperator (C.prelude, (C.#)) $ \x f -> JSApp f [x]
68− , inlineOperator (C.preludeUnsafe, C.unsafeIndex) $ flip JSIndexer
69− , inlineCommonOperators ])
70−
71−untilFixedPoint :: (Eq a) => (a -> a) -> a -> a
72−untilFixedPoint f = go
73− where
74− go a = let a' = f a in
75− if a' == a then a' else go a'
76−
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−191
@@ -1,191 +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− inlineOperator,
19− inlineCommonOperators,
20− etaConvert,
21− unThunk,
22− evaluateIifes
23−) where
24−
25−import Data.Maybe (fromMaybe)
26−
27−import Language.PureScript.CodeGen.JS.AST
28−import Language.PureScript.CodeGen.JS.Common
29−import Language.PureScript.Names
30−import Language.PureScript.CodeGen.JS.Optimizer.Common
31−import qualified Language.PureScript.Constants as C
32−
33−shouldInline :: JS -> Bool
34−shouldInline (JSVar _) = True
35−shouldInline (JSNumericLiteral _) = True
36−shouldInline (JSStringLiteral _) = True
37−shouldInline (JSBooleanLiteral _) = True
38−shouldInline (JSAccessor _ val) = shouldInline val
39−shouldInline (JSIndexer index val) = shouldInline index && shouldInline val
40−shouldInline _ = False
41−
42−etaConvert :: JS -> JS
43−etaConvert = everywhereOnJS convert
44− where
45− convert :: JS -> JS
46− convert (JSBlock [JSReturn (JSApp (JSFunction Nothing idents block@(JSBlock body)) args)])
47− | all shouldInline args &&
48− not (any (`isRebound` block) (map JSVar idents)) &&
49− not (any (`isRebound` block) args)
50− = JSBlock (map (replaceIdents (zip idents args)) body)
51− convert (JSFunction Nothing [] (JSBlock [JSReturn (JSApp fn [])])) = fn
52− convert js = js
53−
54−unThunk :: JS -> JS
55−unThunk = everywhereOnJS convert
56− where
57− convert :: JS -> JS
58− convert (JSBlock []) = JSBlock []
59− convert (JSBlock jss) =
60− case last jss of
61− JSReturn (JSApp (JSFunction Nothing [] (JSBlock body)) []) -> JSBlock $ init jss ++ body
62− _ -> JSBlock jss
63− convert js = js
64−
65−evaluateIifes :: JS -> JS
66−evaluateIifes = everywhereOnJS convert
67− where
68− convert :: JS -> JS
69− convert (JSApp (JSFunction Nothing [] (JSBlock [JSReturn ret])) []) = ret
70− convert js = js
71−
72−inlineVariables :: JS -> JS
73−inlineVariables = everywhereOnJS $ removeFromBlock go
74− where
75− go :: [JS] -> [JS]
76− go [] = []
77− go (JSVariableIntroduction var (Just js) : sts)
78− | shouldInline js && not (any (isReassigned var) sts) && not (any (isRebound js) sts) && not (any (isUpdated var) sts) =
79− go (map (replaceIdent var js) sts)
80− go (s:sts) = s : go sts
81−
82−inlineOperator :: (String, String) -> (JS -> JS -> JS) -> JS -> JS
83−inlineOperator (m, op) f = everywhereOnJS convert
84− where
85− convert :: JS -> JS
86− convert (JSApp (JSApp op' [x]) [y]) | isOp op' = f x y
87− convert other = other
88− isOp (JSAccessor longForm (JSVar m')) = m == m' && longForm == identToJs (Op op)
89− isOp (JSIndexer (JSStringLiteral op') (JSVar m')) = m == m' && op == op'
90− isOp _ = False
91−
92−inlineCommonOperators :: JS -> JS
93−inlineCommonOperators = applyAll $
94− [ binary C.numNumber (C.+) Add
95− , binary C.numNumber (C.-) Subtract
96− , binary C.numNumber (C.*) Multiply
97− , binary C.numNumber (C./) Divide
98− , binary C.numNumber (C.%) Modulus
99− , unary C.numNumber C.negate Negate
100−
101− , binary C.ordNumber (C.<) LessThan
102− , binary C.ordNumber (C.>) GreaterThan
103− , binary C.ordNumber (C.<=) LessThanOrEqualTo
104− , binary C.ordNumber (C.>=) GreaterThanOrEqualTo
105−
106− , binary C.eqNumber (C.==) EqualTo
107− , binary C.eqNumber (C./=) NotEqualTo
108− , binary C.eqString (C.==) EqualTo
109− , binary C.eqString (C./=) NotEqualTo
110− , binary C.eqBoolean (C.==) EqualTo
111− , binary C.eqBoolean (C./=) NotEqualTo
112−
113− , binary C.semigroupString (C.<>) Add
114− , binary C.semigroupString (C.++) Add
115−
116− , binaryFunction C.bitsNumber C.shl ShiftLeft
117− , binaryFunction C.bitsNumber C.shr ShiftRight
118− , binaryFunction C.bitsNumber C.zshr ZeroFillShiftRight
119− , binary C.bitsNumber (C..&.) BitwiseAnd
120− , binary C.bitsNumber (C..|.) BitwiseOr
121− , binary C.bitsNumber (C..^.) BitwiseXor
122− , unary C.bitsNumber C.complement BitwiseNot
123−
124− , binary C.boolLikeBoolean (C.&&) And
125− , binary C.boolLikeBoolean (C.||) Or
126− , unary C.boolLikeBoolean C.not Not
127− ] ++
128− [ fn | i <- [0..10], fn <- [ mkFn i, runFn i ] ]
129− where
130− binary :: String -> String -> BinaryOperator -> JS -> JS
131− binary dictName opString op = everywhereOnJS convert
132− where
133− convert :: JS -> JS
134− convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isOp fn && isOpDict dictName dict = JSBinary op x y
135− convert other = other
136− isOp (JSAccessor longForm (JSAccessor prelude (JSVar _))) = prelude == C.prelude && longForm == identToJs (Op opString)
137− isOp (JSIndexer (JSStringLiteral op') (JSVar prelude)) = prelude == C.prelude && opString == op'
138− isOp _ = False
139− binaryFunction :: String -> String -> BinaryOperator -> JS -> JS
140− binaryFunction dictName fnName op = everywhereOnJS convert
141− where
142− convert :: JS -> JS
143− convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isOp fn && isOpDict dictName dict = JSBinary op x y
144− convert other = other
145− isOp (JSAccessor fnName' (JSVar prelude)) = prelude == C.prelude && fnName == fnName'
146− isOp _ = False
147− unary :: String -> String -> UnaryOperator -> JS -> JS
148− unary dictName fnName op = everywhereOnJS convert
149− where
150− convert :: JS -> JS
151− convert (JSApp (JSApp fn [dict]) [x]) | isOp fn && isOpDict dictName dict = JSUnary op x
152− convert other = other
153− isOp (JSAccessor fnName' (JSVar prelude)) = prelude == C.prelude && fnName' == fnName
154− isOp _ = False
155− isOpDict dictName (JSAccessor prop (JSVar prelude)) = prelude == C.prelude && prop == dictName
156− isOpDict _ _ = False
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
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/Constants.hsdeleted−224
@@ -1,224 +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−return :: String
109−return = "return"
110−
111−pure' :: String
112−pure' = "pure"
113−
114−returnEscaped :: String
115−returnEscaped = "$return"
116−
117−untilE :: String
118−untilE = "untilE"
119−
120−whileE :: String
121−whileE = "whileE"
122−
123−runST :: String
124−runST = "runST"
125−
126−stRefValue :: String
127−stRefValue = "value"
128−
129−newSTRef :: String
130−newSTRef = "newSTRef"
131−
132−readSTRef :: String
133−readSTRef = "readSTRef"
134−
135−writeSTRef :: String
136−writeSTRef = "writeSTRef"
137−
138−modifySTRef :: String
139−modifySTRef = "modifySTRef"
140−
141−mkFn :: String
142−mkFn = "mkFn"
143−
144−runFn :: String
145−runFn = "runFn"
146−
147−unit :: String
148−unit = "unit"
149−
150−-- Prim values
151−
152−undefined :: String
153−undefined = "undefined"
154−
155−-- Type Class Dictionary Names
156−
157−monadEffDictionary :: String
158−monadEffDictionary = "monadEff"
159−
160−applicativeEffDictionary :: String
161−applicativeEffDictionary = "applicativeEff"
162−
163−bindEffDictionary :: String
164−bindEffDictionary = "bindEff"
165−
166−numNumber :: String
167−numNumber = "numNumber"
168−
169−ordNumber :: String
170−ordNumber = "ordNumber"
171−
172−eqNumber :: String
173−eqNumber = "eqNumber"
174−
175−eqString :: String
176−eqString = "eqString"
177−
178−eqBoolean :: String
179−eqBoolean = "eqBoolean"
180−
181−bitsNumber :: String
182−bitsNumber = "bitsNumber"
183−
184−boolLikeBoolean :: String
185−boolLikeBoolean = "boolLikeBoolean"
186−
187−semigroupString :: String
188−semigroupString = "semigroupString"
189−
190−semigroupoidArr :: String
191−semigroupoidArr = "semigroupoidArr"
192−
193−-- Main module
194−
195−main :: String
196−main = "main"
197−
198−-- Code Generation
199−
200−__superclass_ :: String
201−__superclass_ = "__superclass_"
202−
203−__unused :: String
204−__unused = "__unused"
205−
206−-- Modules
207−
208−prim :: String
209−prim = "Prim"
210−
211−prelude :: String
212−prelude = "Prelude"
213−
214−preludeUnsafe :: String
215−preludeUnsafe = "Prelude_Unsafe"
216−
217−eff :: String
218−eff = "Control_Monad_Eff"
219−
220−st :: String
221−st = "Control_Monad_ST"
222−
223−dataFunction :: String
224−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−30
@@ -1,30 +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−
21−-- |
22−-- Type alias for basic annotations
23−--
24−type Ann = (Maybe SourceSpan, Maybe Type, Maybe Meta)
25−
26−-- |
27−-- Initial annotation with no metadata
28−--
29−nullAnn :: Ann
30−nullAnn = (Nothing, Nothing, Nothing)
src/Language/PureScript/CoreFn/Binders.hsdeleted−47
@@ -1,47 +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−
17−module Language.PureScript.CoreFn.Binders where
18−
19−import qualified Data.Data as D
20−
21−import Language.PureScript.CoreFn.Literals
22−import Language.PureScript.Names
23−
24−-- |
25−-- Data type for binders
26−--
27−data Binder a
28− -- |
29− -- Wildcard binder
30− --
31− = NullBinder a
32− -- |
33− -- A binder which matches a literal value
34− --
35− | LiteralBinder a (Literal (Binder a))
36− -- |
37− -- A binder which binds an identifier
38− --
39− | VarBinder a Ident
40− -- |
41− -- A binder which matches a data constructor (type name, constructor name, binders)
42− --
43− | ConstructorBinder a (Qualified ProperName) (Qualified ProperName) [Binder a]
44− -- |
45− -- A binder which binds its input to an identifier
46− --
47− | NamedBinder a Ident (Binder a) deriving (Show, D.Data, D.Typeable)
src/Language/PureScript/CoreFn/Desugar.hsdeleted−242
@@ -1,242 +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 qualified Language.PureScript.AST as A
37−import qualified Language.PureScript.Constants as C
38−
39−-- |
40−-- Desugars a module from AST to CoreFn representation.
41−--
42−moduleToCoreFn :: Environment -> A.Module -> Module Ann
43−moduleToCoreFn env (A.Module mn decls (Just exps)) =
44− let imports = nub $ mapMaybe importToCoreFn decls ++ findQualModules decls
45− exps' = nub $ concatMap exportToCoreFn exps
46− externs = nub $ mapMaybe externToCoreFn decls
47− decls' = concatMap (declToCoreFn env Nothing) decls
48− in Module mn imports exps' externs decls'
49−moduleToCoreFn _ (A.Module{}) =
50− error "Module exports were not elaborated before moduleToCoreFn"
51−
52−findQualModules :: [A.Declaration] -> [ModuleName]
53−findQualModules decls =
54− let (f, _, _, _, _) = everythingOnValues (++) (const []) fqValues (const []) (const []) (const [])
55− in f `concatMap` decls
56− where
57− fqValues :: A.Expr -> [ModuleName]
58− fqValues (A.Var (Qualified (Just mn) _)) = [mn]
59− fqValues _ = []
60−
61−-- |
62−-- Desugars import declarations from AST to CoreFn representation.
63−--
64−importToCoreFn :: A.Declaration -> Maybe ModuleName
65−importToCoreFn (A.ImportDeclaration name _ _) = Just name
66−importToCoreFn (A.PositionedDeclaration _ d) = importToCoreFn d
67−importToCoreFn _ = Nothing
68−
69−-- |
70−-- Desugars foreign declarations from AST to CoreFn representation.
71−--
72−externToCoreFn :: A.Declaration -> Maybe ForeignDecl
73−externToCoreFn (A.ExternDeclaration _ name js ty) = Just (name, js, ty)
74−externToCoreFn (A.ExternInstanceDeclaration name _ _ _) = Just (name, Nothing, tyObject)
75−externToCoreFn (A.PositionedDeclaration _ d) = externToCoreFn d
76−externToCoreFn _ = Nothing
77−
78−-- |
79−-- Desugars export declarations references from AST to CoreFn representation.
80−-- CoreFn modules only export values, so all data constructors, class
81−-- constructor, instances and values are flattened into one list.
82−--
83−exportToCoreFn :: A.DeclarationRef -> [Ident]
84−exportToCoreFn (A.TypeRef _ (Just dctors)) = map properToIdent dctors
85−exportToCoreFn (A.ValueRef name) = [name]
86−exportToCoreFn (A.TypeClassRef name) = [properToIdent name]
87−exportToCoreFn (A.TypeInstanceRef name) = [name]
88−exportToCoreFn (A.PositionedDeclarationRef _ d) = exportToCoreFn d
89−exportToCoreFn _ = []
90−
91−-- |
92−-- Desugars member declarations from AST to CoreFn representation.
93−--
94−declToCoreFn :: Environment -> Maybe SourceSpan -> A.Declaration -> [Bind Ann]
95−declToCoreFn _ ss (A.DataDeclaration Newtype _ _ [(ctor, _)]) =
96− [NonRec (properToIdent ctor) $
97− Abs (ss, Nothing, Just IsNewtype) (Ident "x") (Var nullAnn $ Qualified Nothing (Ident "x"))]
98−declToCoreFn _ _ d@(A.DataDeclaration Newtype _ _ _) =
99− error $ "Found newtype with multiple constructors: " ++ show d
100−declToCoreFn _ ss (A.DataDeclaration Data tyName _ ctors) =
101− flip map ctors $ \(ctor, tys) ->
102− NonRec (properToIdent ctor) $ Constructor (ss, Nothing, Nothing) tyName ctor (length tys)
103−declToCoreFn env ss (A.DataBindingGroupDeclaration ds) = concatMap (declToCoreFn env ss) ds
104−declToCoreFn env ss (A.ValueDeclaration name _ _ (Right e)) =
105− [NonRec name (exprToCoreFn env ss Nothing e)]
106−declToCoreFn env ss (A.BindingGroupDeclaration ds) =
107− [Rec $ map (\(name, _, e) -> (name, exprToCoreFn env ss Nothing e)) ds]
108−declToCoreFn _ ss (A.TypeClassDeclaration name _ supers members) =
109− [NonRec (properToIdent name) $ mkTypeClassConstructor ss supers members]
110−declToCoreFn env _ (A.PositionedDeclaration ss d) =
111− declToCoreFn env (Just ss) d
112−declToCoreFn _ _ _ = []
113−
114−-- |
115−-- Makes a typeclass dictionary constructor function. The returned expression
116−-- is a function that accepts the superclass instances and member
117−-- implementations and returns a record for the instance dictionary.
118−--
119−mkTypeClassConstructor :: Maybe SourceSpan -> [Constraint] -> [A.Declaration] -> Expr Ann
120−mkTypeClassConstructor ss [] [] = Literal (ss, Nothing, Just IsTypeClassConstructor) (ObjectLiteral [])
121−mkTypeClassConstructor ss supers members =
122− let args@(a:as) = sort $ map typeClassMemberName members ++ superClassDictionaryNames supers
123− props = [ (arg, Var nullAnn $ Qualified Nothing (Ident arg)) | arg <- args ]
124− dict = Literal nullAnn (ObjectLiteral props)
125− in Abs (ss, Nothing, Just IsTypeClassConstructor)
126− (Ident a)
127− (foldr (Abs nullAnn . Ident) dict as)
128−
129−-- |
130−-- Desugars expressions from AST to CoreFn representation.
131−--
132−exprToCoreFn :: Environment -> Maybe SourceSpan -> Maybe Type -> A.Expr -> Expr Ann
133−exprToCoreFn _ ss ty (A.NumericLiteral v) =
134− Literal (ss, ty, Nothing) (NumericLiteral v)
135−exprToCoreFn _ ss ty (A.StringLiteral v) =
136− Literal (ss, ty, Nothing) (StringLiteral v)
137−exprToCoreFn _ ss ty (A.BooleanLiteral v) =
138− Literal (ss, ty, Nothing) (BooleanLiteral v)
139−exprToCoreFn env ss ty (A.ArrayLiteral vs) =
140− Literal (ss, ty, Nothing) (ArrayLiteral $ map (exprToCoreFn env ss Nothing) vs)
141−exprToCoreFn env ss ty (A.ObjectLiteral vs) =
142− Literal (ss, ty, Nothing) (ObjectLiteral $ map (second (exprToCoreFn env ss Nothing)) vs)
143−exprToCoreFn env ss ty (A.Accessor name v) =
144− Accessor (ss, ty, Nothing) name (exprToCoreFn env ss Nothing v)
145−exprToCoreFn env ss ty (A.ObjectUpdate obj vs) =
146− ObjectUpdate (ss, ty, Nothing) (exprToCoreFn env ss Nothing obj) $ map (second (exprToCoreFn env ss Nothing)) vs
147−exprToCoreFn env ss ty (A.Abs (Left name) v) =
148− Abs (ss, ty, Nothing) name (exprToCoreFn env ss Nothing v)
149−exprToCoreFn _ _ _ (A.Abs _ _) =
150− error "Abs with Binder argument was not desugared before exprToCoreFn"
151−exprToCoreFn env ss ty (A.App v1 v2) =
152− App (ss, ty, Nothing) (exprToCoreFn env ss Nothing v1) (exprToCoreFn env ss Nothing v2)
153−exprToCoreFn _ ss ty (A.Var ident) =
154− Var (ss, ty, Nothing) ident
155−exprToCoreFn env ss ty (A.IfThenElse v1 v2 v3) =
156− Case (ss, ty, Nothing) [exprToCoreFn env ss Nothing v1]
157− [ CaseAlternative [LiteralBinder nullAnn $ BooleanLiteral True]
158− (Right $ exprToCoreFn env Nothing Nothing v2)
159− , CaseAlternative [LiteralBinder nullAnn $ BooleanLiteral False]
160− (Right $ exprToCoreFn env Nothing Nothing v3) ]
161−exprToCoreFn env ss ty (A.Constructor name) =
162− Var (ss, ty, Just $ getConstructorMeta env name) $ fmap properToIdent name
163−exprToCoreFn env ss ty (A.Case vs alts) =
164− Case (ss, ty, Nothing) (map (exprToCoreFn env ss Nothing) vs) (map (altToCoreFn env ss) alts)
165−exprToCoreFn env ss _ (A.TypedValue _ v ty) =
166− exprToCoreFn env ss (Just ty) v
167−exprToCoreFn env ss ty (A.Let ds v) =
168− Let (ss, ty, Nothing) (concatMap (declToCoreFn env ss) ds) (exprToCoreFn env ss Nothing v)
169−exprToCoreFn env ss ty (A.TypeClassDictionaryConstructorApp name (A.TypedValue _ (A.ObjectLiteral vs) _)) =
170− let args = map (exprToCoreFn env ss Nothing . snd) $ sortBy (compare `on` fst) vs
171− ctor = Var (ss, Nothing, Just IsTypeClassConstructor) (fmap properToIdent name)
172− in foldl (App (ss, Nothing, Nothing)) ctor args
173−exprToCoreFn env _ ty (A.PositionedValue ss v) =
174− exprToCoreFn env (Just ss) ty v
175−exprToCoreFn _ _ _ e =
176− error $ "Unexpected value in exprToCoreFn: " ++ show e
177−
178−-- |
179−-- Desugars case alternatives from AST to CoreFn representation.
180−--
181−altToCoreFn :: Environment -> Maybe SourceSpan -> A.CaseAlternative -> CaseAlternative Ann
182−altToCoreFn env ss (A.CaseAlternative bs vs) = CaseAlternative (map (binderToCoreFn env ss) bs) (go vs)
183− where
184− go :: Either [(A.Guard, A.Expr)] A.Expr -> Either [(Guard Ann, Expr Ann)] (Expr Ann)
185− go (Left ges) = Left $ map (exprToCoreFn env ss Nothing *** exprToCoreFn env ss Nothing) ges
186− go (Right e) = Right (exprToCoreFn env ss Nothing e)
187−
188−-- |
189−-- Desugars case binders from AST to CoreFn representation.
190−--
191−binderToCoreFn :: Environment -> Maybe SourceSpan -> A.Binder -> Binder Ann
192−binderToCoreFn _ ss (A.NullBinder) =
193− NullBinder (ss, Nothing, Nothing)
194−binderToCoreFn _ ss (A.BooleanBinder b) =
195− LiteralBinder (ss, Nothing, Nothing) (BooleanLiteral b)
196−binderToCoreFn _ ss (A.StringBinder s) =
197− LiteralBinder (ss, Nothing, Nothing) (StringLiteral s)
198−binderToCoreFn _ ss (A.NumberBinder n) =
199− LiteralBinder (ss, Nothing, Nothing) (NumericLiteral n)
200−binderToCoreFn _ ss (A.VarBinder name) =
201− VarBinder (ss, Nothing, Nothing) name
202−binderToCoreFn env ss (A.ConstructorBinder dctor@(Qualified mn _) bs) =
203− let (_, tctor, _) = lookupConstructor env dctor
204− in ConstructorBinder (ss, Nothing, Just $ getConstructorMeta env dctor) (Qualified mn tctor) dctor (map (binderToCoreFn env ss) bs)
205−binderToCoreFn env ss (A.ObjectBinder bs) =
206− LiteralBinder (ss, Nothing, Nothing) (ObjectLiteral $ map (second (binderToCoreFn env ss)) bs)
207−binderToCoreFn env ss (A.ArrayBinder bs) =
208− LiteralBinder (ss, Nothing, Nothing) (ArrayLiteral $ map (binderToCoreFn env ss) bs)
209−binderToCoreFn env ss (A.ConsBinder b1 b2) =
210− let arrCtor = Qualified (Just $ ModuleName [ProperName "Prim"]) (ProperName "Array")
211− in ConstructorBinder (ss, Nothing, Nothing) arrCtor arrCtor $ map (binderToCoreFn env ss) [b1, b2]
212−binderToCoreFn env ss (A.NamedBinder name b) =
213− NamedBinder (ss, Nothing, Nothing) name (binderToCoreFn env ss b)
214−binderToCoreFn env _ (A.PositionedBinder ss b) =
215− binderToCoreFn env (Just ss) b
216−
217−-- |
218−-- Converts a ProperName to an Ident.
219−--
220−properToIdent :: ProperName -> Ident
221−properToIdent = Ident . runProperName
222−
223−-- |
224−-- Gets metadata for data constructors.
225−--
226−getConstructorMeta :: Environment -> Qualified ProperName -> Meta
227−getConstructorMeta env ctor =
228− case lookupConstructor env ctor of
229− (Newtype, _, _) -> IsNewtype
230− dc@(Data, _, ty) ->
231− let constructorType = if numConstructors (ctor, dc) == 1 then ProductType else SumType
232− in IsConstructor constructorType (getArity ty)
233− where
234− getArity :: Type -> Int
235− getArity (TypeApp (TypeApp f _) t) | f == tyFunction = getArity t + 1
236− getArity (ForAll _ ty _) = getArity ty
237− getArity _ = 0
238− numConstructors :: (Qualified ProperName, (DataDeclType, ProperName, Type)) -> Int
239− numConstructors ty = length $ filter (((==) `on` typeConstructor) ty) $ M.toList $ dataConstructors env
240− typeConstructor :: (Qualified ProperName, (DataDeclType, ProperName, Type)) -> (ModuleName, ProperName)
241− typeConstructor (Qualified (Just mn) _, (_, tyCtor, _)) = (mn, tyCtor)
242− typeConstructor _ = error "Invalid argument to typeConstructor"
src/Language/PureScript/CoreFn/Expr.hsdeleted−97
@@ -1,97 +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−
17−module Language.PureScript.CoreFn.Expr where
18−
19−import qualified Data.Data as D
20−
21−import Language.PureScript.CoreFn.Binders
22−import Language.PureScript.CoreFn.Literals
23−import Language.PureScript.CoreFn.Meta
24−import Language.PureScript.Names
25−
26−-- |
27−-- Data type for expressions and terms
28−--
29−data Expr a
30− -- |
31− -- A literal value
32− --
33− = Literal a (Literal (Expr a))
34− -- |
35− -- A data constructor (type name, constructor name, arity)
36− --
37− | Constructor a ProperName ProperName Arity
38− -- |
39− -- A record property accessor
40− --
41− | Accessor a String (Expr a)
42− -- |
43− -- Partial record update
44− --
45− | ObjectUpdate a (Expr a) [(String, Expr a)]
46− -- |
47− -- Function introduction
48− --
49− | Abs a Ident (Expr a)
50− -- |
51− -- Function application
52− --
53− | App a (Expr a) (Expr a)
54− -- |
55− -- Variable
56− --
57− | Var a (Qualified Ident)
58− -- |
59− -- A case expression
60− --
61− | Case a [Expr a] [CaseAlternative a]
62− -- |
63− -- A let binding
64− --
65− | Let a [Bind a] (Expr a) deriving (Show, D.Data, D.Typeable)
66−
67−-- |
68−-- A let or module binding.
69−--
70−data Bind a
71− -- |
72− -- Non-recursive binding for a single value
73− --
74− = NonRec Ident (Expr a)
75− -- |
76− -- Mutually recursive binding group for several values
77− --
78− | Rec [(Ident, Expr a)] deriving (Show, D.Data, D.Typeable)
79−
80−-- |
81−-- A guard is just a boolean-valued expression that appears alongside a set of binders
82−--
83−type Guard a = Expr a
84−
85−-- |
86−-- An alternative in a case statement
87−--
88−data CaseAlternative a = CaseAlternative
89− { -- |
90− -- A collection of binders with which to match the inputs
91− --
92− caseAlternativeBinders :: [Binder a]
93− -- |
94− -- The result expression or a collect of guarded expressions
95− --
96− , caseAlternativeResult :: Either [(Guard a, Expr a)] (Expr a)
97− } deriving (Show, D.Data, D.Typeable)
src/Language/PureScript/CoreFn/Literals.hsdeleted−45
@@ -1,45 +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−
17−module Language.PureScript.CoreFn.Literals where
18−
19−import qualified Data.Data as D
20−
21−-- |
22−-- Data type for literal values. Parameterised so it can be used for Exprs and
23−-- Binders.
24−--
25−data Literal a
26− -- |
27− -- A numeric literal
28− --
29− = NumericLiteral (Either Integer Double)
30− -- |
31− -- A string literal
32− --
33− | StringLiteral String
34− -- |
35− -- A boolean literal
36− --
37− | BooleanLiteral Bool
38− -- |
39− -- An array literal
40− --
41− | ArrayLiteral [a]
42− -- |
43− -- An object literal
44− --
45− | ObjectLiteral [(String, a)] deriving (Show, D.Data, D.Typeable)
src/Language/PureScript/CoreFn/Meta.hsdeleted−54
@@ -1,54 +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−-- |
22−-- Metadata annotations
23−--
24−data Meta
25− -- |
26− -- The contained value is a data constructor
27− --
28− = IsConstructor ConstructorType Arity
29− -- |
30− -- The contained value is a newtype
31− --
32− | IsNewtype
33− -- |
34− -- The contained value is a typeclass dictionary constructor
35− --
36− | IsTypeClassConstructor deriving (Show, D.Data, D.Typeable)
37−
38−-- |
39−-- Type alias for constructor arity
40−--
41−type Arity = Int
42−
43−-- |
44−-- Data constructor metadata
45−--
46−data ConstructorType
47− -- |
48− -- The constructor is for a type with a single construcor
49− --
50− = ProductType
51− -- |
52− -- The constructor is for a type with multiple construcors
53− --
54− | SumType deriving (Show, D.Data, D.Typeable)
src/Language/PureScript/CoreFn/Module.hsdeleted−30
@@ -1,30 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.CoreFn.Module
4−-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- | The CoreFn module representation
12−--
13−-----------------------------------------------------------------------------
14−
15−module Language.PureScript.CoreFn.Module where
16−
17−import Language.PureScript.CodeGen.JS.AST
18−import Language.PureScript.CoreFn.Expr
19−import Language.PureScript.Names
20−import Language.PureScript.Types
21−
22−data Module a = Module
23− { moduleName :: ModuleName
24− , moduleImports :: [ModuleName]
25− , moduleExports :: [Ident]
26− , moduleForeign :: [ForeignDecl]
27− , moduleDecls :: [Bind a]
28− } deriving (Show)
29−
30−type ForeignDecl = (Ident, Maybe JS, Type)
src/Language/PureScript/CoreFn/Traversals.hsdeleted−85
@@ -1,85 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.CoreFn.Traversals
4−-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- | CoreFn traversal helpers
12−--
13−-----------------------------------------------------------------------------
14−
15−module Language.PureScript.CoreFn.Traversals where
16−
17−import Control.Arrow (second, (***), (+++))
18−
19−import Language.PureScript.CoreFn.Binders
20−import Language.PureScript.CoreFn.Expr
21−import Language.PureScript.CoreFn.Literals
22−
23−everywhereOnValues :: (Bind a -> Bind a) ->
24− (Expr a -> Expr a) ->
25− (Binder a -> Binder a) ->
26− (Bind a -> Bind a, Expr a -> Expr a, Binder a -> Binder a)
27−everywhereOnValues f g h = (f', g', h')
28− where
29− f' (NonRec name e) = f (NonRec name (g' e))
30− f' (Rec es) = f (Rec (map (second g') es))
31−
32− g' (Literal ann e) = g (Literal ann (handleLiteral g' e))
33− g' (Accessor ann prop e) = g (Accessor ann prop (g' e))
34− g' (ObjectUpdate ann obj vs) = g (ObjectUpdate ann (g' obj) (map (fmap g') vs))
35− g' (Abs ann name e) = g (Abs ann name (g' e))
36− g' (App ann v1 v2) = g (App ann (g' v1) (g' v2))
37− g' (Case ann vs alts) = g (Case ann (map g' vs) (map handleCaseAlternative alts))
38− g' (Let ann ds e) = g (Let ann (map f' ds) (g' e))
39− g' e = g e
40−
41− h' (LiteralBinder a b) = h (LiteralBinder a (handleLiteral h' b))
42− h' (NamedBinder a name b) = h (NamedBinder a name (h' b))
43− h' b = h b
44−
45− handleCaseAlternative ca =
46− ca { caseAlternativeBinders = map h' (caseAlternativeBinders ca)
47− , caseAlternativeResult = (map (g' *** g') +++ g') (caseAlternativeResult ca)
48− }
49−
50− handleLiteral :: (a -> a) -> Literal a -> Literal a
51− handleLiteral i (ArrayLiteral ls) = ArrayLiteral (map i ls)
52− handleLiteral i (ObjectLiteral ls) = ObjectLiteral (map (fmap i) ls)
53− handleLiteral _ other = other
54−
55−everythingOnValues :: (r -> r -> r) ->
56− (Bind a -> r) ->
57− (Expr a -> r) ->
58− (Binder a -> r) ->
59− (CaseAlternative a -> r) ->
60− (Bind a -> r, Expr a -> r, Binder a -> r, CaseAlternative a -> r)
61−everythingOnValues (<>) f g h i = (f', g', h', i')
62− where
63− f' b@(NonRec _ e) = f b <> g' e
64− f' b@(Rec es) = foldl (<>) (f b) (map (g' . snd) es)
65−
66− g' v@(Literal _ l) = foldl (<>) (g v) (map g' (extractLiteral l))
67− g' v@(Accessor _ _ e1) = g v <> g' e1
68− g' v@(ObjectUpdate _ obj vs) = foldl (<>) (g v <> g' obj) (map (g' . snd) vs)
69− g' v@(Abs _ _ e1) = g v <> g' e1
70− g' v@(App _ e1 e2) = g v <> g' e1 <> g' e2
71− g' v@(Case _ vs alts) = foldl (<>) (foldl (<>) (g v) (map g' vs)) (map i' alts)
72− g' v@(Let _ ds e1) = foldl (<>) (g v) (map f' ds) <> g' e1
73− g' v = g v
74−
75− h' b@(LiteralBinder _ l) = foldl (<>) (h b) (map h' (extractLiteral l))
76− h' b@(ConstructorBinder _ _ _ bs) = foldl (<>) (h b) (map h' bs)
77− h' b@(NamedBinder _ _ b1) = h b <> h' b1
78− h' b = h b
79−
80− i' ca@(CaseAlternative bs (Right val)) = foldl (<>) (i ca) (map h' bs) <> g' val
81− i' ca@(CaseAlternative bs (Left gs)) = foldl (<>) (i ca) (map h' bs ++ concatMap (\(grd, val) -> [g' grd, g' val]) gs)
82−
83− extractLiteral (ArrayLiteral xs) = xs
84− extractLiteral (ObjectLiteral xs) = map snd xs
85− extractLiteral _ = []
src/Language/PureScript/DeadCodeElimination.hsdeleted−102
@@ -1,102 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.DeadCodeElimination
4−-- Copyright : (c) 2014 Phil Freeman
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- | Dead code elimination.
12−--
13−-----------------------------------------------------------------------------
14−
15−module Language.PureScript.DeadCodeElimination (
16− eliminateDeadCode
17−) where
18−
19−import Data.Graph
20−import Data.List
21−import Data.Maybe (mapMaybe)
22−
23−import Language.PureScript.CoreFn
24−import Language.PureScript.Names
25−
26−-- |
27−-- Eliminate all declarations which are not a transitive dependency of the entry point module
28−--
29−eliminateDeadCode :: [ModuleName] -> [Module a] -> [Module a]
30−eliminateDeadCode entryPoints ms = map go ms
31− where
32− go (Module mn imps exps foreigns ds) = Module mn imps exps' foreigns' ds'
33− where
34− ds' = filter (isUsed mn graph vertexFor entryPointVertices) ds
35− foreigns' = filter (isUsed' mn graph vertexFor entryPointVertices . foreignIdent) foreigns
36− names = concatMap bindIdents ds' ++ map foreignIdent foreigns'
37− exps' = filter (`elem` names) exps
38− declarations = concatMap declarationsByModule ms
39− (graph, _, vertexFor) = graphFromEdges $ map (\(key, deps) -> (key, key, deps)) declarations
40− entryPointVertices = mapMaybe (vertexFor . fst) . filter (\((mn, _), _) -> mn `elem` entryPoints) $ declarations
41−
42−-- |
43−-- Extract declaration names for a binding group.
44−--
45−bindIdents :: Bind a -> [Ident]
46−bindIdents (NonRec name _) = [name]
47−bindIdents (Rec names) = map fst names
48−
49−-- |
50−-- Extract the ident for a foreign declaration.
51−--
52−foreignIdent :: ForeignDecl -> Ident
53−foreignIdent (name, _, _) = name
54−
55−-- |
56−-- Key type to use in graph
57−--
58−type Key = (ModuleName, Ident)
59−
60−-- |
61−-- Find dependencies for each member in a module.
62−--
63−declarationsByModule :: Module a -> [(Key, [Key])]
64−declarationsByModule (Module mn _ _ fs ds) =
65− let fs' = map ((\name -> ((mn, name), [])) . foreignIdent) fs
66− in fs' ++ concatMap go ds
67− where
68− go :: Bind a -> [(Key, [Key])]
69− go d@(NonRec name _) = [((mn, name), dependencies d)]
70− go d@(Rec names') = map (\(name, _) -> ((mn, name), dependencies d)) names'
71−
72−-- |
73−-- Find all referenced values within a binding group.
74−--
75−dependencies :: Bind a -> [Key]
76−dependencies =
77− let (f, _, _, _) = everythingOnValues (++) (const []) values binders (const [])
78− in nub . f
79− where
80− values :: Expr a -> [Key]
81− values (Var _ (Qualified (Just mn) ident)) = [(mn, ident)]
82− values _ = []
83− binders :: Binder a -> [Key]
84− binders (ConstructorBinder _ _ (Qualified (Just mn) ident) _) = [(mn, Ident $ runProperName ident)]
85− binders _ = []
86−
87−-- |
88−-- Check whether a binding group is used.
89−--
90−isUsed :: ModuleName -> Graph -> (Key -> Maybe Vertex) -> [Vertex] -> Bind a -> Bool
91−isUsed mn graph vertexFor entryPointVertices (NonRec name _) =
92− isUsed' mn graph vertexFor entryPointVertices name
93−isUsed mn graph vertexFor entryPointVertices (Rec ds) =
94− any (isUsed' mn graph vertexFor entryPointVertices . fst) ds
95−
96−-- |
97−-- Check whether a named declaration is used.
98−--
99−isUsed' :: ModuleName -> Graph -> (Key -> Maybe Vertex) -> [Vertex] -> Ident -> Bool
100−isUsed' mn graph vertexFor entryPointVertices name =
101− let Just v' = vertexFor (mn, name)
102− in any (\v -> path graph v v') entryPointVertices
src/Language/PureScript/Environment.hsdeleted−236
@@ -1,236 +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)
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 deriving (Show, Eq, Data, Typeable)
140−
141−-- |
142−-- The type ('data' or 'newtype') of a data type declaration
143−--
144−data DataDeclType
145− -- |
146− -- A standard data constructor
147− --
148− = Data
149− -- |
150− -- A newtype constructor
151− --
152− | Newtype deriving (Eq, Ord, Data, Typeable)
153−
154−instance Show DataDeclType where
155− show Data = "data"
156− show Newtype = "newtype"
157−
158−-- |
159−-- Construct a ProperName in the Prim module
160−--
161−primName :: String -> Qualified ProperName
162−primName = Qualified (Just $ ModuleName [ProperName C.prim]) . ProperName
163−
164−-- |
165−-- Construct a type in the Prim module
166−--
167−primTy :: String -> Type
168−primTy = TypeConstructor . primName
169−
170−-- |
171−-- Type constructor for functions
172−--
173−tyFunction :: Type
174−tyFunction = primTy "Function"
175−
176−-- |
177−-- Type constructor for strings
178−--
179−tyString :: Type
180−tyString = primTy "String"
181−
182−-- |
183−-- Type constructor for numbers
184−--
185−tyNumber :: Type
186−tyNumber = primTy "Number"
187−
188−-- |
189−-- Type constructor for booleans
190−--
191−tyBoolean :: Type
192−tyBoolean = primTy "Boolean"
193−
194−-- |
195−-- Type constructor for arrays
196−--
197−tyArray :: Type
198−tyArray = primTy "Array"
199−
200−-- |
201−-- Type constructor for objects
202−--
203−tyObject :: Type
204−tyObject = primTy "Object"
205−
206−-- |
207−-- Smart constructor for function types
208−--
209−function :: Type -> Type -> Type
210−function t1 = TypeApp (TypeApp tyFunction t1)
211−
212−-- |
213−-- The primitive types in the external javascript environment with their associated kinds.
214−--
215−primTypes :: M.Map (Qualified ProperName) (Kind, TypeKind)
216−primTypes = M.fromList [ (primName "Function" , (FunKind Star (FunKind Star Star), ExternData))
217− , (primName "Array" , (FunKind Star Star, ExternData))
218− , (primName "Object" , (FunKind (Row Star) Star, ExternData))
219− , (primName "String" , (Star, ExternData))
220− , (primName "Number" , (Star, ExternData))
221− , (primName "Boolean" , (Star, ExternData)) ]
222−
223−-- |
224−-- Finds information about data constructors from the current environment.
225−--
226−lookupConstructor :: Environment -> Qualified ProperName -> (DataDeclType, ProperName, Type)
227−lookupConstructor env ctor =
228− fromMaybe (error "Data constructor not found") $ ctor `M.lookup` dataConstructors env
229−
230−-- |
231−-- Checks whether a data constructor is for a newtype.
232−--
233−isNewtypeConstructor :: Environment -> Qualified ProperName -> Bool
234−isNewtypeConstructor e ctor = case lookupConstructor e ctor of
235− (Newtype, _, _) -> True
236− (Data, _, _) -> False
src/Language/PureScript/Errors.hsdeleted−140
@@ -1,140 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.Error
4−-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- |
12−--
13−-----------------------------------------------------------------------------
14−
15−{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleContexts #-}
16−
17−module Language.PureScript.Errors where
18−
19−import Data.Either (lefts, rights)
20−import Data.List (intersperse, intercalate)
21−import Data.Monoid
22−
23−import Control.Monad.Error
24−import Control.Applicative ((<$>))
25−
26−import Language.PureScript.AST
27−import Language.PureScript.Pretty
28−import Language.PureScript.Types
29−
30−-- |
31−-- Type for sources of type checking errors
32−--
33−data ErrorSource
34− -- |
35− -- An error which originated at a Expr
36− --
37− = ExprError Expr
38− -- |
39− -- An error which originated at a Type
40− --
41− | TypeError Type deriving (Show)
42−
43−-- |
44−-- Compilation errors
45−--
46−data CompileError
47− = CompileError
48− { -- |
49− -- Error message
50− --
51− compileErrorMessage :: String
52− -- |
53− -- The value where the error occurred
54− --
55− , compileErrorValue :: Maybe ErrorSource
56− -- |
57− -- Optional source position information
58− --
59− , compileErrorPosition :: Maybe SourceSpan
60− }
61− deriving (Show)
62−
63−-- |
64−-- A stack trace for an error
65−--
66−data ErrorStack
67− = ErrorStack { runErrorStack :: [CompileError] }
68− | MultipleErrors [ErrorStack] deriving (Show)
69−
70−instance Monoid ErrorStack where
71− mempty = ErrorStack []
72− mappend (ErrorStack xs) (ErrorStack ys) = ErrorStack (xs ++ ys)
73− mappend (MultipleErrors es) x = MultipleErrors [ e <> x | e <- es ]
74− mappend x (MultipleErrors es) = MultipleErrors [ x <> e | e <- es ]
75−
76−instance Error ErrorStack where
77− strMsg s = ErrorStack [CompileError s Nothing Nothing]
78− noMsg = ErrorStack []
79−
80−prettyPrintErrorStack :: Bool -> ErrorStack -> String
81−prettyPrintErrorStack printFullStack (ErrorStack es) =
82− case mconcat $ map (Last . compileErrorPosition) es of
83− Last (Just sourcePos) -> "Error at " ++ show sourcePos ++ ": \n" ++ prettyPrintErrorStack'
84− _ -> prettyPrintErrorStack'
85− where
86− prettyPrintErrorStack' :: String
87− prettyPrintErrorStack'
88− | printFullStack = intercalate "\n" (map showError (filter isErrorNonEmpty es))
89− | otherwise =
90− let
91− es' = filter isErrorNonEmpty es
92− in case length es' of
93− 1 -> showError (head es')
94− _ -> showError (head es') ++ "\n" ++ showError (last es')
95−prettyPrintErrorStack printFullStack (MultipleErrors es) =
96− unlines $ intersperse "" $ "Multiple errors:" : map (prettyPrintErrorStack printFullStack) es
97−
98−stringifyErrorStack :: Bool -> Either ErrorStack a -> Either String a
99−stringifyErrorStack printFullStack = either (Left . prettyPrintErrorStack printFullStack) Right
100−
101−isErrorNonEmpty :: CompileError -> Bool
102−isErrorNonEmpty = not . null . compileErrorMessage
103−
104−showError :: CompileError -> String
105−showError (CompileError msg Nothing _) = msg
106−showError (CompileError msg (Just (ExprError val)) _) = "Error in expression " ++ prettyPrintValue val ++ ":\n" ++ msg
107−showError (CompileError msg (Just (TypeError ty)) _) = "Error in type " ++ prettyPrintType ty ++ ":\n" ++ msg
108−
109−mkErrorStack :: String -> Maybe ErrorSource -> ErrorStack
110−mkErrorStack msg t = ErrorStack [CompileError msg t Nothing]
111−
112−positionError :: SourceSpan -> ErrorStack
113−positionError pos = ErrorStack [CompileError "" Nothing (Just pos)]
114−
115−-- |
116−-- Rethrow an error with a more detailed error message in the case of failure
117−--
118−rethrow :: (MonadError e m) => (e -> e) -> m a -> m a
119−rethrow f = flip catchError $ \e -> throwError (f e)
120−
121−-- |
122−-- Rethrow an error with source position information
123−--
124−rethrowWithPosition :: (MonadError ErrorStack m) => SourceSpan -> m a -> m a
125−rethrowWithPosition pos = rethrow (positionError pos <>)
126−
127−-- |
128−-- Collect errors in in parallel
129−--
130−parU :: (MonadError ErrorStack m, Functor m) => [a] -> (a -> m b) -> m [b]
131−parU xs f = forM xs (withError . f) >>= collectErrors
132− where
133− withError :: (MonadError ErrorStack m, Functor m) => m a -> m (Either ErrorStack a)
134− withError u = catchError (Right <$> u) (return . Left)
135−
136− collectErrors :: (MonadError ErrorStack m, Functor m) => [Either ErrorStack a] -> m [a]
137− collectErrors es = case lefts es of
138− [err] -> throwError err
139− [] -> return $ rights es
140− errs -> throwError $ MultipleErrors errs
src/Language/PureScript/Kinds.hsdeleted−60
@@ -1,60 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.Kinds
4−-- Copyright : (c) Phil Freeman 2013
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- |
12−--
13−-----------------------------------------------------------------------------
14−
15−{-# LANGUAGE DeriveDataTypeable #-}
16−
17−module Language.PureScript.Kinds where
18−
19−import Data.Data
20−
21−import Control.Monad.Unify (Unknown)
22−
23−-- |
24−-- The data type of kinds
25−--
26−data Kind
27− -- |
28− -- Unification variable of type Kind
29− --
30− = KUnknown Unknown
31− -- |
32− -- The kind of types
33− --
34− | Star
35− -- |
36− -- The kind of effects
37− --
38− | Bang
39− -- |
40− -- Kinds for labelled, unordered rows without duplicates
41− --
42− | Row Kind
43− -- |
44− -- Function kinds
45− --
46− | FunKind Kind Kind deriving (Show, Eq, Data, Typeable)
47−
48−everywhereOnKinds :: (Kind -> Kind) -> Kind -> Kind
49−everywhereOnKinds f = go
50− where
51− go (Row k1) = f (Row (go k1))
52− go (FunKind k1 k2) = f (FunKind (go k1) (go k2))
53− go other = f other
54−
55−everythingOnKinds :: (r -> r -> r) -> (Kind -> r) -> Kind -> r
56−everythingOnKinds (<>) f = go
57− where
58− go k@(Row k1) = f k <> go k1
59− go k@(FunKind k1 k2) = f k <> go k1 <> go k2
60− go other = f other
src/Language/PureScript/ModuleDependencies.hsdeleted−76
@@ -1,76 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.ModuleDependencies
4−-- Copyright : (c) Phil Freeman 2013
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- | Provides the ability to sort modules based on module dependencies
12−--
13−-----------------------------------------------------------------------------
14−
15−module Language.PureScript.ModuleDependencies (
16− sortModules,
17− ModuleGraph
18−) where
19−
20−import Data.Graph
21−import Data.List (nub)
22−import Data.Maybe (mapMaybe)
23−
24−import Language.PureScript.AST
25−import Language.PureScript.Names
26−import Language.PureScript.Types
27−
28−-- |
29−-- A list of modules with their dependencies
30−--
31−type ModuleGraph = [(ModuleName, [ModuleName])]
32−
33−-- |
34−-- Sort a collection of modules based on module dependencies.
35−--
36−-- Reports an error if the module graph contains a cycle.
37−--
38−sortModules :: [Module] -> Either String ([Module], ModuleGraph)
39−sortModules ms = do
40− let verts = map (\m@(Module _ ds _) -> (m, getModuleName m, nub (concatMap usedModules ds))) ms
41− ms' <- mapM toModule $ stronglyConnComp verts
42− let moduleGraph = map (\(_, mn, deps) -> (mn, deps)) verts
43− return (ms', moduleGraph)
44−
45−-- |
46−-- Calculate a list of used modules based on explicit imports and qualified names
47−--
48−usedModules :: Declaration -> [ModuleName]
49−usedModules = let (f, _, _, _, _) = everythingOnValues (++) forDecls forValues (const []) (const []) (const []) in nub . f
50− where
51− forDecls :: Declaration -> [ModuleName]
52− forDecls (ImportDeclaration mn _ _) = [mn]
53− forDecls _ = []
54−
55− forValues :: Expr -> [ModuleName]
56− forValues (Var (Qualified (Just mn) _)) = [mn]
57− forValues (BinaryNoParens (Qualified (Just mn) _) _ _) = [mn]
58− forValues (Constructor (Qualified (Just mn) _)) = [mn]
59− forValues (TypedValue _ _ ty) = forTypes ty
60− forValues _ = []
61−
62− forTypes :: Type -> [ModuleName]
63− forTypes (TypeConstructor (Qualified (Just mn) _)) = [mn]
64− forTypes (ConstrainedType cs _) = mapMaybe (\(Qualified mn _, _) -> mn) cs
65− forTypes _ = []
66−
67−getModuleName :: Module -> ModuleName
68−getModuleName (Module mn _ _) = mn
69−
70−-- |
71−-- Convert a strongly connected component of the module graph to a module
72−--
73−toModule :: SCC Module -> Either String Module
74−toModule (AcyclicSCC m) = return m
75−toModule (CyclicSCC [m]) = return m
76−toModule (CyclicSCC ms) = Left $ "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−89
@@ -1,89 +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− -- Specify the namespace that PureScript modules will be exported to when running in the
74− -- browser.
75− --
76− , optionsAdditional :: ModeOptions mode
77− } deriving Show
78−
79−-- |
80−-- Default compiler options
81−--
82−defaultCompileOptions :: Options Compile
83−defaultCompileOptions = Options False False False Nothing False False (CompileOptions "PS" [] [])
84−
85−-- |
86−-- Default make options
87−--
88−defaultMakeOptions :: Options Make
89−defaultMakeOptions = Options False False False Nothing 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−133
@@ -1,133 +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.Parser.Lexer
24−import Language.PureScript.Parser.State
25−import Language.PureScript.Names
26−
27−import qualified Text.Parsec as P
28−
29−properName :: TokenParser ProperName
30−properName = ProperName <$> uname
31−
32−-- |
33−-- Parse a module name
34−--
35−moduleName :: TokenParser ModuleName
36−moduleName = part []
37− where
38− part path = (do name <- ProperName <$> P.try qualifier
39− part (path `snoc` name))
40− <|> (ModuleName . snoc path . ProperName <$> mname)
41− snoc path name = path ++ [name]
42−
43−-- |
44−-- Parse a qualified name, i.e. M.name or just name
45−--
46−parseQualified :: TokenParser a -> TokenParser (Qualified a)
47−parseQualified parser = part []
48− where
49− part path = (do name <- ProperName <$> P.try qualifier
50− part (updatePath path name))
51− <|> (Qualified (qual path) <$> P.try parser)
52− updatePath path name = path ++ [name]
53− qual path = if null path then Nothing else Just $ ModuleName path
54−
55−-- |
56−-- Parse an identifier or parenthesized operator
57−--
58−parseIdent :: TokenParser Ident
59−parseIdent = (Ident <$> identifier) <|> (Op <$> parens symbol)
60−
61−-- |
62−-- Run the first parser, then match the second if possible, applying the specified function on a successful match
63−--
64−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
65−augment p q f = flip (maybe id $ flip f) <$> p <*> P.optionMaybe q
66−
67−-- |
68−-- Run the first parser, then match the second zero or more times, applying the specified function for each match
69−--
70−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
71−fold first more combine = do
72− a <- first
73− bs <- P.many more
74− return $ foldl combine a bs
75−
76−-- |
77−-- Build a parser from a smaller parser and a list of parsers for postfix operators
78−--
79−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
80−buildPostfixParser fs first = do
81− a <- first
82− go a
83− where
84− go a = do
85− maybeA <- P.optionMaybe $ P.choice (map ($ a) fs)
86− case maybeA of
87− Nothing -> return a
88− Just a' -> go a'
89−
90−-- |
91−-- Parse an identifier in backticks or an operator
92−--
93−parseIdentInfix :: TokenParser (Qualified Ident)
94−parseIdentInfix = P.between tick tick (parseQualified (Ident <$> identifier)) <|> (parseQualified (Op <$> symbol))
95−
96−-- |
97−-- Mark the current indentation level
98−--
99−mark :: P.Parsec s ParseState a -> P.Parsec s ParseState a
100−mark p = do
101− current <- indentationLevel <$> P.getState
102− pos <- P.sourceColumn <$> P.getPosition
103− P.modifyState $ \st -> st { indentationLevel = pos }
104− a <- p
105− P.modifyState $ \st -> st { indentationLevel = current }
106− return a
107−
108−-- |
109−-- Check that the current identation level matches a predicate
110−--
111−checkIndentation :: (P.Column -> P.Column -> Bool) -> P.Parsec s ParseState ()
112−checkIndentation rel = do
113− col <- P.sourceColumn <$> P.getPosition
114− current <- indentationLevel <$> P.getState
115− guard (col `rel` current)
116−
117−-- |
118−-- Check that the current indentation level is past the current mark
119−--
120−indented :: P.Parsec s ParseState ()
121−indented = checkIndentation (>) P.<?> "indentation"
122−
123−-- |
124−-- Check that the current indentation level is at the same indentation as the current mark
125−--
126−same :: P.Parsec s ParseState ()
127−same = checkIndentation (==) P.<?> "no indentation"
128−
129−-- |
130−-- Run a parser
131−--
132−runTokenParser :: FilePath -> TokenParser a -> [PositionedToken] -> Either P.ParseError a
133−runTokenParser filePath p = P.runParser p (ParseState 0) filePath
src/Language/PureScript/Parser/Declarations.hsdeleted−488
@@ -1,488 +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.Parser.Common
39−import Language.PureScript.AST
40−import Language.PureScript.Parser.Types
41−import Language.PureScript.Parser.Kinds
42−import Language.PureScript.Parser.Lexer
43−import Language.PureScript.CodeGen.JS.AST
44−import Language.PureScript.Environment
45−
46−import qualified Language.PureScript.Parser.Common as C
47−import qualified Text.Parsec as P
48−import qualified Text.Parsec.Expr as P
49−
50−-- |
51−-- Read source position information
52−--
53−withSourceSpan :: (SourceSpan -> a -> a) -> P.Parsec s u a -> P.Parsec s u a
54−withSourceSpan f p = do
55− start <- P.getPosition
56− x <- p
57− end <- P.getPosition
58− let sp = SourceSpan (P.sourceName start) (toSourcePos start) (toSourcePos end)
59− return $ f sp x
60− where
61− toSourcePos pos = SourcePos (P.sourceLine pos) (P.sourceColumn pos)
62−
63−kindedIdent :: TokenParser (String, Maybe Kind)
64−kindedIdent = (, Nothing) <$> identifier
65− <|> parens ((,) <$> identifier <*> (Just <$> (indented *> doubleColon *> indented *> parseKind)))
66−
67−parseDataDeclaration :: TokenParser Declaration
68−parseDataDeclaration = do
69− dtype <- (reserved "data" *> return Data) <|> (reserved "newtype" *> return Newtype)
70− name <- indented *> properName
71− tyArgs <- many (indented *> kindedIdent)
72− ctors <- P.option [] $ do
73− indented *> equals
74− P.sepBy1 ((,) <$> properName <*> P.many (indented *> noWildcards parseTypeAtom)) pipe
75− return $ DataDeclaration dtype name tyArgs ctors
76−
77−parseTypeDeclaration :: TokenParser Declaration
78−parseTypeDeclaration =
79− TypeDeclaration <$> P.try (parseIdent <* indented <* doubleColon)
80− <*> parsePolyType
81−
82−parseTypeSynonymDeclaration :: TokenParser Declaration
83−parseTypeSynonymDeclaration =
84− TypeSynonymDeclaration <$> (P.try (reserved "type") *> indented *> properName)
85− <*> many (indented *> kindedIdent)
86− <*> (indented *> equals *> noWildcards parsePolyType)
87−
88−parseValueDeclaration :: TokenParser Declaration
89−parseValueDeclaration = do
90− name <- parseIdent
91− binders <- P.many parseBinderNoParens
92− value <- Left <$> (C.indented *>
93− P.many1 ((,) <$> parseGuard
94− <*> (indented *> equals *> parseValueWithWhereClause)
95− ))
96− <|> Right <$> (indented *> equals *> parseValueWithWhereClause)
97− return $ ValueDeclaration name Value binders value
98− where
99− parseValueWithWhereClause :: TokenParser Expr
100− parseValueWithWhereClause = do
101− value <- parseValue
102− whereClause <- P.optionMaybe $ do
103− C.indented
104− reserved "where"
105− C.indented
106− C.mark $ P.many1 (C.same *> parseLocalDeclaration)
107− return $ maybe value (`Let` value) whereClause
108−
109−parseExternDeclaration :: TokenParser Declaration
110−parseExternDeclaration = P.try (reserved "foreign") *> indented *> reserved "import" *> indented *>
111− (ExternDataDeclaration <$> (P.try (reserved "data") *> indented *> properName)
112− <*> (indented *> doubleColon *> parseKind)
113− <|> (do reserved "instance"
114− name <- parseIdent <* indented <* doubleColon
115− deps <- P.option [] $ do
116− deps <- parens (commaSep1 ((,) <$> parseQualified properName <*> P.many (noWildcards parseTypeAtom)))
117− indented
118− rfatArrow
119− return deps
120− className <- indented *> parseQualified properName
121− tys <- P.many (indented *> noWildcards parseTypeAtom)
122− return $ ExternInstanceDeclaration name deps className tys)
123− <|> (do ident <- parseIdent
124− js <- P.optionMaybe (JSRaw <$> stringLiteral)
125− ty <- indented *> doubleColon *> noWildcards parsePolyType
126− return $ ExternDeclaration (if isJust js then InlineJavascript else ForeignImport) ident js ty))
127−
128−parseAssociativity :: TokenParser Associativity
129−parseAssociativity =
130− (P.try (reserved "infixl") >> return Infixl) <|>
131− (P.try (reserved "infixr") >> return Infixr) <|>
132− (P.try (reserved "infix") >> return Infix)
133−
134−parseFixity :: TokenParser Fixity
135−parseFixity = Fixity <$> parseAssociativity <*> (indented *> natural)
136−
137−parseFixityDeclaration :: TokenParser Declaration
138−parseFixityDeclaration = do
139− fixity <- parseFixity
140− indented
141− name <- symbol
142− return $ FixityDeclaration fixity name
143−
144−parseImportDeclaration :: TokenParser Declaration
145−parseImportDeclaration = do
146− reserved "import"
147− indented
148− qualImport <|> stdImport
149− where
150− stdImport = do
151− moduleName' <- moduleName
152− stdImportHiding moduleName' <|> stdImportQualifying moduleName'
153− where
154− stdImportHiding mn = do
155− reserved "hiding"
156− declType <- importDeclarationType Hiding
157− return $ ImportDeclaration mn declType Nothing
158− stdImportQualifying mn = do
159− declType <- importDeclarationType Qualifying
160− return $ ImportDeclaration mn declType Nothing
161− qualImport = do
162− reserved "qualified"
163− indented
164− moduleName' <- moduleName
165− declType <- importDeclarationType Qualifying
166− reserved "as"
167− asQ <- moduleName
168− return $ ImportDeclaration moduleName' declType (Just asQ)
169− importDeclarationType expectedType = do
170− idents <- P.optionMaybe $ indented *> (parens $ commaSep parseDeclarationRef)
171− return $ fromMaybe Unqualified (expectedType <$> idents)
172−
173−
174−parseDeclarationRef :: TokenParser DeclarationRef
175−parseDeclarationRef = withSourceSpan PositionedDeclarationRef $
176− ValueRef <$> parseIdent
177− <|> do name <- properName
178− dctors <- P.optionMaybe $ parens (symbol' ".." *> pure Nothing <|> Just <$> commaSep properName)
179− return $ maybe (TypeClassRef name) (TypeRef name) dctors
180−
181−parseTypeClassDeclaration :: TokenParser Declaration
182−parseTypeClassDeclaration = do
183− reserved "class"
184− implies <- P.option [] $ do
185− indented
186− implies <- parens (commaSep1 ((,) <$> parseQualified properName <*> P.many (noWildcards parseTypeAtom)))
187− lfatArrow
188− return implies
189− className <- indented *> properName
190− idents <- P.many (indented *> kindedIdent)
191− members <- P.option [] . P.try $ do
192− indented *> reserved "where"
193− mark (P.many (same *> positioned parseTypeDeclaration))
194− return $ TypeClassDeclaration className idents implies members
195−
196−parseTypeInstanceDeclaration :: TokenParser Declaration
197−parseTypeInstanceDeclaration = do
198− reserved "instance"
199− name <- parseIdent <* indented <* doubleColon
200− deps <- P.optionMaybe $ do
201− deps <- parens (commaSep1 ((,) <$> parseQualified properName <*> P.many (noWildcards parseTypeAtom)))
202− indented
203− rfatArrow
204− return deps
205− className <- indented *> parseQualified properName
206− ty <- P.many (indented *> (noWildcards parseTypeAtom))
207− members <- P.option [] . P.try $ do
208− indented *> reserved "where"
209− mark (P.many (same *> positioned parseValueDeclaration))
210− return $ TypeInstanceDeclaration name (fromMaybe [] deps) className ty members
211−
212−positioned :: TokenParser Declaration -> TokenParser Declaration
213−positioned d = withSourceSpan PositionedDeclaration d
214−
215−-- |
216−-- Parse a single declaration
217−--
218−parseDeclaration :: TokenParser Declaration
219−parseDeclaration = positioned (P.choice
220− [ parseDataDeclaration
221− , parseTypeDeclaration
222− , parseTypeSynonymDeclaration
223− , parseValueDeclaration
224− , parseExternDeclaration
225− , parseFixityDeclaration
226− , parseImportDeclaration
227− , parseTypeClassDeclaration
228− , parseTypeInstanceDeclaration
229− ]) P.<?> "declaration"
230−
231−parseLocalDeclaration :: TokenParser Declaration
232−parseLocalDeclaration = positioned (P.choice
233− [ parseTypeDeclaration
234− , parseValueDeclaration
235− ] P.<?> "local declaration")
236−
237−-- |
238−-- Parse a module header and a collection of declarations
239−--
240−parseModule :: TokenParser Module
241−parseModule = do
242− reserved "module"
243− indented
244− name <- moduleName
245− exports <- P.optionMaybe $ parens $ commaSep1 parseDeclarationRef
246− reserved "where"
247− decls <- mark (P.many (same *> parseDeclaration))
248− return $ Module name decls exports
249−
250−-- |
251−-- Parse a collection of modules
252−--
253−parseModulesFromFiles :: (k -> String) -> [(k, String)] -> Either P.ParseError [(k, Module)]
254−parseModulesFromFiles toFilePath input =
255− fmap collect . forM input $ \(k, content) -> do
256− let filename = toFilePath k
257− ts <- lex filename content
258− ms <- runTokenParser filename parseModules ts
259− return (k, ms)
260− where
261− collect :: [(k, [v])] -> [(k, v)]
262− collect vss = [ (k, v) | (k, vs) <- vss, v <- vs ]
263−
264−-- |
265−-- Parse a collection of modules
266−--
267−parseModules :: TokenParser [Module]
268−parseModules = mark (P.many (same *> parseModule)) <* P.eof
269−
270−booleanLiteral :: TokenParser Bool
271−booleanLiteral = (reserved "true" >> return True) P.<|> (reserved "false" >> return False)
272−
273−parseNumericLiteral :: TokenParser Expr
274−parseNumericLiteral = NumericLiteral <$> number
275−
276−parseStringLiteral :: TokenParser Expr
277−parseStringLiteral = StringLiteral <$> stringLiteral
278−
279−parseBooleanLiteral :: TokenParser Expr
280−parseBooleanLiteral = BooleanLiteral <$> booleanLiteral
281−
282−parseArrayLiteral :: TokenParser Expr
283−parseArrayLiteral = ArrayLiteral <$> squares (commaSep parseValue)
284−
285−parseObjectLiteral :: TokenParser Expr
286−parseObjectLiteral = ObjectLiteral <$> braces (commaSep parseIdentifierAndValue)
287−
288−parseIdentifierAndValue :: TokenParser (String, Expr)
289−parseIdentifierAndValue = (,) <$> (C.indented *> (lname <|> stringLiteral) <* C.indented <* colon)
290− <*> (C.indented *> parseValue)
291−
292−parseAbs :: TokenParser Expr
293−parseAbs = do
294− symbol' "\\"
295− args <- P.many1 (C.indented *> (Abs <$> (Left <$> P.try C.parseIdent <|> Right <$> parseBinderNoParens)))
296− C.indented *> rarrow
297− value <- parseValue
298− return $ toFunction args value
299− where
300− toFunction :: [Expr -> Expr] -> Expr -> Expr
301− toFunction args value = foldr ($) value args
302−
303−parseVar :: TokenParser Expr
304−parseVar = Var <$> C.parseQualified C.parseIdent
305−
306−parseConstructor :: TokenParser Expr
307−parseConstructor = Constructor <$> C.parseQualified C.properName
308−
309−parseCase :: TokenParser Expr
310−parseCase = Case <$> P.between (P.try (reserved "case")) (C.indented *> reserved "of") (return <$> parseValue)
311− <*> (C.indented *> C.mark (P.many (C.same *> C.mark parseCaseAlternative)))
312−
313−parseCaseAlternative :: TokenParser CaseAlternative
314−parseCaseAlternative = CaseAlternative <$> (return <$> parseBinder)
315− <*> (Left <$> (C.indented *>
316− P.many1 ((,) <$> parseGuard
317− <*> (indented *> rarrow *> parseValue)
318− ))
319− <|> Right <$> (indented *> rarrow *> parseValue))
320− P.<?> "case alternative"
321−
322−parseIfThenElse :: TokenParser Expr
323−parseIfThenElse = IfThenElse <$> (P.try (reserved "if") *> C.indented *> parseValue)
324− <*> (C.indented *> reserved "then" *> C.indented *> parseValue)
325− <*> (C.indented *> reserved "else" *> C.indented *> parseValue)
326−
327−parseLet :: TokenParser Expr
328−parseLet = do
329− reserved "let"
330− C.indented
331− ds <- C.mark $ P.many1 (C.same *> parseLocalDeclaration)
332− C.indented
333− reserved "in"
334− result <- parseValue
335− return $ Let ds result
336−
337−parseValueAtom :: TokenParser Expr
338−parseValueAtom = P.choice
339− [ P.try parseNumericLiteral
340− , P.try parseStringLiteral
341− , P.try parseBooleanLiteral
342− , parseArrayLiteral
343− , P.try parseObjectLiteral
344− , parseAbs
345− , P.try parseConstructor
346− , P.try parseVar
347− , parseCase
348− , parseIfThenElse
349− , parseDo
350− , parseLet
351− , Parens <$> parens parseValue ]
352−
353−parsePropertyUpdate :: TokenParser (String, Expr)
354−parsePropertyUpdate = do
355− name <- lname <|> stringLiteral
356− _ <- C.indented *> equals
357− value <- C.indented *> parseValue
358− return (name, value)
359−
360−parseAccessor :: Expr -> TokenParser Expr
361−parseAccessor (Constructor _) = P.unexpected "constructor"
362−parseAccessor obj = P.try $ Accessor <$> (C.indented *> dot *> C.indented *> (lname <|> stringLiteral)) <*> pure obj
363−
364−parseDo :: TokenParser Expr
365−parseDo = do
366− reserved "do"
367− C.indented
368− Do <$> C.mark (P.many (C.same *> C.mark parseDoNotationElement))
369−
370−parseDoNotationLet :: TokenParser DoNotationElement
371−parseDoNotationLet = DoNotationLet <$> (reserved "let" *> C.indented *> C.mark (P.many1 (C.same *> parseLocalDeclaration)))
372−
373−parseDoNotationBind :: TokenParser DoNotationElement
374−parseDoNotationBind = DoNotationBind <$> parseBinder <*> (C.indented *> larrow *> parseValue)
375−
376−parseDoNotationElement :: TokenParser DoNotationElement
377−parseDoNotationElement = P.choice
378− [ P.try parseDoNotationBind
379− , parseDoNotationLet
380− , P.try (DoNotationValue <$> parseValue) ]
381−
382−-- |
383−-- Parse a value
384−--
385−parseValue :: TokenParser Expr
386−parseValue = withSourceSpan PositionedValue
387− (P.buildExpressionParser operators
388− . C.buildPostfixParser postfixTable2
389− $ indexersAndAccessors) P.<?> "expression"
390− where
391− indexersAndAccessors = C.buildPostfixParser postfixTable1 parseValueAtom
392− postfixTable1 = [ parseAccessor
393− , \v -> P.try $ flip ObjectUpdate <$> (C.indented *> braces (commaSep1 (C.indented *> parsePropertyUpdate))) <*> pure v ]
394− postfixTable2 = [ \v -> P.try (flip App <$> (C.indented *> indexersAndAccessors)) <*> pure v
395− , \v -> flip (TypedValue True) <$> (P.try (C.indented *> doubleColon) *> parsePolyType) <*> pure v
396− ]
397− operators = [ [ P.Prefix (P.try (C.indented *> symbol' "-") >> return UnaryMinus)
398− ]
399− , [ P.Infix (P.try (C.indented *> C.parseIdentInfix P.<?> "operator") >>= \ident ->
400− return (BinaryNoParens ident)) P.AssocRight
401− ]
402− ]
403−
404−parseStringBinder :: TokenParser Binder
405−parseStringBinder = StringBinder <$> stringLiteral
406−
407−parseBooleanBinder :: TokenParser Binder
408−parseBooleanBinder = BooleanBinder <$> booleanLiteral
409−
410−parseNumberBinder :: TokenParser Binder
411−parseNumberBinder = NumberBinder <$> (sign <*> number)
412− where
413− sign :: TokenParser (Either Integer Double -> Either Integer Double)
414− sign = (symbol' "-" >> return (negate +++ negate))
415− <|> (symbol' "+" >> return id)
416− <|> return id
417−
418−parseVarBinder :: TokenParser Binder
419−parseVarBinder = VarBinder <$> C.parseIdent
420−
421−parseNullaryConstructorBinder :: TokenParser Binder
422−parseNullaryConstructorBinder = ConstructorBinder <$> C.parseQualified C.properName <*> pure []
423−
424−parseConstructorBinder :: TokenParser Binder
425−parseConstructorBinder = ConstructorBinder <$> C.parseQualified C.properName <*> many (C.indented *> parseBinderNoParens)
426−
427−parseObjectBinder :: TokenParser Binder
428−parseObjectBinder = ObjectBinder <$> braces (commaSep (C.indented *> parseIdentifierAndBinder))
429−
430−parseArrayBinder :: TokenParser Binder
431−parseArrayBinder = squares $ ArrayBinder <$> commaSep (C.indented *> parseBinder)
432−
433−parseNamedBinder :: TokenParser Binder
434−parseNamedBinder = NamedBinder <$> (C.parseIdent <* C.indented <* at)
435− <*> (C.indented *> parseBinder)
436−
437−parseNullBinder :: TokenParser Binder
438−parseNullBinder = reserved "_" *> return NullBinder
439−
440−parseIdentifierAndBinder :: TokenParser (String, Binder)
441−parseIdentifierAndBinder = do
442− name <- lname <|> stringLiteral
443− C.indented *> (equals <|> colon)
444− binder <- C.indented *> parseBinder
445− return (name, binder)
446−
447−-- |
448−-- Parse a binder
449−--
450−parseBinder :: TokenParser Binder
451−parseBinder = withSourceSpan PositionedBinder (P.buildExpressionParser operators parseBinderAtom P.<?> "expression")
452− where
453− operators = [ [ P.Infix (P.try $ C.indented *> colon *> return ConsBinder) P.AssocRight ] ]
454− parseBinderAtom :: TokenParser Binder
455− parseBinderAtom = P.choice (map P.try
456− [ parseNullBinder
457− , parseStringBinder
458− , parseBooleanBinder
459− , parseNumberBinder
460− , parseNamedBinder
461− , parseVarBinder
462− , parseConstructorBinder
463− , parseObjectBinder
464− , parseArrayBinder
465− , parens parseBinder ]) P.<?> "binder"
466−
467−-- |
468−-- Parse a binder as it would appear in a top level declaration
469−--
470−parseBinderNoParens :: TokenParser Binder
471−parseBinderNoParens = P.choice (map P.try
472− [ parseNullBinder
473− , parseStringBinder
474− , parseBooleanBinder
475− , parseNumberBinder
476− , parseNamedBinder
477− , parseVarBinder
478− , parseNullaryConstructorBinder
479− , parseObjectBinder
480− , parseArrayBinder
481− , parens parseBinder ]) P.<?> "binder"
482−-- |
483−-- Parse a guard
484−--
485−parseGuard :: TokenParser Guard
486−parseGuard = pipe *> C.indented *> parseValue
487−
488−
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−489
@@ -1,489 +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− , token
24− , match
25− , lparen
26− , rparen
27− , parens
28− , lbrace
29− , rbrace
30− , braces
31− , lsquare
32− , rsquare
33− , squares
34− , indent
35− , indentAt
36− , larrow
37− , rarrow
38− , lfatArrow
39− , rfatArrow
40− , colon
41− , doubleColon
42− , equals
43− , pipe
44− , tick
45− , dot
46− , comma
47− , semi
48− , at
49− , semiSep
50− , semiSep1
51− , commaSep
52− , commaSep1
53− , lname
54− , qualifier
55− , uname
56− , uname'
57− , mname
58− , reserved
59− , symbol
60− , symbol'
61− , identifier
62− , stringLiteral
63− , number
64− , natural
65− , reservedPsNames
66− , reservedTypeNames
67− , opChars
68− )
69− where
70−
71−import Prelude hiding (lex)
72−
73−import Control.Monad (void, guard)
74−import Data.Functor.Identity
75−
76−import Control.Applicative
77−
78−import Language.PureScript.Parser.State
79−
80−import qualified Text.Parsec as P
81−import qualified Text.Parsec.Token as PT
82−
83−data Comment
84− = LineComment String
85− | BlockComment String
86− deriving (Show, Eq, Ord)
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− | LName String
110− | UName String
111− | Qualifier String
112− | Symbol String
113− | StringLiteral String
114− | Number (Either Integer Double)
115− deriving (Show, Eq, Ord)
116−
117−prettyPrintToken :: Token -> String
118−prettyPrintToken LParen = "("
119−prettyPrintToken RParen = ")"
120−prettyPrintToken LBrace = "{"
121−prettyPrintToken RBrace = "}"
122−prettyPrintToken LSquare = "["
123−prettyPrintToken RSquare = "]"
124−prettyPrintToken LArrow = "<-"
125−prettyPrintToken RArrow = "->"
126−prettyPrintToken LFatArrow = "<="
127−prettyPrintToken RFatArrow = "=>"
128−prettyPrintToken Colon = ":"
129−prettyPrintToken DoubleColon = "::"
130−prettyPrintToken Equals = "="
131−prettyPrintToken Pipe = "|"
132−prettyPrintToken Tick = "`"
133−prettyPrintToken Dot = "."
134−prettyPrintToken Comma = ","
135−prettyPrintToken Semi = ";"
136−prettyPrintToken At = "@"
137−prettyPrintToken (Indent n) = "indentation at level " ++ show n
138−prettyPrintToken (LName s) = show s
139−prettyPrintToken (UName s) = show s
140−prettyPrintToken (Qualifier _) = "qualifier"
141−prettyPrintToken (Symbol s) = s
142−prettyPrintToken (StringLiteral s) = show s
143−prettyPrintToken (Number n) = either show show n
144−
145−data PositionedToken = PositionedToken
146− { ptSourcePos :: P.SourcePos
147− , ptToken :: Token
148− , ptComments :: [Comment]
149− } deriving (Eq)
150−
151−instance Show PositionedToken where
152− show = show . ptToken
153−
154−lex :: FilePath -> String -> Either P.ParseError [PositionedToken]
155−lex filePath input = P.parse parseTokens filePath input
156−
157−parseTokens :: P.Parsec String u [PositionedToken]
158−parseTokens = whitespace *> P.many parsePositionedToken <* P.skipMany parseComment <* P.eof
159−
160−whitespace :: P.Parsec String u ()
161−whitespace = P.skipMany (P.oneOf " \t\r\n")
162−
163−parseComment :: P.Parsec String u Comment
164−parseComment = (BlockComment <$> blockComment <|> LineComment <$> lineComment) <* whitespace
165− where
166− blockComment :: P.Parsec String u String
167− blockComment = P.try $ P.string "{-" *> P.manyTill P.anyChar (P.try (P.string "-}"))
168−
169− lineComment :: P.Parsec String u String
170− lineComment = P.try $ P.string "--" *> P.manyTill P.anyChar (P.try (void (P.char '\n') <|> P.eof))
171−
172−parsePositionedToken :: P.Parsec String u PositionedToken
173−parsePositionedToken = P.try $ do
174− comments <- P.many parseComment
175− pos <- P.getPosition
176− tok <- parseToken
177− return $ PositionedToken pos tok comments
178−
179−parseToken :: P.Parsec String u Token
180−parseToken = P.choice
181− [ P.try $ P.string "<-" *> P.notFollowedBy symbolChar *> pure LArrow
182− , P.try $ P.string "<=" *> P.notFollowedBy symbolChar *> pure LFatArrow
183− , P.try $ P.string "->" *> P.notFollowedBy symbolChar *> pure RArrow
184− , P.try $ P.string "=>" *> P.notFollowedBy symbolChar *> pure RFatArrow
185− , P.try $ P.string "::" *> P.notFollowedBy symbolChar *> pure DoubleColon
186− , P.try $ P.char '(' *> pure LParen
187− , P.try $ P.char ')' *> pure RParen
188− , P.try $ P.char '{' *> pure LBrace
189− , P.try $ P.char '}' *> pure RBrace
190− , P.try $ P.char '[' *> pure LSquare
191− , P.try $ P.char ']' *> pure RSquare
192− , P.try $ P.char '`' *> pure Tick
193− , P.try $ P.char ',' *> pure Comma
194− , P.try $ P.char '=' *> P.notFollowedBy symbolChar *> pure Equals
195− , P.try $ P.char ':' *> P.notFollowedBy symbolChar *> pure Colon
196− , P.try $ P.char '|' *> P.notFollowedBy symbolChar *> pure Pipe
197− , P.try $ P.char '.' *> P.notFollowedBy symbolChar *> pure Dot
198− , P.try $ P.char ';' *> P.notFollowedBy symbolChar *> pure Semi
199− , P.try $ P.char '@' *> P.notFollowedBy symbolChar *> pure At
200− , LName <$> parseLName
201− , do uName <- parseUName
202− (guard (validModuleName uName) >> Qualifier uName <$ P.char '.') <|> pure (UName uName)
203− , Symbol <$> parseSymbol
204− , StringLiteral <$> parseStringLiteral
205− , Number <$> parseNumber
206− ] <* whitespace
207−
208− where
209− parseLName :: P.Parsec String u String
210− parseLName = (:) <$> identStart <*> P.many identLetter
211−
212− parseUName :: P.Parsec String u String
213− parseUName = (:) <$> P.upper <*> P.many uidentLetter
214−
215− parseSymbol :: P.Parsec String u String
216− parseSymbol = P.many1 symbolChar
217−
218− identStart :: P.Parsec String u Char
219− identStart = P.lower <|> P.oneOf "_"
220−
221− identLetter :: P.Parsec String u Char
222− identLetter = P.alphaNum <|> P.oneOf "_'"
223−
224− uidentLetter :: P.Parsec String u Char
225− uidentLetter = P.alphaNum <|> P.char '_'
226−
227− symbolChar :: P.Parsec String u Char
228− symbolChar = P.oneOf opChars
229−
230− parseStringLiteral :: P.Parsec String u String
231− parseStringLiteral = blockString <|> PT.stringLiteral tokenParser
232− where
233− delimeter = P.try (P.string "\"\"\"")
234− blockString = delimeter >> P.manyTill P.anyChar delimeter
235−
236− parseNumber :: P.Parsec String u (Either Integer Double)
237− parseNumber = (Right <$> P.try (PT.float tokenParser) <|>
238− Left <$> P.try (PT.natural tokenParser)) P.<?> "number"
239−
240−-- |
241−-- We use Text.Parsec.Token to implement the string and number lexemes
242−--
243−langDef :: PT.GenLanguageDef String u Identity
244−langDef = PT.LanguageDef
245− { PT.reservedNames = []
246− , PT.reservedOpNames = []
247− , PT.commentStart = ""
248− , PT.commentEnd = ""
249− , PT.commentLine = ""
250− , PT.nestedComments = True
251− , PT.identStart = fail "Identifiers not supported"
252− , PT.identLetter = fail "Identifiers not supported"
253− , PT.opStart = fail "Operators not supported"
254− , PT.opLetter = fail "Operators not supported"
255− , PT.caseSensitive = True
256− }
257−
258−-- |
259−-- A token parser based on the language definition
260−--
261−tokenParser :: PT.GenTokenParser String u Identity
262−tokenParser = PT.makeTokenParser langDef
263−
264−type TokenParser a = P.Parsec [PositionedToken] ParseState a
265−
266−token :: (Token -> Maybe a) -> TokenParser a
267−token f = P.token (prettyPrintToken . ptToken) ptSourcePos (f . ptToken)
268−
269−match :: Token -> TokenParser ()
270−match tok = token (\tok' -> if tok == tok' then Just () else Nothing) P.<?> prettyPrintToken tok
271−
272−lparen :: TokenParser ()
273−lparen = match LParen
274−
275−rparen :: TokenParser ()
276−rparen = match RParen
277−
278−parens :: TokenParser a -> TokenParser a
279−parens = P.between lparen rparen
280−
281−lbrace :: TokenParser ()
282−lbrace = match LBrace
283−
284−rbrace :: TokenParser ()
285−rbrace = match RBrace
286−
287−braces :: TokenParser a -> TokenParser a
288−braces = P.between lbrace rbrace
289−
290−lsquare :: TokenParser ()
291−lsquare = match LSquare
292−
293−rsquare :: TokenParser ()
294−rsquare = match RSquare
295−
296−squares :: TokenParser a -> TokenParser a
297−squares = P.between lsquare rsquare
298−
299−indent :: TokenParser Int
300−indent = token go P.<?> "indentation"
301− where
302− go (Indent n) = Just n
303− go _ = Nothing
304−
305−indentAt :: P.Column -> TokenParser ()
306−indentAt n = token go P.<?> "indentation at level " ++ show n
307− where
308− go (Indent n') | n == n' = Just ()
309− go _ = Nothing
310−
311−larrow :: TokenParser ()
312−larrow = match LArrow
313−
314−rarrow :: TokenParser ()
315−rarrow = match RArrow
316−
317−lfatArrow :: TokenParser ()
318−lfatArrow = match LFatArrow
319−
320−rfatArrow :: TokenParser ()
321−rfatArrow = match RFatArrow
322−
323−colon :: TokenParser ()
324−colon = match Colon
325−
326−doubleColon :: TokenParser ()
327−doubleColon = match DoubleColon
328−
329−equals :: TokenParser ()
330−equals = match Equals
331−
332−pipe :: TokenParser ()
333−pipe = match Pipe
334−
335−tick :: TokenParser ()
336−tick = match Tick
337−
338−dot :: TokenParser ()
339−dot = match Dot
340−
341−comma :: TokenParser ()
342−comma = match Comma
343−
344−semi :: TokenParser ()
345−semi = match Semi
346−
347−at :: TokenParser ()
348−at = match At
349−
350−-- |
351−-- Parse zero or more values separated by semicolons
352−--
353−semiSep :: TokenParser a -> TokenParser [a]
354−semiSep = flip P.sepBy semi
355−
356−-- |
357−-- Parse one or more values separated by semicolons
358−--
359−semiSep1 :: TokenParser a -> TokenParser [a]
360−semiSep1 = flip P.sepBy1 semi
361−
362−-- |
363−-- Parse zero or more values separated by commas
364−--
365−commaSep :: TokenParser a -> TokenParser [a]
366−commaSep = flip P.sepBy comma
367−
368−-- |
369−-- Parse one or more values separated by commas
370−--
371−commaSep1 :: TokenParser a -> TokenParser [a]
372−commaSep1 = flip P.sepBy1 comma
373−
374−lname :: TokenParser String
375−lname = token go P.<?> "identifier"
376− where
377− go (LName s) = Just s
378− go _ = Nothing
379−
380−qualifier :: TokenParser String
381−qualifier = token go P.<?> "qualifier"
382− where
383− go (Qualifier s) = Just s
384− go _ = Nothing
385−
386−reserved :: String -> TokenParser ()
387−reserved s = token go P.<?> show s
388− where
389− go (LName s') | s == s' = Just ()
390− go _ = Nothing
391−
392−uname :: TokenParser String
393−uname = token go P.<?> "proper name"
394− where
395− go (UName s) = Just s
396− go _ = Nothing
397−
398−mname :: TokenParser String
399−mname = token go P.<?> "module name"
400− where
401− go (UName s) | validModuleName s = Just s
402− go _ = Nothing
403−
404−uname' :: String -> TokenParser ()
405−uname' s = token go P.<?> show s
406− where
407− go (UName s') | s == s' = Just ()
408− go _ = Nothing
409−
410−symbol :: TokenParser String
411−symbol = token go P.<?> "symbol"
412− where
413− go (Symbol s) = Just s
414− go Colon = Just ":"
415− go LFatArrow = Just "<="
416− go _ = Nothing
417−
418−symbol' :: String -> TokenParser ()
419−symbol' s = token go P.<?> show s
420− where
421− go (Symbol s') | s == s' = Just ()
422− go Colon | s == ":" = Just ()
423− go LFatArrow | s == "<=" = Just ()
424− go _ = Nothing
425−
426−stringLiteral :: TokenParser String
427−stringLiteral = token go P.<?> "string literal"
428− where
429− go (StringLiteral s) = Just s
430− go _ = Nothing
431−
432−number :: TokenParser (Either Integer Double)
433−number = token go P.<?> "number"
434− where
435− go (Number n) = Just n
436− go _ = Nothing
437−
438−natural :: TokenParser Integer
439−natural = token go P.<?> "natural"
440− where
441− go (Number (Left n)) = Just n
442− go _ = Nothing
443−
444−identifier :: TokenParser String
445−identifier = token go P.<?> "identifier"
446− where
447− go (LName s) | s `notElem` reservedPsNames = Just s
448− go _ = Nothing
449−
450−validModuleName :: String -> Bool
451−validModuleName s = not ('_' `elem` s)
452−
453−-- |
454−-- A list of purescript reserved identifiers
455−--
456−reservedPsNames :: [String]
457−reservedPsNames = [ "data"
458− , "newtype"
459− , "type"
460− , "foreign"
461− , "import"
462− , "infixl"
463− , "infixr"
464− , "infix"
465− , "class"
466− , "instance"
467− , "module"
468− , "case"
469− , "of"
470− , "if"
471− , "then"
472− , "else"
473− , "do"
474− , "let"
475− , "true"
476− , "false"
477− , "in"
478− , "where"
479− ]
480−
481−reservedTypeNames :: [String]
482−reservedTypeNames = [ "forall", "where" ]
483−
484−-- |
485−-- The characters allowed for use in operators
486−--
487−opChars :: [Char]
488−opChars = ":!#$%&*+./<=>?@\\^|-~"
489−
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−132
@@ -1,132 +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 = reserved "_" >> 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 (TypeVar <$> (indented *> pipe *> indented *> identifier))
130−
131−parseRow :: TokenParser Type
132−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−265
@@ -1,265 +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−
33−import Numeric
34−
35−literals :: Pattern PrinterState JS String
36−literals = mkPattern' match
37− where
38− match :: JS -> StateT PrinterState Maybe String
39− match (JSNumericLiteral n) = return $ either show show n
40− match (JSStringLiteral s) = return $ string s
41− match (JSBooleanLiteral True) = return "true"
42− match (JSBooleanLiteral False) = return "false"
43− match (JSArrayLiteral xs) = fmap concat $ sequence
44− [ return "[ "
45− , fmap (intercalate ", ") $ forM xs prettyPrintJS'
46− , return " ]"
47− ]
48− match (JSObjectLiteral []) = return "{}"
49− match (JSObjectLiteral ps) = fmap concat $ sequence
50− [ return "{\n"
51− , withIndent $ do
52− jss <- forM ps $ \(key, value) -> fmap ((objectPropertyToString key ++ ": ") ++) . prettyPrintJS' $ value
53− indentString <- currentIndent
54− return $ intercalate ", \n" $ map (indentString ++) jss
55− , return "\n"
56− , currentIndent
57− , return "}"
58− ]
59− where
60− objectPropertyToString :: String -> String
61− objectPropertyToString s | identNeedsEscaping s = show s
62− | otherwise = s
63− match (JSBlock sts) = fmap concat $ sequence
64− [ return "{\n"
65− , withIndent $ prettyStatements sts
66− , return "\n"
67− , currentIndent
68− , return "}"
69− ]
70− match (JSVar ident) = return ident
71− match (JSVariableIntroduction ident value) = fmap concat $ sequence
72− [ return "var "
73− , return ident
74− , maybe (return "") (fmap (" = " ++) . prettyPrintJS') value
75− ]
76− match (JSAssignment target value) = fmap concat $ sequence
77− [ prettyPrintJS' target
78− , return " = "
79− , prettyPrintJS' value
80− ]
81− match (JSWhile cond sts) = fmap concat $ sequence
82− [ return "while ("
83− , prettyPrintJS' cond
84− , return ") "
85− , prettyPrintJS' sts
86− ]
87− match (JSFor ident start end sts) = fmap concat $ sequence
88− [ return $ "for (var " ++ ident ++ " = "
89− , prettyPrintJS' start
90− , return $ "; " ++ ident ++ " < "
91− , prettyPrintJS' end
92− , return $ "; " ++ ident ++ "++) "
93− , prettyPrintJS' sts
94− ]
95− match (JSForIn ident obj sts) = fmap concat $ sequence
96− [ return $ "for (var " ++ ident ++ " in "
97− , prettyPrintJS' obj
98− , return ") "
99− , prettyPrintJS' sts
100− ]
101− match (JSIfElse cond thens elses) = fmap concat $ sequence
102− [ return "if ("
103− , prettyPrintJS' cond
104− , return ") "
105− , prettyPrintJS' thens
106− , maybe (return "") (fmap (" else " ++) . prettyPrintJS') elses
107− ]
108− match (JSReturn value) = fmap concat $ sequence
109− [ return "return "
110− , prettyPrintJS' value
111− ]
112− match (JSThrow value) = fmap concat $ sequence
113− [ return "throw "
114− , prettyPrintJS' value
115− ]
116− match (JSBreak lbl) = return $ "break " ++ lbl
117− match (JSContinue lbl) = return $ "continue " ++ lbl
118− match (JSLabel lbl js) = fmap concat $ sequence
119− [ return $ lbl ++ ": "
120− , prettyPrintJS' js
121− ]
122− match (JSRaw js) = return js
123− match _ = mzero
124−
125−string :: String -> String
126−string s = '"' : concatMap encodeChar s ++ "\""
127− where
128− encodeChar :: Char -> String
129− encodeChar '\b' = "\\b"
130− encodeChar '\t' = "\\t"
131− encodeChar '\n' = "\\n"
132− encodeChar '\v' = "\\v"
133− encodeChar '\f' = "\\f"
134− encodeChar '\r' = "\\r"
135− encodeChar '"' = "\\\""
136− encodeChar '\\' = "\\\\"
137− encodeChar c | fromEnum c > 0xFFF = "\\u" ++ showHex (fromEnum c) ""
138− encodeChar c | fromEnum c > 0xFF = "\\u0" ++ showHex (fromEnum c) ""
139− encodeChar c = [c]
140−
141−conditional :: Pattern PrinterState JS ((JS, JS), JS)
142−conditional = mkPattern match
143− where
144− match (JSConditional cond th el) = Just ((th, el), cond)
145− match _ = Nothing
146−
147−accessor :: Pattern PrinterState JS (String, JS)
148−accessor = mkPattern match
149− where
150− match (JSAccessor prop val) = Just (prop, val)
151− match _ = Nothing
152−
153−indexer :: Pattern PrinterState JS (String, JS)
154−indexer = mkPattern' match
155− where
156− match (JSIndexer index val) = (,) <$> prettyPrintJS' index <*> pure val
157− match _ = mzero
158−
159−lam :: Pattern PrinterState JS ((Maybe String, [String]), JS)
160−lam = mkPattern match
161− where
162− match (JSFunction name args ret) = Just ((name, args), ret)
163− match _ = Nothing
164−
165−app :: Pattern PrinterState JS (String, JS)
166−app = mkPattern' match
167− where
168− match (JSApp val args) = do
169− jss <- mapM prettyPrintJS' args
170− return (intercalate ", " jss, val)
171− match _ = mzero
172−
173−typeOf :: Pattern PrinterState JS ((), JS)
174−typeOf = mkPattern match
175− where
176− match (JSTypeOf val) = Just ((), val)
177− match _ = Nothing
178−
179−instanceOf :: Pattern PrinterState JS (JS, JS)
180−instanceOf = mkPattern match
181− where
182− match (JSInstanceOf val ty) = Just (val, ty)
183− match _ = Nothing
184−
185−unary :: UnaryOperator -> String -> Operator PrinterState JS String
186−unary op str = Wrap match (++)
187− where
188− match :: Pattern PrinterState JS (String, JS)
189− match = mkPattern match'
190− where
191− match' (JSUnary op' val) | op' == op = Just (str, val)
192− match' _ = Nothing
193−
194−binary :: BinaryOperator -> String -> Operator PrinterState JS String
195−binary op str = AssocL match (\v1 v2 -> v1 ++ " " ++ str ++ " " ++ v2)
196− where
197− match :: Pattern PrinterState JS (JS, JS)
198− match = mkPattern match'
199− where
200− match' (JSBinary op' v1 v2) | op' == op = Just (v1, v2)
201− match' _ = Nothing
202−
203−prettyStatements :: [JS] -> StateT PrinterState Maybe String
204−prettyStatements sts = do
205− jss <- forM sts prettyPrintJS'
206− indentString <- currentIndent
207− return $ intercalate "\n" $ map ((++ ";") . (indentString ++)) jss
208−
209−-- |
210−-- Generate a pretty-printed string representing a Javascript expression
211−--
212−prettyPrintJS1 :: JS -> String
213−prettyPrintJS1 = fromMaybe (error "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyPrintJS'
214−
215−-- |
216−-- Generate a pretty-printed string representing a collection of Javascript expressions at the same indentation level
217−--
218−prettyPrintJS :: [JS] -> String
219−prettyPrintJS = fromMaybe (error "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyStatements
220−
221−-- |
222−-- Generate an indented, pretty-printed string representing a Javascript expression
223−--
224−prettyPrintJS' :: JS -> StateT PrinterState Maybe String
225−prettyPrintJS' = A.runKleisli $ runPattern matchValue
226− where
227− matchValue :: Pattern PrinterState JS String
228− matchValue = buildPrettyPrinter operators (literals <+> fmap parens matchValue)
229− operators :: OperatorTable PrinterState JS String
230− operators =
231− OperatorTable [ [ Wrap accessor $ \prop val -> val ++ "." ++ prop ]
232− , [ Wrap indexer $ \index val -> val ++ "[" ++ index ++ "]" ]
233− , [ Wrap app $ \args val -> val ++ "(" ++ args ++ ")" ]
234− , [ unary JSNew "new " ]
235− , [ Wrap lam $ \(name, args) ret -> "function "
236− ++ fromMaybe "" name
237− ++ "(" ++ intercalate ", " args ++ ") "
238− ++ ret ]
239− , [ binary LessThan "<" ]
240− , [ binary LessThanOrEqualTo "<=" ]
241− , [ binary GreaterThan ">" ]
242− , [ binary GreaterThanOrEqualTo ">=" ]
243− , [ Wrap typeOf $ \_ s -> "typeof " ++ s ]
244− , [ AssocR instanceOf $ \v1 v2 -> v1 ++ " instanceof " ++ v2 ]
245− , [ unary Not "!" ]
246− , [ unary BitwiseNot "~" ]
247− , [ unary Negate "-" ]
248− , [ unary Positive "+" ]
249− , [ binary Multiply "*" ]
250− , [ binary Divide "/" ]
251− , [ binary Modulus "%" ]
252− , [ binary Add "+" ]
253− , [ binary Subtract "-" ]
254− , [ binary ShiftLeft "<<" ]
255− , [ binary ShiftRight ">>" ]
256− , [ binary ZeroFillShiftRight ">>>" ]
257− , [ binary EqualTo "===" ]
258− , [ binary NotEqualTo "!==" ]
259− , [ binary BitwiseAnd "&" ]
260− , [ binary BitwiseXor "^" ]
261− , [ binary BitwiseOr "|" ]
262− , [ binary And "&&" ]
263− , [ binary Or "||" ]
264− , [ Wrap conditional $ \(th, el) cond -> cond ++ " ? " ++ prettyPrintJS1 th ++ " : " ++ prettyPrintJS1 el ]
265− ]
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−241
@@ -1,241 +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)
25−import Control.PatternArrows
26−import Control.Monad.State
27−import Control.Applicative
28−
29−import Language.PureScript.AST
30−import Language.PureScript.Pretty.Common
31−import Language.PureScript.Pretty.Types (prettyPrintType)
32−
33−literals :: Pattern PrinterState Expr String
34−literals = mkPattern' match
35− where
36− match :: Expr -> StateT PrinterState Maybe String
37− match (NumericLiteral n) = return $ either show show n
38− match (StringLiteral s) = return $ show s
39− match (BooleanLiteral True) = return "true"
40− match (BooleanLiteral False) = return "false"
41− match (ArrayLiteral xs) = fmap concat $ sequence
42− [ return "[ "
43− , withIndent $ prettyPrintMany prettyPrintValue' xs
44− , return " ]"
45− ]
46− match (ObjectLiteral []) = return "{}"
47− match (ObjectLiteral ps) = fmap concat $ sequence
48− [ return "{\n"
49− , withIndent $ prettyPrintMany prettyPrintObjectProperty ps
50− , return "\n"
51− , currentIndent
52− , return "}"
53− ]
54− match (TypeClassDictionaryConstructorApp className ps) = fmap concat $ sequence
55− [ return ((show className) ++ "(\n")
56− , match ps
57− , return ")"
58− ]
59− match (Constructor name) = return $ show name
60− match (Case values binders) = fmap concat $ sequence
61− [ return "case "
62− , unwords <$> forM values prettyPrintValue'
63− , return " of\n"
64− , withIndent $ prettyPrintMany prettyPrintCaseAlternative binders
65− , currentIndent
66− ]
67− match (Let ds val) = fmap concat $ sequence
68− [ return "let\n"
69− , withIndent $ prettyPrintMany prettyPrintDeclaration ds
70− , return "\n"
71− , currentIndent
72− , return "in "
73− , prettyPrintValue' val
74− ]
75− match (Var ident) = return $ show ident
76− match (Do els) = fmap concat $ sequence
77− [ return "do "
78− , withIndent $ prettyPrintMany prettyPrintDoNotationElement els
79− , currentIndent
80− ]
81− match (TypeClassDictionary name _ _) = return $ "<<dict " ++ show name ++ ">>"
82− match (SuperClassDictionary name _) = return $ "<<superclass dict " ++ show name ++ ">>"
83− match (TypedValue _ val _) = prettyPrintValue' val
84− match (PositionedValue _ val) = prettyPrintValue' val
85− match _ = mzero
86−
87−prettyPrintDeclaration :: Declaration -> StateT PrinterState Maybe String
88−prettyPrintDeclaration (TypeDeclaration ident ty) = return $ show ident ++ " :: " ++ prettyPrintType ty
89−prettyPrintDeclaration (ValueDeclaration ident _ [] (Right val)) = fmap concat $ sequence
90− [ return $ show ident ++ " = "
91− , prettyPrintValue' val
92− ]
93−prettyPrintDeclaration (PositionedDeclaration _ d) = prettyPrintDeclaration d
94−prettyPrintDeclaration _ = error "Invalid argument to prettyPrintDeclaration"
95−
96−prettyPrintCaseAlternative :: CaseAlternative -> StateT PrinterState Maybe String
97−prettyPrintCaseAlternative (CaseAlternative binders result) =
98− fmap concat $ sequence
99− [ intercalate ", " <$> forM binders prettyPrintBinder'
100− , prettyPrintResult result
101− ]
102− where
103− prettyPrintResult (Left gs) = concat <$> mapM prettyPrintGuardedValue gs
104− prettyPrintResult (Right v) = (" -> " ++) <$> prettyPrintValue' v
105−
106− prettyPrintGuardedValue (grd, val) =
107− fmap concat $ sequence
108− [ return "| "
109− , prettyPrintValue' grd
110− , return " -> "
111− , prettyPrintValue' val
112− , return "\n"
113− ]
114−
115−prettyPrintDoNotationElement :: DoNotationElement -> StateT PrinterState Maybe String
116−prettyPrintDoNotationElement (DoNotationValue val) =
117− prettyPrintValue' val
118−prettyPrintDoNotationElement (DoNotationBind binder val) =
119− fmap concat $ sequence
120− [ prettyPrintBinder' binder
121− , return " <- "
122− , prettyPrintValue' val
123− ]
124−prettyPrintDoNotationElement (DoNotationLet ds) =
125− fmap concat $ sequence
126− [ return "let "
127− , withIndent $ prettyPrintMany prettyPrintDeclaration ds
128− ]
129−prettyPrintDoNotationElement (PositionedDoNotationElement _ el) = prettyPrintDoNotationElement el
130−
131−ifThenElse :: Pattern PrinterState Expr ((Expr, Expr), Expr)
132−ifThenElse = mkPattern match
133− where
134− match (IfThenElse cond th el) = Just ((th, el), cond)
135− match _ = Nothing
136−
137−accessor :: Pattern PrinterState Expr (String, Expr)
138−accessor = mkPattern match
139− where
140− match (Accessor prop val) = Just (prop, val)
141− match _ = Nothing
142−
143−objectUpdate :: Pattern PrinterState Expr ([String], Expr)
144−objectUpdate = mkPattern match
145− where
146− match (ObjectUpdate o ps) = Just (flip map ps $ \(key, val) -> key ++ " = " ++ prettyPrintValue val, o)
147− match _ = Nothing
148−
149−app :: Pattern PrinterState Expr (String, Expr)
150−app = mkPattern match
151− where
152− match (App val arg) = Just (prettyPrintValue arg, val)
153− match _ = Nothing
154−
155−lam :: Pattern PrinterState Expr (String, Expr)
156−lam = mkPattern match
157− where
158− match (Abs (Left arg) val) = Just (show arg, val)
159− match _ = Nothing
160−
161−-- |
162−-- Generate a pretty-printed string representing an expression
163−--
164−prettyPrintValue :: Expr -> String
165−prettyPrintValue = fromMaybe (error "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyPrintValue'
166−
167−prettyPrintValue' :: Expr -> StateT PrinterState Maybe String
168−prettyPrintValue' = runKleisli $ runPattern matchValue
169− where
170− matchValue :: Pattern PrinterState Expr String
171− matchValue = buildPrettyPrinter operators (literals <+> fmap parens matchValue)
172− operators :: OperatorTable PrinterState Expr String
173− operators =
174− OperatorTable [ [ Wrap accessor $ \prop val -> val ++ "." ++ prop ]
175− , [ Wrap objectUpdate $ \ps val -> val ++ "{ " ++ intercalate ", " ps ++ " }" ]
176− , [ Wrap app $ \arg val -> val ++ "(" ++ arg ++ ")" ]
177− , [ Split lam $ \arg val -> "\\" ++ arg ++ " -> " ++ prettyPrintValue val ]
178− , [ Wrap ifThenElse $ \(th, el) cond -> "if " ++ cond ++ " then " ++ prettyPrintValue th ++ " else " ++ prettyPrintValue el ]
179− ]
180−
181−prettyPrintBinderAtom :: Pattern PrinterState Binder String
182−prettyPrintBinderAtom = mkPattern' match
183− where
184− match :: Binder -> StateT PrinterState Maybe String
185− match NullBinder = return "_"
186− match (StringBinder str) = return $ show str
187− match (NumberBinder num) = return $ either show show num
188− match (BooleanBinder True) = return "true"
189− match (BooleanBinder False) = return "false"
190− match (VarBinder ident) = return $ show ident
191− match (ConstructorBinder ctor args) = fmap concat $ sequence
192− [ return $ show ctor ++ " "
193− , unwords <$> forM args match
194− ]
195− match (ObjectBinder bs) = fmap concat $ sequence
196− [ return "{\n"
197− , withIndent $ prettyPrintMany prettyPrintObjectPropertyBinder bs
198− , currentIndent
199− , return "}"
200− ]
201− match (ArrayBinder bs) = fmap concat $ sequence
202− [ return "["
203− , unwords <$> mapM prettyPrintBinder' bs
204− , return "]"
205− ]
206− match (NamedBinder ident binder) = ((show ident ++ "@") ++) <$> prettyPrintBinder' binder
207− match (PositionedBinder _ binder) = prettyPrintBinder' binder
208− match _ = mzero
209−
210−-- |
211−-- Generate a pretty-printed string representing a Binder
212−--
213−prettyPrintBinder :: Binder -> String
214−prettyPrintBinder = fromMaybe (error "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyPrintBinder'
215−
216−prettyPrintBinder' :: Binder -> StateT PrinterState Maybe String
217−prettyPrintBinder' = runKleisli $ runPattern matchBinder
218− where
219− matchBinder :: Pattern PrinterState Binder String
220− matchBinder = buildPrettyPrinter operators (prettyPrintBinderAtom <+> fmap parens matchBinder)
221− operators :: OperatorTable PrinterState Binder String
222− operators =
223− OperatorTable [ [ AssocR matchConsBinder (\b1 b2 -> b1 ++ " : " ++ b2) ] ]
224−
225−matchConsBinder :: Pattern PrinterState Binder (Binder, Binder)
226−matchConsBinder = mkPattern match'
227− where
228− match' (ConsBinder b1 b2) = Just (b1, b2)
229− match' _ = Nothing
230−
231−prettyPrintObjectPropertyBinder :: (String, Binder) -> StateT PrinterState Maybe String
232−prettyPrintObjectPropertyBinder (key, binder) = fmap concat $ sequence
233− [ return $ prettyPrintObjectKey key ++ ": "
234− , prettyPrintBinder' binder
235− ]
236−
237−prettyPrintObjectProperty :: (String, Expr) -> StateT PrinterState Maybe String
238−prettyPrintObjectProperty (key, value) = fmap concat $ sequence
239− [ return $ prettyPrintObjectKey key ++ ": "
240− , prettyPrintValue' value
241− ]
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−59
@@ -1,59 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.Sugar
4−-- Copyright : (c) Phil Freeman 2013
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- |
12−-- Desugaring passes
13−--
14−-----------------------------------------------------------------------------
15−
16−module Language.PureScript.Sugar (desugar, module S) where
17−
18−import Control.Monad
19−import Control.Category ((>>>))
20−import Control.Monad.Trans.Class
21−
22−import Language.PureScript.AST
23−import Language.PureScript.Errors
24−import Language.PureScript.Supply
25−
26−import Language.PureScript.Sugar.Operators as S
27−import Language.PureScript.Sugar.DoNotation as S
28−import Language.PureScript.Sugar.CaseDeclarations as S
29−import Language.PureScript.Sugar.TypeDeclarations as S
30−import Language.PureScript.Sugar.BindingGroups as S
31−import Language.PureScript.Sugar.TypeClasses as S
32−import Language.PureScript.Sugar.Names as S
33−
34−-- |
35−-- The desugaring pipeline proceeds as follows:
36−--
37−-- * Introduce type synonyms for type class dictionaries
38−--
39−-- * Rebracket user-defined binary operators
40−--
41−-- * Desugar do-notation using the @Prelude.Monad@ type class
42−--
43−-- * Desugar top-level case declarations into explicit case expressions
44−--
45−-- * Desugar type declarations into value declarations with explicit type annotations
46−--
47−-- * Group mutually recursive value and data declarations into binding groups.
48−--
49−-- * Qualify any unqualified names and types
50−--
51−desugar :: [Module] -> SupplyT (Either ErrorStack) [Module]
52−desugar = map removeSignedLiterals
53− >>> mapM desugarDoModule
54− >=> desugarCasesModule
55− >=> lift . (desugarTypeDeclarationsModule
56− >=> desugarImports
57− >=> rebracket)
58− >=> desugarTypeClasses
59− >=> lift . createBindingGroupsModule
src/Language/PureScript/Sugar/BindingGroups.hsdeleted−205
@@ -1,205 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.BindingGroups
4−-- Copyright : (c) Phil Freeman 2013
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- |
12−-- This module implements the desugaring pass which creates binding groups from sets of
13−-- mutually-recursive value declarations and mutually-recursive type declarations.
14−--
15−-----------------------------------------------------------------------------
16−
17−module Language.PureScript.Sugar.BindingGroups (
18− createBindingGroups,
19− createBindingGroupsModule,
20− collapseBindingGroups,
21− collapseBindingGroupsModule
22−) where
23−
24−import Data.Graph
25−import Data.List (nub, intersect)
26−import Data.Maybe (isJust, mapMaybe)
27−import Data.Monoid ((<>))
28−import Control.Applicative ((<$>), (<*>), pure)
29−import Control.Monad ((<=<))
30−
31−import qualified Data.Set as S
32−
33−import Language.PureScript.AST
34−import Language.PureScript.Names
35−import Language.PureScript.Types
36−import Language.PureScript.Environment
37−import Language.PureScript.Errors
38−
39−-- |
40−-- Replace all sets of mutually-recursive declarations in a module with binding groups
41−--
42−createBindingGroupsModule :: [Module] -> Either ErrorStack [Module]
43−createBindingGroupsModule = mapM $ \(Module name ds exps) -> Module name <$> createBindingGroups name ds <*> pure exps
44−
45−-- |
46−-- Collapse all binding groups in a module to individual declarations
47−--
48−collapseBindingGroupsModule :: [Module] -> [Module]
49−collapseBindingGroupsModule = map $ \(Module name ds exps) -> Module name (collapseBindingGroups ds) exps
50−
51−createBindingGroups :: ModuleName -> [Declaration] -> Either ErrorStack [Declaration]
52−createBindingGroups moduleName = mapM f <=< handleDecls
53−
54− where
55− (f, _, _) = everywhereOnValuesTopDownM return handleExprs return
56−
57− handleExprs :: Expr -> Either ErrorStack Expr
58− handleExprs (Let ds val) = flip Let val <$> handleDecls ds
59− handleExprs other = return other
60−
61− -- |
62− -- Replace all sets of mutually-recursive declarations with binding groups
63− --
64− handleDecls :: [Declaration] -> Either ErrorStack [Declaration]
65− handleDecls ds = do
66− let values = filter isValueDecl ds
67− dataDecls = filter isDataDecl ds
68− allProperNames = map getProperName dataDecls
69− dataVerts = map (\d -> (d, getProperName d, usedProperNames moduleName d `intersect` allProperNames)) dataDecls
70− dataBindingGroupDecls <- parU (stronglyConnComp dataVerts) toDataBindingGroup
71− let allIdents = map getIdent values
72− valueVerts = map (\d -> (d, getIdent d, usedIdents moduleName d `intersect` allIdents)) values
73− bindingGroupDecls <- parU (stronglyConnComp valueVerts) (toBindingGroup moduleName)
74− return $ filter isImportDecl ds ++
75− filter isExternDataDecl ds ++
76− filter isExternInstanceDecl ds ++
77− dataBindingGroupDecls ++
78− filter isTypeClassDeclaration ds ++
79− filter isFixityDecl ds ++
80− filter isExternDecl ds ++
81− bindingGroupDecls
82−
83−-- |
84−-- Collapse all binding groups to individual declarations
85−--
86−collapseBindingGroups :: [Declaration] -> [Declaration]
87−collapseBindingGroups = let (f, _, _) = everywhereOnValues id collapseBindingGroupsForValue id in map f . concatMap go
88− where
89− go (DataBindingGroupDeclaration ds) = ds
90− go (BindingGroupDeclaration ds) = map (\(ident, nameKind, val) -> ValueDeclaration ident nameKind [] (Right val)) ds
91− go (PositionedDeclaration pos d) = map (PositionedDeclaration pos) $ go d
92− go other = [other]
93−
94−collapseBindingGroupsForValue :: Expr -> Expr
95−collapseBindingGroupsForValue (Let ds val) = Let (collapseBindingGroups ds) val
96−collapseBindingGroupsForValue other = other
97−
98−usedIdents :: ModuleName -> Declaration -> [Ident]
99−usedIdents moduleName =
100− let (f, _, _, _, _) = everythingWithContextOnValues S.empty [] (++) def usedNamesE usedNamesB def def
101− in nub . f
102− where
103− def s _ = (s, [])
104−
105− usedNamesE :: S.Set Ident -> Expr -> (S.Set Ident, [Ident])
106− usedNamesE scope (Var (Qualified Nothing name)) | name `S.notMember` scope = (scope, [name])
107− usedNamesE scope (Var (Qualified (Just moduleName') name)) | moduleName == moduleName' && name `S.notMember` scope = (scope, [name])
108− usedNamesE scope (Abs (Left name) _) = (name `S.insert` scope, [])
109− usedNamesE scope _ = (scope, [])
110−
111− usedNamesB :: S.Set Ident -> Binder -> (S.Set Ident, [Ident])
112− usedNamesB scope binder = (scope `S.union` S.fromList (binderNames binder), [])
113−
114−usedImmediateIdents :: ModuleName -> Declaration -> [Ident]
115−usedImmediateIdents moduleName =
116− let (f, _, _, _, _) = everythingWithContextOnValues True [] (++) def usedNamesE def def def
117− in nub . f
118− where
119− def s _ = (s, [])
120−
121− usedNamesE :: Bool -> Expr -> (Bool, [Ident])
122− usedNamesE True (Var (Qualified Nothing name)) = (True, [name])
123− usedNamesE True (Var (Qualified (Just moduleName') name)) | moduleName == moduleName' = (True, [name])
124− usedNamesE True (Abs _ _) = (False, [])
125− usedNamesE scope _ = (scope, [])
126−
127−usedProperNames :: ModuleName -> Declaration -> [ProperName]
128−usedProperNames moduleName =
129− let (f, _, _, _, _) = accumTypes (everythingOnTypes (++) usedNames)
130− in nub . f
131− where
132− usedNames :: Type -> [ProperName]
133− usedNames (ConstrainedType constraints _) = flip mapMaybe constraints $ \qual ->
134− case qual of
135− (Qualified (Just moduleName') name, _) | moduleName == moduleName' -> Just name
136− _ -> Nothing
137− usedNames (TypeConstructor (Qualified (Just moduleName') name)) | moduleName == moduleName' = [name]
138− usedNames _ = []
139−
140−getIdent :: Declaration -> Ident
141−getIdent (ValueDeclaration ident _ _ _) = ident
142−getIdent (PositionedDeclaration _ d) = getIdent d
143−getIdent _ = error "Expected ValueDeclaration"
144−
145−getProperName :: Declaration -> ProperName
146−getProperName (DataDeclaration _ pn _ _) = pn
147−getProperName (TypeSynonymDeclaration pn _ _) = pn
148−getProperName (PositionedDeclaration _ d) = getProperName d
149−getProperName _ = error "Expected DataDeclaration"
150−
151−-- |
152−-- Convert a group of mutually-recursive dependencies into a BindingGroupDeclaration (or simple ValueDeclaration).
153−--
154−--
155−toBindingGroup :: ModuleName -> SCC Declaration -> Either ErrorStack Declaration
156−toBindingGroup _ (AcyclicSCC d) = return d
157−toBindingGroup _ (CyclicSCC [d]) = return d
158−toBindingGroup moduleName (CyclicSCC ds') =
159− -- Once we have a mutually-recursive group of declarations, we need to sort
160− -- them further by their immediate dependencies (those outside function
161− -- bodies). In particular, this is relevant for type instance dictionaries
162− -- whose members require other type instances (for example, functorEff
163− -- defines (<$>) = liftA1, which depends on applicativeEff). Note that
164− -- superclass references are still inside functions, so don't count here.
165− -- If we discover declarations that still contain mutually-recursive
166− -- immediate references, we're guaranteed to get an undefined reference at
167− -- runtime, so treat this as an error. See also github issue #365.
168− BindingGroupDeclaration <$> mapM toBinding (stronglyConnComp valueVerts)
169− where
170− idents :: [Ident]
171− idents = map (\(_, i, _) -> i) valueVerts
172−
173− valueVerts :: [(Declaration, Ident, [Ident])]
174− valueVerts = map (\d -> (d, getIdent d, usedImmediateIdents moduleName d `intersect` idents)) ds'
175−
176− toBinding :: SCC Declaration -> Either ErrorStack (Ident, NameKind, Expr)
177− toBinding (AcyclicSCC d) = return $ fromValueDecl d
178− toBinding (CyclicSCC ~(d:ds)) = cycleError d ds
179−
180− cycleError :: Declaration -> [Declaration] -> Either ErrorStack a
181− cycleError (PositionedDeclaration p d) ds = rethrowWithPosition p $ cycleError d ds
182− cycleError (ValueDeclaration n _ _ (Right e)) [] = Left $
183− mkErrorStack ("Cycle in definition of " ++ show n) (Just (ExprError e))
184− cycleError d ds@(_:_) = rethrow (<> mkErrorStack ("The following are not yet defined here: " ++ unwords (map (show . getIdent) ds)) Nothing) $ cycleError d []
185− cycleError _ _ = error "Expected ValueDeclaration"
186−
187−toDataBindingGroup :: SCC Declaration -> Either ErrorStack Declaration
188−toDataBindingGroup (AcyclicSCC d) = return d
189−toDataBindingGroup (CyclicSCC [d]) = case isTypeSynonym d of
190− Just pn -> Left $ mkErrorStack ("Cycle in type synonym " ++ show pn) Nothing
191− _ -> return d
192−toDataBindingGroup (CyclicSCC ds')
193− | all (isJust . isTypeSynonym) ds' = Left $ mkErrorStack "Cycle in type synonyms" Nothing
194− | otherwise = return $ DataBindingGroupDeclaration ds'
195−
196−isTypeSynonym :: Declaration -> Maybe ProperName
197−isTypeSynonym (TypeSynonymDeclaration pn _ _) = Just pn
198−isTypeSynonym (PositionedDeclaration _ d) = isTypeSynonym d
199−isTypeSynonym _ = Nothing
200−
201−fromValueDecl :: Declaration -> (Ident, NameKind, Expr)
202−fromValueDecl (ValueDeclaration ident nameKind [] (Right val)) = (ident, nameKind, val)
203−fromValueDecl ValueDeclaration{} = error "Binders should have been desugared"
204−fromValueDecl (PositionedDeclaration _ d) = fromValueDecl d
205−fromValueDecl _ = error "Expected ValueDeclaration"
src/Language/PureScript/Sugar/CaseDeclarations.hsdeleted−127
@@ -1,127 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.CaseDeclarations
4−-- Copyright : (c) Phil Freeman 2013
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- |
12−-- This module implements the desugaring pass which replaces top-level binders with
13−-- case expressions.
14−--
15−-----------------------------------------------------------------------------
16−
17−module Language.PureScript.Sugar.CaseDeclarations (
18− desugarCases,
19− desugarCasesModule
20−) where
21−
22−import Data.Monoid ((<>))
23−import Data.List (nub, groupBy)
24−
25−import Control.Applicative
26−import Control.Monad ((<=<), forM, join, unless, replicateM)
27−import Control.Monad.Error.Class
28−
29−import Language.PureScript.Names
30−import Language.PureScript.AST
31−import Language.PureScript.Environment
32−import Language.PureScript.Errors
33−import Language.PureScript.Supply
34−import Language.PureScript.Traversals
35−import Language.PureScript.TypeChecker.Monad (guardWith)
36−
37−-- Data.Either.isLeft (base 4.7)
38−isLeft :: Either a b -> Bool
39−isLeft (Left _) = True
40−isLeft (Right _) = False
41−
42−-- |
43−-- Replace all top-level binders in a module with case expressions.
44−--
45−desugarCasesModule :: [Module] -> SupplyT (Either ErrorStack) [Module]
46−desugarCasesModule ms = forM ms $ \(Module name ds exps) ->
47− rethrow (strMsg ("Error in module " ++ show name) <>) $
48− Module name <$> (desugarCases <=< desugarAbs $ ds) <*> pure exps
49−
50−desugarAbs :: [Declaration] -> SupplyT (Either ErrorStack) [Declaration]
51−desugarAbs = flip parU f
52− where
53− (f, _, _) = everywhereOnValuesM return replace return
54−
55− replace :: Expr -> SupplyT (Either ErrorStack) Expr
56− replace (Abs (Right binder) val) = do
57− ident <- Ident <$> freshName
58− return $ Abs (Left ident) $ Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] (Right val)]
59− replace other = return other
60−
61−-- |
62−-- Replace all top-level binders with case expressions.
63−--
64−desugarCases :: [Declaration] -> SupplyT (Either ErrorStack) [Declaration]
65−desugarCases = desugarRest <=< fmap join . flip parU toDecls . groupBy inSameGroup
66− where
67− desugarRest :: [Declaration] -> SupplyT (Either ErrorStack) [Declaration]
68− desugarRest (TypeInstanceDeclaration name constraints className tys ds : rest) =
69− (:) <$> (TypeInstanceDeclaration name constraints className tys <$> desugarCases ds) <*> desugarRest rest
70− desugarRest (ValueDeclaration name nameKind bs result : rest) =
71− let (_, f, _) = everywhereOnValuesTopDownM return go return
72− f' (Left gs) = Left <$> mapM (pairM return f) gs
73− f' (Right v) = Right <$> f v
74− in (:) <$> (ValueDeclaration name nameKind bs <$> f' result) <*> desugarRest rest
75− where
76− go (Let ds val') = Let <$> desugarCases ds <*> pure val'
77− go other = return other
78− desugarRest (PositionedDeclaration pos d : ds) = do
79− (d' : ds') <- desugarRest (d : ds)
80− return (PositionedDeclaration pos d' : ds')
81− desugarRest (d : ds) = (:) d <$> desugarRest ds
82− desugarRest [] = pure []
83−
84−inSameGroup :: Declaration -> Declaration -> Bool
85−inSameGroup (ValueDeclaration ident1 _ _ _) (ValueDeclaration ident2 _ _ _) = ident1 == ident2
86−inSameGroup (PositionedDeclaration _ d1) d2 = inSameGroup d1 d2
87−inSameGroup d1 (PositionedDeclaration _ d2) = inSameGroup d1 d2
88−inSameGroup _ _ = False
89−
90−toDecls :: [Declaration] -> SupplyT (Either ErrorStack) [Declaration]
91−toDecls [ValueDeclaration ident nameKind bs (Right val)] | all isVarBinder bs = do
92− let args = map (\(VarBinder arg) -> arg) bs
93− body = foldr (Abs . Left) val args
94− guardWith (strMsg "Overlapping function argument names") $ length (nub args) == length args
95− return [ValueDeclaration ident nameKind [] (Right body)]
96−toDecls ds@(ValueDeclaration ident _ bs result : _) = do
97− let tuples = map toTuple ds
98− unless (all ((== length bs) . length . fst) tuples) $
99− throwError $ mkErrorStack ("Argument list lengths differ in declaration " ++ show ident) Nothing
100− unless (not (null bs) || isLeft result) $
101− throwError $ mkErrorStack ("Duplicate value declaration '" ++ show ident ++ "'") Nothing
102− caseDecl <- makeCaseDeclaration ident tuples
103− return [caseDecl]
104−toDecls (PositionedDeclaration pos d : ds) = do
105− (d' : ds') <- rethrowWithPosition pos $ toDecls (d : ds)
106− return (PositionedDeclaration pos d' : ds')
107−toDecls ds = return ds
108−
109−isVarBinder :: Binder -> Bool
110−isVarBinder (VarBinder _) = True
111−isVarBinder _ = False
112−
113−toTuple :: Declaration -> ([Binder], Either [(Guard, Expr)] Expr)
114−toTuple (ValueDeclaration _ _ bs result) = (bs, result)
115−toTuple (PositionedDeclaration _ d) = toTuple d
116−toTuple _ = error "Not a value declaration"
117−
118−makeCaseDeclaration :: Ident -> [([Binder], Either [(Guard, Expr)] Expr)] -> SupplyT (Either ErrorStack) Declaration
119−makeCaseDeclaration ident alternatives = do
120− let argPattern = length . fst . head $ alternatives
121− args <- map Ident <$> replicateM argPattern freshName
122− let
123− vars = map (Var . Qualified Nothing) args
124− binders = [ CaseAlternative bs result | (bs, result) <- alternatives ]
125− value = foldr (Abs . Left) (Case vars binders) args
126− return $ ValueDeclaration ident Value [] (Right value)
127−
src/Language/PureScript/Sugar/DoNotation.hsdeleted−74
@@ -1,74 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.Sugar.DoNotation
4−-- Copyright : (c) Phil Freeman 2013
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- |
12−-- This module implements the desugaring pass which replaces do-notation statements with
13−-- appropriate calls to (>>=) from the Prelude.Monad type class.
14−--
15−-----------------------------------------------------------------------------
16−
17−module Language.PureScript.Sugar.DoNotation (
18− desugarDoModule
19−) where
20−
21−import Language.PureScript.Names
22−import Language.PureScript.AST
23−import Language.PureScript.Errors
24−import Language.PureScript.Supply
25−
26−import qualified Language.PureScript.Constants as C
27−
28−import Control.Applicative
29−import Control.Monad.Trans.Class
30−
31−-- |
32−-- Replace all @DoNotationBind@ and @DoNotationValue@ constructors with applications of the Prelude.(>>=) function,
33−-- and all @DoNotationLet@ constructors with let expressions.
34−--
35−desugarDoModule :: Module -> SupplyT (Either ErrorStack) Module
36−desugarDoModule (Module mn ds exts) = Module mn <$> parU ds desugarDo <*> pure exts
37−
38−desugarDo :: Declaration -> SupplyT (Either ErrorStack) Declaration
39−desugarDo (PositionedDeclaration pos d) = (PositionedDeclaration pos) <$> (rethrowWithPosition pos $ desugarDo d)
40−desugarDo d =
41− let (f, _, _) = everywhereOnValuesM return replace return
42− in f d
43− where
44− prelude :: ModuleName
45− prelude = ModuleName [ProperName C.prelude]
46−
47− bind :: Expr
48− bind = Var (Qualified (Just prelude) (Op (C.>>=)))
49−
50− replace :: Expr -> SupplyT (Either ErrorStack) Expr
51− replace (Do els) = go els
52− replace (PositionedValue pos v) = PositionedValue pos <$> rethrowWithPosition pos (replace v)
53− replace other = return other
54−
55− go :: [DoNotationElement] -> SupplyT (Either ErrorStack) Expr
56− go [] = error "The impossible happened in desugarDo"
57− go [DoNotationValue val] = return val
58− go (DoNotationValue val : rest) = do
59− rest' <- go rest
60− return $ App (App bind val) (Abs (Left (Ident C.__unused)) rest')
61− go [DoNotationBind _ _] = lift $ Left $ mkErrorStack "Bind statement cannot be the last statement in a do block" Nothing
62− go (DoNotationBind NullBinder val : rest) = go (DoNotationValue val : rest)
63− go (DoNotationBind (VarBinder ident) val : rest) = do
64− rest' <- go rest
65− return $ App (App bind val) (Abs (Left ident) rest')
66− go (DoNotationBind binder val : rest) = do
67− rest' <- go rest
68− ident <- Ident <$> freshName
69− return $ App (App bind val) (Abs (Left ident) (Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] (Right rest')]))
70− go [DoNotationLet _] = lift $ Left $ mkErrorStack "Let statement cannot be the last statement in a do block" Nothing
71− go (DoNotationLet ds : rest) = do
72− rest' <- go rest
73− return $ Let ds rest'
74− go (PositionedDoNotationElement pos el : rest) = rethrowWithPosition pos $ PositionedValue pos <$> go (el : rest)
src/Language/PureScript/Sugar/Names.hsdeleted−522
@@ -1,522 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.Sugar.Names
4−-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- |
12−--
13−-----------------------------------------------------------------------------
14−
15−module Language.PureScript.Sugar.Names (
16− desugarImports
17−) where
18−
19−import Data.List (nub)
20−import Data.Maybe (fromMaybe, isJust, mapMaybe)
21−import Data.Monoid ((<>))
22−
23−import Control.Applicative (Applicative(..), (<$>), (<*>))
24−import Control.Monad.Error
25−
26−import qualified Data.Map as M
27−
28−import Language.PureScript.AST
29−import Language.PureScript.Names
30−import Language.PureScript.Types
31−import Language.PureScript.Environment
32−import Language.PureScript.Errors
33−import Language.PureScript.Traversals
34−
35−import qualified Language.PureScript.Constants as C
36−
37−-- |
38−-- The global export environment - every declaration exported from every module.
39−--
40−type ExportEnvironment = M.Map ModuleName Exports
41−
42−-- |
43−-- The exported declarations from a module.
44−--
45−data Exports = Exports
46− {
47− -- |
48− -- The types exported from each module
49− --
50− exportedTypes :: [(ProperName, [ProperName])]
51− -- |
52− -- The classes exported from each module
53− --
54− , exportedTypeClasses :: [ProperName]
55− -- |
56− -- The values exported from each module
57− , exportedValues :: [Ident]
58− --
59− } deriving (Show)
60−
61−-- |
62−-- An imported environment for a particular module. This also contains the module's own members.
63−--
64−data ImportEnvironment = ImportEnvironment
65− {
66− -- |
67− -- Local names for types within a module mapped to to their qualified names
68− --
69− importedTypes :: M.Map (Qualified ProperName) (Qualified ProperName)
70− -- |
71− -- Local names for data constructors within a module mapped to to their qualified names
72− --
73− , importedDataConstructors :: M.Map (Qualified ProperName) (Qualified ProperName)
74− -- |
75− -- Local names for classes within a module mapped to to their qualified names
76− --
77− , importedTypeClasses :: M.Map (Qualified ProperName) (Qualified ProperName)
78− -- |
79− -- Local names for values within a module mapped to to their qualified names
80− --
81− , importedValues :: M.Map (Qualified Ident) (Qualified Ident)
82− } deriving (Show)
83−
84−-- |
85−-- Updates the exports for a module from the global environment. If the module was not previously
86−-- present in the global environment, it is created.
87−--
88−updateExportedModule :: ExportEnvironment -> ModuleName -> (Exports -> Either ErrorStack Exports) -> Either ErrorStack ExportEnvironment
89−updateExportedModule env mn update = do
90− let exports = fromMaybe (error "Module was undefined in updateExportedModule") $ mn `M.lookup` env
91− exports' <- update exports
92− return $ M.insert mn exports' env
93−
94−-- |
95−-- Adds an empty module to an ExportEnvironment.
96−--
97−addEmptyModule :: ExportEnvironment -> ModuleName -> Either ErrorStack ExportEnvironment
98−addEmptyModule env name =
99− if name `M.member` env
100− then throwError $ mkErrorStack ("Module '" ++ show name ++ "' has been defined more than once") Nothing
101− else return $ M.insert name (Exports [] [] []) env
102−
103−-- |
104−-- Adds a type belonging to a module to the export environment.
105−--
106−addType :: ExportEnvironment -> ModuleName -> ProperName -> [ProperName] -> Either ErrorStack ExportEnvironment
107−addType env mn name dctors = updateExportedModule env mn $ \m -> do
108− types' <- addExport (exportedTypes m) (name, dctors)
109− return $ m { exportedTypes = types' }
110−
111−-- |
112−-- Adds a class to the export environment.
113−--
114−addTypeClass :: ExportEnvironment -> ModuleName -> ProperName -> Either ErrorStack ExportEnvironment
115−addTypeClass env mn name = updateExportedModule env mn $ \m -> do
116− classes <- addExport (exportedTypeClasses m) name
117− return $ m { exportedTypeClasses = classes }
118−
119−-- |
120−-- Adds a class to the export environment.
121−--
122−addValue :: ExportEnvironment -> ModuleName -> Ident -> Either ErrorStack ExportEnvironment
123−addValue env mn name = updateExportedModule env mn $ \m -> do
124− values <- addExport (exportedValues m) name
125− return $ m { exportedValues = values }
126−
127−-- |
128−-- Adds an entry to a list of exports unless it is already present, in which case an error is
129−-- returned.
130−--
131−addExport :: (Eq a, Show a) => [a] -> a -> Either ErrorStack [a]
132−addExport exports name =
133− if name `elem` exports
134− then throwError $ mkErrorStack ("Multiple definitions for '" ++ show name ++ "'") Nothing
135− else return $ name : exports
136−
137−-- |
138−-- Replaces all local names with qualified names within a set of modules.
139−--
140−desugarImports :: [Module] -> Either ErrorStack [Module]
141−desugarImports modules = do
142− unfilteredExports <- findExports modules
143− exports <- foldM filterModuleExports unfilteredExports modules
144− mapM (renameInModule' unfilteredExports exports) modules
145− where
146−
147− -- Filters the exports for a module in the global exports environment so that only explicitly
148− -- exported members remain. If the module does not explicitly export anything, everything is
149− -- exported.
150− filterModuleExports :: ExportEnvironment -> Module -> Either ErrorStack ExportEnvironment
151− filterModuleExports env (Module mn _ (Just exps)) = filterExports mn exps env
152− filterModuleExports env _ = return env
153−
154− -- Rename and check all the names within a module. We tweak the global exports environment so
155− -- the module has access to an unfiltered list of its own members.
156− renameInModule' :: ExportEnvironment -> ExportEnvironment -> Module -> Either ErrorStack Module
157− renameInModule' unfilteredExports exports m@(Module mn _ _) =
158− rethrow (strMsg ("Error in module " ++ show mn) <>) $ do
159− let env = M.update (\_ -> M.lookup mn unfilteredExports) mn exports
160− let exps = fromMaybe (error "Module is missing in renameInModule'") $ M.lookup mn exports
161− imports <- resolveImports env m
162− elaborateImports <$> renameInModule imports env (elaborateExports exps m)
163−
164−-- |
165−-- Make all exports for a module explicit. This may still effect modules that have an exports list,
166−-- as it will also make all data constructor exports explicit.
167−--
168−elaborateExports :: Exports -> Module -> Module
169−elaborateExports exps (Module mn decls _) = Module mn decls (Just $
170− map (\(ctor, dctors) -> TypeRef ctor (Just dctors)) (exportedTypes exps) ++
171− map TypeClassRef (exportedTypeClasses exps) ++
172− map ValueRef (exportedValues exps))
173−
174−-- |
175−-- Add `import X ()` for any modules where there are only fully qualified references to members.
176−-- This ensures transitive instances are included when using a member from a module.
177−--
178−elaborateImports :: Module -> Module
179−elaborateImports (Module mn decls exps) = Module mn decls' exps
180− where
181− decls' :: [Declaration]
182− decls' =
183− let (f, _, _, _, _) = everythingOnValues (++) (const []) fqValues (const []) (const []) (const [])
184− in mkImport `map` nub (f `concatMap` decls) ++ decls
185− fqValues :: Expr -> [ModuleName]
186− fqValues (Var (Qualified (Just mn') _)) = [mn']
187− fqValues _ = []
188− mkImport :: ModuleName -> Declaration
189− mkImport mn' = ImportDeclaration mn' (Qualifying []) Nothing
190−
191−-- |
192−-- Replaces all local names with qualified names within a module and checks that all existing
193−-- qualified names are valid.
194−--
195−renameInModule :: ImportEnvironment -> ExportEnvironment -> Module -> Either ErrorStack Module
196−renameInModule imports exports (Module mn decls exps) =
197− Module mn <$> parU decls go <*> pure exps
198− where
199− (go, _, _, _, _) = everywhereWithContextOnValuesM (Nothing, []) updateDecl updateValue updateBinder updateCase defS
200−
201− updateDecl :: (Maybe SourceSpan, [Ident]) -> Declaration -> Either ErrorStack ((Maybe SourceSpan, [Ident]), Declaration)
202− updateDecl (_, bound) d@(PositionedDeclaration pos _) = return ((Just pos, bound), d)
203− updateDecl (pos, bound) (DataDeclaration dtype name args dctors) =
204− (,) (pos, bound) <$> (DataDeclaration dtype name args <$> mapM (sndM (mapM (updateTypesEverywhere pos))) dctors)
205− updateDecl (pos, bound) (TypeSynonymDeclaration name ps ty) =
206− (,) (pos, bound) <$> (TypeSynonymDeclaration name ps <$> updateTypesEverywhere pos ty)
207− updateDecl (pos, bound) (TypeClassDeclaration className args implies ds) =
208− (,) (pos, bound) <$> (TypeClassDeclaration className args <$> updateConstraints pos implies <*> pure ds)
209− updateDecl (pos, bound) (TypeInstanceDeclaration name cs cn ts ds) =
210− (,) (pos, bound) <$> (TypeInstanceDeclaration name <$> updateConstraints pos cs <*> updateClassName cn pos <*> mapM (updateTypesEverywhere pos) ts <*> pure ds)
211− updateDecl (pos, bound) (ExternInstanceDeclaration name cs cn ts) =
212− (,) (pos, bound) <$> (ExternInstanceDeclaration name <$> updateConstraints pos cs <*> updateClassName cn Nothing <*> mapM (updateTypesEverywhere pos) ts)
213− updateDecl (pos, bound) (TypeDeclaration name ty) =
214− (,) (pos, bound) <$> (TypeDeclaration name <$> updateTypesEverywhere pos ty)
215− updateDecl (pos, bound) (ExternDeclaration fit name js ty) =
216− (,) (pos, name : bound) <$> (ExternDeclaration fit name js <$> updateTypesEverywhere pos ty)
217− updateDecl s d = return (s, d)
218−
219− updateValue :: (Maybe SourceSpan, [Ident]) -> Expr -> Either ErrorStack ((Maybe SourceSpan, [Ident]), Expr)
220− updateValue (_, bound) v@(PositionedValue pos' _) = return ((Just pos', bound), v)
221− updateValue (pos, bound) (Abs (Left arg) val') = return ((pos, arg : bound), Abs (Left arg) val')
222− updateValue (pos, bound) (Let ds val') =
223− let args = mapMaybe letBoundVariable ds
224− in return ((pos, args ++ bound), Let ds val')
225− updateValue (pos, bound) (Var name'@(Qualified Nothing ident)) | ident `notElem` bound =
226− (,) (pos, bound) <$> (Var <$> updateValueName name' pos)
227− updateValue (pos, bound) (Var name'@(Qualified (Just _) _)) =
228− (,) (pos, bound) <$> (Var <$> updateValueName name' pos)
229− updateValue (pos, bound) (BinaryNoParens name'@(Qualified Nothing ident) v1 v2) | ident `notElem` bound =
230− (,) (pos, bound) <$> (BinaryNoParens <$> updateValueName name' pos <*> pure v1 <*> pure v2)
231− updateValue (pos, bound) (BinaryNoParens name'@(Qualified (Just _) _) v1 v2) =
232− (,) (pos, bound) <$> (BinaryNoParens <$> updateValueName name' pos <*> pure v1 <*> pure v2)
233− updateValue s@(pos, _) (Constructor name) = (,) s <$> (Constructor <$> updateDataConstructorName name pos)
234− updateValue s@(pos, _) (TypedValue check val ty) = (,) s <$> (TypedValue check val <$> updateTypesEverywhere pos ty)
235− updateValue s v = return (s, v)
236−
237− updateBinder :: (Maybe SourceSpan, [Ident]) -> Binder -> Either ErrorStack ((Maybe SourceSpan, [Ident]), Binder)
238− updateBinder (_, bound) v@(PositionedBinder pos _) = return ((Just pos, bound), v)
239− updateBinder s@(pos, _) (ConstructorBinder name b) = (,) s <$> (ConstructorBinder <$> updateDataConstructorName name pos <*> pure b)
240− updateBinder s v = return (s, v)
241−
242− updateCase :: (Maybe SourceSpan, [Ident]) -> CaseAlternative -> Either ErrorStack ((Maybe SourceSpan, [Ident]), CaseAlternative)
243− updateCase (pos, bound) c@(CaseAlternative bs _) = return ((pos, concatMap binderNames bs ++ bound), c)
244−
245− letBoundVariable :: Declaration -> Maybe Ident
246− letBoundVariable (ValueDeclaration ident _ _ _) = Just ident
247− letBoundVariable (PositionedDeclaration _ d) = letBoundVariable d
248− letBoundVariable _ = Nothing
249−
250− updateTypesEverywhere :: Maybe SourceSpan -> Type -> Either ErrorStack Type
251− updateTypesEverywhere pos0 = everywhereOnTypesM (updateType pos0)
252− where
253− updateType :: Maybe SourceSpan -> Type -> Either ErrorStack Type
254− updateType pos (TypeConstructor name) = TypeConstructor <$> updateTypeName name pos
255− updateType pos (SaturatedTypeSynonym name tys) = SaturatedTypeSynonym <$> updateTypeName name pos <*> pure tys
256− updateType pos (ConstrainedType cs t) = ConstrainedType <$> updateConstraints pos cs <*> pure t
257− updateType _ t = return t
258−
259− updateConstraints pos = mapM (\(name, ts) -> (,) <$> updateClassName name pos <*> mapM (updateTypesEverywhere pos) ts)
260−
261− updateTypeName = update "type" importedTypes (\mes -> isJust . (`lookup` exportedTypes mes))
262− updateClassName = update "type class" importedTypeClasses (flip elem . exportedTypeClasses)
263− updateValueName = update "value" importedValues (flip elem . exportedValues)
264− updateDataConstructorName = update "data constructor" importedDataConstructors (\mes -> flip elem (join $ snd `map` exportedTypes mes))
265−
266− -- Update names so unqualified references become qualified, and locally qualified references
267− -- are replaced with their canoncial qualified names (e.g. M.Map -> Data.Map.Map)
268− update :: (Ord a, Show a) => String
269− -> (ImportEnvironment -> M.Map (Qualified a) (Qualified a))
270− -> (Exports -> a -> Bool)
271− -> Qualified a
272− -> Maybe SourceSpan
273− -> Either ErrorStack (Qualified a)
274− update t getI checkE qname@(Qualified mn' name) pos = positioned $ case (M.lookup qname imports', mn') of
275− (Just qname', _) -> return qname'
276− (Nothing, Just mn'') -> do
277− when (isExplicitQualModule mn'') $ throwError $ mkErrorStack ("Unknown " ++ t ++ " '" ++ show qname ++ "'") Nothing
278− modExports <- getExports mn''
279− if checkE modExports name
280− then return qname
281− else throwError $ mkErrorStack ("Unknown " ++ t ++ " '" ++ show qname ++ "'") Nothing
282− _ -> throwError $ mkErrorStack ("Unknown " ++ t ++ " '" ++ show name ++ "'") Nothing
283− where
284− isExplicitQualModule :: ModuleName -> Bool
285− isExplicitQualModule = flip elem $ mapMaybe (\(Qualified q _) -> q) (M.keys imports')
286− imports' = getI imports
287− positioned err = case pos of
288− Nothing -> err
289− Just pos' -> rethrowWithPosition pos' err
290−
291− -- Gets the exports for a module, or an error message if the module doesn't exist
292− getExports :: ModuleName -> Either ErrorStack Exports
293− getExports mn' = maybe (throwError $ mkErrorStack ("Unknown module '" ++ show mn' ++ "'") Nothing) return $ M.lookup mn' exports
294−
295−-- |
296−-- Finds all exported declarations in a set of modules.
297−--
298−findExports :: [Module] -> Either ErrorStack ExportEnvironment
299−findExports = foldM addModule $ M.singleton (ModuleName [ProperName C.prim]) primExports
300− where
301−
302− -- The exported types from the Prim module
303− primExports = Exports (mkTypeEntry `map` M.keys primTypes) [] []
304− where
305− mkTypeEntry (Qualified _ name) = (name, [])
306−
307− -- Add all of the exported declarations from a module to the global export environment
308− addModule :: ExportEnvironment -> Module -> Either ErrorStack ExportEnvironment
309− addModule env (Module mn ds _) = do
310− env' <- addEmptyModule env mn
311− rethrow (strMsg ("Error in module " ++ show mn) <>) $ foldM (addDecl mn) env' ds
312−
313− -- Add a declaration from a module to the global export environment
314− addDecl :: ModuleName -> ExportEnvironment -> Declaration -> Either ErrorStack ExportEnvironment
315− addDecl mn env (TypeClassDeclaration tcn _ _ ds) = do
316− env' <- addTypeClass env mn tcn
317− foldM go env' ds
318− where
319− go env'' (TypeDeclaration name _) = addValue env'' mn name
320− go env'' (PositionedDeclaration pos d) = rethrowWithPosition pos $ go env'' d
321− go _ _ = error "Invalid declaration in TypeClassDeclaration"
322− addDecl mn env (DataDeclaration _ tn _ dcs) = addType env mn tn (map fst dcs)
323− addDecl mn env (TypeSynonymDeclaration tn _ _) = addType env mn tn []
324− addDecl mn env (ExternDataDeclaration tn _) = addType env mn tn []
325− addDecl mn env (ValueDeclaration name _ _ _) = addValue env mn name
326− addDecl mn env (ExternDeclaration _ name _ _) = addValue env mn name
327− addDecl mn env (PositionedDeclaration _ d) = addDecl mn env d
328− addDecl _ env _ = return env
329−
330−-- |
331−-- Filters the exports for a module to ensure only explicit exports are kept in the global exports
332−-- environment.
333−--
334−filterExports :: ModuleName -> [DeclarationRef] -> ExportEnvironment -> Either ErrorStack ExportEnvironment
335−filterExports mn exps env = do
336− let moduleExports = fromMaybe (error "Module is missing") (mn `M.lookup` env)
337− moduleExports' <- rethrow (strMsg ("Error in module " ++ show mn) <>) $ filterModule moduleExports
338− return $ M.insert mn moduleExports' env
339− where
340−
341− -- Filter the exports for the specific module
342− filterModule :: Exports -> Either ErrorStack Exports
343− filterModule exported = do
344− types' <- foldM (filterTypes $ exportedTypes exported) [] exps
345− values <- foldM (filterValues $ exportedValues exported) [] exps
346− classes <- foldM (filterClasses $ exportedTypeClasses exported) [] exps
347− return exported { exportedTypes = types', exportedTypeClasses = classes, exportedValues = values }
348−
349− -- Ensure the exported types and data constructors exist in the module and add them to the set of
350− -- exports
351− filterTypes :: [(ProperName, [ProperName])] -> [(ProperName, [ProperName])] -> DeclarationRef -> Either ErrorStack [(ProperName, [ProperName])]
352− filterTypes expTys result (PositionedDeclarationRef pos r) = rethrowWithPosition pos $ filterTypes expTys result r
353− filterTypes expTys result (TypeRef name expDcons) = do
354− dcons <- maybe (throwError $ mkErrorStack ("Cannot export undefined type '" ++ show name ++ "'") Nothing) return $ name `lookup` expTys
355− dcons' <- maybe (return dcons) (foldM (filterDcons name dcons) []) expDcons
356− return $ (name, dcons') : result
357− filterTypes _ result _ = return result
358−
359− -- Ensure the exported data constructors exists for a type and add them to the list of exports
360− filterDcons :: ProperName -> [ProperName] -> [ProperName] -> ProperName -> Either ErrorStack [ProperName]
361− filterDcons tcon exps' result name =
362− if name `elem` exps'
363− then return $ name : result
364− else throwError $ mkErrorStack ("Cannot export undefined data constructor '" ++ show name ++ "' for type '" ++ show tcon ++ "'") Nothing
365−
366− -- Ensure the exported classes exist in the module and add them to the set of exports
367− filterClasses :: [ProperName] -> [ProperName] -> DeclarationRef -> Either ErrorStack [ProperName]
368− filterClasses exps' result (PositionedDeclarationRef pos r) = rethrowWithPosition pos $ filterClasses exps' result r
369− filterClasses exps' result (TypeClassRef name) =
370− if name `elem` exps'
371− then return $ name : result
372− else throwError $ mkErrorStack ("Cannot export undefined type class '" ++ show name ++ "'") Nothing
373− filterClasses _ result _ = return result
374−
375− -- Ensure the exported values exist in the module and add them to the set of exports
376− filterValues :: [Ident] -> [Ident] -> DeclarationRef -> Either ErrorStack [Ident]
377− filterValues exps' result (PositionedDeclarationRef pos r) = rethrowWithPosition pos $ filterValues exps' result r
378− filterValues exps' result (ValueRef name) =
379− if name `elem` exps'
380− then return $ name : result
381− else throwError $ mkErrorStack ("Cannot export undefined value '" ++ show name ++ "'") Nothing
382− filterValues _ result _ = return result
383−
384−-- |
385−-- Finds the imports within a module, mapping the imported module name to an optional set of
386−-- explicitly imported declarations.
387−--
388−findImports :: [Declaration] -> M.Map ModuleName (Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)
389−findImports = foldl (findImports' Nothing) M.empty
390− where
391− findImports' pos result (ImportDeclaration mn typ qual) = M.insert mn (pos, typ, qual) result
392− findImports' _ result (PositionedDeclaration pos d) = findImports' (Just pos) result d
393− findImports' _ result _ = result
394−
395−-- |
396−-- Constructs a local environment for a module.
397−--
398−resolveImports :: ExportEnvironment -> Module -> Either ErrorStack ImportEnvironment
399−resolveImports env (Module currentModule decls _) =
400− foldM resolveImport' (ImportEnvironment M.empty M.empty M.empty M.empty) (M.toList scope)
401− where
402−
403− -- A Map from module name to the source position for the import, the list of imports from that
404− -- module (where Nothing indicates everything is to be imported), and optionally a qualified name
405− -- for the module
406− scope :: M.Map ModuleName (Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)
407− scope = M.insert currentModule (Nothing, Unqualified, Nothing) (findImports decls)
408−
409− resolveImport' :: ImportEnvironment -> (ModuleName, (Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)) -> Either ErrorStack ImportEnvironment
410− resolveImport' imp (mn, (pos, typ, impQual)) = do
411− modExports <- positioned $ maybe (throwError $ mkErrorStack ("Cannot import unknown module '" ++ show mn ++ "'") Nothing) return $ mn `M.lookup` env
412− positioned $ resolveImport currentModule mn modExports imp impQual typ
413− where
414− positioned err = case pos of
415− Nothing -> err
416− Just pos' -> rethrowWithPosition pos' err
417−
418−-- |
419−-- Extends the local environment for a module by resolving an import of another module.
420−--
421−resolveImport :: ModuleName -> ModuleName -> Exports -> ImportEnvironment -> Maybe ModuleName -> ImportDeclarationType -> Either ErrorStack ImportEnvironment
422−resolveImport currentModule importModule exps imps impQual =
423− resolveByType
424− where
425−
426− resolveByType :: ImportDeclarationType -> Either ErrorStack ImportEnvironment
427− resolveByType Unqualified = importAll importExplicit
428− resolveByType (Qualifying explImports) = (checkedRefs >=> foldM importExplicit imps) explImports
429− resolveByType (Hiding hiddenImports) = do
430− hiddenImports' <- checkedRefs hiddenImports
431− importAll (importNonHidden hiddenImports')
432−
433− importNonHidden :: [DeclarationRef] -> ImportEnvironment -> DeclarationRef -> Either ErrorStack ImportEnvironment
434− importNonHidden hidden m ref =
435− if isHidden hidden ref
436− then return m
437− else importExplicit m ref
438−
439− isHidden :: [DeclarationRef] -> DeclarationRef -> Bool
440− isHidden hidden ref@(TypeRef _ _) =
441− let
442− checkTypeRef _ True _ = True
443− checkTypeRef (TypeRef _ Nothing) acc (TypeRef _ (Just _)) = acc
444− checkTypeRef (TypeRef name (Just dctor)) _ (TypeRef name' (Just dctor')) = name == name' && dctor == dctor'
445− checkTypeRef (TypeRef name _) _ (TypeRef name' Nothing) = name == name'
446− checkTypeRef (PositionedDeclarationRef _ r) acc hiddenRef = checkTypeRef r acc hiddenRef
447− checkTypeRef _ acc _ = acc
448− in foldl (checkTypeRef ref) False hidden
449− isHidden hidden ref = ref `elem` hidden
450−
451− -- Import all symbols
452− importAll :: (ImportEnvironment -> DeclarationRef -> Either ErrorStack ImportEnvironment) -> Either ErrorStack ImportEnvironment
453− importAll importer = do
454− imp' <- foldM (\m (name, dctors) -> importer m (TypeRef name (Just dctors))) imps (exportedTypes exps)
455− imp'' <- foldM (\m name -> importer m (ValueRef name)) imp' (exportedValues exps)
456− foldM (\m name -> importer m (TypeClassRef name)) imp'' (exportedTypeClasses exps)
457−
458− -- Import something explicitly
459− importExplicit :: ImportEnvironment -> DeclarationRef -> Either ErrorStack ImportEnvironment
460− importExplicit imp (PositionedDeclarationRef pos r) = rethrowWithPosition pos $ importExplicit imp r
461− importExplicit imp (ValueRef name) = do
462− values' <- updateImports (importedValues imp) name
463− return $ imp { importedValues = values' }
464− importExplicit imp (TypeRef name dctors) = do
465− types' <- updateImports (importedTypes imp) name
466− let allDctors = allExportedDataConstructors name
467− dctors' <- maybe (return allDctors) (mapM $ checkDctorExists allDctors) dctors
468− dctors'' <- foldM updateImports (importedDataConstructors imp) dctors'
469− return $ imp { importedTypes = types', importedDataConstructors = dctors'' }
470− importExplicit imp (TypeClassRef name) = do
471− typeClasses' <- updateImports (importedTypeClasses imp) name
472− return $ imp { importedTypeClasses = typeClasses' }
473− importExplicit _ _ = error "Invalid argument to importExplicit"
474−
475− -- Check if DeclarationRef points to an existent symbol
476− checkedRefs :: [DeclarationRef] -> Either ErrorStack [DeclarationRef]
477− checkedRefs = mapM check
478− where
479− check (PositionedDeclarationRef pos r) =
480− rethrowWithPosition pos $ check r
481− check ref@(ValueRef name) =
482− checkImportExists "value" values name >> return ref
483− check ref@(TypeRef name dctors) = do
484− _ <- checkImportExists "type" availableTypes name
485− let allDctors = allExportedDataConstructors name
486− _ <- maybe (return allDctors) (mapM $ checkDctorExists allDctors) dctors
487− return ref
488− check ref@(TypeClassRef name) =
489− checkImportExists "type class" classes name >> return ref
490− check _ = error "Invalid argument to checkRefIsValid"
491−
492− -- Find all exported data constructors for a given type
493− allExportedDataConstructors :: ProperName -> [ProperName]
494− allExportedDataConstructors name = fromMaybe [] $ name `lookup` exportedTypes exps
495−
496− -- Add something to the ImportEnvironment if it does not already exist there
497− updateImports :: (Ord a, Show a) => M.Map (Qualified a) (Qualified a) -> a -> Either ErrorStack (M.Map (Qualified a) (Qualified a))
498− updateImports m name = case M.lookup (Qualified impQual name) m of
499− Nothing -> return $ M.insert (Qualified impQual name) (Qualified (Just importModule) name) m
500− Just (Qualified Nothing _) -> error "Invalid state in updateImports"
501− Just x@(Qualified (Just mn) _) -> throwError $ mkErrorStack err Nothing
502− where
503− err = if mn == currentModule || importModule == currentModule
504− then "Definition '" ++ show name ++ "' conflicts with import '" ++ show (Qualified (Just mn) name) ++ "'"
505− else "Conflicting imports for '" ++ show name ++ "': '" ++ show x ++ "', '" ++ show (Qualified (Just importModule) name) ++ "'"
506−
507− -- The available values, types, and classes in the module being imported
508− values = exportedValues exps
509− availableTypes = fst `map` exportedTypes exps
510− classes = exportedTypeClasses exps
511−
512− -- Ensure that an explicitly imported data constructor exists for the type it is being imported
513− -- from
514− checkDctorExists :: [ProperName] -> ProperName -> Either ErrorStack ProperName
515− checkDctorExists = checkImportExists "data constructor"
516−
517− -- Check that an explicitly imported item exists in the module it is being imported from
518− checkImportExists :: (Eq a, Show a) => String -> [a] -> a -> Either ErrorStack a
519− checkImportExists t exports item =
520− if item `elem` exports
521− then return item
522− else throwError $ mkErrorStack ("Cannot import unknown " ++ t ++ " '" ++ show item ++ "' from '" ++ show importModule ++ "'") Nothing
src/Language/PureScript/Sugar/Operators.hsdeleted−152
@@ -1,152 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.Sugar.Operators
4−-- Copyright : (c) Phil Freeman 2013
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- |
12−-- This module implements the desugaring pass which reapplies binary operators based
13−-- on their fixity data and removes explicit parentheses.
14−--
15−-- The value parser ignores fixity data when parsing binary operator applications, so
16−-- it is necessary to reorder them here.
17−--
18−-----------------------------------------------------------------------------
19−
20−{-# LANGUAGE Rank2Types, FlexibleContexts #-}
21−
22−module Language.PureScript.Sugar.Operators (
23− rebracket,
24− removeSignedLiterals
25−) where
26−
27−import Language.PureScript.Names
28−import Language.PureScript.AST
29−import Language.PureScript.Errors
30−
31−import Control.Applicative
32−import Control.Monad.State
33−import Control.Monad.Error.Class
34−
35−import Data.Monoid ((<>))
36−import Data.Function (on)
37−import Data.Functor.Identity
38−import Data.List (groupBy, sortBy)
39−
40−import qualified Text.Parsec as P
41−import qualified Text.Parsec.Pos as P
42−import qualified Text.Parsec.Expr as P
43−
44−import qualified Language.PureScript.Constants as C
45−
46−-- |
47−-- Remove explicit parentheses and reorder binary operator applications
48−--
49−rebracket :: [Module] -> Either ErrorStack [Module]
50−rebracket ms = do
51− let fixities = concatMap collectFixities ms
52− ensureNoDuplicates $ map (\(i, pos, _) -> (i, pos)) fixities
53− let opTable = customOperatorTable $ map (\(i, _, f) -> (i, f)) fixities
54− mapM (rebracketModule opTable) ms
55−
56−removeSignedLiterals :: Module -> Module
57−removeSignedLiterals (Module mn ds exts) = Module mn (map f' ds) exts
58− where
59− (f', _, _) = everywhereOnValues id go id
60−
61− go (UnaryMinus (NumericLiteral (Left n))) = NumericLiteral (Left $ negate n)
62− go (UnaryMinus (NumericLiteral (Right n))) = NumericLiteral (Right $ negate n)
63− go (UnaryMinus val) = App (Var (Qualified (Just (ModuleName [ProperName C.prelude])) (Ident C.negate))) val
64− go other = other
65−
66−rebracketModule :: [[(Qualified Ident, Expr -> Expr -> Expr, Associativity)]] -> Module -> Either ErrorStack Module
67−rebracketModule opTable (Module mn ds exts) =
68− let (f, _, _) = everywhereOnValuesTopDownM return (matchOperators opTable) return
69− in Module mn <$> (map removeParens <$> parU ds f) <*> pure exts
70−
71−removeParens :: Declaration -> Declaration
72−removeParens =
73− let (f, _, _) = everywhereOnValues id go id
74− in f
75− where
76− go (Parens val) = val
77− go val = val
78−
79−collectFixities :: Module -> [(Qualified Ident, SourceSpan, Fixity)]
80−collectFixities (Module moduleName ds _) = concatMap collect ds
81− where
82− collect :: Declaration -> [(Qualified Ident, SourceSpan, Fixity)]
83− collect (PositionedDeclaration pos (FixityDeclaration fixity name)) = [(Qualified (Just moduleName) (Op name), pos, fixity)]
84− collect FixityDeclaration{} = error "Fixity without srcpos info"
85− collect _ = []
86−
87−ensureNoDuplicates :: [(Qualified Ident, SourceSpan)] -> Either ErrorStack ()
88−ensureNoDuplicates m = go $ sortBy (compare `on` fst) m
89− where
90− go [] = return ()
91− go [_] = return ()
92− go ((x@(Qualified (Just mn) name), _) : (y, pos) : _) | x == y =
93− rethrow (strMsg ("Error in module " ++ show mn) <>) $
94− rethrowWithPosition pos $
95− throwError $ mkErrorStack ("Redefined fixity for " ++ show name) Nothing
96− go (_ : rest) = go rest
97−
98−customOperatorTable :: [(Qualified Ident, Fixity)] -> [[(Qualified Ident, Expr -> Expr -> Expr, Associativity)]]
99−customOperatorTable fixities =
100− let
101− applyUserOp ident t1 = App (App (Var ident) t1)
102− userOps = map (\(name, Fixity a p) -> (name, applyUserOp name, p, a)) fixities
103− sorted = sortBy (flip compare `on` (\(_, _, p, _) -> p)) userOps
104− groups = groupBy ((==) `on` (\(_, _, p, _) -> p)) sorted
105− in
106− map (map (\(name, f, _, a) -> (name, f, a))) groups
107−
108−type Chain = [Either Expr (Qualified Ident)]
109−
110−matchOperators :: [[(Qualified Ident, Expr -> Expr -> Expr, Associativity)]] -> Expr -> Either ErrorStack Expr
111−matchOperators ops = parseChains
112− where
113− parseChains :: Expr -> Either ErrorStack Expr
114− parseChains b@BinaryNoParens{} = bracketChain (extendChain b)
115− parseChains other = return other
116− extendChain :: Expr -> Chain
117− extendChain (BinaryNoParens name l r) = Left l : Right name : extendChain r
118− extendChain other = [Left other]
119− bracketChain :: Chain -> Either ErrorStack Expr
120− bracketChain = either (Left . (`mkErrorStack` Nothing) . show) Right . P.parse (P.buildExpressionParser opTable parseValue <* P.eof) "operator expression"
121− opTable = [P.Infix (P.try (parseTicks >>= \ident -> return (\t1 t2 -> App (App (Var ident) t1) t2))) P.AssocLeft]
122− : map (map (\(name, f, a) -> P.Infix (P.try (matchOp name) >> return f) (toAssoc a))) ops
123− ++ [[ P.Infix (P.try (parseOp >>= \ident -> return (\t1 t2 -> App (App (Var ident) t1) t2))) P.AssocLeft ]]
124−
125−toAssoc :: Associativity -> P.Assoc
126−toAssoc Infixl = P.AssocLeft
127−toAssoc Infixr = P.AssocRight
128−toAssoc Infix = P.AssocNone
129−
130−token :: (P.Stream s Identity t, Show t) => (t -> Maybe a) -> P.Parsec s u a
131−token = P.token show (const (P.initialPos ""))
132−
133−parseValue :: P.Parsec Chain () Expr
134−parseValue = token (either Just (const Nothing)) P.<?> "expression"
135−
136−parseOp :: P.Parsec Chain () (Qualified Ident)
137−parseOp = token (either (const Nothing) fromOp) P.<?> "operator"
138− where
139− fromOp q@(Qualified _ (Op _)) = Just q
140− fromOp _ = Nothing
141−
142−parseTicks :: P.Parsec Chain () (Qualified Ident)
143−parseTicks = token (either (const Nothing) fromOp) P.<?> "infix function"
144− where
145− fromOp q@(Qualified _ (Ident _)) = Just q
146− fromOp _ = Nothing
147−
148−matchOp :: Qualified Ident -> P.Parsec Chain () ()
149−matchOp op = do
150− ident <- parseOp
151− guard $ ident == op
152−
src/Language/PureScript/Sugar/TypeClasses.hsdeleted−290
@@ -1,290 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.Sugar.TypeClasses
4−-- Copyright : (c) Phil Freeman 2013
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- |
12−-- This module implements the desugaring pass which creates type synonyms for type class dictionaries
13−-- and dictionary expressions for type class instances.
14−--
15−-----------------------------------------------------------------------------
16−
17−module Language.PureScript.Sugar.TypeClasses
18− ( desugarTypeClasses
19− , typeClassMemberName
20− , superClassDictionaryNames
21− ) where
22−
23−import Language.PureScript.AST hiding (isExported)
24−import Language.PureScript.Names
25−import Language.PureScript.Types
26−import Language.PureScript.Kinds
27−import Language.PureScript.Sugar.CaseDeclarations
28−import Language.PureScript.Environment
29−import Language.PureScript.Errors
30−import Language.PureScript.Supply
31−import Language.PureScript.Pretty.Types (prettyPrintTypeAtom)
32−
33−import qualified Language.PureScript.Constants as C
34−
35−import Control.Applicative
36−import Control.Monad.Error
37−import Control.Monad.State
38−import Control.Arrow (first, second)
39−import Data.List ((\\), find)
40−import Data.Monoid ((<>))
41−import Data.Maybe (catMaybes, mapMaybe, isJust)
42−
43−import qualified Data.Map as M
44−
45−type MemberMap = M.Map (ModuleName, ProperName) Declaration
46−
47−type Desugar = StateT MemberMap (SupplyT (Either ErrorStack))
48−
49−-- |
50−-- Add type synonym declarations for type class dictionary types, and value declarations for type class
51−-- instance dictionary expressions.
52−--
53−desugarTypeClasses :: [Module] -> SupplyT (Either ErrorStack) [Module]
54−desugarTypeClasses = flip evalStateT M.empty . mapM desugarModule
55−
56−desugarModule :: Module -> Desugar Module
57−desugarModule (Module name decls (Just exps)) = do
58− (newExpss, declss) <- unzip <$> parU decls (desugarDecl name exps)
59− return $ Module name (concat declss) $ Just (exps ++ catMaybes newExpss)
60−desugarModule _ = error "Exports should have been elaborated in name desugaring"
61−
62−{- Desugar type class and type class instance declarations
63−--
64−-- Type classes become type synonyms for their dictionaries, and type instances become dictionary declarations.
65−-- Additional values are generated to access individual members of a dictionary, with the appropriate type.
66−--
67−-- E.g. the following
68−--
69−-- module Test where
70−--
71−-- class Foo a where
72−-- foo :: a -> a
73−--
74−-- instance fooString :: Foo String where
75−-- foo s = s ++ s
76−--
77−-- instance fooArray :: (Foo a) => Foo [a] where
78−-- foo = map foo
79−--
80−-- {- Superclasses -}
81−--
82−-- class (Foo a) <= Sub a where
83−-- sub :: a
84−--
85−-- instance subString :: Sub String where
86−-- sub = ""
87−--
88−-- becomes:
89−--
90−-- <TypeClassDeclaration Foo ...>
91−--
92−-- type Foo a = { foo :: a -> a }
93−--
94−-- -- this following type is marked as not needing to be checked so a new Abs
95−-- -- is not introduced around the definition in type checking, but when
96−-- -- called the dictionary value is still passed in for the `dict` argument
97−-- foo :: forall a. (Foo a) => a -> a
98−-- foo dict = dict.foo
99−--
100−-- fooString :: {} -> Foo String
101−-- fooString _ = <TypeClassDictionaryConstructorApp Foo { foo: \s -> s ++ s }>
102−--
103−-- fooArray :: forall a. (Foo a) => Foo [a]
104−-- fooArray = <TypeClassDictionaryConstructorApp Foo { foo: map foo }>
105−--
106−-- {- Superclasses -}
107−--
108−-- <TypeClassDeclaration Sub ...>
109−--
110−-- type Sub a = { sub :: a
111−-- , "__superclass_Foo_0" :: {} -> Foo a
112−-- }
113−--
114−-- -- As with `foo` above, this type is unchecked at the declaration
115−-- sub :: forall a. (Sub a) => a
116−-- sub dict = dict.sub
117−--
118−-- subString :: {} -> Sub String
119−-- subString _ = { sub: "",
120−-- , "__superclass_Foo_0": \_ -> <SuperClassDictionary Foo String>
121−-- }
122−--
123−-- and finally as the generated javascript:
124−--
125−-- function Foo(foo) {
126−-- this.foo = foo;
127−-- };
128−--
129−-- var foo = function (dict) {
130−-- return dict.foo;
131−-- };
132−--
133−-- var fooString = function (_) {
134−-- return new Foo(function (s) {
135−-- return s + s;
136−-- });
137−-- };
138−--
139−-- var fooArray = function (__dict_Foo_15) {
140−-- return new Foo(map(foo(__dict_Foo_15)));
141−-- };
142−--
143−-- function Sub(__superclass_Foo_0, sub) {
144−-- this["__superclass_Foo_0"] = __superclass_Foo_0;
145−-- this.sub = sub;
146−-- };
147−--
148−-- var sub = function (dict) {
149−-- return dict.sub;
150−-- };
151−--
152−-- var subString = function (_) {
153−-- return new Sub(fooString, "");
154−-- };
155−-}
156−desugarDecl :: ModuleName -> [DeclarationRef] -> Declaration -> Desugar (Maybe DeclarationRef, [Declaration])
157−desugarDecl mn exps = go
158− where
159− go d@(TypeClassDeclaration name args implies members) = do
160− modify (M.insert (mn, name) d)
161− return $ (Nothing, d : typeClassDictionaryDeclaration name args implies members : map (typeClassMemberToDictionaryAccessor mn name args) members)
162− go d@(ExternInstanceDeclaration name _ className tys) = return (expRef name className tys, [d])
163− go d@(TypeInstanceDeclaration name deps className tys members) = do
164− desugared <- lift $ desugarCases members
165− dictDecl <- typeInstanceDictionaryDeclaration name mn deps className tys desugared
166− return $ (expRef name className tys, [d, dictDecl])
167− go (PositionedDeclaration pos d) = do
168− (dr, ds) <- rethrowWithPosition pos $ desugarDecl mn exps d
169− return (dr, map (PositionedDeclaration pos) ds)
170− go other = return (Nothing, [other])
171−
172− expRef :: Ident -> Qualified ProperName -> [Type] -> Maybe DeclarationRef
173− expRef name className tys
174− | isExportedClass className && all isExportedType (getConstructors `concatMap` tys) = Just $ TypeInstanceRef name
175− | otherwise = Nothing
176−
177− isExportedClass :: Qualified ProperName -> Bool
178− isExportedClass = isExported (elem . TypeClassRef)
179−
180− isExportedType :: Qualified ProperName -> Bool
181− isExportedType = isExported $ \pn -> isJust . find (matchesTypeRef pn)
182−
183− isExported :: (ProperName -> [DeclarationRef] -> Bool) -> Qualified ProperName -> Bool
184− isExported test (Qualified (Just mn') pn) = mn /= mn' || test pn exps
185− isExported _ _ = error "Names should have been qualified in name desugaring"
186−
187− matchesTypeRef :: ProperName -> DeclarationRef -> Bool
188− matchesTypeRef pn (TypeRef pn' _) = pn == pn'
189− matchesTypeRef _ _ = False
190−
191− getConstructors :: Type -> [Qualified ProperName]
192− getConstructors = everythingOnTypes (++) getConstructor
193−
194− getConstructor :: Type -> [Qualified ProperName]
195− getConstructor (TypeConstructor tcname) = [tcname]
196− getConstructor _ = []
197−
198−memberToNameAndType :: Declaration -> (Ident, Type)
199−memberToNameAndType (TypeDeclaration ident ty) = (ident, ty)
200−memberToNameAndType (PositionedDeclaration _ d) = memberToNameAndType d
201−memberToNameAndType _ = error "Invalid declaration in type class definition"
202−
203−typeClassDictionaryDeclaration :: ProperName -> [(String, Maybe Kind)] -> [Constraint] -> [Declaration] -> Declaration
204−typeClassDictionaryDeclaration name args implies members =
205− let superclassTypes = superClassDictionaryNames implies `zip`
206− [ function unit (foldl TypeApp (TypeConstructor superclass) tyArgs)
207− | (superclass, tyArgs) <- implies
208− ]
209− members' = map (first runIdent . memberToNameAndType) members
210− mtys = members' ++ superclassTypes
211− in TypeSynonymDeclaration name args (TypeApp tyObject $ rowFromList (mtys, REmpty))
212−
213−typeClassMemberToDictionaryAccessor :: ModuleName -> ProperName -> [(String, Maybe Kind)] -> Declaration -> Declaration
214−typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration ident ty) =
215− ValueDeclaration ident TypeClassAccessorImport [] $ Right $
216− TypedValue False (Abs (Left $ Ident "dict") (Accessor (runIdent ident) (Var $ Qualified Nothing (Ident "dict")))) $
217− moveQuantifiersToFront (quantify (ConstrainedType [(Qualified (Just mn) name, map (TypeVar . fst) args)] ty))
218−typeClassMemberToDictionaryAccessor mn name args (PositionedDeclaration pos d) =
219− PositionedDeclaration pos $ typeClassMemberToDictionaryAccessor mn name args d
220−typeClassMemberToDictionaryAccessor _ _ _ _ = error "Invalid declaration in type class definition"
221−
222−unit :: Type
223−unit = TypeApp tyObject REmpty
224−
225−typeInstanceDictionaryDeclaration :: Ident -> ModuleName -> [Constraint] -> Qualified ProperName -> [Type] -> [Declaration] -> Desugar Declaration
226−typeInstanceDictionaryDeclaration name mn deps className tys decls =
227− rethrow (strMsg ("Error in type class instance " ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys) ++ ":") <>) $ do
228− m <- get
229−
230− -- Lookup the type arguments and member types for the type class
231− (TypeClassDeclaration _ args implies tyDecls) <- lift . lift $
232− maybe (Left $ mkErrorStack ("Type class " ++ show className ++ " is undefined") Nothing) Right $
233− M.lookup (qualify mn className) m
234−
235− case mapMaybe declName tyDecls \\ mapMaybe declName decls of
236− x : _ -> throwError $ mkErrorStack ("Member '" ++ show x ++ "' has not been implemented") Nothing
237− [] -> do
238−
239− let instanceTys = map memberToNameAndType tyDecls
240−
241− -- Replace the type arguments with the appropriate types in the member types
242− let memberTypes = map (second (replaceAllTypeVars (zip (map fst args) tys))) instanceTys
243−
244− -- Create values for the type instance members
245− members <- zip (map typeClassMemberName decls) <$> mapM (memberToValue memberTypes) decls
246−
247− -- Create the type of the dictionary
248− -- The type is an object type, but depending on type instance dependencies, may be constrained.
249− -- The dictionary itself is an object literal.
250− let superclasses = superClassDictionaryNames implies `zip`
251− [ Abs (Left (Ident C.__unused)) (SuperClassDictionary superclass tyArgs)
252− | (superclass, suTyArgs) <- implies
253− , let tyArgs = map (replaceAllTypeVars (zip (map fst args) tys)) suTyArgs
254− ]
255−
256− let props = ObjectLiteral (members ++ superclasses)
257− dictTy = foldl TypeApp (TypeConstructor className) tys
258− constrainedTy = quantify (if null deps then dictTy else ConstrainedType deps dictTy)
259− dict = TypeClassDictionaryConstructorApp className props
260− result = ValueDeclaration name TypeInstanceDictionaryValue [] (Right (TypedValue True dict constrainedTy))
261− return result
262−
263− where
264−
265− declName :: Declaration -> Maybe Ident
266− declName (PositionedDeclaration _ d) = declName d
267− declName (ValueDeclaration ident _ _ _) = Just ident
268− declName (TypeDeclaration ident _) = Just ident
269− declName _ = Nothing
270−
271− memberToValue :: [(Ident, Type)] -> Declaration -> Desugar Expr
272− memberToValue tys' (ValueDeclaration ident _ [] (Right val)) = do
273− _ <- lift . lift . maybe (Left $ mkErrorStack ("Type class does not define member '" ++ show ident ++ "'") Nothing) Right $ lookup ident tys'
274− return val
275− memberToValue tys' (PositionedDeclaration pos d) = rethrowWithPosition pos $ do
276− val <- memberToValue tys' d
277− return (PositionedValue pos val)
278− memberToValue _ _ = error "Invalid declaration in type instance definition"
279−
280−typeClassMemberName :: Declaration -> String
281−typeClassMemberName (TypeDeclaration ident _) = runIdent ident
282−typeClassMemberName (ValueDeclaration ident _ _ _) = runIdent ident
283−typeClassMemberName (PositionedDeclaration _ d) = typeClassMemberName d
284−typeClassMemberName d = error $ "Invalid declaration in type class definition: " ++ show d
285−
286−superClassDictionaryNames :: [Constraint] -> [String]
287−superClassDictionaryNames supers =
288− [ C.__superclass_ ++ show pn ++ "_" ++ show (index :: Integer)
289− | (index, (pn, _)) <- zip [0..] supers
290− ]
src/Language/PureScript/Sugar/TypeDeclarations.hsdeleted−69
@@ -1,69 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.Sugar.TypeDeclarations
4−-- Copyright : (c) Phil Freeman 2013
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- |
12−-- This module implements the desugaring pass which replaces top-level type declarations with
13−-- type annotations on the corresponding expression.
14−--
15−-----------------------------------------------------------------------------
16−
17−module Language.PureScript.Sugar.TypeDeclarations (
18− desugarTypeDeclarations,
19− desugarTypeDeclarationsModule
20−) where
21−
22−import Data.Monoid ((<>))
23−
24−import Control.Applicative
25−import Control.Monad.Error.Class
26−import Control.Monad (forM)
27−
28−import Language.PureScript.AST
29−import Language.PureScript.Names
30−import Language.PureScript.Environment
31−import Language.PureScript.Errors
32−import Language.PureScript.Traversals
33−
34−-- |
35−-- Replace all top level type declarations in a module with type annotations
36−--
37−desugarTypeDeclarationsModule :: [Module] -> Either ErrorStack [Module]
38−desugarTypeDeclarationsModule ms = forM ms $ \(Module name ds exps) ->
39− rethrow (strMsg ("Error in module " ++ show name) <>) $
40− Module name <$> desugarTypeDeclarations ds <*> pure exps
41−
42−-- |
43−-- Replace all top level type declarations with type annotations
44−--
45−desugarTypeDeclarations :: [Declaration] -> Either ErrorStack [Declaration]
46−desugarTypeDeclarations (PositionedDeclaration pos d : ds) = do
47− (d' : ds') <- rethrowWithPosition pos $ desugarTypeDeclarations (d : ds)
48− return (PositionedDeclaration pos d' : ds')
49−desugarTypeDeclarations (TypeDeclaration name ty : d : rest) = do
50− (_, nameKind, val) <- fromValueDeclaration d
51− desugarTypeDeclarations (ValueDeclaration name nameKind [] (Right (TypedValue True val ty)) : rest)
52− where
53− fromValueDeclaration :: Declaration -> Either ErrorStack (Ident, NameKind, Expr)
54− fromValueDeclaration (ValueDeclaration name' nameKind [] (Right val)) | name == name' = return (name', nameKind, val)
55− fromValueDeclaration (PositionedDeclaration pos d') = do
56− (ident, nameKind, val) <- rethrowWithPosition pos $ fromValueDeclaration d'
57− return (ident, nameKind, PositionedValue pos val)
58− fromValueDeclaration _ = throwError $ mkErrorStack ("Orphan type declaration for " ++ show name) Nothing
59−desugarTypeDeclarations (TypeDeclaration name _ : []) = throwError $ mkErrorStack ("Orphan type declaration for " ++ show name) Nothing
60−desugarTypeDeclarations (ValueDeclaration name nameKind bs val : rest) = do
61− let (_, f, _) = everywhereOnValuesTopDownM return go return
62− f' (Left gs) = Left <$> mapM (pairM return f) gs
63− f' (Right v) = Right <$> f v
64− (:) <$> (ValueDeclaration name nameKind bs <$> f' val) <*> desugarTypeDeclarations rest
65− where
66− go (Let ds val') = Let <$> desugarTypeDeclarations ds <*> pure val'
67− go other = return other
68−desugarTypeDeclarations (d:ds) = (:) d <$> desugarTypeDeclarations ds
69−desugarTypeDeclarations [] = return []
src/Language/PureScript/Supply.hsdeleted−56
@@ -1,56 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.Supply
4−-- Copyright : (c) Phil Freeman 2014
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- |
12−-- Fresh variable supply
13−--
14−-----------------------------------------------------------------------------
15−
16−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
17−{-# LANGUAGE FlexibleInstances #-}
18−{-# LANGUAGE MultiParamTypeClasses #-}
19−{-# LANGUAGE UndecidableInstances #-}
20−
21−module Language.PureScript.Supply where
22−
23−import Data.Functor.Identity
24−
25−import Control.Applicative
26−import Control.Monad.State
27−import Control.Monad.Error.Class
28−
29−newtype SupplyT m a = SupplyT { unSupplyT :: StateT Integer m a } deriving (Functor, Applicative, Monad, MonadTrans)
30−
31−runSupplyT :: Integer -> SupplyT m a -> m (a, Integer)
32−runSupplyT n = flip runStateT n . unSupplyT
33−
34−evalSupplyT :: (Functor m) => Integer -> SupplyT m a -> m a
35−evalSupplyT n = fmap fst . runSupplyT n
36−
37−type Supply = SupplyT Identity
38−
39−runSupply :: Integer -> Supply a -> (a, Integer)
40−runSupply n = runIdentity . runSupplyT n
41−
42−evalSupply :: Integer -> Supply a -> a
43−evalSupply n = runIdentity . evalSupplyT n
44−
45−fresh :: (Monad m) => SupplyT m Integer
46−fresh = SupplyT $ do
47− n <- get
48− put (n + 1)
49− return n
50−
51−freshName :: (Functor m, Monad m) => SupplyT m String
52−freshName = ('_' :) . show <$> fresh
53−
54−instance (MonadError e m) => MonadError e (SupplyT m) where
55− throwError = SupplyT . throwError
56− catchError e f = SupplyT $ catchError (unSupplyT e) (unSupplyT . f)
src/Language/PureScript/Traversals.hsdeleted−41
@@ -1,41 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.Traversals
4−-- Copyright : (c) 2014 Phil Freeman
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- | Common functions for implementing generic traversals
12−--
13−-----------------------------------------------------------------------------
14−
15−module Language.PureScript.Traversals where
16−
17−import Control.Applicative
18−
19−fstM :: (Functor f) => (a -> f c) -> (a, b) -> f (c, b)
20−fstM f (a, b) = flip (,) b <$> f a
21−
22−sndM :: (Functor f) => (b -> f c) -> (a, b) -> f (a, c)
23−sndM f (a, b) = (,) a <$> f b
24−
25−thirdM :: (Functor f) => (c -> f d) -> (a, b, c) -> f (a, b, d)
26−thirdM f (a, b, c) = (,,) a b <$> f c
27−
28−pairM :: (Applicative f) => (a -> f c) -> (b -> f d) -> (a, b) -> f (c, d)
29−pairM f g (a, b) = (,) <$> f a <*> g b
30−
31−maybeM :: (Applicative f) => (a -> f b) -> Maybe a -> f (Maybe b)
32−maybeM _ Nothing = pure Nothing
33−maybeM f (Just a) = Just <$> f a
34−
35−eitherM :: (Applicative f) => (a -> f c) -> (b -> f d) -> Either a b -> f (Either c d)
36−eitherM f _ (Left a) = Left <$> f a
37−eitherM _ g (Right b) = Right <$> g b
38−
39−defS :: (Monad m) => st -> val -> m (st, val)
40−defS s val = return (s, val)
41−
src/Language/PureScript/TypeChecker.hsdeleted−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.Monoid ((<>))
31−import Data.Foldable (for_)
32−import qualified Data.Map as M
33−
34−import Control.Monad.State
35−import Control.Monad.Error
36−
37−import Language.PureScript.Types
38−import Language.PureScript.Names
39−import Language.PureScript.Kinds
40−import Language.PureScript.AST
41−import Language.PureScript.TypeClassDictionaries
42−import Language.PureScript.Environment
43−import Language.PureScript.Errors
44−
45−addDataType :: ModuleName -> DataDeclType -> ProperName -> [(String, Maybe Kind)] -> [(ProperName, [Type])] -> Kind -> Check ()
46−addDataType moduleName dtype name args dctors ctorKind = do
47− env <- getEnv
48− putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (ctorKind, DataType args dctors) (types env) }
49− forM_ dctors $ \(dctor, tys) ->
50− rethrow (strMsg ("Error in data constructor " ++ show dctor) <>) $
51− addDataConstructor moduleName dtype name (map fst args) dctor tys
52−
53−addDataConstructor :: ModuleName -> DataDeclType -> ProperName -> [String] -> ProperName -> [Type] -> Check ()
54−addDataConstructor moduleName dtype name args dctor tys = do
55− env <- getEnv
56− mapM_ checkTypeSynonyms tys
57− let retTy = foldl TypeApp (TypeConstructor (Qualified (Just moduleName) name)) (map TypeVar args)
58− let dctorTy = foldr function retTy tys
59− let polyType = mkForAll args dctorTy
60− putEnv $ env { dataConstructors = M.insert (Qualified (Just moduleName) dctor) (dtype, name, polyType) (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 (strMsg ("Error in type constructor " ++ show name) <>) $ 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 (strMsg "Error in data binding group" <>) $ 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 (strMsg ("Error in type synonym " ++ show name) <>) $ 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 (strMsg ("Error in declaration " ++ show name) <>) $ 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 (strMsg ("Error in binding group " ++ show (map (\(ident, _, _) -> ident) vals)) <>) $ 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 (strMsg ("Error in foreign import declaration " ++ show name) <>) $ 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 d : rest) =
243− rethrowWithPosition pos $ do
244− (d' : rest') <- go (d : rest)
245− return (PositionedDeclaration pos 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 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 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−217
@@ -1,217 +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 qualified Data.Map as M
24−
25−import Control.Applicative
26−import Control.Arrow (Arrow(..))
27−import Control.Monad.Error
28−
29−import Language.PureScript.AST
30−import Language.PureScript.Environment
31−import Language.PureScript.Names
32−import Language.PureScript.Pretty
33−import Language.PureScript.TypeChecker.Monad
34−import Language.PureScript.TypeChecker.Synonyms
35−import Language.PureScript.TypeChecker.Unify
36−import Language.PureScript.TypeClassDictionaries
37−import Language.PureScript.Types
38−import qualified Language.PureScript.Constants as C
39−
40−-- |
41−-- A simplified representation of expressions which are used to represent type
42−-- class dictionaries at runtime, which can be compared for equality
43−--
44−data DictionaryValue
45− -- |
46− -- A dictionary which is brought into scope by a local constraint
47− --
48− = LocalDictionaryValue (Qualified Ident)
49− -- |
50− -- A dictionary which is brought into scope by an instance declaration
51− --
52− | GlobalDictionaryValue (Qualified Ident)
53− -- |
54− -- A dictionary which depends on other dictionaries
55− --
56− | DependentDictionaryValue (Qualified Ident) [DictionaryValue]
57− -- |
58− -- A subclass dictionary
59− --
60− | SubclassDictionaryValue DictionaryValue (Qualified ProperName) Integer
61− deriving (Show, Ord, Eq)
62−
63−-- |
64−-- Check that the current set of type class dictionaries entail the specified type class goal, and, if so,
65−-- return a type class dictionary reference.
66−--
67−entails :: Environment -> ModuleName -> [TypeClassDictionaryInScope] -> Constraint -> Bool -> Check Expr
68−entails env moduleName context = solve (sortedNubBy canonicalizeDictionary (filter filterModule context))
69− where
70− sortedNubBy :: (Ord k) => (v -> k) -> [v] -> [v]
71− sortedNubBy f vs = M.elems (M.fromList (map (f &&& id) vs))
72−
73− -- Filter out type dictionaries which are in scope in the current module
74− filterModule :: TypeClassDictionaryInScope -> Bool
75− filterModule (TypeClassDictionaryInScope { tcdName = Qualified (Just mn) _ }) | mn == moduleName = True
76− filterModule (TypeClassDictionaryInScope { tcdName = Qualified Nothing _ }) = True
77− filterModule _ = False
78−
79− solve context' (className, tys) trySuperclasses =
80− checkOverlaps $ go trySuperclasses className tys
81− where
82− go trySuperclasses' className' tys' =
83− -- Look for regular type instances
84− [ mkDictionary (canonicalizeDictionary tcd) args
85− | tcd <- context'
86− -- Make sure the type class name matches the one we are trying to satisfy
87− , className' == tcdClassName tcd
88− -- Make sure the type unifies with the type in the type instance definition
89− , subst <- maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName env) tys' (tcdInstanceTypes tcd)
90− -- Solve any necessary subgoals
91− , args <- solveSubgoals subst (tcdDependencies tcd) ] ++
92−
93− -- Look for implementations via superclasses
94− [ SubclassDictionaryValue suDict superclass index
95− | trySuperclasses'
96− , (subclassName, (args, _, implies)) <- M.toList (typeClasses env)
97− -- Try each superclass
98− , (index, (superclass, suTyArgs)) <- zip [0..] implies
99− -- Make sure the type class name matches the superclass name
100− , className' == superclass
101− -- Make sure the types unify with the types in the superclass implication
102− , subst <- maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName env) tys' suTyArgs
103− -- Finally, satisfy the subclass constraint
104− , args' <- maybeToList $ mapM ((`lookup` subst) . fst) args
105− , suDict <- go True subclassName args' ]
106−
107− -- Create dictionaries for subgoals which still need to be solved by calling go recursively
108− -- E.g. the goal (Show a, Show b) => Show (Either a b) can be satisfied if the current type
109− -- unifies with Either a b, and we can satisfy the subgoals Show a and Show b recursively.
110− solveSubgoals :: [(String, Type)] -> Maybe [Constraint] -> [Maybe [DictionaryValue]]
111− solveSubgoals _ Nothing = return Nothing
112− solveSubgoals subst (Just subgoals) = do
113− dict <- mapM (uncurry (go True) . second (map (replaceAllTypeVars subst))) subgoals
114− return $ Just dict
115− -- Make a dictionary from subgoal dictionaries by applying the correct function
116− mkDictionary :: Qualified Ident -> Maybe [DictionaryValue] -> DictionaryValue
117− mkDictionary fnName Nothing = LocalDictionaryValue fnName
118− mkDictionary fnName (Just []) = GlobalDictionaryValue fnName
119− mkDictionary fnName (Just dicts) = DependentDictionaryValue fnName dicts
120− -- Turn a DictionaryValue into a Expr
121− dictionaryValueToValue :: DictionaryValue -> Expr
122− dictionaryValueToValue (LocalDictionaryValue fnName) = Var fnName
123− dictionaryValueToValue (GlobalDictionaryValue fnName) = Var fnName
124− dictionaryValueToValue (DependentDictionaryValue fnName dicts) = foldl App (Var fnName) (map dictionaryValueToValue dicts)
125− dictionaryValueToValue (SubclassDictionaryValue dict superclassName index) =
126− App (Accessor (C.__superclass_ ++ show superclassName ++ "_" ++ show index)
127− (dictionaryValueToValue dict))
128− valUndefined
129− -- Ensure that a substitution is valid
130− verifySubstitution :: [(String, Type)] -> Maybe [(String, Type)]
131− verifySubstitution subst = do
132− let grps = groupBy ((==) `on` fst) subst
133− guard (all (pairwise (unifiesWith env) . map snd) grps)
134− return $ map head grps
135− -- |
136− -- Check for overlapping instances
137− --
138− checkOverlaps :: [DictionaryValue] -> Check Expr
139− checkOverlaps dicts =
140− case [ (d1, d2) | d1 <- dicts, d2 <- dicts, d1 `overlapping` d2 ] of
141− (d1, d2) : _ -> throwError . strMsg $ unlines
142− [ "Overlapping instances found for " ++ show className ++ " " ++ unwords (map prettyPrintType tys) ++ "."
143− , "For example:"
144− , prettyPrintDictionaryValue d1
145− , "and:"
146− , prettyPrintDictionaryValue d2
147− ]
148− _ -> case chooseSimplestDictionaries dicts of
149− [] -> throwError . strMsg $
150− "No instance found for " ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys)
151− d : _ -> return $ dictionaryValueToValue d
152− -- Choose the simplest DictionaryValues from a list of candidates
153− -- The reason for this function is as follows:
154− -- When considering overlapping instances, we don't want to consider the same dictionary
155− -- to be an overlap of itself when obtained as a superclass of another class.
156− -- Observing that we probably don't want to select a superclass instance when an instance
157− -- is available directly, and that there is no way for a superclass instance to actually
158− -- introduce an overlap that wouldn't have been there already, we simply remove dictionaries
159− -- obtained as superclass instances if there are simpler instances available.
160− chooseSimplestDictionaries :: [DictionaryValue] -> [DictionaryValue]
161− chooseSimplestDictionaries ds = case filter isSimpleDictionaryValue ds of
162− [] -> ds
163− simple -> simple
164− isSimpleDictionaryValue SubclassDictionaryValue{} = False
165− isSimpleDictionaryValue (DependentDictionaryValue _ ds) = all isSimpleDictionaryValue ds
166− isSimpleDictionaryValue _ = True
167− -- |
168− -- Check if two dictionaries are overlapping
169− --
170− -- Dictionaries which are subclass dictionaries cannot overlap, since otherwise the overlap would have
171− -- been caught when constructing superclass dictionaries.
172− --
173− overlapping :: DictionaryValue -> DictionaryValue -> Bool
174− overlapping (LocalDictionaryValue nm1) (LocalDictionaryValue nm2) | nm1 == nm2 = False
175− overlapping (GlobalDictionaryValue nm1) (GlobalDictionaryValue nm2) | nm1 == nm2 = False
176− overlapping (DependentDictionaryValue nm1 ds1) (DependentDictionaryValue nm2 ds2)
177− | nm1 == nm2 = or $ zipWith overlapping ds1 ds2
178− overlapping SubclassDictionaryValue{} _ = False
179− overlapping _ SubclassDictionaryValue{} = False
180− overlapping _ _ = True
181− -- |
182− -- Render a DictionaryValue fit for human consumption in error messages
183− --
184− prettyPrintDictionaryValue :: DictionaryValue -> String
185− prettyPrintDictionaryValue = unlines . indented 0
186− where
187− indented n (LocalDictionaryValue _) = [spaces n ++ "Dictionary in scope"]
188− indented n (GlobalDictionaryValue nm) = [spaces n ++ show nm]
189− indented n (DependentDictionaryValue nm args) = (spaces n ++ show nm ++ " via") : concatMap (indented (n + 2)) args
190− indented n (SubclassDictionaryValue sup nm _) = (spaces n ++ show nm ++ " via superclass") : indented (n + 2) sup
191−
192− spaces n = replicate n ' ' ++ "- "
193−
194− valUndefined :: Expr
195− valUndefined = Var (Qualified (Just (ModuleName [ProperName C.prim])) (Ident C.undefined))
196−
197−-- |
198−-- Check whether the type heads of two types are equal (for the purposes of type class dictionary lookup),
199−-- and return a substitution from type variables to types which makes the type heads unify.
200−--
201−typeHeadsAreEqual :: ModuleName -> Environment -> Type -> Type -> Maybe [(String, Type)]
202−typeHeadsAreEqual _ _ (Skolem _ s1 _) (Skolem _ s2 _) | s1 == s2 = Just []
203−typeHeadsAreEqual _ _ t (TypeVar v) = Just [(v, t)]
204−typeHeadsAreEqual _ _ (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = Just []
205−typeHeadsAreEqual m e (TypeApp h1 t1) (TypeApp h2 t2) = (++) <$> typeHeadsAreEqual m e h1 h2 <*> typeHeadsAreEqual m e t1 t2
206−typeHeadsAreEqual m e (SaturatedTypeSynonym name args) t2 = case expandTypeSynonym' e name args of
207− Left _ -> Nothing
208− Right t1 -> typeHeadsAreEqual m e t1 t2
209−typeHeadsAreEqual _ _ _ _ = Nothing
210−
211−-- |
212−-- Check all values in a list pairwise match a predicate
213−--
214−pairwise :: (a -> a -> Bool) -> [a] -> Bool
215−pairwise _ [] = True
216−pairwise _ [_] = True
217−pairwise p (x : xs) = all (p x) xs && pairwise p xs
src/Language/PureScript/TypeChecker/Kinds.hsdeleted−192
@@ -1,192 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.TypeChecker.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−-- This module implements the kind checker
13−--
14−-----------------------------------------------------------------------------
15−
16−{-# OPTIONS_GHC -fno-warn-orphans #-}
17−{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}
18−
19−module Language.PureScript.TypeChecker.Kinds (
20− kindOf,
21− kindsOf,
22− kindsOfAll
23−) where
24−
25−import Data.Maybe (fromMaybe)
26−import Data.Monoid ((<>))
27−import qualified Data.HashMap.Strict as H
28−import qualified Data.Map as M
29−
30−import Control.Applicative
31−import Control.Monad.Error
32−import Control.Monad.State
33−import Control.Monad.Unify
34−
35−import Language.PureScript.Environment
36−import Language.PureScript.Errors
37−import Language.PureScript.Kinds
38−import Language.PureScript.Names
39−import Language.PureScript.Pretty
40−import Language.PureScript.TypeChecker.Monad
41−import Language.PureScript.Types
42−
43−instance Partial Kind where
44− unknown = KUnknown
45− isUnknown (KUnknown u) = Just u
46− isUnknown _ = Nothing
47− unknowns = everythingOnKinds (++) go
48− where
49− go (KUnknown u) = [u]
50− go _ = []
51− ($?) sub = everywhereOnKinds go
52− where
53− go t@(KUnknown u) = fromMaybe t $ H.lookup u (runSubstitution sub)
54− go other = other
55−
56−instance Unifiable Check Kind where
57− KUnknown u1 =?= KUnknown u2 | u1 == u2 = return ()
58− KUnknown u =?= k = u =:= k
59− k =?= KUnknown u = u =:= k
60− Star =?= Star = return ()
61− Bang =?= Bang = return ()
62− Row k1 =?= Row k2 = k1 =?= k2
63− FunKind k1 k2 =?= FunKind k3 k4 = do
64− k1 =?= k3
65− k2 =?= k4
66− k1 =?= k2 = UnifyT . lift . throwError . strMsg $ "Cannot unify " ++ prettyPrintKind k1 ++ " with " ++ prettyPrintKind k2 ++ "."
67−
68−-- |
69−-- Infer the kind of a single type
70−--
71−kindOf :: ModuleName -> Type -> Check Kind
72−kindOf _ ty =
73− rethrow (mkErrorStack "Error checking kind" (Just (TypeError ty)) <>) $
74− fmap (starIfUnknown . tidyUp) . liftUnify $ infer ty
75− where
76− tidyUp (k, sub) = sub $? k
77−
78−-- |
79−-- Infer the kind of a type constructor with a collection of arguments and a collection of associated data constructors
80−--
81−kindsOf :: Bool -> ModuleName -> ProperName -> [(String, Maybe Kind)] -> [Type] -> Check Kind
82−kindsOf isData moduleName name args ts = fmap tidyUp . liftUnify $ do
83− tyCon <- fresh
84− kargs <- replicateM (length args) fresh
85− rest <- zipWithM freshKindVar args kargs
86− let dict = (name, tyCon) : rest
87− bindLocalTypeVariables moduleName dict $
88− solveTypes isData ts kargs tyCon
89− where
90− tidyUp (k, sub) = starIfUnknown $ sub $? k
91−
92−freshKindVar :: (String, Maybe Kind) -> Kind -> UnifyT Kind Check (ProperName, Kind)
93−freshKindVar (arg, Nothing) kind = return (ProperName arg, kind)
94−freshKindVar (arg, Just kind') kind = do
95− kind =?= kind'
96− return (ProperName arg, kind')
97−
98−-- |
99−-- Simultaneously infer the kinds of several mutually recursive type constructors
100−--
101−kindsOfAll :: ModuleName -> [(ProperName, [(String, Maybe Kind)], Type)] -> [(ProperName, [(String, Maybe Kind)], [Type])] -> Check ([Kind], [Kind])
102−kindsOfAll moduleName syns tys = fmap tidyUp . liftUnify $ do
103− synVars <- replicateM (length syns) fresh
104− let dict = zipWith (\(name, _, _) var -> (name, var)) syns synVars
105− bindLocalTypeVariables moduleName dict $ do
106− tyCons <- replicateM (length tys) fresh
107− let dict' = zipWith (\(name, _, _) tyCon -> (name, tyCon)) tys tyCons
108− bindLocalTypeVariables moduleName dict' $ do
109− data_ks <- zipWithM (\tyCon (_, args, ts) -> do
110− kargs <- replicateM (length args) fresh
111− argDict <- zipWithM freshKindVar args kargs
112− bindLocalTypeVariables moduleName argDict $
113− solveTypes True ts kargs tyCon) tyCons tys
114− syn_ks <- zipWithM (\synVar (_, args, ty) -> do
115− kargs <- replicateM (length args) fresh
116− argDict <- zipWithM freshKindVar args kargs
117− bindLocalTypeVariables moduleName argDict $
118− solveTypes False [ty] kargs synVar) synVars syns
119− return (syn_ks, data_ks)
120− where
121− tidyUp ((ks1, ks2), sub) = (map (starIfUnknown . (sub $?)) ks1, map (starIfUnknown . (sub $?)) ks2)
122−
123−-- |
124−-- Solve the set of kind constraints associated with the data constructors for a type constructor
125−--
126−solveTypes :: Bool -> [Type] -> [Kind] -> Kind -> UnifyT Kind Check Kind
127−solveTypes isData ts kargs tyCon = do
128− ks <- mapM infer ts
129− when isData $ do
130− tyCon =?= foldr FunKind Star kargs
131− forM_ ks $ \k -> k =?= Star
132− unless isData $
133− tyCon =?= foldr FunKind (head ks) kargs
134− return tyCon
135−
136−-- |
137−-- Default all unknown kinds to the Star kind of types
138−--
139−starIfUnknown :: Kind -> Kind
140−starIfUnknown (KUnknown _) = Star
141−starIfUnknown (Row k) = Row (starIfUnknown k)
142−starIfUnknown (FunKind k1 k2) = FunKind (starIfUnknown k1) (starIfUnknown k2)
143−starIfUnknown k = k
144−
145−-- |
146−-- Infer a kind for a type
147−--
148−infer :: Type -> UnifyT Kind Check Kind
149−infer ty = rethrow (mkErrorStack "Error inferring type of value" (Just (TypeError ty)) <>) $ infer' ty
150−
151−infer' :: Type -> UnifyT Kind Check Kind
152−infer' TypeWildcard = fresh
153−infer' (TypeVar v) = do
154− Just moduleName <- checkCurrentModule <$> get
155− UnifyT . lift $ lookupTypeVariable moduleName (Qualified Nothing (ProperName v))
156−infer' c@(TypeConstructor v) = do
157− env <- liftCheck getEnv
158− case M.lookup v (types env) of
159− Nothing -> UnifyT . lift . throwError $ mkErrorStack "Unknown type constructor" (Just (TypeError c))
160− Just (kind, _) -> return kind
161−infer' (TypeApp t1 t2) = do
162− k0 <- fresh
163− k1 <- infer t1
164− k2 <- infer t2
165− k1 =?= FunKind k2 k0
166− return k0
167−infer' (ForAll ident ty _) = do
168− k1 <- fresh
169− Just moduleName <- checkCurrentModule <$> get
170− k2 <- bindLocalTypeVariables moduleName [(ProperName ident, k1)] $ infer ty
171− k2 =?= Star
172− return Star
173−infer' REmpty = do
174− k <- fresh
175− return $ Row k
176−infer' (RCons _ ty row) = do
177− k1 <- infer ty
178− k2 <- infer row
179− k2 =?= Row k1
180− return $ Row k1
181−infer' (ConstrainedType deps ty) = do
182− forM_ deps $ \(className, tys) -> do
183− _ <- infer $ foldl TypeApp (TypeConstructor className) tys
184− return ()
185− k <- infer ty
186− k =?= Star
187− return Star
188−infer' (KindedType ty k) = do
189− k' <- infer ty
190− k =?= k'
191− return k'
192−infer' _ = error "Invalid argument to infer"
src/Language/PureScript/TypeChecker/Monad.hsdeleted−232
@@ -1,232 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.TypeChecker.Monad
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−-- Monads for type checking and type inference and associated data types
13−--
14−-----------------------------------------------------------------------------
15−
16−{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleInstances, RankNTypes,
17− MultiParamTypeClasses, FlexibleContexts #-}
18−
19−module Language.PureScript.TypeChecker.Monad where
20−
21−import Data.Maybe
22−import qualified Data.Map as M
23−
24−import Control.Applicative
25−import Control.Monad.Error
26−import Control.Monad.State
27−import Control.Monad.Unify
28−
29−import Language.PureScript.Environment
30−import Language.PureScript.Errors
31−import Language.PureScript.Kinds
32−import Language.PureScript.Names
33−import Language.PureScript.Options
34−import Language.PureScript.TypeClassDictionaries
35−import Language.PureScript.Types
36−
37−-- |
38−-- Temporarily bind a collection of names to values
39−--
40−bindNames :: (MonadState CheckState m) => M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility) -> m a -> m a
41−bindNames newNames action = do
42− orig <- get
43− modify $ \st -> st { checkEnv = (checkEnv st) { names = newNames `M.union` (names . checkEnv $ st) } }
44− a <- action
45− modify $ \st -> st { checkEnv = (checkEnv st) { names = names . checkEnv $ orig } }
46− return a
47−
48−-- |
49−-- Temporarily bind a collection of names to types
50−--
51−bindTypes :: (MonadState CheckState m) => M.Map (Qualified ProperName) (Kind, TypeKind) -> m a -> m a
52−bindTypes newNames action = do
53− orig <- get
54− modify $ \st -> st { checkEnv = (checkEnv st) { types = newNames `M.union` (types . checkEnv $ st) } }
55− a <- action
56− modify $ \st -> st { checkEnv = (checkEnv st) { types = types . checkEnv $ orig } }
57− return a
58−
59−-- |
60−-- Temporarily make a collection of type class dictionaries available
61−--
62−withTypeClassDictionaries :: (MonadState CheckState m) => [TypeClassDictionaryInScope] -> m a -> m a
63−withTypeClassDictionaries entries action = do
64− orig <- get
65− let mentries = M.fromList [ ((canonicalizeDictionary entry, mn), entry) | entry@TypeClassDictionaryInScope{ tcdName = Qualified mn _ } <- entries ]
66− modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = (typeClassDictionaries . checkEnv $ st) `M.union` mentries } }
67− a <- action
68− modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = typeClassDictionaries . checkEnv $ orig } }
69− return a
70−
71−-- |
72−-- Get the currently available list of type class dictionaries
73−--
74−getTypeClassDictionaries :: (Functor m, MonadState CheckState m) => m [TypeClassDictionaryInScope]
75−getTypeClassDictionaries = M.elems . typeClassDictionaries . checkEnv <$> get
76−
77−-- |
78−-- Temporarily bind a collection of names to local variables
79−--
80−bindLocalVariables :: (Functor m, MonadState CheckState m) => ModuleName -> [(Ident, Type, NameVisibility)] -> m a -> m a
81−bindLocalVariables moduleName bindings =
82− bindNames (M.fromList $ flip map bindings $ \(name, ty, visibility) -> ((moduleName, name), (ty, LocalVariable, visibility)))
83−
84−-- |
85−-- Temporarily bind a collection of names to local type variables
86−--
87−bindLocalTypeVariables :: (Functor m, MonadState CheckState m) => ModuleName -> [(ProperName, Kind)] -> m a -> m a
88−bindLocalTypeVariables moduleName bindings =
89− bindTypes (M.fromList $ flip map bindings $ \(pn, kind) -> (Qualified (Just moduleName) pn, (kind, LocalTypeVariable)))
90−
91−-- |
92−-- Update the visibility of all names to Defined
93−--
94−makeBindingGroupVisible :: (Functor m, MonadState CheckState m) => m a -> m a
95−makeBindingGroupVisible action = do
96− orig <- get
97− modify $ \st -> st { checkEnv = (checkEnv st) { names = M.map (\(ty, nk, _) -> (ty, nk, Defined)) (names . checkEnv $ st) } }
98− a <- action
99− modify $ \st -> st { checkEnv = (checkEnv st) { names = names . checkEnv $ orig } }
100− return a
101−
102−-- |
103−-- Lookup the type of a value by name in the @Environment@
104−--
105−lookupVariable :: (Error e, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m Type
106−lookupVariable currentModule (Qualified moduleName var) = do
107− env <- getEnv
108− case M.lookup (fromMaybe currentModule moduleName, var) (names env) of
109− Nothing -> throwError . strMsg $ show var ++ " is undefined"
110− Just (ty, _, _) -> return ty
111−
112−-- |
113−-- Lookup the visibility of a value by name in the @Environment@
114−--
115−getVisibility :: (Error e, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m NameVisibility
116−getVisibility currentModule (Qualified moduleName var) = do
117− env <- getEnv
118− case M.lookup (fromMaybe currentModule moduleName, var) (names env) of
119− Nothing -> throwError . strMsg $ show var ++ " is undefined"
120− Just (_, _, vis) -> return vis
121−
122−-- |
123−-- Assert that a name is visible
124−--
125−checkVisibility :: (Error e, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m ()
126−checkVisibility currentModule name@(Qualified _ var) = do
127− vis <- getVisibility currentModule name
128− case vis of
129− Undefined -> throwError . strMsg $ show var ++ " may not be defined in the current scope."
130− _ -> return ()
131−
132−-- |
133−-- Lookup the kind of a type by name in the @Environment@
134−--
135−lookupTypeVariable :: (Error e, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified ProperName -> m Kind
136−lookupTypeVariable currentModule (Qualified moduleName name) = do
137− env <- getEnv
138− case M.lookup (Qualified (Just $ fromMaybe currentModule moduleName) name) (types env) of
139− Nothing -> throwError . strMsg $ "Type variable " ++ show name ++ " is undefined"
140− Just (k, _) -> return k
141−
142−-- |
143−-- State required for type checking:
144−--
145−data CheckState = CheckState {
146− -- |
147− -- The current @Environment@
148− --
149− checkEnv :: Environment
150− -- |
151− -- The next fresh unification variable name
152− --
153− , checkNextVar :: Int
154− -- |
155− -- The next type class dictionary name
156− --
157− , checkNextDictName :: Int
158− -- |
159− -- The current module
160− --
161− , checkCurrentModule :: Maybe ModuleName
162− }
163−
164−-- |
165−-- The type checking monad, which provides the state of the type checker, and error reporting capabilities
166−--
167−newtype Check a = Check { unCheck :: StateT CheckState (Either ErrorStack) a }
168− deriving (Functor, Monad, Applicative, Alternative, MonadPlus, MonadState CheckState, MonadError ErrorStack)
169−
170−-- |
171−-- Get the current @Environment@
172−--
173−getEnv :: (Functor m, MonadState CheckState m) => m Environment
174−getEnv = checkEnv <$> get
175−
176−-- |
177−-- Update the @Environment@
178−--
179−putEnv :: (MonadState CheckState m) => Environment -> m ()
180−putEnv env = modify (\s -> s { checkEnv = env })
181−
182−-- |
183−-- Modify the @Environment@
184−--
185−modifyEnv :: (MonadState CheckState m) => (Environment -> Environment) -> m ()
186−modifyEnv f = modify (\s -> s { checkEnv = f (checkEnv s) })
187−
188−-- |
189−-- Run a computation in the Check monad, starting with an empty @Environment@
190−--
191−runCheck :: Options mode -> Check a -> Either String (a, Environment)
192−runCheck opts = runCheck' opts initEnvironment
193−
194−-- |
195−-- Run a computation in the Check monad, failing with an error, or succeeding with a return value and the final @Environment@.
196−--
197−runCheck' :: Options mode -> Environment -> Check a -> Either String (a, Environment)
198−runCheck' opts env c = stringifyErrorStack (optionsVerboseErrors opts) $ do
199− (a, s) <- flip runStateT (CheckState env 0 0 Nothing) $ unCheck c
200− return (a, checkEnv s)
201−
202−-- |
203−-- Make an assertion, failing with an error message
204−--
205−guardWith :: (MonadError e m) => e -> Bool -> m ()
206−guardWith _ True = return ()
207−guardWith e False = throwError e
208−
209−-- |
210−-- Generate new type class dictionary name
211−--
212−freshDictionaryName :: Check Int
213−freshDictionaryName = do
214− n <- checkNextDictName <$> get
215− modify $ \s -> s { checkNextDictName = succ (checkNextDictName s) }
216− return n
217−
218−-- |
219−-- Lift a computation in the @Check@ monad into the substitution monad.
220−--
221−liftCheck :: Check a -> UnifyT t Check a
222−liftCheck = UnifyT . lift
223−
224−-- |
225−-- Run a computation in the substitution monad, generating a return value and the final substitution.
226−--
227−liftUnify :: (Partial t) => UnifyT t Check a -> Check (a, Substitution t)
228−liftUnify unify = do
229− st <- get
230− (a, ust) <- runUnify (defaultUnifyState { unifyNextVar = checkNextVar st }) unify
231− modify $ \st' -> st' { checkNextVar = unifyNextVar ust }
232− return (a, unifyCurrentSubstitution ust)
src/Language/PureScript/TypeChecker/Rows.hsdeleted−66
@@ -1,66 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.TypeChecker.Rows
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−-- Functions relating to type checking for rows
13−--
14−-----------------------------------------------------------------------------
15−
16−module Language.PureScript.TypeChecker.Rows (
17− checkDuplicateLabels
18−) where
19−
20−import Data.List
21−
22−import Control.Monad.Error
23−
24−import Language.PureScript.AST
25−import Language.PureScript.Errors
26−import Language.PureScript.TypeChecker.Monad
27−import Language.PureScript.Types
28−
29−-- |
30−-- Ensure rows do not contain duplicate labels
31−--
32−checkDuplicateLabels :: Expr -> Check ()
33−checkDuplicateLabels =
34− let (_, f, _) = everywhereOnValuesM def go def
35− in void . f
36− where
37− def :: a -> Check a
38− def = return
39−
40− go :: Expr -> Check Expr
41− go e@(TypedValue _ val ty) = do
42− checkDups ty
43− return e
44−
45− where
46− checkDups :: Type -> Check ()
47− checkDups (TypeApp t1 t2) = checkDups t1 >> checkDups t2
48− checkDups (SaturatedTypeSynonym _ ts) = mapM_ checkDups ts
49− checkDups (ForAll _ t _) = checkDups t
50− checkDups (ConstrainedType args t) = do
51− mapM_ checkDups $ concatMap snd args
52− checkDups t
53− checkDups r@RCons{} =
54− let (ls, _) = rowToList r in
55− case firstDup . sort . map fst $ ls of
56− Just l -> throwError $ mkErrorStack ("Duplicate label " ++ show l ++ " in row") $ Just (ExprError val)
57− Nothing -> return ()
58− checkDups _ = return ()
59−
60− firstDup :: (Eq a) => [a] -> Maybe a
61− firstDup (x : xs@(x' : _))
62− | x == x' = Just x
63− | otherwise = firstDup xs
64− firstDup _ = Nothing
65−
66− go other = return other
src/Language/PureScript/TypeChecker/Skolems.hsdeleted−114
@@ -1,114 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.TypeChecker.Skolems
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−-- Functions relating to skolemization used during typechecking
13−--
14−-----------------------------------------------------------------------------
15−
16−module Language.PureScript.TypeChecker.Skolems (
17− newSkolemConstant,
18− introduceSkolemScope,
19− newSkolemScope,
20− skolemize,
21− skolemizeTypesInValue,
22− skolemEscapeCheck
23−) where
24−
25−import Data.List (nub, (\\))
26−import Data.Monoid
27−
28−import Control.Applicative
29−import Control.Monad.Error
30−import Control.Monad.Unify
31−
32−import Language.PureScript.AST
33−import Language.PureScript.Errors
34−import Language.PureScript.Pretty
35−import Language.PureScript.TypeChecker.Monad
36−import Language.PureScript.Types
37−
38−-- |
39−-- Generate a new skolem constant
40−--
41−newSkolemConstant :: UnifyT Type Check Int
42−newSkolemConstant = fresh'
43−
44−-- |
45−-- Introduce skolem scope at every occurence of a ForAll
46−--
47−introduceSkolemScope :: Type -> UnifyT Type Check Type
48−introduceSkolemScope = everywhereOnTypesM go
49− where
50− go (ForAll ident ty Nothing) = ForAll ident ty <$> (Just <$> newSkolemScope)
51− go other = return other
52−
53−-- |
54−-- Generate a new skolem scope
55−--
56−newSkolemScope :: UnifyT Type Check SkolemScope
57−newSkolemScope = SkolemScope <$> fresh'
58−
59−-- |
60−-- Skolemize a type variable by replacing its instances with fresh skolem constants
61−--
62−skolemize :: String -> Int -> SkolemScope -> Type -> Type
63−skolemize ident sko scope = replaceTypeVars ident (Skolem ident sko scope)
64−
65−-- |
66−-- This function has one purpose - to skolemize type variables appearing in a
67−-- SuperClassDictionary placeholder. These type variables are somewhat unique since they are the
68−-- only example of scoped type variables.
69−--
70−skolemizeTypesInValue :: String -> Int -> SkolemScope -> Expr -> Expr
71−skolemizeTypesInValue ident sko scope = let (_, f, _) = everywhereOnValues id go id in f
72− where
73− go (SuperClassDictionary c ts) = SuperClassDictionary c (map (skolemize ident sko scope) ts)
74− go other = other
75−
76−-- |
77−-- Ensure skolem variables do not escape their scope
78−--
79−skolemEscapeCheck :: Expr -> Check ()
80−skolemEscapeCheck (TypedValue False _ _) = return ()
81−skolemEscapeCheck root@TypedValue{} =
82− -- Every skolem variable is created when a ForAll type is skolemized.
83− -- This determines the scope of that skolem variable, which is copied from the SkolemScope
84− -- field of the ForAll constructor.
85− -- We traverse the tree top-down, and collect any SkolemScopes introduced by ForAlls.
86− -- If a Skolem is encountered whose SkolemScope is not in the current list, we have found
87− -- an escaped skolem variable.
88− let (_, f, _, _, _) = everythingWithContextOnValues [] [] (++) def go def def def
89− in case f root of
90− [] -> return ()
91− ((binding, val) : _) -> throwError $ mkErrorStack ("Rigid/skolem type variable " ++ maybe "" (("bound by " ++) . prettyPrintValue) binding ++ " has escaped.") (Just (ExprError val))
92− where
93− def s _ = (s, [])
94−
95− go :: [(SkolemScope, Expr)] -> Expr -> ([(SkolemScope, Expr)], [(Maybe Expr, Expr)])
96− go scos val@(TypedValue _ _ (ForAll _ _ (Just sco))) = ((sco, val) : scos, [])
97− go scos val@(TypedValue _ _ ty) = case collectSkolems ty \\ map fst scos of
98− (sco : _) -> (scos, [(findBindingScope sco, val)])
99− _ -> (scos, [])
100− where
101− collectSkolems :: Type -> [SkolemScope]
102− collectSkolems = nub . everythingOnTypes (++) collect
103− where
104− collect (Skolem _ _ scope) = [scope]
105− collect _ = []
106− go scos _ = (scos, [])
107− findBindingScope :: SkolemScope -> Maybe Expr
108− findBindingScope sco =
109− let (_, f, _, _, _) = everythingOnValues mappend (const mempty) go' (const mempty) (const mempty) (const mempty)
110− in getFirst $ f root
111− where
112− go' val@(TypedValue _ _ (ForAll _ _ (Just sco'))) | sco == sco' = First (Just val)
113− go' _ = mempty
114−skolemEscapeCheck val = throwError $ mkErrorStack "Untyped value passed to skolemEscapeCheck" (Just (ExprError val))
src/Language/PureScript/TypeChecker/Subsumption.hsdeleted−103
@@ -1,103 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.TypeChecker.Subsumption
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−-- Subsumption checking
13−--
14−-----------------------------------------------------------------------------
15−
16−module Language.PureScript.TypeChecker.Subsumption (
17− subsumes
18−) where
19−
20−import Data.List (sortBy)
21−import Data.Monoid
22−import Data.Ord (comparing)
23−
24−import Control.Applicative
25−import Control.Monad.Error
26−import Control.Monad.Unify
27−
28−import Language.PureScript.AST
29−import Language.PureScript.Environment
30−import Language.PureScript.Errors
31−import Language.PureScript.Pretty
32−import Language.PureScript.TypeChecker.Monad
33−import Language.PureScript.TypeChecker.Skolems
34−import Language.PureScript.TypeChecker.Synonyms
35−import Language.PureScript.TypeChecker.Unify
36−import Language.PureScript.Types
37−
38−-- |
39−-- Check whether one type subsumes another, rethrowing errors to provide a better error message
40−--
41−subsumes :: Maybe Expr -> Type -> Type -> UnifyT Type Check (Maybe Expr)
42−subsumes val ty1 ty2 = rethrow (mkErrorStack errorMessage (ExprError <$> val) <>) $ subsumes' val ty1 ty2
43− where
44− errorMessage = "Error checking that type "
45− ++ prettyPrintType ty1
46− ++ " subsumes type "
47− ++ prettyPrintType ty2
48−
49−-- |
50−-- Check whether one type subsumes another
51−--
52−subsumes' :: Maybe Expr -> Type -> Type -> UnifyT Type Check (Maybe Expr)
53−subsumes' val (ForAll ident ty1 _) ty2 = do
54− replaced <- replaceVarWithUnknown ident ty1
55− subsumes val replaced ty2
56−subsumes' val ty1 (ForAll ident ty2 sco) =
57− case sco of
58− Just sco' -> do
59− sko <- newSkolemConstant
60− let sk = skolemize ident sko sco' ty2
61− subsumes val ty1 sk
62− Nothing -> throwError . strMsg $ "Skolem variable scope is unspecified"
63−subsumes' val (TypeApp (TypeApp f1 arg1) ret1) (TypeApp (TypeApp f2 arg2) ret2) | f1 == tyFunction && f2 == tyFunction = do
64− _ <- subsumes Nothing arg2 arg1
65− _ <- subsumes Nothing ret1 ret2
66− return val
67−subsumes' val (SaturatedTypeSynonym name tyArgs) ty2 = do
68− ty1 <- introduceSkolemScope <=< expandTypeSynonym name $ tyArgs
69− subsumes val ty1 ty2
70−subsumes' val ty1 (SaturatedTypeSynonym name tyArgs) = do
71− ty2 <- introduceSkolemScope <=< expandTypeSynonym name $ tyArgs
72− subsumes val ty1 ty2
73−subsumes' val (KindedType ty1 _) ty2 =
74− subsumes val ty1 ty2
75−subsumes' val ty1 (KindedType ty2 _) =
76− subsumes val ty1 ty2
77−subsumes' (Just val) (ConstrainedType constraints ty1) ty2 = do
78− dicts <- getTypeClassDictionaries
79− subsumes' (Just $ foldl App val (map (flip (TypeClassDictionary True) dicts) constraints)) ty1 ty2
80−subsumes' val (TypeApp f1 r1) (TypeApp f2 r2) | f1 == tyObject && f2 == tyObject = do
81− let
82− (ts1, r1') = rowToList r1
83− (ts2, r2') = rowToList r2
84− ts1' = sortBy (comparing fst) ts1
85− ts2' = sortBy (comparing fst) ts2
86− go ts1' ts2' r1' r2'
87− return val
88− where
89− go [] ts2 r1' r2' = r1' =?= rowFromList (ts2, r2')
90− go ts1 [] r1' r2' = r2' =?= rowFromList (ts1, r1')
91− go ((p1, ty1) : ts1) ((p2, ty2) : ts2) r1' r2'
92− | p1 == p2 = do _ <- subsumes Nothing ty1 ty2
93− go ts1 ts2 r1' r2'
94− | p1 < p2 = do rest <- fresh
95− r2' =?= RCons p1 ty1 rest
96− go ts1 ((p2, ty2) : ts2) r1' rest
97− | otherwise = do rest <- fresh
98− r1' =?= RCons p2 ty2 rest
99− go ((p1, ty1) : ts1) ts2 rest r2'
100−subsumes' val ty1 ty2@(TypeApp obj _) | obj == tyObject = subsumes val ty2 ty1
101−subsumes' val ty1 ty2 = do
102− ty1 =?= ty2
103− return val
src/Language/PureScript/TypeChecker/Synonyms.hsdeleted−110
@@ -1,110 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.TypeChecker.Synonyms
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−-- Functions for replacing fully applied type synonyms with the @SaturatedTypeSynonym@ data constructor
13−--
14−-----------------------------------------------------------------------------
15−
16−{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses #-}
17−
18−module Language.PureScript.TypeChecker.Synonyms (
19− saturateAllTypeSynonyms,
20− desaturateAllTypeSynonyms,
21− replaceAllTypeSynonyms,
22− expandAllTypeSynonyms,
23− expandTypeSynonym,
24− expandTypeSynonym'
25−) where
26−
27−import Data.Maybe (fromMaybe)
28−import qualified Data.Map as M
29−
30−import Control.Applicative
31−import Control.Monad.Error
32−import Control.Monad.State
33−
34−import Language.PureScript.Environment
35−import Language.PureScript.Names
36−import Language.PureScript.TypeChecker.Monad
37−import Language.PureScript.Types
38−
39−-- |
40−-- Build a type substitution for a type synonym
41−--
42−buildTypeSubstitution :: Qualified ProperName -> Int -> Type -> Either String (Maybe Type)
43−buildTypeSubstitution name n = go n []
44− where
45− go :: Int -> [Type] -> Type -> Either String (Maybe Type)
46− go 0 args (TypeConstructor ctor) | name == ctor = return (Just $ SaturatedTypeSynonym ctor args)
47− go m _ (TypeConstructor ctor) | m > 0 && name == ctor = throwError $ "Partially applied type synonym " ++ show name
48− go m args (TypeApp f arg) = go (m - 1) (arg:args) f
49− go _ _ _ = return Nothing
50−
51−-- |
52−-- Replace all instances of a specific type synonym with the @SaturatedTypeSynonym@ data constructor
53−--
54−saturateTypeSynonym :: Qualified ProperName -> Int -> Type -> Either String Type
55−saturateTypeSynonym name n = everywhereOnTypesTopDownM replace
56− where
57− replace t = fromMaybe t <$> buildTypeSubstitution name n t
58−
59−-- |
60−-- Replace all type synonyms with the @SaturatedTypeSynonym@ data constructor
61−--
62−saturateAllTypeSynonyms :: [(Qualified ProperName, Int)] -> Type -> Either String Type
63−saturateAllTypeSynonyms syns d = foldM (\result (name, n) -> saturateTypeSynonym name n result) d syns
64−
65−-- |
66−-- \"Desaturate\" @SaturatedTypeSynonym@s
67−--
68−desaturateAllTypeSynonyms :: Type -> Type
69−desaturateAllTypeSynonyms = everywhereOnTypes replaceSaturatedTypeSynonym
70− where
71− replaceSaturatedTypeSynonym (SaturatedTypeSynonym name args) = foldl TypeApp (TypeConstructor name) args
72− replaceSaturatedTypeSynonym t = t
73−
74−-- |
75−-- Replace fully applied type synonyms with the @SaturatedTypeSynonym@ data constructor, which helps generate
76−-- better error messages during unification.
77−--
78−replaceAllTypeSynonyms' :: Environment -> Type -> Either String Type
79−replaceAllTypeSynonyms' env d =
80− let
81− syns = map (\(name, (args, _)) -> (name, length args)) . M.toList $ typeSynonyms env
82− in
83− saturateAllTypeSynonyms syns d
84−
85−replaceAllTypeSynonyms :: (Error e, Functor m, Monad m, MonadState CheckState m, MonadError e m) => Type -> m Type
86−replaceAllTypeSynonyms d = do
87− env <- getEnv
88− either (throwError . strMsg) return $ replaceAllTypeSynonyms' env d
89−
90−-- |
91−-- Replace a type synonym and its arguments with the aliased type
92−--
93−expandTypeSynonym' :: Environment -> Qualified ProperName -> [Type] -> Either String Type
94−expandTypeSynonym' env name args =
95− case M.lookup name (typeSynonyms env) of
96− Just (synArgs, body) -> do
97− let repl = replaceAllTypeVars (zip (map fst synArgs) args) body
98− replaceAllTypeSynonyms' env repl
99− Nothing -> error "Type synonym was not defined"
100−
101−expandTypeSynonym :: (Error e, Functor m, Monad m, MonadState CheckState m, MonadError e m) => Qualified ProperName -> [Type] -> m Type
102−expandTypeSynonym name args = do
103− env <- getEnv
104− either (throwError . strMsg) return $ expandTypeSynonym' env name args
105−
106−expandAllTypeSynonyms :: (Error e, Functor m, Applicative m, Monad m, MonadState CheckState m, MonadError e m) => Type -> m Type
107−expandAllTypeSynonyms = everywhereOnTypesTopDownM go
108− where
109− go (SaturatedTypeSynonym name args) = expandTypeSynonym name args
110− go other = return other
src/Language/PureScript/TypeChecker/Types.hsdeleted−678
@@ -1,678 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.TypeChecker.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−-- This module implements the type checker
13−--
14−-----------------------------------------------------------------------------
15−
16−{-# LANGUAGE FlexibleContexts, MultiParamTypeClasses #-}
17−
18−module Language.PureScript.TypeChecker.Types (
19− typesOf
20−) where
21−
22−{-
23− The following functions represent the corresponding type checking judgements:
24−
25− infer
26− Synthesize a type for a value
27−
28− check
29− Check a value has a given type
30−
31− checkProperties
32− Check an object with a given type contains specified properties
33−
34− checkFunctionApplication
35− Check a function of a given type returns a value of another type when applied to its arguments
36−-}
37−
38−import Data.Either (lefts, rights)
39−import Data.List
40−import Data.Maybe (fromMaybe)
41−import Data.Monoid
42−import qualified Data.Map as M
43−
44−import Control.Applicative
45−import Control.Monad.Error
46−import Control.Monad.State
47−import Control.Monad.Unify
48−
49−import Language.PureScript.AST
50−import Language.PureScript.Environment
51−import Language.PureScript.Errors
52−import Language.PureScript.Kinds
53−import Language.PureScript.Names
54−import Language.PureScript.Pretty
55−import Language.PureScript.TypeChecker.Entailment
56−import Language.PureScript.TypeChecker.Kinds
57−import Language.PureScript.TypeChecker.Monad
58−import Language.PureScript.TypeChecker.Rows
59−import Language.PureScript.TypeChecker.Skolems
60−import Language.PureScript.TypeChecker.Subsumption
61−import Language.PureScript.TypeChecker.Synonyms
62−import Language.PureScript.TypeChecker.Unify
63−import Language.PureScript.TypeClassDictionaries
64−import Language.PureScript.Types
65−import qualified Language.PureScript.Constants as C
66−
67−-- |
68−-- Infer the types of multiple mutually-recursive values, and return elaborated values including
69−-- type class dictionaries and type annotations.
70−--
71−typesOf :: Maybe ModuleName -> ModuleName -> [(Ident, Expr)] -> Check [(Ident, (Expr, Type))]
72−typesOf mainModuleName moduleName vals = do
73− tys <- fmap tidyUp . liftUnify $ do
74− (untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup moduleName vals
75− ds1 <- parU typed $ \e -> do
76− triple@(_, (_, ty)) <- checkTypedBindingGroupElement moduleName e dict
77− checkMain (fst e) ty
78− return triple
79− ds2 <- forM untyped $ \e -> do
80− triple@(_, (_, ty)) <- typeForBindingGroupElement e dict untypedDict
81− checkMain (fst e) ty
82− return triple
83− return $ ds1 ++ ds2
84−
85− forM tys $ \(ident, (val, ty)) -> do
86− -- Replace type class dictionary placeholders with actual dictionaries
87− val' <- replaceTypeClassDictionaries moduleName val
88− -- Check skolem variables did not escape their scope
89− skolemEscapeCheck val'
90− -- Check rows do not contain duplicate labels
91− checkDuplicateLabels val'
92− -- Remove type synonyms placeholders, and replace
93− -- top-level unification variables with named type variables.
94− let val'' = overTypes desaturateAllTypeSynonyms val'
95− ty' = varIfUnknown . desaturateAllTypeSynonyms $ ty
96− return (ident, (val'', ty'))
97− where
98− -- Apply the substitution that was returned from runUnify to both types and (type-annotated) values
99− tidyUp (ts, sub) = map (\(i, (val, ty)) -> (i, (overTypes (sub $?) val, sub $? ty))) ts
100− -- If --main is enabled, need to check that `main` has type Eff eff a for some eff, a
101− checkMain nm ty = when (Just moduleName == mainModuleName && nm == Ident C.main) $ do
102− [eff, a] <- replicateM 2 fresh
103− ty =?= TypeApp (TypeApp (TypeConstructor (Qualified (Just (ModuleName [ProperName "Control", ProperName "Monad", ProperName "Eff"])) (ProperName "Eff"))) eff) a
104−
105−type TypeData = M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility)
106−
107−type UntypedData = [(Ident, Type)]
108−
109−typeDictionaryForBindingGroup :: ModuleName -> [(Ident, Expr)] -> UnifyT Type Check ([(Ident, Expr)], [(Ident, (Expr, Type, Bool))], TypeData, UntypedData)
110−typeDictionaryForBindingGroup moduleName vals = do
111− let
112− -- Map each declaration to a name/value pair, with an optional type, if the declaration is typed
113− es = map isTyped vals
114− -- Filter the typed and untyped declarations
115− untyped = lefts es
116− typed = rights es
117− -- Make a map of names to typed declarations
118− typedDict = map (\(ident, (_, ty, _)) -> (ident, ty)) typed
119−
120− -- Create fresh unification variables for the types of untyped declarations
121− untypedNames <- replicateM (length untyped) fresh
122−
123− let
124− -- Make a map of names to the unification variables of untyped declarations
125− untypedDict = zip (map fst untyped) untypedNames
126− -- Create the dictionary of all name/type pairs, which will be added to the environment during type checking
127− dict = M.fromList (map (\(ident, ty) -> ((moduleName, ident), (ty, LocalVariable, Undefined))) $ typedDict ++ untypedDict)
128− return (untyped, typed, dict, untypedDict)
129−
130−checkTypedBindingGroupElement :: ModuleName -> (Ident, (Expr, Type, Bool)) -> TypeData -> UnifyT Type Check (Ident, (Expr, Type))
131−checkTypedBindingGroupElement moduleName (ident, (val', ty, checkType)) dict = do
132− -- Replace type wildcards
133− ty' <- replaceTypeWildcards ty
134− -- Kind check
135− kind <- liftCheck $ kindOf moduleName ty
136− guardWith (strMsg $ "Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
137− -- Check the type with the new names in scope
138− ty'' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty'
139− val'' <- if checkType
140− then bindNames dict $ TypedValue True <$> check val' ty'' <*> pure ty''
141− else return (TypedValue False val' ty'')
142− return (ident, (val'', ty''))
143−
144−typeForBindingGroupElement :: (Ident, Expr) -> TypeData -> UntypedData -> UnifyT Type Check (Ident, (Expr, Type))
145−typeForBindingGroupElement (ident, val) dict untypedDict = do
146− -- Infer the type with the new names in scope
147− TypedValue _ val' ty <- bindNames dict $ infer val
148− ty =?= fromMaybe (error "name not found in dictionary") (lookup ident untypedDict)
149− return (ident, (TypedValue True val' ty, ty))
150−
151−-- |
152−-- Check if a value contains a type annotation
153−--
154−isTyped :: (Ident, Expr) -> Either (Ident, Expr) (Ident, (Expr, Type, Bool))
155−isTyped (name, TypedValue checkType value ty) = Right (name, (value, ty, checkType))
156−isTyped (name, value) = Left (name, value)
157−
158−-- |
159−-- Map a function over type annotations appearing inside a value
160−--
161−overTypes :: (Type -> Type) -> Expr -> Expr
162−overTypes f = let (_, f', _) = everywhereOnValues id g id in f'
163− where
164− g :: Expr -> Expr
165− g (TypedValue checkTy val t) = TypedValue checkTy val (f t)
166− g (TypeClassDictionary b (nm, tys) sco) = TypeClassDictionary b (nm, map f tys) sco
167− g other = other
168−
169−-- |
170−-- Replace type class dictionary placeholders with inferred type class dictionaries
171−--
172−replaceTypeClassDictionaries :: ModuleName -> Expr -> Check Expr
173−replaceTypeClassDictionaries mn =
174− let (_, f, _) = everywhereOnValuesTopDownM return go return
175− in f
176− where
177− go (TypeClassDictionary trySuperclasses constraint dicts) = do
178− env <- getEnv
179− entails env mn dicts constraint trySuperclasses
180− go other = return other
181−
182−-- |
183−-- Check the kind of a type, failing if it is not of kind *.
184−--
185−checkTypeKind :: ModuleName -> Type -> UnifyT t Check ()
186−checkTypeKind moduleName ty = do
187− kind <- liftCheck $ kindOf moduleName ty
188− guardWith (strMsg $ "Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
189−
190−-- |
191−-- Remove any ForAlls and ConstrainedType constructors in a type by introducing new unknowns
192−-- or TypeClassDictionary values.
193−--
194−-- This is necessary during type checking to avoid unifying a polymorphic type with a
195−-- unification variable.
196−--
197−instantiatePolyTypeWithUnknowns :: Expr -> Type -> UnifyT Type Check (Expr, Type)
198−instantiatePolyTypeWithUnknowns val (ForAll ident ty _) = do
199− ty' <- replaceVarWithUnknown ident ty
200− instantiatePolyTypeWithUnknowns val ty'
201−instantiatePolyTypeWithUnknowns val (ConstrainedType constraints ty) = do
202− dicts <- getTypeClassDictionaries
203− (_, ty') <- instantiatePolyTypeWithUnknowns (error "Types under a constraint cannot themselves be constrained") ty
204− return (foldl App val (map (flip (TypeClassDictionary True) dicts) constraints), ty')
205−instantiatePolyTypeWithUnknowns val ty = return (val, ty)
206−
207−-- |
208−-- Infer a type for a value, rethrowing any error to provide a more useful error message
209−--
210−infer :: Expr -> UnifyT Type Check Expr
211−infer val = rethrow (mkErrorStack "Error inferring type of value" (Just (ExprError val)) <>) $ infer' val
212−
213−-- |
214−-- Infer a type for a value
215−--
216−infer' :: Expr -> UnifyT Type Check Expr
217−infer' v@(NumericLiteral _) = return $ TypedValue True v tyNumber
218−infer' v@(StringLiteral _) = return $ TypedValue True v tyString
219−infer' v@(BooleanLiteral _) = return $ TypedValue True v tyBoolean
220−infer' (ArrayLiteral vals) = do
221− ts <- mapM infer vals
222− els <- fresh
223− forM_ ts $ \(TypedValue _ _ t) -> els =?= t
224− return $ TypedValue True (ArrayLiteral ts) (TypeApp tyArray els)
225−infer' (ObjectLiteral ps) = do
226− ensureNoDuplicateProperties ps
227− ts <- mapM (infer . snd) ps
228− let fields = zipWith (\name (TypedValue _ _ t) -> (name, t)) (map fst ps) ts
229− ty = TypeApp tyObject $ rowFromList (fields, REmpty)
230− return $ TypedValue True (ObjectLiteral (zip (map fst ps) ts)) ty
231−infer' (ObjectUpdate o ps) = do
232− ensureNoDuplicateProperties ps
233− row <- fresh
234− newVals <- zipWith (\(name, _) t -> (name, t)) ps <$> mapM (infer . snd) ps
235− let newTys = map (\(name, TypedValue _ _ ty) -> (name, ty)) newVals
236− oldTys <- zip (map fst ps) <$> replicateM (length ps) fresh
237− let oldTy = TypeApp tyObject $ rowFromList (oldTys, row)
238− o' <- TypedValue True <$> check o oldTy <*> pure oldTy
239− return $ TypedValue True (ObjectUpdate o' newVals) $ TypeApp tyObject $ rowFromList (newTys, row)
240−infer' (Accessor prop val) = do
241− typed@(TypedValue _ _ objTy) <- infer val
242− propTy <- inferProperty objTy prop
243− case propTy of
244− Nothing -> do
245− field <- fresh
246− rest <- fresh
247− _ <- subsumes Nothing objTy (TypeApp tyObject (RCons prop field rest))
248− return $ TypedValue True (Accessor prop typed) field
249− Just ty -> return $ TypedValue True (Accessor prop typed) ty
250−infer' (Abs (Left arg) ret) = do
251− ty <- fresh
252− Just moduleName <- checkCurrentModule <$> get
253− makeBindingGroupVisible $ bindLocalVariables moduleName [(arg, ty, Defined)] $ do
254− body@(TypedValue _ _ bodyTy) <- infer' ret
255− return $ TypedValue True (Abs (Left arg) body) $ function ty bodyTy
256−infer' (Abs (Right _) _) = error "Binder was not desugared"
257−infer' (App f arg) = do
258− f'@(TypedValue _ _ ft) <- infer f
259− (ret, app) <- checkFunctionApplication f' ft arg Nothing
260− return $ TypedValue True app ret
261−infer' (Var var) = do
262− Just moduleName <- checkCurrentModule <$> get
263− checkVisibility moduleName var
264− ty <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards <=< lookupVariable moduleName $ var
265− case ty of
266− ConstrainedType constraints ty' -> do
267− dicts <- getTypeClassDictionaries
268− return $ TypedValue True (foldl App (Var var) (map (flip (TypeClassDictionary True) dicts) constraints)) ty'
269− _ -> return $ TypedValue True (Var var) ty
270−infer' v@(Constructor c) = do
271− env <- getEnv
272− case M.lookup c (dataConstructors env) of
273− Nothing -> throwError . strMsg $ "Constructor " ++ show c ++ " is undefined"
274− Just (_, _, ty) -> do ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty
275− return $ TypedValue True v ty'
276−infer' (Case vals binders) = do
277− ts <- mapM infer vals
278− ret <- fresh
279− binders' <- checkBinders (map (\(TypedValue _ _ t) -> t) ts) ret binders
280− return $ TypedValue True (Case ts binders') ret
281−infer' (IfThenElse cond th el) = do
282− cond' <- check cond tyBoolean
283− v2@(TypedValue _ _ t2) <- infer th
284− v3@(TypedValue _ _ t3) <- infer el
285− (v2', v3', t) <- meet v2 v3 t2 t3
286− return $ TypedValue True (IfThenElse cond' v2' v3') t
287−infer' (Let ds val) = do
288− (ds', val'@(TypedValue _ _ valTy)) <- inferLetBinding [] ds val infer
289− return $ TypedValue True (Let ds' val') valTy
290−infer' (SuperClassDictionary className tys) = do
291− dicts <- getTypeClassDictionaries
292− return $ TypeClassDictionary False (className, tys) dicts
293−infer' (TypedValue checkType val ty) = do
294− Just moduleName <- checkCurrentModule <$> get
295− checkTypeKind moduleName ty
296− ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty
297− val' <- if checkType then check val ty' else return val
298− return $ TypedValue True val' ty'
299−infer' (PositionedValue pos val) = rethrowWithPosition pos $ infer' val
300−infer' _ = error "Invalid argument to infer"
301−
302−inferLetBinding :: [Declaration] -> [Declaration] -> Expr -> (Expr -> UnifyT Type Check Expr) -> UnifyT Type Check ([Declaration], Expr)
303−inferLetBinding seen [] ret j = (,) seen <$> makeBindingGroupVisible (j ret)
304−inferLetBinding seen (ValueDeclaration ident nameKind [] (Right (tv@(TypedValue checkType val ty))) : rest) ret j = do
305− Just moduleName <- checkCurrentModule <$> get
306− checkTypeKind moduleName ty
307− let dict = M.singleton (moduleName, ident) (ty, nameKind, Undefined)
308− ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty
309− TypedValue _ val' ty'' <- if checkType then bindNames dict (check val ty') else return tv
310− bindNames (M.singleton (moduleName, ident) (ty'', nameKind, Defined)) $ inferLetBinding (seen ++ [ValueDeclaration ident nameKind [] (Right (TypedValue checkType val' ty''))]) rest ret j
311−inferLetBinding seen (ValueDeclaration ident nameKind [] (Right val) : rest) ret j = do
312− valTy <- fresh
313− Just moduleName <- checkCurrentModule <$> get
314− let dict = M.singleton (moduleName, ident) (valTy, nameKind, Undefined)
315− TypedValue _ val' valTy' <- bindNames dict $ infer val
316− valTy =?= valTy'
317− bindNames (M.singleton (moduleName, ident) (valTy', nameKind, Defined)) $ inferLetBinding (seen ++ [ValueDeclaration ident nameKind [] (Right val')]) rest ret j
318−inferLetBinding seen (BindingGroupDeclaration ds : rest) ret j = do
319− Just moduleName <- checkCurrentModule <$> get
320− (untyped, typed, dict, untypedDict) <- typeDictionaryForBindingGroup moduleName (map (\(i, _, v) -> (i, v)) ds)
321− ds1' <- parU typed $ \e -> checkTypedBindingGroupElement moduleName e dict
322− ds2' <- forM untyped $ \e -> typeForBindingGroupElement e dict untypedDict
323− let ds' = [(ident, LocalVariable, val') | (ident, (val', _)) <- ds1' ++ ds2']
324− makeBindingGroupVisible $ bindNames dict $ inferLetBinding (seen ++ [BindingGroupDeclaration ds']) rest ret j
325−inferLetBinding seen (PositionedDeclaration pos d : ds) ret j = rethrowWithPosition pos $ do
326− (d' : ds', val') <- inferLetBinding seen (d : ds) ret j
327− return (PositionedDeclaration pos d' : ds', val')
328−inferLetBinding _ _ _ _ = error "Invalid argument to inferLetBinding"
329−
330−-- |
331−-- Infer the type of a property inside a record with a given type
332−--
333−inferProperty :: Type -> String -> UnifyT Type Check (Maybe Type)
334−inferProperty (TypeApp obj row) prop | obj == tyObject = do
335− let (props, _) = rowToList row
336− return $ lookup prop props
337−inferProperty (SaturatedTypeSynonym name args) prop = do
338− replaced <- introduceSkolemScope <=< expandTypeSynonym name $ args
339− inferProperty replaced prop
340−inferProperty (ForAll ident ty _) prop = do
341− replaced <- replaceVarWithUnknown ident ty
342− inferProperty replaced prop
343−inferProperty _ _ = return Nothing
344−
345−-- |
346−-- Infer the types of variables brought into scope by a binder
347−--
348−inferBinder :: Type -> Binder -> UnifyT Type Check (M.Map Ident Type)
349−inferBinder _ NullBinder = return M.empty
350−inferBinder val (StringBinder _) = val =?= tyString >> return M.empty
351−inferBinder val (NumberBinder _) = val =?= tyNumber >> return M.empty
352−inferBinder val (BooleanBinder _) = val =?= tyBoolean >> return M.empty
353−inferBinder val (VarBinder name) = return $ M.singleton name val
354−inferBinder val (ConstructorBinder ctor binders) = do
355− env <- getEnv
356− case M.lookup ctor (dataConstructors env) of
357− Just (_, _, ty) -> do
358− (_, fn) <- instantiatePolyTypeWithUnknowns (error "Data constructor types cannot contain constraints") ty
359− fn' <- introduceSkolemScope <=< replaceAllTypeSynonyms $ fn
360− go binders fn'
361− where
362− go [] ty' = do
363− _ <- subsumes Nothing val ty'
364− return M.empty
365− go (binder : binders') (TypeApp (TypeApp t obj) ret) | t == tyFunction =
366− M.union <$> inferBinder obj binder <*> go binders' ret
367− go _ _ = throwError . strMsg $ "Wrong number of arguments to constructor " ++ show ctor
368− _ -> throwError . strMsg $ "Constructor " ++ show ctor ++ " is not defined"
369−inferBinder val (ObjectBinder props) = do
370− row <- fresh
371− rest <- fresh
372− m1 <- inferRowProperties row rest props
373− val =?= TypeApp tyObject row
374− return m1
375− where
376− inferRowProperties :: Type -> Type -> [(String, Binder)] -> UnifyT Type Check (M.Map Ident Type)
377− inferRowProperties nrow row [] = nrow =?= row >> return M.empty
378− inferRowProperties nrow row ((name, binder):binders) = do
379− propTy <- fresh
380− m1 <- inferBinder propTy binder
381− m2 <- inferRowProperties nrow (RCons name propTy row) binders
382− return $ m1 `M.union` m2
383−inferBinder val (ArrayBinder binders) = do
384− el <- fresh
385− m1 <- M.unions <$> mapM (inferBinder el) binders
386− val =?= TypeApp tyArray el
387− return m1
388−inferBinder val (ConsBinder headBinder tailBinder) = do
389− el <- fresh
390− m1 <- inferBinder el headBinder
391− m2 <- inferBinder val tailBinder
392− val =?= TypeApp tyArray el
393− return $ m1 `M.union` m2
394−inferBinder val (NamedBinder name binder) = do
395− m <- inferBinder val binder
396− return $ M.insert name val m
397−inferBinder val (PositionedBinder pos binder) =
398− rethrowWithPosition pos $ inferBinder val binder
399−
400−-- |
401−-- Check the types of the return values in a set of binders in a case statement
402−--
403−checkBinders :: [Type] -> Type -> [CaseAlternative] -> UnifyT Type Check [CaseAlternative]
404−checkBinders _ _ [] = return []
405−checkBinders nvals ret (CaseAlternative binders result : bs) = do
406− guardWith (strMsg "Overlapping binders in case statement") $
407− let ns = concatMap binderNames binders in length (nub ns) == length ns
408− Just moduleName <- checkCurrentModule <$> get
409− m1 <- M.unions <$> zipWithM inferBinder nvals binders
410− r <- bindLocalVariables moduleName [ (name, ty, Defined) | (name, ty) <- M.toList m1 ] $
411− CaseAlternative binders <$>
412− case result of
413− Left gs -> do
414− gs' <- forM gs $ \(grd, val) -> do
415− grd' <- check grd tyBoolean
416− val' <- TypedValue True <$> check val ret <*> pure ret
417− return (grd', val')
418− return $ Left gs'
419− Right val -> do
420− val' <- TypedValue True <$> check val ret <*> pure ret
421− return $ Right val'
422− rs <- checkBinders nvals ret bs
423− return $ r : rs
424−
425−-- |
426−-- Check the type of a value, rethrowing errors to provide a better error message
427−--
428−check :: Expr -> Type -> UnifyT Type Check Expr
429−check val ty = rethrow (mkErrorStack errorMessage (Just (ExprError val)) <>) $ check' val ty
430− where
431− errorMessage =
432− "Error checking type of term " ++
433− prettyPrintValue val ++
434− " against type " ++
435− prettyPrintType ty
436−
437−-- |
438−-- Check the type of a value
439−--
440−check' :: Expr -> Type -> UnifyT Type Check Expr
441−check' val (ForAll ident ty _) = do
442− scope <- newSkolemScope
443− sko <- newSkolemConstant
444− let sk = skolemize ident sko scope ty
445− let skVal = skolemizeTypesInValue ident sko scope val
446− val' <- check skVal sk
447− return $ TypedValue True val' (ForAll ident ty (Just scope))
448−check' val t@(ConstrainedType constraints ty) = do
449− dictNames <- forM constraints $ \(Qualified _ (ProperName className), _) -> do
450− n <- liftCheck freshDictionaryName
451− return $ Ident $ "__dict_" ++ className ++ "_" ++ show n
452− val' <- makeBindingGroupVisible $ withTypeClassDictionaries (zipWith (\name (className, instanceTy) ->
453− TypeClassDictionaryInScope name className instanceTy Nothing TCDRegular False) (map (Qualified Nothing) dictNames)
454− constraints) $ check val ty
455− return $ TypedValue True (foldr (Abs . Left) val' dictNames) t
456−check' val (SaturatedTypeSynonym name args) = do
457− ty <- introduceSkolemScope <=< expandTypeSynonym name $ args
458− check val ty
459−check' val u@(TUnknown _) = do
460− val'@(TypedValue _ _ ty) <- infer val
461− -- Don't unify an unknown with an inferred polytype
462− (val'', ty') <- instantiatePolyTypeWithUnknowns val' ty
463− ty' =?= u
464− return $ TypedValue True val'' ty'
465−check' v@(NumericLiteral _) t | t == tyNumber =
466− return $ TypedValue True v t
467−check' v@(StringLiteral _) t | t == tyString =
468− return $ TypedValue True v t
469−check' v@(BooleanLiteral _) t | t == tyBoolean =
470− return $ TypedValue True v t
471−check' (ArrayLiteral vals) t@(TypeApp a ty) = do
472− a =?= tyArray
473− array <- ArrayLiteral <$> forM vals (`check` ty)
474− return $ TypedValue True array t
475−check' (Abs (Left arg) ret) ty@(TypeApp (TypeApp t argTy) retTy) | t == tyFunction = do
476− Just moduleName <- checkCurrentModule <$> get
477− ret' <- makeBindingGroupVisible $ bindLocalVariables moduleName [(arg, argTy, Defined)] $ check ret retTy
478− return $ TypedValue True (Abs (Left arg) ret') ty
479−check' (Abs (Right _) _) _ = error "Binder was not desugared"
480−check' (App f arg) ret = do
481− f'@(TypedValue _ _ ft) <- infer f
482− (_, app) <- checkFunctionApplication f' ft arg (Just ret)
483− return $ TypedValue True app ret
484−check' v@(Var var) ty = do
485− Just moduleName <- checkCurrentModule <$> get
486− checkVisibility moduleName var
487− repl <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< lookupVariable moduleName $ var
488− ty' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty
489− v' <- subsumes (Just v) repl ty'
490− case v' of
491− Nothing -> throwError . strMsg $ "Unable to check type subsumption"
492− Just v'' -> return $ TypedValue True v'' ty'
493−check' (SuperClassDictionary className tys) _ = do
494− {-
495− -- Here, we replace a placeholder for a superclass dictionary with a regular
496− -- TypeClassDictionary placeholder. The reason we do this is that it is necessary to have the
497− -- correct super instance dictionaries in scope, and these are not available when the type class
498− -- declaration gets desugared.
499− --
500− -- Note also that the first argument to TypeClassDictionary is False, meaning we _do not_ want
501− -- to consider superclass instances when searching for this dictionary - doing so might lead
502− -- to traversing a cycle in the instance graph.
503− -}
504− dicts <- getTypeClassDictionaries
505− return $ TypeClassDictionary False (className, tys) dicts
506−check' (TypedValue checkType val ty1) ty2 = do
507− Just moduleName <- checkCurrentModule <$> get
508− checkTypeKind moduleName ty1
509− ty1' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty1
510− ty2' <- introduceSkolemScope <=< replaceAllTypeSynonyms <=< replaceTypeWildcards $ ty2
511− val' <- subsumes (Just val) ty1' ty2'
512− case val' of
513− Nothing -> throwError . strMsg $ "Unable to check type subsumption"
514− Just val'' -> do
515− val''' <- if checkType then check val'' ty2' else return val''
516− return $ TypedValue checkType (TypedValue True val''' ty1') ty2'
517−check' (Case vals binders) ret = do
518− vals' <- mapM infer vals
519− let ts = map (\(TypedValue _ _ t) -> t) vals'
520− binders' <- checkBinders ts ret binders
521− return $ TypedValue True (Case vals' binders') ret
522−check' (IfThenElse cond th el) ty = do
523− cond' <- check cond tyBoolean
524− th' <- check th ty
525− el' <- check el ty
526− return $ TypedValue True (IfThenElse cond' th' el') ty
527−check' (ObjectLiteral ps) t@(TypeApp obj row) | obj == tyObject = do
528− ensureNoDuplicateProperties ps
529− ps' <- checkProperties ps row False
530− return $ TypedValue True (ObjectLiteral ps') t
531−check' (TypeClassDictionaryConstructorApp name ps) t = do
532− ps' <- check' ps t
533− return $ TypedValue True (TypeClassDictionaryConstructorApp name ps') t
534−check' (ObjectUpdate obj ps) t@(TypeApp o row) | o == tyObject = do
535− ensureNoDuplicateProperties ps
536− -- We need to be careful to avoid duplicate labels here.
537− -- We check _obj_ agaist the type _t_ with the types in _ps_ replaced with unknowns.
538− let (propsToCheck, rest) = rowToList row
539− (removedProps, remainingProps) = partition (\(p, _) -> p `elem` map fst ps) propsToCheck
540− us <- zip (map fst removedProps) <$> replicateM (length ps) fresh
541− obj' <- check obj (TypeApp tyObject (rowFromList (us ++ remainingProps, rest)))
542− ps' <- checkProperties ps row True
543− return $ TypedValue True (ObjectUpdate obj' ps') t
544−check' (Accessor prop val) ty = do
545− rest <- fresh
546− val' <- check val (TypeApp tyObject (RCons prop ty rest))
547− return $ TypedValue True (Accessor prop val') ty
548−check' (Constructor c) ty = do
549− env <- getEnv
550− case M.lookup c (dataConstructors env) of
551− Nothing -> throwError . strMsg $ "Constructor " ++ show c ++ " is undefined"
552− Just (_, _, ty1) -> do
553− repl <- introduceSkolemScope <=< replaceAllTypeSynonyms $ ty1
554− _ <- subsumes Nothing repl ty
555− return $ TypedValue True (Constructor c) ty
556−check' (Let ds val) ty = do
557− (ds', val') <- inferLetBinding [] ds val (`check` ty)
558− return $ TypedValue True (Let ds' val') ty
559−check' val ty | containsTypeSynonyms ty = do
560− ty' <- introduceSkolemScope <=< expandAllTypeSynonyms <=< replaceTypeWildcards $ ty
561− check val ty'
562−check' val kt@(KindedType ty kind) = do
563− guardWith (strMsg $ "Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
564− val' <- check' val ty
565− return $ TypedValue True val' kt
566−check' (PositionedValue pos val) ty =
567− rethrowWithPosition pos $ check val ty
568−check' val ty = throwError $ mkErrorStack ("Expr does not have type " ++ prettyPrintType ty) (Just (ExprError val))
569−
570−containsTypeSynonyms :: Type -> Bool
571−containsTypeSynonyms = everythingOnTypes (||) go where
572− go (SaturatedTypeSynonym _ _) = True
573− go _ = False
574−
575−-- |
576−-- Check the type of a collection of named record fields
577−--
578−-- The @lax@ parameter controls whether or not every record member has to be provided. For object updates, this is not the case.
579−--
580−checkProperties :: [(String, Expr)] -> Type -> Bool -> UnifyT Type Check [(String, Expr)]
581−checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where
582− go [] [] REmpty = return []
583− go [] [] u@(TUnknown _) = do u =?= REmpty
584− return []
585− go [] [] Skolem{} | lax = return []
586− go [] ((p, _): _) _ | lax = return []
587− | otherwise = throwError $ mkErrorStack ("Object does not have property " ++ p) (Just (ExprError (ObjectLiteral ps)))
588− go ((p,_):_) [] REmpty = throwError $ mkErrorStack ("Property " ++ p ++ " is not present in closed object type " ++ prettyPrintRow row) (Just (ExprError (ObjectLiteral ps)))
589− go ((p,v):ps') [] u@(TUnknown _) = do
590− v'@(TypedValue _ _ ty) <- infer v
591− rest <- fresh
592− u =?= RCons p ty rest
593− ps'' <- go ps' [] rest
594− return $ (p, v') : ps''
595− go ((p,v):ps') ts r =
596− case lookup p ts of
597− Nothing -> do
598− v'@(TypedValue _ _ ty) <- infer v
599− rest <- fresh
600− r =?= RCons p ty rest
601− ps'' <- go ps' ts rest
602− return $ (p, v') : ps''
603− Just ty -> do
604− v' <- check v ty
605− ps'' <- go ps' (delete (p, ty) ts) r
606− return $ (p, v') : ps''
607− go _ _ _ = throwError $ mkErrorStack ("Object does not have type " ++ prettyPrintType (TypeApp tyObject row)) (Just (ExprError (ObjectLiteral ps)))
608−
609−-- |
610−-- Check the type of a function application, rethrowing errors to provide a better error message
611−--
612−checkFunctionApplication :: Expr -> Type -> Expr -> Maybe Type -> UnifyT Type Check (Type, Expr)
613−checkFunctionApplication fn fnTy arg ret = rethrow (mkErrorStack errorMessage (Just (ExprError fn)) <>) $ do
614− subst <- unifyCurrentSubstitution <$> UnifyT get
615− checkFunctionApplication' fn (subst $? fnTy) arg (($?) subst <$> ret)
616− where
617− errorMessage = "Error applying function of type "
618− ++ prettyPrintType fnTy
619− ++ " to argument " ++ prettyPrintValue arg
620−
621−-- |
622−-- Check the type of a function application
623−--
624−checkFunctionApplication' :: Expr -> Type -> Expr -> Maybe Type -> UnifyT Type Check (Type, Expr)
625−checkFunctionApplication' fn (TypeApp (TypeApp tyFunction' argTy) retTy) arg ret = do
626− tyFunction' =?= tyFunction
627− arg' <- check arg argTy
628− case ret of
629− Nothing -> return (retTy, App fn arg')
630− Just ret' -> do
631− Just app' <- subsumes (Just (App fn arg')) retTy ret'
632− return (retTy, app')
633−checkFunctionApplication' fn (ForAll ident ty _) arg ret = do
634− replaced <- replaceVarWithUnknown ident ty
635− checkFunctionApplication fn replaced arg ret
636−checkFunctionApplication' fn u@(TUnknown _) arg ret = do
637− arg' <- do
638− TypedValue _ arg' t <- infer arg
639− (arg'', t') <- instantiatePolyTypeWithUnknowns arg' t
640− return $ TypedValue True arg'' t'
641− let ty = (\(TypedValue _ _ t) -> t) arg'
642− ret' <- maybe fresh return ret
643− u =?= function ty ret'
644− return (ret', App fn arg')
645−checkFunctionApplication' fn (SaturatedTypeSynonym name tyArgs) arg ret = do
646− ty <- introduceSkolemScope <=< expandTypeSynonym name $ tyArgs
647− checkFunctionApplication fn ty arg ret
648−checkFunctionApplication' fn (KindedType ty _) arg ret =
649− checkFunctionApplication fn ty arg ret
650−checkFunctionApplication' fn (ConstrainedType constraints fnTy) arg ret = do
651− dicts <- getTypeClassDictionaries
652− checkFunctionApplication' (foldl App fn (map (flip (TypeClassDictionary True) dicts) constraints)) fnTy arg ret
653−checkFunctionApplication' fn fnTy dict@TypeClassDictionary{} _ =
654− return (fnTy, App fn dict)
655−checkFunctionApplication' _ fnTy arg _ = throwError . strMsg $ "Cannot apply a function of type "
656− ++ prettyPrintType fnTy
657− ++ " to argument " ++ prettyPrintValue arg
658−
659−-- |
660−-- Compute the meet of two types, i.e. the most general type which both types subsume.
661−-- TODO: handle constrained types
662−--
663−meet :: Expr -> Expr -> Type -> Type -> UnifyT Type Check (Expr, Expr, Type)
664−meet e1 e2 (ForAll ident t1 _) t2 = do
665− t1' <- replaceVarWithUnknown ident t1
666− meet e1 e2 t1' t2
667−meet e1 e2 t1 (ForAll ident t2 _) = do
668− t2' <- replaceVarWithUnknown ident t2
669− meet e1 e2 t1 t2'
670−meet e1 e2 t1 t2 = do
671− t1 =?= t2
672− return (e1, e2, t1)
673−
674−-- |
675−-- Ensure a set of property names and value does not contain duplicate labels
676−--
677−ensureNoDuplicateProperties :: (Error e, MonadError e m) => [(String, Expr)] -> m ()
678−ensureNoDuplicateProperties ps = guardWith (strMsg "Duplicate property names") $ length (nub . map fst $ ps) == length ps
src/Language/PureScript/TypeChecker/Unify.hsdeleted−184

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.