git.iko.soy/rowtype-yoga/purescript-native
on golang help sign in
swap
355eb9b2133 ahead, 0 behind
339 files changed+2720−19265
since splitsnapshots
unifiedsplit
.gitignore+12 .travis.yml−30 CONTRIBUTING.md−18 ChangeLog.md+3 LICENSE+30−684 README-go.md+48 README.md+33−17 Setup.hs−4 app/Main.hs+250 bundle/.gitignore−3 bundle/README−20 bundle/build.sh−43 bundle/winbuild.sh−40 core-tests/.gitignore−2 core-tests/test-everything.sh−44 default.nix+23 examples/.gitignore−1 examples/failing/365.purs−11 examples/failing/438.purs−9 examples/failing/ArrayType.purs−11 examples/failing/Arrays.purs−5 examples/failing/Do.purs−8 examples/failing/DuplicateDeclarationsInLet.purs−9 examples/failing/DuplicateProperties1.purs−9 examples/failing/DuplicateProperties2.purs−9 examples/failing/DuplicateTypeVars.purs−3 examples/failing/Eff.purs−12 examples/failing/Foldable.purs−12 examples/failing/InstanceExport.purs−15 examples/failing/KindError.purs−3 examples/failing/Let.purs−3 examples/failing/MPTCs.purs−7 examples/failing/MissingClassExport.purs−4 examples/failing/MissingClassMemberExport.purs−4 examples/failing/MultipleErrors.purs−9 examples/failing/MultipleErrors2.purs−5 examples/failing/MutRec.purs−5 examples/failing/MutRec2.purs−3 examples/failing/NewtypeMultiArgs.purs−3 examples/failing/NewtypeMultiCtor.purs−3 examples/failing/NoOverlap.purs−11 examples/failing/NullaryAbs.purs−3 examples/failing/Object.purs−5 examples/failing/OverlappingArguments.purs−3 examples/failing/OverlappingBinders.purs−4 examples/failing/OverlappingInstances.purs−11 examples/failing/OverlappingInstances2.purs−23 examples/failing/OverlappingVars.purs−12 examples/failing/Rank2Types.purs−7 examples/failing/Reserved.purs−4 examples/failing/RowConstructors1.purs−6 examples/failing/RowConstructors2.purs−6 examples/failing/RowConstructors3.purs−6 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/TypeSynonyms5.purs−3 examples/failing/TypeWildcards1.purs−4 examples/failing/TypeWildcards2.purs−4 examples/failing/TypeWildcards3.purs−7 examples/failing/UnderscoreModuleName.purs−3 examples/failing/UnifyInTypeInstanceLookup.purs−17 examples/failing/UnknownType.purs−4 examples/manual/QualifiedNames.purs−11 examples/manual/failing/ArgLengthMismatch.purs−4 examples/manual/failing/ExportExplicit.purs−5 examples/manual/failing/ExportExplicit1.purs−14 examples/manual/failing/ExportExplicit2.purs−5 examples/manual/failing/ExportExplicit3.purs−13 examples/manual/failing/ImportExplicit.purs−7 examples/manual/failing/ImportExplicit2.purs−7 examples/manual/failing/ImportModule.purs−7 examples/manual/failing/OrphanTypeDecl.purs−3 examples/manual/failing/RedefinedFixity.purs−6 examples/manual/failing/RequiredHiddenType.purs−8 examples/manual/passing/ExportExplicit.purs−20 examples/manual/passing/ExportExplicit2.purs−15 examples/manual/passing/Import.purs−19 examples/manual/passing/ImportExplicit.purs−14 examples/manual/passing/ImportQualified.purs−12 examples/manual/passing/Module.purs−28 examples/manual/passing/ModuleDeps.purs−17 examples/manual/passing/RedefinedFixity.purs−24 examples/manual/passing/TransitiveImport.purs−21 examples/passing/652.purs−15 examples/passing/810.purs−11 examples/passing/Applicative.purs−16 examples/passing/ArrayType.purs−9 examples/passing/Arrays.purs−24 examples/passing/Auto.purs−13 examples/passing/AutoPrelude.purs−8 examples/passing/AutoPrelude2.purs−9 examples/passing/BindersInFunctions.purs−18 examples/passing/BindingGroups.purs−8 examples/passing/BlockString.purs−12 examples/passing/CaseInDo.purs−20 examples/passing/CaseStatement.purs−19 examples/passing/CheckFunction.purs−5 examples/passing/CheckSynonymBug.purs−16 examples/passing/CheckTypeClass.purs−16 examples/passing/Church.purs−18 examples/passing/Collatz.purs−29 examples/passing/Comparisons.purs−25 examples/passing/Conditional.purs−9 examples/passing/Console.purs−13 examples/passing/DataAndType.purs−7 examples/passing/DeepArrayBinder.purs−18 examples/passing/DeepCase.purs−14 examples/passing/Do.purs−67 examples/passing/Dollar.purs−16 examples/passing/Eff.purs−25 examples/passing/EmptyDataDecls.purs−34 examples/passing/EmptyRow.purs−8 examples/passing/EmptyTypeClass.purs−12 examples/passing/EqOrd.purs−14 examples/passing/ExtendedInfixOperators.purs−20 examples/passing/ExternData.purs−13 examples/passing/ExternRaw.purs−26 examples/passing/FFI.purs−13 examples/passing/Fib.purs−15 examples/passing/FinalTagless.purs−22 examples/passing/ForeignInstance.purs−20 examples/passing/FunctionScope.purs−19 examples/passing/Functions.purs−15 examples/passing/Functions2.purs−19 examples/passing/Guards.purs−39 examples/passing/HoistError.purs−19 examples/passing/IfThenElseMaybe.purs−9 examples/passing/ImplicitEmptyImport.purs−6 examples/passing/ImportHiding.purs−18 examples/passing/InferRecFunWithConstrainedArgument.purs−8 examples/passing/InstanceBeforeClass.purs−9 examples/passing/JSReserved.purs−12 examples/passing/KindedType.purs−31 examples/passing/Let.purs−64 examples/passing/Let2.purs−15 examples/passing/LetInInstance.purs−12 examples/passing/LiberalTypeSynonyms.purs−19 examples/passing/MPTCs.purs−20 examples/passing/Match.purs−7 examples/passing/Monad.purs−32 examples/passing/MonadState.purs−48 examples/passing/MultiArgFunctions.purs−26 examples/passing/MultipleConstructorArgs.purs−21 examples/passing/MutRec.purs−19 examples/passing/MutRec2.purs−17 examples/passing/MutRec3.purs−17 examples/passing/NamedPatterns.purs−7 examples/passing/NegativeBinder.purs−7 examples/passing/Nested.purs−7 examples/passing/NestedTypeSynonyms.purs−11 examples/passing/NestedWhere.purs−10 examples/passing/Newtype.purs−22 examples/passing/NewtypeEff.purs−28 examples/passing/NewtypeWithRecordUpdate.purs−15 examples/passing/ObjectGetter.purs−11 examples/passing/ObjectSynonym.purs−13 examples/passing/ObjectUpdate.purs−18 examples/passing/ObjectUpdate2.purs−14 examples/passing/ObjectUpdater.purs−35 examples/passing/ObjectWildcards.purs−31 examples/passing/Objects.purs−35 examples/passing/OneConstructor.purs−7 examples/passing/OperatorAssociativity.purs−50 examples/passing/OperatorInlining.purs−46 examples/passing/OperatorSections.purs−21 examples/passing/Operators.purs−98 examples/passing/OptimizerBug.purs−9 examples/passing/PartialFunction.purs−19 examples/passing/Patterns.purs−28 examples/passing/Person.purs−18 examples/passing/Rank2Data.purs−29 examples/passing/Rank2Object.purs−10 examples/passing/Rank2TypeSynonym.purs−15 examples/passing/Rank2Types.purs−11 examples/passing/RebindableSyntax.purs−37 examples/passing/Recursion.purs−10 examples/passing/ReservedWords.purs−13 examples/passing/RowConstructors.purs−40 examples/passing/RowPolyInstanceContext.purs−20 examples/passing/RowSynonyms.purs−46 examples/passing/RuntimeScopeIssue.purs−19 examples/passing/ScopedTypeVariables.purs−34 examples/passing/Sequence.purs−12 examples/passing/SequenceDesugared.purs−34 examples/passing/ShadowedRename.purs−21 examples/passing/ShadowedTCO.purs−16 examples/passing/ShadowedTCOLet.purs−7 examples/passing/SignedNumericLiterals.purs−15 examples/passing/Superclasses1.purs−18 examples/passing/Superclasses2.purs−23 examples/passing/Superclasses3.purs−41 examples/passing/TCOCase.purs−10 examples/passing/TailCall.purs−15 examples/passing/Tick.purs−5 examples/passing/TopLevelCase.purs−28 examples/passing/TypeClassImport.purs−18 examples/passing/TypeClassMemberOrderChange.purs−11 examples/passing/TypeClasses.purs−69 examples/passing/TypeClassesInOrder.purs−11 examples/passing/TypeClassesWithOverlappingTypeVariables.purs−11 examples/passing/TypeDecl.purs−12 examples/passing/TypeSynonymInData.purs−9 examples/passing/TypeSynonyms.purs−25 examples/passing/TypeWildcards.purs−13 examples/passing/TypeWildcardsRecordExtension.purs−6 examples/passing/TypedWhere.purs−13 examples/passing/UnderscoreIdent.purs−9 examples/passing/Unit.purs−6 examples/passing/UnknownInTypeClassLookup.purs−12 examples/passing/Where.purs−49 examples/passing/iota.purs−9 examples/passing/s.purs−5 hierarchy/Main.hs−113 logo.png package.yaml+86 psc-docs/Ctags.hs−13 psc-docs/Etags.hs−15 psc-docs/Main.hs−265 psc-docs/Tags.hs−18 psc-make/Main.hs−182 psc/Main.hs−215 psci/Completion.hs−232 psci/Directive.hs−113 psci/PSCi.hs−544 psci/Parser.hs−139 psci/Types.hs−167 psci/main/Main.hs−6 psci/tests/Main.hs−137 psci/tests/data/Sample.purs psgo.cabal+145 purescript.cabal−198 src/CodeGen/IL.hs+321 src/CodeGen/IL/Common.hs+196 src/CodeGen/IL/Optimizer.hs+81 src/CodeGen/IL/Optimizer/Common.hs+18 src/CodeGen/IL/Optimizer/Inliner.hs+435 src/CodeGen/IL/Optimizer/MagicDo.hs+146 src/CodeGen/IL/Optimizer/TCO.hs+141 src/CodeGen/IL/Printer.hs+527 src/Control/Monad/Supply.hs−43 src/Control/Monad/Supply/Class.hs−36 src/Control/Monad/Unify.hs−159 src/Language/PureScript.hs−287 src/Language/PureScript/AST.hs−23 src/Language/PureScript/AST/Binders.hs−87 src/Language/PureScript/AST/Declarations.hs−454 src/Language/PureScript/AST/Operators.hs−39 src/Language/PureScript/AST/SourcePos.hs−58 src/Language/PureScript/AST/Traversals.hs−407 src/Language/PureScript/CodeGen.hs−25 src/Language/PureScript/CodeGen/Externs.hs−121 src/Language/PureScript/CodeGen/JS.hs−359 src/Language/PureScript/CodeGen/JS/AST.hs−337 src/Language/PureScript/CodeGen/JS/Common.hs−181 src/Language/PureScript/CodeGen/JS/Optimizer.hs−86 src/Language/PureScript/CodeGen/JS/Optimizer/Blocks.hs−42 src/Language/PureScript/CodeGen/JS/Optimizer/Common.hs−77 src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hs−294 src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hs−165 src/Language/PureScript/CodeGen/JS/Optimizer/TCO.hs−128 src/Language/PureScript/CodeGen/JS/Optimizer/Unused.hs−46 src/Language/PureScript/Comments.hs−25 src/Language/PureScript/Constants.hs−278 src/Language/PureScript/CoreFn.hs−26 src/Language/PureScript/CoreFn/Ann.hs−37 src/Language/PureScript/CoreFn/Binders.hs−48 src/Language/PureScript/CoreFn/Desugar.hs−254 src/Language/PureScript/CoreFn/Expr.hs−134 src/Language/PureScript/CoreFn/Literals.hs−46 src/Language/PureScript/CoreFn/Meta.hs−51 src/Language/PureScript/CoreFn/Module.hs−32 src/Language/PureScript/CoreFn/Traversals.hs−85 src/Language/PureScript/DeadCodeElimination.hs−102 src/Language/PureScript/Environment.hs−241 src/Language/PureScript/Errors.hs−583 src/Language/PureScript/Kinds.hs−60 src/Language/PureScript/Linter.hs−73 src/Language/PureScript/ModuleDependencies.hs−77 src/Language/PureScript/Names.hs−85 src/Language/PureScript/Options.hs−92 src/Language/PureScript/Parser.hs−35 src/Language/PureScript/Parser/Common.hs−134 src/Language/PureScript/Parser/Declarations.hs−526 src/Language/PureScript/Parser/Kinds.hs−45 src/Language/PureScript/Parser/Lexer.hs−499 src/Language/PureScript/Parser/State.hs−30 src/Language/PureScript/Parser/Types.hs−132 src/Language/PureScript/Pretty.hs−32 src/Language/PureScript/Pretty/Common.hs−69 src/Language/PureScript/Pretty/JS.hs−301 src/Language/PureScript/Pretty/Kinds.hs−59 src/Language/PureScript/Pretty/Types.hs−129 src/Language/PureScript/Pretty/Values.hs−250 src/Language/PureScript/Renamer.hs−196 src/Language/PureScript/Sugar.hs−71 src/Language/PureScript/Sugar/BindingGroups.hs−206 src/Language/PureScript/Sugar/CaseDeclarations.hs−180 src/Language/PureScript/Sugar/DoNotation.hs−74 src/Language/PureScript/Sugar/Names.hs−542 src/Language/PureScript/Sugar/ObjectWildcards.hs−65 src/Language/PureScript/Sugar/Operators.hs−166 src/Language/PureScript/Sugar/TypeClasses.hs−297 src/Language/PureScript/Sugar/TypeDeclarations.hs−69 src/Language/PureScript/Traversals.hs−41 src/Language/PureScript/TypeChecker.hs−347 src/Language/PureScript/TypeChecker/Entailment.hs−212 src/Language/PureScript/TypeChecker/Kinds.hs−218 src/Language/PureScript/TypeChecker/Monad.hs−244 src/Language/PureScript/TypeChecker/Rows.hs−67 src/Language/PureScript/TypeChecker/Skolems.hs−114 src/Language/PureScript/TypeChecker/Subsumption.hs−96 src/Language/PureScript/TypeChecker/Synonyms.hs−112 src/Language/PureScript/TypeChecker/Types.hs−670 src/Language/PureScript/TypeChecker/Unify.hs−204 src/Language/PureScript/TypeClassDictionaries.hs−96 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−112 travis-after-script.sh−21 travis-script.sh−17
.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−30
@@ -1,30 +0,0 @@
1−env:
2− - CABALVER=1.22 GHCVER=7.8.3 SUITE=tests
3− - CABALVER=1.22 GHCVER=7.8.3 SUITE=psci-tests
4−before_install:
5− - travis_retry sudo add-apt-repository -y ppa:hvr/ghc
6− - travis_retry sudo apt-get update
7− - travis_retry sudo apt-get install cabal-install-$CABALVER ghc-$GHCVER
8− - export PATH="/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$HOME/.cabal/bin:$PATH"
9−install:
10− - cabal --version
11− - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]"
12− - travis_retry cabal update
13− - cabal install --only-dependencies --enable-tests --enable-benchmarks
14−script:
15− - ./travis-script.sh
16−after_script:
17− - ./travis-after-script.sh
18−notifications:
19− email: true
20−before_deploy: "./bundle/build.sh linux64"
21−deploy:
22− provider: releases
23− api_key: $RELEASE_KEY
24− file:
25− - bundle/linux64.tar.gz
26− - bundle/linux64.sha
27− skip_cleanup: true
28− on:
29− all_branches: true
30− tags: true
CONTRIBUTING.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−684
@@ -1,684 +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− split
41− boxes
42−
43−base LICENSE file:
44−
45− This library (libraries/base) is derived from code from several
46− sources:
47−
48− * Code from the GHC project which is largely (c) The University of
49− Glasgow, and distributable under a BSD-style license (see below),
50−
51− * Code from the Haskell 98 Report which is (c) Simon Peyton Jones
52− and freely redistributable (but see the full license for
53− restrictions).
54−
55− * Code from the Haskell Foreign Function Interface specification,
56− which is (c) Manuel M. T. Chakravarty and freely redistributable
57− (but see the full license for restrictions).
58−
59− The full text of these licenses is reproduced below. All of the
60− licenses are BSD-style or compatible.
61−
62− -----------------------------------------------------------------------------
63−
64− The Glasgow Haskell Compiler License
65−
66− Copyright 2004, The University Court of the University of Glasgow.
67− All rights reserved.
68−
69− Redistribution and use in source and binary forms, with or without
70− modification, are permitted provided that the following conditions are met:
71−
72− - Redistributions of source code must retain the above copyright notice,
73− this list of conditions and the following disclaimer.
74−
75− - Redistributions in binary form must reproduce the above copyright notice,
76− this list of conditions and the following disclaimer in the documentation
77− and/or other materials provided with the distribution.
78−
79− - Neither name of the University nor the names of its contributors may be
80− used to endorse or promote products derived from this software without
81− specific prior written permission.
82−
83− THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF
84− GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
85− INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
86− FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
87− UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE
88− FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
89− DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
90− SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
91− CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
92− LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
93− OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
94− DAMAGE.
95−
96− -----------------------------------------------------------------------------
97−
98− Code derived from the document "Report on the Programming Language
99− Haskell 98", is distributed under the following license:
100−
101− Copyright (c) 2002 Simon Peyton Jones
102−
103− The authors intend this Report to belong to the entire Haskell
104− community, and so we grant permission to copy and distribute it for
105− any purpose, provided that it is reproduced in its entirety,
106− including this Notice. Modified versions of this Report may also be
107− copied and distributed for any purpose, provided that the modified
108− version is clearly presented as such, and that it does not claim to
109− be a definition of the Haskell 98 Language.
110−
111− -----------------------------------------------------------------------------
112−
113− Code derived from the document "The Haskell 98 Foreign Function
114− Interface, An Addendum to the Haskell 98 Report" is distributed under
115− the following license:
116−
117− Copyright (c) 2002 Manuel M. T. Chakravarty
118−
119− The authors intend this Report to belong to the entire Haskell
120− community, and so we grant permission to copy and distribute it for
121− any purpose, provided that it is reproduced in its entirety,
122− including this Notice. Modified versions of this Report may also be
123− copied and distributed for any purpose, provided that the modified
124− version is clearly presented as such, and that it does not claim to
125− be a definition of the Haskell 98 Foreign Function Interface.
126−
127− -----------------------------------------------------------------------------
128−
129−containers LICENSE file:
130−
131− The Glasgow Haskell Compiler License
132−
133− Copyright 2004, The University Court of the University of Glasgow.
134− All rights reserved.
135−
136− Redistribution and use in source and binary forms, with or without
137− modification, are permitted provided that the following conditions are met:
138−
139− - Redistributions of source code must retain the above copyright notice,
140− this list of conditions and the following disclaimer.
141−
142− - Redistributions in binary form must reproduce the above copyright notice,
143− this list of conditions and the following disclaimer in the documentation
144− and/or other materials provided with the distribution.
145−
146− - Neither name of the University nor the names of its contributors may be
147− used to endorse or promote products derived from this software without
148− specific prior written permission.
149−
150− THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF
151− GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
152− INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
153− FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
154− UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE
155− FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
156− DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
157− SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
158− CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
159− LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
160− OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
161− DAMAGE.
162−
163−directory LICENSE file:
164−
165− This library (libraries/base) is derived from code from two
166− sources:
167−
168− * Code from the GHC project which is largely (c) The University of
169− Glasgow, and distributable under a BSD-style license (see below),
170−
171− * Code from the Haskell 98 Report which is (c) Simon Peyton Jones
172− and freely redistributable (but see the full license for
173− restrictions).
174−
175− The full text of these licenses is reproduced below. Both of the
176− licenses are BSD-style or compatible.
177−
178− -----------------------------------------------------------------------------
179−
180− The Glasgow Haskell Compiler License
181−
182− Copyright 2004, The University Court of the University of Glasgow.
183− All rights reserved.
184−
185− Redistribution and use in source and binary forms, with or without
186− modification, are permitted provided that the following conditions are met:
187−
188− - Redistributions of source code must retain the above copyright notice,
189− this list of conditions and the following disclaimer.
190−
191− - Redistributions in binary form must reproduce the above copyright notice,
192− this list of conditions and the following disclaimer in the documentation
193− and/or other materials provided with the distribution.
194−
195− - Neither name of the University nor the names of its contributors may be
196− used to endorse or promote products derived from this software without
197− specific prior written permission.
198−
199− THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF
200− GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
201− INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
202− FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
203− UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE
204− FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
205− DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
206− SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
207− CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
208− LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
209− OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
210− DAMAGE.
211−
212− -----------------------------------------------------------------------------
213−
214− Code derived from the document "Report on the Programming Language
215− Haskell 98", is distributed under the following license:
216−
217− Copyright (c) 2002 Simon Peyton Jones
218−
219− The authors intend this Report to belong to the entire Haskell
220− community, and so we grant permission to copy and distribute it for
221− any purpose, provided that it is reproduced in its entirety,
222− including this Notice. Modified versions of this Report may also be
223− copied and distributed for any purpose, provided that the modified
224− version is clearly presented as such, and that it does not claim to
225− be a definition of the Haskell 98 Language.
226−
227− -----------------------------------------------------------------------------
228−
229−file-embed LICENSE file:
230−
231− The following license covers this documentation, and the source code, except
232− where otherwise indicated.
233−
234− Copyright 2008, Michael Snoyman. All rights reserved.
235−
236− Redistribution and use in source and binary forms, with or without
237− modification, are permitted provided that the following conditions are met:
238−
239− * Redistributions of source code must retain the above copyright notice, this
240− list of conditions and the following disclaimer.
241−
242− * Redistributions in binary form must reproduce the above copyright notice,
243− this list of conditions and the following disclaimer in the documentation
244− and/or other materials provided with the distribution.
245−
246− THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR
247− IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
248− MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO
249− EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,
250− INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
251− NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,
252− OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
253− LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
254− OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
255− ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
256−
257−filepath LICENSE file:
258−
259− Copyright Neil Mitchell 2005-2007.
260− All rights reserved.
261−
262− Redistribution and use in source and binary forms, with or without
263− modification, are permitted provided that the following conditions are
264− met:
265−
266− * Redistributions of source code must retain the above copyright
267− notice, this list of conditions and the following disclaimer.
268−
269− * Redistributions in binary form must reproduce the above
270− copyright notice, this list of conditions and the following
271− disclaimer in the documentation and/or other materials provided
272− with the distribution.
273−
274− * Neither the name of Neil Mitchell nor the names of other
275− contributors may be used to endorse or promote products derived
276− from this software without specific prior written permission.
277−
278− THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
279− "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
280− LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
281− A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
282− OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
283− SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
284− LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
285− DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
286− THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
287− (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
288− OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
289−
290−haskeline LICENSE file:
291−
292− Copyright 2007-2009, Judah Jacobson.
293− All Rights Reserved.
294−
295− Redistribution and use in source and binary forms, with or without
296− modification, are permitted provided that the following conditions are met:
297−
298− - Redistribution of source code must retain the above copyright notice,
299− this list of conditions and the following disclaimer.
300−
301− - Redistribution in binary form must reproduce the above copyright notice,
302− this list of conditions and the following disclaimer in the documentation
303− and/or other materials provided with the distribution.
304−
305− THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS "AS IS" AND ANY
306− EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
307− WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
308− DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR THE CONTRIBUTORS BE LIABLE
309− FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
310− DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
311− SERVICES; LOSS OF USE, DATA OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
312− CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
313− OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
314− USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
315−
316−monad-unify LICENSE file:
317−
318− The MIT License (MIT)
319−
320− Copyright (c) 2013 Phil Freeman
321−
322− Permission is hereby granted, free of charge, to any person obtaining a copy of
323− this software and associated documentation files (the "Software"), to deal in
324− the Software without restriction, including without limitation the rights to
325− use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of
326− the Software, and to permit persons to whom the Software is furnished to do so,
327− subject to the following conditions:
328−
329− The above copyright notice and this permission notice shall be included in all
330− copies or substantial portions of the Software.
331−
332− THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
333− IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
334− FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
335− COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
336− IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
337− CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
338−
339−mtl LICENSE file:
340−
341− The Glasgow Haskell Compiler License
342−
343− Copyright 2004, The University Court of the University of Glasgow.
344− All rights reserved.
345−
346− Redistribution and use in source and binary forms, with or without
347− modification, are permitted provided that the following conditions are met:
348−
349− - Redistributions of source code must retain the above copyright notice,
350− this list of conditions and the following disclaimer.
351−
352− - Redistributions in binary form must reproduce the above copyright notice,
353− this list of conditions and the following disclaimer in the documentation
354− and/or other materials provided with the distribution.
355−
356− - Neither name of the University nor the names of its contributors may be
357− used to endorse or promote products derived from this software without
358− specific prior written permission.
359−
360− THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF
361− GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
362− INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
363− FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
364− UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE
365− FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
366− DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
367− SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
368− CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
369− LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
370− OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
371− DAMAGE.
372−
373−optparse-applicative LICENSE file:
374−
375− Copyright (c) 2012, Paolo Capriotti
376−
377− All rights reserved.
378−
379− Redistribution and use in source and binary forms, with or without
380− modification, are permitted provided that the following conditions are met:
381−
382− * Redistributions of source code must retain the above copyright
383− notice, this list of conditions and the following disclaimer.
384−
385− * Redistributions in binary form must reproduce the above
386− copyright notice, this list of conditions and the following
387− disclaimer in the documentation and/or other materials provided
388− with the distribution.
389−
390− * Neither the name of Paolo Capriotti nor the names of other
391− contributors may be used to endorse or promote products derived
392− from this software without specific prior written permission.
393−
394− THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
395− "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
396− LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
397− A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
398− OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
399− SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
400− LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
401− DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
402− THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
403− (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
404− OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
405−
406−parsec LICENSE file:
407−
408− Copyright 1999-2000, Daan Leijen; 2007, Paolo Martini. All rights reserved.
409−
410− Redistribution and use in source and binary forms, with or without
411− modification, are permitted provided that the following conditions are met:
412−
413− * Redistributions of source code must retain the above copyright notice,
414− this list of conditions and the following disclaimer.
415− * Redistributions in binary form must reproduce the above copyright
416− notice, this list of conditions and the following disclaimer in the
417− documentation and/or other materials provided with the distribution.
418−
419− This software is provided by the copyright holders "as is" and any express or
420− implied warranties, including, but not limited to, the implied warranties of
421− merchantability and fitness for a particular purpose are disclaimed. In no
422− event shall the copyright holders be liable for any direct, indirect,
423− incidental, special, exemplary, or consequential damages (including, but not
424− limited to, procurement of substitute goods or services; loss of use, data,
425− or profits; or business interruption) however caused and on any theory of
426− liability, whether in contract, strict liability, or tort (including
427− negligence or otherwise) arising in any way out of the use of this software,
428− even if advised of the possibility of such damage.
429−
430−pattern-arrows LICENSE file:
431−
432− The MIT License (MIT)
433−
434− Copyright (c) 2013 Phil Freeman
435−
436− Permission is hereby granted, free of charge, to any person obtaining a copy of
437− this software and associated documentation files (the "Software"), to deal in
438− the Software without restriction, including without limitation the rights to
439− use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of
440− the Software, and to permit persons to whom the Software is furnished to do so,
441− subject to the following conditions:
442−
443− The above copyright notice and this permission notice shall be included in all
444− copies or substantial portions of the Software.
445−
446− THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
447− IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
448− FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
449− COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
450− IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
451− CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
452−
453−process LICENSE file:
454−
455− This library (libraries/process) is derived from code from two
456− sources:
457−
458− * Code from the GHC project which is largely (c) The University of
459− Glasgow, and distributable under a BSD-style license (see below),
460−
461− * Code from the Haskell 98 Report which is (c) Simon Peyton Jones
462− and freely redistributable (but see the full license for
463− restrictions).
464−
465− The full text of these licenses is reproduced below. Both of the
466− licenses are BSD-style or compatible.
467−
468− -----------------------------------------------------------------------------
469−
470− The Glasgow Haskell Compiler License
471−
472− Copyright 2004, The University Court of the University of Glasgow.
473− All rights reserved.
474−
475− Redistribution and use in source and binary forms, with or without
476− modification, are permitted provided that the following conditions are met:
477−
478− - Redistributions of source code must retain the above copyright notice,
479− this list of conditions and the following disclaimer.
480−
481− - Redistributions in binary form must reproduce the above copyright notice,
482− this list of conditions and the following disclaimer in the documentation
483− and/or other materials provided with the distribution.
484−
485− - Neither name of the University nor the names of its contributors may be
486− used to endorse or promote products derived from this software without
487− specific prior written permission.
488−
489− THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF
490− GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
491− INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
492− FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
493− UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE
494− FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
495− DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
496− SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
497− CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
498− LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
499− OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
500− DAMAGE.
501−
502− -----------------------------------------------------------------------------
503−
504− Code derived from the document "Report on the Programming Language
505− Haskell 98", is distributed under the following license:
506−
507− Copyright (c) 2002 Simon Peyton Jones
508−
509− The authors intend this Report to belong to the entire Haskell
510− community, and so we grant permission to copy and distribute it for
511− any purpose, provided that it is reproduced in its entirety,
512− including this Notice. Modified versions of this Report may also be
513− copied and distributed for any purpose, provided that the modified
514− version is clearly presented as such, and that it does not claim to
515− be a definition of the Haskell 98 Language.
516−
517− -----------------------------------------------------------------------------
518−
519−time LICENSE file:
520−
521− TimeLib is Copyright (c) Ashley Yakeley, 2004-2014. All rights reserved.
522− Certain sections are Copyright 2004, The University Court of the University of Glasgow. All rights reserved.
523−
524− Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:
525−
526− - Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.
527−
528− - 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.
529−
530− 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.
531−
532−transformers LICENSE file:
533−
534− The Glasgow Haskell Compiler License
535−
536− Copyright 2004, The University Court of the University of Glasgow.
537− All rights reserved.
538−
539− Redistribution and use in source and binary forms, with or without
540− modification, are permitted provided that the following conditions are met:
541−
542− - Redistributions of source code must retain the above copyright notice,
543− this list of conditions and the following disclaimer.
544−
545− - Redistributions in binary form must reproduce the above copyright notice,
546− this list of conditions and the following disclaimer in the documentation
547− and/or other materials provided with the distribution.
548−
549− - Neither name of the University nor the names of its contributors may be
550− used to endorse or promote products derived from this software without
551− specific prior written permission.
552−
553− THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF
554− GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
555− INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
556− FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
557− UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE
558− FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
559− DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
560− SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
561− CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
562− LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
563− OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH
564− DAMAGE.
565−
566−unordered-containers LICENSE file:
567−
568− Copyright (c) 2010, Johan Tibell
569−
570− All rights reserved.
571−
572− Redistribution and use in source and binary forms, with or without
573− modification, are permitted provided that the following conditions are met:
574−
575− * Redistributions of source code must retain the above copyright
576− notice, this list of conditions and the following disclaimer.
577−
578− * Redistributions in binary form must reproduce the above
579− copyright notice, this list of conditions and the following
580− disclaimer in the documentation and/or other materials provided
581− with the distribution.
582−
583− * Neither the name of Johan Tibell nor the names of other
584− contributors may be used to endorse or promote products derived
585− from this software without specific prior written permission.
586−
587− THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
588− "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
589− LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
590− A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
591− OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
592− SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
593− LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
594− DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
595− THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
596− (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
597− OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
598−
599−utf8-string LICENSE file:
600−
601− * Copyright (c) 2007, Galois Inc.
602− * All rights reserved.
603− *
604− * Redistribution and use in source and binary forms, with or without
605− * modification, are permitted provided that the following conditions are met:
606− * * Redistributions of source code must retain the above copyright
607− * notice, this list of conditions and the following disclaimer.
608− * * Redistributions in binary form must reproduce the above copyright
609− * notice, this list of conditions and the following disclaimer in the
610− * documentation and/or other materials provided with the distribution.
611− * * Neither the name of Galois Inc. nor the
612− * names of its contributors may be used to endorse or promote products
613− * derived from this software without specific prior written permission.
614− *
615− * THIS SOFTWARE IS PROVIDED BY Galois Inc. ``AS IS'' AND ANY
616− * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
617− * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
618− * DISCLAIMED. IN NO EVENT SHALL Galois Inc. BE LIABLE FOR ANY
619− * DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
620− * (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
621− * LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
622− * ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
623− * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
624− * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
625−
626−split LICENSE file:
627−
628− Copyright (c) 2008 Brent Yorgey, Louis Wasserman
629−
630− All rights reserved.
631−
632− Redistribution and use in source and binary forms, with or without
633− modification, are permitted provided that the following conditions
634− are met:
635− 1. Redistributions of source code must retain the above copyright
636− notice, this list of conditions and the following disclaimer.
637− 2. Redistributions in binary form must reproduce the above copyright
638− notice, this list of conditions and the following disclaimer in the
639− documentation and/or other materials provided with the distribution.
640− 3. Neither the name of the author nor the names of other contributors
641− may be used to endorse or promote products derived from this software
642− without specific prior written permission.
643−
644− THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND
645− ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
646− IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
647− ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE
648− FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
649− DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
650− OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
651− HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
652− LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
653− OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
654− SUCH DAMAGE.
655−
656−boxes LICENSE file:
657−
658− Copyright (c) Brent Yorgey 2008
659−
660− Redistribution and use in source and binary forms, with or without
661− modification, are permitted provided that the following conditions
662− are met:
663− 1. Redistributions of source code must retain the above copyright
664− notice, this list of conditions and the following disclaimer.
665− 2. Redistributions in binary form must reproduce the above copyright
666− notice, this list of conditions and the following disclaimer in the
667− documentation and/or other materials provided with the distribution.
668− 3. Neither the name of the author nor the names of other contributors
669− may be used to endorse or promote products derived from this software
670− without specific prior written permission.
671−
672− All other rights are reserved.
673−
674− THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND
675− ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
676− IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
677− ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE
678− FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
679− DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
680− OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
681− HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
682− LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
683− OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
684− 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+33−17
@@ -1,25 +1,41 @@
1−[![PureScript](logo.png)](http://purescript.org)
1+[![PureScript](https://raw.githubusercontent.com/purescript/purescript/master/logo.png)](http://purescript.org)
22
3−A small strongly typed programming language with expressive types that compiles to Javascript, written in and inspired by Haskell.
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.
44
5−[![Hackage](https://budueba.com/hackage/purescript)](http://hackage.haskell.org/package/purescript) [![Build Status](https://secure.travis-ci.org/purescript/purescript.png?branch=master)](http://travis-ci.org/purescript/purescript) [![Coverage Status](https://coveralls.io/repos/purescript/purescript/badge.png?branch=master)](https://coveralls.io/r/purescript/purescript?branch=master)
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).
66
7−## Language info
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`
820
9−- [PureScript home](http://purescript.org)
10−- [Releases & changelog](https://github.com/purescript/purescript/releases)
11−- [Contributing to PureScript](https://github.com/purescript/purescript/blob/master/CONTRIBUTING.md)
1221
13−## Resources
22+#### Requirements for building `pscpp` and `psgo`
1423
15−- [PureScript book](https://leanpub.com/purescript/read)
16−- [Wiki](http://wiki.purescript.org)
17−- [Try PureScript](http://try.purescript.org)
18−- [Pursuit package search engine](http://pursuit.purescript.org/)
19−- [Core library documentation index](http://functorial.com/psc-pages/docs)
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/))
2025
21−## Help!
26+#### Requirements for using PureScript + purescript-native
2227
23−- [#purescript IRC @ FreeNode](http://webchat.freenode.net/?channels=purescript)
24−- [PureScript on StackOverflow](http://stackoverflow.com/questions/tagged/purescript)
25−- [Google Group](https://groups.google.com/forum/#!forum/purescript)
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+---
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−
core-tests/.gitignoredeleted−2
@@ -1,2 +0,0 @@
1−bower_components/
2−output/
core-tests/test-everything.shdeleted−44
@@ -1,44 +0,0 @@
1−#!/bin/bash
2−
3−set -e
4−
5−npm install -g bower
6−
7−bower i purescript-profunctor \
8− purescript-contravariant \
9− purescript-parallel \
10− purescript-control \
11− purescript-tailrec \
12− purescript-maps \
13− purescript-free \
14− purescript-transformers \
15− purescript-monad-eff \
16− purescript-exists \
17− purescript-monoid \
18− purescript-either \
19− purescript-maybe \
20− purescript-inject \
21− purescript-graphs \
22− purescript-enums \
23− purescript-unfoldable \
24− purescript-coproducts \
25− purescript-lazy \
26− purescript-distributive \
27− purescript-identity \
28− purescript-bifunctors \
29− purescript-const \
30− purescript-sets \
31− purescript-quickcheck \
32− purescript-foreign \
33− purescript-foldable-traversable \
34− purescript-tuples \
35− purescript-strings \
36− purescript-arrays \
37− purescript-random \
38− purescript-refs \
39− purescript-globals \
40− purescript-exceptions \
41− purescript-validation \
42− purescript-math
43−
44−find bower_components/**/src -name '*.purs' | xargs ../dist/build/psc-make/psc-make
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/365.pursdeleted−11
@@ -1,11 +0,0 @@
1−module Main where
2−
3−class C a where
4− f :: a -> a
5− g :: a -> a
6−
7−instance cS :: C String where
8− f s = s
9− g = f
10−
11−main = g "Done"
examples/failing/438.pursdeleted−9
@@ -1,9 +0,0 @@
1−module Main where
2−
3−data Fix f = In (f (Fix f))
4−
5−instance eqFix :: (Eq (f (Fix f))) => Eq (Fix f) where
6− (==) (In f) (In g) = f == g
7− (/=) a b = not (a == b)
8−
9−example = In [] == In []
examples/failing/ArrayType.pursdeleted−11
@@ -1,11 +0,0 @@
1−module Main where
2−
3−import Debug.Trace
4−
5−bar :: Number -> Number -> Number
6−bar n m = n + m
7−
8−foo = x `bar` y
9− where
10− x = 1
11− y = []
examples/failing/Arrays.pursdeleted−5
@@ -1,5 +0,0 @@
1−module Main where
2−
3− import Prelude
4−
5− test = \arr -> arr !! (0 !! 0)
examples/failing/Do.pursdeleted−8
@@ -1,8 +0,0 @@
1−module Main where
2−
3−test1 = do let x = 1
4−
5−test2 y = do x <- y
6−
7−test3 = do return 1
8− return 2
examples/failing/DuplicateDeclarationsInLet.pursdeleted−9
@@ -1,9 +0,0 @@
1−module Main where
2−
3−foo = a
4− where
5− a :: Number
6− a = 1
7−
8− a :: Number
9− a = 2
examples/failing/DuplicateProperties1.pursdeleted−9
@@ -1,9 +0,0 @@
1−module DuplicateProperties where
2−
3−foreign import data Test :: # * -> *
4−
5−foreign import subtractX "" :: forall r. Test (x :: Unit | r) -> Test r
6−
7−foreign import hasX "" :: Test (x :: Unit, y :: Unit)
8−
9−baz = subtractX (subtractX hasX)
examples/failing/DuplicateProperties2.pursdeleted−9
@@ -1,9 +0,0 @@
1−module DuplicateProperties where
2−
3−foreign import data Test :: # * -> *
4−
5−foreign import subtractX "" :: forall r. Test (x :: Unit | r) -> Test r
6−
7−foreign import hasX "" :: forall r. Test (x :: Unit, y :: Unit | r)
8−
9−baz = subtractX (subtractX hasX)
examples/failing/DuplicateTypeVars.pursdeleted−3
@@ -1,3 +0,0 @@
1−module Main where
2−
3−type Foo a a = a
examples/failing/Eff.pursdeleted−12
@@ -1,12 +0,0 @@
1−module Main where
2−
3−import Prelude
4−import Control.Monad.Eff
5−import Control.Monad.ST
6−import Debug.Trace
7−
8−test = pureST (do
9− ref <- newSTRef 0
10− trace "ST"
11− modifySTRef ref $ \n -> n + 1
12− readSTRef ref)
examples/failing/Foldable.pursdeleted−12
@@ -1,12 +0,0 @@
1−module Main where
2−
3−class Foldable f where
4− fold :: forall a b. (a -> b -> b) -> b -> f a -> b
5− size :: forall a. f a -> Number
6−
7−instance foldableArray :: Foldable [] where
8− fold _ z [] = z
9− fold f z (x:xs) = x `f` (fold f z xs)
10− size = fold (const ((+) 1)) 0
11−
12−x = size [1,2,3]
examples/failing/InstanceExport.pursdeleted−15
@@ -1,15 +0,0 @@
1−module InstanceExport (S(..), f) where
2−
3−newtype S = S String
4−
5−class F a where
6− f :: a -> String
7−
8−instance fs :: F S where
9− f (S s) = s
10−
11−module Test where
12−
13−import InstanceExport
14−
15−test = f $ S "Test"
examples/failing/KindError.pursdeleted−3
@@ -1,3 +0,0 @@
1−module Main where
2−
3− data KindError f a = One f | Two (f a)
examples/failing/Let.pursdeleted−3
@@ -1,3 +0,0 @@
1−module Main where
2−
3−test = let x = x in x
examples/failing/MPTCs.pursdeleted−7
@@ -1,7 +0,0 @@
1−module Main where
2−
3−class Foo a where
4− f :: a -> a
5−
6−instance fooStringString :: Foo String String where
7− f a = a
examples/failing/MissingClassExport.pursdeleted−4
@@ -1,4 +0,0 @@
1−module Test (bar) where
2−
3− class Foo a where
4− bar :: a -> a
examples/failing/MissingClassMemberExport.pursdeleted−4
@@ -1,4 +0,0 @@
1−module Test (Foo) where
2−
3− class Foo a where
4− bar :: a -> a
examples/failing/MultipleErrors.pursdeleted−9
@@ -1,9 +0,0 @@
1−module MultipleErrors where
2−
3−foo :: Number -> Number
4−foo 0 = "Test"
5−foo n = bar (n - 1)
6−
7−bar :: Number -> Number
8−bar 0 = "Test"
9−bar n = foo (n - 1)
examples/failing/MultipleErrors2.pursdeleted−5
@@ -1,5 +0,0 @@
1−module MultipleErrors2 where
2−
3−foo = itDoesntExist
4−
5−bar = neitherDoesThis
examples/failing/MutRec.pursdeleted−5
@@ -1,5 +0,0 @@
1−module MutRec where
2−
3−x = y
4−
5−y = x
examples/failing/MutRec2.pursdeleted−3
@@ -1,3 +0,0 @@
1−module Main where
2−
3−x = x
examples/failing/NewtypeMultiArgs.pursdeleted−3
@@ -1,3 +0,0 @@
1−module Main where
2−
3−newtype Thing = Thing String Boolean
examples/failing/NewtypeMultiCtor.pursdeleted−3
@@ -1,3 +0,0 @@
1−module Main where
2−
3−newtype Thing = Thing String | Other
examples/failing/NoOverlap.pursdeleted−11
@@ -1,11 +0,0 @@
1−module Main where
2−
3−data Foo = Foo
4−
5−instance showFoo1 :: Show Foo where
6− show _ = "Foo"
7−
8−instance showFoo2 :: Show Foo where
9− show _ = "Bar"
10−
11−test = show Foo
examples/failing/NullaryAbs.pursdeleted−3
@@ -1,3 +0,0 @@
1−module Main where
2−
3− func = \ -> "no"
examples/failing/Object.pursdeleted−5
@@ -1,5 +0,0 @@
1−module Main where
2−
3−test o = o.foo
4−
5−test1 = test {}
examples/failing/OverlappingArguments.pursdeleted−3
@@ -1,3 +0,0 @@
1−module OverlappingArguments where
2−
3−f x x = x
examples/failing/OverlappingBinders.pursdeleted−4
@@ -1,4 +0,0 @@
1−module OverlappingBinders where
2−
3−f x = case x of
4− (y:y@(z:zs)) -> y
examples/failing/OverlappingInstances.pursdeleted−11
@@ -1,11 +0,0 @@
1−module OverlappingInstances where
2−
3−data A = A
4−
5−instance showA1 :: Show A where
6− show A = "Instance 1"
7−
8−instance showA2 :: Show A where
9− show A = "Instance 2"
10−
11−main = Debug.Trace.trace $ show A
examples/failing/OverlappingInstances2.pursdeleted−23
@@ -1,23 +0,0 @@
1−module OverlappingInstances where
2−
3−data A = A | B
4−
5−instance eqA1 :: Eq A where
6− (==) A A = true
7− (==) B B = true
8− (==) _ _ = false
9− (/=) x y = not (x == y)
10−
11−instance eqA2 :: Eq A where
12− (==) _ _ = true
13− (/=) _ _ = false
14−
15−instance ordA :: Ord A where
16− compare A B = LT
17− compare B A = GT
18− compare _ _ = EQ
19−
20−test :: forall a. (Ord a) => a -> a -> String
21−test x y = show $ x == y
22−
23−main = Debug.Trace.trace $ test A B
examples/failing/OverlappingVars.pursdeleted−12
@@ -1,12 +0,0 @@
1−module Main where
2−
3−class OverlappingVars a where
4− f :: a -> a
5−
6−data Foo a b = Foo a b
7−
8−instance overlappingVarsFoo :: OverlappingVars (Foo a a) where
9− f a = a
10−
11−test = f (Foo "" 0)
12−
examples/failing/Rank2Types.pursdeleted−7
@@ -1,7 +0,0 @@
1−module Main where
2−
3− import Prelude
4−
5− foreign import test :: (forall a. a -> a) -> Number
6−
7− test1 = test (\n -> n + 1)
examples/failing/Reserved.pursdeleted−4
@@ -1,4 +0,0 @@
1−module Main where
2−
3−(<) :: Number -> Number -> Number
4−(<) a b = !(a >= b)
examples/failing/RowConstructors1.pursdeleted−6
@@ -1,6 +0,0 @@
1−module Main where
2−
3−data Foo = Bar
4−type Baz = { | Foo }
5−
6−main = Debug.Trace.trace "Done"
examples/failing/RowConstructors2.pursdeleted−6
@@ -1,6 +0,0 @@
1−module Main where
2−
3−type Foo r = (x :: Number | r)
4−type Bar = { | Foo }
5−
6−main = Debug.Trace.trace "Done"
examples/failing/RowConstructors3.pursdeleted−6
@@ -1,6 +0,0 @@
1−module Main where
2−
3−type Foo = { x :: Number }
4−type Bar = { | Foo }
5−
6−main = Debug.Trace.trace "Done"
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/TypeSynonyms5.pursdeleted−3
@@ -1,3 +0,0 @@
1−module Main where
2−
3−type T = T
examples/failing/TypeWildcards1.pursdeleted−4
@@ -1,4 +0,0 @@
1−module TypeWildcards where
2−
3−type Test = _
4−
examples/failing/TypeWildcards2.pursdeleted−4
@@ -1,4 +0,0 @@
1−module TypeWildcards where
2−
3−data Test = Test _
4−
examples/failing/TypeWildcards3.pursdeleted−7
@@ -1,7 +0,0 @@
1−module TypeWildcards where
2−
3−data Foo a = Foo
4−
5−instance showFoo :: Show (Foo _) where
6− show Foo = "Foo"
7−
examples/failing/UnderscoreModuleName.pursdeleted−3
@@ -1,3 +0,0 @@
1−module Bad_Module where
2−
3−main = Debug.Trace.trace "Done"
examples/failing/UnifyInTypeInstanceLookup.pursdeleted−17
@@ -1,17 +0,0 @@
1−module Main where
2−
3−data Z = Z
4−data S n = S n
5−
6−data T
7−data F
8−
9−class EQ x y b
10−instance eqT :: EQ x x T
11−instance eqF :: EQ x y F
12−
13−foreign import test :: forall a b. (EQ a b T) => a -> b -> a
14−
15−foreign import anyNat :: forall a. a
16−
17−test1 = test anyNat (S Z)
examples/failing/UnknownType.pursdeleted−4
@@ -1,4 +0,0 @@
1−module Main where
2−
3−test :: Number -> Something
4−test = {}
examples/manual/QualifiedNames.pursdeleted−11
@@ -1,11 +0,0 @@
1−module Data.Either where
2−
3−data Either a b = Left a | Right b
4−
5−module Main where
6−
7−either :: forall a b c. (a -> c) -> (b -> c) -> Data.Either.Either a b -> c
8−either f _ (Data.Either.Left x) = f x
9−either _ g (Data.Either.Right y) = g y
10−
11−main = Debug.Trace.trace (either id id (Data.Either.Left "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/810.pursdeleted−11
@@ -1,11 +0,0 @@
1−module Main where
2−
3−data Maybe a = Nothing | Just a
4−
5−test :: forall a. Maybe a -> Maybe a
6−test m = o.x
7− where
8− o = case m of Nothing -> { x : Nothing }
9− Just a -> { x : Just a }
10−
11−main = Debug.Trace.trace "Done"
examples/passing/Applicative.pursdeleted−16
@@ -1,16 +0,0 @@
1−module Main where
2−
3−import Prelude ()
4−
5−class Applicative f where
6− pure :: forall a. a -> f a
7− (<*>) :: forall a b. f (a -> b) -> f a -> f b
8−
9−data Maybe a = Nothing | Just a
10−
11−instance applicativeMaybe :: Applicative Maybe where
12− pure = Just
13− (<*>) (Just f) (Just a) = Just (f a)
14− (<*>) _ _ = Nothing
15−
16−main = Debug.Trace.trace "Done"
examples/passing/ArrayType.pursdeleted−9
@@ -1,9 +0,0 @@
1−module Main where
2−
3−class Pointed p where
4− point :: forall a. a -> p a
5−
6−instance pointedArray :: Pointed [] where
7− point a = [a]
8−
9−main = Debug.Trace.trace "Done"
examples/passing/Arrays.pursdeleted−24
@@ -1,24 +0,0 @@
1−module Main where
2−
3−import Prelude.Unsafe (unsafeIndex)
4−
5−test1 arr = arr `unsafeIndex` 0 + arr `unsafeIndex` 1 + 1
6−
7−test2 = \arr -> case arr of
8− [x, y] -> x + y
9− [x] -> x
10− [] -> 0
11− (x : y : _) -> x + y
12−
13−data Tree = One Number | Some [Tree]
14−
15−test3 = \tree sum -> case tree of
16− One n -> n
17− Some (n1 : n2 : rest) -> test3 n1 sum * 10 + test3 n2 sum * 5 + sum rest
18−
19−test4 = \arr -> case arr of
20− [] -> 0
21− [_] -> 0
22− x : y : xs -> x * y + test4 xs
23−
24−main = Debug.Trace.trace "Done"
examples/passing/Auto.pursdeleted−13
@@ -1,13 +0,0 @@
1−module Main where
2−
3− data Auto s i o = Auto { state :: s, step :: s -> i -> o }
4−
5− type SomeAuto i o = forall r. (forall s. Auto s i o -> r) -> r
6−
7− exists :: forall s i o. s -> (s -> i -> o) -> SomeAuto i o
8− exists = \state step f -> f (Auto { state: state, step: step })
9−
10− run :: forall i o. SomeAuto i o -> i -> o
11− run = \s i -> s (\a -> case a of Auto a -> a.step a.state i)
12−
13− main = Debug.Trace.trace "Done"
examples/passing/AutoPrelude.pursdeleted−8
@@ -1,8 +0,0 @@
1−module Main where
2−
3−import Debug.Trace
4−
5−f x = x * 10
6−g y = y - 10
7−
8−main = trace $ show $ (f <<< g) 100
examples/passing/AutoPrelude2.pursdeleted−9
@@ -1,9 +0,0 @@
1−module Main where
2−
3−import qualified Prelude as P
4−import Debug.Trace
5−
6−f :: forall a. a -> a
7−f = P.id
8−
9−main = P.($) trace ((f P.<<< f) "Done")
examples/passing/BindersInFunctions.pursdeleted−18
@@ -1,18 +0,0 @@
1−module Main where
2−
3−import Prelude
4−
5−tail = \(_:xs) -> xs
6−
7−foreign import error
8− """
9− function error(msg) {
10− throw msg;
11− }
12− """ :: forall a. String -> a
13−
14−main =
15− let ts = tail [1, 2, 3] in
16− if ts == [2, 3]
17− then Debug.Trace.trace "Done"
18− else error "Incorrect result from 'tails'."
examples/passing/BindingGroups.pursdeleted−8
@@ -1,8 +0,0 @@
1−module Main where
2−
3−foo = bar
4− where bar r = r + 1
5−
6−r = foo 2
7−
8−main = Debug.Trace.trace "Done"
examples/passing/BlockString.pursdeleted−12
@@ -1,12 +0,0 @@
1−module Main where
2−
3−foreign import foo """
4− function foo(s) {
5− return s;
6− }
7−""" :: String -> String
8−
9−bar :: String -> String
10−bar _ = foo "test"
11−
12−main = Debug.Trace.trace "Done"
examples/passing/CaseInDo.pursdeleted−20
@@ -1,20 +0,0 @@
1−module Main where
2−
3−import Debug.Trace
4−import Control.Monad.Eff
5−
6−foreign import doIt "function doIt() { global.flag = true; }" :: forall eff. Eff eff Unit
7−
8−foreign import get "function get() { return global.flag; }" :: forall eff. Eff eff Boolean
9−
10−set = do
11− trace "Testing..."
12− case 0 of
13− 0 -> doIt
14− _ -> return unit
15−
16−main = do
17− set
18− b <- get
19− case b of
20− true -> trace "Done"
examples/passing/CaseStatement.pursdeleted−19
@@ -1,19 +0,0 @@
1−module Main where
2−
3−data A = A | B | C
4−
5−f a _ A = a
6−f _ a B = a
7−f _ _ C = "Done"
8−
9−g a _ A = a
10−g _ b B = b
11−g _ _ C = C
12−
13−data M a = N | J a
14−
15−h f N a = a
16−h f a N = a
17−h f (J a) (J b) = J (f a b)
18−
19−main = Debug.Trace.trace $ f "Done" "Failed" A
examples/passing/CheckFunction.pursdeleted−5
@@ -1,5 +0,0 @@
1−module Main where
2−
3−test = ((\x -> x+1) >>> (\x -> x*2)) 4
4−
5−main = Debug.Trace.trace "Done"
examples/passing/CheckSynonymBug.pursdeleted−16
@@ -1,16 +0,0 @@
1−module Main where
2−
3− import Prelude
4−
5− type Foo a = [a]
6−
7− foreign import length
8− """
9− function length(a) {
10− return a.length;
11− }
12− """ :: forall a. [a] -> Number
13−
14− foo _ = length ([] :: Foo Number)
15−
16− main = Debug.Trace.trace "Done"
examples/passing/CheckTypeClass.pursdeleted−16
@@ -1,16 +0,0 @@
1−module Main where
2−
3− data Bar a = Bar
4− data Baz
5−
6− class Foo a where
7− foo :: Bar a -> Baz
8−
9− foo_ :: forall a. (Foo a) => a -> Baz
10− foo_ x = foo ((mkBar :: forall a. (Foo a) => a -> Bar a) x)
11−
12− mkBar :: forall a. a -> Bar a
13− mkBar _ = Bar
14−
15− main = Debug.Trace.trace "Done"
16−
examples/passing/Church.pursdeleted−18
@@ -1,18 +0,0 @@
1−module Main where
2−
3− import Prelude ()
4−
5− type List a = forall r. r -> (a -> r -> r) -> r
6−
7− empty :: forall a. List a
8− empty = \r f -> r
9−
10− cons :: forall a. a -> List a -> List a
11− cons = \a l r f -> f a (l r f)
12−
13− append :: forall a. List a -> List a -> List a
14− append = \l1 l2 r f -> l2 (l1 r f) f
15−
16− test = append (cons 1 empty) (cons 2 empty)
17−
18− main = Debug.Trace.trace "Done"
examples/passing/Collatz.pursdeleted−29
@@ -1,29 +0,0 @@
1−module Main where
2−
3−import Control.Monad.Eff
4−import Control.Monad.ST
5−
6−foreign import jsMod
7− """
8− function jsMod(x) {
9− return function (y) {
10− return x % y;
11− };
12− }
13− """ :: Number -> Number -> Number
14−
15−infixl 7 %
16−(%) = jsMod
17−
18−collatz :: Number -> Number
19−collatz n = runPure (runST (do
20− r <- newSTRef n
21− count <- newSTRef 0
22− untilE $ do
23− modifySTRef count $ (+) 1
24− m <- readSTRef r
25− writeSTRef r $ if m % 2 == 0 then m / 2 else 3 * m + 1
26− return $ m == 1
27− readSTRef count))
28−
29−main = Debug.Trace.print $ collatz 1000
examples/passing/Comparisons.pursdeleted−25
@@ -1,25 +0,0 @@
1−module Main where
2−
3−import Control.Monad.Eff
4−import Debug.Trace
5−
6−foreign import data Assert :: !
7−
8−foreign import assert
9− """
10− function assert(x) {
11− return function() {
12− if (!x) throw new Error('assertion failed');
13− return {};
14− };
15− }
16− """ :: forall e. Boolean -> Eff (assert :: Assert | e) Unit
17−
18−main = do
19− assert (1 < 2)
20− assert (2 == 2)
21− assert (3 > 1)
22− assert ("a" < "b")
23− assert ("a" == "a")
24− assert ("z" > "a")
25− trace "Done!"
examples/passing/Conditional.pursdeleted−9
@@ -1,9 +0,0 @@
1−module Main where
2−
3− import Prelude ()
4−
5− fns = \f -> if f true then f else \x -> x
6−
7− not = \x -> if x then false else true
8−
9− main = Debug.Trace.trace "Done"
examples/passing/Console.pursdeleted−13
@@ -1,13 +0,0 @@
1−module Main where
2−
3−import Prelude
4−import Control.Monad.Eff
5−import Debug.Trace
6−
7−replicateM_ :: forall m a. (Monad m) => Number -> m a -> m {}
8−replicateM_ 0 _ = return {}
9−replicateM_ n act = do
10− act
11− replicateM_ (n - 1) act
12−
13−main = replicateM_ 10 (trace "Hello World!")
examples/passing/DataAndType.pursdeleted−7
@@ -1,7 +0,0 @@
1−module Main where
2−
3−data A = A B
4−
5−type B = A
6−
7−main = Debug.Trace.trace "Done"
examples/passing/DeepArrayBinder.pursdeleted−18
@@ -1,18 +0,0 @@
1−module Main where
2−
3−import Control.Monad.Eff
4−
5−match2 :: [Number] -> Number
6−match2 (x : y : xs) = x * y + match2 xs
7−match2 _ = 0
8−
9−foreign import explode
10− """
11− function explode() {
12− throw new Error('Incorrect result');
13− }
14− """ :: forall eff a. Eff eff a
15−
16−main = case match2 [1, 2, 3, 4, 5, 6, 7, 8, 9] of
17− 100 -> Debug.Trace.trace "Done"
18− _ -> explode
examples/passing/DeepCase.pursdeleted−14
@@ -1,14 +0,0 @@
1−module Main where
2−
3−import Debug.Trace
4−import Control.Monad.Eff
5−import Control.Monad.ST
6−
7−f x y =
8− let
9− g = case y of
10− 0 -> x
11− x -> 1 + x * x
12− in g + x + y
13−
14−main = print $ f 1 10
examples/passing/Do.pursdeleted−67
@@ -1,67 +0,0 @@
1−module Main where
2−
3−import Prelude
4−
5−data Maybe a = Nothing | Just a
6−
7−instance functorMaybe :: Functor Maybe where
8− (<$>) f Nothing = Nothing
9− (<$>) f (Just x) = Just (f x)
10−
11−instance applyMaybe :: Apply Maybe where
12− (<*>) (Just f) (Just x) = Just (f x)
13− (<*>) _ _ = Nothing
14−
15−instance applicativeMaybe :: Applicative Maybe where
16− pure = Just
17−
18−instance bindMaybe :: Bind Maybe where
19− (>>=) Nothing _ = Nothing
20− (>>=) (Just a) f = f a
21−
22−instance monadMaybe :: Prelude.Monad Maybe
23−
24−test1 = \_ -> do
25− Just "abc"
26−
27−test2 = \_ -> do
28− (x : _) <- Just [1, 2, 3]
29− (y : _) <- Just [4, 5, 6]
30− Just (x + y)
31−
32−test3 = \_ -> do
33− Just 1
34− Nothing :: Maybe Number
35− Just 2
36−
37−test4 mx my = do
38− x <- mx
39− y <- my
40− Just (x + y + 1)
41−
42−test5 mx my mz = do
43− x <- mx
44− y <- my
45− let sum = x + y
46− z <- mz
47− Just (z + sum + 1)
48−
49−test6 mx = \_ -> do
50− let
51− f :: forall a. Maybe a -> a
52− f (Just x) = x
53− Just (f mx)
54−
55−test8 = \_ -> do
56− Just (do
57− Just 1)
58−
59−test9 = \_ -> (+) <$> Just 1 <*> Just 2
60−
61−test10 _ = do
62− let
63− f x = g x * 3
64− g x = f x / 2
65− Just (f 10)
66−
67−main = Debug.Trace.trace "Done"
examples/passing/Dollar.pursdeleted−16
@@ -1,16 +0,0 @@
1−module Main where
2−
3−import Prelude ()
4−
5−($) :: forall a b. (a -> b) -> a -> b
6−($) f x = f x
7−
8−infixr 1000 $
9−
10−id x = x
11−
12−test1 x = id $ id $ id $ id $ x
13−
14−test2 x = id id $ id x
15−
16−main = Debug.Trace.trace "Done"
examples/passing/Eff.pursdeleted−25
@@ -1,25 +0,0 @@
1−module Main where
2−
3−import Prelude
4−import Control.Monad.Eff
5−import Control.Monad.ST
6−import Debug.Trace
7−
8−test1 = do
9− trace "Line 1"
10− trace "Line 2"
11−
12−test2 = runPure (runST (do
13− ref <- newSTRef 0
14− modifySTRef ref $ \n -> n + 1
15− readSTRef ref))
16−
17−test3 = pureST (do
18− ref <- newSTRef 0
19− modifySTRef ref $ \n -> n + 1
20− readSTRef ref)
21−
22−main = do
23− test1
24− Debug.Trace.print test2
25− Debug.Trace.print test3
examples/passing/EmptyDataDecls.pursdeleted−34
@@ -1,34 +0,0 @@
1−module Main where
2−
3−import Prelude
4−
5−data Z
6−data S n
7−
8−data ArrayBox n a = ArrayBox [a]
9−
10−nil :: forall a. ArrayBox Z a
11−nil = ArrayBox []
12−
13−foreign import concat
14− """
15− function concat(l1) {
16− return function(l2) {
17− return l1.concat(l2);
18− };
19− }
20− """ :: forall a. [a] -> [a] -> [a]
21−
22−cons' :: forall a n. a -> ArrayBox n a -> ArrayBox (S n) a
23−cons' x (ArrayBox xs) = ArrayBox $ concat [x] xs
24−
25−foreign import error
26− """
27− function error(msg) {
28− throw msg;
29− }
30− """ :: forall a. String -> a
31−
32−main = case cons' 1 $ cons' 2 $ cons' 3 nil of
33− ArrayBox [1, 2, 3] -> Debug.Trace.trace "Done"
34− _ -> error "Failed"
examples/passing/EmptyRow.pursdeleted−8
@@ -1,8 +0,0 @@
1−module Main where
2−
3−data Foo r = Foo { | r }
4−
5−test :: Foo ()
6−test = Foo {}
7−
8−main = Debug.Trace.trace "Done"
examples/passing/EmptyTypeClass.pursdeleted−12
@@ -1,12 +0,0 @@
1−module Main where
2−
3−import Prelude
4−
5−class Partial
6−
7−head :: forall a. (Partial) => [a] -> a
8−head (x:xs) = x
9−
10−instance allowPartials :: Partial
11−
12−main = Debug.Trace.trace $ head ["Done"]
examples/passing/EqOrd.pursdeleted−14
@@ -1,14 +0,0 @@
1−module Main where
2−
3−data Pair a b = Pair a b
4−
5−instance ordPair :: (Ord a, Ord b) => Ord (Pair a b) where
6− compare (Pair a1 b1) (Pair a2 b2) = case compare a1 a2 of
7− EQ -> compare b1 b2
8− r -> r
9−
10−instance eqPair :: (Eq a, Eq b) => Eq (Pair a b) where
11− (==) (Pair a1 b1) (Pair a2 b2) = a1 == a2 && b1 == b2
12− (/=) (Pair a1 b1) (Pair a2 b2) = a1 /= a2 || b1 /= b2
13−
14−main = Debug.Trace.print $ Pair 1 2 == Pair 1 2
examples/passing/ExtendedInfixOperators.pursdeleted−20
@@ -1,20 +0,0 @@
1−module Main where
2−
3−zipWith :: forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
4−zipWith _ [] _ = []
5−zipWith _ _ [] = []
6−zipWith f (x:xs) (y:ys) = f x y : zipWith f xs ys
7−
8−test1 = [1, 2, 3] `zipWith (+)` [4, 5, 6]
9−
10−comparing :: forall a b. (Ord b) => (a -> b) -> a -> a -> Ordering
11−comparing f = compare `Data.Function.on` f
12−
13−sum [] = 0
14−sum (x:xs) = x + sum xs
15−
16−test2 = [1, 2, 3] `comparing sum` [4, 5, 6]
17−
18−main = do
19− Debug.Trace.print test1
20− Debug.Trace.print test2
examples/passing/ExternData.pursdeleted−13
@@ -1,13 +0,0 @@
1−module Main where
2−
3− foreign import data IO :: * -> *
4−
5− foreign import bind "function bind() {}" :: forall a b. IO a -> (a -> IO b) -> IO b
6−
7− foreign import showMessage "function showMessage() {}" :: String -> IO { }
8−
9− foreign import prompt "function prompt() {}" :: IO String
10−
11− test _ = prompt `bind` \s -> showMessage s
12−
13− main = Debug.Trace.trace "Done"
examples/passing/ExternRaw.pursdeleted−26
@@ -1,26 +0,0 @@
1−module Main where
2−
3−foreign import first
4− """
5− function first(xs) {
6− return xs[0];
7− }
8− """ :: forall a. [a] -> a
9−
10−foreign import loop
11− """
12− function loop() {
13− while (true) {}
14− }
15− """ :: forall a. a
16−
17−foreign import concat
18− """
19− function concat(xs) {
20− return function(ys) {
21− return xs.concat(ys);
22− };
23− }
24− """ :: forall a. [a] -> [a] -> [a]
25−
26−main = Debug.Trace.trace "Done"
examples/passing/FFI.pursdeleted−13
@@ -1,13 +0,0 @@
1−module Main where
2−
3−foreign import foo
4− """
5− function foo(s) {
6− return s;
7− }
8− """ :: String -> String
9−
10−bar :: String -> String
11−bar _ = foo "test"
12−
13−main = Debug.Trace.trace "Done"
examples/passing/Fib.pursdeleted−15
@@ -1,15 +0,0 @@
1−module Main where
2−
3−import Prelude
4−import Control.Monad.Eff
5−import Control.Monad.ST
6−
7−main = runST (do
8− n1 <- newSTRef 1
9− n2 <- newSTRef 1
10− whileE ((>) 1000 <$> readSTRef n1) $ do
11− n1' <- readSTRef n1
12− n2' <- readSTRef n2
13− writeSTRef n2 $ n1' + n2'
14− writeSTRef n1 n2'
15− Debug.Trace.print n2')
examples/passing/FinalTagless.pursdeleted−22
@@ -1,22 +0,0 @@
1−module Main where
2−
3−import Prelude
4−
5−class E e where
6− num :: Number -> e Number
7− add :: e Number -> e Number -> e Number
8−
9−type Expr a = forall e. (E e) => e a
10−
11−data Id a = Id a
12−
13−instance exprId :: E Id where
14− num = Id
15− add (Id n) (Id m) = Id (n + m)
16−
17−runId (Id a) = a
18−
19−three :: Expr Number
20−three = add (num 1) (num 2)
21−
22−main = Debug.Trace.print $ runId three
examples/passing/ForeignInstance.pursdeleted−20
@@ -1,20 +0,0 @@
1−module Main where
2−
3−class Foo a where
4− foo :: a -> String
5−
6−foreign import instance fooArray :: (Foo a) => Foo [a]
7−
8−foreign import instance fooNumber :: Foo Number
9−
10−foreign import instance fooString :: Foo String
11−
12−foreign import fooString "var fooString = {};" :: Unit
13−foreign import fooNumber "var fooNumber = {};" :: Unit
14−foreign import fooArray "var fooArray = {};" :: Unit
15−
16−test1 _ = foo [1, 2, 3]
17−
18−test2 _ = foo "Test"
19−
20−main = Debug.Trace.trace "Done"
examples/passing/FunctionScope.pursdeleted−19
@@ -1,19 +0,0 @@
1−module Main where
2−
3− import Prelude
4−
5− mkValue :: Number -> Number
6− mkValue id = id
7−
8− foreign import error
9− """
10− function error(msg) {
11− throw msg;
12− }
13− """ :: forall a. String -> a
14−
15− main = do
16− let value = mkValue 1
17− if value == 1
18− then Debug.Trace.trace "Done"
19− else error "Not done"
examples/passing/Functions.pursdeleted−15
@@ -1,15 +0,0 @@
1−module Main where
2−
3− import Prelude
4−
5− test1 = \_ -> 0
6−
7− test2 = \a b -> a + b + 1
8−
9− test3 = \a -> a
10−
11− test4 = \(%%) -> 1 %% 2
12−
13− test5 = \(+++) (***) -> 1 +++ 2 *** 3
14−
15− main = Debug.Trace.trace "Done"
examples/passing/Functions2.pursdeleted−19
@@ -1,19 +0,0 @@
1−module Main where
2−
3− import Prelude
4−
5− test :: forall a b. a -> b -> a
6− test = \const _ -> const
7−
8− foreign import error
9− """
10− function error(msg) {
11− throw msg;
12− }
13− """ :: forall a. String -> a
14−
15− main = do
16− let value = test "Done" {}
17− if value == "Done"
18− then Debug.Trace.trace "Done"
19− else error "Not done"
examples/passing/Guards.pursdeleted−39
@@ -1,39 +0,0 @@
1−module Main where
2−
3−foreign import jsMod
4− """
5− function jsMod(x) {
6− return function (y) {
7− return x % y;
8− };
9− }
10− """ :: Number -> Number -> Number
11−
12−infixl 7 %
13−(%) = jsMod
14−
15−collatz = \x -> case x of
16− y | y % 2 == 0 -> y / 2
17− y -> y * 3 + 1
18−
19−-- Guards have access to current scope
20−collatz2 = \x y -> case x of
21− z | y > 0 -> z / 2
22− z -> z * 3 + 1
23−
24−min :: forall a. (Ord a) => a -> a -> a
25−min n m | n < m = n
26− | otherwise = m
27−
28−max :: forall a. (Ord a) => a -> a -> a
29−max n m = case unit of
30− _ | m < n -> n
31− | otherwise -> m
32−
33−testIndentation :: Number -> Number -> Number
34−testIndentation x y | x > 0
35− = x + y
36− | otherwise
37− = y - x
38−
39−main = Debug.Trace.trace $ min "Done" "ZZZZ"
examples/passing/HoistError.pursdeleted−19
@@ -1,19 +0,0 @@
1−module Main where
2−
3−import Control.Monad.Eff
4−import Debug.Trace
5−
6−foreign import f
7− """
8− function f(x) {
9− return function() {
10− if (x !== 0) throw new Error('x is not 0');
11− };
12− }
13− """ :: forall e. Number -> Eff e Number
14−
15−main = do
16− let x = 0
17− f x
18− let x = 1 + 1
19− trace "Done"
examples/passing/IfThenElseMaybe.pursdeleted−9
@@ -1,9 +0,0 @@
1−module Main where
2−
3−data Maybe a = Nothing | Just a
4−
5−test1 = if true then Just 10 else Nothing
6−
7−test2 = if true then Nothing else Just 10
8−
9−main = Debug.Trace.trace "Done"
examples/passing/ImplicitEmptyImport.pursdeleted−6
@@ -1,6 +0,0 @@
1−module Main where
2−
3−main = do
4− Debug.Trace.trace "Hello"
5− Debug.Trace.trace "Goodbye"
6− Debug.Trace.trace "Done"
examples/passing/ImportHiding.pursdeleted−18
@@ -1,18 +0,0 @@
1−module Main where
2−
3−import Debug.Trace
4−import Prelude hiding (
5− show, -- a value
6− Show, -- a type class
7− Unit(..) -- a constructor
8− )
9−
10−show = 1
11−
12−class Show a where
13− noshow :: a -> a
14−
15−data Unit = X | Y
16−
17−main = do
18− print show
examples/passing/InferRecFunWithConstrainedArgument.pursdeleted−8
@@ -1,8 +0,0 @@
1−module Main where
2−
3−import Prelude
4−
5−test 100 = 100
6−test n = test(1 + n)
7−
8−main = Debug.Trace.print $ test 0
examples/passing/InstanceBeforeClass.pursdeleted−9
@@ -1,9 +0,0 @@
1−module Main where
2−
3−instance fooNumber :: Foo Number where
4− foo = 0
5−
6−class Foo a where
7− foo :: a
8−
9−main = Debug.Trace.trace "Done"
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/Let2.pursdeleted−15
@@ -1,15 +0,0 @@
1−module Main where
2−
3−test =
4− let f :: Number -> Boolean
5− f 0 = false
6− f n = g (n - 1)
7−
8− g :: Number -> Boolean
9− g 0 = true
10− g n = f (n - 1)
11−
12− x = f 1
13− in not x
14−
15−main = Debug.Trace.print test
examples/passing/LetInInstance.pursdeleted−12
@@ -1,12 +0,0 @@
1−module Main where
2−
3−class Foo a where
4− foo :: a -> String
5−
6−instance fooString :: Foo String where
7− foo = go
8− where
9− go :: String -> String
10− go s = s
11−
12−main = Debug.Trace.trace "Done"
examples/passing/LiberalTypeSynonyms.pursdeleted−19
@@ -1,19 +0,0 @@
1−module Main where
2−
3−type Reader = (->) String
4−
5−foo :: Reader String
6−foo s = s
7−
8−type AndFoo r = (foo :: String | r)
9−
10−getFoo :: forall r. Prim.Object (AndFoo r) -> String
11−getFoo o = o.foo
12−
13−type F r = { | r } -> { | r }
14−
15−f :: (forall r. F r) -> String
16−f g = case g { x: "Hello" } of
17− { x = x } -> x
18−
19−main = Debug.Trace.trace "Done"
examples/passing/MPTCs.pursdeleted−20
@@ -1,20 +0,0 @@
1−module Main where
2−
3−import Prelude
4−
5−class NullaryTypeClass where
6− greeting :: String
7−
8−instance nullaryTypeClass :: NullaryTypeClass where
9− greeting = "Hello, World!"
10−
11−class Coerce a b where
12− coerce :: a -> b
13−
14−instance coerceRefl :: Coerce a a where
15− coerce a = a
16−
17−instance coerceShow :: (Prelude.Show a) => Coerce a String where
18− coerce = show
19−
20−main = Debug.Trace.trace "Done"
examples/passing/Match.pursdeleted−7
@@ -1,7 +0,0 @@
1−module Main where
2−
3− data Foo a = Foo
4−
5− foo = \f -> case f of Foo -> "foo"
6−
7− main = Debug.Trace.trace "Done"
examples/passing/Monad.pursdeleted−32
@@ -1,32 +0,0 @@
1−module Main where
2−
3− import Prelude ()
4−
5− type Monad m = { return :: forall a. a -> m a
6− , bind :: forall a b. m a -> (a -> m b) -> m b }
7−
8− data Id a = Id a
9−
10− id :: Monad Id
11− id = { return : Id
12− , bind : \ma f -> case ma of Id a -> f a }
13−
14− data Maybe a = Nothing | Just a
15−
16− maybe :: Monad Maybe
17− maybe = { return : Just
18− , bind : \ma f -> case ma of
19− Nothing -> Nothing
20− Just a -> f a
21− }
22−
23− test :: forall m. Monad m -> m Number
24− test = \m -> m.bind (m.return 1) (\n1 ->
25− m.bind (m.return "Test") (\n2 ->
26− m.return n1))
27−
28− test1 = test id
29−
30− test2 = test maybe
31−
32− main = Debug.Trace.trace "Done"
examples/passing/MonadState.pursdeleted−48
@@ -1,48 +0,0 @@
1−module Main where
2−
3−import Prelude
4−
5−data Tuple a b = Tuple a b
6−
7−class MonadState s m where
8− get :: m s
9− put :: s -> m {}
10−
11−data State s a = State (s -> Tuple s a)
12−
13−runState s (State f) = f s
14−
15−instance functorState :: Functor (State s) where
16− (<$>) = liftM1
17−
18−instance applyState :: Apply (State s) where
19− (<*>) = ap
20−
21−instance applicativeState :: Applicative (State s) where
22− pure a = State $ \s -> Tuple s a
23−
24−instance bindState :: Bind (State s) where
25− (>>=) f g = State $ \s -> case runState s f of
26− Tuple s1 a -> runState s1 (g a)
27−
28−instance monadState :: Monad (State s)
29−
30−instance monadStateState :: MonadState s (State s) where
31− get = State (\s -> Tuple s s)
32− put s = State (\_ -> Tuple s {})
33−
34−modify :: forall m s. (Prelude.Monad m, MonadState s m) => (s -> s) -> m {}
35−modify f = do
36− s <- get
37− put (f s)
38−
39−test :: Tuple String String
40−test = runState "" $ do
41− modify $ (++) "World!"
42− modify $ (++) "Hello, "
43− get
44−
45−main = do
46− let t1 = test
47− Debug.Trace.trace "Done"
48−
examples/passing/MultiArgFunctions.pursdeleted−26
@@ -1,26 +0,0 @@
1−module Main where
2−
3−import Data.Function
4−import Control.Monad.Eff
5−import Debug.Trace
6−
7−f = mkFn2 $ \a b -> runFn2 g a b + runFn2 g b a
8−
9−g = mkFn2 $ \a b -> case {} of
10− _ | a <= 0 || b <= 0 -> b
11− _ -> runFn2 f (a - 1) (b - 1)
12−
13−main = do
14− runFn0 (mkFn0 $ \_ -> trace $ show 0)
15− runFn1 (mkFn1 $ \a -> trace $ show a) 1
16− runFn2 (mkFn2 $ \a b -> trace $ show [a, b]) 1 2
17− runFn3 (mkFn3 $ \a b c -> trace $ show [a, b, c]) 1 2 3
18− runFn4 (mkFn4 $ \a b c d -> trace $ show [a, b, c, d]) 1 2 3 4
19− runFn5 (mkFn5 $ \a b c d e -> trace $ show [a, b, c, d, e]) 1 2 3 4 5
20− runFn6 (mkFn6 $ \a b c d e f -> trace $ show [a, b, c, d, e, f]) 1 2 3 4 5 6
21− runFn7 (mkFn7 $ \a b c d e f g -> trace $ show [a, b, c, d, e, f, g]) 1 2 3 4 5 6 7
22− runFn8 (mkFn8 $ \a b c d e f g h -> trace $ show [a, b, c, d, e, f, g, h]) 1 2 3 4 5 6 7 8
23− runFn9 (mkFn9 $ \a b c d e f g h i -> trace $ show [a, b, c, d, e, f, g, h, i]) 1 2 3 4 5 6 7 8 9
24− runFn10 (mkFn10 $ \a b c d e f g h i j-> trace $ show [a, b, c, d, e, f, g, h, i, j]) 1 2 3 4 5 6 7 8 9 10
25− print $ runFn2 g 15 12
26− trace "Done!"
examples/passing/MultipleConstructorArgs.pursdeleted−21
@@ -1,21 +0,0 @@
1−module Main where
2−
3−import Prelude
4−import Control.Monad.Eff
5−
6−data P a b = P a b
7−
8−runP :: forall a b r. (a -> b -> r) -> P a b -> r
9−runP f (P a b) = f a b
10−
11−idP = runP P
12−
13−testCase = \p -> case p of
14− P (x:xs) (y:ys) -> x + y
15− P _ _ -> 0
16−
17−test1 = testCase (P [1, 2, 3] [4, 5, 6])
18−
19−main = do
20− Debug.Trace.trace (runP (\s n -> s ++ show n) (P "Test" 1))
21− Debug.Trace.print test1
examples/passing/MutRec.pursdeleted−19
@@ -1,19 +0,0 @@
1−module Main where
2−
3− import Prelude
4−
5− f 0 = 0
6− f x = g x + 1
7−
8− g x = f (x / 2)
9−
10− data Even = Zero | Even Odd
11−
12− data Odd = Odd Even
13−
14− evenToNumber Zero = 0
15− evenToNumber (Even n) = oddToNumber n + 1
16−
17− oddToNumber (Odd n) = evenToNumber n + 1
18−
19− main = Debug.Trace.trace "Done"
examples/passing/MutRec2.pursdeleted−17
@@ -1,17 +0,0 @@
1−module Main where
2−
3−data A = A B
4−
5−data B = B A
6−
7−foreign import data S :: *
8−
9−f :: A -> S
10−f a = case a of A b -> g b
11−
12−g b = case b of B a -> f a
13−
14−showN :: A -> S
15−showN a = f a
16−
17−main = Debug.Trace.trace "Done"
examples/passing/MutRec3.pursdeleted−17
@@ -1,17 +0,0 @@
1−module Main where
2−
3−data A = A B
4−
5−data B = B A
6−
7−foreign import data S :: *
8−
9−f a = case a of A b -> g b
10−
11−g :: B -> S
12−g b = case b of B a -> f a
13−
14−showN :: A -> S
15−showN a = f a
16−
17−main = Debug.Trace.trace "Done"
examples/passing/NamedPatterns.pursdeleted−7
@@ -1,7 +0,0 @@
1−module Main where
2−
3− foo = \x -> case x of
4− y@{ foo = "Foo" } -> y
5− y -> y
6−
7− main = Debug.Trace.trace "Done"
examples/passing/NegativeBinder.pursdeleted−7
@@ -1,7 +0,0 @@
1−module Main where
2−
3−test :: Number -> Boolean
4−test -1 = false
5−test _ = true
6−
7−main = Debug.Trace.trace "Done"
examples/passing/Nested.pursdeleted−7
@@ -1,7 +0,0 @@
1−module Main where
2−
3− data Extend r a = Extend { prev :: r a, next :: a }
4−
5− data Matrix r a = Square (r (r a)) | Bigger (Matrix (Extend r) a)
6−
7− main = Debug.Trace.trace "Done"
examples/passing/NestedTypeSynonyms.pursdeleted−11
@@ -1,11 +0,0 @@
1−module Main where
2−
3− import Prelude
4−
5− type X = String
6− type Y = X -> X
7−
8− fn :: Y
9− fn a = a
10−
11− main = Debug.Trace.print (fn "Done")
examples/passing/NestedWhere.pursdeleted−10
@@ -1,10 +0,0 @@
1−module Main where
2−
3−f x = g x
4− where
5− g x = go x
6− where
7− go x = go1 (x - 1)
8− go1 x = go x
9−
10−main = Debug.Trace.trace "Done"
examples/passing/Newtype.pursdeleted−22
@@ -1,22 +0,0 @@
1−module Main where
2−
3−import Control.Monad.Eff
4−import Debug.Trace
5−
6−newtype Thing = Thing String
7−
8−instance showThing :: Show Thing where
9− show (Thing x) = "Thing " ++ show x
10−
11−newtype Box a = Box a
12−
13−instance showBox :: (Show a) => Show (Box a) where
14− show (Box x) = "Box " ++ show x
15−
16−apply f x = f x
17−
18−main = do
19− print $ Thing "hello"
20− print $ Box 42
21− print $ apply Box 9000
22− trace "Done"
examples/passing/NewtypeEff.pursdeleted−28
@@ -1,28 +0,0 @@
1−module Main where
2−
3−import Debug.Trace
4−import Control.Monad.Eff
5−
6−newtype T a = T (Eff (trace :: Trace) a)
7−
8−runT :: forall a. T a -> Eff (trace :: Trace) a
9−runT (T t) = t
10−
11−instance functorT :: Functor T where
12− (<$>) f (T t) = T (f <$> t)
13−
14−instance applyT :: Apply T where
15− (<*>) (T f) (T x) = T (f <*> x)
16−
17−instance applicativeT :: Applicative T where
18− pure t = T (pure t)
19−
20−instance bindT :: Bind T where
21− (>>=) (T t) f = T (t >>= \x -> runT (f x))
22−
23−instance monadT :: Monad T
24−
25−main = runT do
26− T $ trace "Done"
27− T $ trace "Done"
28− T $ trace "Done"
examples/passing/NewtypeWithRecordUpdate.pursdeleted−15
@@ -1,15 +0,0 @@
1−-- https://github.com/purescript/purescript/issues/812
2−
3−module Main where
4−
5−import Debug.Trace
6−
7−newtype NewType a = NewType (Object a)
8−
9−rec1 :: Object (a :: Number, b :: Number, c:: Number)
10−rec1 = { a: 0, b: 0, c: 0 }
11−
12−rec2 :: NewType (a :: Number, b :: Number, c :: Number)
13−rec2 = NewType (rec1 { a = 1 })
14−
15−main = trace "Done"
examples/passing/ObjectGetter.pursdeleted−11
@@ -1,11 +0,0 @@
1−module Main where
2−
3−getX = _.x
4−
5−point = { x: 1, y: 0 }
6−
7−main = do
8− Debug.Trace.print $ getX point
9− Debug.Trace.trace $ _." 123 string Prop Name " { " 123 string Prop Name ": "OK" }
10− Debug.Trace.trace $ (_.x >>> _.y) { x: { y: "Nested" } }
11− Debug.Trace.trace $ _.value { value: "Done!" }
examples/passing/ObjectSynonym.pursdeleted−13
@@ -1,13 +0,0 @@
1−module Main where
2−
3−type Inner = Number
4−
5−inner :: Inner
6−inner = 0
7−
8−type Outer = { inner :: Inner }
9−
10−outer :: Outer
11−outer = { inner: inner }
12−
13−main = Debug.Trace.trace "Done"
examples/passing/ObjectUpdate.pursdeleted−18
@@ -1,18 +0,0 @@
1−module Main where
2−
3− update1 = \o -> o { foo = "Foo" }
4−
5− update2 :: forall r. { foo :: String | r } -> { foo :: String | r }
6− update2 = \o -> o { foo = "Foo" }
7−
8− replace = \o -> case o of
9− { foo = "Foo" } -> o { foo = "Bar" }
10− { foo = "Bar" } -> o { bar = "Baz" }
11− o -> o
12−
13− polyUpdate :: forall a r. { foo :: a | r } -> { foo :: String | r }
14− polyUpdate = \o -> o { foo = "Foo" }
15−
16− inferPolyUpdate = \o -> o { foo = "Foo" }
17−
18− main = Debug.Trace.trace ((update1 {foo: ""}).foo)
examples/passing/ObjectUpdate2.pursdeleted−14
@@ -1,14 +0,0 @@
1−module Main where
2−
3−type X r = { | r }
4−
5−foreign import x "var x = {};" :: forall r. X r
6−
7−blah :: forall r. X r -> X r
8−blah x = x
9−
10−test = blah x
11− { baz = "blah"
12− }
13−
14−main = Debug.Trace.trace "Done"
examples/passing/ObjectUpdater.pursdeleted−35
@@ -1,35 +0,0 @@
1−module Main where
2−
3−import Control.Monad.Eff
4−import Debug.Trace
5−
6−foreign import eqeqeq
7− """
8− function eqeqeq(x) {
9− return function (y) {
10− if (x == y) return x;
11− throw new Error("Unexpected result: " + x + " /== " + y);
12− };
13− };
14− """ :: forall a. a -> a -> a
15−
16−(===) = eqeqeq
17−infixl 4 ===
18−
19−getValue :: forall e. Eff (| e) Boolean
20−getValue = return true
21−
22−main = do
23− let record = { value: false }
24− record' <- record { value = _ } <$> getValue
25− print $ record'.value === true
26−
27− let point = { x: 1, y: 1 }
28− x = 10
29− point' = (point { x = _, y = x }) 100
30−
31− print $ point'.x === 100
32− print $ point'.y === 10
33−
34− let record2 = (_ { x = _ }) { x: 0 } 10
35− print $ record2.x === 10
examples/passing/ObjectWildcards.pursdeleted−31
@@ -1,31 +0,0 @@
1−module Main where
2−
3−import Control.Monad.Eff
4−import Debug.Trace
5−
6−mkRecord = { foo: _, bar: _, baz: "baz" }
7−
8−getValue :: forall e. Eff (| e) Boolean
9−getValue = return true
10−
11−foreign import eqeqeq
12− """
13− function eqeqeq(x) {
14− return function (y) {
15− if (x == y) return x;
16− throw new Error("Unexpected result: " + x + " /== " + y);
17− };
18− };
19− """ :: forall a. a -> a -> a
20−
21−(===) = eqeqeq
22−infixl 4 ===
23−
24−main = do
25− obj <- { value: _ } <$> getValue
26− print obj.value
27− let x = 1
28− point <- { x: _, y: x } <$> return 2
29− print $ point.x === 2
30− print $ point.y === 1
31− trace (mkRecord 1 "Done!").bar
examples/passing/Objects.pursdeleted−35
@@ -1,35 +0,0 @@
1−module Main where
2−
3− import Prelude
4−
5− test = \x -> x.foo + x.bar + 1
6−
7− append = \o -> { foo: o.foo, bar: 1 }
8−
9− apTest = append({foo : "Foo", baz: "Baz"})
10−
11− f = (\a -> a.b.c) { b: { c: 1, d: "Hello" }, e: "World" }
12−
13− g = (\a -> a.f { x: 1, y: "y" }) { f: \o -> o.x + 1 }
14−
15− typed :: { foo :: Number }
16− typed = { foo: 0 }
17−
18− test2 = \x -> x."!@#"
19−
20− test3 = typed."foo"
21−
22− test4 = test2 weirdObj
23− where
24− weirdObj :: { "!@#" :: Number }
25− weirdObj = { "!@#": 1 }
26−
27− test5 = case { "***": 1 } of
28− { "***" = n } -> n
29−
30− test6 = case { "***": 1 } of
31− { "***": n } -> n
32−
33− test7 {a: snoog , b : blah } = blah
34−
35− main = Debug.Trace.trace "Done"
examples/passing/OneConstructor.pursdeleted−7
@@ -1,7 +0,0 @@
1−module Main where
2−
3−data One a = One a
4−
5−one' (One a) = a
6−
7−main = Debug.Trace.trace "Done"
examples/passing/OperatorAssociativity.pursdeleted−50
@@ -1,50 +0,0 @@
1−module Main where
2−
3−import Control.Monad.Eff
4−import Debug.Trace
5−
6−foreign import data Assert :: !
7−
8−foreign import assert
9− """
10− function assert(x) {
11− return function(desc) {
12− return function() {
13− if (!x) throw new Error('assertion (' + desc + ') failed');
14− return {};
15− };
16− };
17− }
18− """ :: forall e. Boolean -> String -> Eff (assert :: Assert | e) Unit
19−
20−bug :: Number -> Number -> Number
21−bug a b = 0 - (a - b)
22−
23−foreign import explode
24− """
25− function explode() {
26− throw new Error('Assertion failed!');
27− }
28− """ :: forall eff a. Eff eff a
29−
30−main = do
31− assert (bug 0 2 == 2) "bug 0 2 == 2"
32− assert (0 - (0 - 2) == 2) "0 - (0 - 2) == 2"
33− assert (0 - (0 + 2) == -2) "0 - (0 + 2) == -2"
34−
35− assert (6 / (3 * 2) == 1) "6 / (3 * 2) == 1"
36− assert ((6 / 3) * 2 == 4) "(6 / 3) * 2 == 4"
37−
38− assert (not (1 < 0) == true) "not (1 < 0) == true"
39− assert (not ((negate 1) < 0) == false) "not ((negate 1) < 0) == false"
40−
41− assert (negate (1 + 10) == -11) "negate (1 + 10) == -11"
42−
43− assert (2 * 3 / 4 == 1.5) "2 * 3 / 4 == 1.5"
44− assert (1 * 2 * 3 * 4 * 5 / 6 == 20) "1 * 2 * 3 * 4 * 5 / 6 == 20"
45−
46− assert (1 + 10 - 5 == 6) "1 + 10 - 5 == 6"
47− assert (1 + 10 * 5 == 51) "1 + 10 * 5 == 51"
48− assert (10 * 5 - 1 == 49) "10 * 5 - 1 == 49"
49−
50− trace "Success!"
examples/passing/OperatorInlining.pursdeleted−46
@@ -1,46 +0,0 @@
1−module Main where
2−
3−import Debug.Trace
4−
5−main = do
6−
7− -- semiringNumber
8− print (1 + 2)
9− print (1 * 2)
10−
11− -- ringNumber
12− print (1 - 2)
13− print (negate 1)
14−
15− -- moduleSemiringNumber
16− print (1 / 2)
17−
18− -- ordNumber
19− print (1 > 2)
20− print (1 < 2)
21− print (1 <= 2)
22− print (1 >= 2)
23− print (1 == 2)
24−
25− -- eqNumber
26− print (1 == 2)
27− print (1 /= 2)
28−
29− -- eqString
30− print ("foo" == "bar")
31− print ("foo" /= "bar")
32−
33− -- eqBoolean
34− print (true == false)
35− print (true /= false)
36−
37− -- semigroupString
38− print ("foo" ++ "bar")
39− print ("foo" <> "bar")
40−
41− -- latticeBoolean
42− print (top && true)
43− print (bottom || false)
44−
45− -- complementedLatticeBoolean
46− print (not true)
examples/passing/OperatorSections.pursdeleted−21
@@ -1,21 +0,0 @@
1−module Main where
2−
3−foreign import eqeqeq
4− """
5− function eqeqeq(x) {
6− return function (y) {
7− if (x == y) return x;
8− throw new Error("Unexpected result: " + x + " /== " + y);
9− };
10− };
11− """ :: forall a. a -> a -> a
12−
13−(===) = eqeqeq
14−infixl 4 ===
15−
16−main = do
17− Debug.Trace.print $ (/ 2) 4 === 2
18− Debug.Trace.print $ (2 /) 4 === 0.5
19− Debug.Trace.print $ (`const` 1) 2 === 2
20− Debug.Trace.print $ (1 `const`) 2 === 1
21− Debug.Trace.trace "Done!"
examples/passing/Operators.pursdeleted−98
@@ -1,98 +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− test17 :: Number
65− test17 = negate (-1)
66−
67− test18 :: Number
68− test18 = negate $ negate 1
69−
70− test19 :: Number
71− test19 = negate $ negate (-1)
72−
73− test20 :: Number
74− test20 = 1 @ 2
75− where
76− (@) x y = x + y * y
77−
78− main = do
79− let t1 = test1 1 2 (\x y -> x + y)
80− let t2 = test2
81− let t3 = test3
82− let t4 = test4
83− let t5 = test5
84− let t6 = test6
85− let t7 = test7
86− let t8 = test8
87− let t9 = test9
88− let t10 = test10
89− let t11 = test11
90− let t12 = test12 k 1 2
91− let t13 = test13 k 1 2
92− let t14 = test14 1 2
93− let t15 = test15 1 2
94− let t17 = test17
95− let t18 = test18
96− let t19 = test19
97− let t20 = test20
98− trace "Done"
examples/passing/OptimizerBug.pursdeleted−9
@@ -1,9 +0,0 @@
1−module Main where
2−
3−import Prelude
4−
5−x a = 1 + y a
6−
7−y a = x a
8−
9−main = Debug.Trace.trace "Done"
examples/passing/PartialFunction.pursdeleted−19
@@ -1,19 +0,0 @@
1−module Main where
2−
3−foreign import testError
4− """
5− function testError(f) {
6− try {
7− return f();
8− } catch (e) {
9− if (e instanceof Error) return 'success';
10− throw new Error('Pattern match failure is not Error');
11− }
12− }
13− """ :: (Unit -> Number) -> String
14−
15−fn :: Number -> Number
16−fn 0 = 0
17−fn 1 = 2
18−
19−main = Debug.Trace.trace (show $ testError $ \_ -> fn 2)
examples/passing/Patterns.pursdeleted−28
@@ -1,28 +0,0 @@
1−module Main where
2−
3− import Prelude
4−
5− test = \x -> case x of
6− { str = "Foo", bool = true } -> true
7− { str = "Bar", bool = b } -> b
8− _ -> false
9−
10− f = \o -> case o of
11− { foo = "Foo" } -> o.bar
12− _ -> 0
13−
14− g = \o -> case o of
15− { arr = [x : xs], take = "car" } -> x
16− { arr = [_, x : xs], take = "cadr" } -> x
17− _ -> 0
18−
19−
20− h = \o -> case o of
21− a@[_,_,_] -> a
22− _ -> []
23−
24− isDesc :: [Number] -> Boolean
25− isDesc [x, y] | x > y = true
26− isDesc _ = false
27−
28− main = Debug.Trace.trace "Done"
examples/passing/Person.pursdeleted−18
@@ -1,18 +0,0 @@
1−module Main where
2−
3− import Prelude ((++))
4−
5− data Person = Person { name :: String, age :: Number }
6−
7− foreign import itoa
8− """
9− function itoa(n) {
10− return n.toString();
11− }
12− """ :: Number -> String
13−
14− showPerson :: Person -> String
15− showPerson = \p -> case p of
16− Person o -> o.name ++ ", aged " ++ itoa(o.age)
17−
18− main = Debug.Trace.trace "Done"
examples/passing/Rank2Data.pursdeleted−29
@@ -1,29 +0,0 @@
1−module Main where
2−
3− import Prelude
4−
5− data Id = Id forall a. a -> a
6−
7− runId = \id a -> case id of
8− Id f -> f a
9−
10− data Nat = Nat forall r. r -> (r -> r) -> r
11−
12− runNat = \nat -> case nat of
13− Nat f -> f 0 (\n -> n + 1)
14−
15− zero' = Nat (\zero' _ -> zero')
16−
17− succ = \n -> case n of
18− Nat f -> Nat (\zero' succ -> succ (f zero' succ))
19−
20− add = \n m -> case n of
21− Nat f -> case m of
22− Nat g -> Nat (\zero' succ -> g (f zero' succ) succ)
23−
24− one' = succ zero'
25− two = succ zero'
26− four = add two two
27− fourNumber = runNat four
28−
29− main = Debug.Trace.trace "Done'"
examples/passing/Rank2Object.pursdeleted−10
@@ -1,10 +0,0 @@
1−module Main where
2−
3−import Debug.Trace
4−
5−data Foo = Foo { id :: forall a. a -> a }
6−
7−foo :: Foo -> Number
8−foo (Foo { id = f }) = f 0
9−
10−main = trace "Done"
examples/passing/Rank2TypeSynonym.pursdeleted−15
@@ -1,15 +0,0 @@
1−module Main where
2−
3−import Control.Monad.Eff
4−
5−type Foo a = forall f. (Monad f) => f a
6−
7−foo :: forall a. a -> Foo a
8−foo x = pure x
9−
10−bar :: Foo Number
11−bar = foo 3
12−
13−main = do
14− x <- bar
15− Debug.Trace.print x
examples/passing/Rank2Types.pursdeleted−11
@@ -1,11 +0,0 @@
1−module Main where
2−
3− import Prelude
4−
5− test1 :: (forall a. (a -> a)) -> Number
6− test1 = \f -> f 0
7−
8− forever :: forall m a b. (forall a b. m a -> (a -> m b) -> m b) -> m a -> m b
9− forever = \bind action -> bind action $ \_ -> forever bind action
10−
11− main = Debug.Trace.trace "Done"
examples/passing/RebindableSyntax.pursdeleted−37
@@ -1,37 +0,0 @@
1−module Main where
2−
3−example1 :: String
4−example1 = do
5− "Do"
6− " notation"
7− " for"
8− " Semigroup"
9− where
10− (>>=) x f = x <> f unit
11−
12−(*>) :: forall f a b. (Apply f) => f a -> f b -> f b
13−(*>) fa fb = const id <$> fa <*> fb
14−
15−newtype Const a b = Const a
16−
17−runConst :: forall a b. Const a b -> a
18−runConst (Const a) = a
19−
20−instance functorConst :: Functor (Const a) where
21− (<$>) _ (Const a) = Const a
22−
23−instance applyConst :: (Semigroup a) => Apply (Const a) where
24− (<*>) (Const a1) (Const a2) = Const (a1 <> a2)
25−
26−example2 :: Const String Unit
27−example2 = do
28− Const "Do"
29− Const " notation"
30− Const " for"
31− Const " Apply"
32− where
33− (>>=) x f = x *> f unit
34−
35−main = do
36− Debug.Trace.trace example1
37− Debug.Trace.trace $ runConst example2
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/RowConstructors.pursdeleted−40
@@ -1,40 +0,0 @@
1−module Main where
2−
3−type Foo = (x :: Number | (y :: Number | (z :: Number)))
4−type Bar = (x :: Number, y :: Number, z :: Number)
5−type Baz = { w :: Number | Bar }
6−
7−foo :: { | Foo }
8−foo = { x: 0, y: 0, z: 0 }
9−
10−bar :: { | Bar }
11−bar = { x: 0, y: 0, z: 0 }
12−
13−id' :: Object Foo -> Object Bar
14−id' = id
15−
16−foo' :: { | Foo }
17−foo' = id' foo
18−
19−bar' :: { | Bar }
20−bar' = id' bar
21−
22−baz :: Baz
23−baz = { x: 0, y: 0, z: 0, w: 0 }
24−
25−type Quux r = (q :: Number | r)
26−type Norf r = (q' :: Number | Quux r)
27−
28−quux :: { f :: { | Foo } | Quux Bar }
29−quux = { f: foo', x: 0, y: 0, z: 0, q: 0 }
30−
31−quux' :: { | Norf Bar }
32−quux' = { x: 0, y: 0, z: 0, q: 0, q': 0 }
33−
34−wildcard :: { w :: Number | _ } -> Baz
35−wildcard { w: w } = { x: w, y: w, z: w, w: w }
36−
37−wildcard' :: { | Quux _ } -> Number
38−wildcard' { q: q } = q
39−
40−main = Debug.Trace.trace "Done"
examples/passing/RowPolyInstanceContext.pursdeleted−20
@@ -1,20 +0,0 @@
1−module Main where
2−
3−class T s m where
4− state :: (s -> s) -> m Unit
5−
6−data S s a = S (s -> { new :: s, ret :: a })
7−
8−instance st :: T s (S s) where
9− state f = S $ \s -> { new: f s, ret: unit }
10−
11−test1 :: forall r . S { foo :: String | r } Unit
12−test1 = state $ \o -> o { foo = o.foo ++ "!" }
13−
14−test2 :: forall m r . (T { foo :: String | r } m) => m Unit
15−test2 = state $ \o -> o { foo = o.foo ++ "!" }
16−
17−main = do
18− let t1 = test1
19− let t2 = test2
20− Debug.Trace.trace "Done"
examples/passing/RowSynonyms.pursdeleted−46
@@ -1,46 +0,0 @@
1−module Main where
2−
3−import Control.Monad.Eff
4−import Control.Monad.ST
5−
6−type State bindings =
7− {
8− bindings :: {addition :: Number | bindings},
9− other :: String
10− }
11−
12−type MyBindings = (test :: Number)
13−
14−data Shadow bindings = Shadow String
15−
16−shadows :: Shadow (Object MyBindings)
17−shadows = Shadow "uhh"
18−
19−main :: Eff () Unit
20−main = withIt
21− shadows
22− \ bindings -> do
23− let state =
24− {
25− bindings : bindings,
26− other : "Test"
27− }
28− runST do
29− stRef <- newSTRef state
30− handleKeyD stRef
31− return unit
32−
33−
34−withIt :: forall bindings eff a. Shadow (Object bindings) ->
35− ({addition :: Number | bindings} -> Eff eff a) -> Eff eff a
36−withIt (Shadow str) success = do
37− b <- withBindings
38− success (b{addition = 1})
39−
40−foreign import withBindings
41−"""
42− function withBindings() {}
43−""" :: forall eff bindings. Eff eff bindings
44−
45−handleKeyD :: forall h eff. STRef h (State MyBindings) -> Eff (st :: ST h | eff) Unit
46−handleKeyD state = return unit
examples/passing/RuntimeScopeIssue.pursdeleted−19
@@ -1,19 +0,0 @@
1−module Main where
2−
3−import Prelude
4−
5−class A a where
6− a :: a -> Boolean
7−
8−class B a where
9− b :: a -> Boolean
10−
11−instance aNumber :: A Number where
12− a 0 = true
13− a n = b (n - 1)
14−
15−instance bNumber :: B Number where
16− b 0 = false
17− b n = a (n - 1)
18−
19−main = Debug.Trace.print $ a 10
examples/passing/ScopedTypeVariables.pursdeleted−34
@@ -1,34 +0,0 @@
1−module Main where
2−
3−test1 :: forall a. (a -> a) -> a -> a
4−test1 f x = g (g x)
5− where
6− g :: a -> a
7− g y = f (f y)
8−
9−test2 :: forall a. (a -> a) -> a -> a
10−test2 = h
11− where
12− h :: forall b. (b -> b) -> b -> b
13− h f x = g (g x)
14− where
15− g :: b -> b
16− g y = f (f y)
17−
18−test3 :: Number
19−test3 = ((\b -> b :: b) :: forall b. b -> b) 0
20−
21−test4 :: forall a. (a -> a) -> a -> a
22−test4 = h
23− where
24− h :: forall b. (b -> b) -> b -> b
25− h f x = g (g x)
26− where
27− g :: b -> b
28− g y = j (f (f y))
29− where
30− j :: forall b. b -> b
31− j x = x
32−
33−
34−main = Debug.Trace.trace "Done"
examples/passing/Sequence.pursdeleted−12
@@ -1,12 +0,0 @@
1−module Main where
2−
3−import Control.Monad.Eff
4−
5−class Sequence t where
6− sequence :: forall m a. (Monad m) => t (m a) -> m (t a)
7−
8−instance sequenceArray :: Sequence [] where
9− sequence [] = pure []
10− sequence (x:xs) = (:) <$> x <*> sequence xs
11−
12−main = sequence $ [Debug.Trace.trace "Done"]
examples/passing/SequenceDesugared.pursdeleted−34
@@ -1,34 +0,0 @@
1−module Main where
2−
3−import Control.Monad.Eff
4−
5−data Sequence t = Sequence (forall m a. (Monad m) => t (m a) -> m (t a))
6−
7−sequence :: forall t. Sequence t -> (forall m a. (Monad m) => t (m a) -> m (t a))
8−sequence (Sequence s) = s
9−
10−sequenceArraySeq :: forall m a. (Monad m) => Array (m a) -> m (Array a)
11−sequenceArraySeq [] = pure []
12−sequenceArraySeq (x:xs) = (:) <$> x <*> sequenceArraySeq xs
13−
14−sequenceArray :: Sequence []
15−sequenceArray = Sequence (sequenceArraySeq)
16−
17−sequenceArray' :: Sequence []
18−sequenceArray' = Sequence ((\val -> case val of
19− [] -> pure []
20− (x:xs) -> (:) <$> x <*> sequence sequenceArray' xs))
21−
22−sequenceArray'' :: Sequence []
23−sequenceArray'' = Sequence (sequenceArraySeq :: forall m a. (Monad m) => Array (m a) -> m (Array a))
24−
25−sequenceArray''' :: Sequence []
26−sequenceArray''' = Sequence ((\val -> case val of
27− [] -> pure []
28− (x:xs) -> (:) <$> x <*> sequence sequenceArray''' xs) :: forall m a. (Monad m) => Array (m a) -> m (Array a))
29−
30−main = do
31− sequence sequenceArray $ [Debug.Trace.trace "Done"]
32− sequence sequenceArray' $ [Debug.Trace.trace "Done"]
33− sequence sequenceArray'' $ [Debug.Trace.trace "Done"]
34− sequence sequenceArray''' $ [Debug.Trace.trace "Done"]
examples/passing/ShadowedRename.pursdeleted−21
@@ -1,21 +0,0 @@
1−module Main where
2−
3−import Control.Monad.Eff
4−import Debug.Trace
5−
6−foreign import f
7− """
8− function f(x) {
9− return function() {
10− if (x !== 2) throw new Error('x is not 2');
11− };
12− }
13− """ :: forall e. Number -> Eff e Number
14−
15−foo foo = let foo_1 = \_ -> foo
16− foo_2 = foo_1 unit + 1
17− in foo_2
18−
19−main = do
20− f (foo 1)
21− trace "Done"
examples/passing/ShadowedTCO.pursdeleted−16
@@ -1,16 +0,0 @@
1−module Main where
2−
3−runNat f = f 0 (\n -> n + 1)
4−
5−zero' z _ = z
6−
7−succ f zero' succ = succ (f zero' succ)
8−
9−add f g zero' succ = g (f zero' succ) succ
10−
11−one' = succ zero'
12−two = succ one'
13−four = add two two
14−fourNumber = runNat four
15−
16−main = Debug.Trace.trace $ show fourNumber
examples/passing/ShadowedTCOLet.pursdeleted−7
@@ -1,7 +0,0 @@
1−module Main where
2−
3−f x y z =
4− let f 1 2 3 = 1
5− in f x z y
6−
7−main = Debug.Trace.trace $ show $ f 1 3 2
examples/passing/SignedNumericLiterals.pursdeleted−15
@@ -1,15 +0,0 @@
1−module Main where
2−
3− p = 0.5
4− q = 1
5− x = -1
6− y = -0.5
7− z = 0.5
8− w = 1
9−
10− f :: Number -> Number
11− f x = -x
12−
13− test1 = 2 - 1
14−
15− main = Debug.Trace.trace "Done"
examples/passing/Superclasses1.pursdeleted−18
@@ -1,18 +0,0 @@
1−module Main where
2−
3−class Su a where
4− su :: a -> a
5−
6−class (Su a) <= Cl a where
7− cl :: a -> a -> a
8−
9−instance suNumber :: Su Number where
10− su n = n + 1
11−
12−instance clNumber :: Cl Number where
13− cl n m = n + m
14−
15−test :: forall a. (Cl a) => a -> a
16−test a = su (cl a a)
17−
18−main = Debug.Trace.print $ test 10
examples/passing/Superclasses2.pursdeleted−23
@@ -1,23 +0,0 @@
1−module Main where
2−
3−import Prelude.Unsafe (unsafeIndex)
4−
5−class Su a where
6− su :: a -> a
7−
8−class (Su [a]) <= Cl a where
9− cl :: a -> a -> a
10−
11−instance suNumber :: Su Number where
12− su n = n + 1
13−
14−instance suArray :: (Su a) => Su [a] where
15− su (x : _) = [su x]
16−
17−instance clNumber :: Cl Number where
18− cl n m = n + m
19−
20−test :: forall a. (Cl a) => a -> [a]
21−test x = su [cl x x]
22−
23−main = Debug.Trace.print $ test 10 `unsafeIndex` 0
examples/passing/Superclasses3.pursdeleted−41
@@ -1,41 +0,0 @@
1−module Main where
2−
3−import Debug.Trace
4−
5−import Control.Monad.Eff
6−
7−class (Monad m) <= MonadWriter w m where
8− tell :: w -> m Unit
9−
10−testFunctor :: forall m. (Monad m) => m Number -> m Number
11−testFunctor n = (+) 1 <$> n
12−
13−test :: forall w m. (Monad m, MonadWriter w m) => w -> m Unit
14−test w = do
15− tell w
16− tell w
17− tell w
18−
19−data MTrace a = MTrace (Eff (trace :: Trace) a)
20−
21−runMTrace :: forall a. MTrace a -> Eff (trace :: Trace) a
22−runMTrace (MTrace a) = a
23−
24−instance functorMTrace :: Functor MTrace where
25− (<$>) = liftM1
26−
27−instance applyMTrace :: Apply MTrace where
28− (<*>) = ap
29−
30−instance applicativeMTrace :: Applicative MTrace where
31− pure = MTrace <<< return
32−
33−instance bindMTrace :: Bind MTrace where
34− (>>=) m f = MTrace (runMTrace m >>= (runMTrace <<< f))
35−
36−instance monadMTrace :: Monad MTrace
37−
38−instance writerMTrace :: MonadWriter String MTrace where
39− tell s = MTrace (trace s)
40−
41−main = runMTrace $ test "Done"
examples/passing/TCOCase.pursdeleted−10
@@ -1,10 +0,0 @@
1−module Main where
2−
3−data Data = One | More Data
4−
5−main = Debug.Trace.trace (from (to 10000 One))
6− where
7− to 0 a = a
8− to n a = to (n - 1) (More a)
9− from One = "Done"
10− from (More d) = from d
examples/passing/TailCall.pursdeleted−15
@@ -1,15 +0,0 @@
1−module Main where
2−
3−import Prelude
4−
5−test :: Number -> [Number] -> Number
6−test n [] = n
7−test n (x:xs) = test (n + x) xs
8−
9−loop :: forall a. Number -> a
10−loop x = loop (x + 1)
11−
12−notATailCall = \x ->
13− (\notATailCall -> notATailCall x) (\x -> x)
14−
15−main = Debug.Trace.print (test 0 [1, 2, 3])
examples/passing/Tick.pursdeleted−5
@@ -1,5 +0,0 @@
1−module Main where
2−
3−test' x = x
4−
5−main = Debug.Trace.trace "Done"
examples/passing/TopLevelCase.pursdeleted−28
@@ -1,28 +0,0 @@
1−module Main where
2−
3−foreign import jsMod
4− """
5− function jsMod(x) {
6− return function (y) {
7− return x % y;
8− };
9− }
10− """ :: Number -> Number -> Number
11−
12−infixl 7 %
13−(%) = jsMod
14−
15−gcd :: Number -> Number -> Number
16−gcd 0 x = x
17−gcd x 0 = x
18−gcd x y | x > y = gcd (x % y) y
19−gcd x y = gcd (y % x) x
20−
21−guardsTest (x:xs) | x > 0 = guardsTest xs
22−guardsTest xs = xs
23−
24−data A = A
25−
26−parseTest A 0 = 0
27−
28−main = Debug.Trace.trace "Done"
examples/passing/TypeClassImport.pursdeleted−18
@@ -1,18 +0,0 @@
1−module Main where
2−
3−foreign import data T :: *
4−
5−foreign import data C :: *
6−
7−foreign import t "var t = null;" :: T
8−
9−foreign import inst """
10− var inst = {
11− show: function(t) {
12− return 'Done';
13− }
14− }""" :: C
15−
16−foreign import instance inst :: Show T
17−
18−main = Debug.Trace.print t
examples/passing/TypeClassMemberOrderChange.pursdeleted−11
@@ -1,11 +0,0 @@
1−module Main where
2−
3−class Test a where
4− fn :: a -> a -> a
5− val :: a
6−
7−instance testBoolean :: Test Boolean where
8− val = true
9− fn x y = y
10−
11−main = Debug.Trace.trace (show (fn true val))
examples/passing/TypeClasses.pursdeleted−69
@@ -1,69 +0,0 @@
1−module Main where
2−
3−import Prelude
4−
5−test1 = \_ -> show "testing"
6−
7−f :: forall a. (Prelude.Show a) => a -> String
8−f x = show x
9−
10−test2 = \_ -> f "testing"
11−
12−test7 :: forall a. (Prelude.Show a) => a -> String
13−test7 = show
14−
15−test8 = \_ -> show $ "testing"
16−
17−data Data a = Data a
18−
19−instance showData :: (Prelude.Show a) => Prelude.Show (Data a) where
20− show (Data a) = "Data (" ++ show a ++ ")"
21−
22−test3 = \_ -> show (Data "testing")
23−
24−instance functorData :: Functor Data where
25− (<$>) = liftM1
26−
27−instance applyData :: Apply Data where
28− (<*>) = ap
29−
30−instance applicativeData :: Applicative Data where
31− pure = Data
32−
33−instance bindData :: Bind Data where
34− (>>=) (Data a) f = f a
35−
36−instance monadData :: Monad Data
37−
38−data Maybe a = Nothing | Just a
39−
40−instance functorMaybe :: Functor Maybe where
41− (<$>) = liftM1
42−
43−instance applyMaybe :: Apply Maybe where
44− (<*>) = ap
45−
46−instance applicativeMaybe :: Applicative Maybe where
47− pure = Just
48−
49−instance bindMaybe :: Bind Maybe where
50− (>>=) Nothing _ = Nothing
51− (>>=) (Just a) f = f a
52−
53−instance monadMaybe :: Monad Maybe
54−
55−test4 :: forall a m. (Monad m) => a -> m Number
56−test4 = \_ -> return 1
57−
58−test5 = \_ -> Just 1 >>= \n -> return (n + 1)
59−
60−ask r = r
61−
62−runReader r f = f r
63−
64−test9 _ = runReader 0 $ do
65− n <- ask
66− return $ n + 1
67−
68−main = Debug.Trace.trace (test7 "Done")
69−
examples/passing/TypeClassesInOrder.pursdeleted−11
@@ -1,11 +0,0 @@
1−module Main where
2−
3−import Prelude
4−
5−class Foo a where
6− foo :: a -> String
7−
8−instance fooString :: Foo String where
9− foo s = s
10−
11−main = Debug.Trace.trace $ foo "Done"
examples/passing/TypeClassesWithOverlappingTypeVariables.pursdeleted−11
@@ -1,11 +0,0 @@
1−module Main where
2−
3− import Prelude
4−
5− data Either a b = Left a | Right b
6−
7− instance functorEither :: Prelude.Functor (Either a) where
8− (<$>) _ (Left x) = Left x
9− (<$>) f (Right y) = Right (f y)
10−
11− main = Debug.Trace.trace "Done"
examples/passing/TypeDecl.pursdeleted−12
@@ -1,12 +0,0 @@
1−module Main where
2−
3− import Prelude
4−
5− k :: String -> Number -> String
6− k x y = x
7−
8− iterate :: forall a. Number -> (a -> a) -> a -> a
9− iterate 0 f a = a
10− iterate n f a = iterate (n - 1) f (f a)
11−
12− main = Debug.Trace.trace "Done"
examples/passing/TypeSynonymInData.pursdeleted−9
@@ -1,9 +0,0 @@
1−module Main where
2−
3−type A a = [a]
4−
5−data Foo a = Foo (A a) | Bar
6−
7−foo (Foo []) = Bar
8−
9−main = Debug.Trace.trace "Done"
examples/passing/TypeSynonyms.pursdeleted−25
@@ -1,25 +0,0 @@
1−module Main where
2−
3− type Lens a b =
4− { get :: a -> b
5− , set :: a -> b -> a
6− }
7−
8− composeLenses :: forall a b c. Lens a b -> Lens b c -> Lens a c
9− composeLenses = \l1 -> \l2 ->
10− { get: \a -> l2.get (l1.get a)
11− , set: \a c -> l1.set a (l2.set (l1.get a) c)
12− }
13−
14− type Pair a b = { fst :: a, snd :: b }
15−
16− fst :: forall a b. Lens (Pair a b) a
17− fst =
18− { get: \p -> p.fst
19− , set: \p a -> { fst: a, snd: p.snd }
20− }
21−
22− test1 :: forall a b c. Lens (Pair (Pair a b) c) a
23− test1 = composeLenses fst fst
24−
25− main = Debug.Trace.trace "Done"
examples/passing/TypeWildcards.pursdeleted−13
@@ -1,13 +0,0 @@
1−module Main where
2−
3−testTopLevel :: _ -> _
4−testTopLevel n = n + 1
5−
6−test :: forall a. (Eq a) => (a -> a) -> a -> a
7−test f a = go (f a) a
8− where
9− go :: _ -> _ -> _
10− go a1 a2 | a1 == a2 = a1
11− go a1 _ = go (f a1) a1
12−
13−main = Debug.Trace.trace "Done"
examples/passing/TypeWildcardsRecordExtension.pursdeleted−6
@@ -1,6 +0,0 @@
1−module Main where
2−
3−foo :: forall a. {b :: Number | a} -> {b :: Number | _}
4−foo f = f
5−
6−main = Debug.Trace.trace "Done"
examples/passing/TypedWhere.pursdeleted−13
@@ -1,13 +0,0 @@
1−module Main where
2−
3−data E a b = L a | R b
4−
5−lefts :: forall a b. [E a b] -> [a]
6−lefts = go []
7− where
8− go :: forall a b. [a] -> [E a b] -> [a]
9− go ls [] = ls
10− go ls (L a : rest) = go (a : ls) rest
11− go ls (_ : rest) = go ls rest
12−
13−main = Debug.Trace.trace "Done"
examples/passing/UnderscoreIdent.pursdeleted−9
@@ -1,9 +0,0 @@
1−module Main where
2−
3−data Data_type = Con_Structor | Con_2 String
4−
5−type Type_name = Data_type
6−
7−done (Con_2 s) = s
8−
9−main = Debug.Trace.trace (done (Con_2 "Done"))
examples/passing/Unit.pursdeleted−6
@@ -1,6 +0,0 @@
1−module Main where
2−
3−import Prelude
4−import Debug.Trace
5−
6−main = print (const unit $ "Hello world")
examples/passing/UnknownInTypeClassLookup.pursdeleted−12
@@ -1,12 +0,0 @@
1−module Main where
2−
3−class EQ a b
4−
5−instance eqAA :: EQ a a
6−
7−test :: forall a b. (EQ a b) => a -> b -> String
8−test _ _ = "Done"
9−
10−runTest a = test a a
11−
12−main = Debug.Trace.trace $ runTest 0
examples/passing/Where.pursdeleted−49
@@ -1,49 +0,0 @@
1−module Main where
2−
3−import Prelude
4−import Control.Monad.Eff
5−import Control.Monad.ST
6−
7−test1 x = y
8− where
9− y :: Number
10− y = x + 1
11−
12−test2 x y = x' + y'
13− where
14− x' = x + 1
15− y' = y + 1
16−
17−
18−test3 = f 1 2 3
19− where f x y z = x + y + z
20−
21−
22−test4 = f (+) [1, 2]
23− where f x [y, z] = x y z
24−
25−
26−test5 = g 10
27− where
28− f x | x > 0 = g (x / 2) + 1
29− f x = 0
30− g x = f (x - 1) + 1
31−
32−test6 = if f true then f 1 else f 2
33− where f :: forall a. a -> a
34− f x = x
35−
36−test7 :: Number -> Number
37−test7 x = go x
38− where
39− go y | (x - 0.1 < y * y) && (y * y < x + 0.1) = y
40− go y = go $ (y + x / y) / 2
41−
42−main = do
43− Debug.Trace.print (test1 1)
44− Debug.Trace.print (test2 1 2)
45− Debug.Trace.print test3
46− Debug.Trace.print test4
47− Debug.Trace.print test5
48− Debug.Trace.print test6
49− Debug.Trace.print (test7 100)
examples/passing/iota.pursdeleted−9
@@ -1,9 +0,0 @@
1−module Main where
2−
3− s = \x -> \y -> \z -> x z (y z)
4−
5− k = \x -> \y -> x
6−
7− iota = \x -> x s k
8−
9− main = Debug.Trace.trace "Done"
examples/passing/s.pursdeleted−5
@@ -1,5 +0,0 @@
1−module Main where
2−
3− s = \x y z -> x z (y z)
4−
5− main = Debug.Trace.trace "Done"
hierarchy/Main.hsdeleted−113
@@ -1,113 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Main
4−-- Copyright : (c) Hardy Jones 2014
5−-- License : MIT
6−--
7−-- Maintainer : Hardy Jones <jones3.hardy@gmail.com>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- |
12−-- Generate Directed Graphs of PureScript TypeClasses
13−--
14−-----------------------------------------------------------------------------
15−
16−module Main where
17−
18−import Control.Monad (unless)
19−
20−import Data.List (intercalate,nub,sort)
21−import Data.Foldable (for_)
22−import Data.Version (showVersion)
23−
24−import Options.Applicative
25−import System.Directory (createDirectoryIfMissing)
26−import System.FilePath ((</>))
27−import System.Exit (exitFailure, exitSuccess)
28−import System.IO (hPutStr, stderr)
29−
30−import Text.Parsec as Par (ParseError)
31−
32−import qualified Language.PureScript as P
33−import qualified Paths_purescript as Paths
34−
35−
36−data HierarchyOptions = HierarchyOptions
37− { hierachyInput :: FilePath
38− , hierarchyOutput :: Maybe FilePath
39− }
40−
41−newtype SuperMap = SuperMap { unSuperMap :: Either P.ProperName (P.ProperName, P.ProperName) }
42− deriving Eq
43−
44−instance Show SuperMap where
45− show (SuperMap (Left sub)) = show sub
46− show (SuperMap (Right (super, sub))) = show super ++ " -> " ++ show sub
47−
48−instance Ord SuperMap where
49− compare (SuperMap s) (SuperMap s') = getCls s `compare` getCls s'
50− where
51− getCls = either id snd
52−
53−runModuleName :: P.ModuleName -> String
54−runModuleName (P.ModuleName pns) = intercalate "_" (P.runProperName `map` pns)
55−
56−readInput :: FilePath -> IO (Either Par.ParseError [P.Module])
57−readInput filename = do
58− content <- readFile filename
59− return $ fmap (map snd) $ P.parseModulesFromFiles id [(filename, content)]
60−
61−compile :: HierarchyOptions -> IO ()
62−compile (HierarchyOptions input mOutput) = do
63− modules <- readInput input
64− case modules of
65− Left err -> hPutStr stderr (show err) >> exitFailure
66− Right ms -> do
67− for_ ms $ \(P.Module _ moduleName decls _) ->
68− let name = runModuleName moduleName
69− tcs = filter P.isTypeClassDeclaration decls
70− supers = sort . nub . filter (not . null) $ fmap superClasses tcs
71− prologue = "digraph " ++ name ++ " {\n"
72− body = intercalate "\n" (concatMap (fmap (\s -> " " ++ show s ++ ";")) supers)
73− epilogue = "\n}"
74− hier = prologue ++ body ++ epilogue
75− in unless (null supers) $ case mOutput of
76− Just output -> do
77− createDirectoryIfMissing True output
78− writeFile (output </> name) hier
79− Nothing -> putStrLn hier
80− exitSuccess
81−
82−superClasses :: P.Declaration -> [SuperMap]
83−superClasses (P.TypeClassDeclaration sub _ supers@(_:_) _) =
84− fmap (\(P.Qualified _ super, _) -> SuperMap (Right (super, sub))) supers
85−superClasses (P.TypeClassDeclaration sub _ _ _) = [SuperMap (Left sub)]
86−superClasses (P.PositionedDeclaration _ _ decl) = superClasses decl
87−superClasses _ = []
88−
89−inputFile :: Parser FilePath
90−inputFile = strArgument $
91− metavar "FILE"
92− <> value "main.purs"
93− <> showDefault
94− <> help "The input file to generate a hierarchy from"
95−
96−outputFile :: Parser (Maybe FilePath)
97−outputFile = optional . strOption $
98− short 'o'
99− <> long "output"
100− <> help "The output directory"
101−
102−pscOptions :: Parser HierarchyOptions
103−pscOptions = HierarchyOptions <$> inputFile
104− <*> outputFile
105−
106−main :: IO ()
107−main = execParser opts >>= compile
108− where
109− opts = info (helper <*> pscOptions) infoModList
110− infoModList = fullDesc <> headerInfo <> footerInfo
111− headerInfo = header "hierarchy - Creates a GraphViz directed graph of PureScript TypeClasses"
112− footerInfo = footer $ "hierarchy " ++ showVersion Paths.version
113−
logo.pngdeleted

Binary file not shown.

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
psc-docs/Ctags.hsdeleted−13
@@ -1,13 +0,0 @@
1−module Ctags (dumpCtags) where
2−
3−import qualified Language.PureScript as P
4−import Tags
5−import Data.List (sort)
6−
7−dumpCtags :: [(String, P.Module)] -> [String]
8−dumpCtags = sort . concat . (map renderModCtags)
9−
10−renderModCtags :: (String, P.Module) -> [String]
11−renderModCtags (path, mdl) = sort tagLines
12− where tagLines = map tagLine $ tags mdl
13− tagLine (name, line) = name ++ "\t" ++ path ++ "\t" ++ show line
psc-docs/Etags.hsdeleted−15
@@ -1,15 +0,0 @@
1−module Etags (dumpEtags) where
2−
3−import qualified Language.PureScript as P
4−import Tags
5−
6−dumpEtags :: [(String, P.Module)] -> [String]
7−dumpEtags = concat . (map renderModEtags)
8−
9−renderModEtags :: (String, P.Module) -> [String]
10−renderModEtags (path, mdl) = ["\x0c", path ++ "," ++ show tagsLen] ++ tagLines
11− where tagsLen = sum $ map length tagLines
12− tagLines = map tagLine $ tags mdl
13− tagLine (name, line) = "\x7f" ++ name ++ "\x01" ++ show line ++ ","
14−
15−
psc-docs/Main.hsdeleted−265
@@ -1,265 +0,0 @@
1−----------------------------------------------------------------------------
2−--
3−-- Module : Main
4−-- Copyright : (c) Phil Freeman 2013
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- |
12−--
13−-----------------------------------------------------------------------------
14−
15−module Main where
16−
17−import Control.Applicative
18−import Control.Monad
19−import Control.Monad.Writer
20−import Control.Arrow (first)
21−import Data.List
22−import Data.Maybe (fromMaybe)
23−import Data.Version (showVersion)
24−import Data.Foldable (traverse_)
25−
26−import Options.Applicative
27−
28−import qualified Language.PureScript as P
29−import qualified Paths_purescript as Paths
30−import System.Exit (exitSuccess, exitFailure)
31−import System.IO (hPutStrLn, stderr)
32−
33−import Etags
34−import Ctags
35−
36−-- Available output formats
37−data Format = Markdown -- Output documentation in Markdown format
38− | Ctags -- Output ctags symbol index suitable for use with vi
39− | Etags -- Output etags symbol index suitable for use with emacs
40−
41−data PSCDocsOptions = PSCDocsOptions
42− { pscdFormat :: Format
43− , pscdInputFiles :: [FilePath]
44− }
45−
46−docgen :: PSCDocsOptions -> IO ()
47−docgen (PSCDocsOptions fmt input) = do
48− e <- P.parseModulesFromFiles (fromMaybe "") <$> mapM (fmap (first Just) . parseFile) (nub input)
49− case e of
50− Left err -> do
51− hPutStrLn stderr $ show err
52− exitFailure
53− Right ms -> do
54− case fmt of
55− Markdown -> putStrLn . runDocs $ renderModules (map snd ms)
56− Etags -> ldump $ dumpEtags $ pairs ms
57− Ctags -> ldump $ dumpCtags $ pairs ms
58− exitSuccess
59− where pairs :: [(Maybe String, m)] -> [(String, m)]
60− pairs = map (\(k,m) -> (fromMaybe "" k,m))
61− ldump :: [String] -> IO ()
62− ldump = mapM_ putStrLn
63−
64−parseFile :: FilePath -> IO (FilePath, String)
65−parseFile input = (,) input <$> readFile input
66−
67−type Docs = Writer [String] ()
68−
69−runDocs :: Docs -> String
70−runDocs = unlines . execWriter
71−
72−spacer :: Docs
73−spacer = tell [""]
74−
75−headerLevel :: Int -> String -> Docs
76−headerLevel level hdr = tell [replicate level '#' ++ ' ' : hdr]
77−
78−withIndent :: Int -> Docs -> Docs
79−withIndent indent = censor (map (replicate indent ' ' ++ ))
80−
81−atIndent :: Int -> String -> Docs
82−atIndent indent text =
83− let ls = lines text in
84− withIndent indent (tell ls)
85−
86−fenced :: String -> Docs
87−fenced text = fencedBlock (tell $ lines text)
88−
89−fencedBlock :: Docs -> Docs
90−fencedBlock inner = do
91− tell ["``` purescript"]
92− inner
93− tell ["```"]
94−
95−ticks :: String -> String
96−ticks = ("`" ++) . (++ "`")
97−
98−renderModules :: [P.Module] -> Docs
99−renderModules ms = do
100− headerLevel 1 "Module Documentation"
101− spacer
102− mapM_ renderModule ms
103−
104−renderModule :: P.Module -> Docs
105−renderModule mdl@(P.Module coms moduleName _ exps) = do
106− headerLevel 2 $ "Module " ++ P.runModuleName moduleName
107− spacer
108− unless (null coms) $ do
109− renderComments coms
110− spacer
111− renderTopLevel exps (P.exportedDeclarations mdl)
112− spacer
113−
114−renderTopLevel :: Maybe [P.DeclarationRef] -> [P.Declaration] -> Docs
115−renderTopLevel exps decls = forM_ decls $ \decl ->
116− when (canRenderDecl decl) $ do
117− traverse_ (headerLevel 4) (ticks `fmap` getDeclarationTitle decl)
118− spacer
119− renderDeclaration exps decl
120− spacer
121−
122−renderTypeclassImage :: P.ModuleName -> Docs
123−renderTypeclassImage name =
124− let name' = P.runModuleName name
125− in tell ["![" ++ name' ++ "](images/" ++ name' ++ ".png)"]
126−
127−getDeclarationTitle :: P.Declaration -> Maybe String
128−getDeclarationTitle (P.TypeDeclaration name _) = Just (show name)
129−getDeclarationTitle (P.ExternDeclaration _ name _ _) = Just (show name)
130−getDeclarationTitle (P.DataDeclaration _ name _ _) = Just (show name)
131−getDeclarationTitle (P.ExternDataDeclaration name _) = Just (show name)
132−getDeclarationTitle (P.TypeSynonymDeclaration name _ _) = Just (show name)
133−getDeclarationTitle (P.TypeClassDeclaration name _ _ _) = Just (show name)
134−getDeclarationTitle (P.TypeInstanceDeclaration name _ _ _ _) = Just (show name)
135−getDeclarationTitle (P.PositionedDeclaration _ _ d) = getDeclarationTitle d
136−getDeclarationTitle _ = Nothing
137−
138−renderDeclaration :: Maybe [P.DeclarationRef] -> P.Declaration -> Docs
139−renderDeclaration _ (P.TypeDeclaration ident ty) =
140− fenced $ show ident ++ " :: " ++ prettyPrintType' ty
141−renderDeclaration _ (P.ExternDeclaration _ ident _ ty) =
142− fenced $ show ident ++ " :: " ++ prettyPrintType' ty
143−renderDeclaration exps (P.DataDeclaration dtype name args ctors) = do
144− let
145− typeApp = foldl P.TypeApp (P.TypeConstructor (P.Qualified Nothing name)) (map toTypeVar args)
146− typeName = prettyPrintType' typeApp
147− exported = filter (P.isDctorExported name exps . fst) ctors
148− fencedBlock $ do
149− tell [show dtype ++ " " ++ typeName]
150− zipWithM_ (\isFirst (ctor, tys) ->
151− atIndent 2 $ (if isFirst then "= " else "| ") ++ P.runProperName ctor ++ " " ++ unwords (map P.prettyPrintTypeAtom tys))
152− (True : repeat False) exported
153−renderDeclaration _ (P.ExternDataDeclaration name kind) =
154− fenced $ "data " ++ P.runProperName name ++ " :: " ++ P.prettyPrintKind kind
155−renderDeclaration _ (P.TypeSynonymDeclaration name args ty) = do
156− let
157− typeApp = foldl P.TypeApp (P.TypeConstructor (P.Qualified Nothing name)) (map toTypeVar args)
158− typeName = prettyPrintType' typeApp
159− fenced $ "type " ++ typeName ++ " = " ++ prettyPrintType' ty
160−renderDeclaration _ (P.TypeClassDeclaration name args implies ds) = do
161− let impliesText = case implies of
162− [] -> ""
163− is -> "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map P.prettyPrintTypeAtom tys')) is) ++ ") <= "
164− classApp = foldl P.TypeApp (P.TypeConstructor (P.Qualified Nothing name)) (map toTypeVar args)
165− className = prettyPrintType' classApp
166− fencedBlock $ do
167− tell ["class " ++ impliesText ++ className ++ " where"]
168− mapM_ renderClassMember ds
169− where
170− renderClassMember (P.PositionedDeclaration _ _ d) = renderClassMember d
171− renderClassMember (P.TypeDeclaration ident ty) = atIndent 2 $ show ident ++ " :: " ++ prettyPrintType' ty
172− renderClassMember _ = error "Invalid argument to renderClassMember."
173−renderDeclaration _ (P.TypeInstanceDeclaration name constraints className tys _) = do
174− let constraintsText = case constraints of
175− [] -> ""
176− cs -> "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map P.prettyPrintTypeAtom tys')) cs) ++ ") => "
177− fenced $ "instance " ++ show name ++ " :: " ++ constraintsText ++ show className ++ " " ++ unwords (map P.prettyPrintTypeAtom tys)
178−renderDeclaration exps (P.PositionedDeclaration _ com d) = do
179− renderDeclaration exps d
180− renderComments com
181−renderDeclaration _ _ = return ()
182−
183−renderComments :: [P.Comment] -> Docs
184−renderComments cs = do
185− let raw = concatMap toLines cs
186− when (all hasPipe raw) $ do
187− spacer
188− atIndent 0 . unlines . map stripPipes $ raw
189− where
190−
191− toLines (P.LineComment s) = [s]
192− toLines (P.BlockComment s) = lines s
193−
194− hasPipe s = case dropWhile (== ' ') s of { ('|':_) -> True; _ -> False }
195−
196− stripPipes = dropPipe . dropWhile (== ' ')
197−
198− dropPipe ('|':' ':s) = s
199− dropPipe ('|':s) = s
200− dropPipe s = s
201−
202−toTypeVar :: (String, Maybe P.Kind) -> P.Type
203−toTypeVar (s, Nothing) = P.TypeVar s
204−toTypeVar (s, Just k) = P.KindedType (P.TypeVar s) k
205−
206−prettyPrintType' :: P.Type -> String
207−prettyPrintType' = P.prettyPrintType . P.everywhereOnTypes dePrim
208− where
209− dePrim ty@(P.TypeConstructor (P.Qualified _ name))
210− | ty == P.tyBoolean || ty == P.tyNumber || ty == P.tyString =
211− P.TypeConstructor $ P.Qualified Nothing name
212− dePrim other = other
213−
214−getName :: P.Declaration -> String
215−getName (P.TypeDeclaration ident _) = show ident
216−getName (P.ExternDeclaration _ ident _ _) = show ident
217−getName (P.DataDeclaration _ name _ _) = P.runProperName name
218−getName (P.ExternDataDeclaration name _) = P.runProperName name
219−getName (P.TypeSynonymDeclaration name _ _) = P.runProperName name
220−getName (P.TypeClassDeclaration name _ _ _) = P.runProperName name
221−getName (P.TypeInstanceDeclaration name _ _ _ _) = show name
222−getName (P.PositionedDeclaration _ _ d) = getName d
223−getName _ = error "Invalid argument to getName"
224−
225−canRenderDecl :: P.Declaration -> Bool
226−canRenderDecl P.TypeDeclaration{} = True
227−canRenderDecl P.ExternDeclaration{} = True
228−canRenderDecl P.DataDeclaration{} = True
229−canRenderDecl P.ExternDataDeclaration{} = True
230−canRenderDecl P.TypeSynonymDeclaration{} = True
231−canRenderDecl P.TypeClassDeclaration{} = True
232−canRenderDecl P.TypeInstanceDeclaration{} = True
233−canRenderDecl (P.PositionedDeclaration _ _ d) = canRenderDecl d
234−canRenderDecl _ = False
235−
236−inputFile :: Parser FilePath
237−inputFile = strArgument $
238− metavar "FILE"
239− <> help "The input .purs file(s)"
240−
241−instance Read Format where
242− readsPrec _ "etags" = [(Etags, "")]
243− readsPrec _ "ctags" = [(Ctags, "")]
244− readsPrec _ "markdown" = [(Markdown, "")]
245− readsPrec _ _ = []
246−
247−format :: Parser Format
248−format = option auto $ value Markdown
249− <> long "format"
250− <> metavar "FORMAT"
251− <> help "Set output FORMAT (markdown | etags | ctags)"
252−
253−pscDocsOptions :: Parser PSCDocsOptions
254−pscDocsOptions = PSCDocsOptions <$> format <*> many inputFile
255−
256−main :: IO ()
257−main = execParser opts >>= docgen
258− where
259− opts = info (version <*> helper <*> pscDocsOptions) infoModList
260− infoModList = fullDesc <> headerInfo <> footerInfo
261− headerInfo = header "psc-docs - Generate Markdown documentation from PureScript extern files"
262− footerInfo = footer $ "psc-docs " ++ showVersion Paths.version
263−
264− version :: Parser (a -> a)
265− version = abortOption (InfoMsg (showVersion Paths.version)) $ long "version" <> help "Show the version number" <> hidden
psc-docs/Tags.hsdeleted−18
@@ -1,18 +0,0 @@
1−module Tags where
2−
3−import qualified Language.PureScript as P
4−
5−tags :: P.Module -> [(String, Int)]
6−tags = concatMap dtags . P.exportedDeclarations
7− where dtags (P.PositionedDeclaration sp _ d) = map tag $ names d
8− where tag name = (name, line)
9− line = P.sourcePosLine $ P.spanStart sp
10− dtags _ = []
11− names (P.DataDeclaration _ name _ dcons) = P.runProperName name : consNames
12− where consNames = map (\(cname, _) -> P.runProperName cname) dcons
13− names (P.TypeDeclaration ident _) = [show ident]
14− names (P.ExternDeclaration _ ident _ _) = [show ident]
15− names (P.TypeSynonymDeclaration name _ _) = [P.runProperName name]
16− names (P.TypeClassDeclaration name _ _ _) = [P.runProperName name]
17− names (P.TypeInstanceDeclaration name _ _ _ _) = [show name]
18− names _ = []
psc-make/Main.hsdeleted−182
@@ -1,182 +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
21−import Control.Monad.Error.Class (MonadError(..))
22−import Control.Monad.Trans.Except
23−import Control.Monad.Reader
24−import Control.Monad.Writer
25−
26−import Data.Version (showVersion)
27−import Data.Traversable (traverse)
28−
29−import Options.Applicative as Opts
30−
31−import System.Directory
32− (doesFileExist, getModificationTime, createDirectoryIfMissing)
33−import System.FilePath (takeDirectory)
34−import System.Exit (exitSuccess, exitFailure)
35−import System.IO.Error (tryIOError)
36−
37−import qualified Language.PureScript as P
38−import qualified Paths_purescript as Paths
39−
40−
41−data PSCMakeOptions = PSCMakeOptions
42− { pscmInput :: [FilePath]
43− , pscmOutputDir :: FilePath
44− , pscmOpts :: P.Options P.Make
45− , pscmUsePrefix :: Bool
46− }
47−
48−data InputOptions = InputOptions
49− { ioNoPrelude :: Bool
50− , ioInputFiles :: [FilePath]
51− }
52−
53−readInput :: InputOptions -> IO [(Either P.RebuildPolicy FilePath, String)]
54−readInput InputOptions{..} = forM ioInputFiles $ \inFile -> (Right inFile, ) <$> readFile inFile
55−
56−newtype Make a = Make { unMake :: ReaderT (P.Options P.Make) (WriterT P.MultipleErrors (ExceptT P.MultipleErrors IO)) a }
57− deriving (Functor, Applicative, Monad, MonadIO, MonadError P.MultipleErrors, MonadWriter P.MultipleErrors, MonadReader (P.Options P.Make))
58−
59−runMake :: P.Options P.Make -> Make a -> IO (Either P.MultipleErrors (a, P.MultipleErrors))
60−runMake opts = runExceptT . runWriterT . flip runReaderT opts . unMake
61−
62−makeIO :: (IOError -> P.ErrorMessage) -> IO a -> Make a
63−makeIO f io = do
64− e <- liftIO $ tryIOError io
65− either (throwError . P.errorMessage . f) return e
66−
67−instance P.MonadMake Make where
68− getTimestamp path = makeIO (const (P.CannotGetFileInfo path)) $ do
69− exists <- doesFileExist path
70− traverse (const $ getModificationTime path) $ guard exists
71− readTextFile path = makeIO (const (P.CannotReadFile path))$ do
72− putStrLn $ "Reading " ++ path
73− readFile path
74− writeTextFile path text = makeIO (const (P.CannotWriteFile path)) $ do
75− mkdirp path
76− putStrLn $ "Writing " ++ path
77− writeFile path text
78− progress = liftIO . putStrLn
79−
80−compile :: PSCMakeOptions -> IO ()
81−compile (PSCMakeOptions input outputDir opts usePrefix) = do
82− modules <- P.parseModulesFromFiles (either (const "") id) <$> readInput (InputOptions (P.optionsNoPrelude opts) input)
83− case modules of
84− Left err -> do
85− print err
86− exitFailure
87− Right ms -> do
88− e <- runMake opts $ P.make outputDir ms prefix
89− case e of
90− Left errs -> do
91− putStrLn (P.prettyPrintMultipleErrors (P.optionsVerboseErrors opts) errs)
92− exitFailure
93− Right (_, warnings) -> do
94− when (P.nonEmpty warnings) $
95− putStrLn (P.prettyPrintMultipleWarnings (P.optionsVerboseErrors opts) warnings)
96− exitSuccess
97− where
98− prefix = if usePrefix
99− then ["Generated by psc-make version " ++ showVersion Paths.version]
100− else []
101−
102−mkdirp :: FilePath -> IO ()
103−mkdirp = createDirectoryIfMissing True . takeDirectory
104−
105−inputFile :: Parser FilePath
106−inputFile = strArgument $
107− metavar "FILE"
108− <> help "The input .purs file(s)"
109−
110−outputDirectory :: Parser FilePath
111−outputDirectory = strOption $
112− short 'o'
113− <> long "output"
114− <> Opts.value "output"
115− <> showDefault
116− <> help "The output directory"
117−
118−noTco :: Parser Bool
119−noTco = switch $
120− long "no-tco"
121− <> help "Disable tail call optimizations"
122−
123−noPrelude :: Parser Bool
124−noPrelude = switch $
125− long "no-prelude"
126− <> help "Omit the automatic Prelude import"
127−
128−noMagicDo :: Parser Bool
129−noMagicDo = switch $
130− long "no-magic-do"
131− <> help "Disable the optimization that overloads the do keyword to generate efficient code specifically for the Eff monad."
132−
133−noOpts :: Parser Bool
134−noOpts = switch $
135− long "no-opts"
136− <> help "Skip the optimization phase."
137−
138−comments :: Parser Bool
139−comments = switch $
140− short 'c'
141− <> long "comments"
142− <> help "Include comments in the generated code."
143−
144−verboseErrors :: Parser Bool
145−verboseErrors = switch $
146− short 'v'
147− <> long "verbose-errors"
148− <> help "Display verbose error messages"
149−
150−noPrefix :: Parser Bool
151−noPrefix = switch $
152− short 'p'
153− <> long "no-prefix"
154− <> help "Do not include comment header"
155−
156−
157−options :: Parser (P.Options P.Make)
158−options = P.Options <$> noPrelude
159− <*> noTco
160− <*> noMagicDo
161− <*> pure Nothing
162− <*> noOpts
163− <*> verboseErrors
164− <*> (not <$> comments)
165− <*> pure P.MakeOptions
166−
167−pscMakeOptions :: Parser PSCMakeOptions
168−pscMakeOptions = PSCMakeOptions <$> many inputFile
169− <*> outputDirectory
170− <*> options
171− <*> (not <$> noPrefix)
172−
173−main :: IO ()
174−main = execParser opts >>= compile
175− where
176− opts = info (version <*> helper <*> pscMakeOptions) infoModList
177− infoModList = fullDesc <> headerInfo <> footerInfo
178− headerInfo = header "psc-make - Compiles PureScript to Javascript"
179− footerInfo = footer $ "psc-make " ++ showVersion Paths.version
180−
181− version :: Parser (a -> a)
182− version = abortOption (InfoMsg (showVersion Paths.version)) $ long "version" <> help "Show the version number" <> hidden
psc/Main.hsdeleted−215
@@ -1,215 +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
21−import Control.Monad.Reader
22−import Control.Monad.Writer
23−
24−import Data.Maybe (fromMaybe)
25−import Data.Version (showVersion)
26−
27−import Options.Applicative as Opts
28−import System.Directory (createDirectoryIfMissing)
29−import System.FilePath (takeDirectory)
30−import System.Exit (exitSuccess, exitFailure)
31−import System.IO (hPutStrLn, stderr)
32−
33−import qualified Language.PureScript as P
34−import qualified Paths_purescript as Paths
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 = forM ioInputFiles $ \inFile -> (Just inFile, ) <$> readFile inFile
55−
56−type PSC = ReaderT (P.Options P.Compile) (WriterT P.MultipleErrors (Either P.MultipleErrors))
57−
58−runPSC :: P.Options P.Compile -> PSC a -> Either P.MultipleErrors (a, P.MultipleErrors)
59−runPSC opts rwe = runWriterT (runReaderT rwe opts)
60−
61−compile :: PSCOptions -> IO ()
62−compile (PSCOptions input opts stdin output externs usePrefix) = do
63− modules <- P.parseModulesFromFiles (fromMaybe "") <$> readInput (InputOptions (P.optionsNoPrelude opts) stdin input)
64− case modules of
65− Left err -> do
66− hPutStrLn stderr $ show err
67− exitFailure
68− Right ms -> do
69− case runPSC opts (P.compile (map snd ms) prefix) of
70− Left errs -> do
71− hPutStrLn stderr (P.prettyPrintMultipleErrors (P.optionsVerboseErrors opts) errs)
72− exitFailure
73− Right ((js, exts, _), warnings) -> do
74− when (P.nonEmpty warnings) $
75− hPutStrLn stderr (P.prettyPrintMultipleWarnings (P.optionsVerboseErrors opts) warnings)
76− case output of
77− Just path -> mkdirp path >> writeFile path js
78− Nothing -> putStrLn js
79− case externs of
80− Just path -> mkdirp path >> writeFile path exts
81− Nothing -> return ()
82− exitSuccess
83− where
84− prefix = if usePrefix
85− then ["Generated by psc version " ++ showVersion Paths.version]
86− else []
87−
88−mkdirp :: FilePath -> IO ()
89−mkdirp = createDirectoryIfMissing True . takeDirectory
90−
91−codeGenModule :: Parser String
92−codeGenModule = strOption $
93− long "codegen"
94− <> help "A list of modules for which Javascript and externs should be generated. This argument can be used multiple times."
95−
96−dceModule :: Parser String
97−dceModule = strOption $
98− short 'm'
99− <> long "module"
100− <> 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."
101−
102−browserNamespace :: Parser String
103−browserNamespace = strOption $
104− long "browser-namespace"
105− <> Opts.value "PS"
106− <> showDefault
107− <> help "Specify the namespace that PureScript modules will be exported to when running in the browser."
108−
109−verboseErrors :: Parser Bool
110−verboseErrors = switch $
111− short 'v'
112− <> long "verbose-errors"
113− <> help "Display verbose error messages"
114−
115−noOpts :: Parser Bool
116−noOpts = switch $
117− long "no-opts"
118− <> help "Skip the optimization phase."
119−
120−runMain :: Parser (Maybe String)
121−runMain = optional $ noArgs <|> withArgs
122− where
123− defaultVal = "Main"
124− noArgs = flag' defaultVal (long "main")
125− withArgs = strOption $
126− long "main"
127− <> help (concat [
128− "Generate code to run the main method in the specified module. ",
129− "(no argument: \"", defaultVal, "\")"
130− ])
131−
132−noMagicDo :: Parser Bool
133−noMagicDo = switch $
134− long "no-magic-do"
135− <> help "Disable the optimization that overloads the do keyword to generate efficient code specifically for the Eff monad."
136−
137−noTco :: Parser Bool
138−noTco = switch $
139− long "no-tco"
140− <> help "Disable tail call optimizations"
141−
142−noPrelude :: Parser Bool
143−noPrelude = switch $
144− long "no-prelude"
145− <> help "Omit the automatic Prelude import"
146−
147−comments :: Parser Bool
148−comments = switch $
149− short 'c'
150− <> long "comments"
151− <> help "Include comments in the generated code."
152−
153−useStdIn :: Parser Bool
154−useStdIn = switch $
155− short 's'
156− <> long "stdin"
157− <> help "Read from standard input"
158−
159−inputFile :: Parser FilePath
160−inputFile = strArgument $
161− metavar "FILE"
162− <> help "The input .purs file(s)"
163−
164−outputFile :: Parser (Maybe FilePath)
165−outputFile = optional . strOption $
166− short 'o'
167− <> long "output"
168− <> help "The output .js file"
169−
170−externsFile :: Parser (Maybe FilePath)
171−externsFile = optional . strOption $
172− short 'e'
173− <> long "externs"
174− <> help "The output .e.purs file"
175−
176−noPrefix :: Parser Bool
177−noPrefix = switch $
178− short 'p'
179− <> long "no-prefix"
180− <> help "Do not include comment header"
181−
182−options :: Parser (P.Options P.Compile)
183−options = P.Options <$> noPrelude
184− <*> noTco
185− <*> noMagicDo
186− <*> runMain
187− <*> noOpts
188− <*> verboseErrors
189− <*> (not <$> comments)
190− <*> additionalOptions
191− where
192− additionalOptions =
193− P.CompileOptions <$> browserNamespace
194− <*> many dceModule
195− <*> many codeGenModule
196−
197−pscOptions :: Parser PSCOptions
198−pscOptions = PSCOptions <$> many inputFile
199− <*> options
200− <*> useStdIn
201− <*> outputFile
202− <*> externsFile
203− <*> (not <$> noPrefix)
204−
205−main :: IO ()
206−main = execParser opts >>= compile
207− where
208− opts = info (version <*> helper <*> pscOptions) infoModList
209− infoModList = fullDesc <> headerInfo <> footerInfo
210− headerInfo = header "psc - Compiles PureScript to Javascript"
211− footerInfo = footer $ "psc " ++ showVersion Paths.version
212−
213− version :: Parser (a -> a)
214− version = abortOption (InfoMsg (showVersion Paths.version)) $ long "version" <> help "Show the version number" <> hidden
215−
psci/Completion.hsdeleted−232
@@ -1,232 +0,0 @@
1−module Completion where
2−
3−import Data.Maybe (mapMaybe)
4−import Data.List (nub, nubBy, sortBy, isPrefixOf, stripPrefix)
5−import Data.Char (isUpper)
6−import Data.Function (on)
7−import Data.Traversable (traverse)
8−
9−import Control.Applicative ((<$>), (<*>))
10−import Control.Monad.Trans.Reader (asks, runReaderT, ReaderT)
11−import Control.Monad.Trans.State.Strict
12−
13−import System.Console.Haskeline
14−
15−import qualified Language.PureScript as P
16−import qualified Language.PureScript.Names as N
17−
18−import qualified Directive as D
19−import Types
20−
21−-- Completions may read the state, but not modify it.
22−type CompletionM = ReaderT PSCiState IO
23−
24−-- Lift a `CompletionM` action to a `StateT PSCiState IO` one.
25−liftCompletionM :: CompletionM a -> StateT PSCiState IO a
26−liftCompletionM act = StateT (\s -> (\a -> (a, s)) <$> runReaderT act s)
27−
28−-- Haskeline completions
29−
30−data CompletionContext
31− = CtxDirective String
32− | CtxFilePath String
33− | CtxModule
34− | CtxIdentifier
35− | CtxType
36− | CtxFixed String
37− deriving (Show)
38−
39−-- |
40−-- Loads module, function, and file completions.
41−--
42−completion :: CompletionFunc (StateT PSCiState IO)
43−completion = liftCompletionM . completion'
44−
45−completion' :: CompletionFunc CompletionM
46−completion' = completeWordWithPrev Nothing " \t\n\r" findCompletions
47−
48−-- |
49−-- Decide what kind of completion we need based on input. This function expects
50−-- a list of complete words (to the left of the cursor) as the first argument,
51−-- and the current word as the second argument.
52−completionContext :: [String] -> String -> [CompletionContext]
53−completionContext [] _ = [CtxDirective "", CtxIdentifier, CtxFixed "import"]
54−completionContext ws w | headSatisfies (":" `isPrefixOf`) ws = completeDirective ws w
55−completionContext ws w | headSatisfies (== "import") ws = completeImport ws w
56−completionContext _ _ = [CtxIdentifier]
57−
58−completeDirective :: [String] -> String -> [CompletionContext]
59−completeDirective ws w =
60− case ws of
61− [] -> [CtxDirective w]
62− [dir] -> case D.directivesFor <$> stripPrefix ":" dir of
63− -- only offer completions if the directive is unambiguous
64− Just [dir'] -> directiveArg w dir'
65− _ -> []
66−
67− -- All directives take exactly one argument. If we haven't yet matched,
68− -- that means one argument has already been supplied. So don't complete
69− -- any others.
70− _ -> []
71−
72−directiveArg :: String -> Directive -> [CompletionContext]
73−directiveArg _ Browse = [CtxModule]
74−directiveArg w Load = [CtxFilePath w]
75−directiveArg _ Quit = []
76−directiveArg _ Reset = []
77−directiveArg _ Help = []
78−directiveArg _ Show = map CtxFixed replQueryStrings
79−directiveArg _ Type = [CtxIdentifier]
80−directiveArg _ Kind = [CtxType]
81−
82−completeImport :: [String] -> String -> [CompletionContext]
83−completeImport ws w' =
84− case (ws, w') of
85− (["import"], w) | headSatisfies isUpper w -> [CtxModule]
86− (["import"], _) -> [CtxModule, CtxFixed "qualified"]
87− (["import", "qualified"], _) -> [CtxModule]
88− _ -> []
89−
90−headSatisfies :: (a -> Bool) -> [a] -> Bool
91−headSatisfies p str =
92− case str of
93− (c:_) -> p c
94− _ -> False
95−
96−-- | Callback for Haskeline's `completeWordWithPrev`.
97−-- Expects:
98−-- * Line contents to the left of the word, reversed
99−-- * Word to be completed
100−findCompletions :: String -> String -> CompletionM [Completion]
101−findCompletions prev word = do
102− let ctx = completionContext (words (reverse prev)) word
103− completions <- concat <$> traverse getCompletions ctx
104− return $ sortBy directivesFirst completions
105− where
106− getCompletions :: CompletionContext -> CompletionM [Completion]
107− getCompletions = fmap (mapMaybe (either (prefixedBy word) Just)) . getCompletion
108−
109− prefixedBy :: String -> String -> Maybe Completion
110− prefixedBy w cand = if w `isPrefixOf` cand
111− then Just (simpleCompletion cand)
112− else Nothing
113−
114−getCompletion :: CompletionContext -> CompletionM [Either String Completion]
115−getCompletion ctx =
116− case ctx of
117− CtxFilePath f -> map Right <$> listFiles f
118− CtxModule -> map Left <$> getModuleNames
119− CtxIdentifier -> map Left <$> ((++) <$> getIdentNames <*> getDctorNames)
120− CtxType -> map Left <$> getTypeNames
121− CtxFixed str -> return [Left str]
122− CtxDirective d -> return (map Left (completeDirectives d))
123−
124− where
125− completeDirectives :: String -> [String]
126− completeDirectives = map (':' :) . D.directiveStringsFor
127−
128−
129−getLoadedModules :: CompletionM [P.Module]
130−getLoadedModules = asks (map snd . psciLoadedModules)
131−
132−getImportedModules :: CompletionM [ImportedModule]
133−getImportedModules = asks psciImportedModules
134−
135−getModuleNames :: CompletionM [String]
136−getModuleNames = moduleNames <$> getLoadedModules
137−
138−mapLoadedModulesAndQualify :: (Show a) => (P.Module -> [(a, P.Declaration)]) -> CompletionM [String]
139−mapLoadedModulesAndQualify f = do
140− ms <- getLoadedModules
141− let argPairs = do m <- ms
142− fm <- f m
143− return (m, fm)
144− concat <$> traverse (uncurry getAllQualifications) argPairs
145−
146−getIdentNames :: CompletionM [String]
147−getIdentNames = mapLoadedModulesAndQualify identNames
148−
149−getDctorNames :: CompletionM [String]
150−getDctorNames = mapLoadedModulesAndQualify dctorNames
151−
152−getTypeNames :: CompletionM [String]
153−getTypeNames = mapLoadedModulesAndQualify typeDecls
154−
155−-- | Given a module and a declaration in that module, return all possible ways
156−-- it could have been referenced given the current PSCiState - including fully
157−-- qualified, qualified using an alias, and unqualified.
158−getAllQualifications :: (Show a) => P.Module -> (a, P.Declaration) -> CompletionM [String]
159−getAllQualifications m (declName, decl) = do
160− imports <- getAllImportsOf m
161− let fullyQualified = qualifyWith (Just (P.getModuleName m))
162− let otherQuals = nub (concatMap qualificationsUsing imports)
163− return $ fullyQualified : otherQuals
164− where
165− qualifyWith mMod = show (P.Qualified mMod declName)
166− referencedBy refs = P.isExported (Just refs) decl
167−
168− qualificationsUsing (_, importType, asQ') =
169− let q = qualifyWith asQ'
170− in case importType of
171− P.Implicit -> [q]
172− P.Explicit refs -> if referencedBy refs
173− then [q]
174− else []
175− P.Hiding refs -> if referencedBy refs
176− then []
177− else [q]
178−
179−
180−-- | Returns all the ImportedModule values referring to imports of a particular
181−-- module.
182−getAllImportsOf :: P.Module -> CompletionM [ImportedModule]
183−getAllImportsOf = asks . allImportsOf
184−
185−nubOnFst :: Eq a => [(a, b)] -> [(a, b)]
186−nubOnFst = nubBy ((==) `on` fst)
187−
188−typeDecls :: P.Module -> [(N.ProperName, P.Declaration)]
189−typeDecls = mapMaybe getTypeName . filter P.isDataDecl . P.exportedDeclarations
190− where
191− getTypeName :: P.Declaration -> Maybe (N.ProperName, P.Declaration)
192− getTypeName d@(P.TypeSynonymDeclaration name _ _) = Just (name, d)
193− getTypeName d@(P.DataDeclaration _ name _ _) = Just (name, d)
194− getTypeName (P.PositionedDeclaration _ _ d) = getTypeName d
195− getTypeName _ = Nothing
196−
197−identNames :: P.Module -> [(N.Ident, P.Declaration)]
198−identNames = nubOnFst . mapMaybe getDeclName . P.exportedDeclarations
199− where
200− getDeclName :: P.Declaration -> Maybe (P.Ident, P.Declaration)
201− getDeclName d@(P.ValueDeclaration ident _ _ _) = Just (ident, d)
202− getDeclName d@(P.ExternDeclaration _ ident _ _) = Just (ident, d)
203− getDeclName (P.PositionedDeclaration _ _ d) = getDeclName d
204− getDeclName _ = Nothing
205−
206−dctorNames :: P.Module -> [(N.ProperName, P.Declaration)]
207−dctorNames m = nubOnFst $ concatMap dctors dnames
208− where
209− getDataDeclName :: P.Declaration -> Maybe (N.ProperName, P.Declaration)
210− getDataDeclName d@(P.DataDeclaration _ name _ _) = Just (name, d)
211− getDataDeclName (P.PositionedDeclaration _ _ d) = getDataDeclName d
212− getDataDeclName _ = Nothing
213−
214− dnames :: [(N.ProperName, P.Declaration)]
215− dnames = (mapMaybe getDataDeclName onlyDataDecls)
216−
217− onlyDataDecls :: [P.Declaration]
218− onlyDataDecls = (filter P.isDataDecl (P.exportedDeclarations m))
219−
220− dctors :: (N.ProperName, P.Declaration) -> [(N.ProperName, P.Declaration)]
221− dctors (name, decl) = map (\n -> (n, decl)) (map fst (P.exportedDctors m name))
222−
223−moduleNames :: [P.Module] -> [String]
224−moduleNames ms = nub [show moduleName | P.Module _ moduleName _ _ <- ms]
225−
226−directivesFirst :: Completion -> Completion -> Ordering
227−directivesFirst (Completion _ d1 _) (Completion _ d2 _) = go d1 d2
228− where
229− go (':' : xs) (':' : ys) = compare xs ys
230− go (':' : _) _ = LT
231− go _ (':' : _) = GT
232− go xs ys = compare xs ys
psci/Directive.hsdeleted−113
@@ -1,113 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Directive
4−-- Copyright :
5−-- License : MIT
6−--
7−-- Maintainer :
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- |
12−-- Directives for PSCI.
13−--
14−-----------------------------------------------------------------------------
15−
16−module Directive where
17−
18−import Data.Maybe (fromJust, listToMaybe)
19−import Data.List (isPrefixOf)
20−import Data.Tuple (swap)
21−
22−import Types
23−
24−-- |
25−-- List of all avaliable directives.
26−--
27−directives :: [Directive]
28−directives = map fst directiveStrings
29−
30−-- |
31−-- A mapping of directives to the different strings that can be used to invoke
32−-- them.
33−--
34−directiveStrings :: [(Directive, [String])]
35−directiveStrings =
36− [ (Help , ["?", "help"])
37− , (Quit , ["quit"])
38− , (Reset , ["reset"])
39− , (Browse , ["browse"])
40− , (Load , ["load", "module"])
41− , (Type , ["type"])
42− , (Kind , ["kind"])
43− , (Show , ["show"])
44− ]
45−
46−-- |
47−-- Like directiveStrings, but the other way around.
48−--
49−directiveStrings' :: [(String, Directive)]
50−directiveStrings' = concatMap go directiveStrings
51− where
52− go (dir, strs) = map (\s -> (s, dir)) strs
53−
54−-- |
55−-- List of all directive strings.
56−--
57−strings :: [String]
58−strings = concatMap snd directiveStrings
59−
60−-- |
61−-- Returns all possible string representations of a directive.
62−--
63−stringsFor :: Directive -> [String]
64−stringsFor d = fromJust (lookup d directiveStrings)
65−
66−-- |
67−-- Returns the default string representation of a directive.
68−--
69−stringFor :: Directive -> String
70−stringFor = head . stringsFor
71−
72−-- |
73−-- Returns the list of directives which could be expanded from the string
74−-- argument, together with the string alias that matched.
75−--
76−directivesFor' :: String -> [(Directive, String)]
77−directivesFor' str = go directiveStrings'
78− where
79− go = map swap . filter ((str `isPrefixOf`) . fst)
80−
81−directivesFor :: String -> [Directive]
82−directivesFor = map fst . directivesFor'
83−
84−directiveStringsFor :: String -> [String]
85−directiveStringsFor = map snd . directivesFor'
86−
87−parseDirective :: String -> Maybe Directive
88−parseDirective = listToMaybe . directivesFor
89−
90−-- |
91−-- True if the given directive takes an argument, false otherwise.
92−hasArgument :: Directive -> Bool
93−hasArgument Help = False
94−hasArgument Quit = False
95−hasArgument Reset = False
96−hasArgument _ = True
97−
98−-- |
99−-- The help menu.
100−--
101−help :: [(Directive, String, String)]
102−help =
103− [ (Help, "", "Show this help menu")
104− , (Quit, "", "Quit PSCi")
105− , (Reset, "", "Discard all imported modules and declared bindings")
106− , (Browse, "<module>", "See all functions in <module>")
107− , (Load, "<file>", "Load <file> for importing")
108− , (Type, "<expr>", "Show the type of <expr>")
109− , (Kind, "<type>", "Show the kind of <type>")
110− , (Show, "import", "Show all imported modules")
111− , (Show, "loaded", "Show all loaded modules")
112− ]
113−
psci/PSCi.hsdeleted−544
@@ -1,544 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : PSCi
4−-- Copyright : (c) Phil Freeman 2013
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- |
12−-- PureScript Compiler Interactive.
13−--
14−-----------------------------------------------------------------------------
15−
16−{-# LANGUAGE DataKinds #-}
17−{-# LANGUAGE DoAndIfThenElse #-}
18−{-# LANGUAGE FlexibleContexts #-}
19−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
20−{-# LANGUAGE RecordWildCards #-}
21−
22−module PSCi where
23−
24−import Data.Foldable (traverse_)
25−import Data.List (intercalate, nub, sort)
26−import Data.Traversable (traverse)
27−import Data.Version (showVersion)
28−import qualified Data.Map as M
29−
30−import Control.Applicative
31−import Control.Monad
32−import Control.Monad.IO.Class (MonadIO, liftIO)
33−import Control.Monad.Error.Class (MonadError(..))
34−import Control.Monad.Trans.Except (ExceptT(..), runExceptT)
35−import Control.Monad.Reader (MonadReader, ReaderT, runReaderT)
36−import Control.Monad.Writer (MonadWriter, WriterT, runWriterT)
37−import Control.Monad.Trans.Class
38−import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
39−import Control.Monad.Trans.State.Strict
40−import qualified Control.Monad.Trans.State.Lazy as L
41−
42−import Options.Applicative as Opts
43−
44−import System.Console.Haskeline
45−import System.Directory (createDirectoryIfMissing, getModificationTime, doesFileExist, findExecutable, getHomeDirectory, getCurrentDirectory)
46−import System.Exit
47−import System.FilePath (pathSeparator, takeDirectory, (</>), isPathSeparator)
48−import System.IO.Error (tryIOError)
49−import System.Process (readProcessWithExitCode)
50−
51−import qualified Text.Parsec as Par (ParseError)
52−
53−import qualified Language.PureScript as P
54−import qualified Language.PureScript.Names as N
55−import qualified Paths_purescript as Paths
56−
57−import qualified Directive as D
58−import Parser (parseCommand)
59−import Completion (completion)
60−import Types
61−
62−
63−-- File helpers
64−-- |
65−-- Load the necessary modules.
66−--
67−defaultImports :: [ImportedModule]
68−defaultImports = [(P.ModuleName [P.ProperName "Prelude"], P.Implicit, Nothing)]
69−
70−-- |
71−-- Locates the node executable.
72−-- Checks for either @nodejs@ or @node@.
73−--
74−findNodeProcess :: IO (Maybe String)
75−findNodeProcess = runMaybeT . msum $ map (MaybeT . findExecutable) names
76− where names = ["nodejs", "node"]
77−
78−-- |
79−-- Grabs the filename where the history is stored.
80−--
81−getHistoryFilename :: IO FilePath
82−getHistoryFilename = do
83− home <- getHomeDirectory
84− let filename = home </> ".purescript" </> "psci_history"
85− mkdirp filename
86− return filename
87−
88−-- |
89−-- Loads a file for use with imports.
90−--
91−loadModule :: FilePath -> IO (Either String [P.Module])
92−loadModule filename = do
93− content <- readFile filename
94− return $ either (Left . show) (Right . map snd) $ P.parseModulesFromFiles id [(filename, content)]
95−
96−-- |
97−-- Load all modules, including the Prelude
98−--
99−loadAllModules :: [FilePath] -> IO (Either Par.ParseError [(Either P.RebuildPolicy FilePath, P.Module)])
100−loadAllModules files = do
101− filesAndContent <- forM files $ \filename -> do
102− content <- readFile filename
103− return (Right filename, content)
104− return $ P.parseModulesFromFiles (either (const "") id) filesAndContent
105−
106−-- |
107−-- Load all modules, updating the application state
108−--
109−loadAllImportedModules :: PSCI ()
110−loadAllImportedModules = do
111− files <- PSCI . lift $ fmap psciImportedFilenames get
112− modulesOrFirstError <- psciIO $ loadAllModules files
113− case modulesOrFirstError of
114− Left err -> psciIO $ print err
115− Right modules -> PSCI . lift . modify $ \st -> st { psciLoadedModules = modules }
116−
117−-- |
118−-- Expands tilde in path.
119−--
120−expandTilde :: FilePath -> IO FilePath
121−expandTilde ('~':p:rest) | isPathSeparator p = (</> rest) <$> getHomeDirectory
122−expandTilde p = return p
123−-- Messages
124−
125−-- |
126−-- The help message.
127−--
128−helpMessage :: String
129−helpMessage = "The following commands are available:\n\n " ++
130− intercalate "\n " (map line D.help) ++
131− "\n\n" ++ extraHelp
132− where
133− line :: (Directive, String, String) -> String
134− line (dir, arg, desc) =
135− let cmd = ':' : D.stringFor dir
136− in intercalate " "
137− [ cmd
138− , replicate (11 - length cmd) ' '
139− , arg
140− , replicate (11 - length arg) ' '
141− , desc
142− ]
143−
144− extraHelp =
145− "Further information is available on the PureScript wiki:\n" ++
146− " --> https://github.com/purescript/purescript/wiki/psci"
147−
148−
149−-- |
150−-- The welcome prologue.
151−--
152−prologueMessage :: String
153−prologueMessage = intercalate "\n"
154− [ " ____ ____ _ _ "
155− , "| _ \\ _ _ _ __ ___/ ___| ___ _ __(_)_ __ | |_ "
156− , "| |_) | | | | '__/ _ \\___ \\ / __| '__| | '_ \\| __|"
157− , "| __/| |_| | | | __/___) | (__| | | | |_) | |_ "
158− , "|_| \\__,_|_| \\___|____/ \\___|_| |_| .__/ \\__|"
159− , " |_| "
160− , ""
161− , ":? shows help"
162− ]
163−
164−-- |
165−-- The quit message.
166−--
167−quitMessage :: String
168−quitMessage = "See ya!"
169−
170−
171−-- Compilation
172−
173−-- | Compilation options.
174−--
175−options :: P.Options P.Make
176−options = P.Options False False False Nothing False False False P.MakeOptions
177−
178−-- |
179−-- PSCI monad
180−--
181−newtype PSCI a = PSCI { runPSCI :: InputT (StateT PSCiState IO) a } deriving (Functor, Applicative, Monad)
182−
183−psciIO :: IO a -> PSCI a
184−psciIO io = PSCI . lift $ lift io
185−
186−newtype Make a = Make { unMake :: ReaderT (P.Options P.Make) (WriterT P.MultipleErrors (ExceptT P.MultipleErrors IO)) a }
187− deriving (Functor, Applicative, Monad, MonadIO, MonadError P.MultipleErrors, MonadWriter P.MultipleErrors, MonadReader (P.Options P.Make))
188−
189−runMake :: Make a -> IO (Either P.MultipleErrors a)
190−runMake = runExceptT . fmap fst . runWriterT . flip runReaderT options . unMake
191−
192−makeIO :: (IOError -> P.ErrorMessage) -> IO a -> Make a
193−makeIO f io = do
194− e <- liftIO $ tryIOError io
195− either (throwError . P.errorMessage . f) return e
196−
197−instance P.MonadMake Make where
198− getTimestamp path = makeIO (const (P.CannotGetFileInfo path)) $ do
199− exists <- doesFileExist path
200− traverse (const $ getModificationTime path) $ guard exists
201− readTextFile path = makeIO (const (P.CannotReadFile path)) $ readFile path
202− writeTextFile path text = makeIO (const (P.CannotWriteFile path)) $ do
203− mkdirp path
204− writeFile path text
205− progress s = unless (s == "Compiling $PSCI") $ liftIO . putStrLn $ s
206−
207−mkdirp :: FilePath -> IO ()
208−mkdirp = createDirectoryIfMissing True . takeDirectory
209−
210−-- |
211−-- Makes a volatile module to execute the current expression.
212−--
213−createTemporaryModule :: Bool -> PSCiState -> P.Expr -> P.Module
214−createTemporaryModule exec PSCiState{psciImportedModules = imports, psciLetBindings = lets} val =
215− let
216− moduleName = P.ModuleName [P.ProperName "$PSCI"]
217− traceModule = P.ModuleName [P.ProperName "Debug", P.ProperName "Trace"]
218− trace = P.Var (P.Qualified (Just traceModule) (P.Ident "print"))
219− mainValue = P.App trace (P.Var (P.Qualified Nothing (P.Ident "it")))
220− itDecl = P.ValueDeclaration (P.Ident "it") P.Value [] $ Right val
221− mainDecl = P.ValueDeclaration (P.Ident "main") P.Value [] $ Right mainValue
222− decls = if exec then [itDecl, mainDecl] else [itDecl]
223− in
224− P.Module [] moduleName ((importDecl `map` imports) ++ lets ++ decls) Nothing
225−
226−
227−-- |
228−-- Makes a volatile module to hold a non-qualified type synonym for a fully-qualified data type declaration.
229−--
230−createTemporaryModuleForKind :: PSCiState -> P.Type -> P.Module
231−createTemporaryModuleForKind PSCiState{psciImportedModules = imports} typ =
232− let
233− moduleName = P.ModuleName [P.ProperName "$PSCI"]
234− itDecl = P.TypeSynonymDeclaration (P.ProperName "IT") [] typ
235− in
236− P.Module [] moduleName ((importDecl `map` imports) ++ [itDecl]) Nothing
237−
238−-- |
239−-- Makes a volatile module to execute the current imports.
240−--
241−createTemporaryModuleForImports :: PSCiState -> P.Module
242−createTemporaryModuleForImports PSCiState{psciImportedModules = imports} =
243− let
244− moduleName = P.ModuleName [P.ProperName "$PSCI"]
245− in
246− P.Module [] moduleName (importDecl `map` imports) Nothing
247−
248−importDecl :: ImportedModule -> P.Declaration
249−importDecl (mn, declType, asQ) = P.ImportDeclaration mn declType asQ
250−
251−modulesDir :: FilePath
252−modulesDir = ".psci_modules" ++ pathSeparator : "node_modules"
253−
254−indexFile :: FilePath
255−indexFile = ".psci_modules" ++ pathSeparator : "index.js"
256−
257−-- |
258−-- Takes a value declaration and evaluates it with the current state.
259−--
260−handleDeclaration :: P.Expr -> PSCI ()
261−handleDeclaration val = do
262− st <- PSCI $ lift get
263− let m = createTemporaryModule True st val
264− let nodeArgs = psciNodeFlags st ++ [indexFile]
265− e <- psciIO . runMake $ P.make modulesDir (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) []
266− case e of
267− Left errs -> printErrors errs
268− Right _ -> do
269− psciIO $ writeFile indexFile "require('$PSCI').main();"
270− process <- psciIO findNodeProcess
271− result <- psciIO $ traverse (\node -> readProcessWithExitCode node nodeArgs "") process
272− case result of
273− Just (ExitSuccess, out, _) -> PSCI $ outputStrLn out
274− Just (ExitFailure _, _, err) -> PSCI $ outputStrLn err
275− Nothing -> PSCI $ outputStrLn "Couldn't find node.js"
276−
277−-- |
278−-- Takes a list of declarations and updates the environment, then run a make. If the declaration fails,
279−-- restore the original environment.
280−--
281−handleDecls :: [P.Declaration] -> PSCI ()
282−handleDecls ds = do
283− st <- PSCI $ lift get
284− let st' = updateLets ds st
285− let m = createTemporaryModule False st' (P.ObjectLiteral [])
286− e <- psciIO . runMake $ P.make modulesDir (psciLoadedModules st' ++ [(Left P.RebuildAlways, m)]) []
287− case e of
288− Left err -> printErrors err
289− Right _ -> PSCI $ lift (put st')
290−
291−-- |
292−-- Show actual loaded modules in psci.
293−--
294−handleShowLoadedModules :: PSCI ()
295−handleShowLoadedModules = do
296− PSCiState { psciLoadedModules = loadedModules } <- PSCI $ lift get
297− psciIO $ readModules loadedModules >>= putStrLn
298− return ()
299− where readModules = return . unlines . sort . nub . map toModuleName
300− toModuleName = N.runModuleName . (\ (P.Module _ mdName _ _) -> mdName) . snd
301−
302−-- |
303−-- Show the imported modules in psci.
304−--
305−handleShowImportedModules :: PSCI ()
306−handleShowImportedModules = do
307− PSCiState { psciImportedModules = importedModules } <- PSCI $ lift get
308− psciIO $ showModules importedModules >>= putStrLn
309− return ()
310− where
311− showModules = return . unlines . sort . map showModule
312− showModule (mn, declType, asQ) =
313− "import " ++ case asQ of
314− Just mn' -> "qualified " ++ N.runModuleName mn ++ " as " ++ N.runModuleName mn'
315− Nothing -> N.runModuleName mn ++ " " ++ showDeclType declType
316−
317− showDeclType P.Implicit = ""
318− showDeclType (P.Explicit refs) = refsList refs
319− showDeclType (P.Hiding refs) = "hiding " ++ refsList refs
320− refsList refs = "(" ++ commaList (map showRef refs) ++ ")"
321−
322− showRef :: P.DeclarationRef -> String
323− showRef (P.TypeRef pn dctors) = show pn ++ "(" ++ maybe ".." (commaList . map N.runProperName) dctors ++ ")"
324− showRef (P.ValueRef ident) = show ident
325− showRef (P.TypeClassRef pn) = show pn
326− showRef (P.TypeInstanceRef ident) = show ident
327− showRef (P.PositionedDeclarationRef _ _ ref) = showRef ref
328−
329− commaList :: [String] -> String
330− commaList = intercalate ", "
331−
332−-- |
333−-- Imports a module, preserving the initial state on failure.
334−--
335−handleImport :: ImportedModule -> PSCI ()
336−handleImport im = do
337− st <- updateImportedModules im <$> PSCI (lift get)
338− let m = createTemporaryModuleForImports st
339− e <- psciIO . runMake $ P.make modulesDir (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) []
340− case e of
341− Left errs -> printErrors errs
342− Right _ -> do
343− PSCI $ lift $ put st
344− return ()
345−
346−-- |
347−-- Takes a value and prints its type
348−--
349−handleTypeOf :: P.Expr -> PSCI ()
350−handleTypeOf val = do
351− st <- PSCI $ lift get
352− let m = createTemporaryModule False st val
353− e <- psciIO . runMake $ P.make modulesDir (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) []
354− case e of
355− Left errs -> printErrors errs
356− Right env' ->
357− case M.lookup (P.ModuleName [P.ProperName "$PSCI"], P.Ident "it") (P.names env') of
358− Just (ty, _, _) -> PSCI . outputStrLn . P.prettyPrintType $ ty
359− Nothing -> PSCI $ outputStrLn "Could not find type"
360−
361−-- |
362−-- Pretty print a module's signatures
363−--
364−printModuleSignatures :: P.ModuleName -> P.Environment -> PSCI ()
365−printModuleSignatures moduleName env =
366− PSCI $ let namesEnv = P.names env
367− moduleNamesIdent = (filter ((== moduleName) . fst) . M.keys) namesEnv
368− in case moduleNamesIdent of
369− [] -> outputStrLn $ "This module '"++ P.runModuleName moduleName ++"' does not export functions."
370− _ -> ( outputStrLn
371− . unlines
372− . sort
373− . map (showType . findType namesEnv)) moduleNamesIdent
374− 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))
375− findType envNames m@(_, mIdent) = (mIdent, M.lookup m envNames)
376− showType :: (P.Ident, Maybe (P.Type, P.NameKind, P.NameVisibility)) -> String
377− showType (mIdent, Just (mType, _, _)) = show mIdent ++ " :: " ++ P.prettyPrintType mType
378− showType _ = error "The impossible happened in printModuleSignatures."
379−
380−-- |
381−-- Browse a module and displays its signature (if module exists).
382−--
383−handleBrowse :: P.ModuleName -> PSCI ()
384−handleBrowse moduleName = do
385− st <- PSCI $ lift get
386− let loadedModules = psciLoadedModules st
387− env <- psciIO . runMake $ P.make modulesDir loadedModules []
388− case env of
389− Left errs -> printErrors errs
390− Right env' ->
391− if moduleName `notElem` (nub . map ((\ (P.Module _ modName _ _ ) -> modName) . snd)) loadedModules
392− then PSCI $ outputStrLn $ "Module '" ++ N.runModuleName moduleName ++ "' is not valid."
393− else printModuleSignatures moduleName env'
394−
395−-- | Pretty-print errors
396−printErrors :: P.MultipleErrors -> PSCI ()
397−printErrors = PSCI . outputStrLn . P.prettyPrintMultipleErrors False
398−
399−-- |
400−-- Takes a value and prints its kind
401−--
402−handleKindOf :: P.Type -> PSCI ()
403−handleKindOf typ = do
404− st <- PSCI $ lift get
405− let m = createTemporaryModuleForKind st typ
406− mName = P.ModuleName [P.ProperName "$PSCI"]
407− e <- psciIO . runMake $ P.make modulesDir (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) []
408− case e of
409− Left errs -> printErrors errs
410− Right env' ->
411− case M.lookup (P.Qualified (Just mName) $ P.ProperName "IT") (P.typeSynonyms env') of
412− Just (_, typ') -> do
413− let chk = P.CheckState env' 0 0 (Just mName)
414− k = L.runStateT (P.unCheck (P.kindOf mName typ')) chk
415− case k of
416− Left errStack -> PSCI . outputStrLn . P.prettyPrintMultipleErrors False $ errStack
417− Right (kind, _) -> PSCI . outputStrLn . P.prettyPrintKind $ kind
418− Nothing -> PSCI $ outputStrLn "Could not find kind"
419−
420−-- Commands
421−
422−-- |
423−-- Parses the input and returns either a Metacommand, or an error as a string.
424−--
425−getCommand :: Bool -> InputT (StateT PSCiState IO) (Either String (Maybe Command))
426−getCommand singleLineMode = do
427− firstLine <- getInputLine "> "
428− case firstLine of
429− Nothing -> return (Right Nothing)
430− Just "" -> return (Right Nothing)
431− Just s | singleLineMode || head s == ':' -> return . either Left (Right . Just) $ parseCommand s
432− Just s -> either Left (Right . Just) . parseCommand <$> go [s]
433− where
434− go :: [String] -> InputT (StateT PSCiState IO) String
435− go ls = maybe (return . unlines $ reverse ls) (go . (:ls)) =<< getInputLine " "
436−
437−-- |
438−-- Performs an action for each meta-command given, and also for expressions.
439−--
440−handleCommand :: Command -> PSCI ()
441−handleCommand (Expression val) = handleDeclaration val
442−handleCommand ShowHelp = PSCI $ outputStrLn helpMessage
443−handleCommand (Import im) = handleImport im
444−handleCommand (Decls l) = handleDecls l
445−handleCommand (LoadFile filePath) = do
446− absPath <- psciIO $ expandTilde filePath
447− exists <- psciIO $ doesFileExist absPath
448− if exists then do
449− PSCI . lift $ modify (updateImportedFiles absPath)
450− m <- psciIO $ loadModule absPath
451− case m of
452− Left err -> PSCI $ outputStrLn err
453− Right mods -> PSCI . lift $ modify (updateModules (map ((,) (Right absPath)) mods))
454− else
455− PSCI . outputStrLn $ "Couldn't locate: " ++ filePath
456−handleCommand ResetState = do
457− files <- psciImportedFilenames <$> PSCI (lift get)
458− PSCI . lift . modify $ \st -> st
459− { psciImportedFilenames = files
460− , psciImportedModules = defaultImports
461− , psciLetBindings = []
462− }
463− loadAllImportedModules
464−handleCommand (TypeOf val) = handleTypeOf val
465−handleCommand (KindOf typ) = handleKindOf typ
466−handleCommand (BrowseModule moduleName) = handleBrowse moduleName
467−handleCommand (ShowInfo QueryLoaded) = handleShowLoadedModules
468−handleCommand (ShowInfo QueryImport) = handleShowImportedModules
469−handleCommand QuitPSCi = error "`handleCommand QuitPSCi` was called. This is a bug."
470−
471−loadUserConfig :: IO (Maybe [Command])
472−loadUserConfig = do
473− configFile <- (</> ".psci") <$> getCurrentDirectory
474− exists <- doesFileExist configFile
475− if exists
476− then do
477− ls <- lines <$> readFile configFile
478− case mapM parseCommand ls of
479− Left err -> print err >> exitFailure
480− Right cs -> return $ Just cs
481− else
482− return Nothing
483−
484−-- |
485−-- The PSCI main loop.
486−--
487−loop :: PSCiOptions -> IO ()
488−loop PSCiOptions{..} = do
489− config <- loadUserConfig
490− modulesOrFirstError <- loadAllModules psciInputFile
491− case modulesOrFirstError of
492− Left err -> print err >> exitFailure
493− Right modules -> do
494− historyFilename <- getHistoryFilename
495− let settings = defaultSettings { historyFile = Just historyFilename }
496− flip evalStateT (PSCiState psciInputFile defaultImports modules [] psciInputNodeFlags) . runInputT (setComplete completion settings) $ do
497− outputStrLn prologueMessage
498− traverse_ (mapM_ (runPSCI . handleCommand)) config
499− go
500− where
501− go :: InputT (StateT PSCiState IO) ()
502− go = do
503− c <- getCommand (not psciMultiLineMode)
504− case c of
505− Left err -> outputStrLn err >> go
506− Right Nothing -> go
507− Right (Just QuitPSCi) -> outputStrLn quitMessage
508− Right (Just c') -> runPSCI (loadAllImportedModules >> handleCommand c') >> go
509−
510−multiLineMode :: Parser Bool
511−multiLineMode = switch $
512− long "multi-line-mode"
513− <> short 'm'
514− <> Opts.help "Run in multi-line mode (use ^D to terminate commands)"
515−
516−inputFile :: Parser FilePath
517−inputFile = strArgument $
518− metavar "FILE"
519− <> Opts.help "Optional .purs files to load on start"
520−
521−nodeFlagsFlag :: Parser [String]
522−nodeFlagsFlag = option parser $
523− long "node-opts"
524− <> metavar "NODE_OPTS"
525− <> value []
526− <> Opts.help "Flags to pass to node, separated by spaces"
527− where
528− parser = words <$> str
529−
530−psciOptions :: Parser PSCiOptions
531−psciOptions = PSCiOptions <$> multiLineMode
532− <*> many inputFile
533− <*> nodeFlagsFlag
534−
535−runPSCi :: IO ()
536−runPSCi = execParser opts >>= loop
537− where
538− opts = info (version <*> helper <*> psciOptions) infoModList
539− infoModList = fullDesc <> headerInfo <> footerInfo
540− headerInfo = header "psci - Interactive mode for PureScript"
541− footerInfo = footer $ "psci " ++ showVersion Paths.version
542−
543− version :: Parser (a -> a)
544− version = abortOption (InfoMsg (showVersion Paths.version)) $ long "version" <> Opts.help "Show the version number" <> hidden
psci/Parser.hsdeleted−139
@@ -1,139 +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 Data.Char (isSpace)
23−import Data.List (intercalate)
24−
25−import Control.Applicative hiding (many)
26−
27−import Text.Parsec hiding ((<|>))
28−
29−import qualified Language.PureScript as P
30−import Language.PureScript.Parser.Common (mark, same)
31−
32−import qualified Directive as D
33−import Types
34−
35−-- |
36−-- Parses PSCI metacommands or expressions input from the user.
37−--
38−parseCommand :: String -> Either String Command
39−parseCommand cmdString =
40− case cmdString of
41− (':' : cmd) -> parseDirective cmd
42− _ -> parseRest psciCommand cmdString
43−
44−parseRest :: P.TokenParser a -> String -> Either String a
45−parseRest p s = either (Left . show) Right $ do
46− ts <- P.lex "" s
47− P.runTokenParser "" (p <* eof) ts
48−
49−psciCommand :: P.TokenParser Command
50−psciCommand = choice (map try parsers)
51− where
52− parsers =
53− [ psciLet
54− , psciImport
55− , psciOtherDeclaration
56− , psciExpression
57− ]
58−
59−trim :: String -> String
60−trim = trimEnd . trimStart
61−
62−trimStart :: String -> String
63−trimStart = dropWhile isSpace
64−
65−trimEnd :: String -> String
66−trimEnd = reverse . trimStart . reverse
67−
68−parseDirective :: String -> Either String Command
69−parseDirective cmd =
70− case D.directivesFor' dstr of
71− [(d, _)] -> commandFor d
72− [] -> Left "Unrecognized directive. Type :? for help."
73− ds -> Left ("Ambiguous directive. Possible matches: " ++
74− intercalate ", " (map snd ds) ++ ". Type :? for help.")
75− where
76− (dstr, arg) = break isSpace cmd
77−
78− commandFor d = case d of
79− Help -> return ShowHelp
80− Quit -> return QuitPSCi
81− Reset -> return ResetState
82− Browse -> BrowseModule <$> parseRest P.moduleName arg
83− Load -> return $ LoadFile (trim arg)
84− Show -> ShowInfo <$> parseReplQuery' (trim arg)
85− Type -> TypeOf <$> parseRest P.parseValue arg
86− Kind -> KindOf <$> parseRest P.parseType arg
87−
88−-- |
89−-- Parses expressions entered at the PSCI repl.
90−--
91−psciExpression :: P.TokenParser Command
92−psciExpression = Expression <$> P.parseValue
93−
94−-- |
95−-- PSCI version of @let@.
96−-- This is essentially let from do-notation.
97−-- However, since we don't support the @Eff@ monad,
98−-- we actually want the normal @let@.
99−--
100−psciLet :: P.TokenParser Command
101−psciLet = Decls <$> (P.reserved "let" *> P.indented *> manyDecls)
102− where
103− manyDecls :: P.TokenParser [P.Declaration]
104− manyDecls = mark (many1 (same *> P.parseLocalDeclaration))
105−
106−-- | Imports must be handled separately from other declarations, so that
107−-- :show import works, for example.
108−psciImport :: P.TokenParser Command
109−psciImport = Import <$> P.parseImportDeclaration'
110−
111−-- | Any other declaration that we don't need a 'special case' parser for
112−-- (like let or import declarations).
113−psciOtherDeclaration :: P.TokenParser Command
114−psciOtherDeclaration = Decls . (:[]) <$> do
115− decl <- discardPositionInfo <$> P.parseDeclaration
116− if acceptable decl
117− then return decl
118− else fail "this kind of declaration is not supported in psci"
119−
120−discardPositionInfo :: P.Declaration -> P.Declaration
121−discardPositionInfo (P.PositionedDeclaration _ _ d) = d
122−discardPositionInfo d = d
123−
124−acceptable :: P.Declaration -> Bool
125−acceptable (P.DataDeclaration _ _ _ _) = True
126−acceptable (P.TypeSynonymDeclaration _ _ _) = True
127−acceptable (P.ExternDeclaration _ _ _ _) = True
128−acceptable (P.ExternDataDeclaration _ _) = True
129−acceptable (P.ExternInstanceDeclaration _ _ _ _) = True
130−acceptable (P.TypeClassDeclaration _ _ _ _) = True
131−acceptable (P.TypeInstanceDeclaration _ _ _ _ _) = True
132−acceptable _ = False
133−
134−parseReplQuery' :: String -> Either String ReplQuery
135−parseReplQuery' str =
136− case parseReplQuery str of
137− Nothing -> Left ("Don't know how to show " ++ str ++ ". Try one of: " ++
138− intercalate ", " replQueryStrings ++ ".")
139− Just query -> Right query
psci/Types.hsdeleted−167
@@ -1,167 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Types
4−-- Copyright : (c) Phil Freeman 2014
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- |
12−-- Type declarations and associated basic functions for PSCI.
13−--
14−-----------------------------------------------------------------------------
15−
16−module Types where
17−
18−import qualified Language.PureScript as P
19−
20−data PSCiOptions = PSCiOptions
21− { psciMultiLineMode :: Bool
22− , psciInputFile :: [FilePath]
23− , psciInputNodeFlags :: [String]
24− }
25−
26−-- |
27−-- The PSCI state.
28−-- Holds a list of imported modules, loaded files, and partial let bindings.
29−-- The let bindings are partial,
30−-- because it makes more sense to apply the binding to the final evaluated expression.
31−--
32−data PSCiState = PSCiState
33− { psciImportedFilenames :: [FilePath]
34− , psciImportedModules :: [ImportedModule]
35− , psciLoadedModules :: [(Either P.RebuildPolicy FilePath, P.Module)]
36− , psciLetBindings :: [P.Declaration]
37− , psciNodeFlags :: [String]
38− }
39−
40−-- | All of the data that is contained by an ImportDeclaration in the AST.
41−-- That is:
42−--
43−-- * A module name, the name of the module which is being imported
44−-- * An ImportDeclarationType which specifies whether there is an explicit
45−-- import list, a hiding list, or neither.
46−-- * If the module is imported qualified, its qualified name in the importing
47−-- module. Otherwise, Nothing.
48−--
49−type ImportedModule = (P.ModuleName, P.ImportDeclarationType, Maybe P.ModuleName)
50−
51−psciImportedModuleNames :: PSCiState -> [P.ModuleName]
52−psciImportedModuleNames (PSCiState{psciImportedModules = is}) =
53− map (\(mn, _, _) -> mn) is
54−
55−allImportsOf :: P.Module -> PSCiState -> [ImportedModule]
56−allImportsOf m (PSCiState{psciImportedModules = is}) =
57− filter isImportOfThis is
58− where
59− name = P.getModuleName m
60− isImportOfThis (name', _, _) = name == name'
61−
62−-- State helpers
63−
64−-- |
65−-- Updates the state to have more imported modules.
66−--
67−updateImportedFiles :: FilePath -> PSCiState -> PSCiState
68−updateImportedFiles filename st = st { psciImportedFilenames = filename : psciImportedFilenames st }
69−
70−-- |
71−-- Updates the state to have more imported modules.
72−--
73−updateImportedModules :: ImportedModule -> PSCiState -> PSCiState
74−updateImportedModules im st = st { psciImportedModules = im : psciImportedModules st }
75−
76−-- |
77−-- Updates the state to have more loaded files.
78−--
79−updateModules :: [(Either P.RebuildPolicy FilePath, P.Module)] -> PSCiState -> PSCiState
80−updateModules modules st = st { psciLoadedModules = psciLoadedModules st ++ modules }
81−
82−-- |
83−-- Updates the state to have more let bindings.
84−--
85−updateLets :: [P.Declaration] -> PSCiState -> PSCiState
86−updateLets ds st = st { psciLetBindings = psciLetBindings st ++ ds }
87−
88−-- |
89−-- Valid Meta-commands for PSCI
90−--
91−data Command
92− -- |
93− -- A purescript expression
94− --
95− = Expression P.Expr
96− -- |
97− -- Show the help (ie, list of directives)
98− --
99− | ShowHelp
100− -- |
101− -- Import a module from a loaded file
102− --
103− | Import ImportedModule
104− -- |
105− -- Browse a module
106− --
107− | BrowseModule P.ModuleName
108− -- |
109− -- Load a file for use with importing
110− --
111− | LoadFile FilePath
112− -- |
113− -- Exit PSCI
114− --
115− | QuitPSCi
116− -- |
117− -- Reset the state of the REPL
118− --
119− | ResetState
120− -- |
121− -- Add some declarations to the current evaluation context.
122− --
123− | Decls [P.Declaration]
124− -- |
125− -- Find the type of an expression
126− --
127− | TypeOf P.Expr
128− -- |
129− -- Find the kind of an expression
130− --
131− | KindOf P.Type
132− -- |
133− -- Shows information about the current state of the REPL
134− --
135− | ShowInfo ReplQuery
136−
137−data ReplQuery
138− = QueryLoaded
139− | QueryImport
140− deriving (Eq, Show)
141−
142−-- | A list of all ReplQuery values.
143−replQueries :: [ReplQuery]
144−replQueries = [QueryLoaded, QueryImport]
145−
146−replQueryStrings :: [String]
147−replQueryStrings = map showReplQuery replQueries
148−
149−showReplQuery :: ReplQuery -> String
150−showReplQuery QueryLoaded = "loaded"
151−showReplQuery QueryImport = "import"
152−
153−parseReplQuery :: String -> Maybe ReplQuery
154−parseReplQuery "loaded" = Just QueryLoaded
155−parseReplQuery "import" = Just QueryImport
156−parseReplQuery _ = Nothing
157−
158−data Directive
159− = Help
160− | Quit
161− | Reset
162− | Browse
163− | Load
164− | Type
165− | Kind
166− | Show
167− deriving (Eq, Show)
psci/main/Main.hsdeleted−6
@@ -1,6 +0,0 @@
1−module Main where
2−
3−import PSCi
4−
5−main :: IO ()
6−main = runPSCi
psci/tests/Main.hsdeleted−137
@@ -1,137 +0,0 @@
1−{-# LANGUAGE RecordWildCards #-}
2−
3−module Main where
4−
5−import Control.Monad.Trans.State.Strict (runStateT)
6−import Control.Monad (when)
7−
8−import System.Exit (exitFailure)
9−import System.Console.Haskeline
10−
11−import Test.HUnit
12−
13−import qualified Language.PureScript as P
14−
15−import PSCi
16−import Completion
17−import Types
18−
19−main :: IO ()
20−main = do
21− Counts{..} <- runTestTT allTests
22− when (errors + failures > 0) exitFailure
23−
24−allTests :: Test
25−allTests = completionTests
26−
27−completionTests :: Test
28−completionTests =
29− TestLabel "completionTests"
30− (TestList (map (TestCase . assertCompletedOk) completionTestData))
31−
32−-- If the cursor is at the right end of the line, with the 1st element of the
33−-- pair as the text in the line, then pressing tab should offer all the
34−-- elements of the list (which is the 2nd element) as completions.
35−completionTestData :: [(String, [String])]
36−completionTestData =
37− -- basic directives
38− [ (":h", [":help"])
39− , (":re", [":reset"])
40− , (":q", [":quit"])
41− , (":mo", [":module"])
42− , (":b", [":browse"])
43−
44− -- :browse should complete modules
45− , (":b Prel", [":b Prelude", ":b Prelude.Unsafe"])
46− , (":b Prelude.", [":b Prelude.Unsafe"])
47−
48− -- :load, :module should complete file paths
49− , (":l psci/tests/data/", [":l psci/tests/data/Sample.purs"])
50− , (":module psci/tests/data/", [":module psci/tests/data/Sample.purs"])
51−
52− -- :quit, :help, :reset should not complete
53− , (":help ", [])
54− , (":quit ", [])
55− , (":reset ", [])
56−
57− -- :show should complete to "loaded" and "import"
58− , (":show ", [":show import", ":show loaded"])
59− , (":show a", [])
60−
61− -- :type should complete values and data constructors in scope
62− , (":type Prelude.Unsafe.un", [":type Prelude.Unsafe.unsafeIndex"])
63− , (":type un", [":type unit"])
64− , (":type E", [":type EQ"])
65−
66− -- :kind should complete types in scope
67− , (":kind C", [":kind Control.Monad.Eff.Pure"])
68− , (":kind O", [":kind Ordering"])
69−
70− -- Only one argument for directives should be completed
71− , (":show import ", [])
72− , (":type EQ ", [])
73− , (":kind Ordering ", [])
74−
75− -- import should complete module names
76− , ("import Control.Monad.S", ["import Control.Monad.ST"])
77− , ("import qualified Control.Monad.S", ["import qualified Control.Monad.ST"])
78− , ("import Control.Monad.", map ("import Control.Monad." ++)
79− ["Eff", "Eff.Unsafe", "ST"])
80−
81− -- a few other import tests
82− , ("impor", ["import"])
83− , ("import q", ["import qualified"])
84− , ("import ", map ("import " ++) allModuleNames ++ ["import qualified"])
85− , ("import Prelude.Unsafe ", [])
86−
87− -- String and number literals should not be completed
88− , ("\"hi", [])
89− , ("34", [])
90−
91− -- Identifiers and data constructors should be completed
92− , ("un", ["unit"])
93− , ("Debug.Trace.", map ("Debug.Trace." ++) ["print", "trace"])
94− , ("G", ["GT"])
95− , ("Prelude.L", ["Prelude.LT"])
96−
97− -- if a module is imported qualified, values should complete under the
98− -- qualified name, as well as the original name.
99− , ("ST.new", ["ST.newSTRef"])
100− , ("Control.Monad.ST.new", ["Control.Monad.ST.newSTRef"])
101− ]
102− where
103− allModuleNames = [ "Control.Monad.Eff"
104− , "Control.Monad.Eff.Unsafe"
105− , "Control.Monad.ST"
106− , "Data.Function"
107− , "Debug.Trace"
108− , "Prelude"
109− , "Prelude.Unsafe"
110− ]
111−
112−assertCompletedOk :: (String, [String]) -> Assertion
113−assertCompletedOk (line, expecteds) = do
114− (unusedR, completions) <- runCM (completion' (reverse line, ""))
115− let unused = reverse unusedR
116− let actuals = map ((unused ++) . replacement) completions
117− expecteds @=? actuals
118−
119−runCM :: CompletionM a -> IO a
120−runCM act = do
121− psciState <- getPSCiState
122− fmap fst (runStateT (liftCompletionM act) psciState)
123−
124−getPSCiState :: IO PSCiState
125−getPSCiState = do
126− modulesOrFirstError <- loadAllModules []
127− case modulesOrFirstError of
128− Left err ->
129− print err >> exitFailure
130− Right modules ->
131− let imports = controlMonadSTasST : defaultImports
132− in return (PSCiState [] imports modules [] [])
133−
134−controlMonadSTasST :: ImportedModule
135−controlMonadSTasST = (s "Control.Monad.ST", P.Implicit, Just (s "ST"))
136− where
137− s = P.moduleNameFromString
psci/tests/data/Sample.pursdeleted

No changes to the content.

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−198
@@ -1,198 +0,0 @@
1−name: purescript
2−version: 0.7.0.0
3−cabal-version: >=1.8
4−build-type: Simple
5−license: MIT
6−license-file: LICENSE
7−copyright: (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
8−maintainer: Phil Freeman <paf31@cantab.net>
9−stability: experimental
10−synopsis: PureScript Programming Language Compiler
11−description: A small strongly, statically typed programming language with expressive types, inspired by Haskell and compiling to Javascript.
12−category: Language
13−Homepage: http://www.purescript.org/
14−author: Phil Freeman <paf31@cantab.net>,
15− Gary Burgess <gary.burgess@gmail.com>,
16− Hardy Jones <jones3.hardy@gmail.com>
17−
18−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 && < 0.5,
35− transformers-compat >= 0.3.0,
36− utf8-string >= 1 && < 2,
37− pattern-arrows >= 0.0.2 && < 0.1,
38− time -any,
39− boxes >= 0.1.4 && < 0.2.0
40− exposed-modules: Language.PureScript
41− Language.PureScript.AST
42− Language.PureScript.AST.Binders
43− Language.PureScript.AST.Declarations
44− Language.PureScript.AST.Operators
45− Language.PureScript.AST.SourcePos
46− Language.PureScript.AST.Traversals
47− Language.PureScript.CodeGen
48− Language.PureScript.CodeGen.Externs
49− Language.PureScript.CodeGen.JS
50− Language.PureScript.CodeGen.JS.AST
51− Language.PureScript.CodeGen.JS.Common
52− Language.PureScript.CodeGen.JS.Optimizer
53− Language.PureScript.CodeGen.JS.Optimizer.Blocks
54− Language.PureScript.CodeGen.JS.Optimizer.Common
55− Language.PureScript.CodeGen.JS.Optimizer.Inliner
56− Language.PureScript.CodeGen.JS.Optimizer.MagicDo
57− Language.PureScript.CodeGen.JS.Optimizer.TCO
58− Language.PureScript.CodeGen.JS.Optimizer.Unused
59− Language.PureScript.Constants
60− Language.PureScript.CoreFn
61− Language.PureScript.CoreFn.Ann
62− Language.PureScript.CoreFn.Binders
63− Language.PureScript.CoreFn.Desugar
64− Language.PureScript.CoreFn.Expr
65− Language.PureScript.CoreFn.Literals
66− Language.PureScript.CoreFn.Meta
67− Language.PureScript.CoreFn.Module
68− Language.PureScript.CoreFn.Traversals
69− Language.PureScript.Comments
70− Language.PureScript.DeadCodeElimination
71− Language.PureScript.Environment
72− Language.PureScript.Errors
73− Language.PureScript.Kinds
74− Language.PureScript.Linter
75− Language.PureScript.ModuleDependencies
76− Language.PureScript.Names
77− Language.PureScript.Options
78− Language.PureScript.Parser
79− Language.PureScript.Parser.Lexer
80− Language.PureScript.Parser.Common
81− Language.PureScript.Parser.Declarations
82− Language.PureScript.Parser.Kinds
83− Language.PureScript.Parser.State
84− Language.PureScript.Parser.Types
85− Language.PureScript.Pretty
86− Language.PureScript.Pretty.Common
87− Language.PureScript.Pretty.JS
88− Language.PureScript.Pretty.Kinds
89− Language.PureScript.Pretty.Types
90− Language.PureScript.Pretty.Values
91− Language.PureScript.Renamer
92− Language.PureScript.Sugar
93− Language.PureScript.Sugar.BindingGroups
94− Language.PureScript.Sugar.CaseDeclarations
95− Language.PureScript.Sugar.DoNotation
96− Language.PureScript.Sugar.Names
97− Language.PureScript.Sugar.ObjectWildcards
98− Language.PureScript.Sugar.Operators
99− Language.PureScript.Sugar.TypeClasses
100− Language.PureScript.Sugar.TypeDeclarations
101− Language.PureScript.Traversals
102− Language.PureScript.TypeChecker
103− Language.PureScript.TypeChecker.Entailment
104− Language.PureScript.TypeChecker.Kinds
105− Language.PureScript.TypeChecker.Monad
106− Language.PureScript.TypeChecker.Rows
107− Language.PureScript.TypeChecker.Skolems
108− Language.PureScript.TypeChecker.Subsumption
109− Language.PureScript.TypeChecker.Synonyms
110− Language.PureScript.TypeChecker.Types
111− Language.PureScript.TypeChecker.Unify
112− Language.PureScript.TypeClassDictionaries
113− Language.PureScript.Types
114−
115− Control.Monad.Unify
116− Control.Monad.Supply
117− Control.Monad.Supply.Class
118− exposed: True
119− buildable: True
120− hs-source-dirs: src
121− other-modules: Paths_purescript
122− ghc-options: -Wall -O2
123−
124−executable psc
125− build-depends: base >=4 && <5, containers -any, directory -any, filepath -any,
126− mtl -any, optparse-applicative >= 0.10.0, parsec -any, purescript -any,
127− transformers -any
128− main-is: Main.hs
129− buildable: True
130− hs-source-dirs: psc
131− other-modules:
132− ghc-options: -Wall -O2 -fno-warn-unused-do-bind
133−
134−executable psc-make
135− build-depends: base >=4 && <5, containers -any, directory -any, filepath -any,
136− mtl -any, optparse-applicative >= 0.10.0, parsec -any, purescript -any,
137− transformers -any, transformers-compat -any
138− main-is: Main.hs
139− buildable: True
140− hs-source-dirs: psc-make
141− other-modules:
142− ghc-options: -Wall -O2 -fno-warn-unused-do-bind
143−
144−executable psci
145− build-depends: base >=4 && <5, containers -any, directory -any, filepath -any,
146− mtl -any, optparse-applicative >= 0.10.0, parsec -any,
147− haskeline >= 0.7.0.0, purescript -any, transformers -any,
148− transformers-compat -any, process -any
149−
150− main-is: Main.hs
151− buildable: True
152− hs-source-dirs: psci psci/main
153− other-modules: Types
154− Parser
155− Directive
156− Completion
157− PSCi
158− ghc-options: -Wall -O2
159−
160−executable psc-docs
161− build-depends: base >=4 && <5, purescript -any,
162− optparse-applicative >= 0.10.0, process -any, mtl -any
163− main-is: Main.hs
164− buildable: True
165− hs-source-dirs: psc-docs
166− other-modules: Ctags
167− Etags
168− Tags
169− ghc-options: -Wall -O2
170−
171−executable psc-hierarchy
172− build-depends: base >=4 && <5, purescript -any, optparse-applicative >= 0.10.0,
173− process -any, mtl -any, parsec -any, filepath -any, directory -any
174− main-is: Main.hs
175− buildable: True
176− hs-source-dirs: hierarchy
177− other-modules:
178− ghc-options: -Wall -O2
179−
180−test-suite tests
181− build-depends: base >=4 && <5, containers -any, directory -any,
182− filepath -any, mtl -any, parsec -any, purescript -any,
183− transformers -any, process -any
184− type: exitcode-stdio-1.0
185− main-is: Main.hs
186− buildable: True
187− hs-source-dirs: tests
188−
189−test-suite psci-tests
190− build-depends: base >=4 && <5, containers -any, directory -any, filepath -any,
191− mtl -any, optparse-applicative >= 0.10.0, parsec -any,
192− haskeline >= 0.7.0.0, purescript -any, transformers -any,
193− transformers-compat -any, process -any, HUnit -any
194− type: exitcode-stdio-1.0
195− main-is: Main.hs
196− buildable: True
197− hs-source-dirs: psci psci/tests
198− ghc-options: -Wall
src/CodeGen/IL.hsnew file+321
@@ -0,0 +1,321 @@
1+-- | This module generates code in the core imperative representation from
2+-- elaborated PureScript code.
3+module CodeGen.IL
4+ ( module AST
5+ , module Common
6+ , moduleToIL
7+ ) where
8+
9+import Prelude.Compat
10+import Protolude (ordNub)
11+
12+import Control.Arrow ((&&&))
13+import Control.Monad (forM, liftM, replicateM, void)
14+import Control.Monad.Supply.Class
15+
16+import Data.List ((\\), delete, intersect, nub)
17+import qualified Data.Foldable as F
18+import qualified Data.Map as M
19+import Data.Maybe (fromMaybe, isNothing, mapMaybe)
20+import Data.Monoid ((<>))
21+import Data.String (fromString)
22+import Data.Text (Text)
23+import qualified Data.Text as T
24+
25+import Language.PureScript.AST.SourcePos
26+import Language.PureScript.CoreImp.AST (AST)
27+import qualified Language.PureScript.CoreImp.AST as AST
28+import Language.PureScript.CoreFn
29+import Language.PureScript.Crash
30+import Language.PureScript.Names
31+import Language.PureScript.Options
32+import Language.PureScript.PSString (PSString, mkString)
33+import Language.PureScript.Traversals (sndM)
34+import qualified Language.PureScript.Constants as C
35+
36+import System.FilePath.Posix ((</>))
37+
38+import CodeGen.IL.Common as Common
39+import CodeGen.IL.Optimizer
40+import CodeGen.IL.Printer
41+
42+data DeclType = ModuleDecl | LetDecl | RecLetDecl deriving (Eq)
43+
44+-- | Generate code in the simplified intermediate representation for all declarations in a
45+-- module.
46+moduleToIL
47+ :: forall m
48+ -- . (Monad m, MonadReader Options m, MonadSupply m, MonadError MultipleErrors m)
49+ . (Monad m, MonadSupply m)
50+ => Module Ann
51+ -> Text
52+ -> m (Text, [Text], [AST], Text, Text)
53+moduleToIL (Module _ coms mn _ imps _ foreigns decls) project =
54+ do
55+ ilDecls <- mapM (bindToIL ModuleDecl) decls
56+ optimized <- traverse (traverse (optimize modName')) ilDecls
57+ let optimized' = concat optimized
58+ values = annotValue <$> optimized'
59+ foreigns' = moduleIdentToIL <$> foreigns
60+ interface = interfaceSource modName values foreigns
61+ imports = nub . concat $ importToIL <$> optimized'
62+ implHeader = implHeaderSource modName imports project
63+ implFooter = implFooterSource (runModuleName mn) foreigns
64+ return $ (interface, foreigns', optimized', implHeader, implFooter)
65+ where
66+ modName = moduleNameToIL mn
67+ modName' = AST.Var Nothing modName
68+
69+ annotValue :: AST -> (Text, Bool)
70+ annotValue (AST.Function _ (Just name) [] (AST.Block _ [AST.Return _ ret]))
71+ | isLiteral ret = (name, True)
72+ annotValue (AST.Function _ (Just name) [] _) = (name, False)
73+ annotValue _ = error "Unexpected top-level value form"
74+
75+ -- | Extracts all declaration names from a binding group.
76+ getNames :: Bind Ann -> [Ident]
77+ getNames (NonRec _ ident _) = [ident]
78+ getNames (Rec vals) = map (snd . fst) vals
79+
80+ -- | Generates IL code for a module import
81+ --
82+ importToIL :: AST -> [Text]
83+ importToIL = AST.everything (++) modRef
84+ where
85+ modRef (AST.Indexer _ (AST.Var _ _) (AST.Var _ mname))
86+ | not $ T.null mname = [extract mname]
87+ modRef _ = []
88+ extract :: Text -> Text
89+ extract = T.replace "_" "." . T.dropWhileEnd (=='_')
90+
91+ -- |
92+ -- Generate code in the simplified intermediate representation for a declaration
93+ --
94+ bindToIL :: DeclType -> Bind Ann -> m [AST]
95+ bindToIL dt (NonRec ann ident val) = return <$> nonRecToIL dt ann ident val
96+ bindToIL dt (Rec vals) = forM vals (uncurry . uncurry $ nonRecToIL dt')
97+ where
98+ dt' = if dt == LetDecl then RecLetDecl else dt
99+
100+ -- | Generate code in the simplified intermediate representation for a single non-recursive
101+ -- declaration.
102+ --
103+ -- The main purpose of this function is to handle code generation for comments.
104+ nonRecToIL :: DeclType -> Ann -> Ident -> Expr Ann -> m AST
105+ nonRecToIL dt a i e@(extractAnn -> (_, com, _, _)) | not (null com) = do
106+ -- withoutComment <- asks optionsNoComments
107+ let withoutComment = False
108+ if withoutComment
109+ then nonRecToIL dt a i (modifyAnn removeComments e)
110+ else AST.Comment Nothing com <$> nonRecToIL dt a i (modifyAnn removeComments e)
111+ nonRecToIL ModuleDecl (ss, _, _, _) ident val = do
112+ il <- valueToIL val
113+ pure $ AST.Function Nothing (Just $ moduleIdentToIL ident) [] (AST.Block Nothing [AST.Return Nothing il])
114+ nonRecToIL RecLetDecl (ss, _, _, _) ident val = do
115+ ilExpr <- valueToIL val
116+ pure $ AST.Assignment Nothing (AST.Var Nothing $ identToIL ident) ilExpr
117+ nonRecToIL _ (ss, _, _, _) ident val = do
118+ il <- valueToIL val
119+ pure $ AST.VariableIntroduction Nothing (identToIL ident) (Just il)
120+
121+ -- | Generate code in the simplified intermediate representation for a variable based on a
122+ -- PureScript identifier.
123+ var :: Ident -> AST
124+ var = AST.Var Nothing . identToIL
125+
126+ accessorString :: PSString -> AST -> AST
127+ accessorString prop = AST.Indexer Nothing (AST.StringLiteral Nothing prop)
128+
129+ -- | Generate code in the simplified intermediate representation for a value or expression.
130+
131+ valueToIL :: Expr Ann -> m AST
132+ valueToIL (Literal (pos, _, _, _) l) = literalToValueIL pos l
133+ valueToIL (Accessor _ prop val) =
134+ accessorString prop <$> valueToIL val
135+ valueToIL (ObjectUpdate _ o ps) = do
136+ obj <- valueToIL o
137+ updates <- mapM (sndM valueToIL) ps
138+ obj' <- freshName'
139+ let objVar = AST.Var Nothing obj'
140+ copy = AST.VariableIntroduction Nothing obj' (Just $ copyDict obj)
141+ assign (k, v) = AST.Assignment Nothing (accessorString k objVar) v
142+ sts = copy : (assign <$> updates) ++ [AST.Return Nothing objVar]
143+ return $ AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing sts)) []
144+ valueToIL (Abs _ arg val) = do
145+ ret <- valueToIL val
146+ let ilArg = case arg of
147+ UnusedIdent -> []
148+ _ -> [identToIL arg]
149+ return $ AST.Function Nothing Nothing ilArg (AST.Block Nothing [AST.Return Nothing ret])
150+ valueToIL e@App{} = do
151+ let (f, args) = unApp e []
152+ args' <- mapM valueToIL args
153+ fn <- valueToIL f
154+ case f of
155+ Var (_, _, _, Just IsNewtype) _ -> return (head args')
156+ _ -> flip (foldl (\fn a -> AST.App Nothing fn [a])) args' <$> valueToIL f
157+ where
158+ unApp :: Expr Ann -> [Expr Ann] -> (Expr Ann, [Expr Ann])
159+ unApp (App _ val arg) args = unApp val (arg : args)
160+ unApp other args = (other, args)
161+ valueToIL (Var _ ident) = return $ varToIL ident
162+ valueToIL (Case (ss, _, _, _) values binders) = do
163+ vals <- mapM valueToIL values
164+ bindersToIL ss binders vals
165+ valueToIL (Let _ ds val) = do
166+ let recurs = concatMap getNames $ filter isRec ds
167+ recurDs = (\v -> AST.VariableIntroduction Nothing (identToIL v) Nothing) <$> recurs
168+ ds' <- concat <$> mapM (bindToIL LetDecl) ds
169+ ret <- valueToIL val
170+ return $ AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing (recurDs ++ ds' ++ [AST.Return Nothing ret]))) []
171+ where
172+ isRec :: Bind Ann -> Bool
173+ isRec (Rec _) = True
174+ isRec _ = False
175+ valueToIL (Constructor (_, _, _, Just IsNewtype) _ (ProperName ctor) _) = error "IsNewtype"
176+ valueToIL (Constructor _ _ (ProperName ctor) fields) =
177+ let body = AST.ObjectLiteral Nothing $ (mkString ctor, AST.BooleanLiteral Nothing True) :
178+ ((\field -> (mkString (identToIL field), var field)) `map` fields)
179+ fn = foldr (\f inner -> AST.Function Nothing Nothing [identToIL f] (AST.Block Nothing [AST.Return Nothing inner])) body fields
180+ in return fn
181+
182+
183+ iife :: Text -> [AST] -> AST
184+ iife v exprs = AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing $ exprs ++ [AST.Return Nothing $ AST.Var Nothing v])) []
185+
186+ literalToValueIL :: SourceSpan -> Literal (Expr Ann) -> m AST
187+ literalToValueIL ss (NumericLiteral (Left i)) = return $ AST.NumericLiteral (Just ss) (Left i)
188+ literalToValueIL ss (NumericLiteral (Right n)) = return $ AST.NumericLiteral (Just ss) (Right n)
189+ literalToValueIL ss (StringLiteral s) = return $ AST.StringLiteral (Just ss) s
190+ literalToValueIL ss (CharLiteral c) = return $ AST.StringLiteral (Just ss) (fromString [c])
191+ literalToValueIL ss (BooleanLiteral b) = return $ AST.BooleanLiteral (Just ss) b
192+ literalToValueIL ss (ArrayLiteral xs) = AST.ArrayLiteral (Just ss) <$> mapM valueToIL xs
193+ literalToValueIL ss (ObjectLiteral ps) = AST.ObjectLiteral (Just ss) <$> mapM (sndM valueToIL) ps
194+
195+ -- | Generate code in the simplified intermediate representation for a reference to a
196+ -- variable.
197+ varToIL :: Qualified Ident -> AST
198+ varToIL (Qualified Nothing ident) = var ident
199+ varToIL qual = qualifiedToIL id qual
200+
201+ -- | Generate code in the simplified intermediate representation for a reference to a
202+ -- variable that may have a qualified name.
203+ qualifiedToIL :: (a -> Ident) -> Qualified a -> AST
204+ qualifiedToIL f (Qualified (Just (ModuleName mn')) a) | mn' == C.prim = AST.Var Nothing . moduleIdentToIL $ f a
205+ qualifiedToIL f (Qualified (Just mn') a) | mn /= mn' = AST.Indexer Nothing (AST.Var Nothing . moduleIdentToIL $ f a) (AST.Var Nothing (moduleNameToIL mn'))
206+ qualifiedToIL f (Qualified _ a) = AST.Indexer Nothing (AST.Var Nothing . moduleIdentToIL $ f a) (AST.Var Nothing "")
207+
208+ -- foreignIdent :: Ident -> AST
209+ -- foreignIdent ident = accessorString (mkString $ runIdent ident) (AST.Var Nothing "$foreign")
210+
211+ -- | Generate code in the simplified intermediate representation for pattern match binders
212+ -- and guards.
213+ bindersToIL :: SourceSpan -> [CaseAlternative Ann] -> [AST] -> m AST
214+ bindersToIL ss binders vals = do
215+ valNames <- replicateM (length vals) freshName'
216+ let assignments = zipWith (AST.VariableIntroduction Nothing) valNames (map Just vals)
217+ ils <- forM binders $ \(CaseAlternative bs result) -> do
218+ ret <- guardsToIL result
219+ go valNames ret bs
220+ return $ AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing (assignments ++ concat ils ++ [AST.Throw Nothing (AST.StringLiteral Nothing $ mkString failedPatternMessage)])))
221+ []
222+ where
223+ go :: [Text] -> [AST] -> [Binder Ann] -> m [AST]
224+ go _ done [] = return done
225+ go (v:vs) done' (b:bs) = do
226+ done'' <- go vs done' bs
227+ binderToIL v done'' b
228+ go _ _ _ = internalError "Invalid arguments to bindersToIL"
229+
230+ failedPatternMessage :: Text
231+ failedPatternMessage = "Failed pattern match at " <> runModuleName mn <> " " <> displayStartEndPos ss
232+
233+ guardsToIL :: Either [(Guard Ann, Expr Ann)] (Expr Ann) -> m [AST]
234+ guardsToIL (Left gs) = traverse genGuard gs where
235+ genGuard (cond, val) = do
236+ cond' <- valueToIL cond
237+ val' <- valueToIL val
238+ return
239+ (AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo cond' (AST.BooleanLiteral Nothing True))
240+ (AST.Block Nothing [AST.Return Nothing val']) Nothing)
241+
242+ guardsToIL (Right v) = return . AST.Return Nothing <$> valueToIL v
243+
244+ -- | Generate code in the simplified intermediate representation for a pattern match
245+ -- binder.
246+ binderToIL :: Text -> [AST] -> Binder Ann -> m [AST]
247+ binderToIL _ done NullBinder{} = return done
248+ binderToIL varName done (LiteralBinder _ l) =
249+ literalToBinderIL varName done l
250+ binderToIL varName done (VarBinder _ ident) =
251+ return (AST.VariableIntroduction Nothing (identToIL ident) (Just (AST.Var Nothing varName)) : done)
252+ binderToIL varName done (ConstructorBinder (_, _, _, Just IsNewtype) _ _ [b]) =
253+ binderToIL varName done b
254+ binderToIL varName done (ConstructorBinder (_, _, _, Just (IsConstructor ctorType fields)) _ (Qualified _ (ProperName ctor)) bs) = do
255+ il <- go (zip fields bs) done
256+ return $ case ctorType of
257+ ProductType -> il
258+ SumType ->
259+ [AST.IfElse Nothing (AST.InstanceOf Nothing (AST.Var Nothing varName) (AST.StringLiteral Nothing (mkString ctor)))
260+ (AST.Block Nothing il)
261+ Nothing]
262+ where
263+ go :: [(Ident, Binder Ann)] -> [AST] -> m [AST]
264+ go [] done' = return done'
265+ go ((field, binder) : remain) done' = do
266+ argVar <- freshName'
267+ done'' <- go remain done'
268+ il <- binderToIL argVar done'' binder
269+ return (AST.VariableIntroduction Nothing argVar (Just $ accessorString (mkString $ identToIL field) $ AST.Var Nothing varName) : il)
270+
271+ binderToIL _ _ ConstructorBinder{} =
272+ internalError "binderToIL: Invalid ConstructorBinder in binderToIL"
273+ binderToIL varName done (NamedBinder _ ident binder) = do
274+ il <- binderToIL varName done binder
275+ return (AST.VariableIntroduction Nothing (identToIL ident) (Just (AST.Var Nothing varName)) : il)
276+
277+ literalToBinderIL :: Text -> [AST] -> Literal (Binder Ann) -> m [AST]
278+ literalToBinderIL varName done (NumericLiteral num) =
279+ return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.NumericLiteral Nothing num)) (AST.Block Nothing done) Nothing]
280+ literalToBinderIL varName done (CharLiteral c) =
281+ return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.StringLiteral Nothing (fromString [c]))) (AST.Block Nothing done) Nothing]
282+ literalToBinderIL varName done (StringLiteral str) =
283+ return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.StringLiteral Nothing str)) (AST.Block Nothing done) Nothing]
284+ literalToBinderIL varName done (BooleanLiteral True) =
285+ return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.BooleanLiteral Nothing True)) (AST.Block Nothing done) Nothing]
286+ literalToBinderIL varName done (BooleanLiteral False) =
287+ return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.BooleanLiteral Nothing False)) (AST.Block Nothing done) Nothing]
288+ -- return [AST.IfElse Nothing (AST.Unary Nothing AST.Not (AST.Var Nothing varName)) (AST.Block Nothing done) Nothing]
289+ literalToBinderIL varName done (ObjectLiteral bs) = go done bs
290+ where
291+ go :: [AST] -> [(PSString, Binder Ann)] -> m [AST]
292+ go done' [] = return done'
293+ go done' ((prop, binder):bs') = do
294+ propVar <- freshName'
295+ done'' <- go done' bs'
296+ il <- binderToIL propVar done'' binder
297+ return (AST.VariableIntroduction Nothing propVar (Just (accessorString prop (AST.Var Nothing varName))) : il)
298+ literalToBinderIL varName done (ArrayLiteral bs) = do
299+ il <- go done 0 bs
300+ return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo
301+ (arrayLength $ AST.Var Nothing varName)
302+ (AST.NumericLiteral Nothing (Left (fromIntegral $ length bs))))
303+ (AST.Block Nothing il) Nothing]
304+ where
305+ go :: [AST] -> Integer -> [Binder Ann] -> m [AST]
306+ go done' _ [] = return done'
307+ go done' index (binder:bs') = do
308+ elVar <- freshName'
309+ done'' <- go done' (index + 1) bs'
310+ il <- binderToIL elVar done'' binder
311+ return (AST.VariableIntroduction Nothing elVar (Just (AST.Indexer Nothing (AST.NumericLiteral Nothing (Left index)) (AST.Var Nothing varName))) : il)
312+
313+emptyAnn :: Ann
314+emptyAnn = (SourceSpan "" (SourcePos 0 0) (SourcePos 0 0), [], Nothing, Nothing)
315+
316+arrayLength :: AST -> AST
317+arrayLength a = AST.App Nothing (AST.Var Nothing arrayLengthFn) [a]
318+-- arrayLength a = AST.Var Nothing (arrayLengthFn <> "(" <> prettyPrintIL1 a <> ")")
319+
320+copyDict :: AST -> AST
321+copyDict a = AST.App Nothing (AST.Var Nothing copyDictFn) [a]
src/CodeGen/IL/Common.hsnew file+196
@@ -0,0 +1,196 @@
1+-- | Common code generation utility functions
2+module CodeGen.IL.Common where
3+
4+import Prelude.Compat
5+
6+import Control.Monad.Supply.Class (MonadSupply, freshName)
7+import Data.Char
8+import Data.Maybe (maybe)
9+import Data.Monoid ((<>))
10+import Data.Text (Text)
11+import qualified Data.Text as T
12+
13+import Language.PureScript.Crash
14+import Language.PureScript.Names
15+
16+import qualified Language.PureScript.Constants as C
17+
18+moduleNameToIL :: ModuleName -> Text
19+moduleNameToIL (ModuleName mn) =
20+ let name = T.replace "." "_" mn
21+ in if nameIsILBuiltIn name then (name <> moduleRenamerMarker) else name
22+
23+moduleNameToIL' :: ModuleName -> Text
24+moduleNameToIL' (ModuleName mn) = T.replace "_" "." mn
25+
26+-- | Convert an 'Ident' into a valid IL identifier:
27+--
28+-- * Alphanumeric characters are kept unmodified.
29+--
30+-- * Reserved IL identifiers are wrapped with '_'.
31+--
32+identToIL :: Ident -> Text
33+identToIL UnusedIdent = unusedName
34+identToIL (Ident "$__unused") = unusedName
35+identToIL (Ident name) | name == C.undefined = undefinedName -- Note: done in Printer.hs too
36+identToIL (Ident name) = properToIL name
37+identToIL (GenIdent _ _) = internalError "GenIdent in identToIL"
38+
39+moduleIdentToIL :: Ident -> Text
40+moduleIdentToIL UnusedIdent = unusedName
41+moduleIdentToIL (Ident name) | name == C.undefined = undefinedName
42+moduleIdentToIL (Ident name) = moduleProperToIL name
43+moduleIdentToIL (GenIdent _ _) = internalError "GenIdent in identToIL"
44+
45+undefinedName :: Text
46+undefinedName = "Undefined"
47+
48+unusedName :: Text
49+unusedName = "_"
50+
51+properToIL :: Text -> Text
52+properToIL name
53+ | nameIsILReserved name = "ˉ" <> name
54+ | otherwise = T.concatMap identCharToText name
55+
56+-- | Attempts to find a human-readable name for a symbol, if none has been specified returns the
57+-- ordinal value.
58+identCharToText :: Char -> Text
59+identCharToText 'ṩ' = "_ṩ"
60+identCharToText c | isAlphaNum c = T.singleton c
61+identCharToText '_' = "_"
62+identCharToText '\'' = "ꞌ" -- lowercase saltillo
63+identCharToText c = error (show (ord c)) -- TODO: should never occur now(?)
64+
65+moduleProperToIL :: Text -> Text
66+moduleProperToIL = T.concatMap identCharToText
67+
68+-- | Checks whether an identifier name is reserved in IL.
69+nameIsILReserved :: Text -> Bool
70+nameIsILReserved name =
71+ name `elem` ilAnyReserved
72+
73+-- | Checks whether a name matches a built-in value in IL.
74+nameIsILBuiltIn :: Text -> Bool
75+nameIsILBuiltIn name =
76+ name `elem`
77+ [ "Any"
78+ , "Apply"
79+ , "Contains"
80+ , "CopyDict"
81+ , "Dict"
82+ , "EffFn"
83+ , "Fn"
84+ , "Foreign"
85+ , "Get"
86+ , "Index"
87+ , "Is"
88+ , "Length"
89+ , "Once"
90+ , "Run"
91+ , "Undefined"
92+ ]
93+
94+ilAnyReserved :: [Text]
95+ilAnyReserved =
96+ concat
97+ [ ilKeywords
98+ , ilLiterals
99+ ]
100+
101+ilKeywords :: [Text]
102+ilKeywords =
103+ [ "break"
104+ , "case"
105+ , "chan"
106+ , "const"
107+ , "continue"
108+ , "default"
109+ , "defer"
110+ , "else"
111+ , "fallthrough"
112+ , "for"
113+ , "func"
114+ , "go"
115+ , "goto"
116+ , "if"
117+ , "import"
118+ , "interface"
119+ , "map"
120+ , "package"
121+ , "range"
122+ , "return"
123+ , "select"
124+ , "struct"
125+ , "switch"
126+ , "type"
127+ , "var"
128+ ]
129+
130+ilLiterals :: [Text]
131+ilLiterals =
132+ [ "init"
133+ , "nil"
134+ , "int"
135+ , "int8"
136+ , "int16"
137+ , "int32"
138+ , "int64"
139+ , "uint"
140+ , "uint8"
141+ , "uint16"
142+ , "uint32"
143+ , "uint64"
144+ , "uintptr"
145+ , "float32"
146+ , "float64"
147+ , "complex64"
148+ , "complex128"
149+ , "byte"
150+ , "rune"
151+ , "string"
152+ ]
153+
154+withPrefix :: Text -> Text
155+withPrefix s = "Ꞌ" <> s -- uppercase saltillo
156+
157+anyType :: Text
158+anyType = "Any"
159+
160+dictType :: Text
161+dictType = "Dict"
162+
163+arrayType :: Text
164+arrayType = "[]" <> anyType
165+
166+uncurriedFnType :: Int -> Text
167+uncurriedFnType i = "Fn" <> (T.pack . show $ i)
168+
169+int :: Text
170+int = "int"
171+
172+float :: Text
173+float = "float64"
174+
175+bool :: Text
176+bool = "bool"
177+
178+string :: Text
179+string = "string"
180+
181+arrayLengthFn :: Text
182+arrayLengthFn = "Length"
183+
184+indexFn :: Text
185+indexFn = "Index"
186+
187+copyDictFn :: Text
188+copyDictFn = "CopyDict"
189+
190+freshName' :: MonadSupply m => m Text
191+freshName' = do
192+ name <- freshName
193+ return $ T.replace "$" "ṩ" name
194+
195+moduleRenamerMarker :: Text
196+moduleRenamerMarker = "__"
src/CodeGen/IL/Optimizer.hsnew file+81
@@ -0,0 +1,81 @@
1+-- | This module optimizes code in the intermediate representation.
2+module CodeGen.IL.Optimizer (optimize) where
3+
4+import Prelude.Compat
5+
6+import Control.Monad.Supply.Class (MonadSupply)
7+import Data.Text (Text)
8+import Language.PureScript.CoreImp.AST
9+import Language.PureScript.CoreImp.Optimizer.Blocks
10+import Language.PureScript.CoreImp.Optimizer.Common hiding (isDict)
11+import Language.PureScript.CoreImp.Optimizer.Inliner (etaConvert, evaluateIifes, inlineVariables, unThunk)
12+import Language.PureScript.CoreImp.Optimizer.Unused
13+
14+import CodeGen.IL.Common (unusedName)
15+import CodeGen.IL.Optimizer.Inliner
16+import CodeGen.IL.Optimizer.MagicDo
17+import CodeGen.IL.Optimizer.TCO
18+
19+import qualified Language.PureScript.Constants as C
20+
21+-- | Apply a series of optimizer passes to simplified IL code
22+optimize :: MonadSupply m => AST -> AST -> m AST
23+optimize mn il = do
24+ il' <- untilFixedPoint (inlineFnComposition . inlineUnsafeCoerce . inlineUnsafePartial . tidyUp) il
25+ il'' <- untilFixedPoint (return . ignoreUnusedResults . inlineCommonValues . inlineCommonOperators . tidyUp) . tco mn . inlineST
26+ =<< untilFixedPoint (return . magicDoST)
27+ =<< untilFixedPoint (return . magicDoEff)
28+ =<< untilFixedPoint (return . magicDoEffect) il'
29+ untilFixedPoint (return . collapseVarDeclarations) il''
30+ where
31+ tidyUp :: AST -> AST
32+ tidyUp = applyAll
33+ [ collapseNestedBlocks
34+ , collapseNestedIfs
35+ , collapseIfChecks
36+ , removeCodeAfterReturnStatements
37+ , unThunk
38+ , etaConvert
39+ , evaluateIifes
40+ , inlineVariables
41+ ]
42+
43+untilFixedPoint :: (Monad m, Eq a) => (a -> m a) -> a -> m a
44+untilFixedPoint f = go
45+ where
46+ go a = do
47+ a' <- f a
48+ if a' == a then return a' else go a'
49+
50+collapseIfChecks :: AST -> AST
51+collapseIfChecks = everywhere collapse where
52+ collapse :: AST -> AST
53+ collapse (IfElse _ (Binary _ EqualTo (BooleanLiteral _ True) (BooleanLiteral _ True)) (Block _ [exprs]) _) = exprs
54+ collapse (IfElse _ (Binary _ EqualTo (Indexer _ (Var _ prop) (Var _ val)) (BooleanLiteral _ True)) (Block _ [exprs]) _)
55+ | prop == "otherwise" && val == "Data_Boolean" = exprs
56+ collapse exprs = exprs
57+
58+collapseVarDeclarations :: AST -> AST
59+collapseVarDeclarations = everywhere collapse where
60+ collapse :: AST -> AST
61+ collapse (Block ss sts) = Block ss (go Nothing sts)
62+ collapse s = s
63+
64+ go :: Maybe Text -> [AST] -> [AST]
65+ go _ [] = []
66+ go Nothing (decl@(VariableIntroduction _ var (Just _)) : sts) = decl : go (Just var) (go Nothing sts)
67+ go (Just var') ((VariableIntroduction ss var (Just val)) : sts)
68+ | var == var' = (Assignment ss (Var Nothing var) val) : go (Just var') sts
69+ go var' (s:sts) = s : go var' sts
70+
71+ignoreUnusedResults :: AST -> AST
72+ignoreUnusedResults = everywhere $ removeFromBlock go
73+ where
74+ go :: [AST] -> [AST]
75+ go [] = []
76+ go (VariableIntroduction ss var (Just s) : sts)
77+ | not $ any (everything (||) (isUsed var)) sts = sts'
78+ where
79+ sts' | App{} <- s = s : (go sts)
80+ | otherwise = go sts
81+ go (s:sts) = s : go sts
src/CodeGen/IL/Optimizer/Common.hsnew file+18
@@ -0,0 +1,18 @@
1+-- | Common functions used by the various optimizer phases
2+module CodeGen.IL.Optimizer.Common where
3+
4+import Prelude.Compat
5+
6+import Data.Text (Text)
7+
8+import Language.PureScript.CoreImp.AST
9+import Language.PureScript.PSString (PSString, decodeString)
10+
11+isDict :: (Text, PSString) -> AST -> Bool
12+isDict (moduleName, dictName) (Indexer _ (Var _ x) (Var _ y)) =
13+ Just x == decodeString dictName && y == moduleName
14+isDict _ _ = False
15+
16+isDict' :: [(Text, PSString)] -> AST -> Bool
17+isDict' xs il = any (`isDict` il) xs
18+
src/CodeGen/IL/Optimizer/Inliner.hsnew file+435
@@ -0,0 +1,435 @@
1+-- | This module performs basic inlining of known functions
2+module CodeGen.IL.Optimizer.Inliner
3+ ( inlineCommonValues
4+ , inlineCommonOperators
5+ , inlineFnComposition
6+ , inlineUnsafeCoerce
7+ , inlineUnsafePartial
8+ ) where
9+
10+import Prelude.Compat
11+
12+import Control.Monad.Supply.Class (MonadSupply)
13+
14+import Data.Either (rights)
15+import Data.Maybe (fromMaybe)
16+import Data.String (IsString, fromString)
17+import Data.Text (Text)
18+import qualified Data.Text as T
19+
20+import Language.PureScript.PSString (PSString, decodeString, mkString)
21+import Language.PureScript.CoreImp.AST
22+import Language.PureScript.CoreImp.Optimizer.Common hiding (isDict, isDict')
23+import Language.PureScript.AST (SourceSpan(..))
24+import qualified Language.PureScript.Constants as C
25+
26+import CodeGen.IL.Common
27+import CodeGen.IL.Optimizer.Common
28+
29+-- TODO: Potential bug:
30+-- Shouldn't just inline this case: { var x = 0; x.toFixed(10); }
31+-- Needs to be: { 0..toFixed(10); }
32+-- Probably needs to be fixed in pretty-printer instead.
33+shouldInline :: AST -> Bool
34+shouldInline (Var _ _) = True
35+shouldInline (NumericLiteral _ _) = True
36+shouldInline (StringLiteral _ _) = True
37+shouldInline (BooleanLiteral _ _) = True
38+shouldInline (Indexer _ index val) = shouldInline index && shouldInline val
39+shouldInline _ = False
40+
41+inlineCommonValues :: AST -> AST
42+inlineCommonValues = everywhere convert
43+ where
44+ convert :: AST -> AST
45+ convert (App ss fn [dict])
46+ | isDict' [semiringNumber, semiringInt] dict && isDict fnZero fn = NumericLiteral ss (Left 0)
47+ | isDict' [semiringNumber, semiringInt] dict && isDict fnOne fn = NumericLiteral ss (Left 1)
48+ | isDict boundedBoolean dict && isDict fnBottom fn = BooleanLiteral ss False
49+ | isDict boundedBoolean dict && isDict fnTop fn = BooleanLiteral ss True
50+ convert (App ss (App _ fn [dict]) [x])
51+ | isDict ringInt dict && isDict fnNegate fn = Unary ss Negate (unbox x $ snd ringInt)
52+ convert (App ss (App _ (App _ fn [dict]) [x]) [y])
53+ | isDict semiringInt dict && isDict fnAdd fn = intOp ss Add semiringInt x y
54+ | isDict semiringInt dict && isDict fnMultiply fn = intOp ss Multiply semiringInt x y
55+ | isDict ringInt dict && isDict fnSubtract fn = intOp ss Subtract ringInt x y
56+ convert other = other
57+ fnZero = (C.dataSemiring, C.zero)
58+ fnOne = (C.dataSemiring, C.one)
59+ fnBottom = (C.dataBounded, C.bottom)
60+ fnTop = (C.dataBounded, C.top)
61+ fnAdd = (C.dataSemiring, C.add)
62+ fnMultiply = (C.dataSemiring, C.mul)
63+ fnSubtract = (C.dataRing, C.sub)
64+ fnNegate = (C.dataRing, C.negate)
65+ intOp ss op (_, d) x y = Binary ss op (unbox x d) (unbox y d)
66+
67+inlineCommonOperators :: AST -> AST
68+inlineCommonOperators = everywhereTopDown $ applyAll $
69+ [ binary semiringNumber opAdd Add
70+ , binary semiringNumber opMul Multiply
71+
72+ , binary ringNumber opSub Subtract
73+ , unary ringNumber opNegate Negate
74+
75+ , binary euclideanRingNumber opDiv Divide
76+
77+ -- , binary eqNumber opEq EqualTo
78+ -- , binary eqNumber opNotEq NotEqualTo
79+ , binary eqInt opEq EqualTo
80+ , binary eqInt opNotEq NotEqualTo
81+ , binary eqString opEq EqualTo
82+ , binary eqString opNotEq NotEqualTo
83+ , binary eqChar opEq EqualTo
84+ , binary eqChar opNotEq NotEqualTo
85+ , binary eqBoolean opEq EqualTo
86+ , binary eqBoolean opNotEq NotEqualTo
87+
88+ , binary ordBoolean opLessThan LessThan
89+ , binary ordBoolean opLessThanOrEq LessThanOrEqualTo
90+ , binary ordBoolean opGreaterThan GreaterThan
91+ , binary ordBoolean opGreaterThanOrEq GreaterThanOrEqualTo
92+ , binary ordChar opLessThan LessThan
93+ , binary ordChar opLessThanOrEq LessThanOrEqualTo
94+ , binary ordChar opGreaterThan GreaterThan
95+ , binary ordChar opGreaterThanOrEq GreaterThanOrEqualTo
96+ , binary ordInt opLessThan LessThan
97+ , binary ordInt opLessThanOrEq LessThanOrEqualTo
98+ , binary ordInt opGreaterThan GreaterThan
99+ , binary ordInt opGreaterThanOrEq GreaterThanOrEqualTo
100+ , binary ordNumber opLessThan LessThan
101+ , binary ordNumber opLessThanOrEq LessThanOrEqualTo
102+ , binary ordNumber opGreaterThan GreaterThan
103+ , binary ordNumber opGreaterThanOrEq GreaterThanOrEqualTo
104+ , binary ordString opLessThan LessThan
105+ , binary ordString opLessThanOrEq LessThanOrEqualTo
106+ , binary ordString opGreaterThan GreaterThan
107+ , binary ordString opGreaterThanOrEq GreaterThanOrEqualTo
108+
109+ , binary semigroupString opAppend Add
110+
111+ , binary heytingAlgebraBoolean opConj And
112+ , binary heytingAlgebraBoolean opDisj Or
113+ , unary heytingAlgebraBoolean opNot Not
114+
115+ , binary' C.dataIntBits C.or BitwiseOr
116+ , binary' C.dataIntBits C.and BitwiseAnd
117+ , binary' C.dataIntBits C.xor BitwiseXor
118+ , binary' C.dataIntBits C.shl ShiftLeft
119+ , binary' C.dataIntBits C.shr ShiftRight
120+ , unary' C.dataIntBits C.complement BitwiseNot
121+
122+ , inlineNonClassFunction (isModFn (C.dataFunction, C.apply)) $ \f x -> App Nothing f [x]
123+ , inlineNonClassFunction (isModFn (C.dataFunction, C.applyFlipped)) $ \x f -> App Nothing f [x]
124+ , inlineUnsafeIndex (isModFnWithDict (C.dataArray, C.unsafeIndex)) $ flip (Indexer Nothing)
125+ ] ++
126+ [ fn | i <- [0..10], fn <- [ mkFn i, runFn i ] ] ++
127+ [ fn | i <- [0..10], fn <- [ mkEffFn C.controlMonadEffUncurried C.mkEffFn i, runEffFn C.controlMonadEffUncurried C.runEffFn i ] ] ++
128+ [ fn | i <- [0..10], fn <- [ mkEffFn C.effectUncurried C.mkEffectFn i, runEffFn C.effectUncurried C.runEffectFn i ] ]
129+ where
130+ binary :: (Text, PSString) -> (Text, PSString) -> BinaryOperator -> AST -> AST
131+ binary dict@(_, d) fns op = convert where
132+ convert :: AST -> AST
133+ convert (App ss (App _ (App _ fn [dict']) [x]) [y])
134+ | isDict dict dict' && isDict fns fn = Binary ss op (unbox x d) (unbox y d)
135+ convert other = other
136+ binary' :: Text -> PSString -> BinaryOperator -> AST -> AST
137+ binary' moduleName opString op = convert where
138+ convert :: AST -> AST
139+ convert (App ss (App _ fn [x]) [y]) | isDict (moduleName, opString) fn = Binary ss op (unbox x mn) (unbox y mn)
140+ convert other = other
141+ mn :: PSString
142+ mn = mkString moduleName
143+ unary :: (Text, PSString) -> (Text, PSString) -> UnaryOperator -> AST -> AST
144+ unary dicts@(_, d) fns op = convert where
145+ convert :: AST -> AST
146+ convert (App ss (App _ fn [dict']) [x]) | isDict dicts dict' && isDict fns fn = Unary ss op (unbox x d)
147+ convert other = other
148+ unary' :: Text -> PSString -> UnaryOperator -> AST -> AST
149+ unary' moduleName fnName op = convert where
150+ convert :: AST -> AST
151+ convert (App ss fn [x]) | isDict (moduleName, fnName) fn = Unary ss op (unbox x fnName)
152+ convert other = other
153+
154+ mkFn :: Int -> AST -> AST
155+ mkFn = mkFn' C.dataFunctionUncurried C.mkFn $ \ss1 ss2 ss3 args il ->
156+ Function ss1 Nothing args (Block ss2 [Return ss3 il])
157+
158+ mkEffFn :: Text -> Text -> Int -> AST -> AST
159+ mkEffFn modName fnName = mkFn' modName fnName $ \ss1 ss2 ss3 args il ->
160+ Function ss1 Nothing args (Block ss2 [Return ss3 (App ss3 il [])])
161+
162+ mkFn' :: Text -> Text -> (Maybe SourceSpan -> Maybe SourceSpan -> Maybe SourceSpan -> [Text] -> AST -> AST) -> Int -> AST -> AST
163+ mkFn' modName fnName res 0 = convert where
164+ convert :: AST -> AST
165+ convert (App _ mkFnN [Function s1 Nothing [_] (Block s2 [Return s3 il])]) | isNFn modName fnName 0 mkFnN =
166+ res s1 s2 s3 [] il
167+ convert other = other
168+ mkFn' modName fnName res n = convert where
169+ convert :: AST -> AST
170+ convert orig@(App ss mkFnN [fn]) | isNFn modName fnName n mkFnN =
171+ case collectArgs n [] fn of
172+ Just (args, [Return ss' ret]) -> res ss ss ss' args ret
173+ _ -> orig
174+ convert other = other
175+ collectArgs :: Int -> [Text] -> AST -> Maybe ([Text], [AST])
176+ collectArgs 1 acc (Function _ Nothing [oneArg] (Block _ il)) | length acc == n - 1 = Just (reverse (oneArg : acc), il)
177+ collectArgs m acc (Function _ Nothing [oneArg] (Block _ [Return _ ret])) = collectArgs (m - 1) (oneArg : acc) ret
178+ collectArgs _ _ _ = Nothing
179+
180+ isNFn :: Text -> Text -> Int -> AST -> Bool
181+ isNFn expectMod prefix n (Indexer _ (Var _ name) (Var _ modName)) | modName == expectMod =
182+ name == fromString (T.unpack prefix <> show n)
183+ isNFn _ _ _ _ = False
184+
185+ runFn :: Int -> AST -> AST
186+ runFn = runFn' C.dataFunctionUncurried C.runFn (\ss f args ->
187+ let len = length args
188+ typ = mkString $ uncurriedFnType len in
189+ if len > 0
190+ then App ss (App Nothing (StringLiteral Nothing typ) [f]) args
191+ else App ss f args)
192+ runEffFn :: Text -> Text -> Int -> AST -> AST
193+ runEffFn modName fnName = runFn' modName fnName $ \ss fn acc ->
194+ let typ = mkString . uncurriedFnType $ length acc in
195+ Function ss Nothing [] (Block ss [Return ss (App ss (App Nothing (StringLiteral Nothing typ) [fn]) acc)])
196+
197+ runFn' :: Text -> Text -> (Maybe SourceSpan -> AST -> [AST] -> AST) -> Int -> AST -> AST
198+ runFn' modName runFnName res n = convert where
199+ convert :: AST -> AST
200+ convert il = fromMaybe il $ go n [] il
201+
202+ go :: Int -> [AST] -> AST -> Maybe AST
203+ go 0 acc (App ss runFnN [fn]) | isNFn modName runFnName n runFnN && length acc == n =
204+ Just $ res ss fn acc
205+ go m acc (App _ lhs [arg]) = go (m - 1) (arg : acc) lhs
206+ go _ _ _ = Nothing
207+
208+ inlineNonClassFunction :: (AST -> Bool) -> (AST -> AST -> AST) -> AST -> AST
209+ inlineNonClassFunction p f = convert where
210+ convert :: AST -> AST
211+ convert (App _ (App _ op' [x]) [y]) | p op' = f x y
212+ convert other = other
213+
214+ inlineUnsafeIndex :: (AST -> Bool) -> (AST -> AST -> AST) -> AST -> AST
215+ inlineUnsafeIndex p _ = convert where
216+ convert :: AST -> AST
217+ convert (App _ (App ss op' [x]) [y@NumericLiteral{}])
218+ | p op' = Indexer ss y x
219+ convert (App _ (App ss op' [x]) [y])
220+ | p op' = App ss (Var Nothing indexFn) [x, y]
221+ convert other = other
222+
223+ isModFn :: (Text, PSString) -> AST -> Bool
224+ isModFn (m, op) (Indexer _ (Var _ op') (Var _ m')) =
225+ m == m' && decodeString op == Just op'
226+ isModFn _ _ = False
227+
228+ isModFnWithDict :: (Text, PSString) -> AST -> Bool
229+ isModFnWithDict (m, op) (App _ (Indexer _ (Var _ op') (Var _ m')) [Var _ _]) =
230+ m == m' && decodeString op == Just op'
231+ isModFnWithDict _ _ = False
232+
233+-- (f <<< g $ x) = f (g x)
234+-- (f <<< g) = \x -> f (g x)
235+inlineFnComposition :: forall m. MonadSupply m => AST -> m AST
236+inlineFnComposition = everywhereTopDownM convert where
237+ convert :: AST -> m AST
238+ convert (App s1 (App s2 (App _ (App _ fn [dict']) [x]) [y]) [z])
239+ | isFnCompose dict' fn = return $ App s1 x [App s2 y [z]]
240+ | isFnComposeFlipped dict' fn = return $ App s2 y [App s1 x [z]]
241+ convert app@(App ss (App _ (App _ fn [dict']) _) _)
242+ | isFnCompose dict' fn || isFnComposeFlipped dict' fn = mkApps ss <$> goApps app <*> freshName'
243+ convert other = return other
244+
245+ mkApps :: Maybe SourceSpan -> [Either AST (Text, AST)] -> Text -> AST
246+ mkApps ss fns a = App ss (Function ss Nothing [] (Block ss $ vars <> [Return Nothing comp])) []
247+ where
248+ vars = uncurry (VariableIntroduction ss) . fmap Just <$> rights fns
249+ comp = Function ss Nothing [a] (Block ss [Return Nothing apps])
250+ apps = foldr (\fn acc -> App ss (mkApp fn) [acc]) (Var ss a) fns
251+
252+ mkApp :: Either AST (Text, AST) -> AST
253+ mkApp = either id $ \(name, arg) -> Var (getSourceSpan arg) name
254+
255+ goApps :: AST -> m [Either AST (Text, AST)]
256+ goApps (App _ (App _ (App _ fn [dict']) [x]) [y])
257+ | isFnCompose dict' fn = mappend <$> goApps x <*> goApps y
258+ | isFnComposeFlipped dict' fn = mappend <$> goApps y <*> goApps x
259+ goApps app@(App {}) = pure . Right . (,app) <$> freshName'
260+ goApps other = pure [Left other]
261+
262+ isFnCompose :: AST -> AST -> Bool
263+ isFnCompose dict' fn = isDict semigroupoidFn dict' && isDict fnCompose fn
264+
265+ isFnComposeFlipped :: AST -> AST -> Bool
266+ isFnComposeFlipped dict' fn = isDict semigroupoidFn dict' && isDict fnComposeFlipped fn
267+
268+ fnCompose :: forall a b. (IsString a, IsString b) => (a, b)
269+ fnCompose = (C.controlSemigroupoid, C.compose)
270+
271+ fnComposeFlipped :: forall a b. (IsString a, IsString b) => (a, b)
272+ fnComposeFlipped = (C.controlSemigroupoid, C.composeFlipped)
273+
274+inlineUnsafeCoerce :: AST -> AST
275+inlineUnsafeCoerce = everywhereTopDown convert where
276+ convert (App _ (Indexer _ (Var _ unsafeCoerceFn) (Var _ unsafeCoerce)) [ comp ])
277+ | unsafeCoerceFn == C.unsafeCoerceFn && unsafeCoerce == C.unsafeCoerce
278+ = comp
279+ convert other = other
280+
281+inlineUnsafePartial :: AST -> AST
282+inlineUnsafePartial = everywhereTopDown convert where
283+ convert (App ss fn [ comp ])
284+ | isDict fnUnsafePartial fn
285+ = App ss comp []
286+ where
287+ fnUnsafePartial :: forall a b. (IsString a, IsString b) => (a, b)
288+ fnUnsafePartial = (C.partialUnsafe, C.unsafePartial)
289+ convert other = other
290+
291+semiringNumber :: forall a b. (IsString a, IsString b) => (a, b)
292+semiringNumber = (C.dataSemiring, C.semiringNumber)
293+
294+semiringInt :: forall a b. (IsString a, IsString b) => (a, b)
295+semiringInt = (C.dataSemiring, C.semiringInt)
296+
297+ringNumber :: forall a b. (IsString a, IsString b) => (a, b)
298+ringNumber = (C.dataRing, C.ringNumber)
299+
300+ringInt :: forall a b. (IsString a, IsString b) => (a, b)
301+ringInt = (C.dataRing, C.ringInt)
302+
303+euclideanRingNumber :: forall a b. (IsString a, IsString b) => (a, b)
304+euclideanRingNumber = (C.dataEuclideanRing, C.euclideanRingNumber)
305+
306+-- eqNumber :: forall a b. (IsString a, IsString b) => (a, b)
307+-- eqNumber = (C.dataEq, C.eqNumber)
308+
309+eqInt :: forall a b. (IsString a, IsString b) => (a, b)
310+eqInt = (C.dataEq, C.eqInt)
311+
312+eqString :: forall a b. (IsString a, IsString b) => (a, b)
313+eqString = (C.dataEq, C.eqString)
314+
315+eqChar :: forall a b. (IsString a, IsString b) => (a, b)
316+eqChar = (C.dataEq, C.eqChar)
317+
318+eqBoolean :: forall a b. (IsString a, IsString b) => (a, b)
319+eqBoolean = (C.dataEq, C.eqBoolean)
320+
321+ordBoolean :: forall a b. (IsString a, IsString b) => (a, b)
322+ordBoolean = (C.dataOrd, C.ordBoolean)
323+
324+ordNumber :: forall a b. (IsString a, IsString b) => (a, b)
325+ordNumber = (C.dataOrd, C.ordNumber)
326+
327+ordInt :: forall a b. (IsString a, IsString b) => (a, b)
328+ordInt = (C.dataOrd, C.ordInt)
329+
330+ordString :: forall a b. (IsString a, IsString b) => (a, b)
331+ordString = (C.dataOrd, C.ordString)
332+
333+ordChar :: forall a b. (IsString a, IsString b) => (a, b)
334+ordChar = (C.dataOrd, C.ordChar)
335+
336+semigroupString :: forall a b. (IsString a, IsString b) => (a, b)
337+semigroupString = (C.dataSemigroup, C.semigroupString)
338+
339+boundedBoolean :: forall a b. (IsString a, IsString b) => (a, b)
340+boundedBoolean = (C.dataBounded, C.boundedBoolean)
341+
342+heytingAlgebraBoolean :: forall a b. (IsString a, IsString b) => (a, b)
343+heytingAlgebraBoolean = (C.dataHeytingAlgebra, C.heytingAlgebraBoolean)
344+
345+semigroupoidFn :: forall a b. (IsString a, IsString b) => (a, b)
346+semigroupoidFn = (C.controlSemigroupoid, C.semigroupoidFn)
347+
348+opAdd :: forall a b. (IsString a, IsString b) => (a, b)
349+opAdd = (C.dataSemiring, C.add)
350+
351+opMul :: forall a b. (IsString a, IsString b) => (a, b)
352+opMul = (C.dataSemiring, C.mul)
353+
354+opEq :: forall a b. (IsString a, IsString b) => (a, b)
355+opEq = (C.dataEq, C.eq)
356+
357+opNotEq :: forall a b. (IsString a, IsString b) => (a, b)
358+opNotEq = (C.dataEq, C.notEq)
359+
360+opLessThan :: forall a b. (IsString a, IsString b) => (a, b)
361+opLessThan = (C.dataOrd, C.lessThan)
362+
363+opLessThanOrEq :: forall a b. (IsString a, IsString b) => (a, b)
364+opLessThanOrEq = (C.dataOrd, C.lessThanOrEq)
365+
366+opGreaterThan :: forall a b. (IsString a, IsString b) => (a, b)
367+opGreaterThan = (C.dataOrd, C.greaterThan)
368+
369+opGreaterThanOrEq :: forall a b. (IsString a, IsString b) => (a, b)
370+opGreaterThanOrEq = (C.dataOrd, C.greaterThanOrEq)
371+
372+opAppend :: forall a b. (IsString a, IsString b) => (a, b)
373+opAppend = (C.dataSemigroup, C.append)
374+
375+opSub :: forall a b. (IsString a, IsString b) => (a, b)
376+opSub = (C.dataRing, C.sub)
377+
378+opNegate :: forall a b. (IsString a, IsString b) => (a, b)
379+opNegate = (C.dataRing, C.negate)
380+
381+opDiv :: forall a b. (IsString a, IsString b) => (a, b)
382+opDiv = (C.dataEuclideanRing, C.div)
383+
384+opConj :: forall a b. (IsString a, IsString b) => (a, b)
385+opConj = (C.dataHeytingAlgebra, C.conj)
386+
387+opDisj :: forall a b. (IsString a, IsString b) => (a, b)
388+opDisj = (C.dataHeytingAlgebra, C.disj)
389+
390+opNot :: forall a b. (IsString a, IsString b) => (a, b)
391+opNot = (C.dataHeytingAlgebra, C.not)
392+
393+unbox :: AST -> PSString -> AST
394+unbox e d = select . inlineCommonValues $ inlineCommonOperators e
395+ where
396+ select :: AST -> AST
397+ select e' =
398+ case e' of
399+ Var{} -> unbox' e'
400+ App{} -> unbox' e'
401+ Indexer{} -> unbox' e'
402+ _ -> e'
403+ unbox' :: AST -> AST
404+ unbox' e' = maybe e' (\t -> App Nothing (StringLiteral Nothing t) [e']) $ unboxType d
405+
406+unboxType :: PSString -> Maybe PSString
407+unboxType s = do
408+ t <- decodeString s
409+ t' <- unboxType' t
410+ return $ mkString t'
411+ where
412+ unboxType' :: Text -> Maybe Text
413+ unboxType' t
414+ | t == C.eqInt ||
415+ t == C.semiringInt ||
416+ t == C.ringInt ||
417+ t == C.ordInt ||
418+ t == C.dataIntBits
419+ = Just int
420+ | t == C.semiringNumber ||
421+ t == C.ringNumber ||
422+ t == C.ordNumber ||
423+ t == C.euclideanRingNumber
424+ = Just float
425+ | t == C.eqBoolean ||
426+ t == C.ordBoolean ||
427+ t == C.heytingAlgebraBoolean
428+ = Just bool
429+ | t == C.eqChar ||
430+ t == C.eqString ||
431+ t == C.ordChar ||
432+ t == C.ordString ||
433+ t == C.semigroupString
434+ = Just string
435+ | otherwise = Nothing
src/CodeGen/IL/Optimizer/MagicDo.hsnew file+146
@@ -0,0 +1,146 @@
1+-- | This module implements the "Magic Do" optimization, which inlines calls to return
2+-- and bind for the Eff monad, as well as some of its actions.
3+module CodeGen.IL.Optimizer.MagicDo (magicDoEffect, magicDoEff, magicDoST, inlineST) where
4+
5+import Prelude.Compat
6+import Protolude (ordNub)
7+
8+import Data.Maybe (fromJust, isJust)
9+import Data.Text (Text)
10+
11+import Language.PureScript.CoreImp.AST
12+import Language.PureScript.CoreImp.Optimizer.Common hiding (isDict)
13+import Language.PureScript.PSString (PSString, decodeString, mkString)
14+import qualified Language.PureScript.Constants as C
15+
16+import CodeGen.IL.Common (undefinedName, unusedName)
17+import CodeGen.IL.Optimizer.Common
18+
19+-- | Inline type class dictionaries for >>= and return for the Eff monad
20+--
21+-- E.g.
22+--
23+-- Prelude[">>="](dict)(m1)(function(x) {
24+-- return ...;
25+-- })
26+--
27+-- becomes
28+--
29+-- function __do {
30+-- var x = m1();
31+-- ...
32+-- }
33+magicDoEff :: AST -> AST
34+magicDoEff = magicDo C.eff C.effDictionaries
35+
36+magicDoEffect :: AST -> AST
37+magicDoEffect = magicDo C.effect C.effectDictionaries
38+
39+magicDoST :: AST -> AST
40+magicDoST = magicDo C.st C.stDictionaries
41+
42+magicDo :: Text -> C.EffectDictionaries -> AST -> AST
43+magicDo effectModule C.EffectDictionaries{..} = everywhereTopDown convert
44+ where
45+ -- Desugar monomorphic calls to >>= and return for the Eff monad
46+ convert :: AST -> AST
47+ -- Desugar pure
48+ convert (App _ (App _ pure' [val]) []) | isPure pure' = val
49+ -- Desugar discard
50+ convert (App _ (App _ bind [m]) [Function s1 Nothing [unused] (Block s2 il)]) | isDiscard bind && unused == unusedName =
51+ Function s1 Nothing [] $ Block s2 (App s2 m [] : map applyReturns il )
52+ -- Desugar bind
53+ convert (App _ (App _ bind [m]) [Function s1 Nothing [arg] (Block s2 il)]) | isBind bind =
54+ Function s1 Nothing [] $ Block s2 (VariableIntroduction s2 arg (Just (App s2 m [])) : map applyReturns il)
55+ -- Desugar untilE
56+ convert (App s1 (App _ f [arg]) []) | isEffFunc edUntil f =
57+ App s1 (Function s1 Nothing [] (Block s1 [ While s1 (Unary s1 Not (App s1 arg [])) (Block s1 []), Return s1 $ ObjectLiteral s1 []])) []
58+ -- Desugar whileE
59+ convert (App _ (App _ (App s1 f [arg1]) [arg2]) []) | isEffFunc edWhile f =
60+ App s1 (Function s1 Nothing [] (Block s1 [ While s1 (App s1 arg1 []) (Block s1 [ App s1 arg2 [] ]), Return s1 $ ObjectLiteral s1 []])) []
61+ -- -- Inline __do returns
62+ -- convert (Return _ (App _ (Function _ (Just ident) [] body) [])) | ident == fnName = body
63+ -- Inline double applications
64+ convert (App _ (App s1 (Function s2 Nothing [] (Block ss body)) []) []) =
65+ App s1 (Function s2 Nothing [] (Block ss (applyReturns `fmap` body))) []
66+ convert other = other
67+ -- Check if an expression represents a monomorphic call to >>= for the Eff monad
68+ isBind (App _ fn [dict]) | isDict (effectModule, edBindDict) dict && isBindPoly fn = True
69+ isBind _ = False
70+ -- Check if an expression represents a call to @discard@
71+ isDiscard (App _ (App _ fn [dict1]) [dict2])
72+ | isDict (C.controlBind, C.discardUnitDictionary) dict1 &&
73+ isDict (effectModule, edBindDict) dict2 &&
74+ isDiscardPoly fn = True
75+ isDiscard _ = False
76+
77+ -- Check if an expression represents a monomorphic call to pure or return for the Eff applicative
78+ isPure (App _ fn [dict]) | isDict (effectModule, edApplicativeDict) dict && isPurePoly fn = True
79+ isPure _ = False
80+ -- Check if an expression represents the polymorphic >>= function
81+ isBindPoly = isDict (C.controlBind, C.bind)
82+ -- Check if an expression represents the polymorphic pure function
83+ isPurePoly = isDict (C.controlApplicative, C.pure')
84+ -- Check if an expression represents the polymorphic discard function
85+ isDiscardPoly = isDict (C.controlBind, C.discard)
86+ -- Check if an expression represents a function in the Effect module
87+ isEffFunc name (Indexer _ (StringLiteral _ name') (Var _ eff)) = eff == effectModule && name == name'
88+ isEffFunc _ _ = False
89+
90+ applyReturns :: AST -> AST
91+ applyReturns (Return ss ret) = Return ss (App ss ret [])
92+ applyReturns (Block ss ils) = Block ss (map applyReturns ils)
93+ applyReturns (While ss cond il) = While ss cond (applyReturns il)
94+ applyReturns (For ss v lo hi il) = For ss v lo hi (applyReturns il)
95+ applyReturns (ForIn ss v xs il) = ForIn ss v xs (applyReturns il)
96+ applyReturns (IfElse ss cond t f) = IfElse ss cond (applyReturns t) (applyReturns `fmap` f)
97+ applyReturns other = other
98+
99+-- | Inline functions in the ST module
100+inlineST :: AST -> AST
101+inlineST = everywhere convertBlock
102+ where
103+ -- Look for runST blocks and inline the STRefs there.
104+ -- If all STRefs are used in the scope of the same runST, only using { read, write, modify }STRef then
105+ -- we can be more aggressive about inlining, and actually turn STRefs into local variables.
106+ convertBlock (App s1 f [arg]) | isSTFunc C.runST f =
107+ let refs = ordNub . findSTRefsIn $ arg
108+ usages = findAllSTUsagesIn arg
109+ allUsagesAreLocalVars = all (\u -> let v = toVar u in isJust v && fromJust v `elem` refs) usages
110+ localVarsDoNotEscape = all (\r -> length (r `appearingIn` arg) == length (filter (\u -> let v = toVar u in v == Just r) usages)) refs
111+ in App s1 (everywhere (convert (allUsagesAreLocalVars && localVarsDoNotEscape)) arg) []
112+ convertBlock other = other
113+ -- Convert a block in a safe way, preserving object wrappers of references,
114+ -- or in a more aggressive way, turning wrappers into local variables depending on the
115+ -- agg(ressive) parameter.
116+ convert agg (App s1 f [arg]) | isSTFunc C.newSTRef f =
117+ Function s1 Nothing [] (Block s1 [Return s1 $ if agg then arg else ObjectLiteral s1 [(mkString C.stRefValue, arg)]])
118+ convert agg (App _ (App s1 f [ref]) []) | isSTFunc C.readSTRef f =
119+ if agg then ref else Indexer s1 (StringLiteral s1 C.stRefValue) ref
120+ convert agg (App _ (App _ (App s1 f [arg]) [ref]) []) | isSTFunc C.writeSTRef f =
121+ if agg then Assignment s1 ref arg else Assignment s1 (Indexer s1 (StringLiteral s1 C.stRefValue) ref) arg
122+ convert agg (App _ (App _ (App s1 f [func]) [ref]) []) | isSTFunc C.modifySTRef f =
123+ if agg then Assignment s1 ref (App s1 func [ref]) else Assignment s1 (Indexer s1 (StringLiteral s1 C.stRefValue) ref) (App s1 func [Indexer s1 (StringLiteral s1 C.stRefValue) ref])
124+ convert _ other = other
125+ -- Check if an expression represents a function in the ST module
126+ isSTFunc name (Indexer _ (StringLiteral _ name') (Var _ st)) = st == C.st && name == name'
127+ isSTFunc _ _ = False
128+ -- Find all ST Refs initialized in this block
129+ findSTRefsIn = everything (++) isSTRef
130+ where
131+ isSTRef (VariableIntroduction _ ident (Just (App _ (App _ f [_]) []))) | isSTFunc C.newSTRef f = [ident]
132+ isSTRef _ = []
133+ -- Find all STRefs used as arguments to readSTRef, writeSTRef, modifySTRef
134+ findAllSTUsagesIn = everything (++) isSTUsage
135+ where
136+ isSTUsage (App _ (App _ f [ref]) []) | isSTFunc C.readSTRef f = [ref]
137+ isSTUsage (App _ (App _ (App _ f [_]) [ref]) []) | isSTFunc C.writeSTRef f || isSTFunc C.modifySTRef f = [ref]
138+ isSTUsage _ = []
139+ -- Find all uses of a variable
140+ appearingIn ref = everything (++) isVar
141+ where
142+ isVar e@(Var _ v) | v == ref = [e]
143+ isVar _ = []
144+ -- Convert a AST value to a String if it is a Var
145+ toVar (Var _ v) = Just v
146+ toVar _ = Nothing
src/CodeGen/IL/Optimizer/TCO.hsnew file+141
@@ -0,0 +1,141 @@
1+module CodeGen.IL.Optimizer.TCO (tco, tcoLoop) where
2+
3+import Prelude.Compat
4+
5+import Data.Text (Text)
6+import Data.Monoid ((<>))
7+import Language.PureScript.CoreImp.AST
8+import Language.PureScript.AST.SourcePos (SourceSpan)
9+import Safe (headDef, tailSafe)
10+import CodeGen.IL.Common
11+
12+import qualified Language.PureScript.Constants as C
13+
14+tcoLoop :: Text
15+tcoLoop = "ṩtco_loop"
16+
17+tco :: AST -> AST -> AST
18+tco mn = everywhere convert where
19+ tcoVar :: Text -> Text
20+ tcoVar arg = "ṩtco_var_" <> arg
21+
22+ copyVar :: Text -> Text
23+ copyVar arg = "ṩcopy_" <> arg
24+
25+ tcoDone :: Text
26+ tcoDone = "ṩtco_done"
27+
28+ tcoResult :: Text
29+ tcoResult = "ṩtco_result"
30+
31+ convert :: AST -> AST
32+ convert fn@(Function ss (Just name) args _)
33+ | isTailRecursive name body'
34+ = replace (toLoop name outerArgs innerArgs body')
35+ where
36+ innerArgs = headDef [] argss
37+ outerArgs = concat . reverse $ tailSafe argss
38+ (argss, body', replace) = collectAllFunctionArgs [] id fn
39+ convert (Assignment ss (Var _ name) fn@(Function _ Nothing _ _))
40+ | isTailRecursive name body'
41+ = Assignment ss (Var ss name) (replace (toLoop name outerArgs innerArgs body'))
42+ where
43+ innerArgs = headDef [] argss
44+ outerArgs = concat . reverse $ tailSafe argss
45+ (argss, body', replace) = collectAllFunctionArgs [] id fn
46+ convert js = js
47+
48+ collectAllFunctionArgs :: [[Text]] -> (AST -> AST) -> AST -> ([[Text]], AST, AST -> AST)
49+ collectAllFunctionArgs allArgs f (Function s1 ident args (Block s2 (body@(Return _ _):_))) =
50+ collectAllFunctionArgs (args : allArgs) (\b -> f (Function s1 ident (map copyVar args) (Block s2 [b]))) body
51+ collectAllFunctionArgs allArgs f (Function ss ident args body@(Block _ _)) =
52+ (args : allArgs, body, f . Function ss ident (map copyVar args))
53+ collectAllFunctionArgs allArgs f (Return s1 (Function s2 ident args (Block s3 [body]))) =
54+ collectAllFunctionArgs (args : allArgs) (\b -> f (Return s1 (Function s2 ident (map copyVar args) (Block s3 [b])))) body
55+ collectAllFunctionArgs allArgs f (Return s1 (Function s2 ident args body@(Block _ _))) =
56+ (args : allArgs, body, f . Return s1 . Function s2 ident (map copyVar args))
57+ collectAllFunctionArgs allArgs f body = (allArgs, body, f)
58+
59+ isTailRecursive :: Text -> AST -> Bool
60+ isTailRecursive ident js = countSelfReferences js > 0 && allInTailPosition js where
61+ countSelfReferences = everything (+) match where
62+ match :: AST -> Int
63+ match (Var _ ident') | ident == ident' = 1
64+ match _ = 0
65+
66+ allInTailPosition (Return _ expr)
67+ | isSelfCall ident expr = countSelfReferences expr == 1
68+ | otherwise = countSelfReferences expr == 0
69+ allInTailPosition (While _ js1 body)
70+ = countSelfReferences js1 == 0 && allInTailPosition body
71+ allInTailPosition (For _ _ js1 js2 body)
72+ = countSelfReferences js1 == 0 && countSelfReferences js2 == 0 && allInTailPosition body
73+ allInTailPosition (ForIn _ _ js1 body)
74+ = countSelfReferences js1 == 0 && allInTailPosition body
75+ allInTailPosition (IfElse _ js1 body el)
76+ = countSelfReferences js1 == 0 && allInTailPosition body && all allInTailPosition el
77+ allInTailPosition (Block _ body)
78+ = all allInTailPosition body
79+ allInTailPosition (Throw _ js1)
80+ = countSelfReferences js1 == 0
81+ allInTailPosition (ReturnNoResult _)
82+ = True
83+ allInTailPosition (VariableIntroduction _ _ js1)
84+ = all ((== 0) . countSelfReferences) js1
85+ allInTailPosition (Assignment _ _ js1)
86+ = countSelfReferences js1 == 0
87+ allInTailPosition (Comment _ _ js1)
88+ = allInTailPosition js1
89+ allInTailPosition _
90+ = False
91+
92+ toLoop :: Text -> [Text] -> [Text] -> AST -> AST
93+ toLoop ident outerArgs innerArgs js =
94+ Block rootSS $
95+ concatMap (\arg -> [ VariableIntroduction rootSS (tcoVar arg) . Just $
96+ Var rootSS (copyVar arg) ]) (outerArgs ++ innerArgs) ++
97+ [ Assignment rootSS (Var rootSS $ "var " <> tcoDone) $ BooleanLiteral Nothing False
98+ , VariableIntroduction rootSS tcoResult Nothing
99+ , Assignment rootSS (Var rootSS $ "var " <> tcoLoop) (Function rootSS (Just tcoLoop) (outerArgs ++ innerArgs) (Block rootSS [loopify js]))
100+ , While rootSS (Unary Nothing Not (Var rootSS tcoDone))
101+ (Block rootSS
102+ [(Assignment rootSS (Var rootSS tcoResult) (App rootSS (Var rootSS tcoLoop) ((map (Var rootSS . tcoVar) outerArgs) ++ (map (Var rootSS . copyVar) innerArgs))))])
103+ , Return rootSS (Var rootSS tcoResult)
104+ ]
105+ where
106+ rootSS = Nothing
107+
108+ loopify :: AST -> AST
109+ loopify (Return ss ret)
110+ | isSelfCall ident ret =
111+ let
112+ allArgumentValues = concat $ collectArgs [] ret
113+ in
114+ Block ss $
115+ zipWith (\val arg ->
116+ Assignment ss (Var ss (tcoVar arg)) val) allArgumentValues outerArgs
117+ ++ zipWith (\val arg ->
118+ Assignment ss (Var ss (copyVar arg)) val) (drop (length outerArgs) allArgumentValues) innerArgs
119+ ++ [ ReturnNoResult ss ]
120+ | otherwise = Block ss [ markDone ss, Return ss ret ]
121+ loopify (ReturnNoResult ss) = Block ss [ markDone ss, ReturnNoResult ss ]
122+ loopify (While ss cond body) = While ss cond (loopify body)
123+ loopify (For ss i js1 js2 body) = For ss i js1 js2 (loopify body)
124+ loopify (ForIn ss i js1 body) = ForIn ss i js1 (loopify body)
125+ loopify (IfElse ss cond body el) = IfElse ss cond (loopify body) (fmap loopify el)
126+ loopify (Block ss body) = Block ss (map loopify body)
127+ loopify other = other
128+
129+ markDone :: Maybe SourceSpan -> AST
130+ markDone ss = Assignment ss (Var ss tcoDone) (BooleanLiteral ss True)
131+
132+ collectArgs :: [[AST]] -> AST -> [[AST]]
133+ collectArgs acc (App _ fn args') = collectArgs (args' : acc) fn
134+ collectArgs acc _ = acc
135+
136+ isSelfCall :: Text -> AST -> Bool
137+ isSelfCall ident (App _ (Var _ ident') _) = ident == ident'
138+ isSelfCall ident (App _ (Indexer _ (Var _ ident') (Var _ mn')) _) = mn' == "" && ident == ident'
139+ isSelfCall ident (App _ (Indexer _ (Var _ ident') mn') _) = mn' == mn && ident == ident'
140+ isSelfCall ident (App _ fn _) = isSelfCall ident fn
141+ isSelfCall _ _ = False
src/CodeGen/IL/Printer.hsnew file+527
@@ -0,0 +1,527 @@
1+-- | Pretty printer for the AST
2+module CodeGen.IL.Printer
3+ ( prettyPrintIL
4+ , prettyPrintIL1
5+ , prettyPrintILWithSourceMaps
6+ , interfaceSource
7+ , implHeaderSource
8+ , implFooterSource
9+ , isLiteral
10+ , modLabel
11+ , modPrefix
12+ , ffiLoader
13+ ) where
14+
15+import Prelude.Compat
16+
17+import Control.Arrow ((<+>))
18+import Control.Monad (forM, mzero)
19+import Control.Monad.State (StateT, evalStateT)
20+import Control.PatternArrows
21+import Data.List (filter, (\\))
22+import qualified Control.Arrow as A
23+
24+import Data.Maybe (fromMaybe)
25+import Data.Monoid ((<>))
26+import Data.Text (Text)
27+import qualified Data.Text as T
28+
29+import Language.PureScript.AST (SourceSpan(..))
30+import Language.PureScript.CoreImp.AST
31+import Language.PureScript.Comments
32+import Language.PureScript.Crash
33+import Language.PureScript.Names (Ident, runIdent)
34+import Language.PureScript.Pretty.Common
35+import Language.PureScript.PSString (PSString, decodeString, mkString)
36+
37+import CodeGen.IL.Common
38+import CodeGen.IL.Optimizer.TCO (tcoLoop)
39+
40+import qualified Language.PureScript.Constants as C
41+
42+-- TODO (Christoph): Get rid of T.unpack / pack
43+
44+literals :: (Emit gen) => Pattern PrinterState AST gen
45+literals = mkPattern' match'
46+ where
47+ match' :: (Emit gen) => AST -> StateT PrinterState Maybe gen
48+ match' il = (addMapping' (getSourceSpan il) <>) <$> match il
49+
50+ match :: (Emit gen) => AST -> StateT PrinterState Maybe gen
51+ match (NumericLiteral _ n) = return $ emit $ T.pack $ either show show n
52+ match (StringLiteral _ s) = return $ emit $ stringLiteral s
53+ match (BooleanLiteral _ True) = return $ emit "true"
54+ match (BooleanLiteral _ False) = return $ emit "false"
55+ match (ArrayLiteral _ xs) = mconcat <$> sequence
56+ [ return . emit $ arrayType <> "{"
57+ , intercalate (emit ", ") <$> forM xs prettyPrintIL'
58+ , return $ emit "}"
59+ ]
60+ -- match (ObjectLiteral _ []) = return $ emit "std::initializer_list<std::pair<const string, boxed>>{}"
61+ match (ObjectLiteral _ ps) = mconcat <$> sequence
62+ [ return . emit $ dictType <> "{"
63+ , withIndent $ do
64+ ils <- forM ps $ \(key, value) -> do
65+ value' <- prettyPrintIL' value
66+ return $ objectPropertyToString key <> value'
67+ return $ intercalate (emit " ") $ map (<> emit ",") ils
68+ , return $ emit "}"
69+ ]
70+ where
71+ objectPropertyToString :: (Emit gen) => PSString -> gen
72+ objectPropertyToString s = emit $ stringLiteral s <> ": "
73+ match (Block _ sts) = mconcat <$> sequence
74+ [ return $ emit "{\n"
75+ , withIndent $ prettyStatements sts
76+ , return $ emit "\n"
77+ , currentIndent
78+ , return $ emit "}"
79+ ]
80+ match (Var _ ident) | ident == C.undefined = return $ emit undefinedName
81+ match (Var _ ident) = return $ emit ident
82+ match (VariableIntroduction _ ident value) = mconcat <$> sequence
83+ [ return . emit $ varDecl <> " " <> ident <> " " <> anyType
84+ , maybe (return mempty) (fmap (emit " = " <>) . prettyPrintIL') value
85+ ]
86+ match (Assignment _ target value) = mconcat <$> sequence
87+ [ prettyPrintIL' target
88+ , return $ emit " = "
89+ , prettyPrintIL' value
90+ ]
91+ match (App _ val []) = mconcat <$> sequence
92+ [ return $ emit "Run("
93+ , prettyPrintIL' val
94+ , return $ emit ")"
95+ ]
96+ match (App _ (StringLiteral _ u) [arg])
97+ | Just ty <- decodeString u = mconcat <$> sequence
98+ [ prettyPrintIL' arg
99+ , return $ emit ".("
100+ , return $ emit ty
101+ , return $ emit ")"
102+ ]
103+ match (App _ (Var _ fn) [arg]) | fn == arrayLengthFn = mconcat <$> sequence
104+ [ return $ emit fn
105+ , return $ emit "("
106+ , prettyPrintIL' arg
107+ , return $ emit ")"
108+ ]
109+ match (App _ (Var _ fn) args) | fn == indexFn = mconcat <$> sequence
110+ [ return $ emit fn
111+ , return $ emit "("
112+ , intercalate (emit ", ") <$> forM args prettyPrintIL'
113+ , return $ emit ")"
114+ ]
115+ match (App _ (Var _ fn) args) | fn == tcoLoop = mconcat <$> sequence
116+ [ return $ emit fn
117+ , return $ emit "("
118+ , intercalate (emit ", ") <$> forM args prettyPrintIL'
119+ , return $ emit ")"
120+ ]
121+ match (App _ (App Nothing (StringLiteral Nothing fnx) [fn@Function{}]) args)
122+ | Just ftype <- decodeString fnx
123+ , "Fn" `T.isPrefixOf` ftype = mconcat <$> sequence
124+ [ prettyPrintIL' fn
125+ , return $ emit "("
126+ , intercalate (emit ", ") <$> forM args prettyPrintIL'
127+ , return $ emit ")"
128+ ]
129+ match (App _ (App Nothing (StringLiteral Nothing fnx) [fn]) args)
130+ | Just ftype <- decodeString fnx
131+ , "Fn" `T.isPrefixOf` ftype = mconcat <$> sequence
132+ [ prettyPrintIL' fn
133+ , return $ emit ".("
134+ , return $ emit ftype
135+ , return $ emit ")("
136+ , intercalate (emit ", ") <$> forM args prettyPrintIL'
137+ , return $ emit ")"
138+ ]
139+ match app@(App{})
140+ | (val, args) <- unApp app []
141+ , length args > 1
142+ = mconcat <$> sequence
143+ [ return $ emit "Apply("
144+ , prettyPrintIL' val
145+ , return $ emit ", "
146+ , intercalate (emit ", ") <$> forM args prettyPrintIL'
147+ , return $ emit ")"
148+ ]
149+ match (App _ val args) = mconcat <$> sequence
150+ [ return $ emit "Apply("
151+ , prettyPrintIL' val
152+ , return $ emit ", "
153+ , intercalate (emit ", ") <$> forM args prettyPrintIL'
154+ , return $ emit ")"
155+ ]
156+ match (Function _ (Just name) [] (Block _ [Return _ ret]))
157+ | isComplexLiteral ret = mconcat <$> sequence
158+ [ return $ emit "\n"
159+ , return . emit $ varDecl <> " " <> initName name <> " Once\n"
160+ , prettyPrintIL' $ VariableIntroduction Nothing (valueName name) Nothing
161+ , return $ emit "\n\n"
162+ , return $ emit "func "
163+ , return . emit $ withPrefix name
164+ , return . emit $ "() " <> anyType <> " "
165+ , return $ emit "{\n"
166+ , withIndent $ do
167+ indentString <- currentIndent
168+ return $ indentString <> (emit $ initName name <> ".Do(func() {\n") <>
169+ indentString <> indentString <> (emit $ valueName name <> " = ")
170+ , withIndent $ do
171+ case ret of
172+ Function _ Nothing args body -> mconcat <$> sequence
173+ [ return $ emit "func("
174+ , return . emit $ intercalate ", " (renderArg anyType <$> args)
175+ , return . emit $ ") " <> anyType <> " "
176+ , prettyPrintIL' body
177+ ]
178+ _ -> do
179+ prettyPrintIL' ret
180+ , return $ emit "\n"
181+ , withIndent $ do
182+ indentString <- currentIndent
183+ return $ indentString <> (emit $ "})\n" <> "return " <> valueName name <>"\n")
184+ , return $ emit "}\n\n"
185+ ]
186+ match (Function _ (Just name) [] ret) = mconcat <$> sequence
187+ [ return $ emit "func "
188+ , return . emit $ withPrefix name
189+ , return . emit $ "() " <> anyType <> " "
190+ , prettyPrintIL' ret
191+ ]
192+ match (Function _ _ args ret) = mconcat <$> sequence
193+ [ return $ emit "func("
194+ , return . emit $ intercalate ", " (renderArg anyType <$> args)
195+ , return . emit $ ") " <> anyType <> " "
196+ , prettyPrintIL' ret
197+ ]
198+ match (Indexer _ (Var _ name) (Var _ "")) = mconcat <$> sequence
199+ [ prettyPrintIL' (Var Nothing $ withPrefix name)
200+ , return $ emit "()"
201+ ]
202+ match (Indexer _ (Var _ name) val) = mconcat <$> sequence
203+ [ prettyPrintIL' val
204+ , return $ emit "."
205+ , prettyPrintIL' (Var Nothing $ withPrefix name)
206+ , return $ emit "()"
207+ ]
208+ match (Indexer _ prop@StringLiteral{} val@ObjectLiteral{}) = mconcat <$> sequence
209+ [ prettyPrintIL' val
210+ , return $ emit "["
211+ , prettyPrintIL' prop
212+ , return $ emit "]"
213+ ]
214+ match (Indexer _ prop@StringLiteral{} val) = mconcat <$> sequence
215+ [ prettyPrintIL' val
216+ , return $ emit ".("
217+ , return $ emit dictType
218+ , return $ emit ")["
219+ , prettyPrintIL' prop
220+ , return $ emit "]"
221+ ]
222+ match (Indexer _ index val@ArrayLiteral{}) = mconcat <$> sequence
223+ [ prettyPrintIL' val
224+ , return $ emit "["
225+ , prettyPrintIL' index
226+ , return $ emit "]"
227+ ]
228+ match (Indexer _ index val) = mconcat <$> sequence
229+ [ prettyPrintIL' val
230+ , return $ emit ".("
231+ , return $ emit arrayType
232+ , return $ emit ")["
233+ , prettyPrintIL' index
234+ , return $ emit "]"
235+ ]
236+ match (InstanceOf _ val ty) = mconcat <$> sequence
237+ [ return $ emit "Is("
238+ , prettyPrintIL' val
239+ , return $ emit ", "
240+ , prettyPrintIL' ty
241+ , return $ emit ")"
242+ ]
243+ match (While _ cond sts) = mconcat <$> sequence
244+ [ return $ emit "for "
245+ , prettyPrintIL' cond
246+ , return $ emit " "
247+ , prettyPrintIL' sts
248+ ]
249+ match (For _ ident start end sts) = mconcat <$> sequence
250+ [ return $ emit $ "for var " <> ident <> " = "
251+ , prettyPrintIL' start
252+ , return $ emit $ "; " <> ident <> " < "
253+ , prettyPrintIL' end
254+ , return $ emit $ "; " <> ident <> "++ "
255+ , prettyPrintIL' sts
256+ ]
257+ match (ForIn _ ident obj sts) = mconcat <$> sequence
258+ [ return $ emit $ "for var " <> ident <> " in "
259+ , prettyPrintIL' obj
260+ , return $ emit " "
261+ , prettyPrintIL' sts
262+ ]
263+ match (IfElse _ (Binary _ EqualTo cond@Binary{} (BooleanLiteral Nothing True)) thens elses) = mconcat <$> sequence
264+ [ return $ emit "if "
265+ , prettyPrintIL' cond
266+ , return $ emit " "
267+ , prettyPrintIL' thens
268+ , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintIL') elses
269+ ]
270+ match (IfElse _ (Binary _ EqualTo cond@Binary{} (BooleanLiteral Nothing False)) thens elses) = mconcat <$> sequence
271+ [ return $ emit "if !("
272+ , prettyPrintIL' cond
273+ , return $ emit ") "
274+ , prettyPrintIL' thens
275+ , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintIL') elses
276+ ]
277+ match (IfElse _ cond thens elses) = mconcat <$> sequence
278+ [ return $ emit "if "
279+ , prettyPrintIL' cond
280+ , return $ emit " "
281+ , prettyPrintIL' thens
282+ , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintIL') elses
283+ ]
284+ match (Return _ value) = mconcat <$> sequence
285+ [ return $ emit "return "
286+ , prettyPrintIL' value
287+ ]
288+ match (ReturnNoResult _) = return . emit $ "return " <> undefinedName
289+ -- match (Throw _ _) = return mempty
290+ match (Throw _ value) = mconcat <$> sequence
291+ [ return $ emit "panic("
292+ , prettyPrintIL' value
293+ , return $ emit ")"
294+ ]
295+ match (Comment _ com il) = mconcat <$> sequence
296+ [ return $ emit "\n"
297+ , mconcat <$> forM com comment
298+ , prettyPrintIL' il
299+ ]
300+ match _ = mzero
301+
302+ comment :: (Emit gen) => Comment -> StateT PrinterState Maybe gen
303+ comment (LineComment com) = fmap mconcat $ sequence $
304+ [ currentIndent
305+ , return $ emit "//" <> emit com <> emit "\n"
306+ ]
307+ comment (BlockComment com) = fmap mconcat $ sequence $
308+ [ currentIndent
309+ , return $ emit "/**\n"
310+ ] ++
311+ map asLine (T.lines com) ++
312+ [ currentIndent
313+ , return $ emit " */\n"
314+ , currentIndent
315+ ]
316+ where
317+ asLine :: (Emit gen) => Text -> StateT PrinterState Maybe gen
318+ asLine s = do
319+ i <- currentIndent
320+ return $ i <> emit " * " <> (emit . removeComments) s <> emit "\n"
321+
322+ removeComments :: Text -> Text
323+ removeComments t =
324+ case T.stripPrefix "*/" t of
325+ Just rest -> removeComments rest
326+ Nothing -> case T.uncons t of
327+ Just (x, xs) -> x `T.cons` removeComments xs
328+ Nothing -> ""
329+
330+unary' :: (Emit gen) => UnaryOperator -> (AST -> Text) -> Operator PrinterState AST gen
331+unary' op mkStr = Wrap match (<>)
332+ where
333+ match :: (Emit gen) => Pattern PrinterState AST (gen, AST)
334+ match = mkPattern match'
335+ where
336+ match' (Unary _ op' val) | op' == op = Just (emit $ mkStr val, val)
337+ match' _ = Nothing
338+
339+unary :: (Emit gen) => UnaryOperator -> Text -> Operator PrinterState AST gen
340+unary op str = unary' op (const str)
341+
342+negateOperator :: (Emit gen) => Operator PrinterState AST gen
343+negateOperator = unary' Negate (\v -> if isNegate v then "- " else "-")
344+ where
345+ isNegate (Unary _ Negate _) = True
346+ isNegate _ = False
347+
348+binary :: (Emit gen) => BinaryOperator -> Text -> Operator PrinterState AST gen
349+binary op str = AssocL match (\v1 v2 -> v1 <> emit (" " <> str <> " ") <> v2)
350+ where
351+ match :: Pattern PrinterState AST (AST, AST)
352+ match = mkPattern match'
353+ where
354+ match' (Binary _ op' v1 v2) | op' == op = Just (v1, v2)
355+ match' _ = Nothing
356+
357+isLiteral :: AST -> Bool
358+isLiteral Function{} = True
359+isLiteral NumericLiteral{} = True
360+isLiteral StringLiteral{} = True
361+isLiteral BooleanLiteral{} = True
362+isLiteral ObjectLiteral{} = True
363+isLiteral ArrayLiteral{} = True
364+isLiteral _ = False
365+
366+isComplexLiteral :: AST -> Bool
367+-- isComplexLiteral Function{} = True
368+isComplexLiteral ObjectLiteral{} = True
369+isComplexLiteral ArrayLiteral{} = True
370+isComplexLiteral _ = False
371+
372+unApp :: AST -> [AST] -> (AST, [AST])
373+unApp (App _ val [arg]) args = unApp val (arg : args)
374+unApp other args = (other, args)
375+
376+prettyStatements :: (Emit gen) => [AST] -> StateT PrinterState Maybe gen
377+prettyStatements sts = do
378+ ils <- forM sts prettyPrintIL'
379+ indentString <- currentIndent
380+ return $ intercalate (emit "\n") $ map (indentString <>) ils
381+
382+-- | Generate a pretty-printed string representing a collection of C++ expressions at the same indentation level
383+prettyPrintILWithSourceMaps :: [AST] -> (Text, [SMap])
384+prettyPrintILWithSourceMaps il =
385+ let StrPos (_, s, mp) = (fromMaybe (internalError "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyStatements) il
386+ in (s, mp)
387+
388+prettyPrintIL :: [AST] -> Text
389+prettyPrintIL = maybe (internalError "Incomplete pattern") runPlainString . flip evalStateT (PrinterState 0) . prettyStatements
390+
391+-- | Generate an indented, pretty-printed string representing a C++ expression
392+prettyPrintIL' :: (Emit gen) => AST -> StateT PrinterState Maybe gen
393+prettyPrintIL' = A.runKleisli $ runPattern matchValue
394+ where
395+ matchValue :: (Emit gen) => Pattern PrinterState AST gen
396+ matchValue = buildPrettyPrinter operators (literals <+> fmap parensPos matchValue)
397+ operators :: (Emit gen) => OperatorTable PrinterState AST gen
398+ operators =
399+ OperatorTable [ [ unary New "?" ]
400+ , [ unary Not "!"
401+ , unary BitwiseNot "~"
402+ , unary Positive "+"
403+ , negateOperator ]
404+ , [ binary Multiply "*"
405+ , binary Divide "/"
406+ , binary Modulus "%" ]
407+ , [ binary Add "+"
408+ , binary Subtract "-" ]
409+ , [ binary ShiftLeft "<<"
410+ , binary ShiftRight ">>" ]
411+ , [ binary LessThan "<"
412+ , binary LessThanOrEqualTo "<="
413+ , binary GreaterThan ">"
414+ , binary GreaterThanOrEqualTo ">=" ]
415+ , [ binary EqualTo "=="
416+ , binary NotEqualTo "!=" ]
417+ , [ binary BitwiseAnd "&" ]
418+ , [ binary BitwiseXor "^" ]
419+ , [ binary BitwiseOr "|" ]
420+ , [ binary And "&&" ]
421+ , [ binary Or "||" ]
422+ ]
423+
424+prettyPrintIL1 :: AST -> Text
425+prettyPrintIL1 = maybe (internalError "Incomplete pattern") runPlainString . flip evalStateT (PrinterState 0) . prettyPrintIL'
426+
427+stringLiteral :: PSString -> Text
428+stringLiteral pss | Just s <- decodeString pss = stringLiteral' s
429+ where
430+ stringLiteral' :: Text -> Text
431+ stringLiteral' s = "\"" <> T.concatMap encodeChar s <> "\""
432+ encodeChar :: Char -> Text
433+ encodeChar '\0' = "\\x00"
434+ encodeChar '\b' = "\\b"
435+ encodeChar '\t' = "\\t"
436+ encodeChar '\n' = "\\n"
437+ encodeChar '\v' = "\\v"
438+ encodeChar '\f' = "\\f"
439+ encodeChar '\r' = "\\r"
440+ encodeChar '"' = "\\\""
441+ encodeChar '\\' = "\\\\"
442+ encodeChar c = T.singleton $ c
443+stringLiteral _ = "\"\\uFFFD\""
444+
445+interfaceSource :: Text -> [(Text,Bool)] -> [Ident] -> Text
446+interfaceSource _ _ _ = ""
447+
448+implHeaderSource :: Text -> [Text] -> Text -> Text
449+implHeaderSource mn imports otherPrefix =
450+ "// Code generated by psgo. DO NOT EDIT.\n\n" <>
451+ "package " <> (if mn == "Main" || mn == "Test_Main" then "main" else mn) <> "\n\n" <>
452+ "import . \"" <> runtime <> "\"\n" <>
453+ (if mn == "Main" || mn == "Test_Main"
454+ then "import _ \"" <> otherPrefix <> "/" <> ffiLoader <> "\"\n"
455+ else "\n") <>
456+ "import (\n" <>
457+ (T.concat $ formatImport <$> imports) <> ")\n\n" <>
458+ "type _ = Any\n\n"
459+ where
460+ formatImport :: Text -> Text
461+ formatImport s =
462+ "\t\"" <> otherPrefix <> "/" <> modPrefix <> "/" <> moduleRenamer s <> "\"\n"
463+ moduleRenamer :: Text -> Text
464+ moduleRenamer s
465+ | (s', sfx) <- T.breakOn moduleRenamerMarker s,
466+ not $ T.null sfx = s'
467+ moduleRenamer s = s
468+
469+implFooterSource :: Text -> [Ident] -> Text
470+implFooterSource mn foreigns =
471+ "\n\n\n" <>
472+ (if null foreigns
473+ then ""
474+ else ("// Foreign values\n\n" <>
475+ "var " <> foreignDict <> " = "<> foreignMod <> "(\"" <> mn <> "\")\n\n" <>
476+ (T.concat $ (\foreign' ->
477+ let name = moduleIdentToIL foreign' in
478+ varDecl <> " " <> initName name <> " Once\n" <>
479+ varDecl <> " " <> valueName name <> " " <> anyType <> "\n\n" <>
480+ "func " <>
481+ withPrefix name <>
482+ "() Any { \n" <>
483+ " " <> initName name <> ".Do(func() {\n" <>
484+ " " <> valueName name <> " = " <>
485+ "Get(" <> foreignDict <> ", " <>
486+ (stringLiteral . mkString $ runIdent foreign') <> ")\n" <>
487+ " })\n" <>
488+ " return " <> valueName name <> "\n" <>
489+ "}\n\n") <$> foreigns))) <>
490+ if mn == "Main" || mn == "Test.Main" then mainSource else "\n"
491+ where
492+ mainSource :: Text
493+ mainSource = "\
494+ \func main() {\n\
495+ \ Run(Ꞌmain())\n\
496+ \}\n\n\
497+ \"
498+
499+varDecl :: Text
500+varDecl = "var"
501+
502+renderArg :: Text -> Text -> Text
503+renderArg decl arg = arg <> " " <> decl
504+
505+foreignMod :: Text
506+foreignMod = "Foreign"
507+
508+foreignDict :: Text
509+foreignDict = "foreign"
510+
511+modLabel :: Text
512+modLabel = "purescript-native"
513+
514+modPrefix :: Text
515+modPrefix = modLabel <> "/output"
516+
517+runtime :: Text
518+runtime = "github.com/" <> modLabel <> "/go-runtime"
519+
520+ffiLoader :: Text
521+ffiLoader = modLabel <> "/ffi-loader"
522+
523+initName :: Text -> Text
524+initName s = "ᛌ" <> s <> "_once"
525+
526+valueName :: Text -> Text
527+valueName s = "ᛧ" <> s
src/Control/Monad/Supply.hsdeleted−43
@@ -1,43 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Control.Monad.Supply
4−-- Copyright : (c) Phil Freeman 2014
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- |
12−-- Fresh variable supply
13−--
14−-----------------------------------------------------------------------------
15−
16−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
17−
18−module Control.Monad.Supply where
19−
20−import Data.Functor.Identity
21−
22−import Control.Applicative
23−import Control.Monad.State
24−import Control.Monad.Error.Class (MonadError(..))
25−import Control.Monad.Reader
26−import Control.Monad.Writer
27−
28−newtype SupplyT m a = SupplyT { unSupplyT :: StateT Integer m a }
29− deriving (Functor, Applicative, Monad, MonadTrans, MonadError e, MonadWriter w, MonadReader r)
30−
31−runSupplyT :: Integer -> SupplyT m a -> m (a, Integer)
32−runSupplyT n = flip runStateT n . unSupplyT
33−
34−evalSupplyT :: (Functor m) => Integer -> SupplyT m a -> m a
35−evalSupplyT n = fmap fst . runSupplyT n
36−
37−type Supply = SupplyT Identity
38−
39−runSupply :: Integer -> Supply a -> (a, Integer)
40−runSupply n = runIdentity . runSupplyT n
41−
42−evalSupply :: Integer -> Supply a -> a
43−evalSupply n = runIdentity . evalSupplyT n
src/Control/Monad/Supply/Class.hsdeleted−36
@@ -1,36 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Control.Monad.Supply.Class
4−-- Copyright : (c) PureScript 2015
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- |
12−-- A class for monads supporting a supply of fresh names
13−--
14−-----------------------------------------------------------------------------
15−
16−{-# LANGUAGE MultiParamTypeClasses #-}
17−
18−module Control.Monad.Supply.Class where
19−
20−import Control.Monad.Supply
21−import Control.Monad.State
22−
23−class (Monad m) => MonadSupply m where
24− fresh :: m Integer
25−
26−instance (Monad m) => MonadSupply (SupplyT m) where
27− fresh = SupplyT $ do
28− n <- get
29− put (n + 1)
30− return n
31−
32−instance (MonadSupply m) => MonadSupply (StateT s m) where
33− fresh = lift fresh
34−
35−freshName :: (MonadSupply m) => m String
36−freshName = liftM (('_' :) . show) fresh
src/Control/Monad/Unify.hsdeleted−159
@@ -1,159 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Control.Monad.Unify
4−-- Copyright : (c) Phil Freeman 2013
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- |
12−--
13−--
14−-----------------------------------------------------------------------------
15−
16−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
17−{-# LANGUAGE FlexibleInstances #-}
18−{-# LANGUAGE FlexibleContexts #-}
19−{-# LANGUAGE DeriveDataTypeable #-}
20−{-# LANGUAGE MultiParamTypeClasses #-}
21−{-# LANGUAGE FunctionalDependencies #-}
22−{-# LANGUAGE UndecidableInstances #-}
23−
24−module Control.Monad.Unify where
25−
26−import Data.Monoid
27−
28−import Control.Applicative
29−import Control.Monad.State
30−import Control.Monad.Error.Class (MonadError(..))
31−
32−import Data.HashMap.Strict as M
33−
34−-- |
35−-- Untyped unification variables
36−--
37−type Unknown = Int
38−
39−-- |
40−-- A type which can contain unification variables
41−--
42−class Partial t where
43− unknown :: Unknown -> t
44− isUnknown :: t -> Maybe Unknown
45− unknowns :: t -> [Unknown]
46− ($?) :: Substitution t -> t -> t
47−
48−-- |
49−-- Identifies types which support unification
50−--
51−class (Partial t) => Unifiable m t | t -> m where
52− (=?=) :: t -> t -> UnifyT t m ()
53−
54−-- |
55−-- A substitution maintains a mapping from unification variables to their values
56−--
57−data Substitution t = Substitution { runSubstitution :: M.HashMap Int t }
58−
59−instance (Partial t) => Monoid (Substitution t) where
60− mempty = Substitution M.empty
61− s1 `mappend` s2 = Substitution $
62− M.map (s2 $?) (runSubstitution s1) `M.union`
63− M.map (s1 $?) (runSubstitution s2)
64−
65−-- |
66−-- State required for type checking
67−--
68−data UnifyState t = UnifyState {
69− -- |
70− -- The next fresh unification variable
71− --
72− unifyNextVar :: Int
73− -- |
74− -- The current substitution
75− --
76− , unifyCurrentSubstitution :: Substitution t
77− }
78−
79−-- |
80−-- An empty @UnifyState@
81−--
82−defaultUnifyState :: (Partial t) => UnifyState t
83−defaultUnifyState = UnifyState 0 mempty
84−
85−-- |
86−-- A class for errors which support unification errors
87−--
88−class UnificationError t e where
89− occursCheckFailed :: t -> e
90−
91−-- |
92−-- The type checking monad, which provides the state of the type checker, and error reporting capabilities
93−--
94−newtype UnifyT t m a = UnifyT { unUnify :: StateT (UnifyState t) m a }
95− deriving (Functor, Monad, Applicative, Alternative, MonadPlus)
96−
97−instance (MonadState s m) => MonadState s (UnifyT t m) where
98− get = UnifyT . lift $ get
99− put = UnifyT . lift . put
100−
101−instance (MonadError e m) => MonadError e (UnifyT t m) where
102− throwError = UnifyT . throwError
103− catchError e f = UnifyT $ catchError (unUnify e) (unUnify . f)
104−
105−-- |
106−-- Run a computation in the Unify monad, failing with an error, or succeeding with a return value and the new next unification variable
107−--
108−runUnify :: UnifyState t -> UnifyT t m a -> m (a, UnifyState t)
109−runUnify s = flip runStateT s . unUnify
110−
111−-- |
112−-- Substitute a single unification variable
113−--
114−substituteOne :: (Partial t) => Unknown -> t -> Substitution t
115−substituteOne u t = Substitution $ M.singleton u t
116−
117−-- |
118−-- Replace a unification variable with the specified value in the current substitution
119−--
120−(=:=) :: (UnificationError t e, Monad m, MonadError e m, Unifiable m t) => Unknown -> t -> UnifyT t m ()
121−(=:=) u t' = do
122− st <- UnifyT get
123− let sub = unifyCurrentSubstitution st
124− let t = sub $? t'
125− occursCheck u t
126− let current = sub $? unknown u
127− case isUnknown current of
128− Just u1 | u1 == u -> return ()
129− _ -> current =?= t
130− UnifyT $ modify $ \s -> s { unifyCurrentSubstitution = substituteOne u t <> unifyCurrentSubstitution s }
131−
132−-- |
133−-- Perform the occurs check, to make sure a unification variable does not occur inside a value
134−--
135−occursCheck :: (UnificationError t e, Monad m, MonadError e m, Partial t) => Unknown -> t -> UnifyT t m ()
136−occursCheck u t =
137− case isUnknown t of
138− Nothing -> when (u `elem` unknowns t) $ UnifyT . lift . throwError $ occursCheckFailed t
139− _ -> return ()
140−
141−-- |
142−-- Generate a fresh untyped unification variable
143−--
144−fresh' :: (Monad m) => UnifyT t m Unknown
145−fresh' = do
146− st <- UnifyT get
147− UnifyT $ modify $ \s -> s { unifyNextVar = succ (unifyNextVar s) }
148− return $ unifyNextVar st
149−
150−-- |
151−-- Generate a fresh unification variable at a specific type
152−--
153−fresh :: (Monad m, Partial t) => UnifyT t m t
154−fresh = do
155− u <- fresh'
156− return $ unknown u
157−
158−
159−
src/Language/PureScript.hsdeleted−287
@@ -1,287 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript
4−-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- |
12−-- The main compiler module
13−--
14−-----------------------------------------------------------------------------
15−
16−{-# LANGUAGE DataKinds #-}
17−{-# LANGUAGE QuasiQuotes #-}
18−{-# LANGUAGE TemplateHaskell #-}
19−{-# LANGUAGE FlexibleContexts #-}
20−{-# LANGUAGE ScopedTypeVariables #-}
21−
22−module Language.PureScript
23− ( module P
24− , compile
25− , compile'
26− , RebuildPolicy(..)
27− , MonadMake(..)
28− , make
29− , version
30− ) where
31−
32−import Data.Function (on)
33−import Data.List (sortBy, groupBy, intercalate)
34−import Data.Maybe (fromMaybe)
35−import Data.Time.Clock
36−import Data.Version (Version)
37−import qualified Data.Traversable as T (traverse)
38−import qualified Data.Map as M
39−import qualified Data.Set as S
40−
41−import Control.Applicative
42−import Control.Arrow ((&&&))
43−import Control.Monad
44−import Control.Monad.Error.Class (MonadError(..))
45−import Control.Monad.Reader
46−import Control.Monad.Writer
47−
48−import System.FilePath ((</>))
49−
50−import Language.PureScript.AST as P
51−import Language.PureScript.Comments as P
52−import Language.PureScript.CodeGen as P
53−import Language.PureScript.DeadCodeElimination as P
54−import Language.PureScript.Environment as P
55−import Language.PureScript.Errors as P
56−import Language.PureScript.Kinds as P
57−import Language.PureScript.Linter as P
58−import Language.PureScript.ModuleDependencies as P
59−import Language.PureScript.Names as P
60−import Language.PureScript.Options as P
61−import Language.PureScript.Parser as P
62−import Language.PureScript.Pretty as P
63−import Language.PureScript.Renamer as P
64−import Language.PureScript.Sugar as P
65−import Control.Monad.Supply as P
66−import Language.PureScript.TypeChecker as P
67−import Language.PureScript.Types as P
68−import qualified Language.PureScript.CoreFn as CoreFn
69−import qualified Language.PureScript.Constants as C
70−
71−import qualified Paths_purescript as Paths
72−
73−-- |
74−-- Compile a collection of modules
75−--
76−-- The compilation pipeline proceeds as follows:
77−--
78−-- * Sort the modules based on module dependencies, checking for cyclic dependencies.
79−--
80−-- * Perform a set of desugaring passes.
81−--
82−-- * Type check, and elaborate values to include type annotations and type class dictionaries.
83−--
84−-- * Regroup values to take into account new value dependencies introduced by elaboration.
85−--
86−-- * Eliminate dead code.
87−--
88−-- * Generate Javascript, and perform optimization passes.
89−--
90−-- * Pretty-print the generated Javascript
91−--
92−compile :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadReader (Options Compile) m)
93− => [Module] -> [String] -> m (String, String, Environment)
94−compile = compile' initEnvironment
95−
96−compile' :: (Functor m, Applicative m, MonadError MultipleErrors m, MonadWriter MultipleErrors m, MonadReader (Options Compile) m)
97− => Environment -> [Module] -> [String] -> m (String, String, Environment)
98−compile' env ms prefix = do
99− noPrelude <- asks optionsNoPrelude
100− unless noPrelude (checkPreludeIsDefined ms)
101− additional <- asks optionsAdditional
102− mainModuleIdent <- asks (fmap moduleNameFromString . optionsMain)
103− (sorted, _) <- sortModules $ map importPrim $ if noPrelude then ms else map importPrelude ms
104− mapM_ lint sorted
105− (desugared, nextVar) <- runSupplyT 0 $ desugar sorted
106− (elaborated, env') <- runCheck' env $ forM desugared $ typeCheckModule mainModuleIdent
107− regrouped <- createBindingGroupsModule . collapseBindingGroupsModule $ elaborated
108− let corefn = map (CoreFn.moduleToCoreFn env') regrouped
109− entryPoints = moduleNameFromString `map` entryPointModules additional
110− elim = if null entryPoints then corefn else eliminateDeadCode entryPoints corefn
111− renamed = renameInModules elim
112− codeGenModuleNames = moduleNameFromString `map` codeGenModules additional
113− modulesToCodeGen = if null codeGenModuleNames then renamed else filter (\(CoreFn.Module _ mn _ _ _ _) -> mn `elem` codeGenModuleNames) renamed
114− js <- concat <$> (evalSupplyT nextVar $ T.traverse moduleToJs modulesToCodeGen)
115− let exts = intercalate "\n" . map (`moduleToPs` env') $ regrouped
116− js' <- generateMain env' js
117− let pjs = unlines $ map ("// " ++) prefix ++ [prettyPrintJS js']
118− return (pjs, exts, env')
119−
120−generateMain :: (MonadError MultipleErrors m, MonadReader (Options Compile) m) => Environment -> [JS] -> m [JS]
121−generateMain env js = do
122− main <- asks optionsMain
123− additional <- asks optionsAdditional
124− case moduleNameFromString <$> main of
125− Just mmi -> do
126− when ((mmi, Ident C.main) `M.notMember` names env) $
127− throwError . errorMessage $ NameIsUndefined (Ident C.main)
128− return $ js ++ [JSApp (JSAccessor C.main (JSAccessor (moduleNameToJs mmi) (JSVar (browserNamespace additional)))) []]
129− _ -> return js
130−
131−-- |
132−-- A type class which collects the IO actions we need to be able to run in "make" mode
133−--
134−class (MonadReader (P.Options P.Make) m, MonadError MultipleErrors m, MonadWriter MultipleErrors m) => MonadMake m where
135− -- |
136− -- Get a file timestamp
137− --
138− getTimestamp :: FilePath -> m (Maybe UTCTime)
139−
140− -- |
141− -- Read a file as a string
142− --
143− readTextFile :: FilePath -> m String
144−
145− -- |
146− -- Write a text file
147− --
148− writeTextFile :: FilePath -> String -> m ()
149−
150− -- |
151− -- Respond to a progress update
152− --
153− progress :: String -> m ()
154−
155−-- |
156−-- Determines when to rebuild a module
157−--
158−data RebuildPolicy
159− -- | Never rebuild this module
160− = RebuildNever
161− -- | Always rebuild this module
162− | RebuildAlways deriving (Show, Eq, Ord)
163−
164−-- Traverse (Either e) instance (base 4.7)
165−traverseEither :: Applicative f => (a -> f b) -> Either e a -> f (Either e b)
166−traverseEither _ (Left x) = pure (Left x)
167−traverseEither f (Right y) = Right <$> f y
168−
169−-- |
170−-- Compiles in "make" mode, compiling each module separately to a js files and an externs file
171−--
172−-- If timestamps have not changed, the externs file can be used to provide the module's types without
173−-- having to typecheck the module again.
174−--
175−make :: forall m. (Functor m, Applicative m, Monad m, MonadMake m)
176− => FilePath -> [(Either RebuildPolicy FilePath, Module)] -> [String] -> m Environment
177−make outputDir ms prefix = do
178− noPrelude <- asks optionsNoPrelude
179− unless noPrelude (checkPreludeIsDefined (map snd ms))
180− let filePathMap = M.fromList (map (\(fp, Module _ mn _ _) -> (mn, fp)) ms)
181−
182− (sorted, graph) <- sortModules $ map importPrim $ if noPrelude then map snd ms else map (importPrelude . snd) ms
183−
184− mapM_ lint sorted
185−
186− toRebuild <- foldM (\s (Module _ moduleName' _ _) -> do
187− let filePath = runModuleName moduleName'
188−
189− jsFile = outputDir </> filePath </> "index.js"
190− externsFile = outputDir </> filePath </> "externs.purs"
191− inputFile = fromMaybe (error "Module has no filename in 'make'") $ M.lookup moduleName' filePathMap
192−
193− jsTimestamp <- getTimestamp jsFile
194− externsTimestamp <- getTimestamp externsFile
195− inputTimestamp <- traverseEither getTimestamp inputFile
196−
197− return $ case (inputTimestamp, jsTimestamp, externsTimestamp) of
198− (Right (Just t1), Just t2, Just t3) | t1 < min t2 t3 -> s
199− (Left RebuildNever, Just _, Just _) -> s
200− _ -> S.insert moduleName' s) S.empty sorted
201−
202− marked <- rebuildIfNecessary (reverseDependencies graph) toRebuild sorted
203−
204− (desugared, nextVar) <- runSupplyT 0 $ zip (map fst marked) <$> desugar (map snd marked)
205−
206− evalSupplyT nextVar $ go initEnvironment desugared
207−
208− where
209− go :: Environment -> [(Bool, Module)] -> SupplyT m Environment
210− go env [] = return env
211− go env ((False, m) : ms') = do
212− (_, env') <- lift . runCheck' env $ typeCheckModule Nothing m
213−
214− go env' ms'
215− go env ((True, m@(Module coms moduleName' _ exps)) : ms') = do
216− let filePath = runModuleName moduleName'
217− jsFile = outputDir </> filePath </> "index.js"
218− externsFile = outputDir </> filePath </> "externs.purs"
219−
220− lift . progress $ "Compiling " ++ runModuleName moduleName'
221−
222− (Module _ _ elaborated _, env') <- lift . runCheck' env $ typeCheckModule Nothing m
223−
224− regrouped <- createBindingGroups moduleName' . collapseBindingGroups $ elaborated
225−
226− let mod' = Module coms moduleName' regrouped exps
227− corefn = CoreFn.moduleToCoreFn env' mod'
228− [renamed] = renameInModules [corefn]
229−
230− pjs <- prettyPrintJS <$> moduleToJs renamed
231− let js = unlines $ map ("// " ++) prefix ++ [pjs]
232− let exts = unlines $ map ("-- " ++) prefix ++ [moduleToPs mod' env']
233−
234− lift $ writeTextFile jsFile js
235− lift $ writeTextFile externsFile exts
236−
237− go env' ms'
238−
239− rebuildIfNecessary :: M.Map ModuleName [ModuleName] -> S.Set ModuleName -> [Module] -> m [(Bool, Module)]
240− rebuildIfNecessary _ _ [] = return []
241− rebuildIfNecessary graph toRebuild (m@(Module _ moduleName' _ _) : ms') | moduleName' `S.member` toRebuild = do
242− let deps = fromMaybe [] $ moduleName' `M.lookup` graph
243− toRebuild' = toRebuild `S.union` S.fromList deps
244− (:) (True, m) <$> rebuildIfNecessary graph toRebuild' ms'
245− rebuildIfNecessary graph toRebuild (Module _ moduleName' _ _ : ms') = do
246− let externsFile = outputDir </> runModuleName moduleName' </> "externs.purs"
247− externs <- readTextFile externsFile
248− externsModules <- fmap (map snd) . either (throwError . errorMessage . ErrorParsingExterns) return $ P.parseModulesFromFiles id [(externsFile, externs)]
249− case externsModules of
250− [m'@(Module _ moduleName'' _ _)] | moduleName'' == moduleName' -> (:) (False, m') <$> rebuildIfNecessary graph toRebuild ms'
251− _ -> throwError . errorMessage . InvalidExternsFile $ externsFile
252−
253−checkPreludeIsDefined :: (MonadWriter MultipleErrors m) => [Module] -> m ()
254−checkPreludeIsDefined ms = do
255− let mns = map getModuleName ms
256− unless (preludeModuleName `elem` mns) $
257− tell (errorMessage PreludeNotPresent)
258−
259−reverseDependencies :: ModuleGraph -> M.Map ModuleName [ModuleName]
260−reverseDependencies g = combine [ (dep, mn) | (mn, deps) <- g, dep <- deps ]
261− where
262− combine :: (Ord a) => [(a, b)] -> M.Map a [b]
263− combine = M.fromList . map ((fst . head) &&& map snd) . groupBy ((==) `on` fst) . sortBy (compare `on` fst)
264−
265−-- |
266−-- Add an import declaration for a module if it does not already explicitly import it.
267−--
268−addDefaultImport :: ModuleName -> Module -> Module
269−addDefaultImport toImport m@(Module coms mn decls exps) =
270− if isExistingImport `any` decls || mn == toImport then m
271− else Module coms mn (ImportDeclaration toImport Implicit Nothing : decls) exps
272− where
273− isExistingImport (ImportDeclaration mn' _ _) | mn' == toImport = True
274− isExistingImport (PositionedDeclaration _ _ d) = isExistingImport d
275− isExistingImport _ = False
276−
277−importPrim :: Module -> Module
278−importPrim = addDefaultImport (ModuleName [ProperName C.prim])
279−
280−preludeModuleName :: ModuleName
281−preludeModuleName = ModuleName [ProperName C.prelude]
282−
283−importPrelude :: Module -> Module
284−importPrelude = addDefaultImport preludeModuleName
285−
286−version :: Version
287−version = Paths.version
src/Language/PureScript/AST.hsdeleted−23
@@ -1,23 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.AST
4−-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- | The initial PureScript AST
12−--
13−-----------------------------------------------------------------------------
14−
15−module Language.PureScript.AST (
16− module AST
17−) where
18−
19−import Language.PureScript.AST.Binders as AST
20−import Language.PureScript.AST.Declarations as AST
21−import Language.PureScript.AST.Operators as AST
22−import Language.PureScript.AST.SourcePos as AST
23−import Language.PureScript.AST.Traversals as AST
src/Language/PureScript/AST/Binders.hsdeleted−87
@@ -1,87 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.AST.Binders
4−-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- | Case binders
12−--
13−-----------------------------------------------------------------------------
14−
15−{-# LANGUAGE DeriveDataTypeable #-}
16−
17−module Language.PureScript.AST.Binders where
18−
19−import qualified Data.Data as D
20−
21−import Language.PureScript.AST.SourcePos
22−import Language.PureScript.Names
23−import Language.PureScript.Comments
24−
25−-- |
26−-- Data type for binders
27−--
28−data Binder
29− -- |
30− -- Wildcard binder
31− --
32− = NullBinder
33− -- |
34− -- A binder which matches a boolean literal
35− --
36− | BooleanBinder Bool
37− -- |
38− -- A binder which matches a string literal
39− --
40− | StringBinder String
41− -- |
42− -- A binder which matches a numeric literal
43− --
44− | NumberBinder (Either Integer Double)
45− -- |
46− -- A binder which binds an identifier
47− --
48− | VarBinder Ident
49− -- |
50− -- A binder which matches a data constructor
51− --
52− | ConstructorBinder (Qualified ProperName) [Binder]
53− -- |
54− -- A binder which matches a record and binds its properties
55− --
56− | ObjectBinder [(String, Binder)]
57− -- |
58− -- A binder which matches an array and binds its elements
59− --
60− | ArrayBinder [Binder]
61− -- |
62− -- A binder which matches an array and binds its head and tail
63− --
64− | ConsBinder Binder Binder
65− -- |
66− -- A binder which binds its input to an identifier
67− --
68− | NamedBinder Ident Binder
69− -- |
70− -- A binder with source position information
71− --
72− | PositionedBinder SourceSpan [Comment] Binder deriving (Show, D.Data, D.Typeable)
73−
74−-- |
75−-- Collect all names introduced in binders in an expression
76−--
77−binderNames :: Binder -> [Ident]
78−binderNames = go []
79− where
80− go ns (VarBinder name) = name : ns
81− go ns (ConstructorBinder _ bs) = foldl go ns bs
82− go ns (ObjectBinder bs) = foldl go ns (map snd bs)
83− go ns (ArrayBinder bs) = foldl go ns bs
84− go ns (ConsBinder b1 b2) = go (go ns b1) b2
85− go ns (NamedBinder name b) = go (name : ns) b
86− go ns (PositionedBinder _ _ b) = go ns b
87− go ns _ = ns
src/Language/PureScript/AST/Declarations.hsdeleted−454
@@ -1,454 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.AST.Declarations
4−-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- | Data types for modules and declarations
12−--
13−-----------------------------------------------------------------------------
14−
15−{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-}
16−
17−module Language.PureScript.AST.Declarations where
18−
19−import qualified Data.Data as D
20−
21−import Language.PureScript.AST.Binders
22−import Language.PureScript.AST.Operators
23−import Language.PureScript.AST.SourcePos
24−import Language.PureScript.Types
25−import Language.PureScript.Names
26−import Language.PureScript.Kinds
27−import Language.PureScript.TypeClassDictionaries
28−import Language.PureScript.Comments
29−import Language.PureScript.CodeGen.JS.AST
30−import Language.PureScript.Environment
31−
32−-- |
33−-- A module declaration, consisting of comments about the module, a module name,
34−-- a list of declarations, and a list of the declarations that are
35−-- explicitly exported. If the export list is Nothing, everything is exported.
36−--
37−data Module = Module [Comment] ModuleName [Declaration] (Maybe [DeclarationRef]) deriving (Show, D.Data, D.Typeable)
38−
39−-- | Return a module's name.
40−getModuleName :: Module -> ModuleName
41−getModuleName (Module _ name _ _) = name
42−
43−-- |
44−-- Test if a declaration is exported, given a module's export list.
45−--
46−isExported :: Maybe [DeclarationRef] -> Declaration -> Bool
47−isExported Nothing _ = True
48−isExported _ TypeInstanceDeclaration{} = True
49−isExported exps (PositionedDeclaration _ _ d) = isExported exps d
50−isExported (Just exps) decl = any (matches decl) exps
51− where
52− matches (TypeDeclaration ident _) (ValueRef ident') = ident == ident'
53− matches (ValueDeclaration ident _ _ _) (ValueRef ident') = ident == ident'
54− matches (ExternDeclaration _ ident _ _) (ValueRef ident') = ident == ident'
55− matches (DataDeclaration _ ident _ _) (TypeRef ident' _) = ident == ident'
56− matches (ExternDataDeclaration ident _) (TypeRef ident' _) = ident == ident'
57− matches (TypeSynonymDeclaration ident _ _) (TypeRef ident' _) = ident == ident'
58− matches (TypeClassDeclaration ident _ _ _) (TypeClassRef ident') = ident == ident'
59− matches (PositionedDeclaration _ _ d) r = d `matches` r
60− matches d (PositionedDeclarationRef _ _ r) = d `matches` r
61− matches _ _ = False
62−
63−exportedDeclarations :: Module -> [Declaration]
64−exportedDeclarations (Module _ _ decls exps) = filter (isExported exps) (flattenDecls decls)
65−
66−-- |
67−-- Test if a data constructor for a given type is exported, given a module's export list.
68−--
69−isDctorExported :: ProperName -> Maybe [DeclarationRef] -> ProperName -> Bool
70−isDctorExported _ Nothing _ = True
71−isDctorExported ident (Just exps) ctor = test `any` exps
72− where
73− test (PositionedDeclarationRef _ _ d) = test d
74− test (TypeRef ident' Nothing) = ident == ident'
75− test (TypeRef ident' (Just ctors)) = ident == ident' && ctor `elem` ctors
76− test _ = False
77−
78−-- |
79−-- Return the exported data constructors for a given type.
80−--
81−exportedDctors :: Module -> ProperName -> [(ProperName, [Type])]
82−exportedDctors (Module _ _ decls exps) ident =
83− filter (isDctorExported ident exps . fst) dctors
84− where
85− dctors = concatMap getDctors (flattenDecls decls)
86− getDctors (DataDeclaration _ _ _ ctors) = ctors
87− getDctors (PositionedDeclaration _ _ d) = getDctors d
88− getDctors _ = []
89−
90−-- |
91−-- An item in a list of explicit imports or exports
92−--
93−data DeclarationRef
94− -- |
95− -- A type constructor with data constructors
96− --
97− = TypeRef ProperName (Maybe [ProperName])
98− -- |
99− -- A value
100− --
101− | ValueRef Ident
102− -- |
103− -- A type class
104− --
105− | TypeClassRef ProperName
106− -- |
107− -- A type class instance, created during typeclass desugaring (name, class name, instance types)
108− --
109− | TypeInstanceRef Ident
110− -- |
111− -- A declaration reference with source position information
112− --
113− | PositionedDeclarationRef SourceSpan [Comment] DeclarationRef
114− deriving (Show, D.Data, D.Typeable)
115−
116−instance Eq DeclarationRef where
117− (TypeRef name dctors) == (TypeRef name' dctors') = name == name' && dctors == dctors'
118− (ValueRef name) == (ValueRef name') = name == name'
119− (TypeClassRef name) == (TypeClassRef name') = name == name'
120− (TypeInstanceRef name) == (TypeInstanceRef name') = name == name'
121− (PositionedDeclarationRef _ _ r) == r' = r == r'
122− r == (PositionedDeclarationRef _ _ r') = r == r'
123− _ == _ = False
124−
125−-- |
126−-- The data type which specifies type of import declaration
127−--
128−data ImportDeclarationType
129− -- |
130− -- An import with no explicit list: `import M`
131− --
132− = Implicit
133− -- |
134− -- An import with an explicit list of references to import: `import M (foo)`
135− --
136− | Explicit [DeclarationRef]
137− -- |
138− -- An import with a list of references to hide: `import M hiding (foo)`
139− --
140− | Hiding [DeclarationRef]
141− deriving (Show, D.Data, D.Typeable)
142−
143−-- |
144−-- The data type of declarations
145−--
146−data Declaration
147− -- |
148− -- A data type declaration (data or newtype, name, arguments, data constructors)
149− --
150− = DataDeclaration DataDeclType ProperName [(String, Maybe Kind)] [(ProperName, [Type])]
151− -- |
152− -- A minimal mutually recursive set of data type declarations
153− --
154− | DataBindingGroupDeclaration [Declaration]
155− -- |
156− -- A type synonym declaration (name, arguments, type)
157− --
158− | TypeSynonymDeclaration ProperName [(String, Maybe Kind)] Type
159− -- |
160− -- A type declaration for a value (name, ty)
161− --
162− | TypeDeclaration Ident Type
163− -- |
164− -- A value declaration (name, top-level binders, optional guard, value)
165− --
166− | ValueDeclaration Ident NameKind [Binder] (Either [(Guard, Expr)] Expr)
167− -- |
168− -- A minimal mutually recursive set of value declarations
169− --
170− | BindingGroupDeclaration [(Ident, NameKind, Expr)]
171− -- |
172− -- A foreign import declaration (type, name, optional inline Javascript, type)
173− --
174− | ExternDeclaration ForeignImportType Ident (Maybe JS) Type
175− -- |
176− -- A data type foreign import (name, kind)
177− --
178− | ExternDataDeclaration ProperName Kind
179− -- |
180− -- A type class instance foreign import
181− --
182− | ExternInstanceDeclaration Ident [Constraint] (Qualified ProperName) [Type]
183− -- |
184− -- A fixity declaration (fixity data, operator name)
185− --
186− | FixityDeclaration Fixity String
187− -- |
188− -- A module import (module name, qualified/unqualified/hiding, optional "qualified as" name)
189− --
190− | ImportDeclaration ModuleName ImportDeclarationType (Maybe ModuleName)
191− -- |
192− -- A type class declaration (name, argument, implies, member declarations)
193− --
194− | TypeClassDeclaration ProperName [(String, Maybe Kind)] [Constraint] [Declaration]
195− -- |
196− -- A type instance declaration (name, dependencies, class name, instance types, member
197− -- declarations)
198− --
199− | TypeInstanceDeclaration Ident [Constraint] (Qualified ProperName) [Type] [Declaration]
200− -- |
201− -- A declaration with source position information
202− --
203− | PositionedDeclaration SourceSpan [Comment] Declaration
204− deriving (Show, D.Data, D.Typeable)
205−
206−-- |
207−-- Test if a declaration is a value declaration
208−--
209−isValueDecl :: Declaration -> Bool
210−isValueDecl ValueDeclaration{} = True
211−isValueDecl (PositionedDeclaration _ _ d) = isValueDecl d
212−isValueDecl _ = False
213−
214−-- |
215−-- Test if a declaration is a data type or type synonym declaration
216−--
217−isDataDecl :: Declaration -> Bool
218−isDataDecl DataDeclaration{} = True
219−isDataDecl TypeSynonymDeclaration{} = True
220−isDataDecl (PositionedDeclaration _ _ d) = isDataDecl d
221−isDataDecl _ = False
222−
223−-- |
224−-- Test if a declaration is a module import
225−--
226−isImportDecl :: Declaration -> Bool
227−isImportDecl ImportDeclaration{} = True
228−isImportDecl (PositionedDeclaration _ _ d) = isImportDecl d
229−isImportDecl _ = False
230−
231−-- |
232−-- Test if a declaration is a data type foreign import
233−--
234−isExternDataDecl :: Declaration -> Bool
235−isExternDataDecl ExternDataDeclaration{} = True
236−isExternDataDecl (PositionedDeclaration _ _ d) = isExternDataDecl d
237−isExternDataDecl _ = False
238−
239−-- |
240−-- Test if a declaration is a type class instance foreign import
241−--
242−isExternInstanceDecl :: Declaration -> Bool
243−isExternInstanceDecl ExternInstanceDeclaration{} = True
244−isExternInstanceDecl (PositionedDeclaration _ _ d) = isExternInstanceDecl d
245−isExternInstanceDecl _ = False
246−
247−-- |
248−-- Test if a declaration is a fixity declaration
249−--
250−isFixityDecl :: Declaration -> Bool
251−isFixityDecl FixityDeclaration{} = True
252−isFixityDecl (PositionedDeclaration _ _ d) = isFixityDecl d
253−isFixityDecl _ = False
254−
255−-- |
256−-- Test if a declaration is a foreign import
257−--
258−isExternDecl :: Declaration -> Bool
259−isExternDecl ExternDeclaration{} = True
260−isExternDecl (PositionedDeclaration _ _ d) = isExternDecl d
261−isExternDecl _ = False
262−
263−-- |
264−-- Test if a declaration is a type class instance declaration
265−--
266−isTypeClassInstanceDeclaration :: Declaration -> Bool
267−isTypeClassInstanceDeclaration TypeInstanceDeclaration{} = True
268−isTypeClassInstanceDeclaration (PositionedDeclaration _ _ d) = isTypeClassInstanceDeclaration d
269−isTypeClassInstanceDeclaration _ = False
270−
271−-- |
272−-- Test if a declaration is a type class declaration
273−--
274−isTypeClassDeclaration :: Declaration -> Bool
275−isTypeClassDeclaration TypeClassDeclaration{} = True
276−isTypeClassDeclaration (PositionedDeclaration _ _ d) = isTypeClassDeclaration d
277−isTypeClassDeclaration _ = False
278−
279−-- |
280−-- Recursively flatten data binding groups in the list of declarations
281−flattenDecls :: [Declaration] -> [Declaration]
282−flattenDecls = concatMap flattenOne
283− where flattenOne :: Declaration -> [Declaration]
284− flattenOne (DataBindingGroupDeclaration decls) = concatMap flattenOne decls
285− flattenOne d = [d]
286−
287−-- |
288−-- A guard is just a boolean-valued expression that appears alongside a set of binders
289−--
290−type Guard = Expr
291−
292−-- |
293−-- Data type for expressions and terms
294−--
295−data Expr
296− -- |
297− -- A numeric literal
298− --
299− = NumericLiteral (Either Integer Double)
300− -- |
301− -- A string literal
302− --
303− | StringLiteral String
304− -- |
305− -- A boolean literal
306− --
307− | BooleanLiteral Bool
308− -- |
309− -- A prefix -, will be desugared
310− --
311− | UnaryMinus Expr
312− -- |
313− -- Binary operator application. During the rebracketing phase of desugaring, this data constructor
314− -- will be removed.
315− --
316− | BinaryNoParens Expr Expr Expr
317− -- |
318− -- Explicit parentheses. During the rebracketing phase of desugaring, this data constructor
319− -- will be removed.
320− --
321− | Parens Expr
322− -- |
323− -- Operator section. This will be removed during desugaring and replaced with a partially applied
324− -- operator or lambda to flip the arguments.
325− --
326− | OperatorSection Expr (Either Expr Expr)
327− -- |
328− -- An array literal
329− --
330− | ArrayLiteral [Expr]
331− -- |
332− -- An object literal
333− --
334− | ObjectLiteral [(String, Expr)]
335− -- |
336− -- An object constructor (object literal with underscores). This will be removed during
337− -- desugaring and expanded into a lambda that returns an object literal.
338− --
339− | ObjectConstructor [(String, Maybe Expr)]
340− -- |
341− -- An object property getter (e.g. `_.x`). This will be removed during
342− -- desugaring and expanded into a lambda that reads a property from an object.
343− --
344− | ObjectGetter String
345− -- |
346− -- An record property accessor expression
347− --
348− | Accessor String Expr
349− -- |
350− -- Partial record update
351− --
352− | ObjectUpdate Expr [(String, Expr)]
353− -- |
354− -- Partial record updater. This will be removed during desugaring and
355− -- expanded into a lambda that returns an object update.
356− --
357− | ObjectUpdater (Maybe Expr) [(String, Maybe Expr)]
358− -- |
359− -- Function introduction
360− --
361− | Abs (Either Ident Binder) Expr
362− -- |
363− -- Function application
364− --
365− | App Expr Expr
366− -- |
367− -- Variable
368− --
369− | Var (Qualified Ident)
370− -- |
371− -- Conditional (if-then-else expression)
372− --
373− | IfThenElse Expr Expr Expr
374− -- |
375− -- A data constructor
376− --
377− | Constructor (Qualified ProperName)
378− -- |
379− -- A case expression. During the case expansion phase of desugaring, top-level binders will get
380− -- desugared into case expressions, hence the need for guards and multiple binders per branch here.
381− --
382− | Case [Expr] [CaseAlternative]
383− -- |
384− -- A value with a type annotation
385− --
386− | TypedValue Bool Expr Type
387− -- |
388− -- A let binding
389− --
390− | Let [Declaration] Expr
391− -- |
392− -- A do-notation block
393− --
394− | Do [DoNotationElement]
395− -- |
396− -- An application of a typeclass dictionary constructor. The value should be
397− -- an ObjectLiteral.
398− --
399− | TypeClassDictionaryConstructorApp (Qualified ProperName) Expr
400− -- |
401− -- A placeholder for a type class dictionary to be inserted later. At the end of type checking, these
402− -- placeholders will be replaced with actual expressions representing type classes dictionaries which
403− -- can be evaluated at runtime. The constructor arguments represent (in order): whether or not to look
404− -- at superclass implementations when searching for a dictionary, the type class name and
405− -- instance type, and the type class dictionaries in scope.
406− --
407− | TypeClassDictionary Bool Constraint [TypeClassDictionaryInScope]
408− -- |
409− -- A typeclass dictionary accessor, the implementation is left unspecified until CoreFn desugaring.
410− --
411− | TypeClassDictionaryAccessor (Qualified ProperName) Ident
412− -- |
413− -- A placeholder for a superclass dictionary to be turned into a TypeClassDictionary during typechecking
414− --
415− | SuperClassDictionary (Qualified ProperName) [Type]
416− -- |
417− -- A value with source position information
418− --
419− | PositionedValue SourceSpan [Comment] Expr deriving (Show, D.Data, D.Typeable)
420−
421−-- |
422−-- An alternative in a case statement
423−--
424−data CaseAlternative = CaseAlternative
425− { -- |
426− -- A collection of binders with which to match the inputs
427− --
428− caseAlternativeBinders :: [Binder]
429− -- |
430− -- The result expression or a collect of guarded expressions
431− --
432− , caseAlternativeResult :: Either [(Guard, Expr)] Expr
433− } deriving (Show, D.Data, D.Typeable)
434−
435−-- |
436−-- A statement in a do-notation block
437−--
438−data DoNotationElement
439− -- |
440− -- A monadic value without a binder
441− --
442− = DoNotationValue Expr
443− -- |
444− -- A monadic value with a binder
445− --
446− | DoNotationBind Binder Expr
447− -- |
448− -- A let statement, i.e. a pure value with a binder
449− --
450− | DoNotationLet [Declaration]
451− -- |
452− -- A do notation element with source position information
453− --
454− | PositionedDoNotationElement SourceSpan [Comment] DoNotationElement deriving (Show, D.Data, D.Typeable)
src/Language/PureScript/AST/Operators.hsdeleted−39
@@ -1,39 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.AST.Operators
4−-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- | Operators fixity and associativity
12−--
13−-----------------------------------------------------------------------------
14−
15−{-# LANGUAGE DeriveDataTypeable #-}
16−
17−module Language.PureScript.AST.Operators where
18−
19−import qualified Data.Data as D
20−
21−-- |
22−-- A precedence level for an infix operator
23−--
24−type Precedence = Integer
25−
26−-- |
27−-- Associativity for infix operators
28−--
29−data Associativity = Infixl | Infixr | Infix deriving (D.Data, D.Typeable)
30−
31−instance Show Associativity where
32− show Infixl = "infixl"
33− show Infixr = "infixr"
34− show Infix = "infix"
35−
36−-- |
37−-- Fixity data for infix operators
38−--
39−data Fixity = Fixity Associativity Precedence deriving (Show, D.Data, D.Typeable)
src/Language/PureScript/AST/SourcePos.hsdeleted−58
@@ -1,58 +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 (Eq, Show, D.Data, D.Typeable)
34−
35−displaySourcePos :: SourcePos -> String
36−displaySourcePos sp =
37− "line " ++ show (sourcePosLine sp) ++
38− ", column " ++ show (sourcePosColumn sp)
39−
40−data SourceSpan = SourceSpan
41− { -- |
42− -- Source name
43− --
44− spanName :: String
45− -- |
46− -- Start of the span
47− --
48− , spanStart :: SourcePos
49− -- End of the span
50− --
51− , spanEnd :: SourcePos
52− } deriving (Eq, Show, D.Data, D.Typeable)
53−
54−displaySourceSpan :: SourceSpan -> String
55−displaySourceSpan sp =
56− spanName sp ++ " " ++
57− displaySourcePos (spanStart sp) ++ " - " ++
58− displaySourcePos (spanEnd sp)
src/Language/PureScript/AST/Traversals.hsdeleted−407
@@ -1,407 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.AST.Traversals
4−-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- | AST traversal helpers
12−--
13−-----------------------------------------------------------------------------
14−
15−module Language.PureScript.AST.Traversals where
16−
17−import Data.Monoid (Monoid(..), mconcat)
18−import Data.Maybe (mapMaybe)
19−
20−import Control.Applicative
21−import Control.Monad
22−import Control.Arrow ((***), (+++), second)
23−
24−import Language.PureScript.AST.Binders
25−import Language.PureScript.AST.Declarations
26−import Language.PureScript.Types
27−import Language.PureScript.Traversals
28−
29−everywhereOnValues :: (Declaration -> Declaration) ->
30− (Expr -> Expr) ->
31− (Binder -> Binder) ->
32− (Declaration -> Declaration, Expr -> Expr, Binder -> Binder)
33−everywhereOnValues f g h = (f', g', h')
34− where
35− f' :: Declaration -> Declaration
36− f' (DataBindingGroupDeclaration ds) = f (DataBindingGroupDeclaration (map f' ds))
37− f' (ValueDeclaration name nameKind bs val) = f (ValueDeclaration name nameKind (map h' bs) ((map (g' *** g') +++ g') val))
38− f' (BindingGroupDeclaration ds) = f (BindingGroupDeclaration (map (\(name, nameKind, val) -> (name, nameKind, g' val)) ds))
39− f' (TypeClassDeclaration name args implies ds) = f (TypeClassDeclaration name args implies (map f' ds))
40− f' (TypeInstanceDeclaration name cs className args ds) = f (TypeInstanceDeclaration name cs className args (map f' ds))
41− f' (PositionedDeclaration pos com d) = f (PositionedDeclaration pos com (f' d))
42− f' other = f other
43−
44− g' :: Expr -> Expr
45− g' (UnaryMinus v) = g (UnaryMinus (g' v))
46− g' (BinaryNoParens op v1 v2) = g (BinaryNoParens (g' op) (g' v1) (g' v2))
47− g' (Parens v) = g (Parens (g' v))
48− g' (OperatorSection op (Left v)) = g (OperatorSection (g' op) (Left $ g' v))
49− g' (OperatorSection op (Right v)) = g (OperatorSection (g' op) (Right $ g' v))
50− g' (ArrayLiteral vs) = g (ArrayLiteral (map g' vs))
51− g' (ObjectLiteral vs) = g (ObjectLiteral (map (fmap g') vs))
52− g' (ObjectConstructor vs) = g (ObjectConstructor (map (second (fmap g')) vs))
53− g' (TypeClassDictionaryConstructorApp name v) = g (TypeClassDictionaryConstructorApp name (g' v))
54− g' (Accessor prop v) = g (Accessor prop (g' v))
55− g' (ObjectUpdate obj vs) = g (ObjectUpdate (g' obj) (map (fmap g') vs))
56− g' (ObjectUpdater obj vs) = g (ObjectUpdater (fmap g' obj) (map (second (fmap g')) vs))
57− g' (Abs name v) = g (Abs name (g' v))
58− g' (App v1 v2) = g (App (g' v1) (g' v2))
59− g' (IfThenElse v1 v2 v3) = g (IfThenElse (g' v1) (g' v2) (g' v3))
60− g' (Case vs alts) = g (Case (map g' vs) (map handleCaseAlternative alts))
61− g' (TypedValue check v ty) = g (TypedValue check (g' v) ty)
62− g' (Let ds v) = g (Let (map f' ds) (g' v))
63− g' (Do es) = g (Do (map handleDoNotationElement es))
64− g' (PositionedValue pos com v) = g (PositionedValue pos com (g' v))
65− g' other = g other
66−
67− h' :: Binder -> Binder
68− h' (ConstructorBinder ctor bs) = h (ConstructorBinder ctor (map h' bs))
69− h' (ObjectBinder bs) = h (ObjectBinder (map (fmap h') bs))
70− h' (ArrayBinder bs) = h (ArrayBinder (map h' bs))
71− h' (ConsBinder b1 b2) = h (ConsBinder (h' b1) (h' b2))
72− h' (NamedBinder name b) = h (NamedBinder name (h' b))
73− h' (PositionedBinder pos com b) = h (PositionedBinder pos com (h' b))
74− h' other = h other
75−
76− handleCaseAlternative :: CaseAlternative -> CaseAlternative
77− handleCaseAlternative ca =
78− ca { caseAlternativeBinders = map h' (caseAlternativeBinders ca)
79− , caseAlternativeResult = (map (g' *** g') +++ g') (caseAlternativeResult ca)
80− }
81−
82− handleDoNotationElement :: DoNotationElement -> DoNotationElement
83− handleDoNotationElement (DoNotationValue v) = DoNotationValue (g' v)
84− handleDoNotationElement (DoNotationBind b v) = DoNotationBind (h' b) (g' v)
85− handleDoNotationElement (DoNotationLet ds) = DoNotationLet (map f' ds)
86− handleDoNotationElement (PositionedDoNotationElement pos com e) = PositionedDoNotationElement pos com (handleDoNotationElement e)
87−
88−everywhereOnValuesTopDownM :: (Functor m, Applicative m, Monad m) =>
89− (Declaration -> m Declaration) ->
90− (Expr -> m Expr) ->
91− (Binder -> m Binder) ->
92− (Declaration -> m Declaration, Expr -> m Expr, Binder -> m Binder)
93−everywhereOnValuesTopDownM f g h = (f' <=< f, g' <=< g, h' <=< h)
94− where
95− f' (DataBindingGroupDeclaration ds) = DataBindingGroupDeclaration <$> mapM (f' <=< f) ds
96− f' (ValueDeclaration name nameKind bs val) = ValueDeclaration name nameKind <$> mapM (h' <=< h) bs <*> eitherM (mapM (pairM (g' <=< g) (g' <=< g))) (g' <=< g) val
97− f' (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> mapM (\(name, nameKind, val) -> (,,) name nameKind <$> (g val >>= g')) ds
98− f' (TypeClassDeclaration name args implies ds) = TypeClassDeclaration name args implies <$> mapM (f' <=< f) ds
99− f' (TypeInstanceDeclaration name cs className args ds) = TypeInstanceDeclaration name cs className args <$> mapM (f' <=< f) ds
100− f' (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> (f d >>= f')
101− f' other = f other
102−
103− g' (UnaryMinus v) = UnaryMinus <$> (g v >>= g')
104− g' (BinaryNoParens op v1 v2) = BinaryNoParens <$> (g op >>= g') <*> (g v1 >>= g') <*> (g v2 >>= g')
105− g' (Parens v) = Parens <$> (g v >>= g')
106− g' (OperatorSection op (Left v)) = OperatorSection <$> (g op >>= g') <*> (Left <$> (g v >>= g'))
107− g' (OperatorSection op (Right v)) = OperatorSection <$> (g op >>= g') <*> (Right <$> (g v >>= g'))
108− g' (ArrayLiteral vs) = ArrayLiteral <$> mapM (g' <=< g) vs
109− g' (ObjectLiteral vs) = ObjectLiteral <$> mapM (sndM (g' <=< g)) vs
110− g' (ObjectConstructor vs) = ObjectConstructor <$> mapM (sndM $ maybeM (g' <=< g)) vs
111− g' (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> (g v >>= g')
112− g' (Accessor prop v) = Accessor prop <$> (g v >>= g')
113− g' (ObjectUpdate obj vs) = ObjectUpdate <$> (g obj >>= g') <*> mapM (sndM (g' <=< g)) vs
114− g' (ObjectUpdater obj vs) = ObjectUpdater <$> (maybeM g obj >>= maybeM g') <*> mapM (sndM $ maybeM (g' <=< g)) vs
115− g' (Abs name v) = Abs name <$> (g v >>= g')
116− g' (App v1 v2) = App <$> (g v1 >>= g') <*> (g v2 >>= g')
117− g' (IfThenElse v1 v2 v3) = IfThenElse <$> (g v1 >>= g') <*> (g v2 >>= g') <*> (g v3 >>= g')
118− g' (Case vs alts) = Case <$> mapM (g' <=< g) vs <*> mapM handleCaseAlternative alts
119− g' (TypedValue check v ty) = TypedValue check <$> (g v >>= g') <*> pure ty
120− g' (Let ds v) = Let <$> mapM (f' <=< f) ds <*> (g v >>= g')
121− g' (Do es) = Do <$> mapM handleDoNotationElement es
122− g' (PositionedValue pos com v) = PositionedValue pos com <$> (g v >>= g')
123− g' other = g other
124−
125− h' (ConstructorBinder ctor bs) = ConstructorBinder ctor <$> mapM (h' <=< h) bs
126− h' (ObjectBinder bs) = ObjectBinder <$> mapM (sndM (h' <=< h)) bs
127− h' (ArrayBinder bs) = ArrayBinder <$> mapM (h' <=< h) bs
128− h' (ConsBinder b1 b2) = ConsBinder <$> (h b1 >>= h') <*> (h b2 >>= h')
129− h' (NamedBinder name b) = NamedBinder name <$> (h b >>= h')
130− h' (PositionedBinder pos com b) = PositionedBinder pos com <$> (h b >>= h')
131− h' other = h other
132−
133− handleCaseAlternative (CaseAlternative bs val) = CaseAlternative <$> mapM (h' <=< h) bs
134− <*> eitherM (mapM (pairM (g' <=< g) (g' <=< g))) (g' <=< g) val
135−
136− handleDoNotationElement (DoNotationValue v) = DoNotationValue <$> (g' <=< g) v
137− handleDoNotationElement (DoNotationBind b v) = DoNotationBind <$> (h' <=< h) b <*> (g' <=< g) v
138− handleDoNotationElement (DoNotationLet ds) = DoNotationLet <$> mapM (f' <=< f) ds
139− handleDoNotationElement (PositionedDoNotationElement pos com e) = PositionedDoNotationElement pos com <$> handleDoNotationElement e
140−
141−everywhereOnValuesM :: (Functor m, Applicative m, Monad m) =>
142− (Declaration -> m Declaration) ->
143− (Expr -> m Expr) ->
144− (Binder -> m Binder) ->
145− (Declaration -> m Declaration, Expr -> m Expr, Binder -> m Binder)
146−everywhereOnValuesM f g h = (f', g', h')
147− where
148− f' (DataBindingGroupDeclaration ds) = (DataBindingGroupDeclaration <$> mapM f' ds) >>= f
149− f' (ValueDeclaration name nameKind bs val) = (ValueDeclaration name nameKind <$> mapM h' bs <*> eitherM (mapM (pairM g' g')) g' val) >>= f
150− f' (BindingGroupDeclaration ds) = (BindingGroupDeclaration <$> mapM (\(name, nameKind, val) -> (,,) name nameKind <$> g' val) ds) >>= f
151− f' (TypeClassDeclaration name args implies ds) = (TypeClassDeclaration name args implies <$> mapM f' ds) >>= f
152− f' (TypeInstanceDeclaration name cs className args ds) = (TypeInstanceDeclaration name cs className args <$> mapM f' ds) >>= f
153− f' (PositionedDeclaration pos com d) = (PositionedDeclaration pos com <$> f' d) >>= f
154− f' other = f other
155−
156− g' (UnaryMinus v) = (UnaryMinus <$> g' v) >>= g
157− g' (BinaryNoParens op v1 v2) = (BinaryNoParens <$> g' op <*> g' v1 <*> g' v2) >>= g
158− g' (Parens v) = (Parens <$> g' v) >>= g
159− g' (OperatorSection op (Left v)) = (OperatorSection <$> g' op <*> (Left <$> g' v)) >>= g
160− g' (OperatorSection op (Right v)) = (OperatorSection <$> g' op <*> (Right <$> g' v)) >>= g
161− g' (ArrayLiteral vs) = (ArrayLiteral <$> mapM g' vs) >>= g
162− g' (ObjectLiteral vs) = (ObjectLiteral <$> mapM (sndM g') vs) >>= g
163− g' (ObjectConstructor vs) = (ObjectConstructor <$> mapM (sndM $ maybeM g') vs) >>= g
164− g' (TypeClassDictionaryConstructorApp name v) = (TypeClassDictionaryConstructorApp name <$> g' v) >>= g
165− g' (Accessor prop v) = (Accessor prop <$> g' v) >>= g
166− g' (ObjectUpdate obj vs) = (ObjectUpdate <$> g' obj <*> mapM (sndM g') vs) >>= g
167− g' (ObjectUpdater obj vs) = (ObjectUpdater <$> maybeM g' obj <*> mapM (sndM $ maybeM g') vs) >>= g
168− g' (Abs name v) = (Abs name <$> g' v) >>= g
169− g' (App v1 v2) = (App <$> g' v1 <*> g' v2) >>= g
170− g' (IfThenElse v1 v2 v3) = (IfThenElse <$> g' v1 <*> g' v2 <*> g' v3) >>= g
171− g' (Case vs alts) = (Case <$> mapM g' vs <*> mapM handleCaseAlternative alts) >>= g
172− g' (TypedValue check v ty) = (TypedValue check <$> g' v <*> pure ty) >>= g
173− g' (Let ds v) = (Let <$> mapM f' ds <*> g' v) >>= g
174− g' (Do es) = (Do <$> mapM handleDoNotationElement es) >>= g
175− g' (PositionedValue pos com v) = (PositionedValue pos com <$> g' v) >>= g
176− g' other = g other
177−
178− h' (ConstructorBinder ctor bs) = (ConstructorBinder ctor <$> mapM h' bs) >>= h
179− h' (ObjectBinder bs) = (ObjectBinder <$> mapM (sndM h') bs) >>= h
180− h' (ArrayBinder bs) = (ArrayBinder <$> mapM h' bs) >>= h
181− h' (ConsBinder b1 b2) = (ConsBinder <$> h' b1 <*> h' b2) >>= h
182− h' (NamedBinder name b) = (NamedBinder name <$> h' b) >>= h
183− h' (PositionedBinder pos com b) = (PositionedBinder pos com <$> h' b) >>= h
184− h' other = h other
185−
186− handleCaseAlternative (CaseAlternative bs val) = CaseAlternative <$> mapM h' bs
187− <*> eitherM (mapM (pairM g' g')) g' val
188−
189− handleDoNotationElement (DoNotationValue v) = DoNotationValue <$> g' v
190− handleDoNotationElement (DoNotationBind b v) = DoNotationBind <$> h' b <*> g' v
191− handleDoNotationElement (DoNotationLet ds) = DoNotationLet <$> mapM f' ds
192− handleDoNotationElement (PositionedDoNotationElement pos com e) = PositionedDoNotationElement pos com <$> handleDoNotationElement e
193−
194−everythingOnValues :: (r -> r -> r) ->
195− (Declaration -> r) ->
196− (Expr -> r) ->
197− (Binder -> r) ->
198− (CaseAlternative -> r) ->
199− (DoNotationElement -> r) ->
200− (Declaration -> r, Expr -> r, Binder -> r, CaseAlternative -> r, DoNotationElement -> r)
201−everythingOnValues (<>) f g h i j = (f', g', h', i', j')
202− where
203− f' d@(DataBindingGroupDeclaration ds) = foldl (<>) (f d) (map f' ds)
204− f' d@(ValueDeclaration _ _ bs (Right val)) = foldl (<>) (f d) (map h' bs) <> g' val
205− f' d@(ValueDeclaration _ _ bs (Left gs)) = foldl (<>) (f d) (map h' bs ++ concatMap (\(grd, val) -> [g' grd, g' val]) gs)
206− f' d@(BindingGroupDeclaration ds) = foldl (<>) (f d) (map (\(_, _, val) -> g' val) ds)
207− f' d@(TypeClassDeclaration _ _ _ ds) = foldl (<>) (f d) (map f' ds)
208− f' d@(TypeInstanceDeclaration _ _ _ _ ds) = foldl (<>) (f d) (map f' ds)
209− f' d@(PositionedDeclaration _ _ d1) = f d <> f' d1
210− f' d = f d
211−
212− g' v@(UnaryMinus v1) = g v <> g' v1
213− g' v@(BinaryNoParens op v1 v2) = g v <> g op <> g' v1 <> g' v2
214− g' v@(Parens v1) = g v <> g' v1
215− g' v@(OperatorSection op (Left v1)) = g v <> g op <> g' v1
216− g' v@(OperatorSection op (Right v1)) = g v <> g op <> g' v1
217− g' v@(ArrayLiteral vs) = foldl (<>) (g v) (map g' vs)
218− g' v@(ObjectLiteral vs) = foldl (<>) (g v) (map (g' . snd) vs)
219− g' v@(ObjectConstructor vs) = foldl (<>) (g v) (map g' (mapMaybe snd vs))
220− g' v@(TypeClassDictionaryConstructorApp _ v1) = g v <> g' v1
221− g' v@(Accessor _ v1) = g v <> g' v1
222− g' v@(ObjectUpdate obj vs) = foldl (<>) (g v <> g' obj) (map (g' . snd) vs)
223− g' v@(ObjectUpdater obj vs) = foldl (<>) (maybe (g v) (\x -> g v <> g' x) obj) (map g' (mapMaybe snd vs))
224− g' v@(Abs _ v1) = g v <> g' v1
225− g' v@(App v1 v2) = g v <> g' v1 <> g' v2
226− g' v@(IfThenElse v1 v2 v3) = g v <> g' v1 <> g' v2 <> g' v3
227− g' v@(Case vs alts) = foldl (<>) (foldl (<>) (g v) (map g' vs)) (map i' alts)
228− g' v@(TypedValue _ v1 _) = g v <> g' v1
229− g' v@(Let ds v1) = foldl (<>) (g v) (map f' ds) <> g' v1
230− g' v@(Do es) = foldl (<>) (g v) (map j' es)
231− g' v@(PositionedValue _ _ v1) = g v <> g' v1
232− g' v = g v
233−
234− h' b@(ConstructorBinder _ bs) = foldl (<>) (h b) (map h' bs)
235− h' b@(ObjectBinder bs) = foldl (<>) (h b) (map (h' . snd) bs)
236− h' b@(ArrayBinder bs) = foldl (<>) (h b) (map h' bs)
237− h' b@(ConsBinder b1 b2) = h b <> h' b1 <> h' b2
238− h' b@(NamedBinder _ b1) = h b <> h' b1
239− h' b@(PositionedBinder _ _ b1) = h b <> h' b1
240− h' b = h b
241−
242− i' ca@(CaseAlternative bs (Right val)) = foldl (<>) (i ca) (map h' bs) <> g' val
243− i' ca@(CaseAlternative bs (Left gs)) = foldl (<>) (i ca) (map h' bs ++ concatMap (\(grd, val) -> [g' grd, g' val]) gs)
244−
245− j' e@(DoNotationValue v) = j e <> g' v
246− j' e@(DoNotationBind b v) = j e <> h' b <> g' v
247− j' e@(DoNotationLet ds) = foldl (<>) (j e) (map f' ds)
248− j' e@(PositionedDoNotationElement _ _ e1) = j e <> j' e1
249−
250−everythingWithContextOnValues ::
251− s ->
252− r ->
253− (r -> r -> r) ->
254− (s -> Declaration -> (s, r)) ->
255− (s -> Expr -> (s, r)) ->
256− (s -> Binder -> (s, r)) ->
257− (s -> CaseAlternative -> (s, r)) ->
258− (s -> DoNotationElement -> (s, r)) ->
259− ( Declaration -> r
260− , Expr -> r
261− , Binder -> r
262− , CaseAlternative -> r
263− , DoNotationElement -> r)
264−everythingWithContextOnValues s0 r0 (<>) f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j'' s0)
265− where
266− f'' s d = let (s', r) = f s d in r <> f' s' d
267−
268− f' s (DataBindingGroupDeclaration ds) = foldl (<>) r0 (map (f'' s) ds)
269− f' s (ValueDeclaration _ _ bs (Right val)) = foldl (<>) r0 (map (h'' s) bs) <> g'' s val
270− f' s (ValueDeclaration _ _ bs (Left gs)) = foldl (<>) r0 (map (h'' s) bs ++ concatMap (\(grd, val) -> [g'' s grd, g'' s val]) gs)
271− f' s (BindingGroupDeclaration ds) = foldl (<>) r0 (map (\(_, _, val) -> g'' s val) ds)
272− f' s (TypeClassDeclaration _ _ _ ds) = foldl (<>) r0 (map (f'' s) ds)
273− f' s (TypeInstanceDeclaration _ _ _ _ ds) = foldl (<>) r0 (map (f'' s) ds)
274− f' s (PositionedDeclaration _ _ d1) = f'' s d1
275− f' _ _ = r0
276−
277− g'' s v = let (s', r) = g s v in r <> g' s' v
278−
279− g' s (UnaryMinus v1) = g'' s v1
280− g' s (BinaryNoParens op v1 v2) = g'' s op <> g'' s v1 <> g'' s v2
281− g' s (Parens v1) = g'' s v1
282− g' s (OperatorSection op (Left v)) = g'' s op <> g'' s v
283− g' s (OperatorSection op (Right v)) = g'' s op <> g'' s v
284− g' s (ArrayLiteral vs) = foldl (<>) r0 (map (g'' s) vs)
285− g' s (ObjectLiteral vs) = foldl (<>) r0 (map (g'' s . snd) vs)
286− g' s (ObjectConstructor vs) = foldl (<>) r0 (map (g'' s) (mapMaybe snd vs))
287− g' s (TypeClassDictionaryConstructorApp _ v1) = g'' s v1
288− g' s (Accessor _ v1) = g'' s v1
289− g' s (ObjectUpdate obj vs) = foldl (<>) (g'' s obj) (map (g'' s . snd) vs)
290− g' s (ObjectUpdater obj vs) = foldl (<>) (maybe r0 (g'' s) obj) (map (g'' s) (mapMaybe snd vs))
291− g' s (Abs _ v1) = g'' s v1
292− g' s (App v1 v2) = g'' s v1 <> g'' s v2
293− g' s (IfThenElse v1 v2 v3) = g'' s v1 <> g'' s v2 <> g'' s v3
294− g' s (Case vs alts) = foldl (<>) (foldl (<>) r0 (map (g'' s) vs)) (map (i'' s) alts)
295− g' s (TypedValue _ v1 _) = g'' s v1
296− g' s (Let ds v1) = foldl (<>) r0 (map (f'' s) ds) <> g'' s v1
297− g' s (Do es) = foldl (<>) r0 (map (j'' s) es)
298− g' s (PositionedValue _ _ v1) = g'' s v1
299− g' _ _ = r0
300−
301− h'' s b = let (s', r) = h s b in r <> h' s' b
302−
303− h' s (ConstructorBinder _ bs) = foldl (<>) r0 (map (h'' s) bs)
304− h' s (ObjectBinder bs) = foldl (<>) r0 (map (h'' s . snd) bs)
305− h' s (ArrayBinder bs) = foldl (<>) r0 (map (h'' s) bs)
306− h' s (ConsBinder b1 b2) = h'' s b1 <> h'' s b2
307− h' s (NamedBinder _ b1) = h'' s b1
308− h' s (PositionedBinder _ _ b1) = h'' s b1
309− h' _ _ = r0
310−
311− i'' s ca = let (s', r) = i s ca in r <> i' s' ca
312−
313− i' s (CaseAlternative bs (Right val)) = foldl (<>) r0 (map (h'' s) bs) <> g'' s val
314− i' s (CaseAlternative bs (Left gs)) = foldl (<>) r0 (map (h'' s) bs ++ concatMap (\(grd, val) -> [g'' s grd, g'' s val]) gs)
315−
316− j'' s e = let (s', r) = j s e in r <> j' s' e
317−
318− j' s (DoNotationValue v) = g'' s v
319− j' s (DoNotationBind b v) = h'' s b <> g'' s v
320− j' s (DoNotationLet ds) = foldl (<>) r0 (map (f'' s) ds)
321− j' s (PositionedDoNotationElement _ _ e1) = j'' s e1
322−
323−everywhereWithContextOnValuesM :: (Functor m, Applicative m, Monad m) =>
324− s ->
325− (s -> Declaration -> m (s, Declaration)) ->
326− (s -> Expr -> m (s, Expr)) ->
327− (s -> Binder -> m (s, Binder)) ->
328− (s -> CaseAlternative -> m (s, CaseAlternative)) ->
329− (s -> DoNotationElement -> m (s, DoNotationElement)) ->
330− ( Declaration -> m Declaration
331− , Expr -> m Expr
332− , Binder -> m Binder
333− , CaseAlternative -> m CaseAlternative
334− , DoNotationElement -> m DoNotationElement)
335−everywhereWithContextOnValuesM s0 f g h i j = (f'' s0, g'' s0, h'' s0, i'' s0, j'' s0)
336− where
337− f'' s = uncurry f' <=< f s
338−
339− f' s (DataBindingGroupDeclaration ds) = DataBindingGroupDeclaration <$> mapM (f'' s) ds
340− f' s (ValueDeclaration name nameKind bs val) = ValueDeclaration name nameKind <$> mapM (h'' s) bs <*> eitherM (mapM (pairM (g'' s) (g'' s))) (g'' s) val
341− f' s (BindingGroupDeclaration ds) = BindingGroupDeclaration <$> mapM (thirdM (g'' s)) ds
342− f' s (TypeClassDeclaration name args implies ds) = TypeClassDeclaration name args implies <$> mapM (f'' s) ds
343− f' s (TypeInstanceDeclaration name cs className args ds) = TypeInstanceDeclaration name cs className args <$> mapM (f'' s) ds
344− f' s (PositionedDeclaration pos com d1) = PositionedDeclaration pos com <$> f'' s d1
345− f' _ other = return other
346−
347− g'' s = uncurry g' <=< g s
348−
349− g' s (UnaryMinus v) = UnaryMinus <$> g'' s v
350− g' s (BinaryNoParens op v1 v2) = BinaryNoParens <$> g'' s op <*> g'' s v1 <*> g'' s v2
351− g' s (Parens v) = Parens <$> g'' s v
352− g' s (OperatorSection op (Left v)) = OperatorSection <$> g'' s op <*> (Left <$> g'' s v)
353− g' s (OperatorSection op (Right v)) = OperatorSection <$> g'' s op <*> (Right <$> g'' s v)
354− g' s (ArrayLiteral vs) = ArrayLiteral <$> mapM (g'' s) vs
355− g' s (ObjectLiteral vs) = ObjectLiteral <$> mapM (sndM (g'' s)) vs
356− g' s (ObjectConstructor vs) = ObjectConstructor <$> mapM (sndM $ maybeM (g'' s)) vs
357− g' s (TypeClassDictionaryConstructorApp name v) = TypeClassDictionaryConstructorApp name <$> g'' s v
358− g' s (Accessor prop v) = Accessor prop <$> g'' s v
359− g' s (ObjectUpdate obj vs) = ObjectUpdate <$> g'' s obj <*> mapM (sndM (g'' s)) vs
360− g' s (ObjectUpdater obj vs) = ObjectUpdater <$> maybeM (g'' s) obj <*> mapM (sndM $ maybeM (g'' s)) vs
361− g' s (Abs name v) = Abs name <$> g'' s v
362− g' s (App v1 v2) = App <$> g'' s v1 <*> g'' s v2
363− g' s (IfThenElse v1 v2 v3) = IfThenElse <$> g'' s v1 <*> g'' s v2 <*> g'' s v3
364− g' s (Case vs alts) = Case <$> mapM (g'' s) vs <*> mapM (i'' s) alts
365− g' s (TypedValue check v ty) = TypedValue check <$> g'' s v <*> pure ty
366− g' s (Let ds v) = Let <$> mapM (f'' s) ds <*> g'' s v
367− g' s (Do es) = Do <$> mapM (j'' s) es
368− g' s (PositionedValue pos com v) = PositionedValue pos com <$> g'' s v
369− g' _ other = return other
370−
371− h'' s = uncurry h' <=< h s
372−
373− h' s (ConstructorBinder ctor bs) = ConstructorBinder ctor <$> mapM (h'' s) bs
374− h' s (ObjectBinder bs) = ObjectBinder <$> mapM (sndM (h'' s)) bs
375− h' s (ArrayBinder bs) = ArrayBinder <$> mapM (h'' s) bs
376− h' s (ConsBinder b1 b2) = ConsBinder <$> h'' s b1 <*> h'' s b2
377− h' s (NamedBinder name b) = NamedBinder name <$> h'' s b
378− h' s (PositionedBinder pos com b) = PositionedBinder pos com <$> h'' s b
379− h' _ other = return other
380−
381− i'' s = uncurry i' <=< i s
382−
383− i' s (CaseAlternative bs val) = CaseAlternative <$> mapM (h'' s) bs <*> eitherM (mapM (pairM (g'' s) (g'' s))) (g'' s) val
384−
385− j'' s = uncurry j' <=< j s
386−
387− j' s (DoNotationValue v) = DoNotationValue <$> g'' s v
388− j' s (DoNotationBind b v) = DoNotationBind <$> h'' s b <*> g'' s v
389− j' s (DoNotationLet ds) = DoNotationLet <$> mapM (f'' s) ds
390− j' s (PositionedDoNotationElement pos com e1) = PositionedDoNotationElement pos com <$> j'' s e1
391−
392−accumTypes :: (Monoid r) => (Type -> r) -> (Declaration -> r, Expr -> r, Binder -> r, CaseAlternative -> r, DoNotationElement -> r)
393−accumTypes f = everythingOnValues mappend forDecls forValues (const mempty) (const mempty) (const mempty)
394− where
395− forDecls (DataDeclaration _ _ _ dctors) = mconcat (concatMap (map f . snd) dctors)
396− forDecls (ExternDeclaration _ _ _ ty) = f ty
397− forDecls (ExternInstanceDeclaration _ cs _ tys) = mconcat (concatMap (map f . snd) cs) `mappend` mconcat (map f tys)
398− forDecls (TypeClassDeclaration _ _ implies _) = mconcat (concatMap (map f . snd) implies)
399− forDecls (TypeInstanceDeclaration _ cs _ tys _) = mconcat (concatMap (map f . snd) cs) `mappend` mconcat (map f tys)
400− forDecls (TypeSynonymDeclaration _ _ ty) = f ty
401− forDecls (TypeDeclaration _ ty) = f ty
402− forDecls _ = mempty
403−
404− forValues (TypeClassDictionary _ (_, cs) _) = mconcat (map f cs)
405− forValues (SuperClassDictionary _ tys) = mconcat (map f tys)
406− forValues (TypedValue _ _ ty) = f ty
407− forValues _ = mempty
src/Language/PureScript/CodeGen.hsdeleted−25
@@ -1,25 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.CodeGen
4−-- Copyright : (c) Phil Freeman 2013
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- |
12−-- A collection of modules related to code generation:
13−--
14−-- [@Language.PureScript.CodeGen.JS@] Code generator for Javascript
15−--
16−-- [@Language.PureScript.CodeGen.Externs@] Code generator for extern (foreign import) files
17−--
18−-- [@Language.PureScript.CodeGen.Optimize@] Optimization passes for generated Javascript
19−--
20−-----------------------------------------------------------------------------
21−
22−module Language.PureScript.CodeGen (module C) where
23−
24−import Language.PureScript.CodeGen.JS as C
25−import Language.PureScript.CodeGen.Externs as C
src/Language/PureScript/CodeGen/Externs.hsdeleted−121
@@ -1,121 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.CodeGen.Externs
4−-- Copyright : (c) Phil Freeman 2013
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- |
12−-- This module generates code for \"externs\" files, i.e. files containing only foreign import declarations.
13−--
14−-----------------------------------------------------------------------------
15−
16−module Language.PureScript.CodeGen.Externs (
17− moduleToPs
18−) where
19−
20−import Data.List (intercalate, find)
21−import Data.Maybe (fromMaybe, mapMaybe)
22−import qualified Data.Map as M
23−
24−import Control.Monad.Writer
25−
26−import Language.PureScript.AST
27−import Language.PureScript.Environment
28−import Language.PureScript.Kinds
29−import Language.PureScript.Names
30−import Language.PureScript.Pretty
31−import Language.PureScript.TypeClassDictionaries
32−import Language.PureScript.Types
33−import Language.PureScript.Comments
34−
35−-- |
36−-- Generate foreign imports for all declarations in a module
37−--
38−moduleToPs :: Module -> Environment -> String
39−moduleToPs (Module _ _ _ Nothing) _ = error "Module exports were not elaborated in moduleToPs"
40−moduleToPs (Module _ moduleName ds (Just exts)) env = intercalate "\n" . execWriter $ do
41− tell [ "module " ++ runModuleName moduleName ++ " where"]
42− mapM_ declToPs ds
43− mapM_ exportToPs exts
44− where
45−
46− declToPs :: Declaration -> Writer [String] ()
47− declToPs (ImportDeclaration mn _ _) = tell ["import " ++ show mn ++ " ()"]
48− declToPs (FixityDeclaration (Fixity assoc prec) op) =
49− case find exportsOp exts of
50− Nothing -> return ()
51− Just _ -> tell [ unwords [ show assoc, show prec, op ] ]
52− where
53− exportsOp :: DeclarationRef -> Bool
54− exportsOp (PositionedDeclarationRef _ _ r) = exportsOp r
55− exportsOp (ValueRef ident') = ident' == Op op
56− exportsOp _ = False
57− declToPs (PositionedDeclaration _ com d) = mapM commentToPs com >> declToPs d
58− declToPs _ = return ()
59−
60− commentToPs :: Comment -> Writer [String] ()
61− commentToPs (LineComment s) = tell ["-- " ++ s]
62− commentToPs (BlockComment s) = tell ["{- " ++ s ++ " -}"]
63−
64− exportToPs :: DeclarationRef -> Writer [String] ()
65− exportToPs (PositionedDeclarationRef _ _ r) = exportToPs r
66− exportToPs (TypeRef pn dctors) = do
67− case Qualified (Just moduleName) pn `M.lookup` types env of
68− Nothing -> error $ show pn ++ " has no kind in exportToPs"
69− Just (kind, ExternData) ->
70− tell ["foreign import data " ++ show pn ++ " :: " ++ prettyPrintKind kind]
71− Just (_, DataType args tys) -> do
72− let dctors' = fromMaybe (map fst tys) dctors
73− printDctor dctor = case dctor `lookup` tys of
74− Nothing -> Nothing
75− Just tyArgs -> Just $ show dctor ++ " " ++ unwords (map prettyPrintTypeAtom tyArgs)
76− let dtype = if length dctors' == 1 && isNewtypeConstructor env (Qualified (Just moduleName) $ head dctors')
77− then "newtype"
78− else "data"
79− typeName = prettyPrintType $ foldl TypeApp (TypeConstructor (Qualified Nothing pn)) (map toTypeVar args)
80− tell [dtype ++ " " ++ typeName ++ (if null dctors' then "" else " = " ++ intercalate " | " (mapMaybe printDctor dctors'))]
81− Just (_, TypeSynonym) ->
82− case Qualified (Just moduleName) pn `M.lookup` typeSynonyms env of
83− Nothing -> error $ show pn ++ " has no type synonym info in exportToPs"
84− Just (args, synTy) ->
85− let
86− typeName = prettyPrintType $ foldl TypeApp (TypeConstructor (Qualified Nothing pn)) (map toTypeVar args)
87− in tell ["type " ++ typeName ++ " = " ++ prettyPrintType synTy]
88− _ -> error "Invalid input in exportToPs"
89−
90− exportToPs (ValueRef ident) =
91− case (moduleName, ident) `M.lookup` names env of
92− Nothing -> error $ show ident ++ " has no type in exportToPs"
93− Just (ty, nameKind, _) | nameKind == Value || nameKind == Extern ForeignImport || nameKind == Extern InlineJavascript ->
94− tell ["foreign import " ++ show ident ++ " :: " ++ prettyPrintType ty]
95− _ -> return ()
96− exportToPs (TypeClassRef className) =
97− case Qualified (Just moduleName) className `M.lookup` typeClasses env of
98− Nothing -> error $ show className ++ " has no type class definition in exportToPs"
99− Just (args, members, implies) -> do
100− let impliesString = if null implies
101− then ""
102− else "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map prettyPrintTypeAtom tys')) implies) ++ ") <= "
103− typeName = prettyPrintType $ foldl TypeApp (TypeConstructor (Qualified Nothing className)) (map toTypeVar args)
104− tell ["class " ++ impliesString ++ typeName ++ " where"]
105− forM_ (filter (isValueExported . fst) members) $ \(member ,ty) ->
106− tell [ " " ++ show member ++ " :: " ++ prettyPrintType ty ]
107−
108− exportToPs (TypeInstanceRef ident) = do
109− let TypeClassDictionaryInScope { tcdClassName = className, tcdInstanceTypes = tys, tcdDependencies = deps} =
110− fromMaybe (error $ "Type class instance has no dictionary in exportToPs") . find (\tcd -> tcdName tcd == Qualified (Just moduleName) ident && tcdType tcd == TCDRegular) $ M.elems $ typeClassDictionaries env
111− let constraintsText = case fromMaybe [] deps of
112− [] -> ""
113− cs -> "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map prettyPrintTypeAtom tys')) cs) ++ ") => "
114− tell ["foreign import instance " ++ show ident ++ " :: " ++ constraintsText ++ show className ++ " " ++ unwords (map prettyPrintTypeAtom tys)]
115−
116− toTypeVar :: (String, Maybe Kind) -> Type
117− toTypeVar (s, Nothing) = TypeVar s
118− toTypeVar (s, Just k) = KindedType (TypeVar s) k
119−
120− isValueExported :: Ident -> Bool
121− isValueExported ident = ValueRef ident `elem` exts
src/Language/PureScript/CodeGen/JS.hsdeleted−359
@@ -1,359 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.CodeGen.JS
4−-- Copyright : (c) Phil Freeman 2013
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- |
12−-- This module generates code in the simplified Javascript intermediate representation from Purescript code
13−--
14−-----------------------------------------------------------------------------
15−
16−{-# LANGUAGE GADTs #-}
17−{-# LANGUAGE ViewPatterns #-}
18−{-# LANGUAGE FlexibleContexts #-}
19−{-# LANGUAGE ScopedTypeVariables #-}
20−
21−module Language.PureScript.CodeGen.JS (
22− module AST,
23− module Common,
24− moduleToJs
25−) where
26−
27−import Data.List ((\\), delete)
28−import Data.Maybe (mapMaybe)
29−import qualified Data.Traversable as T (traverse)
30−
31−import Control.Applicative
32−import Control.Arrow ((&&&))
33−import Control.Monad (foldM, replicateM, forM)
34−import Control.Monad.Reader (MonadReader, asks)
35−import Control.Monad.Supply.Class
36−
37−import Language.PureScript.CodeGen.JS.AST as AST
38−import Language.PureScript.CodeGen.JS.Common as Common
39−import Language.PureScript.CoreFn
40−import Language.PureScript.Names
41−import Language.PureScript.CodeGen.JS.Optimizer
42−import Language.PureScript.Options
43−import Language.PureScript.Traversals (sndM)
44−import qualified Language.PureScript.Constants as C
45−
46−-- |
47−-- Generate code in the simplified Javascript intermediate representation for all declarations in a
48−-- module.
49−--
50−moduleToJs :: forall m mode. (Applicative m, Monad m, MonadReader (Options mode) m, MonadSupply m)
51− => Module Ann -> m [JS]
52−moduleToJs (Module coms mn imps exps foreigns decls) = do
53− additional <- asks optionsAdditional
54− jsImports <- T.traverse importToJs . delete (ModuleName [ProperName C.prim]) . (\\ [mn]) $ imps
55− let foreigns' = mapMaybe (\(_, js, _) -> js) foreigns
56− jsDecls <- mapM bindToJs decls
57− optimized <- T.traverse (T.traverse optimize) jsDecls
58− let isModuleEmpty = null exps
59− comments <- not <$> asks optionsNoComments
60− let strict = JSStringLiteral "use strict"
61− let header = if comments && not (null coms) then JSComment coms strict else strict
62− let moduleBody = header : jsImports ++ foreigns' ++ concat optimized
63− let exps' = JSObjectLiteral $ map (runIdent &&& JSVar . identToJs) exps
64− return $ case additional of
65− MakeOptions -> moduleBody ++ [JSAssignment (JSAccessor "exports" (JSVar "module")) exps']
66− CompileOptions ns _ _ | not isModuleEmpty ->
67− [ JSVariableIntroduction ns
68− (Just (JSBinary Or (JSVar ns) (JSObjectLiteral [])) )
69− , JSAssignment (JSAccessor (moduleNameToJs mn) (JSVar ns))
70− (JSApp (JSFunction Nothing [] (JSBlock (moduleBody ++ [JSReturn exps']))) [])
71− ]
72− _ -> []
73−
74− where
75−
76− -- |
77− -- Generates Javascript code for a module import.
78− --
79− importToJs :: ModuleName -> m JS
80− importToJs mn' = do
81− additional <- asks optionsAdditional
82− let moduleBody = case additional of
83− MakeOptions -> JSApp (JSVar "require") [JSStringLiteral (runModuleName mn')]
84− CompileOptions ns _ _ -> JSAccessor (moduleNameToJs mn') (JSVar ns)
85− return $ JSVariableIntroduction (moduleNameToJs mn') (Just moduleBody)
86−
87− -- |
88− -- Generate code in the simplified Javascript intermediate representation for a declaration
89− --
90− bindToJs :: Bind Ann -> m [JS]
91− bindToJs (NonRec ident val) = return <$> nonRecToJS ident val
92− bindToJs (Rec vals) = forM vals (uncurry nonRecToJS)
93−
94− -- |
95− -- Generate code in the simplified Javascript intermediate representation for a single non-recursive
96− -- declaration.
97− --
98− -- The main purpose of this function is to handle code generation for comments.
99− --
100− nonRecToJS :: Ident -> Expr Ann -> m JS
101− nonRecToJS i e@(extractAnn -> (_, com, _, _)) | not (null com) = do
102− withoutComment <- asks optionsNoComments
103− if withoutComment
104− then nonRecToJS i (modifyAnn removeComments e)
105− else JSComment com <$> nonRecToJS i (modifyAnn removeComments e)
106− nonRecToJS ident val = do
107− js <- valueToJs val
108− return $ JSVariableIntroduction (identToJs ident) (Just js)
109−
110− -- |
111− -- Generate code in the simplified Javascript intermediate representation for a variable based on a
112− -- PureScript identifier.
113− --
114− var :: Ident -> JS
115− var = JSVar . identToJs
116−
117− -- |
118− -- Generate code in the simplified Javascript intermediate representation for an accessor based on
119− -- a PureScript identifier. If the name is not valid in Javascript (symbol based, reserved name) an
120− -- indexer is returned.
121− --
122− accessor :: Ident -> JS -> JS
123− accessor (Ident prop) = accessorString prop
124− accessor (Op op) = JSIndexer (JSStringLiteral op)
125−
126− accessorString :: String -> JS -> JS
127− accessorString prop | identNeedsEscaping prop = JSIndexer (JSStringLiteral prop)
128− | otherwise = JSAccessor prop
129−
130− -- |
131− -- Generate code in the simplified Javascript intermediate representation for a value or expression.
132− --
133− valueToJs :: Expr Ann -> m JS
134− valueToJs (Literal _ l) =
135− literalToValueJS l
136− valueToJs (Var (_, _, _, Just (IsConstructor _ [])) name) =
137− return $ JSAccessor "value" $ qualifiedToJS id name
138− valueToJs (Var (_, _, _, Just (IsConstructor _ _)) name) =
139− return $ JSAccessor "create" $ qualifiedToJS id name
140− valueToJs (Accessor _ prop val) =
141− accessorString prop <$> valueToJs val
142− valueToJs (ObjectUpdate _ o ps) = do
143− obj <- valueToJs o
144− sts <- mapM (sndM valueToJs) ps
145− extendObj obj sts
146− valueToJs e@(Abs (_, _, _, Just IsTypeClassConstructor) _ _) =
147− let args = unAbs e
148− in return $ JSFunction Nothing (map identToJs args) (JSBlock $ map assign args)
149− where
150− unAbs :: Expr Ann -> [Ident]
151− unAbs (Abs _ arg val) = arg : unAbs val
152− unAbs _ = []
153− assign :: Ident -> JS
154− assign name = JSAssignment (accessorString (runIdent name) (JSVar "this"))
155− (var name)
156− valueToJs (Abs _ arg val) = do
157− ret <- valueToJs val
158− return $ JSFunction Nothing [identToJs arg] (JSBlock [JSReturn ret])
159− valueToJs e@App{} = do
160− let (f, args) = unApp e []
161− args' <- mapM valueToJs args
162− case f of
163− Var (_, _, _, Just IsNewtype) _ -> return (head args')
164− Var (_, _, _, Just (IsConstructor _ fields)) name | length args == length fields ->
165− return $ JSUnary JSNew $ JSApp (qualifiedToJS id name) args'
166− Var (_, _, _, Just IsTypeClassConstructor) name ->
167− return $ JSUnary JSNew $ JSApp (qualifiedToJS id name) args'
168− _ -> flip (foldl (\fn a -> JSApp fn [a])) args' <$> valueToJs f
169− where
170− unApp :: Expr Ann -> [Expr Ann] -> (Expr Ann, [Expr Ann])
171− unApp (App _ val arg) args = unApp val (arg : args)
172− unApp other args = (other, args)
173− valueToJs (Var _ ident) =
174− return $ varToJs ident
175− valueToJs (Case _ values binders) = do
176− vals <- mapM valueToJs values
177− bindersToJs binders vals
178− valueToJs (Let _ ds val) = do
179− ds' <- concat <$> mapM bindToJs ds
180− ret <- valueToJs val
181− return $ JSApp (JSFunction Nothing [] (JSBlock (ds' ++ [JSReturn ret]))) []
182− valueToJs (Constructor (_, _, _, Just IsNewtype) _ (ProperName ctor) _) =
183− return $ JSVariableIntroduction ctor (Just $
184− JSObjectLiteral [("create",
185− JSFunction Nothing ["value"]
186− (JSBlock [JSReturn $ JSVar "value"]))])
187− valueToJs (Constructor _ _ (ProperName ctor) []) =
188− return $ iife ctor [ JSFunction (Just ctor) [] (JSBlock [])
189− , JSAssignment (JSAccessor "value" (JSVar ctor))
190− (JSUnary JSNew $ JSApp (JSVar ctor) []) ]
191− valueToJs (Constructor _ _ (ProperName ctor) fields) =
192− let constructor =
193− let body = [ JSAssignment (JSAccessor (identToJs f) (JSVar "this")) (var f) | f <- fields ]
194− in JSFunction (Just ctor) (identToJs `map` fields) (JSBlock body)
195− createFn =
196− let body = JSUnary JSNew $ JSApp (JSVar ctor) (var `map` fields)
197− in foldr (\f inner -> JSFunction Nothing [identToJs f] (JSBlock [JSReturn inner])) body fields
198− in return $ iife ctor [ constructor
199− , JSAssignment (JSAccessor "create" (JSVar ctor)) createFn
200− ]
201−
202− iife :: String -> [JS] -> JS
203− iife v exprs = JSApp (JSFunction Nothing [] (JSBlock $ exprs ++ [JSReturn $ JSVar v])) []
204−
205− literalToValueJS :: Literal (Expr Ann) -> m JS
206− literalToValueJS (NumericLiteral n) = return $ JSNumericLiteral n
207− literalToValueJS (StringLiteral s) = return $ JSStringLiteral s
208− literalToValueJS (BooleanLiteral b) = return $ JSBooleanLiteral b
209− literalToValueJS (ArrayLiteral xs) = JSArrayLiteral <$> mapM valueToJs xs
210− literalToValueJS (ObjectLiteral ps) = JSObjectLiteral <$> mapM (sndM valueToJs) ps
211−
212− -- |
213− -- Shallow copy an object.
214− --
215− extendObj :: JS -> [(String, JS)] -> m JS
216− extendObj obj sts = do
217− newObj <- freshName
218− key <- freshName
219− let
220− jsKey = JSVar key
221− jsNewObj = JSVar newObj
222− block = JSBlock (objAssign:copy:extend ++ [JSReturn jsNewObj])
223− objAssign = JSVariableIntroduction newObj (Just $ JSObjectLiteral [])
224− copy = JSForIn key obj $ JSBlock [JSIfElse cond assign Nothing]
225− cond = JSApp (JSAccessor "hasOwnProperty" obj) [jsKey]
226− assign = JSBlock [JSAssignment (JSIndexer jsKey jsNewObj) (JSIndexer jsKey obj)]
227− stToAssign (s, js) = JSAssignment (JSAccessor s jsNewObj) js
228− extend = map stToAssign sts
229− return $ JSApp (JSFunction Nothing [] block) []
230−
231− -- |
232− -- Generate code in the simplified Javascript intermediate representation for a reference to a
233− -- variable.
234− --
235− varToJs :: Qualified Ident -> JS
236− varToJs (Qualified Nothing ident) = var ident
237− varToJs qual = qualifiedToJS id qual
238−
239− -- |
240− -- Generate code in the simplified Javascript intermediate representation for a reference to a
241− -- variable that may have a qualified name.
242− --
243− qualifiedToJS :: (a -> Ident) -> Qualified a -> JS
244− qualifiedToJS f (Qualified (Just (ModuleName [ProperName mn'])) a) | mn' == C.prim = JSVar . runIdent $ f a
245− qualifiedToJS f (Qualified (Just mn') a) | mn /= mn' = accessor (f a) (JSVar (moduleNameToJs mn'))
246− qualifiedToJS f (Qualified _ a) = JSVar $ identToJs (f a)
247−
248− -- |
249− -- Generate code in the simplified Javascript intermediate representation for pattern match binders
250− -- and guards.
251− --
252− bindersToJs :: [CaseAlternative Ann] -> [JS] -> m JS
253− bindersToJs binders vals = do
254− valNames <- replicateM (length vals) freshName
255− let assignments = zipWith JSVariableIntroduction valNames (map Just vals)
256− jss <- forM binders $ \(CaseAlternative bs result) -> do
257− ret <- guardsToJs result
258− go valNames ret bs
259− return $ JSApp (JSFunction Nothing [] (JSBlock (assignments ++ concat jss ++ [JSThrow $ JSUnary JSNew $ JSApp (JSVar "Error") [JSStringLiteral "Failed pattern match"]])))
260− []
261− where
262− go :: [String] -> [JS] -> [Binder Ann] -> m [JS]
263− go _ done [] = return done
264− go (v:vs) done' (b:bs) = do
265− done'' <- go vs done' bs
266− binderToJs v done'' b
267− go _ _ _ = error "Invalid arguments to bindersToJs"
268−
269− guardsToJs :: Either [(Guard Ann, Expr Ann)] (Expr Ann) -> m [JS]
270− guardsToJs (Left gs) = forM gs $ \(cond, val) -> do
271− cond' <- valueToJs cond
272− done <- valueToJs val
273− return $ JSIfElse cond' (JSBlock [JSReturn done]) Nothing
274− guardsToJs (Right v) = return . JSReturn <$> valueToJs v
275−
276− -- |
277− -- Generate code in the simplified Javascript intermediate representation for a pattern match
278− -- binder.
279− --
280− binderToJs :: String -> [JS] -> Binder Ann -> m [JS]
281− binderToJs _ done (NullBinder{}) = return done
282− binderToJs varName done (LiteralBinder _ l) =
283− literalToBinderJS varName done l
284− binderToJs varName done (VarBinder _ ident) =
285− return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : done)
286− binderToJs varName done (ConstructorBinder (_, _, _, Just IsNewtype) _ _ [b]) =
287− binderToJs varName done b
288− binderToJs varName done (ConstructorBinder (_, _, _, Just (IsConstructor ctorType fields)) _ ctor bs) = do
289− js <- go (zip fields bs) done
290− return $ case ctorType of
291− ProductType -> js
292− SumType ->
293− [JSIfElse (JSInstanceOf (JSVar varName) (qualifiedToJS (Ident . runProperName) ctor))
294− (JSBlock js)
295− Nothing]
296− where
297− go :: [(Ident, Binder Ann)] -> [JS] -> m [JS]
298− go [] done' = return done'
299− go ((field, binder) : remain) done' = do
300− argVar <- freshName
301− done'' <- go remain done'
302− js <- binderToJs argVar done'' binder
303− return (JSVariableIntroduction argVar (Just (JSAccessor (identToJs field) (JSVar varName))) : js)
304− binderToJs varName done binder@(ConstructorBinder _ _ ctor _) | isCons ctor = do
305− let (headBinders, tailBinder) = uncons [] binder
306− numberOfHeadBinders = fromIntegral $ length headBinders
307− js1 <- foldM (\done' (headBinder, index) -> do
308− headVar <- freshName
309− jss <- binderToJs headVar done' headBinder
310− return (JSVariableIntroduction headVar (Just (JSIndexer (JSNumericLiteral (Left index)) (JSVar varName))) : jss)) done (zip headBinders [0..])
311− tailVar <- freshName
312− js2 <- binderToJs tailVar js1 tailBinder
313− return [JSIfElse (JSBinary GreaterThanOrEqualTo (JSAccessor "length" (JSVar varName)) (JSNumericLiteral (Left numberOfHeadBinders))) (JSBlock
314− ( JSVariableIntroduction tailVar (Just (JSApp (JSAccessor "slice" (JSVar varName)) [JSNumericLiteral (Left numberOfHeadBinders)])) :
315− js2
316− )) Nothing]
317− where
318− uncons :: [Binder Ann] -> Binder Ann -> ([Binder Ann], Binder Ann)
319− uncons acc (ConstructorBinder _ _ ctor' [h, t]) | isCons ctor' = uncons (h : acc) t
320− uncons acc tailBinder = (reverse acc, tailBinder)
321− binderToJs _ _ b@(ConstructorBinder{}) =
322− error $ "Invalid ConstructorBinder in binderToJs: " ++ show b
323− binderToJs varName done (NamedBinder _ ident binder) = do
324− js <- binderToJs varName done binder
325− return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : js)
326−
327− literalToBinderJS :: String -> [JS] -> Literal (Binder Ann) -> m [JS]
328− literalToBinderJS varName done (NumericLiteral num) =
329− return [JSIfElse (JSBinary EqualTo (JSVar varName) (JSNumericLiteral num)) (JSBlock done) Nothing]
330− literalToBinderJS varName done (StringLiteral str) =
331− return [JSIfElse (JSBinary EqualTo (JSVar varName) (JSStringLiteral str)) (JSBlock done) Nothing]
332− literalToBinderJS varName done (BooleanLiteral True) =
333− return [JSIfElse (JSVar varName) (JSBlock done) Nothing]
334− literalToBinderJS varName done (BooleanLiteral False) =
335− return [JSIfElse (JSUnary Not (JSVar varName)) (JSBlock done) Nothing]
336− literalToBinderJS varName done (ObjectLiteral bs) = go done bs
337− where
338− go :: [JS] -> [(String, Binder Ann)] -> m [JS]
339− go done' [] = return done'
340− go done' ((prop, binder):bs') = do
341− propVar <- freshName
342− done'' <- go done' bs'
343− js <- binderToJs propVar done'' binder
344− return (JSVariableIntroduction propVar (Just (accessorString prop (JSVar varName))) : js)
345− literalToBinderJS varName done (ArrayLiteral bs) = do
346− js <- go done 0 bs
347− return [JSIfElse (JSBinary EqualTo (JSAccessor "length" (JSVar varName)) (JSNumericLiteral (Left (fromIntegral $ length bs)))) (JSBlock js) Nothing]
348− where
349− go :: [JS] -> Integer -> [Binder Ann] -> m [JS]
350− go done' _ [] = return done'
351− go done' index (binder:bs') = do
352− elVar <- freshName
353− done'' <- go done' (index + 1) bs'
354− js <- binderToJs elVar done'' binder
355− return (JSVariableIntroduction elVar (Just (JSIndexer (JSNumericLiteral (Left index)) (JSVar varName))) : js)
356−
357− isCons :: Qualified ProperName -> Bool
358− isCons (Qualified (Just mn') ctor) = mn' == ModuleName [ProperName C.prim] && ctor == ProperName "Array"
359− isCons name = error $ "Unexpected argument in isCons: " ++ show name
src/Language/PureScript/CodeGen/JS/AST.hsdeleted−337
@@ -1,337 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.CodeGen.JS.AST
4−-- Copyright : (c) Phil Freeman 2013
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- |
12−-- Data types for the intermediate simplified-Javascript AST
13−--
14−-----------------------------------------------------------------------------
15−
16−{-# LANGUAGE DeriveDataTypeable #-}
17−
18−module Language.PureScript.CodeGen.JS.AST where
19−
20−import Data.Data
21−
22−import Language.PureScript.Comments
23−
24−-- |
25−-- Built-in unary operators
26−--
27−data UnaryOperator
28− -- |
29− -- Numeric negation
30− --
31− = Negate
32− -- |
33− -- Boolean negation
34− --
35− | Not
36− -- |
37− -- Bitwise negation
38− --
39− | BitwiseNot
40− -- |
41− -- Numeric unary \'plus\'
42− --
43− | Positive
44− -- |
45− -- Constructor
46− --
47− | JSNew deriving (Show, Eq, Data, Typeable)
48−
49−-- |
50−-- Built-in binary operators
51−--
52−data BinaryOperator
53− -- |
54− -- Numeric addition
55− --
56− = Add
57− -- |
58− -- Numeric subtraction
59− --
60− | Subtract
61− -- |
62− -- Numeric multiplication
63− --
64− | Multiply
65− -- |
66− -- Numeric division
67− --
68− | Divide
69− -- |
70− -- Remainder
71− --
72− | Modulus
73− -- |
74− -- Generic equality test
75− --
76− | EqualTo
77− -- |
78− -- Generic inequality test
79− --
80− | NotEqualTo
81− -- |
82− -- Numeric less-than
83− --
84− | LessThan
85− -- |
86− -- Numeric less-than-or-equal
87− --
88− | LessThanOrEqualTo
89− -- |
90− -- Numeric greater-than
91− --
92− | GreaterThan
93− -- |
94− -- Numeric greater-than-or-equal
95− --
96− | GreaterThanOrEqualTo
97− -- |
98− -- Boolean and
99− --
100− | And
101− -- |
102− -- Boolean or
103− --
104− | Or
105− -- |
106− -- Bitwise and
107− --
108− | BitwiseAnd
109− -- |
110− -- Bitwise or
111− --
112− | BitwiseOr
113− -- |
114− -- Bitwise xor
115− --
116− | BitwiseXor
117− -- |
118− -- Bitwise left shift
119− --
120− | ShiftLeft
121− -- |
122− -- Bitwise right shift
123− --
124− | ShiftRight
125− -- |
126− -- Bitwise right shift with zero-fill
127− --
128− | ZeroFillShiftRight deriving (Show, Eq, Data, Typeable)
129−
130−-- |
131−-- Data type for simplified Javascript expressions
132−--
133−data JS
134− -- |
135− -- A numeric literal
136− --
137− = JSNumericLiteral (Either Integer Double)
138− -- |
139− -- A string literal
140− --
141− | JSStringLiteral String
142− -- |
143− -- A boolean literal
144− --
145− | JSBooleanLiteral Bool
146− -- |
147− -- A unary operator application
148− --
149− | JSUnary UnaryOperator JS
150− -- |
151− -- A binary operator application
152− --
153− | JSBinary BinaryOperator JS JS
154− -- |
155− -- An array literal
156− --
157− | JSArrayLiteral [JS]
158− -- |
159− -- An array indexer expression
160− --
161− | JSIndexer JS JS
162− -- |
163− -- An object literal
164− --
165− | JSObjectLiteral [(String, JS)]
166− -- |
167− -- An object property accessor expression
168− --
169− | JSAccessor String JS
170− -- |
171− -- A function introduction (optional name, arguments, body)
172− --
173− | JSFunction (Maybe String) [String] JS
174− -- |
175− -- Function application
176− --
177− | JSApp JS [JS]
178− -- |
179− -- Variable
180− --
181− | JSVar String
182− -- |
183− -- Conditional expression
184− --
185− | JSConditional JS JS JS
186− -- |
187− -- A block of expressions in braces
188− --
189− | JSBlock [JS]
190− -- |
191− -- A variable introduction and optional initialization
192− --
193− | JSVariableIntroduction String (Maybe JS)
194− -- |
195− -- A variable assignment
196− --
197− | JSAssignment JS JS
198− -- |
199− -- While loop
200− --
201− | JSWhile JS JS
202− -- |
203− -- For loop
204− --
205− | JSFor String JS JS JS
206− -- |
207− -- ForIn loop
208− --
209− | JSForIn String JS JS
210− -- |
211− -- If-then-else statement
212− --
213− | JSIfElse JS JS (Maybe JS)
214− -- |
215− -- Return statement
216− --
217− | JSReturn JS
218− -- |
219− -- Throw statement
220− --
221− | JSThrow JS
222− -- |
223− -- Type-Of operator
224− --
225− | JSTypeOf JS
226− -- |
227− -- InstanceOf test
228− --
229− | JSInstanceOf JS JS
230− -- |
231− -- Labelled statement
232− --
233− | JSLabel String JS
234− -- |
235− -- Break statement
236− --
237− | JSBreak String
238− -- |
239− -- Continue statement
240− --
241− | JSContinue String
242− -- |
243− -- Raw Javascript (generated when parsing fails for an inline foreign import declaration)
244− --
245− | JSRaw String
246− -- |
247− -- Commented Javascript
248− --
249− | JSComment [Comment] JS deriving (Show, Eq, Data, Typeable)
250−
251−--
252−-- Traversals
253−--
254−
255−everywhereOnJS :: (JS -> JS) -> JS -> JS
256−everywhereOnJS f = go
257− where
258− go :: JS -> JS
259− go (JSUnary op j) = f (JSUnary op (go j))
260− go (JSBinary op j1 j2) = f (JSBinary op (go j1) (go j2))
261− go (JSArrayLiteral js) = f (JSArrayLiteral (map go js))
262− go (JSIndexer j1 j2) = f (JSIndexer (go j1) (go j2))
263− go (JSObjectLiteral js) = f (JSObjectLiteral (map (fmap go) js))
264− go (JSAccessor prop j) = f (JSAccessor prop (go j))
265− go (JSFunction name args j) = f (JSFunction name args (go j))
266− go (JSApp j js) = f (JSApp (go j) (map go js))
267− go (JSConditional j1 j2 j3) = f (JSConditional (go j1) (go j2) (go j3))
268− go (JSBlock js) = f (JSBlock (map go js))
269− go (JSVariableIntroduction name j) = f (JSVariableIntroduction name (fmap go j))
270− go (JSAssignment j1 j2) = f (JSAssignment (go j1) (go j2))
271− go (JSWhile j1 j2) = f (JSWhile (go j1) (go j2))
272− go (JSFor name j1 j2 j3) = f (JSFor name (go j1) (go j2) (go j3))
273− go (JSForIn name j1 j2) = f (JSForIn name (go j1) (go j2))
274− go (JSIfElse j1 j2 j3) = f (JSIfElse (go j1) (go j2) (fmap go j3))
275− go (JSReturn js) = f (JSReturn (go js))
276− go (JSThrow js) = f (JSThrow (go js))
277− go (JSTypeOf js) = f (JSTypeOf (go js))
278− go (JSLabel name js) = f (JSLabel name (go js))
279− go (JSInstanceOf j1 j2) = f (JSInstanceOf (go j1) (go j2))
280− go (JSComment com j) = f (JSComment com (go j))
281− go other = f other
282−
283−everywhereOnJSTopDown :: (JS -> JS) -> JS -> JS
284−everywhereOnJSTopDown f = go . f
285− where
286− go :: JS -> JS
287− go (JSUnary op j) = JSUnary op (go (f j))
288− go (JSBinary op j1 j2) = JSBinary op (go (f j1)) (go (f j2))
289− go (JSArrayLiteral js) = JSArrayLiteral (map (go . f) js)
290− go (JSIndexer j1 j2) = JSIndexer (go (f j1)) (go (f j2))
291− go (JSObjectLiteral js) = JSObjectLiteral (map (fmap (go . f)) js)
292− go (JSAccessor prop j) = JSAccessor prop (go (f j))
293− go (JSFunction name args j) = JSFunction name args (go (f j))
294− go (JSApp j js) = JSApp (go (f j)) (map (go . f) js)
295− go (JSConditional j1 j2 j3) = JSConditional (go (f j1)) (go (f j2)) (go (f j3))
296− go (JSBlock js) = JSBlock (map (go . f) js)
297− go (JSVariableIntroduction name j) = JSVariableIntroduction name (fmap (go . f) j)
298− go (JSAssignment j1 j2) = JSAssignment (go (f j1)) (go (f j2))
299− go (JSWhile j1 j2) = JSWhile (go (f j1)) (go (f j2))
300− go (JSFor name j1 j2 j3) = JSFor name (go (f j1)) (go (f j2)) (go (f j3))
301− go (JSForIn name j1 j2) = JSForIn name (go (f j1)) (go (f j2))
302− go (JSIfElse j1 j2 j3) = JSIfElse (go (f j1)) (go (f j2)) (fmap (go . f) j3)
303− go (JSReturn j) = JSReturn (go (f j))
304− go (JSThrow j) = JSThrow (go (f j))
305− go (JSTypeOf j) = JSTypeOf (go (f j))
306− go (JSLabel name j) = JSLabel name (go (f j))
307− go (JSInstanceOf j1 j2) = JSInstanceOf (go (f j1)) (go (f j2))
308− go (JSComment com j) = JSComment com (go (f j))
309− go other = f other
310−
311−everythingOnJS :: (r -> r -> r) -> (JS -> r) -> JS -> r
312−everythingOnJS (<>) f = go
313− where
314− go j@(JSUnary _ j1) = f j <> go j1
315− go j@(JSBinary _ j1 j2) = f j <> go j1 <> go j2
316− go j@(JSArrayLiteral js) = foldl (<>) (f j) (map go js)
317− go j@(JSIndexer j1 j2) = f j <> go j1 <> go j2
318− go j@(JSObjectLiteral js) = foldl (<>) (f j) (map (go . snd) js)
319− go j@(JSAccessor _ j1) = f j <> go j1
320− go j@(JSFunction _ _ j1) = f j <> go j1
321− go j@(JSApp j1 js) = foldl (<>) (f j <> go j1) (map go js)
322− go j@(JSConditional j1 j2 j3) = f j <> go j1 <> go j2 <> go j3
323− go j@(JSBlock js) = foldl (<>) (f j) (map go js)
324− go j@(JSVariableIntroduction _ (Just j1)) = f j <> go j1
325− go j@(JSAssignment j1 j2) = f j <> go j1 <> go j2
326− go j@(JSWhile j1 j2) = f j <> go j1 <> go j2
327− go j@(JSFor _ j1 j2 j3) = f j <> go j1 <> go j2 <> go j3
328− go j@(JSForIn _ j1 j2) = f j <> go j1 <> go j2
329− go j@(JSIfElse j1 j2 Nothing) = f j <> go j1 <> go j2
330− go j@(JSIfElse j1 j2 (Just j3)) = f j <> go j1 <> go j2 <> go j3
331− go j@(JSReturn j1) = f j <> go j1
332− go j@(JSThrow j1) = f j <> go j1
333− go j@(JSTypeOf j1) = f j <> go j1
334− go j@(JSLabel _ j1) = f j <> go j1
335− go j@(JSInstanceOf j1 j2) = f j <> go j1 <> go j2
336− go j@(JSComment _ j1) = f j <> go j1
337− go other = f other
src/Language/PureScript/CodeGen/JS/Common.hsdeleted−181
@@ -1,181 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.CodeGen.Common
4−-- Copyright : (c) Phil Freeman 2013
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- |
12−-- Common code generation utility functions
13−--
14−-----------------------------------------------------------------------------
15−
16−module Language.PureScript.CodeGen.JS.Common where
17−
18−import Data.Char
19−import Data.List (intercalate)
20−
21−import Language.PureScript.Names
22−
23−-- |
24−-- Convert an Ident into a valid Javascript identifier:
25−--
26−-- * Alphanumeric characters are kept unmodified.
27−--
28−-- * Reserved javascript identifiers are prefixed with '$$'.
29−--
30−-- * Symbols are prefixed with '$' followed by a symbol name or their ordinal value.
31−--
32−identToJs :: Ident -> String
33−identToJs (Ident name) | nameIsJsReserved name = "$$" ++ name
34−identToJs (Ident name) = concatMap identCharToString name
35−identToJs (Op op) = concatMap identCharToString op
36−
37−-- |
38−-- Test if a string is a valid JS identifier without escaping.
39−--
40−identNeedsEscaping :: String -> Bool
41−identNeedsEscaping s = s /= identToJs (Ident s)
42−
43−-- |
44−-- Attempts to find a human-readable name for a symbol, if none has been specified returns the
45−-- ordinal value.
46−--
47−identCharToString :: Char -> String
48−identCharToString c | isAlphaNum c = [c]
49−identCharToString '_' = "_"
50−identCharToString '.' = "$dot"
51−identCharToString '$' = "$dollar"
52−identCharToString '~' = "$tilde"
53−identCharToString '=' = "$eq"
54−identCharToString '<' = "$less"
55−identCharToString '>' = "$greater"
56−identCharToString '!' = "$bang"
57−identCharToString '#' = "$hash"
58−identCharToString '%' = "$percent"
59−identCharToString '^' = "$up"
60−identCharToString '&' = "$amp"
61−identCharToString '|' = "$bar"
62−identCharToString '*' = "$times"
63−identCharToString '/' = "$div"
64−identCharToString '+' = "$plus"
65−identCharToString '-' = "$minus"
66−identCharToString ':' = "$colon"
67−identCharToString '\\' = "$bslash"
68−identCharToString '?' = "$qmark"
69−identCharToString '@' = "$at"
70−identCharToString '\'' = "$prime"
71−identCharToString c = '$' : show (ord c)
72−
73−-- |
74−-- Checks whether an identifier name is reserved in Javascript.
75−--
76−nameIsJsReserved :: String -> Bool
77−nameIsJsReserved name =
78− name `elem` [ "abstract"
79− , "arguments"
80− , "boolean"
81− , "break"
82− , "byte"
83− , "case"
84− , "catch"
85− , "char"
86− , "class"
87− , "const"
88− , "continue"
89− , "debugger"
90− , "default"
91− , "delete"
92− , "do"
93− , "double"
94− , "else"
95− , "enum"
96− , "eval"
97− , "export"
98− , "extends"
99− , "final"
100− , "finally"
101− , "float"
102− , "for"
103− , "function"
104− , "goto"
105− , "if"
106− , "implements"
107− , "import"
108− , "in"
109− , "instanceof"
110− , "int"
111− , "interface"
112− , "let"
113− , "long"
114− , "native"
115− , "new"
116− , "null"
117− , "package"
118− , "private"
119− , "protected"
120− , "public"
121− , "return"
122− , "short"
123− , "static"
124− , "super"
125− , "switch"
126− , "synchronized"
127− , "this"
128− , "throw"
129− , "throws"
130− , "transient"
131− , "try"
132− , "typeof"
133− , "var"
134− , "void"
135− , "volatile"
136− , "while"
137− , "with"
138− , "yield" ] || properNameIsJsReserved name
139−
140−moduleNameToJs :: ModuleName -> String
141−moduleNameToJs (ModuleName pns) =
142− let name = intercalate "_" (runProperName `map` pns)
143− in if properNameIsJsReserved name then "$$" ++ name else name
144−
145−-- |
146−-- Checks whether a proper name is reserved in Javascript.
147−--
148−properNameIsJsReserved :: String -> Bool
149−properNameIsJsReserved name =
150− name `elem` [ "Infinity"
151− , "NaN"
152− , "Object"
153− , "Function"
154− , "Boolean"
155− , "Error"
156− , "EvalError"
157− , "InternalError"
158− , "RangeError"
159− , "ReferenceError"
160− , "SyntaxError"
161− , "TypeError"
162− , "URIError"
163− , "Number"
164− , "Math"
165− , "Date"
166− , "String"
167− , "RegExp"
168− , "Array"
169− , "Int8Array"
170− , "Uint8Array"
171− , "Uint8ClampedArray"
172− , "Int16Array"
173− , "Uint16Array"
174− , "Int32Array"
175− , "Uint32Array"
176− , "Float32Array"
177− , "Float64Array"
178− , "ArrayBuffer"
179− , "DataView"
180− , "JSON"
181− , "Intl" ]
src/Language/PureScript/CodeGen/JS/Optimizer.hsdeleted−86
@@ -1,86 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.CodeGen.JS.Optimizer
4−-- Copyright : (c) Phil Freeman 2013
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- |
12−-- This module optimizes code in the simplified-Javascript intermediate representation.
13−--
14−-- The following optimizations are supported:
15−--
16−-- * Collapsing nested blocks
17−--
18−-- * Tail call elimination
19−--
20−-- * Inlining of (>>=) and ret for the Eff monad
21−--
22−-- * Removal of unnecessary thunks
23−--
24−-- * Eta conversion
25−--
26−-- * Inlining variables
27−--
28−-- * Inline Prelude.($), Prelude.(#), Prelude.(++), Prelude.(!!)
29−--
30−-- * Inlining primitive Javascript operators
31−--
32−-----------------------------------------------------------------------------
33−
34−{-# LANGUAGE FlexibleContexts #-}
35−
36−module Language.PureScript.CodeGen.JS.Optimizer (
37− optimize
38−) where
39−
40−import Control.Monad.Reader (MonadReader, ask, asks)
41−
42−import Language.PureScript.CodeGen.JS.AST
43−import Language.PureScript.Options
44−import qualified Language.PureScript.Constants as C
45−
46−import Language.PureScript.CodeGen.JS.Optimizer.Common
47−import Language.PureScript.CodeGen.JS.Optimizer.TCO
48−import Language.PureScript.CodeGen.JS.Optimizer.MagicDo
49−import Language.PureScript.CodeGen.JS.Optimizer.Inliner
50−import Language.PureScript.CodeGen.JS.Optimizer.Unused
51−import Language.PureScript.CodeGen.JS.Optimizer.Blocks
52−
53−-- |
54−-- Apply a series of optimizer passes to simplified Javascript code
55−--
56−optimize :: (Monad m, MonadReader (Options mode) m) => JS -> m JS
57−optimize js = do
58− noOpt <- asks optionsNoOptimizations
59− if noOpt then return js else optimize' js
60−
61−optimize' :: (Monad m, MonadReader (Options mode) m) => JS -> m JS
62−optimize' js = do
63− opts <- ask
64− return $ untilFixedPoint (applyAll
65− [ collapseNestedBlocks
66− , collapseNestedIfs
67− , tco opts
68− , magicDo opts
69− , removeCodeAfterReturnStatements
70− , removeUnusedArg
71− , removeUndefinedApp
72− , unThunk
73− , etaConvert
74− , evaluateIifes
75− , inlineVariables
76− , inlineValues
77− , inlineOperator (C.prelude, (C.$)) $ \f x -> JSApp f [x]
78− , inlineOperator (C.prelude, (C.#)) $ \x f -> JSApp f [x]
79− , inlineOperator (C.preludeUnsafe, C.unsafeIndex) $ flip JSIndexer
80− , inlineCommonOperators ]) js
81−
82−untilFixedPoint :: (Eq a) => (a -> a) -> a -> a
83−untilFixedPoint f = go
84− where
85− go a = let a' = f a in
86− if a' == a then a' else go a'
src/Language/PureScript/CodeGen/JS/Optimizer/Blocks.hsdeleted−42
@@ -1,42 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.CodeGen.JS.Optimizer.Blocks
4−-- Copyright : (c) Phil Freeman 2013-14
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- |
12−-- Optimizer steps for simplifying Javascript blocks
13−--
14−-----------------------------------------------------------------------------
15−
16−module Language.PureScript.CodeGen.JS.Optimizer.Blocks
17− ( collapseNestedBlocks
18− , collapseNestedIfs
19− ) where
20−
21−import Language.PureScript.CodeGen.JS.AST
22−
23−-- |
24−-- Collapse blocks which appear nested directly below another block
25−--
26−collapseNestedBlocks :: JS -> JS
27−collapseNestedBlocks = everywhereOnJS collapse
28− where
29− collapse :: JS -> JS
30− collapse (JSBlock sts) = JSBlock (concatMap go sts)
31− collapse js = js
32− go :: JS -> [JS]
33− go (JSBlock sts) = sts
34− go s = [s]
35−
36−collapseNestedIfs :: JS -> JS
37−collapseNestedIfs = everywhereOnJS collapse
38− where
39− collapse :: JS -> JS
40− collapse (JSIfElse cond1 (JSBlock [JSIfElse cond2 body Nothing]) Nothing) =
41− JSIfElse (JSBinary And cond1 cond2) body Nothing
42− collapse js = js
src/Language/PureScript/CodeGen/JS/Optimizer/Common.hsdeleted−77
@@ -1,77 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.CodeGen.JS.Optimizer.Common
4−-- Copyright : (c) Phil Freeman 2013-14
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- |
12−-- Common functions used by the various optimizer phases
13−--
14−-----------------------------------------------------------------------------
15−
16−module Language.PureScript.CodeGen.JS.Optimizer.Common where
17−
18−import Data.Maybe (fromMaybe)
19−
20−import Language.PureScript.CodeGen.JS.AST
21−
22−applyAll :: [a -> a] -> a -> a
23−applyAll = foldl1 (.)
24−
25−replaceIdent :: String -> JS -> JS -> JS
26−replaceIdent var1 js = everywhereOnJS replace
27− where
28− replace (JSVar var2) | var1 == var2 = js
29− replace other = other
30−
31−replaceIdents :: [(String, JS)] -> JS -> JS
32−replaceIdents vars = everywhereOnJS replace
33− where
34− replace v@(JSVar var) = fromMaybe v $ lookup var vars
35− replace other = other
36−
37−isReassigned :: String -> JS -> Bool
38−isReassigned var1 = everythingOnJS (||) check
39− where
40− check :: JS -> Bool
41− check (JSFunction _ args _) | var1 `elem` args = True
42− check (JSVariableIntroduction arg _) | var1 == arg = True
43− check (JSAssignment (JSVar arg) _) | var1 == arg = True
44− check (JSFor arg _ _ _) | var1 == arg = True
45− check (JSForIn arg _ _) | var1 == arg = True
46− check _ = False
47−
48−isRebound :: JS -> JS -> Bool
49−isRebound js d = any (\v -> isReassigned v d || isUpdated v d) (everythingOnJS (++) variablesOf js)
50− where
51− variablesOf (JSVar var) = [var]
52− variablesOf _ = []
53−
54−isUsed :: String -> JS -> Bool
55−isUsed var1 = everythingOnJS (||) check
56− where
57− check :: JS -> Bool
58− check (JSVar var2) | var1 == var2 = True
59− check (JSAssignment target _) | var1 == targetVariable target = True
60− check _ = False
61−
62−targetVariable :: JS -> String
63−targetVariable (JSVar var) = var
64−targetVariable (JSAccessor _ tgt) = targetVariable tgt
65−targetVariable (JSIndexer _ tgt) = targetVariable tgt
66−targetVariable _ = error "Invalid argument to targetVariable"
67−
68−isUpdated :: String -> JS -> Bool
69−isUpdated var1 = everythingOnJS (||) check
70− where
71− check :: JS -> Bool
72− check (JSAssignment target _) | var1 == targetVariable target = True
73− check _ = False
74−
75−removeFromBlock :: ([JS] -> [JS]) -> JS -> JS
76−removeFromBlock go (JSBlock sts) = JSBlock (go sts)
77−removeFromBlock _ js = js
src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hsdeleted−294
@@ -1,294 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.CodeGen.JS.Optimizer.Inliner
4−-- Copyright : (c) Phil Freeman 2013-14
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- |
12−-- This module provides basic inlining capabilities
13−--
14−-----------------------------------------------------------------------------
15−
16−module Language.PureScript.CodeGen.JS.Optimizer.Inliner (
17− inlineVariables,
18− inlineValues,
19− inlineOperator,
20− inlineCommonOperators,
21− etaConvert,
22− unThunk,
23− evaluateIifes
24−) where
25−
26−import Data.Maybe (fromMaybe)
27−
28−import Language.PureScript.CodeGen.JS.AST
29−import Language.PureScript.CodeGen.JS.Common
30−import Language.PureScript.Names
31−import Language.PureScript.CodeGen.JS.Optimizer.Common
32−import qualified Language.PureScript.Constants as C
33−
34−shouldInline :: JS -> Bool
35−shouldInline (JSVar _) = True
36−shouldInline (JSNumericLiteral _) = True
37−shouldInline (JSStringLiteral _) = True
38−shouldInline (JSBooleanLiteral _) = True
39−shouldInline (JSAccessor _ val) = shouldInline val
40−shouldInline (JSIndexer index val) = shouldInline index && shouldInline val
41−shouldInline _ = False
42−
43−etaConvert :: JS -> JS
44−etaConvert = everywhereOnJS convert
45− where
46− convert :: JS -> JS
47− convert (JSBlock [JSReturn (JSApp (JSFunction Nothing idents block@(JSBlock body)) args)])
48− | all shouldInline args &&
49− not (any (`isRebound` block) (map JSVar idents)) &&
50− not (any (`isRebound` block) args)
51− = JSBlock (map (replaceIdents (zip idents args)) body)
52− convert (JSFunction Nothing [] (JSBlock [JSReturn (JSApp fn [])])) = fn
53− convert js = js
54−
55−unThunk :: JS -> JS
56−unThunk = everywhereOnJS convert
57− where
58− convert :: JS -> JS
59− convert (JSBlock []) = JSBlock []
60− convert (JSBlock jss) =
61− case last jss of
62− JSReturn (JSApp (JSFunction Nothing [] (JSBlock body)) []) -> JSBlock $ init jss ++ body
63− _ -> JSBlock jss
64− convert js = js
65−
66−evaluateIifes :: JS -> JS
67−evaluateIifes = everywhereOnJS convert
68− where
69− convert :: JS -> JS
70− convert (JSApp (JSFunction Nothing [] (JSBlock [JSReturn ret])) []) = ret
71− convert js = js
72−
73−inlineVariables :: JS -> JS
74−inlineVariables = everywhereOnJS $ removeFromBlock go
75− where
76− go :: [JS] -> [JS]
77− go [] = []
78− go (JSVariableIntroduction var (Just js) : sts)
79− | shouldInline js && not (any (isReassigned var) sts) && not (any (isRebound js) sts) && not (any (isUpdated var) sts) =
80− go (map (replaceIdent var js) sts)
81− go (s:sts) = s : go sts
82−
83−inlineValues :: JS -> JS
84−inlineValues = everywhereOnJS convert
85− where
86− convert :: JS -> JS
87− convert (JSApp fn [dict]) | isDict semiringNumber dict && isFn fnZero fn = JSNumericLiteral (Left 0)
88− | isDict semiringNumber dict && isFn fnOne fn = JSNumericLiteral (Left 1)
89− | isDict semiringInt dict && isFn fnZero fn = JSNumericLiteral (Left 0)
90− | isDict semiringInt dict && isFn fnOne fn = JSNumericLiteral (Left 1)
91− | isDict boundedBoolean dict && isFn fnBottom fn = JSBooleanLiteral False
92− | isDict boundedBoolean dict && isFn fnTop fn = JSBooleanLiteral True
93− convert (JSApp fn [value]) | isFn fromNumber fn = JSBinary BitwiseOr value (JSNumericLiteral (Left 0))
94− convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y])
95− | isDict semiringInt dict && isFn fnAdd fn = JSBinary BitwiseOr (JSBinary Add x y) (JSNumericLiteral (Left 0))
96− | isDict semiringInt dict && isFn fnMultiply fn = JSBinary BitwiseOr (JSBinary Multiply x y) (JSNumericLiteral (Left 0))
97− | isDict moduloSemiringInt dict && isFn fnDivide fn = JSBinary BitwiseOr (JSBinary Divide x y) (JSNumericLiteral (Left 0))
98− | isDict ringInt dict && isFn fnSubtract fn = JSBinary BitwiseOr (JSBinary Subtract x y) (JSNumericLiteral (Left 0))
99− convert other = other
100− fnZero = (C.prelude, C.zero)
101− fnOne = (C.prelude, C.one)
102− fnBottom = (C.prelude, C.bottom)
103− fnTop = (C.prelude, C.top)
104− fromNumber = (C.dataInt, C.fromNumber)
105− fnAdd = (C.prelude, (C.+))
106− fnDivide = (C.prelude, (C./))
107− fnMultiply = (C.prelude, (C.*))
108− fnSubtract = (C.prelude, (C.-))
109−
110−inlineOperator :: (String, String) -> (JS -> JS -> JS) -> JS -> JS
111−inlineOperator (m, op) f = everywhereOnJS convert
112− where
113− convert :: JS -> JS
114− convert (JSApp (JSApp op' [x]) [y]) | isOp op' = f x y
115− convert other = other
116− isOp (JSAccessor longForm (JSVar m')) = m == m' && longForm == identToJs (Op op)
117− isOp (JSIndexer (JSStringLiteral op') (JSVar m')) = m == m' && op == op'
118− isOp _ = False
119−
120−inlineCommonOperators :: JS -> JS
121−inlineCommonOperators = applyAll $
122− [ binary semiringNumber (C.+) Add
123− , binary semiringNumber (C.*) Multiply
124−
125− , binary ringNumber (C.-) Subtract
126− , unary ringNumber C.negate Negate
127− , binary ringInt (C.-) Subtract
128− , unary ringInt C.negate Negate
129−
130− , binary moduloSemiringNumber (C./) Divide
131− , binary moduloSemiringInt C.mod Modulus
132−
133− , binary eqNumber (C.==) EqualTo
134− , binary eqNumber (C./=) NotEqualTo
135− , binary eqInt (C.==) EqualTo
136− , binary eqInt (C./=) NotEqualTo
137− , binary eqString (C.==) EqualTo
138− , binary eqString (C./=) NotEqualTo
139− , binary eqBoolean (C.==) EqualTo
140− , binary eqBoolean (C./=) NotEqualTo
141−
142− , binary ordNumber (C.<) LessThan
143− , binary ordNumber (C.>) GreaterThan
144− , binary ordNumber (C.<=) LessThanOrEqualTo
145− , binary ordNumber (C.>=) GreaterThanOrEqualTo
146− , binary ordInt (C.<) LessThan
147− , binary ordInt (C.>) GreaterThan
148− , binary ordInt (C.<=) LessThanOrEqualTo
149− , binary ordInt (C.>=) GreaterThanOrEqualTo
150−
151− , binary semigroupString (C.<>) Add
152− , binary semigroupString (C.++) Add
153−
154− , binary latticeBoolean (C.&&) And
155− , binary latticeBoolean (C.||) Or
156− , binaryFunction latticeBoolean C.inf And
157− , binaryFunction latticeBoolean C.sup Or
158− , unary complementedLatticeBoolean C.not Not
159−
160− , binary' C.dataIntBits (C..|.) BitwiseOr
161− , binary' C.dataIntBits (C..&.) BitwiseAnd
162− , binary' C.dataIntBits (C..^.) BitwiseXor
163− , binary' C.dataIntBits C.shl ShiftLeft
164− , binary' C.dataIntBits C.shr ShiftRight
165− , binary' C.dataIntBits C.zshr ZeroFillShiftRight
166− , unary' C.dataIntBits C.complement BitwiseNot
167− ] ++
168− [ fn | i <- [0..10], fn <- [ mkFn i, runFn i ] ]
169− where
170− binary :: (String, String) -> String -> BinaryOperator -> JS -> JS
171− binary dict opString op = everywhereOnJS convert
172− where
173− convert :: JS -> JS
174− convert (JSApp (JSApp (JSApp fn [dict']) [x]) [y]) | isDict dict dict' && isPreludeFn opString fn = JSBinary op x y
175− convert other = other
176− binary' :: String -> String -> BinaryOperator -> JS -> JS
177− binary' moduleName opString op = everywhereOnJS convert
178− where
179− convert :: JS -> JS
180− convert (JSApp (JSApp fn [x]) [y]) | isFn (moduleName, opString) fn = JSBinary op x y
181− convert other = other
182− binaryFunction :: (String, String) -> String -> BinaryOperator -> JS -> JS
183− binaryFunction dict fnName op = everywhereOnJS convert
184− where
185− convert :: JS -> JS
186− convert (JSApp (JSApp (JSApp fn [dict']) [x]) [y]) | isPreludeFn fnName fn && isDict dict dict' = JSBinary op x y
187− convert other = other
188− unary :: (String, String) -> String -> UnaryOperator -> JS -> JS
189− unary dict fnName op = everywhereOnJS convert
190− where
191− convert :: JS -> JS
192− convert (JSApp (JSApp fn [dict']) [x]) | isPreludeFn fnName fn && isDict dict dict' = JSUnary op x
193− convert other = other
194− unary' :: String -> String -> UnaryOperator -> JS -> JS
195− unary' moduleName fnName op = everywhereOnJS convert
196− where
197− convert :: JS -> JS
198− convert (JSApp fn [x]) | isFn (moduleName, fnName) fn = JSUnary op x
199− convert other = other
200− mkFn :: Int -> JS -> JS
201− mkFn 0 = everywhereOnJS convert
202− where
203− convert :: JS -> JS
204− convert (JSApp mkFnN [JSFunction Nothing [_] (JSBlock js)]) | isNFn C.mkFn 0 mkFnN =
205− JSFunction Nothing [] (JSBlock js)
206− convert other = other
207− mkFn n = everywhereOnJS convert
208− where
209− convert :: JS -> JS
210− convert orig@(JSApp mkFnN [fn]) | isNFn C.mkFn n mkFnN =
211− case collectArgs n [] fn of
212− Just (args, js) -> JSFunction Nothing args (JSBlock js)
213− Nothing -> orig
214− convert other = other
215− collectArgs :: Int -> [String] -> JS -> Maybe ([String], [JS])
216− collectArgs 1 acc (JSFunction Nothing [oneArg] (JSBlock js)) | length acc == n - 1 = Just (reverse (oneArg : acc), js)
217− collectArgs m acc (JSFunction Nothing [oneArg] (JSBlock [JSReturn ret])) = collectArgs (m - 1) (oneArg : acc) ret
218− collectArgs _ _ _ = Nothing
219−
220− isNFn :: String -> Int -> JS -> Bool
221− isNFn prefix n (JSVar name) = name == (prefix ++ show n)
222− isNFn prefix n (JSAccessor name (JSVar dataFunction)) | dataFunction == C.dataFunction = name == (prefix ++ show n)
223− isNFn _ _ _ = False
224−
225− runFn :: Int -> JS -> JS
226− runFn n = everywhereOnJS convert
227− where
228− convert :: JS -> JS
229− convert js = fromMaybe js $ go n [] js
230−
231− go :: Int -> [JS] -> JS -> Maybe JS
232− go 0 acc (JSApp runFnN [fn]) | isNFn C.runFn n runFnN && length acc == n = Just (JSApp fn acc)
233− go m acc (JSApp lhs [arg]) = go (m - 1) (arg : acc) lhs
234− go _ _ _ = Nothing
235−
236−isDict :: (String, String) -> JS -> Bool
237−isDict (moduleName, dictName) (JSAccessor x (JSVar y)) = x == dictName && y == moduleName
238−isDict _ _ = False
239−
240−isFn :: (String, String) -> JS -> Bool
241−isFn (moduleName, fnName) (JSAccessor x (JSVar y)) = x == fnName && y == moduleName
242−isFn (moduleName, fnName) (JSIndexer (JSStringLiteral x) (JSVar y)) = x == fnName && y == moduleName
243−isFn _ _ = False
244−
245−isPreludeFn :: String -> JS -> Bool
246−isPreludeFn fnName = isFn (C.prelude, fnName)
247−
248−semiringNumber :: (String, String)
249−semiringNumber = (C.prelude, C.semiringNumber)
250−
251−semiringInt :: (String, String)
252−semiringInt = (C.dataInt, C.semiringInt)
253−
254−ringNumber :: (String, String)
255−ringNumber = (C.prelude, C.ringNumber)
256−
257−ringInt :: (String, String)
258−ringInt = (C.dataInt, C.ringInt)
259−
260−moduloSemiringNumber :: (String, String)
261−moduloSemiringNumber = (C.prelude, C.moduloSemiringNumber)
262−
263−moduloSemiringInt :: (String, String)
264−moduloSemiringInt = (C.dataInt, C.moduloSemiringInt)
265−
266−eqNumber :: (String, String)
267−eqNumber = (C.prelude, C.eqNumber)
268−
269−eqInt :: (String, String)
270−eqInt = (C.dataInt, C.eqInt)
271−
272−eqString :: (String, String)
273−eqString = (C.prelude, C.eqNumber)
274−
275−eqBoolean :: (String, String)
276−eqBoolean = (C.prelude, C.eqNumber)
277−
278−ordNumber :: (String, String)
279−ordNumber = (C.prelude, C.ordNumber)
280−
281−ordInt :: (String, String)
282−ordInt = (C.dataInt, C.ordInt)
283−
284−semigroupString :: (String, String)
285−semigroupString = (C.prelude, C.semigroupString)
286−
287−boundedBoolean :: (String, String)
288−boundedBoolean = (C.prelude, C.boundedBoolean)
289−
290−latticeBoolean :: (String, String)
291−latticeBoolean = (C.prelude, C.latticeBoolean)
292−
293−complementedLatticeBoolean :: (String, String)
294−complementedLatticeBoolean = (C.prelude, C.complementedLatticeBoolean)
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−128
@@ -1,128 +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 Data.Monoid
19−
20−import Language.PureScript.Options
21−import Language.PureScript.CodeGen.JS.AST
22−
23−-- |
24−-- Eliminate tail calls
25−--
26−tco :: Options mode -> JS -> JS
27−tco opts | optionsNoTco opts = id
28− | otherwise = tco'
29−
30−tco' :: JS -> JS
31−tco' = everywhereOnJS convert
32− where
33− tcoLabel :: String
34− tcoLabel = "tco"
35−
36− tcoVar :: String -> String
37− tcoVar arg = "__tco_" ++ arg
38−
39− copyVar :: String -> String
40− copyVar arg = "__copy_" ++ arg
41−
42− convert :: JS -> JS
43− convert js@(JSVariableIntroduction name (Just fn@JSFunction {})) =
44− let
45− (argss, body', replace) = collectAllFunctionArgs [] id fn
46− in case () of
47− _ | isTailCall name body' ->
48− let
49− allArgs = concat $ reverse argss
50− in
51− JSVariableIntroduction name (Just (replace (toLoop name allArgs body')))
52− | otherwise -> js
53− convert js = js
54−
55− collectAllFunctionArgs :: [[String]] -> (JS -> JS) -> JS -> ([[String]], JS, JS -> JS)
56− collectAllFunctionArgs allArgs f (JSFunction ident args (JSBlock (body@(JSReturn _):_))) =
57− collectAllFunctionArgs (args : allArgs) (\b -> f (JSFunction ident (map copyVar args) (JSBlock [b]))) body
58− collectAllFunctionArgs allArgs f (JSFunction ident args body@(JSBlock _)) =
59− (args : allArgs, body, f . JSFunction ident (map copyVar args))
60− collectAllFunctionArgs allArgs f (JSReturn (JSFunction ident args (JSBlock [body]))) =
61− collectAllFunctionArgs (args : allArgs) (\b -> f (JSReturn (JSFunction ident (map copyVar args) (JSBlock [b])))) body
62− collectAllFunctionArgs allArgs f (JSReturn (JSFunction ident args body@(JSBlock _))) =
63− (args : allArgs, body, f . JSReturn . JSFunction ident (map copyVar args))
64− collectAllFunctionArgs allArgs f body = (allArgs, body, f)
65−
66− isTailCall :: String -> JS -> Bool
67− isTailCall ident js =
68− let
69− numSelfCalls = everythingOnJS (+) countSelfCalls js
70− numSelfCallsInTailPosition = everythingOnJS (+) countSelfCallsInTailPosition js
71− numSelfCallsUnderFunctions = everythingOnJS (+) countSelfCallsUnderFunctions js
72− numSelfCallWithFnArgs = everythingOnJS (+) countSelfCallsWithFnArgs js
73− in
74− numSelfCalls > 0
75− && numSelfCalls == numSelfCallsInTailPosition
76− && numSelfCallsUnderFunctions == 0
77− && numSelfCallWithFnArgs == 0
78− where
79− countSelfCalls :: JS -> Int
80− countSelfCalls (JSApp (JSVar ident') _) | ident == ident' = 1
81− countSelfCalls _ = 0
82−
83− countSelfCallsInTailPosition :: JS -> Int
84− countSelfCallsInTailPosition (JSReturn ret) | isSelfCall ident ret = 1
85− countSelfCallsInTailPosition _ = 0
86−
87− countSelfCallsUnderFunctions :: JS -> Int
88− countSelfCallsUnderFunctions (JSFunction _ _ js') = everythingOnJS (+) countSelfCalls js'
89− countSelfCallsUnderFunctions _ = 0
90−
91− countSelfCallsWithFnArgs :: JS -> Int
92− countSelfCallsWithFnArgs ret = if isSelfCallWithFnArgs ident ret [] then 1 else 0
93−
94− toLoop :: String -> [String] -> JS -> JS
95− toLoop ident allArgs js = JSBlock $
96− map (\arg -> JSVariableIntroduction arg (Just (JSVar (copyVar arg)))) allArgs ++
97− [ JSLabel tcoLabel $ JSWhile (JSBooleanLiteral True) (JSBlock [ everywhereOnJS loopify js ]) ]
98− where
99− loopify :: JS -> JS
100− loopify (JSReturn ret) | isSelfCall ident ret =
101− let
102− allArgumentValues = concat $ collectSelfCallArgs [] ret
103− in
104− JSBlock $ zipWith (\val arg ->
105− JSVariableIntroduction (tcoVar arg) (Just val)) allArgumentValues allArgs
106− ++ map (\arg ->
107− JSAssignment (JSVar arg) (JSVar (tcoVar arg))) allArgs
108− ++ [ JSContinue tcoLabel ]
109− loopify other = other
110− collectSelfCallArgs :: [[JS]] -> JS -> [[JS]]
111− collectSelfCallArgs allArgumentValues (JSApp fn args') = collectSelfCallArgs (args' : allArgumentValues) fn
112− collectSelfCallArgs allArgumentValues _ = allArgumentValues
113−
114− isSelfCall :: String -> JS -> Bool
115− isSelfCall ident (JSApp (JSVar ident') _) = ident == ident'
116− isSelfCall ident (JSApp fn _) = isSelfCall ident fn
117− isSelfCall _ _ = False
118−
119− isSelfCallWithFnArgs :: String -> JS -> [JS] -> Bool
120− isSelfCallWithFnArgs ident (JSVar ident') args | ident == ident' && any hasFunction args = True
121− isSelfCallWithFnArgs ident (JSApp fn args) acc = isSelfCallWithFnArgs ident fn (args ++ acc)
122− isSelfCallWithFnArgs _ _ _ = False
123−
124− hasFunction :: JS -> Bool
125− hasFunction = getAny . everythingOnJS mappend (Any . isFunction)
126− where
127− isFunction (JSFunction _ _ _) = True
128− isFunction _ = False
src/Language/PureScript/CodeGen/JS/Optimizer/Unused.hsdeleted−46
@@ -1,46 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.CodeGen.JS.Optimizer.Unused
4−-- Copyright : (c) Phil Freeman 2013-14
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- |
12−-- Removes unused variables
13−--
14−-----------------------------------------------------------------------------
15−
16−module Language.PureScript.CodeGen.JS.Optimizer.Unused
17− ( removeCodeAfterReturnStatements
18− , removeUnusedArg
19− , removeUndefinedApp
20− ) where
21−
22−import Language.PureScript.CodeGen.JS.AST
23−import Language.PureScript.CodeGen.JS.Optimizer.Common
24−
25−import qualified Language.PureScript.Constants as C
26−
27−removeCodeAfterReturnStatements :: JS -> JS
28−removeCodeAfterReturnStatements = everywhereOnJS (removeFromBlock go)
29− where
30− go :: [JS] -> [JS]
31− go jss | not (any isJSReturn jss) = jss
32− | otherwise = let (body, ret : _) = span (not . isJSReturn) jss in body ++ [ret]
33− isJSReturn (JSReturn _) = True
34− isJSReturn _ = False
35−
36−removeUnusedArg :: JS -> JS
37−removeUnusedArg = everywhereOnJS convert
38− where
39− convert (JSFunction name [arg] body) | arg == C.__unused = JSFunction name [] body
40− convert js = js
41−
42−removeUndefinedApp :: JS -> JS
43−removeUndefinedApp = everywhereOnJS convert
44− where
45− convert (JSApp fn [JSVar arg]) | arg == C.undefined = JSApp fn []
46− convert js = js
src/Language/PureScript/Comments.hsdeleted−25
@@ -1,25 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.Parser.Comments
4−-- Copyright : (c) Phil Freeman 2015
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- |
12−-- Defines the types of source code comments
13−--
14−-----------------------------------------------------------------------------
15−
16−{-# LANGUAGE DeriveDataTypeable #-}
17−
18−module Language.PureScript.Comments where
19−
20−import qualified Data.Data as D
21−
22−data Comment
23− = LineComment String
24− | BlockComment String
25− deriving (Show, Eq, Ord, D.Data, D.Typeable)
src/Language/PureScript/Constants.hsdeleted−278
@@ -1,278 +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−-- 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−unsafeIndex :: String
75−unsafeIndex = "unsafeIndex"
76−
77−(.|.) :: String
78−(.|.) = ".|."
79−
80−(.&.) :: String
81−(.&.) = ".&."
82−
83−(.^.) :: String
84−(.^.) = ".^."
85−
86−-- Functions
87−
88−negate :: String
89−negate = "negate"
90−
91−not :: String
92−not = "not"
93−
94−sup :: String
95−sup = "sup"
96−
97−inf :: String
98−inf = "inf"
99−
100−mod :: String
101−mod = "mod"
102−
103−shl :: String
104−shl = "shl"
105−
106−shr :: String
107−shr = "shr"
108−
109−zshr :: String
110−zshr = "zshr"
111−
112−complement :: String
113−complement = "complement"
114−
115−fromNumber :: String
116−fromNumber = "fromNumber"
117−
118−-- Prelude Values
119−
120−zero :: String
121−zero = "zero"
122−
123−one :: String
124−one = "one"
125−
126−bottom :: String
127−bottom = "bottom"
128−
129−top :: String
130−top = "top"
131−
132−return :: String
133−return = "return"
134−
135−pure' :: String
136−pure' = "pure"
137−
138−returnEscaped :: String
139−returnEscaped = "$return"
140−
141−untilE :: String
142−untilE = "untilE"
143−
144−whileE :: String
145−whileE = "whileE"
146−
147−runST :: String
148−runST = "runST"
149−
150−stRefValue :: String
151−stRefValue = "value"
152−
153−newSTRef :: String
154−newSTRef = "newSTRef"
155−
156−readSTRef :: String
157−readSTRef = "readSTRef"
158−
159−writeSTRef :: String
160−writeSTRef = "writeSTRef"
161−
162−modifySTRef :: String
163−modifySTRef = "modifySTRef"
164−
165−mkFn :: String
166−mkFn = "mkFn"
167−
168−runFn :: String
169−runFn = "runFn"
170−
171−unit :: String
172−unit = "unit"
173−
174−-- Prim values
175−
176−undefined :: String
177−undefined = "undefined"
178−
179−-- Type Class Dictionary Names
180−
181−monadEffDictionary :: String
182−monadEffDictionary = "monadEff"
183−
184−applicativeEffDictionary :: String
185−applicativeEffDictionary = "applicativeEff"
186−
187−bindEffDictionary :: String
188−bindEffDictionary = "bindEff"
189−
190−semiringNumber :: String
191−semiringNumber = "semiringNumber"
192−
193−semiringInt :: String
194−semiringInt = "semiringInt"
195−
196−ringNumber :: String
197−ringNumber = "ringNumber"
198−
199−ringInt :: String
200−ringInt = "ringInt"
201−
202−moduloSemiringNumber :: String
203−moduloSemiringNumber = "moduloSemiringNumber"
204−
205−moduloSemiringInt :: String
206−moduloSemiringInt = "moduloSemiringInt"
207−
208−ordNumber :: String
209−ordNumber = "ordNumber"
210−
211−ordInt :: String
212−ordInt = "ordInt"
213−
214−eqNumber :: String
215−eqNumber = "eqNumber"
216−
217−eqInt :: String
218−eqInt = "eqInt"
219−
220−eqString :: String
221−eqString = "eqString"
222−
223−eqBoolean :: String
224−eqBoolean = "eqBoolean"
225−
226−boundedBoolean :: String
227−boundedBoolean = "boundedBoolean"
228−
229−latticeBoolean :: String
230−latticeBoolean = "latticeBoolean"
231−
232−complementedLatticeBoolean :: String
233−complementedLatticeBoolean = "complementedLatticeBoolean"
234−
235−semigroupString :: String
236−semigroupString = "semigroupString"
237−
238−semigroupoidArr :: String
239−semigroupoidArr = "semigroupoidArr"
240−
241−-- Main module
242−
243−main :: String
244−main = "main"
245−
246−-- Code Generation
247−
248−__superclass_ :: String
249−__superclass_ = "__superclass_"
250−
251−__unused :: String
252−__unused = "__unused"
253−
254−-- Modules
255−
256−prim :: String
257−prim = "Prim"
258−
259−prelude :: String
260−prelude = "Prelude"
261−
262−preludeUnsafe :: String
263−preludeUnsafe = "Prelude_Unsafe"
264−
265−eff :: String
266−eff = "Control_Monad_Eff"
267−
268−st :: String
269−st = "Control_Monad_ST"
270−
271−dataFunction :: String
272−dataFunction = "Data_Function"
273−
274−dataInt :: String
275−dataInt = "Data_Int"
276−
277−dataIntBits :: String
278−dataIntBits = "Data_Int_Bits"
src/Language/PureScript/CoreFn.hsdeleted−26
@@ -1,26 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.CoreFn
4−-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- | The core functional representation
12−--
13−-----------------------------------------------------------------------------
14−
15−module Language.PureScript.CoreFn (
16− module C
17−) where
18−
19−import Language.PureScript.CoreFn.Ann as C
20−import Language.PureScript.CoreFn.Binders as C
21−import Language.PureScript.CoreFn.Desugar as C
22−import Language.PureScript.CoreFn.Expr as C
23−import Language.PureScript.CoreFn.Literals as C
24−import Language.PureScript.CoreFn.Meta as C
25−import Language.PureScript.CoreFn.Module as C
26−import Language.PureScript.CoreFn.Traversals as C
src/Language/PureScript/CoreFn/Ann.hsdeleted−37
@@ -1,37 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.CoreFn.Ann
4−-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- | Type alias for basic annotations
12−--
13−-----------------------------------------------------------------------------
14−
15−module Language.PureScript.CoreFn.Ann where
16−
17−import Language.PureScript.AST.SourcePos
18−import Language.PureScript.CoreFn.Meta
19−import Language.PureScript.Types
20−import Language.PureScript.Comments
21−
22−-- |
23−-- Type alias for basic annotations
24−--
25−type Ann = (Maybe SourceSpan, [Comment], Maybe Type, Maybe Meta)
26−
27−-- |
28−-- Initial annotation with no metadata
29−--
30−nullAnn :: Ann
31−nullAnn = (Nothing, [], Nothing, Nothing)
32−
33−-- |
34−-- Remove the comments from an annotation
35−--
36−removeComments :: Ann -> Ann
37−removeComments (ss, _, ty, meta) = (ss, [], ty, meta)
src/Language/PureScript/CoreFn/Binders.hsdeleted−48
@@ -1,48 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.CoreFn.Binders
4−-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- | The core functional representation for binders
12−--
13−-----------------------------------------------------------------------------
14−
15−{-# LANGUAGE DeriveDataTypeable #-}
16−{-# LANGUAGE DeriveFunctor #-}
17−
18−module Language.PureScript.CoreFn.Binders where
19−
20−import qualified Data.Data as D
21−
22−import Language.PureScript.CoreFn.Literals
23−import Language.PureScript.Names
24−
25−-- |
26−-- Data type for binders
27−--
28−data Binder a
29− -- |
30− -- Wildcard binder
31− --
32− = NullBinder a
33− -- |
34− -- A binder which matches a literal value
35− --
36− | LiteralBinder a (Literal (Binder a))
37− -- |
38− -- A binder which binds an identifier
39− --
40− | VarBinder a Ident
41− -- |
42− -- A binder which matches a data constructor (type name, constructor name, binders)
43− --
44− | ConstructorBinder a (Qualified ProperName) (Qualified ProperName) [Binder a]
45− -- |
46− -- A binder which binds its input to an identifier
47− --
48− | NamedBinder a Ident (Binder a) deriving (Show, D.Data, D.Typeable, Functor)
src/Language/PureScript/CoreFn/Desugar.hsdeleted−254
@@ -1,254 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.CoreFn.Desugar
4−-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- | The AST -> CoreFn desugaring step
12−--
13−-----------------------------------------------------------------------------
14−
15−module Language.PureScript.CoreFn.Desugar (moduleToCoreFn) where
16−
17−import Data.Function (on)
18−import Data.List (sort, sortBy, nub)
19−import Data.Maybe (mapMaybe)
20−import qualified Data.Map as M
21−
22−import Control.Arrow (second, (***))
23−
24−import Language.PureScript.AST.SourcePos
25−import Language.PureScript.AST.Traversals
26−import Language.PureScript.CoreFn.Ann
27−import Language.PureScript.CoreFn.Binders
28−import Language.PureScript.CoreFn.Expr
29−import Language.PureScript.CoreFn.Literals
30−import Language.PureScript.CoreFn.Meta
31−import Language.PureScript.CoreFn.Module
32−import Language.PureScript.Environment
33−import Language.PureScript.Names
34−import Language.PureScript.Sugar.TypeClasses (typeClassMemberName, superClassDictionaryNames)
35−import Language.PureScript.Types
36−import Language.PureScript.Comments
37−import qualified Language.PureScript.AST as A
38−
39−-- |
40−-- Desugars a module from AST to CoreFn representation.
41−--
42−moduleToCoreFn :: Environment -> A.Module -> Module Ann
43−moduleToCoreFn _ (A.Module _ _ _ Nothing) =
44− error "Module exports were not elaborated before moduleToCoreFn"
45−moduleToCoreFn env (A.Module coms mn decls (Just exps)) =
46− let imports = nub $ mapMaybe importToCoreFn decls ++ findQualModules decls
47− exps' = nub $ concatMap exportToCoreFn exps
48− externs = nub $ mapMaybe externToCoreFn decls
49− decls' = concatMap (declToCoreFn Nothing []) decls
50− in Module coms mn imports exps' externs decls'
51−
52− where
53−
54− -- |
55− -- Desugars member declarations from AST to CoreFn representation.
56− --
57− declToCoreFn :: Maybe SourceSpan -> [Comment] -> A.Declaration -> [Bind Ann]
58− declToCoreFn ss com (A.DataDeclaration Newtype _ _ [(ctor, _)]) =
59− [NonRec (properToIdent ctor) $
60− Abs (ss, com, Nothing, Just IsNewtype) (Ident "x") (Var nullAnn $ Qualified Nothing (Ident "x"))]
61− declToCoreFn _ _ d@(A.DataDeclaration Newtype _ _ _) =
62− error $ "Found newtype with multiple constructors: " ++ show d
63− declToCoreFn ss com (A.DataDeclaration Data tyName _ ctors) =
64− flip map ctors $ \(ctor, _) ->
65− let (_, _, _, fields) = lookupConstructor env (Qualified (Just mn) ctor)
66− in NonRec (properToIdent ctor) $ Constructor (ss, com, Nothing, Nothing) tyName ctor fields
67− declToCoreFn ss _ (A.DataBindingGroupDeclaration ds) = concatMap (declToCoreFn ss []) ds
68− declToCoreFn ss com (A.ValueDeclaration name _ _ (Right e)) =
69− [NonRec name (exprToCoreFn ss com Nothing e)]
70− declToCoreFn ss _ (A.BindingGroupDeclaration ds) =
71− [Rec $ map (\(name, _, e) -> (name, exprToCoreFn ss [] Nothing e)) ds]
72− declToCoreFn ss com (A.TypeClassDeclaration name _ supers members) =
73− [NonRec (properToIdent name) $ mkTypeClassConstructor ss com supers members]
74− declToCoreFn _ com (A.PositionedDeclaration ss com1 d) =
75− declToCoreFn (Just ss) (com ++ com1) d
76− declToCoreFn _ _ _ = []
77−
78− -- |
79− -- Desugars expressions from AST to CoreFn representation.
80− --
81− exprToCoreFn :: Maybe SourceSpan -> [Comment] -> Maybe Type -> A.Expr -> Expr Ann
82− exprToCoreFn ss com ty (A.NumericLiteral v) =
83− Literal (ss, com, ty, Nothing) (NumericLiteral v)
84− exprToCoreFn ss com ty (A.StringLiteral v) =
85− Literal (ss, com, ty, Nothing) (StringLiteral v)
86− exprToCoreFn ss com ty (A.BooleanLiteral v) =
87− Literal (ss, com, ty, Nothing) (BooleanLiteral v)
88− exprToCoreFn ss com ty (A.ArrayLiteral vs) =
89− Literal (ss, com, ty, Nothing) (ArrayLiteral $ map (exprToCoreFn ss [] Nothing) vs)
90− exprToCoreFn ss com ty (A.ObjectLiteral vs) =
91− Literal (ss, com, ty, Nothing) (ObjectLiteral $ map (second (exprToCoreFn ss [] Nothing)) vs)
92− exprToCoreFn ss com ty (A.Accessor name v) =
93− Accessor (ss, com, ty, Nothing) name (exprToCoreFn ss [] Nothing v)
94− exprToCoreFn ss com ty (A.ObjectUpdate obj vs) =
95− ObjectUpdate (ss, com, ty, Nothing) (exprToCoreFn ss [] Nothing obj) $ map (second (exprToCoreFn ss [] Nothing)) vs
96− exprToCoreFn ss com ty (A.Abs (Left name) v) =
97− Abs (ss, com, ty, Nothing) name (exprToCoreFn ss [] Nothing v)
98− exprToCoreFn _ _ _ (A.Abs _ _) =
99− error "Abs with Binder argument was not desugared before exprToCoreFn mn"
100− exprToCoreFn ss com ty (A.App v1 v2) =
101− App (ss, com, ty, Nothing) (exprToCoreFn ss [] Nothing v1) (exprToCoreFn ss [] Nothing v2)
102− exprToCoreFn ss com ty (A.Var ident) =
103− Var (ss, com, ty, Nothing) ident
104− exprToCoreFn ss com ty (A.IfThenElse v1 v2 v3) =
105− Case (ss, com, ty, Nothing) [exprToCoreFn ss [] Nothing v1]
106− [ CaseAlternative [LiteralBinder nullAnn $ BooleanLiteral True]
107− (Right $ exprToCoreFn Nothing [] Nothing v2)
108− , CaseAlternative [LiteralBinder nullAnn $ BooleanLiteral False]
109− (Right $ exprToCoreFn Nothing [] Nothing v3) ]
110− exprToCoreFn ss com ty (A.Constructor name) =
111− Var (ss, com, ty, Just $ getConstructorMeta name) $ fmap properToIdent name
112− exprToCoreFn ss com ty (A.Case vs alts) =
113− Case (ss, com, ty, Nothing) (map (exprToCoreFn ss [] Nothing) vs) (map (altToCoreFn ss) alts)
114− exprToCoreFn ss com _ (A.TypedValue _ v ty) =
115− exprToCoreFn ss com (Just ty) v
116− exprToCoreFn ss com ty (A.Let ds v) =
117− Let (ss, com, ty, Nothing) (concatMap (declToCoreFn ss []) ds) (exprToCoreFn ss [] Nothing v)
118− exprToCoreFn ss com _ (A.TypeClassDictionaryConstructorApp name (A.TypedValue _ (A.ObjectLiteral vs) _)) =
119− let args = map (exprToCoreFn ss [] Nothing . snd) $ sortBy (compare `on` fst) vs
120− ctor = Var (ss, [], Nothing, Just IsTypeClassConstructor) (fmap properToIdent name)
121− in foldl (App (ss, com, Nothing, Nothing)) ctor args
122− exprToCoreFn ss com ty (A.TypeClassDictionaryAccessor _ ident) =
123− Abs (ss, com, ty, Nothing) (Ident "dict")
124− (Accessor nullAnn (runIdent ident) (Var nullAnn $ Qualified Nothing (Ident "dict")))
125− exprToCoreFn _ com ty (A.PositionedValue ss com1 v) =
126− exprToCoreFn (Just ss) (com ++ com1) ty v
127− exprToCoreFn _ _ _ e =
128− error $ "Unexpected value in exprToCoreFn mn: " ++ show e
129−
130− -- |
131− -- Desugars case alternatives from AST to CoreFn representation.
132− --
133− altToCoreFn :: Maybe SourceSpan -> A.CaseAlternative -> CaseAlternative Ann
134− altToCoreFn ss (A.CaseAlternative bs vs) = CaseAlternative (map (binderToCoreFn ss []) bs) (go vs)
135− where
136− go :: Either [(A.Guard, A.Expr)] A.Expr -> Either [(Guard Ann, Expr Ann)] (Expr Ann)
137− go (Left ges) = Left $ map (exprToCoreFn ss [] Nothing *** exprToCoreFn ss [] Nothing) ges
138− go (Right e) = Right (exprToCoreFn ss [] Nothing e)
139−
140− -- |
141− -- Desugars case binders from AST to CoreFn representation.
142− --
143− binderToCoreFn :: Maybe SourceSpan -> [Comment] -> A.Binder -> Binder Ann
144− binderToCoreFn ss com (A.NullBinder) =
145− NullBinder (ss, com, Nothing, Nothing)
146− binderToCoreFn ss com (A.BooleanBinder b) =
147− LiteralBinder (ss, com, Nothing, Nothing) (BooleanLiteral b)
148− binderToCoreFn ss com (A.StringBinder s) =
149− LiteralBinder (ss, com, Nothing, Nothing) (StringLiteral s)
150− binderToCoreFn ss com (A.NumberBinder n) =
151− LiteralBinder (ss, com, Nothing, Nothing) (NumericLiteral n)
152− binderToCoreFn ss com (A.VarBinder name) =
153− VarBinder (ss, com, Nothing, Nothing) name
154− binderToCoreFn ss com (A.ConstructorBinder dctor@(Qualified mn' _) bs) =
155− let (_, tctor, _, _) = lookupConstructor env dctor
156− in ConstructorBinder (ss, com, Nothing, Just $ getConstructorMeta dctor) (Qualified mn' tctor) dctor (map (binderToCoreFn ss []) bs)
157− binderToCoreFn ss com (A.ObjectBinder bs) =
158− LiteralBinder (ss, com, Nothing, Nothing) (ObjectLiteral $ map (second (binderToCoreFn ss [])) bs)
159− binderToCoreFn ss com (A.ArrayBinder bs) =
160− LiteralBinder (ss, com, Nothing, Nothing) (ArrayLiteral $ map (binderToCoreFn ss []) bs)
161− binderToCoreFn ss com (A.ConsBinder b1 b2) =
162− let arrCtor = Qualified (Just $ ModuleName [ProperName "Prim"]) (ProperName "Array")
163− in ConstructorBinder (ss, com, Nothing, Nothing) arrCtor arrCtor $ map (binderToCoreFn ss []) [b1, b2]
164− binderToCoreFn ss com (A.NamedBinder name b) =
165− NamedBinder (ss, com, Nothing, Nothing) name (binderToCoreFn ss [] b)
166− binderToCoreFn _ com (A.PositionedBinder ss com1 b) =
167− binderToCoreFn (Just ss) (com ++ com1) b
168−
169− -- |
170− -- Gets metadata for data constructors.
171− --
172− getConstructorMeta :: Qualified ProperName -> Meta
173− getConstructorMeta ctor =
174− case lookupConstructor env ctor of
175− (Newtype, _, _, _) -> IsNewtype
176− dc@(Data, _, _, fields) ->
177− let constructorType = if numConstructors (ctor, dc) == 1 then ProductType else SumType
178− in IsConstructor constructorType fields
179− where
180− numConstructors :: (Qualified ProperName, (DataDeclType, ProperName, Type, [Ident])) -> Int
181− numConstructors ty = length $ filter (((==) `on` typeConstructor) ty) $ M.toList $ dataConstructors env
182− typeConstructor :: (Qualified ProperName, (DataDeclType, ProperName, Type, [Ident])) -> (ModuleName, ProperName)
183− typeConstructor (Qualified (Just mn') _, (_, tyCtor, _, _)) = (mn', tyCtor)
184− typeConstructor _ = error "Invalid argument to typeConstructor"
185−
186−-- |
187−-- Find module names from qualified references to values. This is used to
188−-- ensure instances are imported from any module that is referenced by the
189−-- current module, not just from those that are imported explicitly (#667).
190−--
191−findQualModules :: [A.Declaration] -> [ModuleName]
192−findQualModules decls =
193− let (f, _, _, _, _) = everythingOnValues (++) (const []) fqValues fqBinders (const []) (const [])
194− in f `concatMap` decls
195− where
196− fqValues :: A.Expr -> [ModuleName]
197− fqValues (A.Var (Qualified (Just mn) _)) = [mn]
198− fqValues (A.Constructor (Qualified (Just mn) _)) = [mn]
199− fqValues _ = []
200−
201− fqBinders :: A.Binder -> [ModuleName]
202− fqBinders (A.ConstructorBinder (Qualified (Just mn) _) _) = [mn]
203− fqBinders _ = []
204−
205−-- |
206−-- Desugars import declarations from AST to CoreFn representation.
207−--
208−importToCoreFn :: A.Declaration -> Maybe ModuleName
209−importToCoreFn (A.ImportDeclaration name _ _) = Just name
210−importToCoreFn (A.PositionedDeclaration _ _ d) = importToCoreFn d
211−importToCoreFn _ = Nothing
212−
213−-- |
214−-- Desugars foreign declarations from AST to CoreFn representation.
215−--
216−externToCoreFn :: A.Declaration -> Maybe ForeignDecl
217−externToCoreFn (A.ExternDeclaration _ name js ty) = Just (name, js, ty)
218−externToCoreFn (A.ExternInstanceDeclaration name _ _ _) = Just (name, Nothing, tyObject)
219−externToCoreFn (A.PositionedDeclaration _ _ d) = externToCoreFn d
220−externToCoreFn _ = Nothing
221−
222−-- |
223−-- Desugars export declarations references from AST to CoreFn representation.
224−-- CoreFn modules only export values, so all data constructors, class
225−-- constructor, instances and values are flattened into one list.
226−--
227−exportToCoreFn :: A.DeclarationRef -> [Ident]
228−exportToCoreFn (A.TypeRef _ (Just dctors)) = map properToIdent dctors
229−exportToCoreFn (A.ValueRef name) = [name]
230−exportToCoreFn (A.TypeClassRef name) = [properToIdent name]
231−exportToCoreFn (A.TypeInstanceRef name) = [name]
232−exportToCoreFn (A.PositionedDeclarationRef _ _ d) = exportToCoreFn d
233−exportToCoreFn _ = []
234−
235−-- |
236−-- Makes a typeclass dictionary constructor function. The returned expression
237−-- is a function that accepts the superclass instances and member
238−-- implementations and returns a record for the instance dictionary.
239−--
240−mkTypeClassConstructor :: Maybe SourceSpan -> [Comment] -> [Constraint] -> [A.Declaration] -> Expr Ann
241−mkTypeClassConstructor ss com [] [] = Literal (ss, com, Nothing, Just IsTypeClassConstructor) (ObjectLiteral [])
242−mkTypeClassConstructor ss com supers members =
243− let args@(a:as) = sort $ map typeClassMemberName members ++ superClassDictionaryNames supers
244− props = [ (arg, Var nullAnn $ Qualified Nothing (Ident arg)) | arg <- args ]
245− dict = Literal nullAnn (ObjectLiteral props)
246− in Abs (ss, com, Nothing, Just IsTypeClassConstructor)
247− (Ident a)
248− (foldr (Abs nullAnn . Ident) dict as)
249−
250−-- |
251−-- Converts a ProperName to an Ident.
252−--
253−properToIdent :: ProperName -> Ident
254−properToIdent = Ident . runProperName
src/Language/PureScript/CoreFn/Expr.hsdeleted−134
@@ -1,134 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.CoreFn.Expr
4−-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- | The core functional representation
12−--
13−-----------------------------------------------------------------------------
14−
15−{-# LANGUAGE DeriveDataTypeable #-}
16−{-# LANGUAGE DeriveFunctor #-}
17−
18−module Language.PureScript.CoreFn.Expr where
19−
20−import Control.Arrow ((***))
21−
22−import qualified Data.Data as D
23−
24−import Language.PureScript.CoreFn.Binders
25−import Language.PureScript.CoreFn.Literals
26−import Language.PureScript.Names
27−
28−-- |
29−-- Data type for expressions and terms
30−--
31−data Expr a
32− -- |
33− -- A literal value
34− --
35− = Literal a (Literal (Expr a))
36− -- |
37− -- A data constructor (type name, constructor name, field names)
38− --
39− | Constructor a ProperName ProperName [Ident]
40− -- |
41− -- A record property accessor
42− --
43− | Accessor a String (Expr a)
44− -- |
45− -- Partial record update
46− --
47− | ObjectUpdate a (Expr a) [(String, Expr a)]
48− -- |
49− -- Function introduction
50− --
51− | Abs a Ident (Expr a)
52− -- |
53− -- Function application
54− --
55− | App a (Expr a) (Expr a)
56− -- |
57− -- Variable
58− --
59− | Var a (Qualified Ident)
60− -- |
61− -- A case expression
62− --
63− | Case a [Expr a] [CaseAlternative a]
64− -- |
65− -- A let binding
66− --
67− | Let a [Bind a] (Expr a) deriving (Show, D.Data, D.Typeable, Functor)
68−
69−-- |
70−-- A let or module binding.
71−--
72−data Bind a
73− -- |
74− -- Non-recursive binding for a single value
75− --
76− = NonRec Ident (Expr a)
77− -- |
78− -- Mutually recursive binding group for several values
79− --
80− | Rec [(Ident, Expr a)] deriving (Show, D.Data, D.Typeable, Functor)
81−
82−-- |
83−-- A guard is just a boolean-valued expression that appears alongside a set of binders
84−--
85−type Guard a = Expr a
86−
87−-- |
88−-- An alternative in a case statement
89−--
90−data CaseAlternative a = CaseAlternative
91− { -- |
92− -- A collection of binders with which to match the inputs
93− --
94− caseAlternativeBinders :: [Binder a]
95− -- |
96− -- The result expression or a collect of guarded expressions
97− --
98− , caseAlternativeResult :: Either [(Guard a, Expr a)] (Expr a)
99− } deriving (Show, D.Data, D.Typeable)
100−
101−instance Functor CaseAlternative where
102−
103− fmap f (CaseAlternative cabs car) = CaseAlternative
104− (fmap (fmap f) $ cabs)
105− (either (Left . fmap (fmap f *** fmap f)) (Right . fmap f) car)
106−
107−-- |
108−-- Extract the annotation from a term
109−--
110−extractAnn :: Expr a -> a
111−extractAnn (Literal a _) = a
112−extractAnn (Constructor a _ _ _) = a
113−extractAnn (Accessor a _ _) = a
114−extractAnn (ObjectUpdate a _ _) = a
115−extractAnn (Abs a _ _) = a
116−extractAnn (App a _ _) = a
117−extractAnn (Var a _) = a
118−extractAnn (Case a _ _) = a
119−extractAnn (Let a _ _) = a
120−
121−
122−-- |
123−-- Modify the annotation on a term
124−--
125−modifyAnn :: (a -> a) -> Expr a -> Expr a
126−modifyAnn f (Literal a b) = Literal (f a) b
127−modifyAnn f (Constructor a b c d) = Constructor (f a) b c d
128−modifyAnn f (Accessor a b c) = Accessor (f a) b c
129−modifyAnn f (ObjectUpdate a b c) = ObjectUpdate (f a) b c
130−modifyAnn f (Abs a b c) = Abs (f a) b c
131−modifyAnn f (App a b c) = App (f a) b c
132−modifyAnn f (Var a b) = Var (f a) b
133−modifyAnn f (Case a b c) = Case (f a) b c
134−modifyAnn f (Let a b c) = Let (f a) b c
src/Language/PureScript/CoreFn/Literals.hsdeleted−46
@@ -1,46 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.CoreFn.Literals
4−-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- | The core functional representation for literal values.
12−--
13−-----------------------------------------------------------------------------
14−
15−{-# LANGUAGE DeriveDataTypeable #-}
16−{-# LANGUAGE DeriveFunctor #-}
17−
18−module Language.PureScript.CoreFn.Literals where
19−
20−import qualified Data.Data as D
21−
22−-- |
23−-- Data type for literal values. Parameterised so it can be used for Exprs and
24−-- Binders.
25−--
26−data Literal a
27− -- |
28− -- A numeric literal
29− --
30− = NumericLiteral (Either Integer Double)
31− -- |
32− -- A string literal
33− --
34− | StringLiteral String
35− -- |
36− -- A boolean literal
37− --
38− | BooleanLiteral Bool
39− -- |
40− -- An array literal
41− --
42− | ArrayLiteral [a]
43− -- |
44− -- An object literal
45− --
46− | ObjectLiteral [(String, a)] deriving (Show, D.Data, D.Typeable, Functor)
src/Language/PureScript/CoreFn/Meta.hsdeleted−51
@@ -1,51 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.CoreFn.Meta
4−-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- | Metadata annotations for core functional representation
12−--
13−-----------------------------------------------------------------------------
14−
15−{-# LANGUAGE DeriveDataTypeable #-}
16−
17−module Language.PureScript.CoreFn.Meta where
18−
19−import qualified Data.Data as D
20−
21−import Language.PureScript.Names
22−
23−-- |
24−-- Metadata annotations
25−--
26−data Meta
27− -- |
28− -- The contained value is a data constructor
29− --
30− = IsConstructor ConstructorType [Ident]
31− -- |
32− -- The contained value is a newtype
33− --
34− | IsNewtype
35− -- |
36− -- The contained value is a typeclass dictionary constructor
37− --
38− | IsTypeClassConstructor deriving (Show, D.Data, D.Typeable)
39−
40−-- |
41−-- Data constructor metadata
42−--
43−data ConstructorType
44− -- |
45− -- The constructor is for a type with a single construcor
46− --
47− = ProductType
48− -- |
49− -- The constructor is for a type with multiple construcors
50− --
51− | SumType deriving (Show, D.Data, D.Typeable)
src/Language/PureScript/CoreFn/Module.hsdeleted−32
@@ -1,32 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.CoreFn.Module
4−-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- | The CoreFn module representation
12−--
13−-----------------------------------------------------------------------------
14−
15−module Language.PureScript.CoreFn.Module where
16−
17−import Language.PureScript.CodeGen.JS.AST
18−import Language.PureScript.Comments
19−import Language.PureScript.CoreFn.Expr
20−import Language.PureScript.Names
21−import Language.PureScript.Types
22−
23−data Module a = Module
24− { moduleComments :: [Comment]
25− , moduleName :: ModuleName
26− , moduleImports :: [ModuleName]
27− , moduleExports :: [Ident]
28− , moduleForeign :: [ForeignDecl]
29− , moduleDecls :: [Bind a]
30− } deriving (Show)
31−
32−type ForeignDecl = (Ident, Maybe JS, Type)
src/Language/PureScript/CoreFn/Traversals.hsdeleted−85
@@ -1,85 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.CoreFn.Traversals
4−-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- | CoreFn traversal helpers
12−--
13−-----------------------------------------------------------------------------
14−
15−module Language.PureScript.CoreFn.Traversals where
16−
17−import Control.Arrow (second, (***), (+++))
18−
19−import Language.PureScript.CoreFn.Binders
20−import Language.PureScript.CoreFn.Expr
21−import Language.PureScript.CoreFn.Literals
22−
23−everywhereOnValues :: (Bind a -> Bind a) ->
24− (Expr a -> Expr a) ->
25− (Binder a -> Binder a) ->
26− (Bind a -> Bind a, Expr a -> Expr a, Binder a -> Binder a)
27−everywhereOnValues f g h = (f', g', h')
28− where
29− f' (NonRec name e) = f (NonRec name (g' e))
30− f' (Rec es) = f (Rec (map (second g') es))
31−
32− g' (Literal ann e) = g (Literal ann (handleLiteral g' e))
33− g' (Accessor ann prop e) = g (Accessor ann prop (g' e))
34− g' (ObjectUpdate ann obj vs) = g (ObjectUpdate ann (g' obj) (map (fmap g') vs))
35− g' (Abs ann name e) = g (Abs ann name (g' e))
36− g' (App ann v1 v2) = g (App ann (g' v1) (g' v2))
37− g' (Case ann vs alts) = g (Case ann (map g' vs) (map handleCaseAlternative alts))
38− g' (Let ann ds e) = g (Let ann (map f' ds) (g' e))
39− g' e = g e
40−
41− h' (LiteralBinder a b) = h (LiteralBinder a (handleLiteral h' b))
42− h' (NamedBinder a name b) = h (NamedBinder a name (h' b))
43− h' b = h b
44−
45− handleCaseAlternative ca =
46− ca { caseAlternativeBinders = map h' (caseAlternativeBinders ca)
47− , caseAlternativeResult = (map (g' *** g') +++ g') (caseAlternativeResult ca)
48− }
49−
50− handleLiteral :: (a -> a) -> Literal a -> Literal a
51− handleLiteral i (ArrayLiteral ls) = ArrayLiteral (map i ls)
52− handleLiteral i (ObjectLiteral ls) = ObjectLiteral (map (fmap i) ls)
53− handleLiteral _ other = other
54−
55−everythingOnValues :: (r -> r -> r) ->
56− (Bind a -> r) ->
57− (Expr a -> r) ->
58− (Binder a -> r) ->
59− (CaseAlternative a -> r) ->
60− (Bind a -> r, Expr a -> r, Binder a -> r, CaseAlternative a -> r)
61−everythingOnValues (<>) f g h i = (f', g', h', i')
62− where
63− f' b@(NonRec _ e) = f b <> g' e
64− f' b@(Rec es) = foldl (<>) (f b) (map (g' . snd) es)
65−
66− g' v@(Literal _ l) = foldl (<>) (g v) (map g' (extractLiteral l))
67− g' v@(Accessor _ _ e1) = g v <> g' e1
68− g' v@(ObjectUpdate _ obj vs) = foldl (<>) (g v <> g' obj) (map (g' . snd) vs)
69− g' v@(Abs _ _ e1) = g v <> g' e1
70− g' v@(App _ e1 e2) = g v <> g' e1 <> g' e2
71− g' v@(Case _ vs alts) = foldl (<>) (foldl (<>) (g v) (map g' vs)) (map i' alts)
72− g' v@(Let _ ds e1) = foldl (<>) (g v) (map f' ds) <> g' e1
73− g' v = g v
74−
75− h' b@(LiteralBinder _ l) = foldl (<>) (h b) (map h' (extractLiteral l))
76− h' b@(ConstructorBinder _ _ _ bs) = foldl (<>) (h b) (map h' bs)
77− h' b@(NamedBinder _ _ b1) = h b <> h' b1
78− h' b = h b
79−
80− i' ca@(CaseAlternative bs (Right val)) = foldl (<>) (i ca) (map h' bs) <> g' val
81− i' ca@(CaseAlternative bs (Left gs)) = foldl (<>) (i ca) (map h' bs ++ concatMap (\(grd, val) -> [g' grd, g' val]) gs)
82−
83− extractLiteral (ArrayLiteral xs) = xs
84− extractLiteral (ObjectLiteral xs) = map snd xs
85− extractLiteral _ = []
src/Language/PureScript/DeadCodeElimination.hsdeleted−102
@@ -1,102 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.DeadCodeElimination
4−-- Copyright : (c) 2014 Phil Freeman
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- | Dead code elimination.
12−--
13−-----------------------------------------------------------------------------
14−
15−module Language.PureScript.DeadCodeElimination (
16− eliminateDeadCode
17−) where
18−
19−import Data.Graph
20−import Data.List
21−import Data.Maybe (mapMaybe)
22−
23−import Language.PureScript.CoreFn
24−import Language.PureScript.Names
25−
26−-- |
27−-- Eliminate all declarations which are not a transitive dependency of the entry point module
28−--
29−eliminateDeadCode :: [ModuleName] -> [Module a] -> [Module a]
30−eliminateDeadCode entryPoints ms = map go ms
31− where
32− go (Module coms mn imps exps foreigns ds) = Module coms mn imps exps' foreigns' ds'
33− where
34− ds' = filter (isUsed mn graph vertexFor entryPointVertices) ds
35− foreigns' = filter (isUsed' mn graph vertexFor entryPointVertices . foreignIdent) foreigns
36− names = concatMap bindIdents ds' ++ map foreignIdent foreigns'
37− exps' = filter (`elem` names) exps
38− declarations = concatMap declarationsByModule ms
39− (graph, _, vertexFor) = graphFromEdges $ map (\(key, deps) -> (key, key, deps)) declarations
40− entryPointVertices = mapMaybe (vertexFor . fst) . filter (\((mn, _), _) -> mn `elem` entryPoints) $ declarations
41−
42−-- |
43−-- Extract declaration names for a binding group.
44−--
45−bindIdents :: Bind a -> [Ident]
46−bindIdents (NonRec name _) = [name]
47−bindIdents (Rec names) = map fst names
48−
49−-- |
50−-- Extract the ident for a foreign declaration.
51−--
52−foreignIdent :: ForeignDecl -> Ident
53−foreignIdent (name, _, _) = name
54−
55−-- |
56−-- Key type to use in graph
57−--
58−type Key = (ModuleName, Ident)
59−
60−-- |
61−-- Find dependencies for each member in a module.
62−--
63−declarationsByModule :: Module a -> [(Key, [Key])]
64−declarationsByModule (Module _ mn _ _ fs ds) =
65− let fs' = map ((\name -> ((mn, name), [])) . foreignIdent) fs
66− in fs' ++ concatMap go ds
67− where
68− go :: Bind a -> [(Key, [Key])]
69− go d@(NonRec name _) = [((mn, name), dependencies d)]
70− go d@(Rec names') = map (\(name, _) -> ((mn, name), dependencies d)) names'
71−
72−-- |
73−-- Find all referenced values within a binding group.
74−--
75−dependencies :: Bind a -> [Key]
76−dependencies =
77− let (f, _, _, _) = everythingOnValues (++) (const []) values binders (const [])
78− in nub . f
79− where
80− values :: Expr a -> [Key]
81− values (Var _ (Qualified (Just mn) ident)) = [(mn, ident)]
82− values _ = []
83− binders :: Binder a -> [Key]
84− binders (ConstructorBinder _ _ (Qualified (Just mn) ident) _) = [(mn, Ident $ runProperName ident)]
85− binders _ = []
86−
87−-- |
88−-- Check whether a binding group is used.
89−--
90−isUsed :: ModuleName -> Graph -> (Key -> Maybe Vertex) -> [Vertex] -> Bind a -> Bool
91−isUsed mn graph vertexFor entryPointVertices (NonRec name _) =
92− isUsed' mn graph vertexFor entryPointVertices name
93−isUsed mn graph vertexFor entryPointVertices (Rec ds) =
94− any (isUsed' mn graph vertexFor entryPointVertices . fst) ds
95−
96−-- |
97−-- Check whether a named declaration is used.
98−--
99−isUsed' :: ModuleName -> Graph -> (Key -> Maybe Vertex) -> [Vertex] -> Ident -> Bool
100−isUsed' mn graph vertexFor entryPointVertices name =
101− let Just v' = vertexFor (mn, name)
102− in any (\v -> path graph v v') entryPointVertices
src/Language/PureScript/Environment.hsdeleted−241
@@ -1,241 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.Environment
4−-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- |
12−--
13−-----------------------------------------------------------------------------
14−
15−{-# LANGUAGE DeriveDataTypeable #-}
16−
17−module Language.PureScript.Environment where
18−
19−import Data.Data
20−import Data.Maybe (fromMaybe)
21−import qualified Data.Map as M
22−
23−import Language.PureScript.Kinds
24−import Language.PureScript.Names
25−import Language.PureScript.TypeClassDictionaries
26−import Language.PureScript.Types
27−import qualified Language.PureScript.Constants as C
28−
29−-- |
30−-- The @Environment@ defines all values and types which are currently in scope:
31−--
32−data Environment = Environment {
33− -- |
34− -- Value names currently in scope
35− --
36− names :: M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility)
37− -- |
38− -- Type names currently in scope
39− --
40− , types :: M.Map (Qualified ProperName) (Kind, TypeKind)
41− -- |
42− -- Data constructors currently in scope, along with their associated data type constructors
43− --
44− , dataConstructors :: M.Map (Qualified ProperName) (DataDeclType, ProperName, Type, [Ident])
45− -- |
46− -- Type synonyms currently in scope
47− --
48− , typeSynonyms :: M.Map (Qualified ProperName) ([(String, Maybe Kind)], Type)
49− -- |
50− -- Available type class dictionaries
51− --
52− , typeClassDictionaries :: M.Map (Qualified Ident, Maybe ModuleName) TypeClassDictionaryInScope
53− -- |
54− -- Type classes
55− --
56− , typeClasses :: M.Map (Qualified ProperName) ([(String, Maybe Kind)], [(Ident, Type)], [Constraint])
57− } deriving (Show)
58−
59−-- |
60−-- The initial environment with no values and only the default javascript types defined
61−--
62−initEnvironment :: Environment
63−initEnvironment = Environment M.empty primTypes M.empty M.empty M.empty M.empty
64−
65−-- |
66−-- The type of a foreign import
67−--
68−data ForeignImportType
69− -- |
70− -- A regular foreign import
71− --
72− = ForeignImport
73− -- |
74− -- A foreign import which contains inline Javascript as a string literal
75− --
76− | InlineJavascript deriving (Show, Eq, Data, Typeable)
77−
78−-- |
79−-- The visibility of a name in scope
80−--
81−data NameVisibility
82− -- |
83− -- The name is defined in the current binding group, but is not visible
84− --
85− = Undefined
86− -- |
87− -- The name is defined in the another binding group, or has been made visible by a function binder
88− --
89− | Defined deriving (Show, Eq)
90−
91−-- |
92−-- The kind of a name
93−--
94−data NameKind
95− -- |
96− -- A value introduced as a binding in a module
97− --
98− = Value
99− -- |
100− -- A type class dictionary member accessor import, generated during desugaring of type class declarations
101− --
102− | TypeClassAccessorImport
103− -- |
104− -- A foreign import
105− --
106− | Extern ForeignImportType
107− -- |
108− -- A local name introduced using a lambda abstraction, variable introduction or binder
109− --
110− | LocalVariable
111− -- |
112− -- A data constructor
113− --
114− | DataConstructor
115− -- |
116− -- A type class dictionary, generated during desugaring of type class declarations
117− --
118− | TypeInstanceDictionaryValue deriving (Show, Eq, Data, Typeable)
119−
120−-- |
121−-- The kinds of a type
122−--
123−data TypeKind
124− -- |
125− -- Data type
126− --
127− = DataType [(String, Maybe Kind)] [(ProperName, [Type])]
128− -- |
129− -- Type synonym
130− --
131− | TypeSynonym
132− -- |
133− -- Foreign data
134− --
135− | ExternData
136− -- |
137− -- A local type variable
138− --
139− | LocalTypeVariable
140− -- |
141− -- A scoped type variable
142− --
143− | ScopedTypeVar
144− deriving (Show, Eq, Data, Typeable)
145−
146−-- |
147−-- The type ('data' or 'newtype') of a data type declaration
148−--
149−data DataDeclType
150− -- |
151− -- A standard data constructor
152− --
153− = Data
154− -- |
155− -- A newtype constructor
156− --
157− | Newtype deriving (Eq, Ord, Data, Typeable)
158−
159−instance Show DataDeclType where
160− show Data = "data"
161− show Newtype = "newtype"
162−
163−-- |
164−-- Construct a ProperName in the Prim module
165−--
166−primName :: String -> Qualified ProperName
167−primName = Qualified (Just $ ModuleName [ProperName C.prim]) . ProperName
168−
169−-- |
170−-- Construct a type in the Prim module
171−--
172−primTy :: String -> Type
173−primTy = TypeConstructor . primName
174−
175−-- |
176−-- Type constructor for functions
177−--
178−tyFunction :: Type
179−tyFunction = primTy "Function"
180−
181−-- |
182−-- Type constructor for strings
183−--
184−tyString :: Type
185−tyString = primTy "String"
186−
187−-- |
188−-- Type constructor for numbers
189−--
190−tyNumber :: Type
191−tyNumber = primTy "Number"
192−
193−-- |
194−-- Type constructor for booleans
195−--
196−tyBoolean :: Type
197−tyBoolean = primTy "Boolean"
198−
199−-- |
200−-- Type constructor for arrays
201−--
202−tyArray :: Type
203−tyArray = primTy "Array"
204−
205−-- |
206−-- Type constructor for objects
207−--
208−tyObject :: Type
209−tyObject = primTy "Object"
210−
211−-- |
212−-- Smart constructor for function types
213−--
214−function :: Type -> Type -> Type
215−function t1 = TypeApp (TypeApp tyFunction t1)
216−
217−-- |
218−-- The primitive types in the external javascript environment with their associated kinds.
219−--
220−primTypes :: M.Map (Qualified ProperName) (Kind, TypeKind)
221−primTypes = M.fromList [ (primName "Function" , (FunKind Star (FunKind Star Star), ExternData))
222− , (primName "Array" , (FunKind Star Star, ExternData))
223− , (primName "Object" , (FunKind (Row Star) Star, ExternData))
224− , (primName "String" , (Star, ExternData))
225− , (primName "Number" , (Star, ExternData))
226− , (primName "Boolean" , (Star, ExternData)) ]
227−
228−-- |
229−-- Finds information about data constructors from the current environment.
230−--
231−lookupConstructor :: Environment -> Qualified ProperName -> (DataDeclType, ProperName, Type, [Ident])
232−lookupConstructor env ctor =
233− fromMaybe (error "Data constructor not found") $ ctor `M.lookup` dataConstructors env
234−
235−-- |
236−-- Checks whether a data constructor is for a newtype.
237−--
238−isNewtypeConstructor :: Environment -> Qualified ProperName -> Bool
239−isNewtypeConstructor e ctor = case lookupConstructor e ctor of
240− (Newtype, _, _, _) -> True
241− (Data, _, _, _) -> False
src/Language/PureScript/Errors.hsdeleted−583
@@ -1,583 +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 #-}
16−{-# LANGUAGE FlexibleContexts #-}
17−{-# LANGUAGE MultiParamTypeClasses #-}
18−
19−module Language.PureScript.Errors where
20−
21−import Data.Either (lefts, rights)
22−import Data.List (intercalate)
23−import Data.Monoid
24−import Data.Foldable (fold, foldMap)
25−
26−import Control.Monad
27−import Control.Monad.Error.Class (MonadError(..))
28−import Control.Monad.Unify
29−import Control.Applicative ((<$>))
30−
31−import Language.PureScript.AST
32−import Language.PureScript.Pretty
33−import Language.PureScript.Types
34−import Language.PureScript.Names
35−import Language.PureScript.Kinds
36−import Language.PureScript.TypeClassDictionaries
37−
38−import qualified Text.PrettyPrint.Boxes as Box
39−
40−import qualified Text.Parsec as P
41−
42−-- |
43−-- A type of error messages
44−--
45−data ErrorMessage
46− = ErrorParsingExterns P.ParseError
47− | ErrorParsingPrelude P.ParseError
48− | InvalidExternsFile FilePath
49− | CannotGetFileInfo FilePath
50− | CannotReadFile FilePath
51− | CannotWriteFile FilePath
52− | InfiniteType Type
53− | InfiniteKind Kind
54− | CannotReorderOperators
55− | MultipleFixities Ident
56− | OrphanTypeDeclaration Ident
57− | OrphanFixityDeclaration String
58− | RedefinedModule ModuleName
59− | RedefinedIdent Ident
60− | OverlappingNamesInLet
61− | UnknownModule ModuleName
62− | UnknownType (Qualified ProperName)
63− | UnknownTypeClass (Qualified ProperName)
64− | UnknownValue (Qualified Ident)
65− | UnknownDataConstructor (Qualified ProperName) (Maybe (Qualified ProperName))
66− | UnknownTypeConstructor (Qualified ProperName)
67− | ConflictingImport String ModuleName
68− | ConflictingImports String ModuleName ModuleName
69− | ConflictingTypeDecls ProperName
70− | ConflictingCtorDecls ProperName
71− | TypeConflictsWithClass ProperName
72− | CtorConflictsWithClass ProperName
73− | ClassConflictsWithType ProperName
74− | ClassConflictsWithCtor ProperName
75− | DuplicateClassExport ProperName
76− | DuplicateValueExport Ident
77− | DuplicateTypeArgument String
78− | InvalidDoBind
79− | InvalidDoLet
80− | CycleInDeclaration Ident
81− | CycleInTypeSynonym (Maybe ProperName)
82− | CycleInModules [ModuleName]
83− | NameIsUndefined Ident
84− | NameNotInScope Ident
85− | UndefinedTypeVariable ProperName
86− | PartiallyAppliedSynonym (Qualified ProperName)
87− | NotYetDefined [Ident] ErrorMessage
88− | EscapedSkolem (Maybe Expr)
89− | UnspecifiedSkolemScope
90− | TypesDoNotUnify Type Type
91− | KindsDoNotUnify Kind Kind
92− | ConstrainedTypeUnified Type Type
93− | OverlappingInstances (Qualified ProperName) [Type] [DictionaryValue]
94− | NoInstanceFound (Qualified ProperName) [Type]
95− | DuplicateLabel String (Maybe Expr)
96− | DuplicateValueDeclaration Ident
97− | ArgListLengthsDiffer Ident
98− | OverlappingArgNames (Maybe Ident)
99− | MissingClassMember Ident
100− | ExpectedType Kind
101− | IncorrectConstructorArity (Qualified ProperName)
102− | SubsumptionCheckFailed
103− | ExprDoesNotHaveType Expr Type
104− | PropertyIsMissing String Type
105− | ErrorUnifyingTypes Type Type ErrorMessage
106− | CannotApplyFunction Type Expr
107− | TypeSynonymInstance
108− | InvalidNewtype
109− | InvalidInstanceHead Type
110− | TransitiveExportError DeclarationRef [DeclarationRef]
111− | ShadowedName Ident
112− | PreludeNotPresent
113− | ErrorInExpression Expr ErrorMessage
114− | ErrorInModule ModuleName ErrorMessage
115− | ErrorInInstance (Qualified ProperName) [Type] ErrorMessage
116− | ErrorInSubsumption Type Type ErrorMessage
117− | ErrorCheckingType Expr Type ErrorMessage
118− | ErrorCheckingKind Type ErrorMessage
119− | ErrorInferringType Expr ErrorMessage
120− | ErrorInApplication Expr Type Expr ErrorMessage
121− | ErrorInDataConstructor ProperName ErrorMessage
122− | ErrorInTypeConstructor ProperName ErrorMessage
123− | ErrorInBindingGroup [Ident] ErrorMessage
124− | ErrorInDataBindingGroup ErrorMessage
125− | ErrorInTypeSynonym ProperName ErrorMessage
126− | ErrorInValueDeclaration Ident ErrorMessage
127− | ErrorInForeignImport Ident ErrorMessage
128− | PositionedError SourceSpan ErrorMessage
129− deriving (Show)
130−
131−instance UnificationError Type ErrorMessage where
132− occursCheckFailed = InfiniteType
133−
134−instance UnificationError Kind ErrorMessage where
135− occursCheckFailed = InfiniteKind
136−
137−-- |
138−-- Get the error code for a particular error type
139−--
140−errorCode :: ErrorMessage -> String
141−errorCode (ErrorParsingExterns _) = "ErrorParsingExterns"
142−errorCode (ErrorParsingPrelude _) = "ErrorParsingPrelude"
143−errorCode (InvalidExternsFile _) = "InvalidExternsFile"
144−errorCode (CannotGetFileInfo _) = "CannotGetFileInfo"
145−errorCode (CannotReadFile _) = "CannotReadFile"
146−errorCode (CannotWriteFile _) = "CannotWriteFile"
147−errorCode (InfiniteType _) = "InfiniteType"
148−errorCode (InfiniteKind _) = "InfiniteKind"
149−errorCode CannotReorderOperators = "CannotReorderOperators"
150−errorCode (MultipleFixities _) = "MultipleFixities"
151−errorCode (OrphanTypeDeclaration _) = "OrphanTypeDeclaration"
152−errorCode (OrphanFixityDeclaration _) = "OrphanFixityDeclaration"
153−errorCode (RedefinedModule _) = "RedefinedModule"
154−errorCode (RedefinedIdent _) = "RedefinedIdent"
155−errorCode OverlappingNamesInLet = "OverlappingNamesInLet"
156−errorCode (UnknownModule _) = "UnknownModule"
157−errorCode (UnknownType _) = "UnknownType"
158−errorCode (UnknownTypeClass _) = "UnknownTypeClass"
159−errorCode (UnknownValue _) = "UnknownValue"
160−errorCode (UnknownDataConstructor _ _) = "UnknownDataConstructor"
161−errorCode (UnknownTypeConstructor _) = "UnknownTypeConstructor"
162−errorCode (ConflictingImport _ _) = "ConflictingImport"
163−errorCode (ConflictingImports _ _ _) = "ConflictingImports"
164−errorCode (ConflictingTypeDecls _) = "ConflictingTypeDecls"
165−errorCode (ConflictingCtorDecls _) = "ConflictingCtorDecls"
166−errorCode (TypeConflictsWithClass _) = "TypeConflictsWithClass"
167−errorCode (CtorConflictsWithClass _) = "CtorConflictsWithClass"
168−errorCode (ClassConflictsWithType _) = "ClassConflictsWithType"
169−errorCode (ClassConflictsWithCtor _) = "ClassConflictsWithCtor"
170−errorCode (DuplicateClassExport _) = "DuplicateClassExport"
171−errorCode (DuplicateValueExport _) = "DuplicateValueExport"
172−errorCode (DuplicateTypeArgument _) = "DuplicateTypeArgument"
173−errorCode InvalidDoBind = "InvalidDoBind"
174−errorCode InvalidDoLet = "InvalidDoLet"
175−errorCode (CycleInDeclaration _) = "CycleInDeclaration"
176−errorCode (CycleInTypeSynonym _) = "CycleInTypeSynonym"
177−errorCode (CycleInModules _) = "CycleInModules"
178−errorCode (NameIsUndefined _) = "NameIsUndefined"
179−errorCode (NameNotInScope _) = "NameNotInScope"
180−errorCode (UndefinedTypeVariable _) = "UndefinedTypeVariable"
181−errorCode (PartiallyAppliedSynonym _) = "PartiallyAppliedSynonym"
182−errorCode (EscapedSkolem _) = "EscapedSkolem"
183−errorCode UnspecifiedSkolemScope = "UnspecifiedSkolemScope"
184−errorCode (TypesDoNotUnify _ _) = "TypesDoNotUnify"
185−errorCode (KindsDoNotUnify _ _) = "KindsDoNotUnify"
186−errorCode (ConstrainedTypeUnified _ _) = "ConstrainedTypeUnified"
187−errorCode (OverlappingInstances _ _ _) = "OverlappingInstances"
188−errorCode (NoInstanceFound _ _) = "NoInstanceFound"
189−errorCode (DuplicateLabel _ _) = "DuplicateLabel"
190−errorCode (DuplicateValueDeclaration _) = "DuplicateValueDeclaration"
191−errorCode (ArgListLengthsDiffer _) = "ArgListLengthsDiffer"
192−errorCode (OverlappingArgNames _) = "OverlappingArgNames"
193−errorCode (MissingClassMember _) = "MissingClassMember"
194−errorCode (ExpectedType _) = "ExpectedType"
195−errorCode (IncorrectConstructorArity _) = "IncorrectConstructorArity"
196−errorCode SubsumptionCheckFailed = "SubsumptionCheckFailed"
197−errorCode (ExprDoesNotHaveType _ _) = "ExprDoesNotHaveType"
198−errorCode (PropertyIsMissing _ _) = "PropertyIsMissing"
199−errorCode (CannotApplyFunction _ _) = "CannotApplyFunction"
200−errorCode TypeSynonymInstance = "TypeSynonymInstance"
201−errorCode InvalidNewtype = "InvalidNewtype"
202−errorCode (InvalidInstanceHead _) = "InvalidInstanceHead"
203−errorCode (TransitiveExportError _ _) = "TransitiveExportError"
204−errorCode (ShadowedName _) = "ShadowedName"
205−errorCode PreludeNotPresent = "PreludeNotPresent"
206−errorCode (NotYetDefined _ e) = errorCode e
207−errorCode (ErrorUnifyingTypes _ _ e) = errorCode e
208−errorCode (ErrorInExpression _ e) = errorCode e
209−errorCode (ErrorInModule _ e) = errorCode e
210−errorCode (ErrorInInstance _ _ e) = errorCode e
211−errorCode (ErrorInSubsumption _ _ e) = errorCode e
212−errorCode (ErrorCheckingType _ _ e) = errorCode e
213−errorCode (ErrorCheckingKind _ e) = errorCode e
214−errorCode (ErrorInferringType _ e) = errorCode e
215−errorCode (ErrorInApplication _ _ _ e) = errorCode e
216−errorCode (ErrorInDataConstructor _ e) = errorCode e
217−errorCode (ErrorInTypeConstructor _ e) = errorCode e
218−errorCode (ErrorInBindingGroup _ e) = errorCode e
219−errorCode (ErrorInDataBindingGroup e) = errorCode e
220−errorCode (ErrorInTypeSynonym _ e) = errorCode e
221−errorCode (ErrorInValueDeclaration _ e) = errorCode e
222−errorCode (ErrorInForeignImport _ e) = errorCode e
223−errorCode (PositionedError _ e) = errorCode e
224−
225−-- |
226−-- A stack trace for an error
227−--
228−newtype MultipleErrors = MultipleErrors
229− { runMultipleErrors :: [ErrorMessage] } deriving (Show, Monoid)
230−
231−instance UnificationError Type MultipleErrors where
232− occursCheckFailed = errorMessage . occursCheckFailed
233−
234−instance UnificationError Kind MultipleErrors where
235− occursCheckFailed = errorMessage . occursCheckFailed
236−
237−-- | Check whether a collection of errors is empty or not.
238−nonEmpty :: MultipleErrors -> Bool
239−nonEmpty = not . null . runMultipleErrors
240−
241−-- |
242−-- Create an error set from a single error message
243−--
244−errorMessage :: ErrorMessage -> MultipleErrors
245−errorMessage err = MultipleErrors [err]
246−
247−-- |
248−-- Lift a function on ErrorMessage to a function on MultipleErrors
249−--
250−onErrorMessages :: (ErrorMessage -> ErrorMessage) -> MultipleErrors -> MultipleErrors
251−onErrorMessages f = MultipleErrors . map f . runMultipleErrors
252−
253−-- |
254−-- Pretty print a single error, simplifying if necessary
255−--
256−prettyPrintSingleError :: Bool -> ErrorMessage -> Box.Box
257−prettyPrintSingleError full e = prettyPrintErrorMessage (if full then e else simplifyErrorMessage e)
258− where
259− -- |
260− -- Pretty print an ErrorMessage
261− --
262− prettyPrintErrorMessage :: ErrorMessage -> Box.Box
263− prettyPrintErrorMessage em =
264− paras
265− [ go em
266− , line ("See " ++ wikiUri ++ " for more information, or to contribute content related to this error.")
267− ]
268− where
269− wikiUri :: String
270− wikiUri = "https://github.com/purescript/purescript/wiki/Error-Code-" ++ errorCode e
271−
272− go :: ErrorMessage -> Box.Box
273− go (CannotGetFileInfo path) = paras [ line "Unable to read file info: "
274− , indent . line $ path
275− ]
276− go (CannotReadFile path) = paras [ line "Unable to read file: "
277− , indent . line $ path
278− ]
279− go (CannotWriteFile path) = paras [ line "Unable to write file: "
280− , indent . line $ path
281− ]
282− go (ErrorParsingExterns err) = paras [ line "Error parsing externs files: "
283− , indent . line . show $ err
284− ]
285− go (ErrorParsingPrelude err) = paras [ line "Error parsing prelude: "
286− , indent . line . show $ err
287− ]
288− go (InvalidExternsFile path) = paras [ line "Externs file is invalid: "
289− , indent . line $ path
290− ]
291− go InvalidDoBind = line "Bind statement cannot be the last statement in a do block"
292− go InvalidDoLet = line "Let statement cannot be the last statement in a do block"
293− go CannotReorderOperators = line "Unable to reorder operators"
294− go UnspecifiedSkolemScope = line "Skolem variable scope is unspecified"
295− go OverlappingNamesInLet = line "Overlapping names in let binding."
296− go (InfiniteType ty) = paras [ line "Infinite type detected: "
297− , indent $ line $ prettyPrintType ty
298− ]
299− go (InfiniteKind ki) = paras [ line "Infinite kind detected: "
300− , indent $ line $ prettyPrintKind ki
301− ]
302− go (MultipleFixities name) = line $ "Multiple fixity declarations for " ++ show name
303− go (OrphanTypeDeclaration nm) = line $ "Orphan type declaration for " ++ show nm
304− go (OrphanFixityDeclaration op) = line $ "Orphan fixity declaration for " ++ show op
305− go (RedefinedModule name) = line $ "Module " ++ show name ++ " has been defined multiple times"
306− go (RedefinedIdent name) = line $ "Name " ++ show name ++ " has been defined multiple times"
307− go (UnknownModule mn) = line $ "Unknown module " ++ show mn
308− go (UnknownType name) = line $ "Unknown type " ++ show name
309− go (UnknownTypeClass name) = line $ "Unknown type class " ++ show name
310− go (UnknownValue name) = line $ "Unknown value " ++ show name
311− go (UnknownTypeConstructor name) = line $ "Unknown type constructor " ++ show name
312− go (UnknownDataConstructor dc tc) = line $ "Unknown data constructor " ++ show dc ++ foldMap ((" for type constructor " ++) . show) tc
313− go (ConflictingImport nm mn) = line $ "Declaration " ++ nm ++ " conflicts with import " ++ show mn
314− go (ConflictingImports nm m1 m2) = line $ "Conflicting imports for " ++ nm ++ " from modules " ++ show m1 ++ " and " ++ show m2
315− go (ConflictingTypeDecls nm) = line $ "Conflicting type declarations for " ++ show nm
316− go (ConflictingCtorDecls nm) = line $ "Conflicting data constructor declarations for " ++ show nm
317− go (TypeConflictsWithClass nm) = line $ "Type " ++ show nm ++ " conflicts with type class declaration of the same name"
318− go (CtorConflictsWithClass nm) = line $ "Data constructor " ++ show nm ++ " conflicts with type class declaration of the same name"
319− go (ClassConflictsWithType nm) = line $ "Type class " ++ show nm ++ " conflicts with type declaration of the same name"
320− go (ClassConflictsWithCtor nm) = line $ "Type class " ++ show nm ++ " conflicts with data constructor declaration of the same name"
321− go (DuplicateClassExport nm) = line $ "Duplicate export declaration for type class " ++ show nm
322− go (DuplicateValueExport nm) = line $ "Duplicate export declaration for value " ++ show nm
323− go (CycleInDeclaration nm) = line $ "Cycle in declaration of " ++ show nm
324− go (CycleInModules mns) = line $ "Cycle in module dependencies: " ++ intercalate ", " (map show mns)
325− go (NotYetDefined names err) = paras [ line $ "The following are not yet defined here: " ++ intercalate ", " (map show names) ++ ":"
326− , indent $ go err
327− ]
328− go (CycleInTypeSynonym pn) = line $ "Cycle in type synonym" ++ foldMap ((" " ++) . show) pn
329− go (NameIsUndefined ident) = line $ show ident ++ " is undefined"
330− go (NameNotInScope ident) = line $ show ident ++ " may not be defined in the current scope"
331− go (UndefinedTypeVariable name) = line $ "Type variable " ++ show name ++ " is undefined"
332− go (PartiallyAppliedSynonym name) = line $ "Partially applied type synonym " ++ show name
333− go (EscapedSkolem binding) = paras $ [ line "Rigid/skolem type variable has escaped." ]
334− <> foldMap (\expr -> [ line "Relevant expression: "
335− , indent $ line $ prettyPrintValue expr
336− ]) binding
337− go (TypesDoNotUnify t1 t2) = paras [ line "Cannot unify type"
338− , indent $ line $ prettyPrintType t1
339− , line "with type"
340− , indent $ line $ prettyPrintType t2
341− ]
342− go (KindsDoNotUnify k1 k2) = paras [ line "Cannot unify kind"
343− , indent $ line $ prettyPrintKind k1
344− , line "with kind"
345− , indent $ line $ prettyPrintKind k2
346− ]
347− go (ConstrainedTypeUnified t1 t2) = paras [ line "Cannot unify constrained type"
348− , indent $ line $ prettyPrintType t1
349− , line "with type"
350− , indent $ line $ prettyPrintType t2
351− ]
352− go (OverlappingInstances nm ts ds) = paras [ line $ "Overlapping instances found for " ++ show nm ++ " " ++ unwords (map prettyPrintTypeAtom ts) ++ ":"
353− , paras $ map prettyPrintDictionaryValue ds
354− ]
355− go (NoInstanceFound nm ts) = line $ "No instance found for " ++ show nm ++ " " ++ unwords (map prettyPrintTypeAtom ts)
356− go (DuplicateLabel l expr) = paras $ [ line $ "Duplicate label " ++ show l ++ " in row." ]
357− <> foldMap (\expr' -> [ line "Relevant expression: "
358− , indent $ line $ prettyPrintValue expr'
359− ]) expr
360− go (DuplicateTypeArgument name) = line $ "Duplicate type argument " ++ show name
361− go (DuplicateValueDeclaration nm) = line $ "Duplicate value declaration for " ++ show nm
362− go (ArgListLengthsDiffer ident) = line $ "Argument list lengths differ in declaration " ++ show ident
363− go (OverlappingArgNames ident) = line $ "Overlapping names in function/binder" ++ foldMap ((" in declaration" ++) . show) ident
364− go (MissingClassMember ident) = line $ "Member " ++ show ident ++ " has not been implemented"
365− go (ExpectedType kind) = line $ "Expected type of kind *, was " ++ prettyPrintKind kind
366− go (IncorrectConstructorArity nm) = line $ "Wrong number of arguments to constructor " ++ show nm
367− go SubsumptionCheckFailed = line $ "Unable to check type subsumption"
368− go (ExprDoesNotHaveType expr ty) = paras [ line "Expression"
369− , indent $ line $ prettyPrintValue expr
370− , line "does not have type"
371− , indent $ line $ prettyPrintType ty
372− ]
373− go (PropertyIsMissing prop row) = line $ "Row " ++ prettyPrintRow row ++ " lacks required property " ++ show prop
374− go (CannotApplyFunction fn arg) = paras [ line "Cannot apply function of type"
375− , indent $ line $ prettyPrintType fn
376− , line "to argument"
377− , indent $ line $ prettyPrintValue arg
378− ]
379− go TypeSynonymInstance = line "Type synonym instances are disallowed"
380− go InvalidNewtype = line "Newtypes must define a single constructor with a single argument"
381− go (InvalidInstanceHead ty) = paras [ line "Invalid type in class instance head:"
382− , indent $ line $ prettyPrintType ty
383− ]
384− go (TransitiveExportError x ys) = paras $ (line $ "An export for " ++ prettyPrintExport x ++ " requires the following to also be exported: ")
385− : map (line . prettyPrintExport) ys
386− go (ShadowedName nm) = line $ "Name '" ++ show nm ++ "' was shadowed."
387− go PreludeNotPresent = paras [ line $ "There is no Prelude module loaded, and the --no-prelude option was not specified."
388− , line $ "You probably need to install the Prelude and other dependencies using Bower."
389− ]
390− go (ErrorUnifyingTypes t1 t2 err) = paras [ line "Error unifying type "
391− , indent $ line $ prettyPrintType t1
392− , line "with type"
393− , indent $ line $ prettyPrintType t2
394− , go err
395− ]
396− go (ErrorInExpression expr err) = paras [ line "Error in expression:"
397− , indent $ line $ prettyPrintValue expr
398− , go err
399− ]
400− go (ErrorInModule mn err) = paras [ line $ "Error in module " ++ show mn ++ ":"
401− , go err
402− ]
403− go (ErrorInSubsumption t1 t2 err) = paras [ line "Error checking that type "
404− , indent $ line $ prettyPrintType t1
405− , line "subsumes type"
406− , indent $ line $ prettyPrintType t2
407− , go err
408− ]
409− go (ErrorInInstance name ts err) = paras [ line $ "Error in type class instance " ++ show name ++ " " ++ unwords (map prettyPrintTypeAtom ts) ++ ":"
410− , go err
411− ]
412− go (ErrorCheckingKind ty err) = paras [ line "Error checking kind of type "
413− , indent $ line $ prettyPrintType ty
414− , go err
415− ]
416− go (ErrorInferringType expr err) = paras [ line "Error inferring type of value "
417− , indent $ line $ prettyPrintValue expr
418− , go err
419− ]
420− go (ErrorCheckingType expr ty err) = paras [ line "Error checking that value "
421− , indent $ line $ prettyPrintValue expr
422− , line "has type"
423− , indent $ line $ prettyPrintType ty
424− , go err
425− ]
426− go (ErrorInApplication f t a err) = paras [ line "Error applying function"
427− , indent $ line $ prettyPrintValue f
428− , line "of type"
429− , indent $ line $ prettyPrintType t
430− , line "to argument"
431− , indent $ line $ prettyPrintValue a
432− , go err
433− ]
434− go (ErrorInDataConstructor nm err) = paras [ line $ "Error in data constructor " ++ show nm ++ ":"
435− , go err
436− ]
437− go (ErrorInTypeConstructor nm err) = paras [ line $ "Error in type constructor " ++ show nm ++ ":"
438− , go err
439− ]
440− go (ErrorInBindingGroup nms err) = paras [ line $ "Error in binding group " ++ intercalate ", " (map show nms) ++ ":"
441− , go err
442− ]
443− go (ErrorInDataBindingGroup err) = paras [ line $ "Error in data binding group:"
444− , go err
445− ]
446− go (ErrorInTypeSynonym name err) = paras [ line $ "Error in type synonym " ++ show name ++ ":"
447− , go err
448− ]
449− go (ErrorInValueDeclaration n err) = paras [ line $ "Error in value declaration " ++ show n ++ ":"
450− , go err
451− ]
452− go (ErrorInForeignImport nm err) = paras [ line $ "Error in foreign import " ++ show nm ++ ":"
453− , go err
454− ]
455− go (PositionedError srcSpan err) = paras [ line $ "Error at " ++ displaySourceSpan srcSpan ++ ":"
456− , indent $ go err
457− ]
458−
459− line :: String -> Box.Box
460− line = Box.text
461−
462− paras :: [Box.Box] -> Box.Box
463− paras = Box.vcat Box.left
464−
465− indent :: Box.Box -> Box.Box
466− indent = Box.moveRight 2
467−
468− -- |
469− -- Render a DictionaryValue fit for human consumption in error messages
470− --
471− prettyPrintDictionaryValue :: DictionaryValue -> Box.Box
472− prettyPrintDictionaryValue (LocalDictionaryValue _) = line "Dictionary in scope"
473− prettyPrintDictionaryValue (GlobalDictionaryValue nm) = line (show nm)
474− prettyPrintDictionaryValue (DependentDictionaryValue nm args) = paras [ line $ (show nm) ++ " via"
475− , indent $ paras $ map prettyPrintDictionaryValue args
476− ]
477− prettyPrintDictionaryValue (SubclassDictionaryValue sup nm _) = paras [ line $ (show nm) ++ " via superclass"
478− , indent $ prettyPrintDictionaryValue sup
479− ]
480−
481− -- |
482− -- Pretty print and export declaration
483− --
484− prettyPrintExport :: DeclarationRef -> String
485− prettyPrintExport (TypeRef pn _) = show pn
486− prettyPrintExport (ValueRef ident) = show ident
487− prettyPrintExport (TypeClassRef pn) = show pn
488− prettyPrintExport (TypeInstanceRef ident) = show ident
489− prettyPrintExport (PositionedDeclarationRef _ _ ref) = prettyPrintExport ref
490−
491− -- |
492− -- Simplify an error message
493− --
494− simplifyErrorMessage :: ErrorMessage -> ErrorMessage
495− simplifyErrorMessage = unwrap Nothing
496− where
497− unwrap :: Maybe SourceSpan -> ErrorMessage -> ErrorMessage
498− unwrap pos (ErrorInExpression _ err) = unwrap pos err
499− unwrap pos (ErrorInInstance name ts err) = ErrorInInstance name ts (unwrap pos err)
500− unwrap pos (ErrorInSubsumption t1 t2 err) = ErrorInSubsumption t1 t2 (unwrap pos err)
501− unwrap pos (ErrorUnifyingTypes _ _ err) = unwrap pos err
502− unwrap pos (ErrorInferringType _ err) = unwrap pos err
503− unwrap pos (ErrorCheckingType _ _ err) = unwrap pos err
504− unwrap pos (ErrorCheckingKind ty err) = ErrorCheckingKind ty (unwrap pos err)
505− unwrap pos (ErrorInModule mn err) = ErrorInModule mn (unwrap pos err)
506− unwrap pos (ErrorInApplication _ _ _ err) = unwrap pos err
507− unwrap pos (ErrorInDataConstructor nm err) = ErrorInDataConstructor nm (unwrap pos err)
508− unwrap pos (ErrorInTypeConstructor nm err) = ErrorInTypeConstructor nm (unwrap pos err)
509− unwrap pos (ErrorInBindingGroup nms err) = ErrorInBindingGroup nms (unwrap pos err)
510− unwrap pos (ErrorInDataBindingGroup err) = ErrorInDataBindingGroup (unwrap pos err)
511− unwrap pos (ErrorInTypeSynonym nm err) = ErrorInTypeSynonym nm (unwrap pos err)
512− unwrap pos (ErrorInValueDeclaration nm err) = ErrorInValueDeclaration nm (unwrap pos err)
513− unwrap pos (ErrorInForeignImport nm err) = ErrorInForeignImport nm (unwrap pos err)
514− unwrap pos (NotYetDefined ns err) = NotYetDefined ns (unwrap pos err)
515− unwrap _ (PositionedError pos err) = unwrap (Just pos) err
516− unwrap pos other = wrap pos other
517−
518− wrap :: Maybe SourceSpan -> ErrorMessage -> ErrorMessage
519− wrap Nothing = id
520− wrap (Just pos) = PositionedError pos
521−
522−-- |
523−-- Pretty print multiple errors
524−--
525−prettyPrintMultipleErrors :: Bool -> MultipleErrors -> String
526−prettyPrintMultipleErrors = prettyPrintMultipleErrorsWith "Error:" "Multiple errors:"
527−
528−-- |
529−-- Pretty print multiple warnings
530−--
531−prettyPrintMultipleWarnings :: Bool -> MultipleErrors -> String
532−prettyPrintMultipleWarnings = prettyPrintMultipleErrorsWith "Warning:" "Multiple warnings:"
533−
534−prettyPrintMultipleErrorsWith :: String -> String -> Bool -> MultipleErrors -> String
535−prettyPrintMultipleErrorsWith intro _ full (MultipleErrors [e]) = renderBox $
536− Box.vcat Box.left [ Box.text intro
537− , prettyPrintSingleError full e
538− ]
539−prettyPrintMultipleErrorsWith _ intro full (MultipleErrors es) = renderBox $
540− Box.vcat Box.left [ Box.text intro
541− , Box.vsep 1 Box.left $ map (Box.moveRight 2 . prettyPrintSingleError full) es
542− ]
543−
544−renderBox :: Box.Box -> String
545−renderBox = unlines . map trimEnd . lines . Box.render
546− where
547− trimEnd = reverse . dropWhile (== ' ') . reverse
548−
549−-- |
550−-- Interpret multiple errors in a monad supporting errors
551−--
552−interpretMultipleErrors :: (MonadError MultipleErrors m) => Either MultipleErrors a -> m a
553−interpretMultipleErrors = either throwError return
554−
555−-- |
556−-- Rethrow an error with a more detailed error message in the case of failure
557−--
558−rethrow :: (MonadError e m) => (e -> e) -> m a -> m a
559−rethrow f = flip catchError $ \e -> throwError (f e)
560−
561−-- |
562−-- Rethrow an error with source position information
563−--
564−rethrowWithPosition :: (MonadError MultipleErrors m) => SourceSpan -> m a -> m a
565−rethrowWithPosition pos = rethrow (onErrorMessages withPosition)
566− where
567− withPosition :: ErrorMessage -> ErrorMessage
568− withPosition (PositionedError _ err) = withPosition err
569− withPosition err = PositionedError pos err
570−
571−-- |
572−-- Collect errors in in parallel
573−--
574−parU :: (MonadError MultipleErrors m, Functor m) => [a] -> (a -> m b) -> m [b]
575−parU xs f = forM xs (withError . f) >>= collectErrors
576− where
577− withError :: (MonadError MultipleErrors m, Functor m) => m a -> m (Either MultipleErrors a)
578− withError u = catchError (Right <$> u) (return . Left)
579−
580− collectErrors :: (MonadError MultipleErrors m, Functor m) => [Either MultipleErrors a] -> m [a]
581− collectErrors es = case lefts es of
582− [] -> return $ rights es
583− errs -> throwError $ fold 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/Linter.hsdeleted−73
@@ -1,73 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.Linter
4−-- Copyright : (c) Copyright 2015 PureScript
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- | This module implements a simple linting pass on the PureScript AST.
12−--
13−-----------------------------------------------------------------------------
14−
15−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
16−{-# LANGUAGE FlexibleContexts #-}
17−{-# LANGUAGE ScopedTypeVariables #-}
18−
19−module Language.PureScript.Linter (lint) where
20−
21−import Data.List (mapAccumL, nub)
22−import Data.Maybe (mapMaybe)
23−import Data.Monoid
24−
25−import qualified Data.Set as S
26−
27−import Control.Applicative
28−import Control.Monad.Writer.Class
29−
30−import Language.PureScript.AST
31−import Language.PureScript.Names
32−import Language.PureScript.Errors
33−
34−-- | Lint the PureScript AST.
35−-- |
36−-- | Right now, this pass only performs a shadowing check.
37−lint :: forall m. (Applicative m, MonadWriter MultipleErrors m) => Module -> m ()
38−lint (Module _ mn ds _) = censor (onErrorMessages (ErrorInModule mn)) $ mapM_ lintDeclaration ds
39− where
40− moduleNames :: S.Set Ident
41− moduleNames = S.fromList (nub (mapMaybe getDeclIdent ds))
42−
43− getDeclIdent :: Declaration -> Maybe Ident
44− getDeclIdent (PositionedDeclaration _ _ d) = getDeclIdent d
45− getDeclIdent (ValueDeclaration ident _ _ _) = Just ident
46− getDeclIdent (ExternDeclaration _ ident _ _) = Just ident
47− getDeclIdent (ExternInstanceDeclaration ident _ _ _) = Just ident
48− getDeclIdent (TypeInstanceDeclaration ident _ _ _ _) = Just ident
49− getDeclIdent (BindingGroupDeclaration _) = error "lint: binding groups should not be desugared yet."
50− getDeclIdent _ = Nothing
51−
52− lintDeclaration :: Declaration -> m ()
53− lintDeclaration d =
54− let (f, _, _, _, _) = everythingWithContextOnValues moduleNames mempty mappend def stepE stepB def def
55− in tell (f d)
56− where
57− def s _ = (s, mempty)
58−
59− stepE :: S.Set Ident -> Expr -> (S.Set Ident, MultipleErrors)
60− stepE s (Abs (Left name) _) = bind s name
61− stepE s (Let ds' _) =
62− case mapAccumL bind s (nub (mapMaybe getDeclIdent ds')) of
63− (s', es) -> (s', mconcat es)
64− stepE s _ = (s, mempty)
65−
66− stepB :: S.Set Ident -> Binder -> (S.Set Ident, MultipleErrors)
67− stepB s (VarBinder name) = bind s name
68− stepB s (NamedBinder name _) = bind s name
69− stepB s _ = (s, mempty)
70−
71− bind :: S.Set Ident -> Ident -> (S.Set Ident, MultipleErrors)
72− bind s name | name `S.member` s = (s, errorMessage (ShadowedName name))
73− | otherwise = (S.insert name s, mempty)
src/Language/PureScript/ModuleDependencies.hsdeleted−77
@@ -1,77 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.ModuleDependencies
4−-- Copyright : (c) Phil Freeman 2013
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- | Provides the ability to sort modules based on module dependencies
12−--
13−-----------------------------------------------------------------------------
14−
15−{-# LANGUAGE FlexibleContexts #-}
16−
17−module Language.PureScript.ModuleDependencies (
18− sortModules,
19− ModuleGraph
20−) where
21−
22−import Control.Monad.Error.Class (MonadError(..))
23−
24−import Data.Graph
25−import Data.List (nub)
26−import Data.Maybe (mapMaybe)
27−
28−import Language.PureScript.AST
29−import Language.PureScript.Names
30−import Language.PureScript.Types
31−import Language.PureScript.Errors
32−
33−-- |
34−-- A list of modules with their dependencies
35−--
36−type ModuleGraph = [(ModuleName, [ModuleName])]
37−
38−-- |
39−-- Sort a collection of modules based on module dependencies.
40−--
41−-- Reports an error if the module graph contains a cycle.
42−--
43−sortModules :: (MonadError MultipleErrors m) => [Module] -> m ([Module], ModuleGraph)
44−sortModules ms = do
45− let verts = map (\m@(Module _ _ ds _) -> (m, getModuleName m, nub (concatMap usedModules ds))) ms
46− ms' <- mapM toModule $ stronglyConnComp verts
47− let moduleGraph = map (\(_, mn, deps) -> (mn, deps)) verts
48− return (ms', moduleGraph)
49−
50−-- |
51−-- Calculate a list of used modules based on explicit imports and qualified names
52−--
53−usedModules :: Declaration -> [ModuleName]
54−usedModules = let (f, _, _, _, _) = everythingOnValues (++) forDecls forValues (const []) (const []) (const []) in nub . f
55− where
56− forDecls :: Declaration -> [ModuleName]
57− forDecls (ImportDeclaration mn _ _) = [mn]
58− forDecls _ = []
59−
60− forValues :: Expr -> [ModuleName]
61− forValues (Var (Qualified (Just mn) _)) = [mn]
62− forValues (Constructor (Qualified (Just mn) _)) = [mn]
63− forValues (TypedValue _ _ ty) = forTypes ty
64− forValues _ = []
65−
66− forTypes :: Type -> [ModuleName]
67− forTypes (TypeConstructor (Qualified (Just mn) _)) = [mn]
68− forTypes (ConstrainedType cs _) = mapMaybe (\(Qualified mn _, _) -> mn) cs
69− forTypes _ = []
70−
71−-- |
72−-- Convert a strongly connected component of the module graph to a module
73−--
74−toModule :: (MonadError MultipleErrors m) => SCC Module -> m Module
75−toModule (AcyclicSCC m) = return m
76−toModule (CyclicSCC [m]) = return m
77−toModule (CyclicSCC ms) = throwError . errorMessage $ CycleInModules (map getModuleName ms)
src/Language/PureScript/Names.hsdeleted−85
@@ -1,85 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.Names
4−-- Copyright : (c) Phil Freeman 2013
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- |
12−-- Data types for names
13−--
14−-----------------------------------------------------------------------------
15−
16−{-# LANGUAGE DeriveDataTypeable, DeriveFunctor #-}
17−
18−module Language.PureScript.Names where
19−
20−import Data.List
21−import Data.Data
22−
23−-- |
24−-- Names for value identifiers
25−--
26−data Ident
27− -- |
28− -- An alphanumeric identifier
29− --
30− = Ident String
31− -- |
32− -- A symbolic name for an infix operator
33− --
34− | Op String deriving (Eq, Ord, Data, Typeable)
35−
36−runIdent :: Ident -> String
37−runIdent (Ident i) = i
38−runIdent (Op op) = op
39−
40−instance Show Ident where
41− show (Ident s) = s
42− show (Op op) = '(':op ++ ")"
43−
44−-- |
45−-- Proper names, i.e. capitalized names for e.g. module names, type//data constructors.
46−--
47−newtype ProperName = ProperName { runProperName :: String } deriving (Eq, Ord, Data, Typeable)
48−
49−instance Show ProperName where
50− show = runProperName
51−
52−-- |
53−-- Module names
54−--
55−data ModuleName = ModuleName [ProperName] deriving (Eq, Ord, Data, Typeable)
56−
57−runModuleName :: ModuleName -> String
58−runModuleName (ModuleName pns) = intercalate "." (runProperName `map` pns)
59−
60−moduleNameFromString :: String -> ModuleName
61−moduleNameFromString = ModuleName . splitProperNames
62− where
63− splitProperNames s = case dropWhile (== '.') s of
64− "" -> []
65− s' -> ProperName w : splitProperNames s''
66− where (w, s'') = break (== '.') s'
67−
68−instance Show ModuleName where
69− show = runModuleName
70−
71−-- |
72−-- A qualified name, i.e. a name with an optional module name
73−--
74−data Qualified a = Qualified (Maybe ModuleName) a deriving (Eq, Ord, Data, Typeable, Functor)
75−
76−instance (Show a) => Show (Qualified a) where
77− show (Qualified Nothing a) = show a
78− show (Qualified (Just name) a) = show name ++ "." ++ show a
79−
80−-- |
81−-- Provide a default module name, if a name is unqualified
82−--
83−qualify :: ModuleName -> Qualified a -> (ModuleName, a)
84−qualify m (Qualified Nothing a) = (m, a)
85−qualify _ (Qualified (Just m) a) = (m, a)
src/Language/PureScript/Options.hsdeleted−92
@@ -1,92 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.Options
4−-- Copyright : (c) Phil Freeman 2013
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- |
12−-- The data type of compiler options
13−--
14−-----------------------------------------------------------------------------
15−
16−{-# LANGUAGE GADTs, DataKinds, StandaloneDeriving #-}
17−
18−module Language.PureScript.Options where
19−
20−-- |
21−-- Indicates the mode of the compiler. Lifted using DataKinds to refine the Options type.
22−--
23−data Mode = Compile | Make
24−
25−-- |
26−-- Per-mode options
27−--
28−data ModeOptions mode where
29− CompileOptions :: String -> [String] -> [String] -> ModeOptions Compile
30− MakeOptions :: ModeOptions Make
31−
32−browserNamespace :: ModeOptions Compile -> String
33−browserNamespace (CompileOptions ns _ _) = ns
34−
35−entryPointModules :: ModeOptions Compile -> [String]
36−entryPointModules (CompileOptions _ ms _) = ms
37−
38−codeGenModules :: ModeOptions Compile -> [String]
39−codeGenModules (CompileOptions _ _ ms) = ms
40−
41−deriving instance Show (ModeOptions mode)
42−
43−-- |
44−-- The data type of compiler options
45−--
46−data Options mode = Options {
47− -- |
48− -- Disable inclusion of the built in Prelude
49− --
50− optionsNoPrelude :: Bool
51− -- |
52− -- Disable tail-call elimination
53− --
54− , optionsNoTco :: Bool
55− -- |
56− -- Disable inlining of calls to return and bind for the Eff monad
57− --
58− , optionsNoMagicDo :: Bool
59− -- |
60− -- When specified, checks the type of `main` in the module, and generate a call to run main
61− -- after the module definitions.
62− --
63− , optionsMain :: Maybe String
64− -- |
65− -- Skip all optimizations
66− --
67− , optionsNoOptimizations :: Bool
68− -- |
69− -- Verbose error message
70− --
71− , optionsVerboseErrors :: Bool
72− -- |
73− -- Remove the comments from the generated js
74− , optionsNoComments :: Bool
75− -- |
76− -- Specify the namespace that PureScript modules will be exported to when running in the
77− -- browser.
78− --
79− , optionsAdditional :: ModeOptions mode
80− } deriving Show
81−
82−-- |
83−-- Default compiler options
84−--
85−defaultCompileOptions :: Options Compile
86−defaultCompileOptions = Options False False False Nothing False False False (CompileOptions "PS" [] [])
87−
88−-- |
89−-- Default make options
90−--
91−defaultMakeOptions :: Options Make
92−defaultMakeOptions = Options False False False Nothing False False False MakeOptions
src/Language/PureScript/Parser.hsdeleted−35
@@ -1,35 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.Parser
4−-- Copyright : (c) Phil Freeman 2013
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- |
12−-- A collection of parsers for core data types:
13−--
14−-- [@Language.PureScript.Parser.Kinds@] Parser for kinds
15−--
16−-- [@Language.PureScript.Parser.Values@] Parser for values
17−--
18−-- [@Language.PureScript.Parser.Types@] Parser for types
19−--
20−-- [@Language.PureScript.Parser.Declaration@] Parsers for declarations and modules
21−--
22−-- [@Language.PureScript.Parser.State@] Parser state, including indentation
23−--
24−-- [@Language.PureScript.Parser.Common@] Common parsing utility functions
25−--
26−-----------------------------------------------------------------------------
27−
28−module Language.PureScript.Parser (module P) where
29−
30−import Language.PureScript.Parser.Common as P
31−import Language.PureScript.Parser.Types as P
32−import Language.PureScript.Parser.State as P
33−import Language.PureScript.Parser.Kinds as P
34−import Language.PureScript.Parser.Lexer as P
35−import Language.PureScript.Parser.Declarations as P
src/Language/PureScript/Parser/Common.hsdeleted−134
@@ -1,134 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.Parser.Common
4−-- Copyright : (c) Phil Freeman 2013
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- |
12−-- Constants, and utility functions to be used when parsing
13−--
14−-----------------------------------------------------------------------------
15−
16−{-# LANGUAGE FlexibleContexts #-}
17−
18−module Language.PureScript.Parser.Common where
19−
20−import Control.Applicative
21−import Control.Monad (guard)
22−
23−import Language.PureScript.Comments
24−import Language.PureScript.Parser.Lexer
25−import Language.PureScript.Parser.State
26−import Language.PureScript.Names
27−
28−import qualified Text.Parsec as P
29−
30−properName :: TokenParser ProperName
31−properName = ProperName <$> uname
32−
33−-- |
34−-- Parse a module name
35−--
36−moduleName :: TokenParser ModuleName
37−moduleName = part []
38− where
39− part path = (do name <- ProperName <$> P.try qualifier
40− part (path `snoc` name))
41− <|> (ModuleName . snoc path . ProperName <$> mname)
42− snoc path name = path ++ [name]
43−
44−-- |
45−-- Parse a qualified name, i.e. M.name or just name
46−--
47−parseQualified :: TokenParser a -> TokenParser (Qualified a)
48−parseQualified parser = part []
49− where
50− part path = (do name <- ProperName <$> P.try qualifier
51− part (updatePath path name))
52− <|> (Qualified (qual path) <$> P.try parser)
53− updatePath path name = path ++ [name]
54− qual path = if null path then Nothing else Just $ ModuleName path
55−
56−-- |
57−-- Parse an identifier or parenthesized operator
58−--
59−parseIdent :: TokenParser Ident
60−parseIdent = (Ident <$> identifier) <|> (Op <$> parens symbol)
61−
62−-- |
63−-- Run the first parser, then match the second if possible, applying the specified function on a successful match
64−--
65−augment :: P.Stream s m t => P.ParsecT s u m a -> P.ParsecT s u m b -> (a -> b -> a) -> P.ParsecT s u m a
66−augment p q f = flip (maybe id $ flip f) <$> p <*> P.optionMaybe q
67−
68−-- |
69−-- Run the first parser, then match the second zero or more times, applying the specified function for each match
70−--
71−fold :: P.Stream s m t => P.ParsecT s u m a -> P.ParsecT s u m b -> (a -> b -> a) -> P.ParsecT s u m a
72−fold first more combine = do
73− a <- first
74− bs <- P.many more
75− return $ foldl combine a bs
76−
77−-- |
78−-- Build a parser from a smaller parser and a list of parsers for postfix operators
79−--
80−buildPostfixParser :: P.Stream s m t => [a -> P.ParsecT s u m a] -> P.ParsecT s u m a -> P.ParsecT s u m a
81−buildPostfixParser fs first = do
82− a <- first
83− go a
84− where
85− go a = do
86− maybeA <- P.optionMaybe $ P.choice (map ($ a) fs)
87− case maybeA of
88− Nothing -> return a
89− Just a' -> go a'
90−
91−-- |
92−-- Mark the current indentation level
93−--
94−mark :: P.Parsec s ParseState a -> P.Parsec s ParseState a
95−mark p = do
96− current <- indentationLevel <$> P.getState
97− pos <- P.sourceColumn <$> P.getPosition
98− P.modifyState $ \st -> st { indentationLevel = pos }
99− a <- p
100− P.modifyState $ \st -> st { indentationLevel = current }
101− return a
102−
103−-- |
104−-- Check that the current identation level matches a predicate
105−--
106−checkIndentation :: (P.Column -> P.Column -> Bool) -> P.Parsec s ParseState ()
107−checkIndentation rel = do
108− col <- P.sourceColumn <$> P.getPosition
109− current <- indentationLevel <$> P.getState
110− guard (col `rel` current)
111−
112−-- |
113−-- Check that the current indentation level is past the current mark
114−--
115−indented :: P.Parsec s ParseState ()
116−indented = checkIndentation (>) P.<?> "indentation"
117−
118−-- |
119−-- Check that the current indentation level is at the same indentation as the current mark
120−--
121−same :: P.Parsec s ParseState ()
122−same = checkIndentation (==) P.<?> "no indentation"
123−
124−-- |
125−-- Read the comments from the the next token, without consuming it
126−--
127−readComments :: P.Parsec [PositionedToken] u [Comment]
128−readComments = P.lookAhead $ ptComments <$> P.anyToken
129−
130−-- |
131−-- Run a parser
132−--
133−runTokenParser :: FilePath -> TokenParser a -> [PositionedToken] -> Either P.ParseError a
134−runTokenParser filePath p = P.runParser p (ParseState 0) filePath
src/Language/PureScript/Parser/Declarations.hsdeleted−526
@@ -1,526 +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− parseImportDeclaration',
28− parseLocalDeclaration
29−) where
30−
31−import Prelude hiding (lex)
32−
33−import Data.Maybe (isJust, fromMaybe)
34−import Data.Traversable (forM)
35−
36−import Control.Applicative
37−import Control.Arrow ((+++))
38−
39−import Language.PureScript.Kinds
40−import Language.PureScript.AST
41−import Language.PureScript.Comments
42−import Language.PureScript.Parser.Common
43−import Language.PureScript.Parser.Types
44−import Language.PureScript.Parser.Kinds
45−import Language.PureScript.Parser.Lexer
46−import Language.PureScript.Names
47−import Language.PureScript.CodeGen.JS.AST
48−import Language.PureScript.Environment
49−
50−import qualified Language.PureScript.Parser.Common as C
51−import qualified Text.Parsec as P
52−import qualified Text.Parsec.Expr as P
53−
54−-- |
55−-- Read source position information
56−--
57−withSourceSpan :: (SourceSpan -> [Comment] -> a -> a) -> P.Parsec [PositionedToken] u a -> P.Parsec [PositionedToken] u a
58−withSourceSpan f p = do
59− start <- P.getPosition
60− comments <- C.readComments
61− x <- p
62− end <- P.getPosition
63− let sp = SourceSpan (P.sourceName start) (toSourcePos start) (toSourcePos end)
64− return $ f sp comments x
65− where
66− toSourcePos pos = SourcePos (P.sourceLine pos) (P.sourceColumn pos)
67−
68−kindedIdent :: TokenParser (String, Maybe Kind)
69−kindedIdent = (, Nothing) <$> identifier
70− <|> parens ((,) <$> identifier <*> (Just <$> (indented *> doubleColon *> indented *> parseKind)))
71−
72−parseDataDeclaration :: TokenParser Declaration
73−parseDataDeclaration = do
74− dtype <- (reserved "data" *> return Data) <|> (reserved "newtype" *> return Newtype)
75− name <- indented *> properName
76− tyArgs <- many (indented *> kindedIdent)
77− ctors <- P.option [] $ do
78− indented *> equals
79− P.sepBy1 ((,) <$> properName <*> P.many (indented *> noWildcards parseTypeAtom)) pipe
80− return $ DataDeclaration dtype name tyArgs ctors
81−
82−parseTypeDeclaration :: TokenParser Declaration
83−parseTypeDeclaration =
84− TypeDeclaration <$> P.try (parseIdent <* indented <* doubleColon)
85− <*> parsePolyType
86−
87−parseTypeSynonymDeclaration :: TokenParser Declaration
88−parseTypeSynonymDeclaration =
89− TypeSynonymDeclaration <$> (P.try (reserved "type") *> indented *> properName)
90− <*> many (indented *> kindedIdent)
91− <*> (indented *> equals *> noWildcards parsePolyType)
92−
93−parseValueDeclaration :: TokenParser Declaration
94−parseValueDeclaration = do
95− name <- parseIdent
96− binders <- P.many parseBinderNoParens
97− value <- Left <$> (C.indented *>
98− P.many1 ((,) <$> parseGuard
99− <*> (indented *> equals *> parseValueWithWhereClause)
100− ))
101− <|> Right <$> (indented *> equals *> parseValueWithWhereClause)
102− return $ ValueDeclaration name Value binders value
103− where
104− parseValueWithWhereClause :: TokenParser Expr
105− parseValueWithWhereClause = do
106− value <- parseValue
107− whereClause <- P.optionMaybe $ do
108− C.indented
109− reserved "where"
110− C.indented
111− C.mark $ P.many1 (C.same *> parseLocalDeclaration)
112− return $ maybe value (`Let` value) whereClause
113−
114−parseExternDeclaration :: TokenParser Declaration
115−parseExternDeclaration = P.try (reserved "foreign") *> indented *> reserved "import" *> indented *>
116− (ExternDataDeclaration <$> (P.try (reserved "data") *> indented *> properName)
117− <*> (indented *> doubleColon *> parseKind)
118− <|> (do reserved "instance"
119− name <- parseIdent <* indented <* doubleColon
120− deps <- P.option [] $ do
121− deps <- parens (commaSep1 ((,) <$> parseQualified properName <*> P.many (noWildcards parseTypeAtom)))
122− indented
123− rfatArrow
124− return deps
125− className <- indented *> parseQualified properName
126− tys <- P.many (indented *> noWildcards parseTypeAtom)
127− return $ ExternInstanceDeclaration name deps className tys)
128− <|> (do ident <- parseIdent
129− js <- P.optionMaybe (JSRaw <$> stringLiteral)
130− ty <- indented *> doubleColon *> noWildcards parsePolyType
131− return $ ExternDeclaration (if isJust js then InlineJavascript else ForeignImport) ident js ty))
132−
133−parseAssociativity :: TokenParser Associativity
134−parseAssociativity =
135− (P.try (reserved "infixl") >> return Infixl) <|>
136− (P.try (reserved "infixr") >> return Infixr) <|>
137− (P.try (reserved "infix") >> return Infix)
138−
139−parseFixity :: TokenParser Fixity
140−parseFixity = Fixity <$> parseAssociativity <*> (indented *> natural)
141−
142−parseFixityDeclaration :: TokenParser Declaration
143−parseFixityDeclaration = do
144− fixity <- parseFixity
145− indented
146− name <- symbol
147− return $ FixityDeclaration fixity name
148−
149−parseImportDeclaration :: TokenParser Declaration
150−parseImportDeclaration = do
151− (mn, declType, asQ) <- parseImportDeclaration'
152− return $ ImportDeclaration mn declType asQ
153−
154−parseImportDeclaration' :: TokenParser (ModuleName, ImportDeclarationType, (Maybe ModuleName))
155−parseImportDeclaration' = do
156− reserved "import"
157− indented
158− qualImport <|> stdImport
159− where
160− stdImport = do
161− moduleName' <- moduleName
162− stdImportHiding moduleName' <|> stdImportQualifying moduleName'
163− where
164− stdImportHiding mn = do
165− reserved "hiding"
166− declType <- importDeclarationType Hiding
167− return (mn, declType, Nothing)
168− stdImportQualifying mn = do
169− declType <- importDeclarationType Explicit
170− return (mn, declType, Nothing)
171− qualImport = do
172− reserved "qualified"
173− indented
174− moduleName' <- moduleName
175− declType <- importDeclarationType Explicit
176− reserved "as"
177− asQ <- moduleName
178− return (moduleName', declType, Just asQ)
179− importDeclarationType expectedType = do
180− idents <- P.optionMaybe $ indented *> (parens $ commaSep parseDeclarationRef)
181− return $ fromMaybe Implicit (expectedType <$> idents)
182−
183−
184−parseDeclarationRef :: TokenParser DeclarationRef
185−parseDeclarationRef = withSourceSpan PositionedDeclarationRef $
186− ValueRef <$> parseIdent
187− <|> do name <- properName
188− dctors <- P.optionMaybe $ parens (symbol' ".." *> pure Nothing <|> Just <$> commaSep properName)
189− return $ maybe (TypeClassRef name) (TypeRef name) dctors
190−
191−parseTypeClassDeclaration :: TokenParser Declaration
192−parseTypeClassDeclaration = do
193− reserved "class"
194− implies <- P.option [] $ do
195− indented
196− implies <- parens (commaSep1 ((,) <$> parseQualified properName <*> P.many (noWildcards parseTypeAtom)))
197− lfatArrow
198− return implies
199− className <- indented *> properName
200− idents <- P.many (indented *> kindedIdent)
201− members <- P.option [] . P.try $ do
202− indented *> reserved "where"
203− mark (P.many (same *> positioned parseTypeDeclaration))
204− return $ TypeClassDeclaration className idents implies members
205−
206−parseTypeInstanceDeclaration :: TokenParser Declaration
207−parseTypeInstanceDeclaration = do
208− reserved "instance"
209− name <- parseIdent <* indented <* doubleColon
210− deps <- P.optionMaybe $ do
211− deps <- parens (commaSep1 ((,) <$> parseQualified properName <*> P.many (noWildcards parseTypeAtom)))
212− indented
213− rfatArrow
214− return deps
215− className <- indented *> parseQualified properName
216− ty <- P.many (indented *> (noWildcards parseTypeAtom))
217− members <- P.option [] . P.try $ do
218− indented *> reserved "where"
219− mark (P.many (same *> positioned parseValueDeclaration))
220− return $ TypeInstanceDeclaration name (fromMaybe [] deps) className ty members
221−
222−positioned :: TokenParser Declaration -> TokenParser Declaration
223−positioned d = withSourceSpan PositionedDeclaration d
224−
225−-- |
226−-- Parse a single declaration
227−--
228−parseDeclaration :: TokenParser Declaration
229−parseDeclaration = positioned (P.choice
230− [ parseDataDeclaration
231− , parseTypeDeclaration
232− , parseTypeSynonymDeclaration
233− , parseValueDeclaration
234− , parseExternDeclaration
235− , parseFixityDeclaration
236− , parseImportDeclaration
237− , parseTypeClassDeclaration
238− , parseTypeInstanceDeclaration
239− ]) P.<?> "declaration"
240−
241−parseLocalDeclaration :: TokenParser Declaration
242−parseLocalDeclaration = positioned (P.choice
243− [ parseTypeDeclaration
244− , parseValueDeclaration
245− ] P.<?> "local declaration")
246−
247−-- |
248−-- Parse a module header and a collection of declarations
249−--
250−parseModule :: TokenParser Module
251−parseModule = do
252− comments <- C.readComments
253− reserved "module"
254− indented
255− name <- moduleName
256− exports <- P.optionMaybe $ parens $ commaSep1 parseDeclarationRef
257− reserved "where"
258− decls <- mark (P.many (same *> parseDeclaration))
259− return $ Module comments name decls exports
260−
261−-- |
262−-- Parse a collection of modules
263−--
264−parseModulesFromFiles :: (k -> String) -> [(k, String)] -> Either P.ParseError [(k, Module)]
265−parseModulesFromFiles toFilePath input =
266− fmap collect . forM input $ \(k, content) -> do
267− let filename = toFilePath k
268− ts <- lex filename content
269− ms <- runTokenParser filename parseModules ts
270− return (k, ms)
271− where
272− collect :: [(k, [v])] -> [(k, v)]
273− collect vss = [ (k, v) | (k, vs) <- vss, v <- vs ]
274−
275−-- |
276−-- Parse a collection of modules
277−--
278−parseModules :: TokenParser [Module]
279−parseModules = mark (P.many (same *> parseModule)) <* P.eof
280−
281−booleanLiteral :: TokenParser Bool
282−booleanLiteral = (reserved "true" >> return True) P.<|> (reserved "false" >> return False)
283−
284−parseNumericLiteral :: TokenParser Expr
285−parseNumericLiteral = NumericLiteral <$> number
286−
287−parseStringLiteral :: TokenParser Expr
288−parseStringLiteral = StringLiteral <$> stringLiteral
289−
290−parseBooleanLiteral :: TokenParser Expr
291−parseBooleanLiteral = BooleanLiteral <$> booleanLiteral
292−
293−parseArrayLiteral :: TokenParser Expr
294−parseArrayLiteral = ArrayLiteral <$> squares (commaSep parseValue)
295−
296−parseObjectLiteral :: TokenParser Expr
297−parseObjectLiteral = ObjectConstructor <$> braces (commaSep parseIdentifierAndValue)
298−
299−parseIdentifierAndValue :: TokenParser (String, Maybe Expr)
300−parseIdentifierAndValue = (,) <$> (C.indented *> (lname <|> stringLiteral) <* C.indented <* colon)
301− <*> (C.indented *> val)
302− where
303− val = (Just <$> parseValue) <|> (underscore *> pure Nothing)
304−
305−parseAbs :: TokenParser Expr
306−parseAbs = do
307− symbol' "\\"
308− args <- P.many1 (C.indented *> (Abs <$> (Left <$> P.try C.parseIdent <|> Right <$> parseBinderNoParens)))
309− C.indented *> rarrow
310− value <- parseValue
311− return $ toFunction args value
312− where
313− toFunction :: [Expr -> Expr] -> Expr -> Expr
314− toFunction args value = foldr ($) value args
315−
316−parseVar :: TokenParser Expr
317−parseVar = Var <$> C.parseQualified C.parseIdent
318−
319−parseConstructor :: TokenParser Expr
320−parseConstructor = Constructor <$> C.parseQualified C.properName
321−
322−parseCase :: TokenParser Expr
323−parseCase = Case <$> P.between (P.try (reserved "case")) (C.indented *> reserved "of") (return <$> parseValue)
324− <*> (C.indented *> C.mark (P.many (C.same *> C.mark parseCaseAlternative)))
325−
326−parseCaseAlternative :: TokenParser CaseAlternative
327−parseCaseAlternative = CaseAlternative <$> (return <$> parseBinder)
328− <*> (Left <$> (C.indented *>
329− P.many1 ((,) <$> parseGuard
330− <*> (indented *> rarrow *> parseValue)
331− ))
332− <|> Right <$> (indented *> rarrow *> parseValue))
333− P.<?> "case alternative"
334−
335−parseIfThenElse :: TokenParser Expr
336−parseIfThenElse = IfThenElse <$> (P.try (reserved "if") *> C.indented *> parseValue)
337− <*> (C.indented *> reserved "then" *> C.indented *> parseValue)
338− <*> (C.indented *> reserved "else" *> C.indented *> parseValue)
339−
340−parseLet :: TokenParser Expr
341−parseLet = do
342− reserved "let"
343− C.indented
344− ds <- C.mark $ P.many1 (C.same *> parseLocalDeclaration)
345− C.indented
346− reserved "in"
347− result <- parseValue
348− return $ Let ds result
349−
350−parseValueAtom :: TokenParser Expr
351−parseValueAtom = P.choice
352− [ P.try parseNumericLiteral
353− , P.try parseStringLiteral
354− , P.try parseBooleanLiteral
355− , parseArrayLiteral
356− , P.try parseObjectLiteral
357− , P.try parseObjectGetter
358− , parseAbs
359− , P.try parseConstructor
360− , P.try parseVar
361− , parseCase
362− , parseIfThenElse
363− , parseDo
364− , parseLet
365− , P.try $ Parens <$> parens parseValue
366− , parseOperatorSection
367− , P.try parseObjectUpdaterWildcard ]
368−
369−-- |
370−-- Parse an expression in backticks or an operator
371−--
372−parseInfixExpr :: TokenParser Expr
373−parseInfixExpr = P.between tick tick parseValue
374− <|> Var <$> parseQualified (Op <$> symbol)
375−
376−parseOperatorSection :: TokenParser Expr
377−parseOperatorSection = parens $ left <|> right
378− where
379− right = OperatorSection <$> parseInfixExpr <* indented <*> (Right <$> parseValueAtom)
380− left = flip OperatorSection <$> (Left <$> parseValueAtom) <* indented <*> parseInfixExpr
381−
382−parsePropertyUpdate :: TokenParser (String, Maybe Expr)
383−parsePropertyUpdate = do
384− name <- lname <|> stringLiteral
385− _ <- C.indented *> equals
386− value <- C.indented *> (underscore *> pure Nothing) <|> (Just <$> parseValue)
387− return (name, value)
388−
389−parseAccessor :: Expr -> TokenParser Expr
390−parseAccessor (Constructor _) = P.unexpected "constructor"
391−parseAccessor obj = P.try $ Accessor <$> (C.indented *> dot *> C.indented *> (lname <|> stringLiteral)) <*> pure obj
392−
393−parseDo :: TokenParser Expr
394−parseDo = do
395− reserved "do"
396− C.indented
397− Do <$> C.mark (P.many (C.same *> C.mark parseDoNotationElement))
398−
399−parseDoNotationLet :: TokenParser DoNotationElement
400−parseDoNotationLet = DoNotationLet <$> (reserved "let" *> C.indented *> C.mark (P.many1 (C.same *> parseLocalDeclaration)))
401−
402−parseDoNotationBind :: TokenParser DoNotationElement
403−parseDoNotationBind = DoNotationBind <$> parseBinder <*> (C.indented *> larrow *> parseValue)
404−
405−parseDoNotationElement :: TokenParser DoNotationElement
406−parseDoNotationElement = P.choice
407− [ P.try parseDoNotationBind
408− , parseDoNotationLet
409− , P.try (DoNotationValue <$> parseValue) ]
410−
411−parseObjectGetter :: TokenParser Expr
412−parseObjectGetter = ObjectGetter <$> (underscore *> C.indented *> dot *> C.indented *> (lname <|> stringLiteral))
413−
414−-- |
415−-- Parse a value
416−--
417−parseValue :: TokenParser Expr
418−parseValue = withSourceSpan PositionedValue
419− (P.buildExpressionParser operators
420− . C.buildPostfixParser postfixTable2
421− $ indexersAndAccessors) P.<?> "expression"
422− where
423− indexersAndAccessors = C.buildPostfixParser postfixTable1 parseValueAtom
424− postfixTable1 = [ parseAccessor
425− , P.try . parseUpdaterBody . Just ]
426− postfixTable2 = [ \v -> P.try (flip App <$> (C.indented *> indexersAndAccessors)) <*> pure v
427− , \v -> flip (TypedValue True) <$> (P.try (C.indented *> doubleColon) *> parsePolyType) <*> pure v
428− ]
429− operators = [ [ P.Prefix (P.try (C.indented *> symbol' "-") >> return UnaryMinus)
430− ]
431− , [ P.Infix (P.try (C.indented *> parseInfixExpr P.<?> "infix expression") >>= \ident ->
432− return (BinaryNoParens ident)) P.AssocRight
433− ]
434− ]
435−
436−parseUpdaterBody :: Maybe Expr -> TokenParser Expr
437−parseUpdaterBody v = ObjectUpdater v <$> (C.indented *> braces (commaSep1 (C.indented *> parsePropertyUpdate)))
438−
439−parseObjectUpdaterWildcard :: TokenParser Expr
440−parseObjectUpdaterWildcard = underscore *> C.indented *> parseUpdaterBody Nothing
441−
442−parseStringBinder :: TokenParser Binder
443−parseStringBinder = StringBinder <$> stringLiteral
444−
445−parseBooleanBinder :: TokenParser Binder
446−parseBooleanBinder = BooleanBinder <$> booleanLiteral
447−
448−parseNumberBinder :: TokenParser Binder
449−parseNumberBinder = NumberBinder <$> (sign <*> number)
450− where
451− sign :: TokenParser (Either Integer Double -> Either Integer Double)
452− sign = (symbol' "-" >> return (negate +++ negate))
453− <|> (symbol' "+" >> return id)
454− <|> return id
455−
456−parseVarBinder :: TokenParser Binder
457−parseVarBinder = VarBinder <$> C.parseIdent
458−
459−parseNullaryConstructorBinder :: TokenParser Binder
460−parseNullaryConstructorBinder = ConstructorBinder <$> C.parseQualified C.properName <*> pure []
461−
462−parseConstructorBinder :: TokenParser Binder
463−parseConstructorBinder = ConstructorBinder <$> C.parseQualified C.properName <*> many (C.indented *> parseBinderNoParens)
464−
465−parseObjectBinder :: TokenParser Binder
466−parseObjectBinder = ObjectBinder <$> braces (commaSep (C.indented *> parseIdentifierAndBinder))
467−
468−parseArrayBinder :: TokenParser Binder
469−parseArrayBinder = squares $ ArrayBinder <$> commaSep (C.indented *> parseBinder)
470−
471−parseNamedBinder :: TokenParser Binder
472−parseNamedBinder = NamedBinder <$> (C.parseIdent <* C.indented <* at)
473− <*> (C.indented *> parseBinder)
474−
475−parseNullBinder :: TokenParser Binder
476−parseNullBinder = underscore *> return NullBinder
477−
478−parseIdentifierAndBinder :: TokenParser (String, Binder)
479−parseIdentifierAndBinder = do
480− name <- lname <|> stringLiteral
481− C.indented *> (equals <|> colon)
482− binder <- C.indented *> parseBinder
483− return (name, binder)
484−
485−-- |
486−-- Parse a binder
487−--
488−parseBinder :: TokenParser Binder
489−parseBinder = withSourceSpan PositionedBinder (P.buildExpressionParser operators parseBinderAtom P.<?> "expression")
490− where
491− operators = [ [ P.Infix (P.try $ C.indented *> colon *> return ConsBinder) P.AssocRight ] ]
492− parseBinderAtom :: TokenParser Binder
493− parseBinderAtom = P.choice (map P.try
494− [ parseNullBinder
495− , parseStringBinder
496− , parseBooleanBinder
497− , parseNumberBinder
498− , parseNamedBinder
499− , parseVarBinder
500− , parseConstructorBinder
501− , parseObjectBinder
502− , parseArrayBinder
503− , parens parseBinder ]) P.<?> "binder"
504−
505−-- |
506−-- Parse a binder as it would appear in a top level declaration
507−--
508−parseBinderNoParens :: TokenParser Binder
509−parseBinderNoParens = P.choice (map P.try
510− [ parseNullBinder
511− , parseStringBinder
512− , parseBooleanBinder
513− , parseNumberBinder
514− , parseNamedBinder
515− , parseVarBinder
516− , parseNullaryConstructorBinder
517− , parseObjectBinder
518− , parseArrayBinder
519− , parens parseBinder ]) P.<?> "binder"
520−-- |
521−-- Parse a guard
522−--
523−parseGuard :: TokenParser Guard
524−parseGuard = pipe *> C.indented *> parseValue
525−
526−
src/Language/PureScript/Parser/Kinds.hsdeleted−45
@@ -1,45 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.Parser.Kinds
4−-- Copyright : (c) Phil Freeman 2013
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- |
12−-- A parser for kinds
13−--
14−-----------------------------------------------------------------------------
15−
16−module Language.PureScript.Parser.Kinds (
17− parseKind
18−) where
19−
20−import Language.PureScript.Kinds
21−import Language.PureScript.Parser.Common
22−import Language.PureScript.Parser.Lexer
23−import Control.Applicative
24−import qualified Text.Parsec as P
25−import qualified Text.Parsec.Expr as P
26−
27−parseStar :: TokenParser Kind
28−parseStar = const Star <$> symbol' "*"
29−
30−parseBang :: TokenParser Kind
31−parseBang = const Bang <$> symbol' "!"
32−
33−parseTypeAtom :: TokenParser Kind
34−parseTypeAtom = indented *> P.choice (map P.try
35− [ parseStar
36− , parseBang
37− , parens parseKind ])
38−-- |
39−-- Parse a kind
40−--
41−parseKind :: TokenParser Kind
42−parseKind = P.buildExpressionParser operators parseTypeAtom P.<?> "kind"
43− where
44− operators = [ [ P.Prefix (symbol' "#" >> return Row) ]
45− , [ P.Infix ((P.try rarrow) >> return FunKind) P.AssocRight ] ]
src/Language/PureScript/Parser/Lexer.hsdeleted−499
@@ -1,499 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.Parser.Lexer
4−-- Copyright : (c) Phil Freeman 2014
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- |
12−-- The first step in the parsing process - turns source code into a list of lexemes
13−--
14−-----------------------------------------------------------------------------
15−
16−{-# LANGUAGE TupleSections #-}
17−
18−module Language.PureScript.Parser.Lexer
19− ( PositionedToken(..)
20− , Token()
21− , TokenParser()
22− , lex
23− , anyToken
24− , token
25− , match
26− , lparen
27− , rparen
28− , parens
29− , lbrace
30− , rbrace
31− , braces
32− , lsquare
33− , rsquare
34− , squares
35− , indent
36− , indentAt
37− , larrow
38− , rarrow
39− , lfatArrow
40− , rfatArrow
41− , colon
42− , doubleColon
43− , equals
44− , pipe
45− , tick
46− , dot
47− , comma
48− , semi
49− , at
50− , underscore
51− , semiSep
52− , semiSep1
53− , commaSep
54− , commaSep1
55− , lname
56− , qualifier
57− , uname
58− , uname'
59− , mname
60− , reserved
61− , symbol
62− , symbol'
63− , identifier
64− , stringLiteral
65− , number
66− , natural
67− , reservedPsNames
68− , reservedTypeNames
69− , opChars
70− )
71− where
72−
73−import Prelude hiding (lex)
74−
75−import Data.Char (isSpace)
76−
77−import Control.Monad (void, guard)
78−import Data.Functor.Identity
79−
80−import Control.Applicative
81−
82−import Language.PureScript.Parser.State
83−import Language.PureScript.Comments
84−
85−import qualified Text.Parsec as P
86−import qualified Text.Parsec.Token as PT
87−
88−data Token
89− = LParen
90− | RParen
91− | LBrace
92− | RBrace
93− | LSquare
94− | RSquare
95− | Indent Int
96− | LArrow
97− | RArrow
98− | LFatArrow
99− | RFatArrow
100− | Colon
101− | DoubleColon
102− | Equals
103− | Pipe
104− | Tick
105− | Dot
106− | Comma
107− | Semi
108− | At
109− | Underscore
110− | LName String
111− | UName String
112− | Qualifier String
113− | Symbol String
114− | StringLiteral String
115− | Number (Either Integer Double)
116− deriving (Show, Eq, Ord)
117−
118−prettyPrintToken :: Token -> String
119−prettyPrintToken LParen = "("
120−prettyPrintToken RParen = ")"
121−prettyPrintToken LBrace = "{"
122−prettyPrintToken RBrace = "}"
123−prettyPrintToken LSquare = "["
124−prettyPrintToken RSquare = "]"
125−prettyPrintToken LArrow = "<-"
126−prettyPrintToken RArrow = "->"
127−prettyPrintToken LFatArrow = "<="
128−prettyPrintToken RFatArrow = "=>"
129−prettyPrintToken Colon = ":"
130−prettyPrintToken DoubleColon = "::"
131−prettyPrintToken Equals = "="
132−prettyPrintToken Pipe = "|"
133−prettyPrintToken Tick = "`"
134−prettyPrintToken Dot = "."
135−prettyPrintToken Comma = ","
136−prettyPrintToken Semi = ";"
137−prettyPrintToken At = "@"
138−prettyPrintToken Underscore = "_"
139−prettyPrintToken (Indent n) = "indentation at level " ++ show n
140−prettyPrintToken (LName s) = show s
141−prettyPrintToken (UName s) = show s
142−prettyPrintToken (Qualifier _) = "qualifier"
143−prettyPrintToken (Symbol s) = s
144−prettyPrintToken (StringLiteral s) = show s
145−prettyPrintToken (Number n) = either show show n
146−
147−data PositionedToken = PositionedToken
148− { ptSourcePos :: P.SourcePos
149− , ptToken :: Token
150− , ptComments :: [Comment]
151− } deriving (Eq)
152−
153−instance Show PositionedToken where
154− show = show . ptToken
155−
156−lex :: FilePath -> String -> Either P.ParseError [PositionedToken]
157−lex filePath input = P.parse parseTokens filePath input
158−
159−parseTokens :: P.Parsec String u [PositionedToken]
160−parseTokens = whitespace *> P.many parsePositionedToken <* P.skipMany parseComment <* P.eof
161−
162−whitespace :: P.Parsec String u ()
163−whitespace = P.skipMany (P.satisfy isSpace)
164−
165−parseComment :: P.Parsec String u Comment
166−parseComment = (BlockComment <$> blockComment <|> LineComment <$> lineComment) <* whitespace
167− where
168− blockComment :: P.Parsec String u String
169− blockComment = P.try $ P.string "{-" *> P.manyTill P.anyChar (P.try (P.string "-}"))
170−
171− lineComment :: P.Parsec String u String
172− lineComment = P.try $ P.string "--" *> P.manyTill P.anyChar (P.try (void (P.char '\n') <|> P.eof))
173−
174−parsePositionedToken :: P.Parsec String u PositionedToken
175−parsePositionedToken = P.try $ do
176− comments <- P.many parseComment
177− pos <- P.getPosition
178− tok <- parseToken
179− return $ PositionedToken pos tok comments
180−
181−parseToken :: P.Parsec String u Token
182−parseToken = P.choice
183− [ P.try $ P.string "<-" *> P.notFollowedBy symbolChar *> pure LArrow
184− , P.try $ P.string "<=" *> P.notFollowedBy symbolChar *> pure LFatArrow
185− , P.try $ P.string "->" *> P.notFollowedBy symbolChar *> pure RArrow
186− , P.try $ P.string "=>" *> P.notFollowedBy symbolChar *> pure RFatArrow
187− , P.try $ P.string "::" *> P.notFollowedBy symbolChar *> pure DoubleColon
188− , P.try $ P.char '(' *> pure LParen
189− , P.try $ P.char ')' *> pure RParen
190− , P.try $ P.char '{' *> pure LBrace
191− , P.try $ P.char '}' *> pure RBrace
192− , P.try $ P.char '[' *> pure LSquare
193− , P.try $ P.char ']' *> pure RSquare
194− , P.try $ P.char '`' *> pure Tick
195− , P.try $ P.char ',' *> pure Comma
196− , P.try $ P.char '=' *> P.notFollowedBy symbolChar *> pure Equals
197− , P.try $ P.char ':' *> P.notFollowedBy symbolChar *> pure Colon
198− , P.try $ P.char '|' *> P.notFollowedBy symbolChar *> pure Pipe
199− , P.try $ P.char '.' *> P.notFollowedBy symbolChar *> pure Dot
200− , P.try $ P.char ';' *> P.notFollowedBy symbolChar *> pure Semi
201− , P.try $ P.char '@' *> P.notFollowedBy symbolChar *> pure At
202− , P.try $ P.char '_' *> P.notFollowedBy identLetter *> pure Underscore
203− , LName <$> parseLName
204− , do uName <- parseUName
205− (guard (validModuleName uName) >> Qualifier uName <$ P.char '.') <|> pure (UName uName)
206− , Symbol <$> parseSymbol
207− , StringLiteral <$> parseStringLiteral
208− , Number <$> parseNumber
209− ] <* whitespace
210−
211− where
212− parseLName :: P.Parsec String u String
213− parseLName = (:) <$> identStart <*> P.many identLetter
214−
215− parseUName :: P.Parsec String u String
216− parseUName = (:) <$> P.upper <*> P.many uidentLetter
217−
218− parseSymbol :: P.Parsec String u String
219− parseSymbol = P.many1 symbolChar
220−
221− identStart :: P.Parsec String u Char
222− identStart = P.lower <|> P.oneOf "_"
223−
224− identLetter :: P.Parsec String u Char
225− identLetter = P.alphaNum <|> P.oneOf "_'"
226−
227− uidentLetter :: P.Parsec String u Char
228− uidentLetter = P.alphaNum <|> P.char '_'
229−
230− symbolChar :: P.Parsec String u Char
231− symbolChar = P.oneOf opChars
232−
233− parseStringLiteral :: P.Parsec String u String
234− parseStringLiteral = blockString <|> PT.stringLiteral tokenParser
235− where
236− delimeter = P.try (P.string "\"\"\"")
237− blockString = delimeter >> P.manyTill P.anyChar delimeter
238−
239− parseNumber :: P.Parsec String u (Either Integer Double)
240− parseNumber = (Right <$> P.try (PT.float tokenParser) <|>
241− Left <$> P.try (PT.natural tokenParser)) P.<?> "number"
242−
243−-- |
244−-- We use Text.Parsec.Token to implement the string and number lexemes
245−--
246−langDef :: PT.GenLanguageDef String u Identity
247−langDef = PT.LanguageDef
248− { PT.reservedNames = []
249− , PT.reservedOpNames = []
250− , PT.commentStart = ""
251− , PT.commentEnd = ""
252− , PT.commentLine = ""
253− , PT.nestedComments = True
254− , PT.identStart = fail "Identifiers not supported"
255− , PT.identLetter = fail "Identifiers not supported"
256− , PT.opStart = fail "Operators not supported"
257− , PT.opLetter = fail "Operators not supported"
258− , PT.caseSensitive = True
259− }
260−
261−-- |
262−-- A token parser based on the language definition
263−--
264−tokenParser :: PT.GenTokenParser String u Identity
265−tokenParser = PT.makeTokenParser langDef
266−
267−type TokenParser a = P.Parsec [PositionedToken] ParseState a
268−
269−anyToken :: TokenParser PositionedToken
270−anyToken = P.token (prettyPrintToken . ptToken) ptSourcePos Just
271−
272−token :: (Token -> Maybe a) -> TokenParser a
273−token f = P.token (prettyPrintToken . ptToken) ptSourcePos (f . ptToken)
274−
275−match :: Token -> TokenParser ()
276−match tok = token (\tok' -> if tok == tok' then Just () else Nothing) P.<?> prettyPrintToken tok
277−
278−lparen :: TokenParser ()
279−lparen = match LParen
280−
281−rparen :: TokenParser ()
282−rparen = match RParen
283−
284−parens :: TokenParser a -> TokenParser a
285−parens = P.between lparen rparen
286−
287−lbrace :: TokenParser ()
288−lbrace = match LBrace
289−
290−rbrace :: TokenParser ()
291−rbrace = match RBrace
292−
293−braces :: TokenParser a -> TokenParser a
294−braces = P.between lbrace rbrace
295−
296−lsquare :: TokenParser ()
297−lsquare = match LSquare
298−
299−rsquare :: TokenParser ()
300−rsquare = match RSquare
301−
302−squares :: TokenParser a -> TokenParser a
303−squares = P.between lsquare rsquare
304−
305−indent :: TokenParser Int
306−indent = token go P.<?> "indentation"
307− where
308− go (Indent n) = Just n
309− go _ = Nothing
310−
311−indentAt :: P.Column -> TokenParser ()
312−indentAt n = token go P.<?> "indentation at level " ++ show n
313− where
314− go (Indent n') | n == n' = Just ()
315− go _ = Nothing
316−
317−larrow :: TokenParser ()
318−larrow = match LArrow
319−
320−rarrow :: TokenParser ()
321−rarrow = match RArrow
322−
323−lfatArrow :: TokenParser ()
324−lfatArrow = match LFatArrow
325−
326−rfatArrow :: TokenParser ()
327−rfatArrow = match RFatArrow
328−
329−colon :: TokenParser ()
330−colon = match Colon
331−
332−doubleColon :: TokenParser ()
333−doubleColon = match DoubleColon
334−
335−equals :: TokenParser ()
336−equals = match Equals
337−
338−pipe :: TokenParser ()
339−pipe = match Pipe
340−
341−tick :: TokenParser ()
342−tick = match Tick
343−
344−dot :: TokenParser ()
345−dot = match Dot
346−
347−comma :: TokenParser ()
348−comma = match Comma
349−
350−semi :: TokenParser ()
351−semi = match Semi
352−
353−at :: TokenParser ()
354−at = match At
355−
356−underscore :: TokenParser ()
357−underscore = match Underscore
358−
359−-- |
360−-- Parse zero or more values separated by semicolons
361−--
362−semiSep :: TokenParser a -> TokenParser [a]
363−semiSep = flip P.sepBy semi
364−
365−-- |
366−-- Parse one or more values separated by semicolons
367−--
368−semiSep1 :: TokenParser a -> TokenParser [a]
369−semiSep1 = flip P.sepBy1 semi
370−
371−-- |
372−-- Parse zero or more values separated by commas
373−--
374−commaSep :: TokenParser a -> TokenParser [a]
375−commaSep = flip P.sepBy comma
376−
377−-- |
378−-- Parse one or more values separated by commas
379−--
380−commaSep1 :: TokenParser a -> TokenParser [a]
381−commaSep1 = flip P.sepBy1 comma
382−
383−lname :: TokenParser String
384−lname = token go P.<?> "identifier"
385− where
386− go (LName s) = Just s
387− go _ = Nothing
388−
389−qualifier :: TokenParser String
390−qualifier = token go P.<?> "qualifier"
391− where
392− go (Qualifier s) = Just s
393− go _ = Nothing
394−
395−reserved :: String -> TokenParser ()
396−reserved s = token go P.<?> show s
397− where
398− go (LName s') | s == s' = Just ()
399− go _ = Nothing
400−
401−uname :: TokenParser String
402−uname = token go P.<?> "proper name"
403− where
404− go (UName s) = Just s
405− go _ = Nothing
406−
407−mname :: TokenParser String
408−mname = token go P.<?> "module name"
409− where
410− go (UName s) | validModuleName s = Just s
411− go _ = Nothing
412−
413−uname' :: String -> TokenParser ()
414−uname' s = token go P.<?> show s
415− where
416− go (UName s') | s == s' = Just ()
417− go _ = Nothing
418−
419−symbol :: TokenParser String
420−symbol = token go P.<?> "symbol"
421− where
422− go (Symbol s) = Just s
423− go Colon = Just ":"
424− go LFatArrow = Just "<="
425− go At = Just "@"
426− go _ = Nothing
427−
428−symbol' :: String -> TokenParser ()
429−symbol' s = token go P.<?> show s
430− where
431− go (Symbol s') | s == s' = Just ()
432− go Colon | s == ":" = Just ()
433− go LFatArrow | s == "<=" = Just ()
434− go _ = Nothing
435−
436−stringLiteral :: TokenParser String
437−stringLiteral = token go P.<?> "string literal"
438− where
439− go (StringLiteral s) = Just s
440− go _ = Nothing
441−
442−number :: TokenParser (Either Integer Double)
443−number = token go P.<?> "number"
444− where
445− go (Number n) = Just n
446− go _ = Nothing
447−
448−natural :: TokenParser Integer
449−natural = token go P.<?> "natural"
450− where
451− go (Number (Left n)) = Just n
452− go _ = Nothing
453−
454−identifier :: TokenParser String
455−identifier = token go P.<?> "identifier"
456− where
457− go (LName s) | s `notElem` reservedPsNames = Just s
458− go _ = Nothing
459−
460−validModuleName :: String -> Bool
461−validModuleName s = not ('_' `elem` s)
462−
463−-- |
464−-- A list of purescript reserved identifiers
465−--
466−reservedPsNames :: [String]
467−reservedPsNames = [ "data"
468− , "newtype"
469− , "type"
470− , "foreign"
471− , "import"
472− , "infixl"
473− , "infixr"
474− , "infix"
475− , "class"
476− , "instance"
477− , "module"
478− , "case"
479− , "of"
480− , "if"
481− , "then"
482− , "else"
483− , "do"
484− , "let"
485− , "true"
486− , "false"
487− , "in"
488− , "where"
489− ]
490−
491−reservedTypeNames :: [String]
492−reservedTypeNames = [ "forall", "where" ]
493−
494−-- |
495−-- The characters allowed for use in operators
496−--
497−opChars :: [Char]
498−opChars = ":!#$%&*+./<=>?@\\^|-~"
499−
src/Language/PureScript/Parser/State.hsdeleted−30
@@ -1,30 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.Parser.State
4−-- Copyright : (c) Phil Freeman 2013
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- |
12−-- State for the parser monad
13−--
14−-----------------------------------------------------------------------------
15−
16−module Language.PureScript.Parser.State where
17−
18−import qualified Text.Parsec as P
19−
20−-- |
21−-- State for the parser monad
22−--
23−data ParseState = ParseState {
24− -- |
25− -- The most recently marked indentation level
26− --
27− indentationLevel :: P.Column
28− } deriving Show
29−
30−
src/Language/PureScript/Parser/Types.hsdeleted−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 = underscore >> return TypeWildcard
49−
50−parseTypeVariable :: TokenParser Type
51−parseTypeVariable = do
52− ident <- identifier
53− when (ident `elem` reservedTypeNames) $ P.unexpected ident
54− return $ TypeVar ident
55−
56−parseTypeConstructor :: TokenParser Type
57−parseTypeConstructor = TypeConstructor <$> parseQualified properName
58−
59−parseForAll :: TokenParser Type
60−parseForAll = mkForAll <$> (P.try (reserved "forall") *> P.many1 (indented *> identifier) <* indented <* dot)
61− <*> parseConstrainedType
62−
63−-- |
64−-- Parse a type as it appears in e.g. a data constructor
65−--
66−parseTypeAtom :: TokenParser Type
67−parseTypeAtom = indented *> P.choice (map P.try
68− [ parseArray
69− , parseArrayOf
70− , parseFunction
71− , parseObject
72− , parseTypeWildcard
73− , parseTypeVariable
74− , parseTypeConstructor
75− , parseForAll
76− , parens parseRow
77− , parens parsePolyType ])
78−
79−parseConstrainedType :: TokenParser Type
80−parseConstrainedType = do
81− constraints <- P.optionMaybe . P.try $ do
82− constraints <- parens . commaSep1 $ do
83− className <- parseQualified properName
84− indented
85− ty <- P.many parseTypeAtom
86− return (className, ty)
87− _ <- rfatArrow
88− return constraints
89− indented
90− ty <- parseType
91− return $ maybe ty (flip ConstrainedType ty) constraints
92−
93−parseAnyType :: TokenParser Type
94−parseAnyType = P.buildExpressionParser operators (buildPostfixParser postfixTable parseTypeAtom) P.<?> "type"
95− where
96− operators = [ [ P.Infix (return TypeApp) P.AssocLeft ]
97− , [ P.Infix (rarrow >> return function) P.AssocRight ] ]
98− postfixTable = [ \t -> KindedType t <$> (P.try (indented *> doubleColon) *> parseKind)
99− ]
100−
101−-- |
102−-- Parse a monotype
103−--
104−parseType :: TokenParser Type
105−parseType = do
106− ty <- parseAnyType
107− unless (isMonoType ty) $ P.unexpected "polymorphic type"
108− return ty
109−
110−-- |
111−-- Parse a polytype
112−--
113−parsePolyType :: TokenParser Type
114−parsePolyType = parseAnyType
115−
116−-- |
117−-- Parse an atomic type with no wildcards
118−--
119−noWildcards :: TokenParser Type -> TokenParser Type
120−noWildcards p = do
121− ty <- p
122− when (containsWildcards ty) $ P.unexpected "type wildcard"
123− return ty
124−
125−parseNameAndType :: TokenParser t -> TokenParser (String, t)
126−parseNameAndType p = (,) <$> (indented *> (lname <|> stringLiteral) <* indented <* doubleColon) <*> p
127−
128−parseRowEnding :: TokenParser Type
129−parseRowEnding = P.option REmpty $ indented *> pipe *> indented *> parseType
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−301
@@ -1,301 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.Pretty.JS
4−-- Copyright : (c) Phil Freeman 2013
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- |
12−-- Pretty printer for the Javascript AST
13−--
14−-----------------------------------------------------------------------------
15−
16−module Language.PureScript.Pretty.JS (
17− prettyPrintJS
18−) where
19−
20−import Data.List
21−import Data.Maybe (fromMaybe)
22−
23−import Control.Applicative
24−import Control.Arrow ((<+>))
25−import Control.Monad.State
26−import Control.PatternArrows
27−import qualified Control.Arrow as A
28−
29−import Language.PureScript.CodeGen.JS.AST
30−import Language.PureScript.CodeGen.JS.Common
31−import Language.PureScript.Pretty.Common
32−import Language.PureScript.Comments
33−
34−import Numeric
35−
36−literals :: Pattern PrinterState JS String
37−literals = mkPattern' match
38− where
39− match :: JS -> StateT PrinterState Maybe String
40− match (JSNumericLiteral n) = return $ either show show n
41− match (JSStringLiteral s) = return $ string s
42− match (JSBooleanLiteral True) = return "true"
43− match (JSBooleanLiteral False) = return "false"
44− match (JSArrayLiteral xs) = fmap concat $ sequence
45− [ return "[ "
46− , fmap (intercalate ", ") $ forM xs prettyPrintJS'
47− , return " ]"
48− ]
49− match (JSObjectLiteral []) = return "{}"
50− match (JSObjectLiteral ps) = fmap concat $ sequence
51− [ return "{\n"
52− , withIndent $ do
53− jss <- forM ps $ \(key, value) -> fmap ((objectPropertyToString key ++ ": ") ++) . prettyPrintJS' $ value
54− indentString <- currentIndent
55− return $ intercalate ", \n" $ map (indentString ++) jss
56− , return "\n"
57− , currentIndent
58− , return "}"
59− ]
60− where
61− objectPropertyToString :: String -> String
62− objectPropertyToString s | identNeedsEscaping s = show s
63− | otherwise = s
64− match (JSBlock sts) = fmap concat $ sequence
65− [ return "{\n"
66− , withIndent $ prettyStatements sts
67− , return "\n"
68− , currentIndent
69− , return "}"
70− ]
71− match (JSVar ident) = return ident
72− match (JSVariableIntroduction ident value) = fmap concat $ sequence
73− [ return "var "
74− , return ident
75− , maybe (return "") (fmap (" = " ++) . prettyPrintJS') value
76− ]
77− match (JSAssignment target value) = fmap concat $ sequence
78− [ prettyPrintJS' target
79− , return " = "
80− , prettyPrintJS' value
81− ]
82− match (JSWhile cond sts) = fmap concat $ sequence
83− [ return "while ("
84− , prettyPrintJS' cond
85− , return ") "
86− , prettyPrintJS' sts
87− ]
88− match (JSFor ident start end sts) = fmap concat $ sequence
89− [ return $ "for (var " ++ ident ++ " = "
90− , prettyPrintJS' start
91− , return $ "; " ++ ident ++ " < "
92− , prettyPrintJS' end
93− , return $ "; " ++ ident ++ "++) "
94− , prettyPrintJS' sts
95− ]
96− match (JSForIn ident obj sts) = fmap concat $ sequence
97− [ return $ "for (var " ++ ident ++ " in "
98− , prettyPrintJS' obj
99− , return ") "
100− , prettyPrintJS' sts
101− ]
102− match (JSIfElse cond thens elses) = fmap concat $ sequence
103− [ return "if ("
104− , prettyPrintJS' cond
105− , return ") "
106− , prettyPrintJS' thens
107− , maybe (return "") (fmap (" else " ++) . prettyPrintJS') elses
108− ]
109− match (JSReturn value) = fmap concat $ sequence
110− [ return "return "
111− , prettyPrintJS' value
112− ]
113− match (JSThrow value) = fmap concat $ sequence
114− [ return "throw "
115− , prettyPrintJS' value
116− ]
117− match (JSBreak lbl) = return $ "break " ++ lbl
118− match (JSContinue lbl) = return $ "continue " ++ lbl
119− match (JSLabel lbl js) = fmap concat $ sequence
120− [ return $ lbl ++ ": "
121− , prettyPrintJS' js
122− ]
123− match (JSComment com js) = fmap concat $ sequence $
124− [ return "\n"
125− , currentIndent
126− , return "/**\n"
127− ] ++
128− map asLine (concatMap commentLines com) ++
129− [ currentIndent
130− , return " */\n"
131− , currentIndent
132− , prettyPrintJS' js
133− ]
134− where
135− commentLines :: Comment -> [String]
136− commentLines (LineComment s) = [s]
137− commentLines (BlockComment s) = lines s
138−
139− asLine :: String -> StateT PrinterState Maybe String
140− asLine s = do
141− i <- currentIndent
142− return $ i ++ " * " ++ removeComments s ++ "\n"
143−
144− removeComments :: String -> String
145− removeComments ('*' : '/' : s) = removeComments s
146− removeComments (c : s) = c : removeComments s
147−
148− removeComments [] = []
149− match (JSRaw js) = return js
150− match _ = mzero
151−
152−string :: String -> String
153−string s = '"' : concatMap encodeChar s ++ "\""
154− where
155− encodeChar :: Char -> String
156− encodeChar '\b' = "\\b"
157− encodeChar '\t' = "\\t"
158− encodeChar '\n' = "\\n"
159− encodeChar '\v' = "\\v"
160− encodeChar '\f' = "\\f"
161− encodeChar '\r' = "\\r"
162− encodeChar '"' = "\\\""
163− encodeChar '\\' = "\\\\"
164− encodeChar c | fromEnum c > 0xFFF = "\\u" ++ showHex (fromEnum c) ""
165− encodeChar c | fromEnum c > 0xFF = "\\u0" ++ showHex (fromEnum c) ""
166− encodeChar c = [c]
167−
168−conditional :: Pattern PrinterState JS ((JS, JS), JS)
169−conditional = mkPattern match
170− where
171− match (JSConditional cond th el) = Just ((th, el), cond)
172− match _ = Nothing
173−
174−accessor :: Pattern PrinterState JS (String, JS)
175−accessor = mkPattern match
176− where
177− match (JSAccessor prop val) = Just (prop, val)
178− match _ = Nothing
179−
180−indexer :: Pattern PrinterState JS (String, JS)
181−indexer = mkPattern' match
182− where
183− match (JSIndexer index val) = (,) <$> prettyPrintJS' index <*> pure val
184− match _ = mzero
185−
186−lam :: Pattern PrinterState JS ((Maybe String, [String]), JS)
187−lam = mkPattern match
188− where
189− match (JSFunction name args ret) = Just ((name, args), ret)
190− match _ = Nothing
191−
192−app :: Pattern PrinterState JS (String, JS)
193−app = mkPattern' match
194− where
195− match (JSApp val args) = do
196− jss <- mapM prettyPrintJS' args
197− return (intercalate ", " jss, val)
198− match _ = mzero
199−
200−typeOf :: Pattern PrinterState JS ((), JS)
201−typeOf = mkPattern match
202− where
203− match (JSTypeOf val) = Just ((), val)
204− match _ = Nothing
205−
206−instanceOf :: Pattern PrinterState JS (JS, JS)
207−instanceOf = mkPattern match
208− where
209− match (JSInstanceOf val ty) = Just (val, ty)
210− match _ = Nothing
211−
212−unary' :: UnaryOperator -> (JS -> String) -> Operator PrinterState JS String
213−unary' op mkStr = Wrap match (++)
214− where
215− match :: Pattern PrinterState JS (String, JS)
216− match = mkPattern match'
217− where
218− match' (JSUnary op' val) | op' == op = Just (mkStr val, val)
219− match' _ = Nothing
220−
221−unary :: UnaryOperator -> String -> Operator PrinterState JS String
222−unary op str = unary' op (const str)
223−
224−negateOperator :: Operator PrinterState JS String
225−negateOperator = unary' Negate (\v -> if isNegate v then "- " else "-")
226− where
227− isNegate (JSUnary Negate _) = True
228− isNegate _ = False
229−
230−binary :: BinaryOperator -> String -> Operator PrinterState JS String
231−binary op str = AssocL match (\v1 v2 -> v1 ++ " " ++ str ++ " " ++ v2)
232− where
233− match :: Pattern PrinterState JS (JS, JS)
234− match = mkPattern match'
235− where
236− match' (JSBinary op' v1 v2) | op' == op = Just (v1, v2)
237− match' _ = Nothing
238−
239−prettyStatements :: [JS] -> StateT PrinterState Maybe String
240−prettyStatements sts = do
241− jss <- forM sts prettyPrintJS'
242− indentString <- currentIndent
243− return $ intercalate "\n" $ map ((++ ";") . (indentString ++)) jss
244−
245−-- |
246−-- Generate a pretty-printed string representing a Javascript expression
247−--
248−prettyPrintJS1 :: JS -> String
249−prettyPrintJS1 = fromMaybe (error "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyPrintJS'
250−
251−-- |
252−-- Generate a pretty-printed string representing a collection of Javascript expressions at the same indentation level
253−--
254−prettyPrintJS :: [JS] -> String
255−prettyPrintJS = fromMaybe (error "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyStatements
256−
257−-- |
258−-- Generate an indented, pretty-printed string representing a Javascript expression
259−--
260−prettyPrintJS' :: JS -> StateT PrinterState Maybe String
261−prettyPrintJS' = A.runKleisli $ runPattern matchValue
262− where
263− matchValue :: Pattern PrinterState JS String
264− matchValue = buildPrettyPrinter operators (literals <+> fmap parens matchValue)
265− operators :: OperatorTable PrinterState JS String
266− operators =
267− OperatorTable [ [ Wrap accessor $ \prop val -> val ++ "." ++ prop ]
268− , [ Wrap indexer $ \index val -> val ++ "[" ++ index ++ "]" ]
269− , [ Wrap app $ \args val -> val ++ "(" ++ args ++ ")" ]
270− , [ unary JSNew "new " ]
271− , [ Wrap lam $ \(name, args) ret -> "function "
272− ++ fromMaybe "" name
273− ++ "(" ++ intercalate ", " args ++ ") "
274− ++ ret ]
275− , [ Wrap typeOf $ \_ s -> "typeof " ++ s ]
276− , [ unary Not "!"
277− , unary BitwiseNot "~"
278− , unary Positive "+"
279− , negateOperator ]
280− , [ binary Multiply "*"
281− , binary Divide "/"
282− , binary Modulus "%" ]
283− , [ binary Add "+"
284− , binary Subtract "-" ]
285− , [ binary ShiftLeft "<<"
286− , binary ShiftRight ">>"
287− , binary ZeroFillShiftRight ">>>" ]
288− , [ binary LessThan "<"
289− , binary LessThanOrEqualTo "<="
290− , binary GreaterThan ">"
291− , binary GreaterThanOrEqualTo ">="
292− , AssocR instanceOf $ \v1 v2 -> v1 ++ " instanceof " ++ v2 ]
293− , [ binary EqualTo "==="
294− , binary NotEqualTo "!==" ]
295− , [ binary BitwiseAnd "&" ]
296− , [ binary BitwiseXor "^" ]
297− , [ binary BitwiseOr "|" ]
298− , [ binary And "&&" ]
299− , [ binary Or "||" ]
300− , [ Wrap conditional $ \(th, el) cond -> cond ++ " ? " ++ prettyPrintJS1 th ++ " : " ++ prettyPrintJS1 el ]
301− ]
src/Language/PureScript/Pretty/Kinds.hsdeleted−59
@@ -1,59 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.Pretty.Kinds
4−-- Copyright : (c) Phil Freeman 2013
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- |
12−-- Pretty printer for kinds
13−--
14−-----------------------------------------------------------------------------
15−
16−module Language.PureScript.Pretty.Kinds (
17− prettyPrintKind
18−) where
19−
20−import Data.Maybe (fromMaybe)
21−
22−import Control.Arrow (ArrowPlus(..))
23−import Control.PatternArrows
24−
25−import Language.PureScript.Kinds
26−import Language.PureScript.Pretty.Common
27−
28−typeLiterals :: Pattern () Kind String
29−typeLiterals = mkPattern match
30− where
31− match Star = Just "*"
32− match Bang = Just "!"
33− match (KUnknown u) = Just $ 'u' : show u
34− match _ = Nothing
35−
36−matchRow :: Pattern () Kind ((), Kind)
37−matchRow = mkPattern match
38− where
39− match (Row k) = Just ((), k)
40− match _ = Nothing
41−
42−funKind :: Pattern () Kind (Kind, Kind)
43−funKind = mkPattern match
44− where
45− match (FunKind arg ret) = Just (arg, ret)
46− match _ = Nothing
47−
48−-- |
49−-- Generate a pretty-printed string representing a Kind
50−--
51−prettyPrintKind :: Kind -> String
52−prettyPrintKind = fromMaybe (error "Incomplete pattern") . pattern matchKind ()
53− where
54− matchKind :: Pattern () Kind String
55− matchKind = buildPrettyPrinter operators (typeLiterals <+> fmap parens matchKind)
56− operators :: OperatorTable () Kind String
57− operators =
58− OperatorTable [ [ Wrap matchRow $ \_ k -> "# " ++ k]
59− , [ AssocR funKind $ \arg ret -> arg ++ " -> " ++ ret ] ]
src/Language/PureScript/Pretty/Types.hsdeleted−129
@@ -1,129 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.Pretty.Types
4−-- Copyright : (c) Phil Freeman 2013
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- |
12−-- Pretty printer for Types
13−--
14−-----------------------------------------------------------------------------
15−
16−module Language.PureScript.Pretty.Types (
17− prettyPrintType,
18− prettyPrintTypeAtom,
19− prettyPrintRow
20−) where
21−
22−import Data.Maybe (fromMaybe)
23−import Data.List (intercalate)
24−
25−import Control.Arrow ((<+>))
26−import Control.PatternArrows
27−
28−import Language.PureScript.Types
29−import Language.PureScript.Kinds
30−import Language.PureScript.Pretty.Common
31−import Language.PureScript.Pretty.Kinds
32−import Language.PureScript.Environment
33−
34−typeLiterals :: Pattern () Type String
35−typeLiterals = mkPattern match
36− where
37− match TypeWildcard = Just "_"
38− match (TypeVar var) = Just var
39− match (PrettyPrintObject row) = Just $ "{ " ++ prettyPrintRow row ++ " }"
40− match (PrettyPrintArray ty) = Just $ "[" ++ prettyPrintType ty ++ "]"
41− match (TypeConstructor ctor) = Just $ show ctor
42− match (TUnknown u) = Just $ 'u' : show u
43− match (Skolem name s _) = Just $ name ++ show s
44− match (ConstrainedType deps ty) = Just $ "(" ++ intercalate ", " (map (\(pn, ty') -> show pn ++ " " ++ unwords (map prettyPrintTypeAtom ty')) deps) ++ ") => " ++ prettyPrintType ty
45− match (SaturatedTypeSynonym name args) = Just $ show name ++ "<" ++ intercalate "," (map prettyPrintTypeAtom args) ++ ">"
46− match REmpty = Just "()"
47− match row@RCons{} = Just $ '(' : prettyPrintRow row ++ ")"
48− match _ = Nothing
49−
50−-- |
51−-- Generate a pretty-printed string representing a Row
52−--
53−prettyPrintRow :: Type -> String
54−prettyPrintRow = (\(tys, rest) -> intercalate ", " (map (uncurry nameAndTypeToPs) tys) ++ tailToPs rest) . toList []
55− where
56− nameAndTypeToPs :: String -> Type -> String
57− nameAndTypeToPs name ty = prettyPrintObjectKey name ++ " :: " ++ prettyPrintType ty
58− tailToPs :: Type -> String
59− tailToPs REmpty = ""
60− tailToPs other = " | " ++ prettyPrintType other
61− toList :: [(String, Type)] -> Type -> ([(String, Type)], Type)
62− toList tys (RCons name ty row) = toList ((name, ty):tys) row
63− toList tys r = (tys, r)
64−
65−typeApp :: Pattern () Type (Type, Type)
66−typeApp = mkPattern match
67− where
68− match (TypeApp f x) = Just (f, x)
69− match _ = Nothing
70−
71−appliedFunction :: Pattern () Type (Type, Type)
72−appliedFunction = mkPattern match
73− where
74− match (PrettyPrintFunction arg ret) = Just (arg, ret)
75− match _ = Nothing
76−
77−kinded :: Pattern () Type (Kind, Type)
78−kinded = mkPattern match
79− where
80− match (KindedType t k) = Just (k, t)
81− match _ = Nothing
82−
83−insertPlaceholders :: Type -> Type
84−insertPlaceholders = everywhereOnTypesTopDown convertForAlls . everywhereOnTypes convert
85− where
86− convert (TypeApp (TypeApp f arg) ret) | f == tyFunction = PrettyPrintFunction arg ret
87− convert (TypeApp a el) | a == tyArray = PrettyPrintArray el
88− convert (TypeApp o r) | o == tyObject = PrettyPrintObject r
89− convert other = other
90− convertForAlls (ForAll ident ty _) = go [ident] ty
91− where
92− go idents (ForAll ident' ty' _) = go (ident' : idents) ty'
93− go idents other = PrettyPrintForAll idents other
94− convertForAlls other = other
95−
96−matchTypeAtom :: Pattern () Type String
97−matchTypeAtom = typeLiterals <+> fmap parens matchType
98−
99−matchType :: Pattern () Type String
100−matchType = buildPrettyPrinter operators matchTypeAtom
101− where
102− operators :: OperatorTable () Type String
103− operators =
104− OperatorTable [ [ AssocL typeApp $ \f x -> f ++ " " ++ x ]
105− , [ AssocR appliedFunction $ \arg ret -> arg ++ " -> " ++ ret
106− ]
107− , [ Wrap forall_ $ \idents ty -> "forall " ++ unwords idents ++ ". " ++ ty ]
108− , [ Wrap kinded $ \k ty -> ty ++ " :: " ++ prettyPrintKind k ]
109− ]
110−
111−forall_ :: Pattern () Type ([String], Type)
112−forall_ = mkPattern match
113− where
114− match (PrettyPrintForAll idents ty) = Just (idents, ty)
115− match _ = Nothing
116−
117−-- |
118−-- Generate a pretty-printed string representing a Type, as it should appear inside parentheses
119−--
120−prettyPrintTypeAtom :: Type -> String
121−prettyPrintTypeAtom = fromMaybe (error "Incomplete pattern") . pattern matchTypeAtom () . insertPlaceholders
122−
123−
124−-- |
125−-- Generate a pretty-printed string representing a Type
126−--
127−prettyPrintType :: Type -> String
128−prettyPrintType = fromMaybe (error "Incomplete pattern") . pattern matchType () . insertPlaceholders
129−
src/Language/PureScript/Pretty/Values.hsdeleted−250
@@ -1,250 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.Pretty.Values
4−-- Copyright : (c) Phil Freeman 2013
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- |
12−-- Pretty printer for values
13−--
14−-----------------------------------------------------------------------------
15−
16−module Language.PureScript.Pretty.Values (
17− prettyPrintValue,
18− prettyPrintBinder
19−) where
20−
21−import Data.Maybe (fromMaybe)
22−import Data.List (intercalate)
23−
24−import Control.Arrow ((<+>), runKleisli, second)
25−import Control.PatternArrows
26−import Control.Monad.State
27−import Control.Applicative
28−
29−import Language.PureScript.AST
30−import Language.PureScript.Names
31−import Language.PureScript.Pretty.Common
32−import Language.PureScript.Pretty.Types (prettyPrintType, prettyPrintTypeAtom)
33−
34−literals :: Pattern PrinterState Expr String
35−literals = mkPattern' match
36− where
37− match :: Expr -> StateT PrinterState Maybe String
38− match (NumericLiteral n) = return $ either show show n
39− match (StringLiteral s) = return $ show s
40− match (BooleanLiteral True) = return "true"
41− match (BooleanLiteral False) = return "false"
42− match (ArrayLiteral xs) = concat <$> sequence
43− [ return "[ "
44− , withIndent $ prettyPrintMany prettyPrintValue' xs
45− , return " ]"
46− ]
47− match (ObjectLiteral ps) = prettyPrintObject' $ second Just `map` ps
48− match (ObjectConstructor ps) = prettyPrintObject' ps
49− match (ObjectGetter prop) = return $ "(." ++ prop ++ ")"
50− match (TypeClassDictionaryConstructorApp className ps) = concat <$> sequence
51− [ return (show className ++ "(\n")
52− , match ps
53− , return ")"
54− ]
55− match (Constructor name) = return $ show name
56− match (Case values binders) = concat <$> sequence
57− [ return "case "
58− , unwords <$> forM values prettyPrintValue'
59− , return " of\n"
60− , withIndent $ prettyPrintMany prettyPrintCaseAlternative binders
61− , currentIndent
62− ]
63− match (Let ds val) = concat <$> sequence
64− [ return "let\n"
65− , withIndent $ prettyPrintMany prettyPrintDeclaration ds
66− , return "\n"
67− , currentIndent
68− , return "in "
69− , prettyPrintValue' val
70− ]
71− match (Var ident) = return $ show ident
72− match (Do els) = concat <$> sequence
73− [ return "do "
74− , withIndent $ prettyPrintMany prettyPrintDoNotationElement els
75− , currentIndent
76− ]
77− match (OperatorSection op (Right val)) = return $ "(" ++ prettyPrintValue op ++ " " ++ prettyPrintValue val ++ ")"
78− match (OperatorSection op (Left val)) = return $ "(" ++ prettyPrintValue val ++ " " ++ prettyPrintValue op ++ ")"
79− match (TypeClassDictionary _ (name, tys) _) = return $ "<<dict " ++ show name ++ " " ++ unwords (map prettyPrintTypeAtom tys) ++ ">>"
80− match (SuperClassDictionary name _) = return $ "<<superclass dict " ++ show name ++ ">>"
81− match (TypedValue _ val _) = prettyPrintValue' val
82− match (PositionedValue _ _ val) = prettyPrintValue' val
83− match _ = mzero
84−
85−prettyPrintDeclaration :: Declaration -> StateT PrinterState Maybe String
86−prettyPrintDeclaration (TypeDeclaration ident ty) = return $ show ident ++ " :: " ++ prettyPrintType ty
87−prettyPrintDeclaration (ValueDeclaration ident _ [] (Right val)) = concat <$> sequence
88− [ return $ show ident ++ " = "
89− , prettyPrintValue' val
90− ]
91−prettyPrintDeclaration (PositionedDeclaration _ _ d) = prettyPrintDeclaration d
92−prettyPrintDeclaration _ = error "Invalid argument to prettyPrintDeclaration"
93−
94−prettyPrintCaseAlternative :: CaseAlternative -> StateT PrinterState Maybe String
95−prettyPrintCaseAlternative (CaseAlternative binders result) =
96− concat <$> sequence
97− [ intercalate ", " <$> forM binders prettyPrintBinder'
98− , prettyPrintResult result
99− ]
100− where
101− prettyPrintResult (Left gs) = concat <$> mapM prettyPrintGuardedValue gs
102− prettyPrintResult (Right v) = (" -> " ++) <$> prettyPrintValue' v
103−
104− prettyPrintGuardedValue (grd, val) =
105− concat <$> sequence
106− [ return "| "
107− , prettyPrintValue' grd
108− , return " -> "
109− , prettyPrintValue' val
110− , return "\n"
111− ]
112−
113−prettyPrintDoNotationElement :: DoNotationElement -> StateT PrinterState Maybe String
114−prettyPrintDoNotationElement (DoNotationValue val) =
115− prettyPrintValue' val
116−prettyPrintDoNotationElement (DoNotationBind binder val) =
117− concat <$> sequence
118− [ prettyPrintBinder' binder
119− , return " <- "
120− , prettyPrintValue' val
121− ]
122−prettyPrintDoNotationElement (DoNotationLet ds) =
123− concat <$> sequence
124− [ return "let "
125− , withIndent $ prettyPrintMany prettyPrintDeclaration ds
126− ]
127−prettyPrintDoNotationElement (PositionedDoNotationElement _ _ el) = prettyPrintDoNotationElement el
128−
129−prettyPrintObject' :: [(String, Maybe Expr)] -> StateT PrinterState Maybe String
130−prettyPrintObject' [] = return "{}"
131−prettyPrintObject' ps = concat <$> sequence
132− [ return "{\n"
133− , withIndent $ prettyPrintMany prettyPrintObjectProperty ps
134− , return "\n"
135− , currentIndent
136− , return "}"
137− ]
138−
139−ifThenElse :: Pattern PrinterState Expr ((Expr, Expr), Expr)
140−ifThenElse = mkPattern match
141− where
142− match (IfThenElse cond th el) = Just ((th, el), cond)
143− match _ = Nothing
144−
145−accessor :: Pattern PrinterState Expr (String, Expr)
146−accessor = mkPattern match
147− where
148− match (Accessor prop val) = Just (prop, val)
149− match _ = Nothing
150−
151−objectUpdate :: Pattern PrinterState Expr ([String], Expr)
152−objectUpdate = mkPattern match
153− where
154− match (ObjectUpdate o ps) = Just (flip map ps $ \(key, val) -> key ++ " = " ++ prettyPrintValue val, o)
155− match (ObjectUpdater o ps) = Just (flip map ps $ \(key, val) -> key ++ " = " ++ maybe "_" prettyPrintValue val, fromMaybe (Var (Qualified Nothing $ Ident "_")) o)
156− match _ = Nothing
157−
158−app :: Pattern PrinterState Expr (String, Expr)
159−app = mkPattern match
160− where
161− match (App val arg) = Just (prettyPrintValue arg, val)
162− match _ = Nothing
163−
164−lam :: Pattern PrinterState Expr (String, Expr)
165−lam = mkPattern match
166− where
167− match (Abs (Left arg) val) = Just (show arg, val)
168− match _ = Nothing
169−
170−-- |
171−-- Generate a pretty-printed string representing an expression
172−--
173−prettyPrintValue :: Expr -> String
174−prettyPrintValue = fromMaybe (error "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyPrintValue'
175−
176−prettyPrintValue' :: Expr -> StateT PrinterState Maybe String
177−prettyPrintValue' = runKleisli $ runPattern matchValue
178− where
179− matchValue :: Pattern PrinterState Expr String
180− matchValue = buildPrettyPrinter operators (literals <+> fmap parens matchValue)
181− operators :: OperatorTable PrinterState Expr String
182− operators =
183− OperatorTable [ [ Wrap accessor $ \prop val -> val ++ "." ++ prop ]
184− , [ Wrap objectUpdate $ \ps val -> val ++ "{ " ++ intercalate ", " ps ++ " }" ]
185− , [ Wrap app $ \arg val -> val ++ "(" ++ arg ++ ")" ]
186− , [ Split lam $ \arg val -> "\\" ++ arg ++ " -> " ++ prettyPrintValue val ]
187− , [ Wrap ifThenElse $ \(th, el) cond -> "if " ++ cond ++ " then " ++ prettyPrintValue th ++ " else " ++ prettyPrintValue el ]
188− ]
189−
190−prettyPrintBinderAtom :: Pattern PrinterState Binder String
191−prettyPrintBinderAtom = mkPattern' match
192− where
193− match :: Binder -> StateT PrinterState Maybe String
194− match NullBinder = return "_"
195− match (StringBinder str) = return $ show str
196− match (NumberBinder num) = return $ either show show num
197− match (BooleanBinder True) = return "true"
198− match (BooleanBinder False) = return "false"
199− match (VarBinder ident) = return $ show ident
200− match (ConstructorBinder ctor args) = concat <$> sequence
201− [ return $ show ctor ++ " "
202− , unwords <$> forM args match
203− ]
204− match (ObjectBinder bs) = concat <$> sequence
205− [ return "{\n"
206− , withIndent $ prettyPrintMany prettyPrintObjectPropertyBinder bs
207− , currentIndent
208− , return "}"
209− ]
210− match (ArrayBinder bs) = concat <$> sequence
211− [ return "["
212− , unwords <$> mapM prettyPrintBinder' bs
213− , return "]"
214− ]
215− match (NamedBinder ident binder) = ((show ident ++ "@") ++) <$> prettyPrintBinder' binder
216− match (PositionedBinder _ _ binder) = prettyPrintBinder' binder
217− match _ = mzero
218−
219−-- |
220−-- Generate a pretty-printed string representing a Binder
221−--
222−prettyPrintBinder :: Binder -> String
223−prettyPrintBinder = fromMaybe (error "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyPrintBinder'
224−
225−prettyPrintBinder' :: Binder -> StateT PrinterState Maybe String
226−prettyPrintBinder' = runKleisli $ runPattern matchBinder
227− where
228− matchBinder :: Pattern PrinterState Binder String
229− matchBinder = buildPrettyPrinter operators (prettyPrintBinderAtom <+> fmap parens matchBinder)
230− operators :: OperatorTable PrinterState Binder String
231− operators =
232− OperatorTable [ [ AssocR matchConsBinder (\b1 b2 -> b1 ++ " : " ++ b2) ] ]
233−
234−matchConsBinder :: Pattern PrinterState Binder (Binder, Binder)
235−matchConsBinder = mkPattern match'
236− where
237− match' (ConsBinder b1 b2) = Just (b1, b2)
238− match' _ = Nothing
239−
240−prettyPrintObjectPropertyBinder :: (String, Binder) -> StateT PrinterState Maybe String
241−prettyPrintObjectPropertyBinder (key, binder) = concat <$> sequence
242− [ return $ prettyPrintObjectKey key ++ ": "
243− , prettyPrintBinder' binder
244− ]
245−
246−prettyPrintObjectProperty :: (String, Maybe Expr) -> StateT PrinterState Maybe String
247−prettyPrintObjectProperty (key, value) = concat <$> sequence
248− [ return $ prettyPrintObjectKey key ++ ": "
249− , maybe (pure "_") prettyPrintValue' value
250− ]
src/Language/PureScript/Renamer.hsdeleted−196
@@ -1,196 +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−{-# LANGUAGE FlexibleContexts, ScopedTypeVariables #-}
18−
19−module Language.PureScript.Renamer (renameInModules) where
20−
21−import Control.Applicative
22−import Control.Monad.State
23−
24−import Data.List (find)
25−
26−import qualified Data.Map as M
27−import qualified Data.Set as S
28−
29−import Language.PureScript.CoreFn
30−import Language.PureScript.Names
31−import Language.PureScript.Traversals
32−
33−import qualified Language.PureScript.Constants as C
34−
35−-- |
36−-- The state object used in this module
37−--
38−data RenameState = RenameState {
39− -- |
40− -- A map from names bound (in the input) to their names (in the output)
41− --
42− rsBoundNames :: M.Map Ident Ident
43− -- |
44− -- The set of names which have been used and are in scope in the output
45− --
46− , rsUsedNames :: S.Set Ident
47− }
48−
49−type Rename = State RenameState
50−
51−initState :: [Ident] -> RenameState
52−initState scope = RenameState (M.fromList (zip scope scope)) (S.fromList scope)
53−
54−-- |
55−-- Runs renaming starting with a list of idents for the initial scope.
56−--
57−runRename :: [Ident] -> Rename a -> a
58−runRename scope = flip evalState (initState scope)
59−
60−-- |
61−-- Creates a new renaming scope using the current as a basis. Used to backtrack
62−-- when leaving an Abs.
63−--
64−newScope :: Rename a -> Rename a
65−newScope x = do
66− scope <- get
67− a <- x
68− put scope
69− return a
70−
71−-- |
72−-- Adds a new scope entry for an ident. If the ident is already present, a new
73−-- unique name is generated and stored.
74−--
75−updateScope :: Ident -> Rename Ident
76−updateScope i@(Ident name) | name == C.__unused = return i
77−updateScope name = do
78− scope <- get
79− name' <- case name `S.member` rsUsedNames scope of
80− True -> do
81− let newNames = [ Ident (runIdent name ++ "_" ++ show (i :: Int)) | i <- [1..] ]
82− Just newName = find (`S.notMember` rsUsedNames scope) newNames
83− return newName
84− False -> return name
85− modify $ \s -> s { rsBoundNames = M.insert name name' (rsBoundNames s)
86− , rsUsedNames = S.insert name' (rsUsedNames s)
87− }
88− return name'
89−
90−-- |
91−-- Finds the new name to use for an ident.
92−--
93−lookupIdent :: Ident -> Rename Ident
94−lookupIdent i@(Ident name) | name == C.__unused = return i
95−lookupIdent name = do
96− name' <- gets $ M.lookup name . rsBoundNames
97− case name' of
98− Just name'' -> return name''
99− Nothing -> error $ "Rename scope is missing ident '" ++ show name ++ "'"
100−
101−-- |
102−-- Finds idents introduced by declarations.
103−--
104−findDeclIdents :: [Bind Ann] -> [Ident]
105−findDeclIdents = concatMap go
106− where
107− go (NonRec ident _) = [ident]
108− go (Rec ds) = map fst ds
109−
110−-- |
111−-- Renames within each declaration in a module.
112−--
113−renameInModules :: [Module Ann] -> [Module Ann]
114−renameInModules = map go
115− where
116− go :: Module Ann -> Module Ann
117− go m@(Module _ _ _ _ _ decls) = m { moduleDecls = map (renameInDecl' (findDeclIdents decls)) decls }
118−
119− renameInDecl' :: [Ident] -> Bind Ann -> Bind Ann
120− renameInDecl' scope = runRename scope . renameInDecl True
121−
122−-- |
123−-- Renames within a declaration. isTopLevel is used to determine whether the
124−-- declaration is a module member or appearing within a Let. At the top level
125−-- declarations are not renamed or added to the scope (they should already have
126−-- been added), whereas in a Let declarations are renamed if their name shadows
127−-- another in the current scope.
128−--
129−renameInDecl :: Bool -> Bind Ann -> Rename (Bind Ann)
130−renameInDecl isTopLevel (NonRec name val) = do
131− name' <- if isTopLevel then return name else updateScope name
132− NonRec name' <$> renameInValue val
133−renameInDecl isTopLevel (Rec ds) = do
134− ds' <- mapM updateNames ds
135− Rec <$> mapM updateValues ds'
136− where
137− updateNames :: (Ident, Expr Ann) -> Rename (Ident, Expr Ann)
138− updateNames (name, val) = do
139− name' <- if isTopLevel then return name else updateScope name
140− return (name', val)
141− updateValues :: (Ident, Expr Ann) -> Rename (Ident, Expr Ann)
142− updateValues (name, val) = (,) name <$> renameInValue val
143−
144−-- |
145−-- Renames within a value.
146−--
147−renameInValue :: Expr Ann -> Rename (Expr Ann)
148−renameInValue (Literal ann l) =
149− Literal ann <$> renameInLiteral renameInValue l
150−renameInValue c@(Constructor{}) = return c
151−renameInValue (Accessor ann prop v) =
152− Accessor ann prop <$> renameInValue v
153−renameInValue (ObjectUpdate ann obj vs) =
154− ObjectUpdate ann <$> renameInValue obj <*> mapM (\(name, v) -> (,) name <$> renameInValue v) vs
155−renameInValue e@(Abs (_, _, _, Just IsTypeClassConstructor) _ _) = return e
156−renameInValue (Abs ann name v) =
157− newScope $ Abs ann <$> updateScope name <*> renameInValue v
158−renameInValue (App ann v1 v2) =
159− App ann <$> renameInValue v1 <*> renameInValue v2
160−renameInValue (Var ann (Qualified Nothing name)) =
161− Var ann . Qualified Nothing <$> lookupIdent name
162−renameInValue v@(Var{}) = return v
163−renameInValue (Case ann vs alts) =
164− newScope $ Case ann <$> mapM renameInValue vs <*> mapM renameInCaseAlternative alts
165−renameInValue (Let ann ds v) =
166− newScope $ Let ann <$> mapM (renameInDecl False) ds <*> renameInValue v
167−
168−-- |
169−-- Renames within literals.
170−--
171−renameInLiteral :: (a -> Rename a) -> Literal a -> Rename (Literal a)
172−renameInLiteral rename (ArrayLiteral bs) = ArrayLiteral <$> mapM rename bs
173−renameInLiteral rename (ObjectLiteral bs) = ObjectLiteral <$> mapM (sndM rename) bs
174−renameInLiteral _ l = return l
175−
176−-- |
177−-- Renames within case alternatives.
178−--
179−renameInCaseAlternative :: CaseAlternative Ann -> Rename (CaseAlternative Ann)
180−renameInCaseAlternative (CaseAlternative bs v) = newScope $
181− CaseAlternative <$> mapM renameInBinder bs
182− <*> eitherM (mapM (pairM renameInValue renameInValue)) renameInValue v
183−
184−-- |
185−-- Renames within binders.
186−--
187−renameInBinder :: Binder a -> Rename (Binder a)
188−renameInBinder n@(NullBinder{}) = return n
189−renameInBinder (LiteralBinder ann b) =
190− LiteralBinder ann <$> renameInLiteral renameInBinder b
191−renameInBinder (VarBinder ann name) =
192− VarBinder ann <$> updateScope name
193−renameInBinder (ConstructorBinder ann tctor dctor bs) =
194− ConstructorBinder ann tctor dctor <$> mapM renameInBinder bs
195−renameInBinder (NamedBinder ann name b) =
196− NamedBinder ann <$> updateScope name <*> renameInBinder b
src/Language/PureScript/Sugar.hsdeleted−71
@@ -1,71 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.Sugar
4−-- Copyright : (c) Phil Freeman 2013
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- |
12−-- Desugaring passes
13−--
14−-----------------------------------------------------------------------------
15−
16−{-# LANGUAGE FlexibleContexts #-}
17−
18−module Language.PureScript.Sugar (desugar, module S) where
19−
20−import Control.Monad
21−import Control.Category ((>>>))
22−import Control.Applicative
23−import Control.Monad.Error.Class (MonadError(..))
24−import Control.Monad.Supply.Class
25−
26−import Language.PureScript.AST
27−import Language.PureScript.Errors
28−
29−import Language.PureScript.Sugar.BindingGroups as S
30−import Language.PureScript.Sugar.CaseDeclarations as S
31−import Language.PureScript.Sugar.DoNotation as S
32−import Language.PureScript.Sugar.Names as S
33−import Language.PureScript.Sugar.ObjectWildcards as S
34−import Language.PureScript.Sugar.Operators as S
35−import Language.PureScript.Sugar.TypeClasses as S
36−import Language.PureScript.Sugar.TypeDeclarations as S
37−
38−-- |
39−-- The desugaring pipeline proceeds as follows:
40−--
41−-- * Remove signed literals in favour of `negate` applications
42−--
43−-- * Desugar object literals with wildcards into lambdas
44−--
45−-- * Desugar operator sections
46−--
47−-- * Desugar do-notation using the @Prelude.Monad@ type class
48−--
49−-- * Desugar top-level case declarations into explicit case expressions
50−--
51−-- * Desugar type declarations into value declarations with explicit type annotations
52−--
53−-- * Qualify any unqualified names and types
54−--
55−-- * Rebracket user-defined binary operators
56−--
57−-- * Introduce type synonyms for type class dictionaries
58−--
59−-- * Group mutually recursive value and data declarations into binding groups.
60−--
61−desugar :: (Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Module] -> m [Module]
62−desugar = map removeSignedLiterals
63− >>> mapM desugarObjectConstructors
64− >=> mapM desugarOperatorSections
65− >=> mapM desugarDoModule
66− >=> desugarCasesModule
67− >=> desugarTypeDeclarationsModule
68− >=> desugarImports
69− >=> rebracket
70− >=> desugarTypeClasses
71− >=> createBindingGroupsModule
src/Language/PureScript/Sugar/BindingGroups.hsdeleted−206
@@ -1,206 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.BindingGroups
4−-- Copyright : (c) Phil Freeman 2013
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- |
12−-- This module implements the desugaring pass which creates binding groups from sets of
13−-- mutually-recursive value declarations and mutually-recursive type declarations.
14−--
15−-----------------------------------------------------------------------------
16−
17−{-# LANGUAGE FlexibleContexts #-}
18−
19−module Language.PureScript.Sugar.BindingGroups (
20− createBindingGroups,
21− createBindingGroupsModule,
22− collapseBindingGroups,
23− collapseBindingGroupsModule
24−) where
25−
26−import Data.Graph
27−import Data.List (nub, intersect)
28−import Data.Maybe (isJust, mapMaybe)
29−import Control.Applicative
30−import Control.Monad ((<=<))
31−import Control.Monad.Error.Class (MonadError(..))
32−
33−import qualified Data.Set as S
34−
35−import Language.PureScript.AST
36−import Language.PureScript.Names
37−import Language.PureScript.Types
38−import Language.PureScript.Environment
39−import Language.PureScript.Errors
40−
41−-- |
42−-- Replace all sets of mutually-recursive declarations in a module with binding groups
43−--
44−createBindingGroupsModule :: (Functor m, Applicative m, MonadError MultipleErrors m) => [Module] -> m [Module]
45−createBindingGroupsModule = mapM $ \(Module coms name ds exps) -> Module coms name <$> createBindingGroups name ds <*> pure exps
46−
47−-- |
48−-- Collapse all binding groups in a module to individual declarations
49−--
50−collapseBindingGroupsModule :: [Module] -> [Module]
51−collapseBindingGroupsModule = map $ \(Module coms name ds exps) -> Module coms name (collapseBindingGroups ds) exps
52−
53−createBindingGroups :: (Functor m, Applicative m, MonadError MultipleErrors m) => ModuleName -> [Declaration] -> m [Declaration]
54−createBindingGroups moduleName = mapM f <=< handleDecls
55−
56− where
57− (f, _, _) = everywhereOnValuesTopDownM return handleExprs return
58−
59− handleExprs :: (Functor m, MonadError MultipleErrors m) => Expr -> m Expr
60− handleExprs (Let ds val) = flip Let val <$> handleDecls ds
61− handleExprs other = return other
62−
63− -- |
64− -- Replace all sets of mutually-recursive declarations with binding groups
65− --
66− handleDecls :: (Functor m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]
67− handleDecls ds = do
68− let values = filter isValueDecl ds
69− dataDecls = filter isDataDecl ds
70− allProperNames = map getProperName dataDecls
71− dataVerts = map (\d -> (d, getProperName d, usedProperNames moduleName d `intersect` allProperNames)) dataDecls
72− dataBindingGroupDecls <- parU (stronglyConnComp dataVerts) toDataBindingGroup
73− let allIdents = map getIdent values
74− valueVerts = map (\d -> (d, getIdent d, usedIdents moduleName d `intersect` allIdents)) values
75− bindingGroupDecls <- parU (stronglyConnComp valueVerts) (toBindingGroup moduleName)
76− return $ filter isImportDecl ds ++
77− filter isExternDataDecl ds ++
78− filter isExternInstanceDecl ds ++
79− dataBindingGroupDecls ++
80− filter isTypeClassDeclaration ds ++
81− filter isTypeClassInstanceDeclaration ds ++
82− filter isFixityDecl ds ++
83− filter isExternDecl ds ++
84− bindingGroupDecls
85−
86−-- |
87−-- Collapse all binding groups to individual declarations
88−--
89−collapseBindingGroups :: [Declaration] -> [Declaration]
90−collapseBindingGroups = let (f, _, _) = everywhereOnValues id collapseBindingGroupsForValue id in map f . concatMap go
91− where
92− go (DataBindingGroupDeclaration ds) = ds
93− go (BindingGroupDeclaration ds) = map (\(ident, nameKind, val) -> ValueDeclaration ident nameKind [] (Right val)) ds
94− go (PositionedDeclaration pos com d) = map (PositionedDeclaration pos com) $ go d
95− go other = [other]
96−
97−collapseBindingGroupsForValue :: Expr -> Expr
98−collapseBindingGroupsForValue (Let ds val) = Let (collapseBindingGroups ds) val
99−collapseBindingGroupsForValue other = other
100−
101−usedIdents :: ModuleName -> Declaration -> [Ident]
102−usedIdents moduleName =
103− let (f, _, _, _, _) = everythingWithContextOnValues S.empty [] (++) def usedNamesE usedNamesB def def
104− in nub . f
105− where
106− def s _ = (s, [])
107−
108− usedNamesE :: S.Set Ident -> Expr -> (S.Set Ident, [Ident])
109− usedNamesE scope (Var (Qualified Nothing name)) | name `S.notMember` scope = (scope, [name])
110− usedNamesE scope (Var (Qualified (Just moduleName') name)) | moduleName == moduleName' && name `S.notMember` scope = (scope, [name])
111− usedNamesE scope (Abs (Left name) _) = (name `S.insert` scope, [])
112− usedNamesE scope _ = (scope, [])
113−
114− usedNamesB :: S.Set Ident -> Binder -> (S.Set Ident, [Ident])
115− usedNamesB scope binder = (scope `S.union` S.fromList (binderNames binder), [])
116−
117−usedImmediateIdents :: ModuleName -> Declaration -> [Ident]
118−usedImmediateIdents moduleName =
119− let (f, _, _, _, _) = everythingWithContextOnValues True [] (++) def usedNamesE def def def
120− in nub . f
121− where
122− def s _ = (s, [])
123−
124− usedNamesE :: Bool -> Expr -> (Bool, [Ident])
125− usedNamesE True (Var (Qualified Nothing name)) = (True, [name])
126− usedNamesE True (Var (Qualified (Just moduleName') name)) | moduleName == moduleName' = (True, [name])
127− usedNamesE True (Abs _ _) = (False, [])
128− usedNamesE scope _ = (scope, [])
129−
130−usedProperNames :: ModuleName -> Declaration -> [ProperName]
131−usedProperNames moduleName =
132− let (f, _, _, _, _) = accumTypes (everythingOnTypes (++) usedNames)
133− in nub . f
134− where
135− usedNames :: Type -> [ProperName]
136− usedNames (ConstrainedType constraints _) = flip mapMaybe constraints $ \qual ->
137− case qual of
138− (Qualified (Just moduleName') name, _) | moduleName == moduleName' -> Just name
139− _ -> Nothing
140− usedNames (TypeConstructor (Qualified (Just moduleName') name)) | moduleName == moduleName' = [name]
141− usedNames _ = []
142−
143−getIdent :: Declaration -> Ident
144−getIdent (ValueDeclaration ident _ _ _) = ident
145−getIdent (PositionedDeclaration _ _ d) = getIdent d
146−getIdent _ = error "Expected ValueDeclaration"
147−
148−getProperName :: Declaration -> ProperName
149−getProperName (DataDeclaration _ pn _ _) = pn
150−getProperName (TypeSynonymDeclaration pn _ _) = pn
151−getProperName (PositionedDeclaration _ _ d) = getProperName d
152−getProperName _ = error "Expected DataDeclaration"
153−
154−-- |
155−-- Convert a group of mutually-recursive dependencies into a BindingGroupDeclaration (or simple ValueDeclaration).
156−--
157−--
158−toBindingGroup :: (Functor m, MonadError MultipleErrors m) => ModuleName -> SCC Declaration -> m Declaration
159−toBindingGroup _ (AcyclicSCC d) = return d
160−toBindingGroup moduleName (CyclicSCC ds') =
161− -- Once we have a mutually-recursive group of declarations, we need to sort
162− -- them further by their immediate dependencies (those outside function
163− -- bodies). In particular, this is relevant for type instance dictionaries
164− -- whose members require other type instances (for example, functorEff
165− -- defines (<$>) = liftA1, which depends on applicativeEff). Note that
166− -- superclass references are still inside functions, so don't count here.
167− -- If we discover declarations that still contain mutually-recursive
168− -- immediate references, we're guaranteed to get an undefined reference at
169− -- runtime, so treat this as an error. See also github issue #365.
170− BindingGroupDeclaration <$> mapM toBinding (stronglyConnComp valueVerts)
171− where
172− idents :: [Ident]
173− idents = map (\(_, i, _) -> i) valueVerts
174−
175− valueVerts :: [(Declaration, Ident, [Ident])]
176− valueVerts = map (\d -> (d, getIdent d, usedImmediateIdents moduleName d `intersect` idents)) ds'
177−
178− toBinding :: (MonadError MultipleErrors m) => SCC Declaration -> m (Ident, NameKind, Expr)
179− toBinding (AcyclicSCC d) = return $ fromValueDecl d
180− toBinding (CyclicSCC ~(d:ds)) = cycleError d ds
181−
182− cycleError :: (MonadError MultipleErrors m) => Declaration -> [Declaration] -> m a
183− cycleError (PositionedDeclaration p _ d) ds = rethrowWithPosition p $ cycleError d ds
184− cycleError (ValueDeclaration n _ _ (Right _)) [] = throwError . errorMessage $ CycleInDeclaration n
185− cycleError d ds@(_:_) = rethrow (onErrorMessages (NotYetDefined (map getIdent ds))) $ cycleError d []
186− cycleError _ _ = error "Expected ValueDeclaration"
187−
188−toDataBindingGroup :: (MonadError MultipleErrors m) => SCC Declaration -> m Declaration
189−toDataBindingGroup (AcyclicSCC d) = return d
190−toDataBindingGroup (CyclicSCC [d]) = case isTypeSynonym d of
191− Just pn -> throwError . errorMessage $ CycleInTypeSynonym (Just pn)
192− _ -> return d
193−toDataBindingGroup (CyclicSCC ds')
194− | all (isJust . isTypeSynonym) ds' = throwError . errorMessage $ CycleInTypeSynonym Nothing
195− | otherwise = return $ DataBindingGroupDeclaration ds'
196−
197−isTypeSynonym :: Declaration -> Maybe ProperName
198−isTypeSynonym (TypeSynonymDeclaration pn _ _) = Just pn
199−isTypeSynonym (PositionedDeclaration _ _ d) = isTypeSynonym d
200−isTypeSynonym _ = Nothing
201−
202−fromValueDecl :: Declaration -> (Ident, NameKind, Expr)
203−fromValueDecl (ValueDeclaration ident nameKind [] (Right val)) = (ident, nameKind, val)
204−fromValueDecl ValueDeclaration{} = error "Binders should have been desugared"
205−fromValueDecl (PositionedDeclaration _ _ d) = fromValueDecl d
206−fromValueDecl _ = error "Expected ValueDeclaration"
src/Language/PureScript/Sugar/CaseDeclarations.hsdeleted−180
@@ -1,180 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.CaseDeclarations
4−-- Copyright : (c) Phil Freeman 2013
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- |
12−-- This module implements the desugaring pass which replaces top-level binders with
13−-- case expressions.
14−--
15−-----------------------------------------------------------------------------
16−
17−{-# LANGUAGE FlexibleContexts, ScopedTypeVariables #-}
18−
19−module Language.PureScript.Sugar.CaseDeclarations (
20− desugarCases,
21− desugarCasesModule
22−) where
23−
24−import Data.Maybe (catMaybes)
25−import Data.List (nub, groupBy)
26−
27−import Control.Applicative
28−import Control.Monad ((<=<), forM, replicateM, join, unless)
29−import Control.Monad.Error.Class (MonadError(..))
30−import Control.Monad.Supply.Class
31−
32−import Language.PureScript.Names
33−import Language.PureScript.AST
34−import Language.PureScript.Environment
35−import Language.PureScript.Errors
36−import Language.PureScript.Traversals
37−import Language.PureScript.TypeChecker.Monad (guardWith)
38−
39−-- Data.Either.isLeft (base 4.7)
40−isLeft :: Either a b -> Bool
41−isLeft (Left _) = True
42−isLeft (Right _) = False
43−
44−-- |
45−-- Replace all top-level binders in a module with case expressions.
46−--
47−desugarCasesModule :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Module] -> m [Module]
48−desugarCasesModule ms = forM ms $ \(Module coms name ds exps) ->
49− rethrow (onErrorMessages (ErrorInModule name)) $
50− Module coms name <$> (desugarCases <=< desugarAbs $ ds) <*> pure exps
51−
52−desugarAbs :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]
53−desugarAbs = flip parU f
54− where
55− (f, _, _) = everywhereOnValuesM return replace return
56−
57− replace :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => Expr -> m Expr
58− replace (Abs (Right binder) val) = do
59− ident <- Ident <$> freshName
60− return $ Abs (Left ident) $ Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] (Right val)]
61− replace other = return other
62−
63−-- |
64−-- Replace all top-level binders with case expressions.
65−--
66−desugarCases :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]
67−desugarCases = desugarRest <=< fmap join . flip parU toDecls . groupBy inSameGroup
68− where
69− desugarRest :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]
70− desugarRest (TypeInstanceDeclaration name constraints className tys ds : rest) =
71− (:) <$> (TypeInstanceDeclaration name constraints className tys <$> desugarCases ds) <*> desugarRest rest
72− desugarRest (ValueDeclaration name nameKind bs result : rest) =
73− let (_, f, _) = everywhereOnValuesTopDownM return go return
74− f' (Left gs) = Left <$> mapM (pairM return f) gs
75− f' (Right v) = Right <$> f v
76− in (:) <$> (ValueDeclaration name nameKind bs <$> f' result) <*> desugarRest rest
77− where
78− go (Let ds val') = Let <$> desugarCases ds <*> pure val'
79− go other = return other
80− desugarRest (PositionedDeclaration pos com d : ds) = do
81− (d' : ds') <- desugarRest (d : ds)
82− return (PositionedDeclaration pos com d' : ds')
83− desugarRest (d : ds) = (:) d <$> desugarRest ds
84− desugarRest [] = pure []
85−
86−inSameGroup :: Declaration -> Declaration -> Bool
87−inSameGroup (ValueDeclaration ident1 _ _ _) (ValueDeclaration ident2 _ _ _) = ident1 == ident2
88−inSameGroup (PositionedDeclaration _ _ d1) d2 = inSameGroup d1 d2
89−inSameGroup d1 (PositionedDeclaration _ _ d2) = inSameGroup d1 d2
90−inSameGroup _ _ = False
91−
92−toDecls :: forall m. (Functor m, Applicative m, Monad m, MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]
93−toDecls [ValueDeclaration ident nameKind bs (Right val)] | all isVarBinder bs = do
94− args <- mapM fromVarBinder bs
95− let body = foldr (Abs . Left) val args
96− guardWith (errorMessage (OverlappingArgNames (Just ident))) $ length (nub args) == length args
97− return [ValueDeclaration ident nameKind [] (Right body)]
98− where
99− isVarBinder :: Binder -> Bool
100− isVarBinder NullBinder = True
101− isVarBinder (VarBinder _) = True
102− isVarBinder (PositionedBinder _ _ b) = isVarBinder b
103− isVarBinder _ = False
104−
105− fromVarBinder :: Binder -> m Ident
106− fromVarBinder NullBinder = Ident <$> freshName
107− fromVarBinder (VarBinder name) = return name
108− fromVarBinder (PositionedBinder _ _ b) = fromVarBinder b
109− fromVarBinder _ = error "fromVarBinder: Invalid argument"
110−toDecls ds@(ValueDeclaration ident _ bs result : _) = do
111− let tuples = map toTuple ds
112− unless (all ((== length bs) . length . fst) tuples) $
113− throwError . errorMessage $ ArgListLengthsDiffer ident
114− unless (not (null bs) || isLeft result) $
115− throwError . errorMessage $ DuplicateValueDeclaration ident
116− caseDecl <- makeCaseDeclaration ident tuples
117− return [caseDecl]
118−toDecls (PositionedDeclaration pos com d : ds) = do
119− (d' : ds') <- rethrowWithPosition pos $ toDecls (d : ds)
120− return (PositionedDeclaration pos com d' : ds')
121−toDecls ds = return ds
122−
123−toTuple :: Declaration -> ([Binder], Either [(Guard, Expr)] Expr)
124−toTuple (ValueDeclaration _ _ bs result) = (bs, result)
125−toTuple (PositionedDeclaration _ _ d) = toTuple d
126−toTuple _ = error "Not a value declaration"
127−
128−makeCaseDeclaration :: forall m. (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => Ident -> [([Binder], Either [(Guard, Expr)] Expr)] -> m Declaration
129−makeCaseDeclaration ident alternatives = do
130− let namedArgs = map findName . fst <$> alternatives
131− argNames = map join $ foldl1 resolveNames namedArgs
132− args <- if allUnique (catMaybes argNames)
133− then mapM argName argNames
134− else replicateM (length argNames) (Ident <$> freshName)
135− let vars = map (Var . Qualified Nothing) args
136− binders = [ CaseAlternative bs result | (bs, result) <- alternatives ]
137− value = foldr (Abs . Left) (Case vars binders) args
138− return $ ValueDeclaration ident Value [] (Right value)
139− where
140− -- We will construct a table of potential names.
141− -- VarBinders will become Just (Just _) which is a potential name.
142− -- NullBinder will become Just Nothing, which indicates that we may
143− -- have to generate a name.
144− -- Everything else becomes Nothing, which indicates that we definitely
145− -- have to generate a name.
146− findName :: Binder -> Maybe (Maybe Ident)
147− findName NullBinder = Just Nothing
148− findName (VarBinder name) = Just (Just name)
149− findName (PositionedBinder _ _ binder) = findName binder
150− findName _ = Nothing
151−
152− -- We still have to make sure the generated names are unique, or else
153− -- we will end up constructing an invalid function.
154− allUnique :: (Eq a) => [a] -> Bool
155− allUnique xs = length xs == length (nub xs)
156−
157− argName :: Maybe Ident -> m Ident
158− argName (Just name) = return name
159− argName _ = do
160− name <- freshName
161− return (Ident name)
162−
163− -- Combine two lists of potential names from two case alternatives
164− -- by zipping correspoding columns.
165− resolveNames :: [Maybe (Maybe Ident)] ->
166− [Maybe (Maybe Ident)] ->
167− [Maybe (Maybe Ident)]
168− resolveNames = zipWith resolveName
169−
170− -- Resolve a pair of names. VarBinder beats NullBinder, and everything
171− -- else results in Nothing.
172− resolveName :: Maybe (Maybe Ident) ->
173− Maybe (Maybe Ident) ->
174− Maybe (Maybe Ident)
175− resolveName (Just (Just a)) (Just (Just b))
176− | a == b = Just (Just a)
177− | otherwise = Nothing
178− resolveName (Just Nothing) a = a
179− resolveName a (Just Nothing) = a
180− resolveName _ _ = Nothing
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−{-# LANGUAGE FlexibleContexts #-}
18−{-# LANGUAGE ScopedTypeVariables #-}
19−
20−module Language.PureScript.Sugar.DoNotation (
21− desugarDoModule
22−) where
23−
24−import Language.PureScript.Names
25−import Language.PureScript.AST
26−import Language.PureScript.Errors
27−
28−import qualified Language.PureScript.Constants as C
29−
30−import Control.Applicative
31−import Control.Monad.Error.Class (MonadError(..))
32−import Control.Monad.Supply.Class
33−
34−-- |
35−-- Replace all @DoNotationBind@ and @DoNotationValue@ constructors with applications of the Prelude.(>>=) function,
36−-- and all @DoNotationLet@ constructors with let expressions.
37−--
38−desugarDoModule :: forall m. (Applicative m, MonadSupply m, MonadError MultipleErrors m) => Module -> m Module
39−desugarDoModule (Module coms mn ds exts) = Module coms mn <$> parU ds desugarDo <*> pure exts
40−
41−desugarDo :: forall m. (Applicative m, MonadSupply m, MonadError MultipleErrors m) => Declaration -> m Declaration
42−desugarDo (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> (rethrowWithPosition pos $ desugarDo d)
43−desugarDo d =
44− let (f, _, _) = everywhereOnValuesM return replace return
45− in f d
46− where
47− bind :: Expr
48− bind = Var (Qualified Nothing (Op (C.>>=)))
49−
50− replace :: Expr -> m Expr
51− replace (Do els) = go els
52− replace (PositionedValue pos com v) = PositionedValue pos com <$> rethrowWithPosition pos (replace v)
53− replace other = return other
54−
55− go :: [DoNotationElement] -> m 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 _ _] = throwError . errorMessage $ InvalidDoBind
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 _] = throwError . errorMessage $ InvalidDoLet
71− go (DoNotationLet ds : rest) = do
72− rest' <- go rest
73− return $ Let ds rest'
74− go (PositionedDoNotationElement pos com el : rest) = rethrowWithPosition pos $ PositionedValue pos com <$> go (el : rest)
src/Language/PureScript/Sugar/Names.hsdeleted−542
@@ -1,542 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.Sugar.Names
4−-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- |
12−--
13−-----------------------------------------------------------------------------
14−
15−{-# LANGUAGE FlexibleContexts #-}
16−{-# LANGUAGE ScopedTypeVariables #-}
17−
18−module Language.PureScript.Sugar.Names (
19− desugarImports
20−) where
21−
22−import Data.List (nub)
23−import Data.Maybe (fromMaybe, isJust, mapMaybe)
24−
25−import Control.Applicative (Applicative(..), (<$>), (<*>))
26−import Control.Monad
27−import Control.Monad.Error.Class (MonadError(..))
28−
29−import qualified Data.Map as M
30−
31−import Language.PureScript.AST
32−import Language.PureScript.Names
33−import Language.PureScript.Types
34−import Language.PureScript.Environment
35−import Language.PureScript.Errors
36−import Language.PureScript.Traversals
37−
38−import qualified Language.PureScript.Constants as C
39−
40−-- |
41−-- The global export environment - every declaration exported from every module.
42−--
43−type ExportEnvironment = M.Map ModuleName Exports
44−
45−-- |
46−-- The exported declarations from a module.
47−--
48−data Exports = Exports
49− {
50− -- |
51− -- The types exported from each module
52− --
53− exportedTypes :: [(ProperName, [ProperName])]
54− -- |
55− -- The classes exported from each module
56− --
57− , exportedTypeClasses :: [ProperName]
58− -- |
59− -- The values exported from each module
60− --
61− , exportedValues :: [Ident]
62− } deriving (Show)
63−
64−-- |
65−-- An imported environment for a particular module. This also contains the module's own members.
66−--
67−data ImportEnvironment = ImportEnvironment
68− {
69− -- |
70− -- Local names for types within a module mapped to to their qualified names
71− --
72− importedTypes :: M.Map (Qualified ProperName) (Qualified ProperName)
73− -- |
74− -- Local names for data constructors within a module mapped to to their qualified names
75− --
76− , importedDataConstructors :: M.Map (Qualified ProperName) (Qualified ProperName)
77− -- |
78− -- Local names for classes within a module mapped to to their qualified names
79− --
80− , importedTypeClasses :: M.Map (Qualified ProperName) (Qualified ProperName)
81− -- |
82− -- Local names for values within a module mapped to to their qualified names
83− --
84− , importedValues :: M.Map (Qualified Ident) (Qualified Ident)
85− } deriving (Show)
86−
87−-- |
88−-- Updates the exports for a module from the global environment. If the module was not previously
89−-- present in the global environment, it is created.
90−--
91−updateExportedModule :: (Applicative m, MonadError MultipleErrors m) => ExportEnvironment -> ModuleName -> (Exports -> m Exports) -> m ExportEnvironment
92−updateExportedModule env mn update = do
93− let exports = fromMaybe (error "Module was undefined in updateExportedModule") $ mn `M.lookup` env
94− exports' <- update exports
95− return $ M.insert mn exports' env
96−
97−-- |
98−-- Adds an empty module to an ExportEnvironment.
99−--
100−addEmptyModule :: (Applicative m, MonadError MultipleErrors m) => ExportEnvironment -> ModuleName -> m ExportEnvironment
101−addEmptyModule env name =
102− if name `M.member` env
103− then throwError . errorMessage $ RedefinedModule name
104− else return $ M.insert name (Exports [] [] []) env
105−
106−-- |
107−-- Adds a type belonging to a module to the export environment.
108−--
109−addType :: (Applicative m, MonadError MultipleErrors m) => ExportEnvironment -> ModuleName -> ProperName -> [ProperName] -> m ExportEnvironment
110−addType env mn name dctors = updateExportedModule env mn $ \m -> do
111− let exTypes = exportedTypes m
112− let exDctors = snd `concatMap` exTypes
113− let exClasses = exportedTypeClasses m
114− when (any ((== name) . fst) exTypes) $ throwConflictError ConflictingTypeDecls name
115− when (name `elem` exClasses) $ throwConflictError TypeConflictsWithClass name
116− forM_ dctors $ \dctor -> do
117− when (dctor `elem` exDctors) $ throwConflictError ConflictingCtorDecls dctor
118− when (dctor `elem` exClasses) $ throwConflictError CtorConflictsWithClass dctor
119− return $ m { exportedTypes = (name, dctors) : exTypes }
120−
121−-- |
122−-- Adds a class to the export environment.
123−--
124−addTypeClass :: (Applicative m, MonadError MultipleErrors m) => ExportEnvironment -> ModuleName -> ProperName -> m ExportEnvironment
125−addTypeClass env mn name = updateExportedModule env mn $ \m -> do
126− let exTypes = exportedTypes m
127− let exDctors = snd `concatMap` exTypes
128− when (any ((== name) . fst) exTypes) $ throwConflictError ClassConflictsWithType name
129− when (name `elem` exDctors) $ throwConflictError ClassConflictsWithCtor name
130− classes <- addExport DuplicateClassExport (exportedTypeClasses m) name
131− return $ m { exportedTypeClasses = classes }
132−
133−-- |
134−-- Adds a class to the export environment.
135−--
136−addValue :: (Applicative m, MonadError MultipleErrors m) => ExportEnvironment -> ModuleName -> Ident -> m ExportEnvironment
137−addValue env mn name = updateExportedModule env mn $ \m -> do
138− values <- addExport DuplicateValueExport (exportedValues m) name
139− return $ m { exportedValues = values }
140−
141−-- |
142−-- Adds an entry to a list of exports unless it is already present, in which case an error is
143−-- returned.
144−--
145−addExport :: (Applicative m, MonadError MultipleErrors m, Eq a, Show a) => (a -> ErrorMessage) -> [a] -> a -> m [a]
146−addExport what exports name =
147− if name `elem` exports
148− then throwConflictError what name
149− else return $ name : exports
150−
151−-- |
152−-- Replaces all local names with qualified names within a set of modules.
153−--
154−desugarImports :: forall m. (Applicative m, MonadError MultipleErrors m) => [Module] -> m [Module]
155−desugarImports modules = do
156− unfilteredExports <- findExports modules
157− exports <- foldM filterModuleExports unfilteredExports modules
158− mapM (renameInModule' unfilteredExports exports) modules
159− where
160−
161− -- Filters the exports for a module in the global exports environment so that only explicitly
162− -- exported members remain. If the module does not explicitly export anything, everything is
163− -- exported.
164− filterModuleExports :: ExportEnvironment -> Module -> m ExportEnvironment
165− filterModuleExports env (Module _ mn _ (Just exps)) = filterExports mn exps env
166− filterModuleExports env _ = return env
167−
168− -- Rename and check all the names within a module. We tweak the global exports environment so
169− -- the module has access to an unfiltered list of its own members.
170− renameInModule' :: ExportEnvironment -> ExportEnvironment -> Module -> m Module
171− renameInModule' unfilteredExports exports m@(Module _ mn _ _) =
172− rethrow (onErrorMessages (ErrorInModule mn)) $ do
173− let env = M.update (\_ -> M.lookup mn unfilteredExports) mn exports
174− let exps = fromMaybe (error "Module is missing in renameInModule'") $ M.lookup mn exports
175− imports <- resolveImports env m
176− elaborateImports <$> renameInModule imports env (elaborateExports exps m)
177−
178−-- |
179−-- Make all exports for a module explicit. This may still effect modules that have an exports list,
180−-- as it will also make all data constructor exports explicit.
181−--
182−elaborateExports :: Exports -> Module -> Module
183−elaborateExports exps (Module coms mn decls _) = Module coms mn decls (Just $
184− map (\(ctor, dctors) -> TypeRef ctor (Just dctors)) (exportedTypes exps) ++
185− map TypeClassRef (exportedTypeClasses exps) ++
186− map ValueRef (exportedValues exps))
187−
188−-- |
189−-- Add `import X ()` for any modules where there are only fully qualified references to members.
190−-- This ensures transitive instances are included when using a member from a module.
191−--
192−elaborateImports :: Module -> Module
193−elaborateImports (Module coms mn decls exps) = Module coms mn decls' exps
194− where
195− decls' :: [Declaration]
196− decls' =
197− let (f, _, _, _, _) = everythingOnValues (++) (const []) fqValues (const []) (const []) (const [])
198− in mkImport `map` nub (f `concatMap` decls) ++ decls
199− fqValues :: Expr -> [ModuleName]
200− fqValues (Var (Qualified (Just mn') _)) = [mn']
201− fqValues _ = []
202− mkImport :: ModuleName -> Declaration
203− mkImport mn' = ImportDeclaration mn' (Explicit []) Nothing
204−
205−-- |
206−-- Replaces all local names with qualified names within a module and checks that all existing
207−-- qualified names are valid.
208−--
209−renameInModule :: forall m. (Applicative m, MonadError MultipleErrors m) => ImportEnvironment -> ExportEnvironment -> Module -> m Module
210−renameInModule imports exports (Module coms mn decls exps) =
211− Module coms mn <$> parU decls go <*> pure exps
212− where
213− (go, _, _, _, _) = everywhereWithContextOnValuesM (Nothing, []) updateDecl updateValue updateBinder updateCase defS
214−
215− updateDecl :: (Maybe SourceSpan, [Ident]) -> Declaration -> m ((Maybe SourceSpan, [Ident]), Declaration)
216− updateDecl (_, bound) d@(PositionedDeclaration pos _ _) = return ((Just pos, bound), d)
217− updateDecl (pos, bound) (DataDeclaration dtype name args dctors) =
218− (,) (pos, bound) <$> (DataDeclaration dtype name args <$> mapM (sndM (mapM (updateTypesEverywhere pos))) dctors)
219− updateDecl (pos, bound) (TypeSynonymDeclaration name ps ty) =
220− (,) (pos, bound) <$> (TypeSynonymDeclaration name ps <$> updateTypesEverywhere pos ty)
221− updateDecl (pos, bound) (TypeClassDeclaration className args implies ds) =
222− (,) (pos, bound) <$> (TypeClassDeclaration className args <$> updateConstraints pos implies <*> pure ds)
223− updateDecl (pos, bound) (TypeInstanceDeclaration name cs cn ts ds) =
224− (,) (pos, bound) <$> (TypeInstanceDeclaration name <$> updateConstraints pos cs <*> updateClassName cn pos <*> mapM (updateTypesEverywhere pos) ts <*> pure ds)
225− updateDecl (pos, bound) (ExternInstanceDeclaration name cs cn ts) =
226− (,) (pos, bound) <$> (ExternInstanceDeclaration name <$> updateConstraints pos cs <*> updateClassName cn Nothing <*> mapM (updateTypesEverywhere pos) ts)
227− updateDecl (pos, bound) (TypeDeclaration name ty) =
228− (,) (pos, bound) <$> (TypeDeclaration name <$> updateTypesEverywhere pos ty)
229− updateDecl (pos, bound) (ExternDeclaration fit name js ty) =
230− (,) (pos, name : bound) <$> (ExternDeclaration fit name js <$> updateTypesEverywhere pos ty)
231− updateDecl s d = return (s, d)
232−
233− updateValue :: (Maybe SourceSpan, [Ident]) -> Expr -> m ((Maybe SourceSpan, [Ident]), Expr)
234− updateValue (_, bound) v@(PositionedValue pos' _ _) = return ((Just pos', bound), v)
235− updateValue (pos, bound) (Abs (Left arg) val') = return ((pos, arg : bound), Abs (Left arg) val')
236− updateValue (pos, bound) (Let ds val') = do
237− let args = mapMaybe letBoundVariable ds
238− unless (length (nub args) == length args) $
239− maybe id rethrowWithPosition pos $
240− throwError . errorMessage $ OverlappingNamesInLet
241− return ((pos, args ++ bound), Let ds val')
242− where
243− updateValue (pos, bound) (Var name'@(Qualified Nothing ident)) | ident `notElem` bound =
244− (,) (pos, bound) <$> (Var <$> updateValueName name' pos)
245− updateValue (pos, bound) (Var name'@(Qualified (Just _) _)) =
246− (,) (pos, bound) <$> (Var <$> updateValueName name' pos)
247− updateValue s@(pos, _) (Constructor name) = (,) s <$> (Constructor <$> updateDataConstructorName name pos)
248− updateValue s@(pos, _) (TypedValue check val ty) = (,) s <$> (TypedValue check val <$> updateTypesEverywhere pos ty)
249− updateValue s v = return (s, v)
250−
251− updateBinder :: (Maybe SourceSpan, [Ident]) -> Binder -> m ((Maybe SourceSpan, [Ident]), Binder)
252− updateBinder (_, bound) v@(PositionedBinder pos _ _) = return ((Just pos, bound), v)
253− updateBinder s@(pos, _) (ConstructorBinder name b) = (,) s <$> (ConstructorBinder <$> updateDataConstructorName name pos <*> pure b)
254− updateBinder s v = return (s, v)
255−
256− updateCase :: (Maybe SourceSpan, [Ident]) -> CaseAlternative -> m ((Maybe SourceSpan, [Ident]), CaseAlternative)
257− updateCase (pos, bound) c@(CaseAlternative bs _) = return ((pos, concatMap binderNames bs ++ bound), c)
258−
259− letBoundVariable :: Declaration -> Maybe Ident
260− letBoundVariable (ValueDeclaration ident _ _ _) = Just ident
261− letBoundVariable (PositionedDeclaration _ _ d) = letBoundVariable d
262− letBoundVariable _ = Nothing
263−
264− updateTypesEverywhere :: Maybe SourceSpan -> Type -> m Type
265− updateTypesEverywhere pos0 = everywhereOnTypesM (updateType pos0)
266− where
267− updateType :: Maybe SourceSpan -> Type -> m Type
268− updateType pos (TypeConstructor name) = TypeConstructor <$> updateTypeName name pos
269− updateType pos (SaturatedTypeSynonym name tys) = SaturatedTypeSynonym <$> updateTypeName name pos <*> pure tys
270− updateType pos (ConstrainedType cs t) = ConstrainedType <$> updateConstraints pos cs <*> pure t
271− updateType _ t = return t
272−
273− updateConstraints pos = mapM (\(name, ts) -> (,) <$> updateClassName name pos <*> mapM (updateTypesEverywhere pos) ts)
274−
275− updateTypeName = update UnknownType importedTypes (\mes -> isJust . (`lookup` exportedTypes mes))
276− updateClassName = update UnknownTypeClass importedTypeClasses (flip elem . exportedTypeClasses)
277− updateValueName = update UnknownValue importedValues (flip elem . exportedValues)
278− updateDataConstructorName = update (flip UnknownDataConstructor Nothing) importedDataConstructors (\mes -> flip elem (join $ snd `map` exportedTypes mes))
279−
280− -- Update names so unqualified references become qualified, and locally qualified references
281− -- are replaced with their canoncial qualified names (e.g. M.Map -> Data.Map.Map)
282− update :: (Ord a, Show a) => (Qualified a -> ErrorMessage)
283− -> (ImportEnvironment -> M.Map (Qualified a) (Qualified a))
284− -> (Exports -> a -> Bool)
285− -> Qualified a
286− -> Maybe SourceSpan
287− -> m (Qualified a)
288− update unknown getI checkE qname@(Qualified mn' name) pos = positioned $ case (M.lookup qname imports', mn') of
289− (Just qname', _) -> return qname'
290− (Nothing, Just mn'') -> do
291− when (isExplicitQualModule mn'') . throwError . errorMessage $ unknown qname
292− modExports <- getExports mn''
293− if checkE modExports name
294− then return qname
295− else throwError . errorMessage $ unknown qname
296− _ -> throwError . errorMessage $ unknown qname
297− where
298− isExplicitQualModule :: ModuleName -> Bool
299− isExplicitQualModule = flip elem $ mapMaybe (\(Qualified q _) -> q) (M.keys imports')
300− imports' = getI imports
301− positioned err = case pos of
302− Nothing -> err
303− Just pos' -> rethrowWithPosition pos' err
304−
305− -- Gets the exports for a module, or an error message if the module doesn't exist
306− getExports :: ModuleName -> m Exports
307− getExports mn' = maybe (throwError . errorMessage $ UnknownModule mn') return $ M.lookup mn' exports
308−
309−-- |
310−-- Finds all exported declarations in a set of modules.
311−--
312−findExports :: forall m. (Applicative m, MonadError MultipleErrors m) => [Module] -> m ExportEnvironment
313−findExports = foldM addModule $ M.singleton (ModuleName [ProperName C.prim]) primExports
314− where
315−
316− -- The exported types from the Prim module
317− primExports = Exports (mkTypeEntry `map` M.keys primTypes) [] []
318− where
319− mkTypeEntry (Qualified _ name) = (name, [])
320−
321− -- Add all of the exported declarations from a module to the global export environment
322− addModule :: ExportEnvironment -> Module -> m ExportEnvironment
323− addModule env (Module _ mn ds _) = do
324− env' <- addEmptyModule env mn
325− rethrow (onErrorMessages (ErrorInModule mn)) $ foldM (addDecl mn) env' ds
326−
327− -- Add a declaration from a module to the global export environment
328− addDecl :: ModuleName -> ExportEnvironment -> Declaration -> m ExportEnvironment
329− addDecl mn env (TypeClassDeclaration tcn _ _ ds) = do
330− env' <- addTypeClass env mn tcn
331− foldM go env' ds
332− where
333− go env'' (TypeDeclaration name _) = addValue env'' mn name
334− go env'' (PositionedDeclaration pos _ d) = rethrowWithPosition pos $ go env'' d
335− go _ _ = error "Invalid declaration in TypeClassDeclaration"
336− addDecl mn env (DataDeclaration _ tn _ dcs) = addType env mn tn (map fst dcs)
337− addDecl mn env (TypeSynonymDeclaration tn _ _) = addType env mn tn []
338− addDecl mn env (ExternDataDeclaration tn _) = addType env mn tn []
339− addDecl mn env (ValueDeclaration name _ _ _) = addValue env mn name
340− addDecl mn env (ExternDeclaration _ name _ _) = addValue env mn name
341− addDecl mn env (PositionedDeclaration pos _ d) = rethrowWithPosition pos $ addDecl mn env d
342− addDecl _ env _ = return env
343−
344−-- |
345−-- Filters the exports for a module to ensure only explicit exports are kept in the global exports
346−-- environment.
347−--
348−filterExports :: forall m. (Applicative m, MonadError MultipleErrors m) => ModuleName -> [DeclarationRef] -> ExportEnvironment -> m ExportEnvironment
349−filterExports mn exps env = do
350− let moduleExports = fromMaybe (error "Module is missing") (mn `M.lookup` env)
351− moduleExports' <- rethrow (onErrorMessages (ErrorInModule mn)) $ filterModule moduleExports
352− return $ M.insert mn moduleExports' env
353− where
354−
355− -- Filter the exports for the specific module
356− filterModule :: Exports -> m Exports
357− filterModule exported = do
358− types' <- foldM (filterTypes $ exportedTypes exported) [] exps
359− values <- foldM (filterValues $ exportedValues exported) [] exps
360− classes <- foldM (filterClasses $ exportedTypeClasses exported) [] exps
361− return exported { exportedTypes = types', exportedTypeClasses = classes, exportedValues = values }
362−
363− -- Ensure the exported types and data constructors exist in the module and add them to the set of
364− -- exports
365− filterTypes :: [(ProperName, [ProperName])] -> [(ProperName, [ProperName])] -> DeclarationRef -> m [(ProperName, [ProperName])]
366− filterTypes expTys result (PositionedDeclarationRef pos _ r) = rethrowWithPosition pos $ filterTypes expTys result r
367− filterTypes expTys result (TypeRef name expDcons) = do
368− dcons <- maybe (throwError . errorMessage . UnknownType $ Qualified (Just mn) name) return $ name `lookup` expTys
369− dcons' <- maybe (return dcons) (foldM (filterDcons name dcons) []) expDcons
370− return $ (name, dcons') : result
371− filterTypes _ result _ = return result
372−
373− -- Ensure the exported data constructors exists for a type and add them to the list of exports
374− filterDcons :: ProperName -> [ProperName] -> [ProperName] -> ProperName -> m [ProperName]
375− filterDcons tcon exps' result name =
376− if name `elem` exps'
377− then return $ name : result
378− else throwError . errorMessage $ UnknownDataConstructor (Qualified (Just mn) name) (Just (Qualified (Just mn) tcon))
379−
380− -- Ensure the exported classes exist in the module and add them to the set of exports
381− filterClasses :: [ProperName] -> [ProperName] -> DeclarationRef -> m [ProperName]
382− filterClasses exps' result (PositionedDeclarationRef pos _ r) = rethrowWithPosition pos $ filterClasses exps' result r
383− filterClasses exps' result (TypeClassRef name) =
384− if name `elem` exps'
385− then return $ name : result
386− else throwError . errorMessage . UnknownTypeClass $ Qualified (Just mn) name
387− filterClasses _ result _ = return result
388−
389− -- Ensure the exported values exist in the module and add them to the set of exports
390− filterValues :: [Ident] -> [Ident] -> DeclarationRef -> m [Ident]
391− filterValues exps' result (PositionedDeclarationRef pos _ r) = rethrowWithPosition pos $ filterValues exps' result r
392− filterValues exps' result (ValueRef name) =
393− if name `elem` exps'
394− then return $ name : result
395− else throwError . errorMessage . UnknownValue $ Qualified (Just mn) name
396− filterValues _ result _ = return result
397−
398−-- |
399−-- Finds the imports within a module, mapping the imported module name to an optional set of
400−-- explicitly imported declarations.
401−--
402−findImports :: [Declaration] -> M.Map ModuleName (Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)
403−findImports = foldl (findImports' Nothing) M.empty
404− where
405− findImports' pos result (ImportDeclaration mn typ qual) = M.insert mn (pos, typ, qual) result
406− findImports' _ result (PositionedDeclaration pos _ d) = findImports' (Just pos) result d
407− findImports' _ result _ = result
408−
409−-- |
410−-- Constructs a local environment for a module.
411−--
412−resolveImports :: forall m. (Applicative m, MonadError MultipleErrors m) => ExportEnvironment -> Module -> m ImportEnvironment
413−resolveImports env (Module _ currentModule decls _) =
414− foldM resolveImport' (ImportEnvironment M.empty M.empty M.empty M.empty) (M.toList scope)
415− where
416−
417− -- A Map from module name to the source position for the import, the list of imports from that
418− -- module (where Nothing indicates everything is to be imported), and optionally a qualified name
419− -- for the module
420− scope :: M.Map ModuleName (Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)
421− scope = M.insert currentModule (Nothing, Implicit, Nothing) (findImports decls)
422−
423− resolveImport' :: ImportEnvironment -> (ModuleName, (Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)) -> m ImportEnvironment
424− resolveImport' imp (mn, (pos, typ, impQual)) = do
425− modExports <- positioned $ maybe (throwError . errorMessage $ UnknownModule mn) return $ mn `M.lookup` env
426− positioned $ resolveImport currentModule mn modExports imp impQual typ
427− where
428− positioned err = case pos of
429− Nothing -> err
430− Just pos' -> rethrowWithPosition pos' err
431−
432−-- |
433−-- Extends the local environment for a module by resolving an import of another module.
434−--
435−resolveImport :: forall m. (Applicative m, MonadError MultipleErrors m) => ModuleName -> ModuleName -> Exports -> ImportEnvironment -> Maybe ModuleName -> ImportDeclarationType -> m ImportEnvironment
436−resolveImport currentModule importModule exps imps impQual =
437− resolveByType
438− where
439−
440− resolveByType :: ImportDeclarationType -> m ImportEnvironment
441− resolveByType Implicit = importAll importExplicit
442− resolveByType (Explicit explImports) = (checkedRefs >=> foldM importExplicit imps) explImports
443− resolveByType (Hiding hiddenImports) = do
444− hiddenImports' <- checkedRefs hiddenImports
445− importAll (importNonHidden hiddenImports')
446−
447− importNonHidden :: [DeclarationRef] -> ImportEnvironment -> DeclarationRef -> m ImportEnvironment
448− importNonHidden hidden m ref =
449− if isHidden hidden ref
450− then return m
451− else importExplicit m ref
452−
453− isHidden :: [DeclarationRef] -> DeclarationRef -> Bool
454− isHidden hidden ref@(TypeRef _ _) =
455− let
456− checkTypeRef _ True _ = True
457− checkTypeRef (TypeRef _ Nothing) acc (TypeRef _ (Just _)) = acc
458− checkTypeRef (TypeRef name (Just dctor)) _ (TypeRef name' (Just dctor')) = name == name' && dctor == dctor'
459− checkTypeRef (TypeRef name _) _ (TypeRef name' Nothing) = name == name'
460− checkTypeRef (PositionedDeclarationRef _ _ r) acc hiddenRef = checkTypeRef r acc hiddenRef
461− checkTypeRef _ acc _ = acc
462− in foldl (checkTypeRef ref) False hidden
463− isHidden hidden ref = ref `elem` hidden
464−
465− -- Import all symbols
466− importAll :: (ImportEnvironment -> DeclarationRef -> m ImportEnvironment) -> m ImportEnvironment
467− importAll importer = do
468− imp' <- foldM (\m (name, dctors) -> importer m (TypeRef name (Just dctors))) imps (exportedTypes exps)
469− imp'' <- foldM (\m name -> importer m (ValueRef name)) imp' (exportedValues exps)
470− foldM (\m name -> importer m (TypeClassRef name)) imp'' (exportedTypeClasses exps)
471−
472− -- Import something explicitly
473− importExplicit :: ImportEnvironment -> DeclarationRef -> m ImportEnvironment
474− importExplicit imp (PositionedDeclarationRef pos _ r) = rethrowWithPosition pos $ importExplicit imp r
475− importExplicit imp (ValueRef name) = do
476− values' <- updateImports (importedValues imp) name
477− return $ imp { importedValues = values' }
478− importExplicit imp (TypeRef name dctors) = do
479− types' <- updateImports (importedTypes imp) name
480− let allDctors = allExportedDataConstructors name
481− dctors' <- maybe (return allDctors) (mapM $ checkDctorExists allDctors) dctors
482− dctors'' <- foldM updateImports (importedDataConstructors imp) dctors'
483− return $ imp { importedTypes = types', importedDataConstructors = dctors'' }
484− importExplicit imp (TypeClassRef name) = do
485− typeClasses' <- updateImports (importedTypeClasses imp) name
486− return $ imp { importedTypeClasses = typeClasses' }
487− importExplicit _ _ = error "Invalid argument to importExplicit"
488−
489− -- Check if DeclarationRef points to an existent symbol
490− checkedRefs :: [DeclarationRef] -> m [DeclarationRef]
491− checkedRefs = mapM check
492− where
493− check (PositionedDeclarationRef pos _ r) =
494− rethrowWithPosition pos $ check r
495− check ref@(ValueRef name) =
496− checkImportExists UnknownValue values name >> return ref
497− check ref@(TypeRef name dctors) = do
498− _ <- checkImportExists UnknownType availableTypes name
499− let allDctors = allExportedDataConstructors name
500− _ <- maybe (return allDctors) (mapM $ checkDctorExists allDctors) dctors
501− return ref
502− check ref@(TypeClassRef name) =
503− checkImportExists UnknownTypeClass classes name >> return ref
504− check _ = error "Invalid argument to checkRefIsValid"
505−
506− -- Find all exported data constructors for a given type
507− allExportedDataConstructors :: ProperName -> [ProperName]
508− allExportedDataConstructors name = fromMaybe [] $ name `lookup` exportedTypes exps
509−
510− -- Add something to the ImportEnvironment if it does not already exist there
511− updateImports :: (Ord a, Show a) => M.Map (Qualified a) (Qualified a) -> a -> m (M.Map (Qualified a) (Qualified a))
512− updateImports m name = case M.lookup (Qualified impQual name) m of
513− Nothing -> return $ M.insert (Qualified impQual name) (Qualified (Just importModule) name) m
514− Just (Qualified Nothing _) -> error "Invalid state in updateImports"
515− Just (Qualified (Just mn) _) -> throwError . errorMessage $ err
516− where
517− err = if mn == currentModule || importModule == currentModule
518− then ConflictingImport (show name) mn
519− else ConflictingImports (show name) mn importModule
520−
521− -- The available values, types, and classes in the module being imported
522− values = exportedValues exps
523− availableTypes = fst `map` exportedTypes exps
524− classes = exportedTypeClasses exps
525−
526− -- Ensure that an explicitly imported data constructor exists for the type it is being imported
527− -- from
528− checkDctorExists :: [ProperName] -> ProperName -> m ProperName
529− checkDctorExists = checkImportExists (flip UnknownDataConstructor Nothing)
530−
531− -- Check that an explicitly imported item exists in the module it is being imported from
532− checkImportExists :: (Eq a, Show a) => (Qualified a -> ErrorMessage) -> [a] -> a -> m a
533− checkImportExists unknown exports item =
534− if item `elem` exports
535− then return item
536− else throwError . errorMessage . unknown $ Qualified (Just importModule) item
537−
538−-- |
539−-- Raises an error for when there is more than one definition for something.
540−--
541−throwConflictError :: (Applicative m, MonadError MultipleErrors m, Show a) => (a -> ErrorMessage) -> a -> m b
542−throwConflictError conflict = throwError . errorMessage . conflict
src/Language/PureScript/Sugar/ObjectWildcards.hsdeleted−65
@@ -1,65 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.Sugar.ObjectWildcards
4−-- Copyright : (c) 2013-14 Phil Freeman, (c) 2014 Gary Burgess, and other contributors
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- |
12−--
13−-----------------------------------------------------------------------------
14−
15−{-# LANGUAGE FlexibleContexts #-}
16−{-# LANGUAGE ScopedTypeVariables #-}
17−
18−module Language.PureScript.Sugar.ObjectWildcards (
19− desugarObjectConstructors
20−) where
21−
22−import Control.Applicative
23−import Control.Arrow (second)
24−import Control.Monad.Error.Class (MonadError(..))
25−import Control.Monad.Supply.Class
26−
27−import Data.List (partition)
28−import Data.Maybe (isJust, fromJust, catMaybes)
29−
30−import Language.PureScript.AST
31−import Language.PureScript.Errors
32−import Language.PureScript.Names
33−
34−desugarObjectConstructors :: forall m. (Applicative m, MonadSupply m, MonadError MultipleErrors m) => Module -> m Module
35−desugarObjectConstructors (Module coms mn ds exts) = Module coms mn <$> mapM desugarDecl ds <*> pure exts
36− where
37−
38− desugarDecl :: Declaration -> m Declaration
39− (desugarDecl, _, _) = everywhereOnValuesM return desugarExpr return
40−
41− desugarExpr :: Expr -> m Expr
42− desugarExpr (ObjectConstructor ps) = wrapLambda ObjectLiteral ps
43− desugarExpr (ObjectUpdater (Just obj) ps) = wrapLambda (ObjectUpdate obj) ps
44− desugarExpr (ObjectUpdater Nothing ps) = do
45− obj <- Ident <$> freshName
46− Abs (Left obj) <$> wrapLambda (ObjectUpdate (Var (Qualified Nothing obj))) ps
47− desugarExpr (ObjectGetter prop) = do
48− arg <- Ident <$> freshName
49− return $ Abs (Left arg) (Accessor prop (Var (Qualified Nothing arg)))
50− desugarExpr e = return e
51−
52− wrapLambda :: ([(String, Expr)] -> Expr) -> [(String, Maybe Expr)] -> m Expr
53− wrapLambda mkVal ps =
54− let (props, args) = partition (isJust . snd) ps
55− in if null args
56− then return . mkVal $ second fromJust `map` props
57− else do
58− (args', ps') <- unzip <$> mapM mkProp ps
59− return $ foldr (Abs . Left) (mkVal ps') (catMaybes args')
60−
61− mkProp :: (String, Maybe Expr) -> m (Maybe Ident, (String, Expr))
62− mkProp (name, Just e) = return (Nothing, (name, e))
63− mkProp (name, Nothing) = do
64− arg <- Ident <$> freshName
65− return (Just arg, (name, Var (Qualified Nothing arg)))
src/Language/PureScript/Sugar/Operators.hsdeleted−166
@@ -1,166 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.Sugar.Operators
4−-- Copyright : (c) Phil Freeman 2013
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- |
12−-- This module implements the desugaring pass which reapplies binary operators based
13−-- on their fixity data and removes explicit parentheses.
14−--
15−-- The value parser ignores fixity data when parsing binary operator applications, so
16−-- it is necessary to reorder them here.
17−--
18−-----------------------------------------------------------------------------
19−
20−{-# LANGUAGE Rank2Types #-}
21−{-# LANGUAGE FlexibleContexts #-}
22−{-# LANGUAGE ScopedTypeVariables #-}
23−
24−module Language.PureScript.Sugar.Operators (
25− rebracket,
26− removeSignedLiterals,
27− desugarOperatorSections
28−) where
29−
30−import Language.PureScript.AST
31−import Language.PureScript.Errors
32−import Language.PureScript.Names
33−
34−import Control.Applicative
35−import Control.Monad.State
36−import Control.Monad.Error.Class (MonadError(..))
37−import Control.Monad.Supply.Class
38−
39−import Data.Function (on)
40−import Data.Functor.Identity
41−import Data.List (groupBy, sortBy)
42−
43−import qualified Text.Parsec as P
44−import qualified Text.Parsec.Pos as P
45−import qualified Text.Parsec.Expr as P
46−
47−import qualified Language.PureScript.Constants as C
48−
49−-- |
50−-- Remove explicit parentheses and reorder binary operator applications
51−--
52−rebracket :: (Applicative m, MonadError MultipleErrors m) => [Module] -> m [Module]
53−rebracket ms = do
54− let fixities = concatMap collectFixities ms
55− ensureNoDuplicates $ map (\(i, pos, _) -> (i, pos)) fixities
56− let opTable = customOperatorTable $ map (\(i, _, f) -> (i, f)) fixities
57− mapM (rebracketModule opTable) ms
58−
59−removeSignedLiterals :: Module -> Module
60−removeSignedLiterals (Module coms mn ds exts) = Module coms mn (map f' ds) exts
61− where
62− (f', _, _) = everywhereOnValues id go id
63−
64− go (UnaryMinus val) = App (Var (Qualified (Just (ModuleName [ProperName C.prelude])) (Ident C.negate))) val
65− go other = other
66−
67−rebracketModule :: (Applicative m, MonadError MultipleErrors m) => [[(Qualified Ident, Expr -> Expr -> Expr, Associativity)]] -> Module -> m Module
68−rebracketModule opTable (Module coms mn ds exts) =
69− let (f, _, _) = everywhereOnValuesTopDownM return (matchOperators opTable) return
70− in Module coms mn <$> (map removeParens <$> parU ds f) <*> pure exts
71−
72−removeParens :: Declaration -> Declaration
73−removeParens =
74− let (f, _, _) = everywhereOnValues id go id
75− in f
76− where
77− go (Parens val) = val
78− go val = val
79−
80−collectFixities :: Module -> [(Qualified Ident, SourceSpan, Fixity)]
81−collectFixities (Module _ moduleName ds _) = concatMap collect ds
82− where
83− collect :: Declaration -> [(Qualified Ident, SourceSpan, Fixity)]
84− collect (PositionedDeclaration pos _ (FixityDeclaration fixity name)) = [(Qualified (Just moduleName) (Op name), pos, fixity)]
85− collect FixityDeclaration{} = error "Fixity without srcpos info"
86− collect _ = []
87−
88−ensureNoDuplicates :: (MonadError MultipleErrors m) => [(Qualified Ident, SourceSpan)] -> m ()
89−ensureNoDuplicates m = go $ sortBy (compare `on` fst) m
90− where
91− go [] = return ()
92− go [_] = return ()
93− go ((x@(Qualified (Just mn) name), _) : (y, pos) : _) | x == y =
94− rethrow (onErrorMessages (ErrorInModule mn)) $
95− rethrowWithPosition pos $
96− throwError . errorMessage $ MultipleFixities name
97− go (_ : rest) = go rest
98−
99−customOperatorTable :: [(Qualified Ident, Fixity)] -> [[(Qualified Ident, Expr -> Expr -> Expr, Associativity)]]
100−customOperatorTable fixities =
101− let
102− applyUserOp ident t1 = App (App (Var ident) t1)
103− userOps = map (\(name, Fixity a p) -> (name, applyUserOp name, p, a)) fixities
104− sorted = sortBy (flip compare `on` (\(_, _, p, _) -> p)) userOps
105− groups = groupBy ((==) `on` (\(_, _, p, _) -> p)) sorted
106− in
107− map (map (\(name, f, _, a) -> (name, f, a))) groups
108−
109−type Chain = [Either Expr Expr]
110−
111−matchOperators :: forall m. (MonadError MultipleErrors m) => [[(Qualified Ident, Expr -> Expr -> Expr, Associativity)]] -> Expr -> m Expr
112−matchOperators ops = parseChains
113− where
114− parseChains :: Expr -> m Expr
115− parseChains b@BinaryNoParens{} = bracketChain (extendChain b)
116− parseChains other = return other
117− extendChain :: Expr -> Chain
118− extendChain (BinaryNoParens op l r) = Left l : Right op : extendChain r
119− extendChain other = [Left other]
120− bracketChain :: Chain -> m Expr
121− bracketChain = either (const . throwError . errorMessage $ CannotReorderOperators) return . P.parse (P.buildExpressionParser opTable parseValue <* P.eof) "operator expression"
122− opTable = [P.Infix (P.try (parseTicks >>= \op -> return (\t1 t2 -> App (App op t1) t2))) P.AssocLeft]
123− : map (map (\(name, f, a) -> P.Infix (P.try (matchOp name) >> return f) (toAssoc a))) ops
124− ++ [[ P.Infix (P.try (parseOp >>= \ident -> return (\t1 t2 -> App (App (Var ident) t1) t2))) P.AssocLeft ]]
125−
126−toAssoc :: Associativity -> P.Assoc
127−toAssoc Infixl = P.AssocLeft
128−toAssoc Infixr = P.AssocRight
129−toAssoc Infix = P.AssocNone
130−
131−token :: (P.Stream s Identity t, Show t) => (t -> Maybe a) -> P.Parsec s u a
132−token = P.token show (const (P.initialPos ""))
133−
134−parseValue :: P.Parsec Chain () Expr
135−parseValue = token (either Just (const Nothing)) P.<?> "expression"
136−
137−parseOp :: P.Parsec Chain () (Qualified Ident)
138−parseOp = token (either (const Nothing) fromOp) P.<?> "operator"
139− where
140− fromOp (Var q@(Qualified _ (Op _))) = Just q
141− fromOp _ = Nothing
142−
143−parseTicks :: P.Parsec Chain () Expr
144−parseTicks = token (either (const Nothing) fromOther) P.<?> "infix function"
145− where
146− fromOther (Var (Qualified _ (Op _))) = Nothing
147− fromOther v = Just v
148−
149−matchOp :: Qualified Ident -> P.Parsec Chain () ()
150−matchOp op = do
151− ident <- parseOp
152− guard $ ident == op
153−
154−desugarOperatorSections :: forall m. (Applicative m, MonadSupply m, MonadError MultipleErrors m) => Module -> m Module
155−desugarOperatorSections (Module coms mn ds exts) = Module coms mn <$> mapM goDecl ds <*> pure exts
156− where
157−
158− goDecl :: Declaration -> m Declaration
159− (goDecl, _, _) = everywhereOnValuesM return goExpr return
160−
161− goExpr :: Expr -> m Expr
162− goExpr (OperatorSection op (Left val)) = return $ App op val
163− goExpr (OperatorSection op (Right val)) = do
164− arg <- Ident <$> freshName
165− return $ Abs (Left arg) $ App (App op (Var (Qualified Nothing arg))) val
166− goExpr other = return other
src/Language/PureScript/Sugar/TypeClasses.hsdeleted−297
@@ -1,297 +0,0 @@
1−-----------------------------------------------------------------------------
2−--
3−-- Module : Language.PureScript.Sugar.TypeClasses
4−-- Copyright : (c) Phil Freeman 2013
5−-- License : MIT
6−--
7−-- Maintainer : Phil Freeman <paf31@cantab.net>
8−-- Stability : experimental
9−-- Portability :
10−--
11−-- |
12−-- This module implements the desugaring pass which creates type synonyms for type class dictionaries
13−-- and dictionary expressions for type class instances.
14−--
15−-----------------------------------------------------------------------------
16−
17−{-# LANGUAGE FlexibleContexts #-}
18−
19−module Language.PureScript.Sugar.TypeClasses
20− ( desugarTypeClasses
21− , typeClassMemberName
22− , superClassDictionaryNames
23− ) where
24−
25−import Language.PureScript.AST hiding (isExported)
26−import Language.PureScript.Environment
27−import Language.PureScript.Errors
28−import Language.PureScript.Kinds
29−import Language.PureScript.Names
30−import Language.PureScript.Sugar.CaseDeclarations
31−import Control.Monad.Supply.Class
32−import Language.PureScript.Types
33−
34−import qualified Language.PureScript.Constants as C
35−
36−import Control.Applicative
37−import Control.Arrow (first, second)
38−import Control.Monad.Error.Class (MonadError(..))
39−import Control.Monad.State
40−import Data.List ((\\), find, sortBy)
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
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 :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Module] -> m [Module]
54−desugarTypeClasses = flip evalStateT M.empty . mapM desugarModule
55−
56−desugarModule :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => Module -> Desugar m Module
57−desugarModule (Module coms name decls (Just exps)) = do
58− (newExpss, declss) <- unzip <$> parU (sortBy classesFirst decls) (desugarDecl name exps)
59− return $ Module coms name (concat declss) $ Just (exps ++ catMaybes newExpss)
60− where
61− classesFirst :: Declaration -> Declaration -> Ordering
62− classesFirst d1 d2
63− | isTypeClassDeclaration d1 && not (isTypeClassDeclaration d2) = LT
64− | not (isTypeClassDeclaration d1) && isTypeClassDeclaration d2 = GT
65− | otherwise = EQ
66−desugarModule _ = error "Exports should have been elaborated in name desugaring"
67−
68−{- Desugar type class and type class instance declarations
69−--
70−-- Type classes become type synonyms for their dictionaries, and type instances become dictionary declarations.
71−-- Additional values are generated to access individual members of a dictionary, with the appropriate type.
72−--
73−-- E.g. the following
74−--
75−-- module Test where
76−--
77−-- class Foo a where
78−-- foo :: a -> a
79−--
80−-- instance fooString :: Foo String where
81−-- foo s = s ++ s
82−--
83−-- instance fooArray :: (Foo a) => Foo [a] where
84−-- foo = map foo
85−--
86−-- {- Superclasses -}
87−--
88−-- class (Foo a) <= Sub a where
89−-- sub :: a
90−--
91−-- instance subString :: Sub String where
92−-- sub = ""
93−--
94−-- becomes:
95−--
96−-- <TypeClassDeclaration Foo ...>
97−--
98−-- type Foo a = { foo :: a -> a }
99−--
100−-- -- this following type is marked as not needing to be checked so a new Abs
101−-- -- is not introduced around the definition in type checking, but when
102−-- -- called the dictionary value is still passed in for the `dict` argument
103−-- foo :: forall a. (Foo a) => a -> a
104−-- foo dict = dict.foo
105−--
106−-- fooString :: {} -> Foo String
107−-- fooString _ = <TypeClassDictionaryConstructorApp Foo { foo: \s -> s ++ s }>
108−--
109−-- fooArray :: forall a. (Foo a) => Foo [a]
110−-- fooArray = <TypeClassDictionaryConstructorApp Foo { foo: map foo }>
111−--
112−-- {- Superclasses -}
113−--
114−-- <TypeClassDeclaration Sub ...>
115−--
116−-- type Sub a = { sub :: a
117−-- , "__superclass_Foo_0" :: {} -> Foo a
118−-- }
119−--
120−-- -- As with `foo` above, this type is unchecked at the declaration
121−-- sub :: forall a. (Sub a) => a
122−-- sub dict = dict.sub
123−--
124−-- subString :: {} -> Sub String
125−-- subString _ = { sub: "",
126−-- , "__superclass_Foo_0": \_ -> <SuperClassDictionary Foo String>
127−-- }
128−--
129−-- and finally as the generated javascript:
130−--
131−-- function Foo(foo) {
132−-- this.foo = foo;
133−-- };
134−--
135−-- var foo = function (dict) {
136−-- return dict.foo;
137−-- };
138−--
139−-- var fooString = function (_) {
140−-- return new Foo(function (s) {
141−-- return s + s;
142−-- });
143−-- };
144−--
145−-- var fooArray = function (__dict_Foo_15) {
146−-- return new Foo(map(foo(__dict_Foo_15)));
147−-- };
148−--
149−-- function Sub(__superclass_Foo_0, sub) {
150−-- this["__superclass_Foo_0"] = __superclass_Foo_0;
151−-- this.sub = sub;
152−-- };
153−--
154−-- var sub = function (dict) {
155−-- return dict.sub;
156−-- };
157−--
158−-- var subString = function (_) {
159−-- return new Sub(fooString, "");
160−-- };
161−-}
162−desugarDecl :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => ModuleName -> [DeclarationRef] -> Declaration -> Desugar m (Maybe DeclarationRef, [Declaration])
163−desugarDecl mn exps = go
164− where
165− go d@(TypeClassDeclaration name args implies members) = do
166− modify (M.insert (mn, name) d)
167− return (Nothing, d : typeClassDictionaryDeclaration name args implies members : map (typeClassMemberToDictionaryAccessor mn name args) members)
168− go d@(ExternInstanceDeclaration name _ className tys) = return (expRef name className tys, [d])
169− go d@(TypeInstanceDeclaration name deps className tys members) = do
170− desugared <- desugarCases members
171− dictDecl <- typeInstanceDictionaryDeclaration name mn deps className tys desugared
172− return (expRef name className tys, [d, dictDecl])
173− go (PositionedDeclaration pos com d) = do
174− (dr, ds) <- rethrowWithPosition pos $ desugarDecl mn exps d
175− return (dr, map (PositionedDeclaration pos com) ds)
176− go other = return (Nothing, [other])
177−
178− expRef :: Ident -> Qualified ProperName -> [Type] -> Maybe DeclarationRef
179− expRef name className tys
180− | isExportedClass className && all isExportedType (getConstructors `concatMap` tys) = Just $ TypeInstanceRef name
181− | otherwise = Nothing
182−
183− isExportedClass :: Qualified ProperName -> Bool
184− isExportedClass = isExported (elem . TypeClassRef)
185−
186− isExportedType :: Qualified ProperName -> Bool
187− isExportedType = isExported $ \pn -> isJust . find (matchesTypeRef pn)
188−
189− isExported :: (ProperName -> [DeclarationRef] -> Bool) -> Qualified ProperName -> Bool
190− isExported test (Qualified (Just mn') pn) = mn /= mn' || test pn exps
191− isExported _ _ = error "Names should have been qualified in name desugaring"
192−
193− matchesTypeRef :: ProperName -> DeclarationRef -> Bool
194− matchesTypeRef pn (TypeRef pn' _) = pn == pn'
195− matchesTypeRef _ _ = False
196−
197− getConstructors :: Type -> [Qualified ProperName]
198− getConstructors = everythingOnTypes (++) getConstructor
199−
200− getConstructor :: Type -> [Qualified ProperName]
201− getConstructor (TypeConstructor tcname) = [tcname]
202− getConstructor _ = []
203−
204−memberToNameAndType :: Declaration -> (Ident, Type)
205−memberToNameAndType (TypeDeclaration ident ty) = (ident, ty)
206−memberToNameAndType (PositionedDeclaration _ _ d) = memberToNameAndType d
207−memberToNameAndType _ = error "Invalid declaration in type class definition"
208−
209−typeClassDictionaryDeclaration :: ProperName -> [(String, Maybe Kind)] -> [Constraint] -> [Declaration] -> Declaration
210−typeClassDictionaryDeclaration name args implies members =
211− let superclassTypes = superClassDictionaryNames implies `zip`
212− [ function unit (foldl TypeApp (TypeConstructor superclass) tyArgs)
213− | (superclass, tyArgs) <- implies
214− ]
215− members' = map (first runIdent . memberToNameAndType) members
216− mtys = members' ++ superclassTypes
217− in TypeSynonymDeclaration name args (TypeApp tyObject $ rowFromList (mtys, REmpty))
218−
219−typeClassMemberToDictionaryAccessor :: ModuleName -> ProperName -> [(String, Maybe Kind)] -> Declaration -> Declaration
220−typeClassMemberToDictionaryAccessor mn name args (TypeDeclaration ident ty) =
221− let className = Qualified (Just mn) name
222− in ValueDeclaration ident TypeClassAccessorImport [] $ Right $
223− TypedValue False (TypeClassDictionaryAccessor className ident) $
224− moveQuantifiersToFront (quantify (ConstrainedType [(className, map (TypeVar . fst) args)] ty))
225−typeClassMemberToDictionaryAccessor mn name args (PositionedDeclaration pos com d) =
226− PositionedDeclaration pos com $ typeClassMemberToDictionaryAccessor mn name args d
227−typeClassMemberToDictionaryAccessor _ _ _ _ = error "Invalid declaration in type class definition"
228−
229−unit :: Type
230−unit = TypeApp tyObject REmpty
231−
232−typeInstanceDictionaryDeclaration :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => Ident -> ModuleName -> [Constraint] -> Qualified ProperName -> [Type] -> [Declaration] -> Desugar m Declaration
233−typeInstanceDictionaryDeclaration name mn deps className tys decls =
234− rethrow (onErrorMessages (ErrorInInstance className tys)) $ do
235− m <- get
236−
237− -- Lookup the type arguments and member types for the type class
238− (TypeClassDeclaration _ args implies tyDecls) <-
239− maybe (throwError . errorMessage $ UnknownTypeClass className) return $
240− M.lookup (qualify mn className) m
241−
242− case mapMaybe declName tyDecls \\ mapMaybe declName decls of
243− member : _ -> throwError . errorMessage $ MissingClassMember member
244− [] -> do
245−
246− let instanceTys = map memberToNameAndType tyDecls
247−
248− -- Replace the type arguments with the appropriate types in the member types
249− let memberTypes = map (second (replaceAllTypeVars (zip (map fst args) tys))) instanceTys
250−
251− -- Create values for the type instance members
252− members <- zip (map typeClassMemberName decls) <$> mapM (memberToValue memberTypes) decls
253−
254− -- Create the type of the dictionary
255− -- The type is an object type, but depending on type instance dependencies, may be constrained.
256− -- The dictionary itself is an object literal.
257− let superclasses = superClassDictionaryNames implies `zip`
258− [ Abs (Left (Ident C.__unused)) (SuperClassDictionary superclass tyArgs)
259− | (superclass, suTyArgs) <- implies
260− , let tyArgs = map (replaceAllTypeVars (zip (map fst args) tys)) suTyArgs
261− ]
262−
263− let props = ObjectLiteral (members ++ superclasses)
264− dictTy = foldl TypeApp (TypeConstructor className) tys
265− constrainedTy = quantify (if null deps then dictTy else ConstrainedType deps dictTy)
266− dict = TypeClassDictionaryConstructorApp className props
267− result = ValueDeclaration name TypeInstanceDictionaryValue [] (Right (TypedValue True dict constrainedTy))
268− return result
269−
270− where
271−
272− declName :: Declaration -> Maybe Ident
273− declName (PositionedDeclaration _ _ d) = declName d
274− declName (ValueDeclaration ident _ _ _) = Just ident
275− declName (TypeDeclaration ident _) = Just ident
276− declName _ = Nothing
277−
278− memberToValue :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [(Ident, Type)] -> Declaration -> Desugar m Expr
279− memberToValue tys' (ValueDeclaration ident _ [] (Right val)) = do
280− _ <- maybe (throwError . errorMessage $ MissingClassMember ident) return $ lookup ident tys'
281− return val
282− memberToValue tys' (PositionedDeclaration pos com d) = rethrowWithPosition pos $ do
283− val <- memberToValue tys' d
284− return (PositionedValue pos com val)
285− memberToValue _ _ = error "Invalid declaration in type instance definition"
286−
287−typeClassMemberName :: Declaration -> String
288−typeClassMemberName (TypeDeclaration ident _) = runIdent ident
289−typeClassMemberName (ValueDeclaration ident _ _ _) = runIdent ident
290−typeClassMemberName (PositionedDeclaration _ _ d) = typeClassMemberName d
291−typeClassMemberName d = error $ "Invalid declaration in type class definition: " ++ show d
292−
293−superClassDictionaryNames :: [Constraint] -> [String]
294−superClassDictionaryNames supers =
295− [ C.__superclass_ ++ show pn ++ "_" ++ show (index :: Integer)
296− | (index, (pn, _)) <- zip [0..] supers
297− ]
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−{-# LANGUAGE FlexibleContexts #-}
18−
19−module Language.PureScript.Sugar.TypeDeclarations (
20− desugarTypeDeclarations,
21− desugarTypeDeclarationsModule
22−) where
23−
24−import Control.Applicative
25−import Control.Monad (forM)
26−import Control.Monad.Error.Class (MonadError(..))
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 :: (Functor m, Applicative m, MonadError MultipleErrors m) => [Module] -> m [Module]
38−desugarTypeDeclarationsModule ms = forM ms $ \(Module coms name ds exps) ->
39− rethrow (onErrorMessages (ErrorInModule name)) $
40− Module coms name <$> desugarTypeDeclarations ds <*> pure exps
41−
42−-- |
43−-- Replace all top level type declarations with type annotations
44−--
45−desugarTypeDeclarations :: (Functor m, Applicative m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]
46−desugarTypeDeclarations (PositionedDeclaration pos com d : ds) = do
47− (d' : ds') <- rethrowWithPosition pos $ desugarTypeDeclarations (d : ds)
48− return (PositionedDeclaration pos com d' : ds')
49−desugarTypeDeclarations (TypeDeclaration name ty : d : rest) = do
50− (_, nameKind, val) <- fromValueDeclaration d
51− desugarTypeDeclarations (ValueDeclaration name nameKind [] (Right (TypedValue True val ty)) : rest)
52− where
53− fromValueDeclaration :: (Functor m, Applicative m, MonadError MultipleErrors m) => Declaration -> m (Ident, NameKind, Expr)
54− fromValueDeclaration (ValueDeclaration name' nameKind [] (Right val)) | name == name' = return (name', nameKind, val)
55− fromValueDeclaration (PositionedDeclaration pos com d') = do
56− (ident, nameKind, val) <- rethrowWithPosition pos $ fromValueDeclaration d'
57− return (ident, nameKind, PositionedValue pos com val)
58− fromValueDeclaration _ = throwError . errorMessage $ OrphanTypeDeclaration name
59−desugarTypeDeclarations (TypeDeclaration name _ : []) = throwError . errorMessage $ OrphanTypeDeclaration name
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/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−347
@@ -1,347 +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, (\\))
30−import Data.Foldable (for_)
31−
32−import qualified Data.Map as M
33−
34−import Control.Monad.State
35−import Control.Monad.Error.Class (MonadError(..))
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 (onErrorMessages (ErrorInDataConstructor dctor)) $
51− addDataConstructor moduleName dtype name (map fst args) dctor tys
52−
53−addDataConstructor :: ModuleName -> DataDeclType -> ProperName -> [String] -> ProperName -> [Type] -> Check ()
54−addDataConstructor moduleName dtype name args dctor tys = do
55− env <- getEnv
56− mapM_ checkTypeSynonyms tys
57− let retTy = foldl TypeApp (TypeConstructor (Qualified (Just moduleName) name)) (map TypeVar args)
58− let dctorTy = foldr function retTy tys
59− let polyType = mkForAll args dctorTy
60− let fields = [Ident ("value" ++ show n) | n <- [0..(length tys - 1)]]
61− putEnv $ env { dataConstructors = M.insert (Qualified (Just moduleName) dctor) (dtype, name, polyType, fields) (dataConstructors env) }
62−
63−addTypeSynonym :: ModuleName -> ProperName -> [(String, Maybe Kind)] -> Type -> Kind -> Check ()
64−addTypeSynonym moduleName name args ty kind = do
65− env <- getEnv
66− checkTypeSynonyms ty
67− putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (kind, TypeSynonym) (types env)
68− , typeSynonyms = M.insert (Qualified (Just moduleName) name) (args, ty) (typeSynonyms env) }
69−
70−valueIsNotDefined :: ModuleName -> Ident -> Check ()
71−valueIsNotDefined moduleName name = do
72− env <- getEnv
73− case M.lookup (moduleName, name) (names env) of
74− Just _ -> throwError . errorMessage $ RedefinedIdent name
75− Nothing -> return ()
76−
77−addValue :: ModuleName -> Ident -> Type -> NameKind -> Check ()
78−addValue moduleName name ty nameKind = do
79− env <- getEnv
80− putEnv (env { names = M.insert (moduleName, name) (ty, nameKind, Defined) (names env) })
81−
82−addTypeClass :: ModuleName -> ProperName -> [(String, Maybe Kind)] -> [Constraint] -> [Declaration] -> Check ()
83−addTypeClass moduleName pn args implies ds =
84− let members = map toPair ds in
85− modify $ \st -> st { checkEnv = (checkEnv st) { typeClasses = M.insert (Qualified (Just moduleName) pn) (args, members, implies) (typeClasses . checkEnv $ st) } }
86− where
87− toPair (TypeDeclaration ident ty) = (ident, ty)
88− toPair (PositionedDeclaration _ _ d) = toPair d
89− toPair _ = error "Invalid declaration in TypeClassDeclaration"
90−
91−addTypeClassDictionaries :: [TypeClassDictionaryInScope] -> Check ()
92−addTypeClassDictionaries entries =
93− let mentries = M.fromList [ ((canonicalizeDictionary entry, mn), entry) | entry@TypeClassDictionaryInScope{ tcdName = Qualified mn _ } <- entries ]
94− in modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = (typeClassDictionaries . checkEnv $ st) `M.union` mentries } }
95−
96−checkDuplicateTypeArguments :: [String] -> Check ()
97−checkDuplicateTypeArguments args = for_ firstDup $ \dup ->
98− throwError . errorMessage $ DuplicateTypeArgument dup
99− where
100− firstDup :: Maybe String
101− firstDup = listToMaybe $ args \\ nub args
102−
103−checkTypeClassInstance :: ModuleName -> Type -> Check ()
104−checkTypeClassInstance _ (TypeVar _) = return ()
105−checkTypeClassInstance _ (TypeConstructor ctor) = do
106− env <- getEnv
107− when (ctor `M.member` typeSynonyms env) . throwError . errorMessage $ TypeSynonymInstance
108− return ()
109−checkTypeClassInstance m (TypeApp t1 t2) = checkTypeClassInstance m t1 >> checkTypeClassInstance m t2
110−checkTypeClassInstance _ ty = throwError . errorMessage $ InvalidInstanceHead ty
111−
112−-- |
113−-- Check that type synonyms are fully-applied in a type
114−--
115−checkTypeSynonyms :: Type -> Check ()
116−checkTypeSynonyms = void . replaceAllTypeSynonyms
117−
118−-- |
119−-- Type check all declarations in a module
120−--
121−-- At this point, many declarations will have been desugared, but it is still necessary to
122−--
123−-- * Kind-check all types and add them to the @Environment@
124−--
125−-- * Type-check all values and add them to the @Environment@
126−--
127−-- * Bring type class instances into scope
128−--
129−-- * Process module imports
130−--
131−typeCheckAll :: Maybe ModuleName -> ModuleName -> [DeclarationRef] -> [Declaration] -> Check [Declaration]
132−typeCheckAll mainModuleName moduleName exps = go
133− where
134− go :: [Declaration] -> Check [Declaration]
135− go [] = return []
136− go (DataDeclaration dtype name args dctors : rest) = do
137− rethrow (onErrorMessages (ErrorInTypeConstructor name)) $ do
138− when (dtype == Newtype) $ checkNewtype dctors
139− checkDuplicateTypeArguments $ map fst args
140− ctorKind <- kindsOf True moduleName name args (concatMap snd dctors)
141− let args' = args `withKinds` ctorKind
142− addDataType moduleName dtype name args' dctors ctorKind
143− ds <- go rest
144− return $ DataDeclaration dtype name args dctors : ds
145− where
146− checkNewtype :: [(ProperName, [Type])] -> Check ()
147− checkNewtype [(_, [_])] = return ()
148− checkNewtype [(_, _)] = throwError . errorMessage $ InvalidNewtype
149− checkNewtype _ = throwError . errorMessage $ InvalidNewtype
150− go (d@(DataBindingGroupDeclaration tys) : rest) = do
151− rethrow (onErrorMessages ErrorInDataBindingGroup) $ do
152− let syns = mapMaybe toTypeSynonym tys
153− let dataDecls = mapMaybe toDataDecl tys
154− (syn_ks, data_ks) <- kindsOfAll moduleName syns (map (\(_, name, args, dctors) -> (name, args, concatMap snd dctors)) dataDecls)
155− forM_ (zip dataDecls data_ks) $ \((dtype, name, args, dctors), ctorKind) -> do
156− checkDuplicateTypeArguments $ map fst args
157− let args' = args `withKinds` ctorKind
158− addDataType moduleName dtype name args' dctors ctorKind
159− forM_ (zip syns syn_ks) $ \((name, args, ty), kind) -> do
160− checkDuplicateTypeArguments $ map fst args
161− let args' = args `withKinds` kind
162− addTypeSynonym moduleName name args' ty kind
163− ds <- go rest
164− return $ d : ds
165− where
166− toTypeSynonym (TypeSynonymDeclaration nm args ty) = Just (nm, args, ty)
167− toTypeSynonym (PositionedDeclaration _ _ d') = toTypeSynonym d'
168− toTypeSynonym _ = Nothing
169− toDataDecl (DataDeclaration dtype nm args dctors) = Just (dtype, nm, args, dctors)
170− toDataDecl (PositionedDeclaration _ _ d') = toDataDecl d'
171− toDataDecl _ = Nothing
172− go (TypeSynonymDeclaration name args ty : rest) = do
173− rethrow (onErrorMessages (ErrorInTypeSynonym name)) $ do
174− checkDuplicateTypeArguments $ map fst args
175− kind <- kindsOf False moduleName name args [ty]
176− let args' = args `withKinds` kind
177− addTypeSynonym moduleName name args' ty kind
178− ds <- go rest
179− return $ TypeSynonymDeclaration name args ty : ds
180− go (TypeDeclaration _ _ : _) = error "Type declarations should have been removed"
181− go (ValueDeclaration name nameKind [] (Right val) : rest) = do
182− d <- rethrow (onErrorMessages (ErrorInValueDeclaration name)) $ do
183− valueIsNotDefined moduleName name
184− [(_, (val', ty))] <- typesOf mainModuleName moduleName [(name, val)]
185− addValue moduleName name ty nameKind
186− return $ ValueDeclaration name nameKind [] $ Right val'
187− ds <- go rest
188− return $ d : ds
189− go (ValueDeclaration{} : _) = error "Binders were not desugared"
190− go (BindingGroupDeclaration vals : rest) = do
191− d <- rethrow (onErrorMessages (ErrorInBindingGroup (map (\(ident, _, _) -> ident) vals))) $ do
192− forM_ (map (\(ident, _, _) -> ident) vals) $ \name ->
193− valueIsNotDefined moduleName name
194− tys <- typesOf mainModuleName moduleName $ map (\(ident, _, ty) -> (ident, ty)) vals
195− vals' <- forM [ (name, val, nameKind, ty)
196− | (name, nameKind, _) <- vals
197− , (name', (val, ty)) <- tys
198− , name == name'
199− ] $ \(name, val, nameKind, ty) -> do
200− addValue moduleName name ty nameKind
201− return (name, nameKind, val)
202− return $ BindingGroupDeclaration vals'
203− ds <- go rest
204− return $ d : ds
205− go (d@(ExternDataDeclaration name kind) : rest) = do
206− env <- getEnv
207− putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (kind, ExternData) (types env) }
208− ds <- go rest
209− return $ d : ds
210− go (d@(ExternDeclaration importTy name _ ty) : rest) = do
211− rethrow (onErrorMessages (ErrorInForeignImport name)) $ do
212− env <- getEnv
213− kind <- kindOf moduleName ty
214− guardWith (errorMessage (ExpectedType kind)) $ kind == Star
215− case M.lookup (moduleName, name) (names env) of
216− Just _ -> throwError . errorMessage $ RedefinedIdent name
217− Nothing -> putEnv (env { names = M.insert (moduleName, name) (ty, Extern importTy, Defined) (names env) })
218− ds <- go rest
219− return $ d : ds
220− go (d@(FixityDeclaration _ name) : rest) = do
221− ds <- go rest
222− env <- getEnv
223− guardWith (errorMessage (OrphanFixityDeclaration name)) $ M.member (moduleName, Op name) $ names env
224− return $ d : ds
225− go (d@(ImportDeclaration importedModule _ _) : rest) = do
226− tcds <- getTypeClassDictionaries
227− let instances = filter (\tcd -> let Qualified (Just mn) _ = tcdName tcd in importedModule == mn) tcds
228− addTypeClassDictionaries [ tcd { tcdName = Qualified (Just moduleName) ident, tcdType = TCDAlias (canonicalizeDictionary tcd) }
229− | tcd <- instances
230− , tcdExported tcd
231− , let (Qualified _ ident) = tcdName tcd
232− ]
233− ds <- go rest
234− return $ d : ds
235− go (d@(TypeClassDeclaration pn args implies tys) : rest) = do
236− addTypeClass moduleName pn args implies tys
237− ds <- go rest
238− return $ d : ds
239− go (d@(TypeInstanceDeclaration dictName deps className tys _) : rest) = do
240− goInstance d dictName deps className tys rest
241− go (d@(ExternInstanceDeclaration dictName deps className tys) : rest) = do
242− goInstance d dictName deps className tys rest
243− go (PositionedDeclaration pos com d : rest) =
244− rethrowWithPosition pos $ do
245− (d' : rest') <- go (d : rest)
246− return (PositionedDeclaration pos com d' : rest')
247− goInstance :: Declaration -> Ident -> [Constraint] -> Qualified ProperName -> [Type] -> [Declaration] -> Check [Declaration]
248− goInstance d dictName deps className tys rest = do
249− mapM_ (checkTypeClassInstance moduleName) tys
250− forM_ deps $ mapM_ (checkTypeClassInstance moduleName) . snd
251− addTypeClassDictionaries [TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) className tys (Just deps) TCDRegular isInstanceExported]
252− ds <- go rest
253− return $ d : ds
254−
255− where
256−
257− isInstanceExported :: Bool
258− isInstanceExported = any exportsInstance exps
259−
260− exportsInstance :: DeclarationRef -> Bool
261− exportsInstance (TypeInstanceRef name) | name == dictName = True
262− exportsInstance (PositionedDeclarationRef _ _ r) = exportsInstance r
263− exportsInstance _ = False
264−
265− -- |
266− -- This function adds the argument kinds for a type constructor so that they may appear in the externs file,
267− -- extracted from the kind of the type constructor itself.
268− --
269− withKinds :: [(String, Maybe Kind)] -> Kind -> [(String, Maybe Kind)]
270− withKinds [] _ = []
271− withKinds (s@(_, Just _ ):ss) (FunKind _ k) = s : withKinds ss k
272− withKinds ( (s, Nothing):ss) (FunKind k1 k2) = (s, Just k1) : withKinds ss k2
273− withKinds _ _ = error "Invalid arguments to peelKinds"
274−
275−-- |
276−-- Type check an entire module and ensure all types and classes defined within the module that are
277−-- required by exported members are also exported.
278−--
279−typeCheckModule :: Maybe ModuleName -> Module -> Check Module
280−typeCheckModule _ (Module _ _ _ Nothing) = error "exports should have been elaborated"
281−typeCheckModule mainModuleName (Module coms mn decls (Just exps)) = rethrow (onErrorMessages (ErrorInModule mn)) $ do
282− modify (\s -> s { checkCurrentModule = Just mn })
283− decls' <- typeCheckAll mainModuleName mn exps decls
284− forM_ exps $ \e -> do
285− checkTypesAreExported e
286− checkClassMembersAreExported e
287− checkClassesAreExported e
288− return $ Module coms mn decls' (Just exps)
289− where
290−
291− checkMemberExport :: (Type -> [DeclarationRef]) -> DeclarationRef -> Check ()
292− checkMemberExport extract dr@(ValueRef name) = do
293− ty <- lookupVariable mn (Qualified (Just mn) name)
294− case filter (not . exported) (extract ty) of
295− [] -> return ()
296− hidden -> throwError . errorMessage $ TransitiveExportError dr hidden
297− where
298− exported e = any (exports e) exps
299− exports (TypeRef pn1 _) (TypeRef pn2 _) = pn1 == pn2
300− exports (ValueRef id1) (ValueRef id2) = id1 == id2
301− exports (TypeClassRef pn1) (TypeClassRef pn2) = pn1 == pn2
302− exports (TypeInstanceRef id1) (TypeInstanceRef id2) = id1 == id2
303− exports (PositionedDeclarationRef _ _ r1) r2 = exports r1 r2
304− exports r1 (PositionedDeclarationRef _ _ r2) = exports r1 r2
305− exports _ _ = False
306− checkMemberExport _ _ = return ()
307−
308− -- Check that all the type constructors defined in the current module that appear in member types
309− -- have also been exported from the module
310− checkTypesAreExported :: DeclarationRef -> Check ()
311− checkTypesAreExported = checkMemberExport findTcons
312− where
313− findTcons :: Type -> [DeclarationRef]
314− findTcons = everythingOnTypes (++) go
315− where
316− go (TypeConstructor (Qualified (Just mn') name)) | mn' == mn = [TypeRef name (error "Data constructors unused in checkTypesAreExported")]
317− go _ = []
318−
319− -- Check that all the classes defined in the current module that appear in member types have also
320− -- been exported from the module
321− checkClassesAreExported :: DeclarationRef -> Check ()
322− checkClassesAreExported = checkMemberExport findClasses
323− where
324− findClasses :: Type -> [DeclarationRef]
325− findClasses = everythingOnTypes (++) go
326− where
327− go (ConstrainedType cs _) = mapMaybe (fmap TypeClassRef . extractCurrentModuleClass . fst) cs
328− go _ = []
329− extractCurrentModuleClass :: Qualified ProperName -> Maybe ProperName
330− extractCurrentModuleClass (Qualified (Just mn') name) | mn == mn' = Just name
331− extractCurrentModuleClass _ = Nothing
332−
333− checkClassMembersAreExported :: DeclarationRef -> Check ()
334− checkClassMembersAreExported dr@(TypeClassRef name) = do
335− let members = ValueRef `map` head (mapMaybe findClassMembers decls)
336− let missingMembers = members \\ exps
337− unless (null missingMembers) $ throwError . errorMessage $ TransitiveExportError dr members
338− where
339− findClassMembers :: Declaration -> Maybe [Ident]
340− findClassMembers (TypeClassDeclaration name' _ _ ds) | name == name' = Just $ map extractMemberName ds
341− findClassMembers (PositionedDeclaration _ _ d) = findClassMembers d
342− findClassMembers _ = Nothing
343− extractMemberName :: Declaration -> Ident
344− extractMemberName (PositionedDeclaration _ _ d) = extractMemberName d
345− extractMemberName (TypeDeclaration memberName _) = memberName
346− extractMemberName _ = error "Unexpected declaration in typeclass member list"
347− checkClassMembersAreExported _ = return ()
src/Language/PureScript/TypeChecker/Entailment.hsdeleted−212
@@ -1,212 +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−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
17−
18−module Language.PureScript.TypeChecker.Entailment (
19− entails
20−) where
21−
22−import Data.Function (on)
23−import Data.List
24−import Data.Maybe (maybeToList)
25−import Data.Foldable (foldMap)
26−import qualified Data.Map as M
27−
28−import Control.Applicative
29−import Control.Arrow (Arrow(..))
30−import Control.Monad.State
31−import Control.Monad.Error.Class (MonadError(..))
32−
33−import Language.PureScript.AST
34−import Language.PureScript.Errors
35−import Language.PureScript.Environment
36−import Language.PureScript.Names
37−import Language.PureScript.TypeChecker.Monad
38−import Language.PureScript.TypeChecker.Synonyms
39−import Language.PureScript.TypeChecker.Unify
40−import Language.PureScript.TypeClassDictionaries
41−import Language.PureScript.Types
42−import qualified Language.PureScript.Constants as C
43−
44−newtype Work = Work Integer deriving (Show, Eq, Ord, Num)
45−
46−-- |
47−-- Check that the current set of type class dictionaries entail the specified type class goal, and, if so,
48−-- return a type class dictionary reference.
49−--
50−entails :: Environment -> ModuleName -> [TypeClassDictionaryInScope] -> Constraint -> Bool -> Check Expr
51−entails env moduleName context = solve (sortedNubBy canonicalizeDictionary (filter filterModule context))
52− where
53− sortedNubBy :: (Ord k) => (v -> k) -> [v] -> [v]
54− sortedNubBy f vs = M.elems (M.fromList (map (f &&& id) vs))
55−
56− -- Filter out type dictionaries which are in scope in the current module
57− filterModule :: TypeClassDictionaryInScope -> Bool
58− filterModule (TypeClassDictionaryInScope { tcdName = Qualified (Just mn) _ }) | mn == moduleName = True
59− filterModule (TypeClassDictionaryInScope { tcdName = Qualified Nothing _ }) = True
60− filterModule _ = False
61−
62− solve :: [TypeClassDictionaryInScope] -> Constraint -> Bool -> Check Expr
63− solve context' (className, tys) trySuperclasses = do
64− let dicts = flip evalStateT (Work 0) $ go trySuperclasses className tys
65− checkOverlaps dicts
66− where
67− go :: Bool -> Qualified ProperName -> [Type] -> StateT Work [] DictionaryValue
68− go trySuperclasses' className' tys' = do
69− workDone <- get
70− guard $ workDone < 1000
71− modify (1 +)
72− directInstances <|> superclassInstances
73− where
74− directInstances :: StateT Work [] DictionaryValue
75− directInstances = do
76− tcd <- lift context'
77− -- Make sure the type class name matches the one we are trying to satisfy
78− guard $ className' == tcdClassName tcd
79− -- Make sure the type unifies with the type in the type instance definition
80− subst <- lift . maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName env) tys' (tcdInstanceTypes tcd)
81− -- Solve any necessary subgoals
82− args <- solveSubgoals subst (tcdDependencies tcd)
83− return $ mkDictionary (canonicalizeDictionary tcd) args
84−
85− superclassInstances :: StateT Work [] DictionaryValue
86− superclassInstances = do
87− guard trySuperclasses'
88− (subclassName, (args, _, implies)) <- lift $ M.toList (typeClasses env)
89− -- Try each superclass
90− (index, (superclass, suTyArgs)) <- lift $ zip [0..] implies
91− -- Make sure the type class name matches the superclass name
92− guard $ className' == superclass
93− -- Make sure the types unify with the types in the superclass implication
94− subst <- lift . maybeToList . (>>= verifySubstitution) . fmap concat $ zipWithM (typeHeadsAreEqual moduleName env) tys' suTyArgs
95− -- Finally, satisfy the subclass constraint
96− args' <- lift . maybeToList $ mapM ((`lookup` subst) . fst) args
97− suDict <- go True subclassName args'
98− return $ SubclassDictionaryValue suDict superclass index
99−
100− -- Create dictionaries for subgoals which still need to be solved by calling go recursively
101− -- E.g. the goal (Show a, Show b) => Show (Either a b) can be satisfied if the current type
102− -- unifies with Either a b, and we can satisfy the subgoals Show a and Show b recursively.
103− solveSubgoals :: [(String, Type)] -> Maybe [Constraint] -> StateT Work [] (Maybe [DictionaryValue])
104− solveSubgoals _ Nothing = return Nothing
105− solveSubgoals subst (Just subgoals) = do
106− dict <- mapM (uncurry (go True) . second (map (replaceAllTypeVars subst))) subgoals
107− return $ Just dict
108−
109− -- Make a dictionary from subgoal dictionaries by applying the correct function
110− mkDictionary :: Qualified Ident -> Maybe [DictionaryValue] -> DictionaryValue
111− mkDictionary fnName Nothing = LocalDictionaryValue fnName
112− mkDictionary fnName (Just []) = GlobalDictionaryValue fnName
113− mkDictionary fnName (Just dicts) = DependentDictionaryValue fnName dicts
114−
115− -- Turn a DictionaryValue into a Expr
116− dictionaryValueToValue :: DictionaryValue -> Expr
117− dictionaryValueToValue (LocalDictionaryValue fnName) = Var fnName
118− dictionaryValueToValue (GlobalDictionaryValue fnName) = Var fnName
119− dictionaryValueToValue (DependentDictionaryValue fnName dicts) = foldl App (Var fnName) (map dictionaryValueToValue dicts)
120− dictionaryValueToValue (SubclassDictionaryValue dict superclassName index) =
121− App (Accessor (C.__superclass_ ++ show superclassName ++ "_" ++ show index)
122− (dictionaryValueToValue dict))
123− valUndefined
124− -- Ensure that a substitution is valid
125− verifySubstitution :: [(String, Type)] -> Maybe [(String, Type)]
126− verifySubstitution subst = do
127− let grps = groupBy ((==) `on` fst) subst
128− guard (all (pairwise (unifiesWith env) . map snd) grps)
129− return $ map head grps
130− -- |
131− -- Check for overlapping instances
132− --
133− checkOverlaps :: [DictionaryValue] -> Check Expr
134− checkOverlaps dicts =
135− case [ (d1, d2) | d1 <- dicts, d2 <- dicts, d1 `overlapping` d2 ] of
136− ds@(_ : _) -> throwError . errorMessage $ OverlappingInstances className tys $ nub (map fst ds)
137− _ -> case chooseSimplestDictionaries dicts of
138− [] -> throwError . errorMessage $ NoInstanceFound className tys
139− d : _ -> return $ dictionaryValueToValue d
140− -- Choose the simplest DictionaryValues from a list of candidates
141− -- The reason for this function is as follows:
142− -- When considering overlapping instances, we don't want to consider the same dictionary
143− -- to be an overlap of itself when obtained as a superclass of another class.
144− -- Observing that we probably don't want to select a superclass instance when an instance
145− -- is available directly, and that there is no way for a superclass instance to actually
146− -- introduce an overlap that wouldn't have been there already, we simply remove dictionaries
147− -- obtained as superclass instances if there are simpler instances available.
148− chooseSimplestDictionaries :: [DictionaryValue] -> [DictionaryValue]
149− chooseSimplestDictionaries ds = case filter isSimpleDictionaryValue ds of
150− [] -> ds
151− simple -> simple
152− isSimpleDictionaryValue SubclassDictionaryValue{} = False
153− isSimpleDictionaryValue (DependentDictionaryValue _ ds) = all isSimpleDictionaryValue ds
154− isSimpleDictionaryValue _ = True
155− -- |
156− -- Check if two dictionaries are overlapping
157− --
158− -- Dictionaries which are subclass dictionaries cannot overlap, since otherwise the overlap would have
159− -- been caught when constructing superclass dictionaries.
160− --
161− overlapping :: DictionaryValue -> DictionaryValue -> Bool
162− overlapping (LocalDictionaryValue nm1) (LocalDictionaryValue nm2) | nm1 == nm2 = False
163− overlapping (GlobalDictionaryValue nm1) (GlobalDictionaryValue nm2) | nm1 == nm2 = False
164− overlapping (DependentDictionaryValue nm1 ds1) (DependentDictionaryValue nm2 ds2)
165− | nm1 == nm2 = or $ zipWith overlapping ds1 ds2
166− overlapping SubclassDictionaryValue{} _ = False
167− overlapping _ SubclassDictionaryValue{} = False
168− overlapping _ _ = True
169−
170− valUndefined :: Expr
171− valUndefined = Var (Qualified (Just (ModuleName [ProperName C.prim])) (Ident C.undefined))
172−
173−-- |
174−-- Check whether the type heads of two types are equal (for the purposes of type class dictionary lookup),
175−-- and return a substitution from type variables to types which makes the type heads unify.
176−--
177−typeHeadsAreEqual :: ModuleName -> Environment -> Type -> Type -> Maybe [(String, Type)]
178−typeHeadsAreEqual _ _ (Skolem _ s1 _) (Skolem _ s2 _) | s1 == s2 = Just []
179−typeHeadsAreEqual _ _ t (TypeVar v) = Just [(v, t)]
180−typeHeadsAreEqual _ _ (TypeConstructor c1) (TypeConstructor c2) | c1 == c2 = Just []
181−typeHeadsAreEqual m e (TypeApp h1 t1) (TypeApp h2 t2) = (++) <$> typeHeadsAreEqual m e h1 h2
182− <*> typeHeadsAreEqual m e t1 t2
183−typeHeadsAreEqual m e (SaturatedTypeSynonym name args) t2 = case expandTypeSynonym' e name args of
184− Left _ -> Nothing
185− Right t1 -> typeHeadsAreEqual m e t1 t2
186−typeHeadsAreEqual _ _ REmpty REmpty = Just []
187−typeHeadsAreEqual m e r1@(RCons _ _ _) r2@(RCons _ _ _) =
188− let (s1, r1') = rowToList r1
189− (s2, r2') = rowToList r2
190−
191− int = [ (t1, t2) | (name, t1) <- s1, (name', t2) <- s2, name == name' ]
192− sd1 = [ (name, t1) | (name, t1) <- s1, name `notElem` map fst s2 ]
193− sd2 = [ (name, t2) | (name, t2) <- s2, name `notElem` map fst s1 ]
194− in (++) <$> foldMap (\(t1, t2) -> typeHeadsAreEqual m e t1 t2) int
195− <*> go sd1 r1' sd2 r2'
196− where
197− go :: [(String, Type)] -> Type -> [(String, Type)] -> Type -> Maybe [(String, Type)]
198− go [] REmpty [] REmpty = Just []
199− go [] (TUnknown _) _ _ = Just []
200− go [] (TypeVar v1) [] (TypeVar v2) | v1 == v2 = Just []
201− go [] (Skolem _ s1 _) [] (Skolem _ s2 _) | s1 == s2 = Just []
202− go sd r [] (TypeVar v) = Just [(v, rowFromList (sd, r))]
203− go _ _ _ _ = Nothing
204−typeHeadsAreEqual _ _ _ _ = Nothing
205−
206−-- |
207−-- Check all values in a list pairwise match a predicate
208−--
209−pairwise :: (a -> a -> Bool) -> [a] -> Bool
210−pairwise _ [] = True
211−pairwise _ [_] = True
212−pairwise p (x : xs) = all (p x) xs && pairwise p xs
src/Language/PureScript/TypeChecker/Kinds.hsdeleted−218
@@ -1,218 +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, TupleSections #-}
18−
19−module Language.PureScript.TypeChecker.Kinds (
20− kindOf,
21− kindOfWithScopedVars,
22− kindsOf,
23− kindsOfAll
24−) where
25−
26−import Data.Maybe (fromMaybe)
27−
28−import qualified Data.HashMap.Strict as H
29−import qualified Data.Map as M
30−
31−import Control.Arrow (second)
32−import Control.Applicative
33−import Control.Monad
34−import Control.Monad.Error.Class (MonadError(..))
35−import Control.Monad.State
36−import Control.Monad.Unify
37−
38−import Language.PureScript.Environment
39−import Language.PureScript.Errors
40−import Language.PureScript.Kinds
41−import Language.PureScript.Names
42−import Language.PureScript.TypeChecker.Monad
43−import Language.PureScript.Types
44−
45−instance Partial Kind where
46− unknown = KUnknown
47− isUnknown (KUnknown u) = Just u
48− isUnknown _ = Nothing
49− unknowns = everythingOnKinds (++) go
50− where
51− go (KUnknown u) = [u]
52− go _ = []
53− ($?) sub = everywhereOnKinds go
54− where
55− go t@(KUnknown u) = fromMaybe t $ H.lookup u (runSubstitution sub)
56− go other = other
57−
58−instance Unifiable Check Kind where
59− KUnknown u1 =?= KUnknown u2 | u1 == u2 = return ()
60− KUnknown u =?= k = u =:= k
61− k =?= KUnknown u = u =:= k
62− Star =?= Star = return ()
63− Bang =?= Bang = return ()
64− Row k1 =?= Row k2 = k1 =?= k2
65− FunKind k1 k2 =?= FunKind k3 k4 = do
66− k1 =?= k3
67− k2 =?= k4
68− k1 =?= k2 = UnifyT . lift . throwError . errorMessage $ KindsDoNotUnify k1 k2
69−
70−-- |
71−-- Infer the kind of a single type
72−--
73−kindOf :: ModuleName -> Type -> Check Kind
74−kindOf _ ty = fst <$> kindOfWithScopedVars ty
75−
76−-- |
77−-- Infer the kind of a single type, returning the kinds of any scoped type variables
78−--
79−kindOfWithScopedVars :: Type -> Check (Kind, [(String, Kind)])
80−kindOfWithScopedVars ty =
81− rethrow (onErrorMessages (ErrorCheckingKind ty)) $
82− fmap tidyUp . liftUnify $ infer ty
83− where
84− tidyUp ((k, args), sub) = ( starIfUnknown (sub $? k)
85− , map (second (starIfUnknown . (sub $?))) args
86− )
87−
88−-- |
89−-- Infer the kind of a type constructor with a collection of arguments and a collection of associated data constructors
90−--
91−kindsOf :: Bool -> ModuleName -> ProperName -> [(String, Maybe Kind)] -> [Type] -> Check Kind
92−kindsOf isData moduleName name args ts = fmap tidyUp . liftUnify $ do
93− tyCon <- fresh
94− kargs <- replicateM (length args) fresh
95− rest <- zipWithM freshKindVar args kargs
96− let dict = (name, tyCon) : rest
97− bindLocalTypeVariables moduleName dict $
98− solveTypes isData ts kargs tyCon
99− where
100− tidyUp (k, sub) = starIfUnknown $ sub $? k
101−
102−freshKindVar :: (String, Maybe Kind) -> Kind -> UnifyT Kind Check (ProperName, Kind)
103−freshKindVar (arg, Nothing) kind = return (ProperName arg, kind)
104−freshKindVar (arg, Just kind') kind = do
105− kind =?= kind'
106− return (ProperName arg, kind')
107−
108−-- |
109−-- Simultaneously infer the kinds of several mutually recursive type constructors
110−--
111−kindsOfAll :: ModuleName -> [(ProperName, [(String, Maybe Kind)], Type)] -> [(ProperName, [(String, Maybe Kind)], [Type])] -> Check ([Kind], [Kind])
112−kindsOfAll moduleName syns tys = fmap tidyUp . liftUnify $ do
113− synVars <- replicateM (length syns) fresh
114− let dict = zipWith (\(name, _, _) var -> (name, var)) syns synVars
115− bindLocalTypeVariables moduleName dict $ do
116− tyCons <- replicateM (length tys) fresh
117− let dict' = zipWith (\(name, _, _) tyCon -> (name, tyCon)) tys tyCons
118− bindLocalTypeVariables moduleName dict' $ do
119− data_ks <- zipWithM (\tyCon (_, args, ts) -> do
120− kargs <- replicateM (length args) fresh
121− argDict <- zipWithM freshKindVar args kargs
122− bindLocalTypeVariables moduleName argDict $
123− solveTypes True ts kargs tyCon) tyCons tys
124− syn_ks <- zipWithM (\synVar (_, args, ty) -> do
125− kargs <- replicateM (length args) fresh
126− argDict <- zipWithM freshKindVar args kargs
127− bindLocalTypeVariables moduleName argDict $
128− solveTypes False [ty] kargs synVar) synVars syns
129− return (syn_ks, data_ks)
130− where
131− tidyUp ((ks1, ks2), sub) = (map (starIfUnknown . (sub $?)) ks1, map (starIfUnknown . (sub $?)) ks2)
132−
133−-- |
134−-- Solve the set of kind constraints associated with the data constructors for a type constructor
135−--
136−solveTypes :: Bool -> [Type] -> [Kind] -> Kind -> UnifyT Kind Check Kind
137−solveTypes isData ts kargs tyCon = do
138− ks <- mapM (fmap fst . infer) ts
139− when isData $ do
140− tyCon =?= foldr FunKind Star kargs
141− forM_ ks $ \k -> k =?= Star
142− unless isData $
143− tyCon =?= foldr FunKind (head ks) kargs
144− return tyCon
145−
146−-- |
147−-- Default all unknown kinds to the Star kind of types
148−--
149−starIfUnknown :: Kind -> Kind
150−starIfUnknown (KUnknown _) = Star
151−starIfUnknown (Row k) = Row (starIfUnknown k)
152−starIfUnknown (FunKind k1 k2) = FunKind (starIfUnknown k1) (starIfUnknown k2)
153−starIfUnknown k = k
154−
155−-- |
156−-- Infer a kind for a type
157−--
158−infer :: Type -> UnifyT Kind Check (Kind, [(String, Kind)])
159−infer ty = rethrow (onErrorMessages (ErrorCheckingKind ty)) $ infer' ty
160−
161−infer' :: Type -> UnifyT Kind Check (Kind, [(String, Kind)])
162−infer' (ForAll ident ty _) = do
163− k1 <- fresh
164− Just moduleName <- checkCurrentModule <$> get
165− (k2, args) <- bindLocalTypeVariables moduleName [(ProperName ident, k1)] $ infer ty
166− k2 =?= Star
167− return (Star, (ident, k1) : args)
168−infer' (KindedType ty k) = do
169− (k', args) <- infer ty
170− k =?= k'
171− return (k', args)
172−infer' other = (, []) <$> go other
173− where
174− go :: Type -> UnifyT Kind Check Kind
175− go (ForAll ident ty _) = do
176− k1 <- fresh
177− Just moduleName <- checkCurrentModule <$> get
178− k2 <- bindLocalTypeVariables moduleName [(ProperName ident, k1)] $ go ty
179− k2 =?= Star
180− return Star
181− go (KindedType ty k) = do
182− k' <- go ty
183− k =?= k'
184− return k'
185− go TypeWildcard = fresh
186− go (TypeVar v) = do
187− Just moduleName <- checkCurrentModule <$> get
188− UnifyT . lift $ lookupTypeVariable moduleName (Qualified Nothing (ProperName v))
189− go (Skolem v _ _) = do
190− Just moduleName <- checkCurrentModule <$> get
191− UnifyT . lift $ lookupTypeVariable moduleName (Qualified Nothing (ProperName v))
192− go (TypeConstructor v) = do
193− env <- liftCheck getEnv
194− case M.lookup v (types env) of
195− Nothing -> UnifyT . lift . throwError . errorMessage $ UnknownTypeConstructor v
196− Just (kind, _) -> return kind
197− go (TypeApp t1 t2) = do
198− k0 <- fresh
199− k1 <- go t1
200− k2 <- go t2
201− k1 =?= FunKind k2 k0
202− return k0
203− go REmpty = do
204− k <- fresh
205− return $ Row k
206− go (RCons _ ty row) = do
207− k1 <- go ty
208− k2 <- go row
209− k2 =?= Row k1
210− return $ Row k1
211− go (ConstrainedType deps ty) = do
212− forM_ deps $ \(className, tys) -> do
213− _ <- go $ foldl TypeApp (TypeConstructor className) tys
214− return ()
215− k <- go ty
216− k =?= Star
217− return Star
218− go _ = error "Invalid argument to infer"
src/Language/PureScript/TypeChecker/Monad.hsdeleted−244
@@ -1,244 +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, GADTs #-}
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.Class (MonadError(..))
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.TypeClassDictionaries
34−import Language.PureScript.Types
35−
36−-- |
37−-- Temporarily bind a collection of names to values
38−--
39−bindNames :: (MonadState CheckState m) => M.Map (ModuleName, Ident) (Type, NameKind, NameVisibility) -> m a -> m a
40−bindNames newNames action = do
41− orig <- get
42− modify $ \st -> st { checkEnv = (checkEnv st) { names = newNames `M.union` (names . checkEnv $ st) } }
43− a <- action
44− modify $ \st -> st { checkEnv = (checkEnv st) { names = names . checkEnv $ orig } }
45− return a
46−
47−-- |
48−-- Temporarily bind a collection of names to types
49−--
50−bindTypes :: (MonadState CheckState m) => M.Map (Qualified ProperName) (Kind, TypeKind) -> m a -> m a
51−bindTypes newNames action = do
52− orig <- get
53− modify $ \st -> st { checkEnv = (checkEnv st) { types = newNames `M.union` (types . checkEnv $ st) } }
54− a <- action
55− modify $ \st -> st { checkEnv = (checkEnv st) { types = types . checkEnv $ orig } }
56− return a
57−
58−-- |
59−-- Temporarily bind a collection of names to types
60−--
61−withScopedTypeVars :: (Functor m, MonadState CheckState m) => ModuleName -> [(String, Kind)] -> m a -> m a
62−withScopedTypeVars mn ks = bindTypes (M.fromList (map (\(name, k) -> (Qualified (Just mn) (ProperName name), (k, ScopedTypeVar))) ks))
63−
64−-- |
65−-- Temporarily make a collection of type class dictionaries available
66−--
67−withTypeClassDictionaries :: (MonadState CheckState m) => [TypeClassDictionaryInScope] -> m a -> m a
68−withTypeClassDictionaries entries action = do
69− orig <- get
70− let mentries = M.fromList [ ((canonicalizeDictionary entry, mn), entry) | entry@TypeClassDictionaryInScope{ tcdName = Qualified mn _ } <- entries ]
71− modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = (typeClassDictionaries . checkEnv $ st) `M.union` mentries } }
72− a <- action
73− modify $ \st -> st { checkEnv = (checkEnv st) { typeClassDictionaries = typeClassDictionaries . checkEnv $ orig } }
74− return a
75−
76−-- |
77−-- Get the currently available list of type class dictionaries
78−--
79−getTypeClassDictionaries :: (Functor m, MonadState CheckState m) => m [TypeClassDictionaryInScope]
80−getTypeClassDictionaries = M.elems . typeClassDictionaries . checkEnv <$> get
81−
82−-- |
83−-- Temporarily bind a collection of names to local variables
84−--
85−bindLocalVariables :: (Functor m, MonadState CheckState m) => ModuleName -> [(Ident, Type, NameVisibility)] -> m a -> m a
86−bindLocalVariables moduleName bindings =
87− bindNames (M.fromList $ flip map bindings $ \(name, ty, visibility) -> ((moduleName, name), (ty, LocalVariable, visibility)))
88−
89−-- |
90−-- Temporarily bind a collection of names to local type variables
91−--
92−bindLocalTypeVariables :: (Functor m, MonadState CheckState m) => ModuleName -> [(ProperName, Kind)] -> m a -> m a
93−bindLocalTypeVariables moduleName bindings =
94− bindTypes (M.fromList $ flip map bindings $ \(pn, kind) -> (Qualified (Just moduleName) pn, (kind, LocalTypeVariable)))
95−
96−-- |
97−-- Update the visibility of all names to Defined
98−--
99−makeBindingGroupVisible :: (Functor m, MonadState CheckState m) => m ()
100−makeBindingGroupVisible = modifyEnv $ \e -> e { names = M.map (\(ty, nk, _) -> (ty, nk, Defined)) (names e) }
101−
102−-- | Update the visibility of all names to Defined in the scope of the provided action
103−withBindingGroupVisible :: (Functor m, MonadState CheckState m) => m a -> m a
104−withBindingGroupVisible action = preservingNames $ makeBindingGroupVisible >> action
105−
106−-- | Perform an action while preserving the names from the @Environment@.
107−preservingNames :: (Functor m, MonadState CheckState m) => m a -> m a
108−preservingNames action = do
109− orig <- gets (names . checkEnv)
110− a <- action
111− modifyEnv $ \e -> e { names = orig }
112− return a
113−
114−-- |
115−-- Lookup the type of a value by name in the @Environment@
116−--
117−lookupVariable :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m Type
118−lookupVariable currentModule (Qualified moduleName var) = do
119− env <- getEnv
120− case M.lookup (fromMaybe currentModule moduleName, var) (names env) of
121− Nothing -> throwError . errorMessage $ NameIsUndefined var
122− Just (ty, _, _) -> return ty
123−
124−-- |
125−-- Lookup the visibility of a value by name in the @Environment@
126−--
127−getVisibility :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m NameVisibility
128−getVisibility currentModule (Qualified moduleName var) = do
129− env <- getEnv
130− case M.lookup (fromMaybe currentModule moduleName, var) (names env) of
131− Nothing -> throwError . errorMessage $ NameIsUndefined var
132− Just (_, _, vis) -> return vis
133−
134−-- |
135−-- Assert that a name is visible
136−--
137−checkVisibility :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified Ident -> m ()
138−checkVisibility currentModule name@(Qualified _ var) = do
139− vis <- getVisibility currentModule name
140− case vis of
141− Undefined -> throwError . errorMessage $ NameNotInScope var
142− _ -> return ()
143−
144−-- |
145−-- Lookup the kind of a type by name in the @Environment@
146−--
147−lookupTypeVariable :: (e ~ MultipleErrors, Functor m, MonadState CheckState m, MonadError e m) => ModuleName -> Qualified ProperName -> m Kind
148−lookupTypeVariable currentModule (Qualified moduleName name) = do
149− env <- getEnv
150− case M.lookup (Qualified (Just $ fromMaybe currentModule moduleName) name) (types env) of
151− Nothing -> throwError . errorMessage $ UndefinedTypeVariable name
152− Just (k, _) -> return k
153−
154−-- |
155−-- State required for type checking:
156−--
157−data CheckState = CheckState {
158− -- |
159− -- The current @Environment@
160− --
161− checkEnv :: Environment
162− -- |
163− -- The next fresh unification variable name
164− --
165− , checkNextVar :: Int
166− -- |
167− -- The next type class dictionary name
168− --
169− , checkNextDictName :: Int
170− -- |
171− -- The current module
172− --
173− , checkCurrentModule :: Maybe ModuleName
174− }
175−
176−-- |
177−-- The type checking monad, which provides the state of the type checker, and error reporting capabilities
178−--
179−newtype Check a = Check { unCheck :: StateT CheckState (Either MultipleErrors) a }
180− deriving (Functor, Monad, Applicative, MonadState CheckState, MonadError MultipleErrors)
181−
182−-- |
183−-- Get the current @Environment@
184−--
185−getEnv :: (Functor m, MonadState CheckState m) => m Environment
186−getEnv = checkEnv <$> get
187−
188−-- |
189−-- Update the @Environment@
190−--
191−putEnv :: (MonadState CheckState m) => Environment -> m ()
192−putEnv env = modify (\s -> s { checkEnv = env })
193−
194−-- |
195−-- Modify the @Environment@
196−--
197−modifyEnv :: (MonadState CheckState m) => (Environment -> Environment) -> m ()
198−modifyEnv f = modify (\s -> s { checkEnv = f (checkEnv s) })
199−
200−-- |
201−-- Run a computation in the Check monad, starting with an empty @Environment@
202−--
203−runCheck :: (MonadError MultipleErrors m) => Check a -> m (a, Environment)
204−runCheck = runCheck' initEnvironment
205−
206−-- |
207−-- Run a computation in the Check monad, failing with an error, or succeeding with a return value and the final @Environment@.
208−--
209−runCheck' :: (MonadError MultipleErrors m) => Environment -> Check a -> m (a, Environment)
210−runCheck' env c = interpretMultipleErrors $ do
211− (a, s) <- flip runStateT (CheckState env 0 0 Nothing) $ unCheck c
212− return (a, checkEnv s)
213−
214−-- |
215−-- Make an assertion, failing with an error message
216−--
217−guardWith :: (MonadError e m) => e -> Bool -> m ()
218−guardWith _ True = return ()
219−guardWith e False = throwError e
220−
221−-- |
222−-- Generate new type class dictionary name
223−--
224−freshDictionaryName :: Check Int
225−freshDictionaryName = do
226− n <- checkNextDictName <$> get
227− modify $ \s -> s { checkNextDictName = succ (checkNextDictName s) }
228− return n
229−
230−-- |
231−-- Lift a computation in the @Check@ monad into the substitution monad.
232−--
233−liftCheck :: Check a -> UnifyT t Check a
234−liftCheck = UnifyT . lift
235−
236−-- |
237−-- Run a computation in the substitution monad, generating a return value and the final substitution.
238−--
239−liftUnify :: (Partial t) => UnifyT t Check a -> Check (a, Substitution t)
240−liftUnify unify = do
241− st <- get
242− (a, ust) <- runUnify (defaultUnifyState { unifyNextVar = checkNextVar st }) unify
243− modify $ \st' -> st' { checkNextVar = unifyNextVar ust }
244− return (a, unifyCurrentSubstitution ust)
src/Language/PureScript/TypeChecker/Rows.hsdeleted−67

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

src/Language/PureScript/TypeClassDictionaries.hsdeleted−96

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

This diff is too big to show here.

travis-after-script.shdeleted−21

This diff is too big to show here.

travis-script.shdeleted−17

This diff is too big to show here.