golang..125b023 · rowtype-yoga/purescript-native

git.iko.soy/rowtype-yoga/purescript-native

324 files changed+20586−2728

unifiedsplit

.gitignore−12

@@ -9,15 +9,3 @@ 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.ymlnew file+19

@@ -0,0 +1,19 @@

1+language: haskell

2+ghc: 7.8

3+script:

4+ - ./travis-script.sh

5+after_script:

6+ - ./travis-after-script.sh

7+notifications:

8+ email: true

9+before_deploy: "./bundle/build.sh linux64"

10+deploy:

11+ provider: releases

12+ api_key: $RELEASE_KEY

13+ file:

14+ - bundle/linux64.tar.gz

15+ - bundle/linux64.sha

16+ skip_cleanup: true

17+ on:

18+ all_branches: true

19+ tags: true

CONTRIBUTING.mdnew file+18

@@ -0,0 +1,18 @@

1+An introductory overview of the compiler is available [here](https://www.youtube.com/watch?v=Y3P1dxqwFiE).

3+Pull requests are encouraged.

5+Please follow the following guidelines:

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.mddeleted−3

@@ -1,3 +0,0 @@

1−# Changelog for pscpp

2−

3−## Unreleased changes

LICENSE+622−30

@@ -1,30 +1,622 @@

2−

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.

1+The MIT License (MIT)

5+Permission is hereby granted, free of charge, to any person obtaining a copy of

6+this software and associated documentation files (the "Software"), to deal in

7+the Software without restriction, including without limitation the rights to

8+use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of

9+the Software, and to permit persons to whom the Software is furnished to do so,

10+subject to the following conditions:

11+

12+The above copyright notice and this permission notice shall be included in all

13+copies or substantial portions of the Software.

14+

15+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR

16+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS

17+FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR

18+COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER

19+IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN

20+CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

21+

22+PureScript uses the following Haskell library packages. Their license files follow.

23+

24+ base

25+ containers

26+ directory

27+ file-embed

28+ filepath

29+ haskeline

30+ monad-unify

31+ mtl

32+ optparse-applicative

33+ parsec

34+ pattern-arrows

35+ process

36+ time

37+ transformers

38+ unordered-containers

39+ utf8-string

40+

41+base LICENSE file:

42+

43+ This library (libraries/base) is derived from code from several

44+ sources:

45+

46+ * Code from the GHC project which is largely (c) The University of

47+ Glasgow, and distributable under a BSD-style license (see below),

48+

49+ * Code from the Haskell 98 Report which is (c) Simon Peyton Jones

50+ and freely redistributable (but see the full license for

51+ restrictions).

52+

53+ * Code from the Haskell Foreign Function Interface specification,

54+ which is (c) Manuel M. T. Chakravarty and freely redistributable

55+ (but see the full license for restrictions).

56+

57+ The full text of these licenses is reproduced below. All of the

58+ licenses are BSD-style or compatible.

59+

60+ -----------------------------------------------------------------------------

61+

62+ The Glasgow Haskell Compiler License

63+

66+

67+ Redistribution and use in source and binary forms, with or without

68+ modification, are permitted provided that the following conditions are met:

69+

70+ - Redistributions of source code must retain the above copyright notice,

71+ this list of conditions and the following disclaimer.

72+

73+ - Redistributions in binary form must reproduce the above copyright notice,

74+ this list of conditions and the following disclaimer in the documentation

75+ and/or other materials provided with the distribution.

76+

77+ - Neither name of the University nor the names of its contributors may be

78+ used to endorse or promote products derived from this software without

79+ specific prior written permission.

80+

81+ THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF

82+ GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,

83+ INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND

84+ FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE

85+ UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE

86+ FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL

87+ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR

88+ SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER

89+ CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT

90+ LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY

91+ OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH

92+ DAMAGE.

93+

94+ -----------------------------------------------------------------------------

95+

96+ Code derived from the document "Report on the Programming Language

97+ Haskell 98", is distributed under the following license:

98+

100+

101+ The authors intend this Report to belong to the entire Haskell

102+ community, and so we grant permission to copy and distribute it for

103+ any purpose, provided that it is reproduced in its entirety,

104+ including this Notice. Modified versions of this Report may also be

105+ copied and distributed for any purpose, provided that the modified

106+ version is clearly presented as such, and that it does not claim to

107+ be a definition of the Haskell 98 Language.

108+

109+ -----------------------------------------------------------------------------

110+

111+ Code derived from the document "The Haskell 98 Foreign Function

112+ Interface, An Addendum to the Haskell 98 Report" is distributed under

113+ the following license:

114+

116+

117+ The authors intend this Report to belong to the entire Haskell

118+ community, and so we grant permission to copy and distribute it for

119+ any purpose, provided that it is reproduced in its entirety,

120+ including this Notice. Modified versions of this Report may also be

121+ copied and distributed for any purpose, provided that the modified

122+ version is clearly presented as such, and that it does not claim to

123+ be a definition of the Haskell 98 Foreign Function Interface.

124+

125+ -----------------------------------------------------------------------------

126+

127+containers LICENSE file:

128+

129+ The Glasgow Haskell Compiler License

130+

133+

134+ Redistribution and use in source and binary forms, with or without

135+ modification, are permitted provided that the following conditions are met:

136+

137+ - Redistributions of source code must retain the above copyright notice,

138+ this list of conditions and the following disclaimer.

139+

140+ - Redistributions in binary form must reproduce the above copyright notice,

141+ this list of conditions and the following disclaimer in the documentation

142+ and/or other materials provided with the distribution.

143+

144+ - Neither name of the University nor the names of its contributors may be

145+ used to endorse or promote products derived from this software without

146+ specific prior written permission.

147+

148+ THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF

149+ GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,

150+ INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND

151+ FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE

152+ UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE

153+ FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL

154+ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR

155+ SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER

156+ CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT

157+ LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY

158+ OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH

159+ DAMAGE.

160+

161+directory LICENSE file:

162+

163+ This library (libraries/base) is derived from code from two

164+ sources:

165+

166+ * Code from the GHC project which is largely (c) The University of

167+ Glasgow, and distributable under a BSD-style license (see below),

168+

169+ * Code from the Haskell 98 Report which is (c) Simon Peyton Jones

170+ and freely redistributable (but see the full license for

171+ restrictions).

172+

173+ The full text of these licenses is reproduced below. Both of the

174+ licenses are BSD-style or compatible.

175+

176+ -----------------------------------------------------------------------------

177+

178+ The Glasgow Haskell Compiler License

179+

182+

183+ Redistribution and use in source and binary forms, with or without

184+ modification, are permitted provided that the following conditions are met:

185+

186+ - Redistributions of source code must retain the above copyright notice,

187+ this list of conditions and the following disclaimer.

188+

189+ - Redistributions in binary form must reproduce the above copyright notice,

190+ this list of conditions and the following disclaimer in the documentation

191+ and/or other materials provided with the distribution.

192+

193+ - Neither name of the University nor the names of its contributors may be

194+ used to endorse or promote products derived from this software without

195+ specific prior written permission.

196+

197+ THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF

198+ GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,

199+ INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND

200+ FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE

201+ UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE

202+ FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL

203+ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR

204+ SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER

205+ CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT

206+ LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY

207+ OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH

208+ DAMAGE.

209+

210+ -----------------------------------------------------------------------------

211+

212+ Code derived from the document "Report on the Programming Language

213+ Haskell 98", is distributed under the following license:

214+

216+

217+ The authors intend this Report to belong to the entire Haskell

218+ community, and so we grant permission to copy and distribute it for

219+ any purpose, provided that it is reproduced in its entirety,

220+ including this Notice. Modified versions of this Report may also be

221+ copied and distributed for any purpose, provided that the modified

222+ version is clearly presented as such, and that it does not claim to

223+ be a definition of the Haskell 98 Language.

224+

225+ -----------------------------------------------------------------------------

226+

227+file-embed LICENSE file:

228+

229+ The following license covers this documentation, and the source code, except

230+ where otherwise indicated.

231+

233+

234+ Redistribution and use in source and binary forms, with or without

235+ modification, are permitted provided that the following conditions are met:

236+

237+ * Redistributions of source code must retain the above copyright notice, this

238+ list of conditions and the following disclaimer.

239+

240+ * Redistributions in binary form must reproduce the above copyright notice,

241+ this list of conditions and the following disclaimer in the documentation

242+ and/or other materials provided with the distribution.

243+

244+ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR

245+ IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF

246+ MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO

247+ EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,

248+ INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT

249+ NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,

250+ OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF

251+ LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE

252+ OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF

253+ ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

254+

255+filepath LICENSE file:

256+

257+ Copyright Neil Mitchell 2005-2007.

259+

260+ Redistribution and use in source and binary forms, with or without

261+ modification, are permitted provided that the following conditions are

262+ met:

263+

264+ * Redistributions of source code must retain the above copyright

265+ notice, this list of conditions and the following disclaimer.

266+

267+ * Redistributions in binary form must reproduce the above

268+ copyright notice, this list of conditions and the following

269+ disclaimer in the documentation and/or other materials provided

270+ with the distribution.

271+

272+ * Neither the name of Neil Mitchell nor the names of other

273+ contributors may be used to endorse or promote products derived

274+ from this software without specific prior written permission.

275+

276+ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS

277+ "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT

278+ LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR

279+ A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT

280+ OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,

281+ SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT

282+ LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,

283+ DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY

284+ THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT

285+ (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE

286+ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

287+

288+haskeline LICENSE file:

289+

292+

293+ Redistribution and use in source and binary forms, with or without

294+ modification, are permitted provided that the following conditions are met:

295+

296+ - Redistribution of source code must retain the above copyright notice,

297+ this list of conditions and the following disclaimer.

298+

299+ - Redistribution in binary form must reproduce the above copyright notice,

300+ this list of conditions and the following disclaimer in the documentation

301+ and/or other materials provided with the distribution.

302+

303+ THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS "AS IS" AND ANY

304+ EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED

305+ WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE

306+ DISCLAIMED. IN NO EVENT SHALL THE AUTHOR OR THE CONTRIBUTORS BE LIABLE

307+ FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL

308+ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR

309+ SERVICES; LOSS OF USE, DATA OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER

310+ CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,

311+ OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE

312+ USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

313+

314+monad-unify LICENSE file:

315+

316+ The MIT License (MIT)

317+

319+

320+ Permission is hereby granted, free of charge, to any person obtaining a copy of

321+ this software and associated documentation files (the "Software"), to deal in

322+ the Software without restriction, including without limitation the rights to

323+ use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of

324+ the Software, and to permit persons to whom the Software is furnished to do so,

325+ subject to the following conditions:

326+

327+ The above copyright notice and this permission notice shall be included in all

328+ copies or substantial portions of the Software.

329+

330+ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR

331+ IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS

332+ FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR

333+ COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER

334+ IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN

335+ CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

336+

337+mtl LICENSE file:

338+

339+ The Glasgow Haskell Compiler License

340+

343+

344+ Redistribution and use in source and binary forms, with or without

345+ modification, are permitted provided that the following conditions are met:

346+

347+ - Redistributions of source code must retain the above copyright notice,

348+ this list of conditions and the following disclaimer.

349+

350+ - Redistributions in binary form must reproduce the above copyright notice,

351+ this list of conditions and the following disclaimer in the documentation

352+ and/or other materials provided with the distribution.

353+

354+ - Neither name of the University nor the names of its contributors may be

355+ used to endorse or promote products derived from this software without

356+ specific prior written permission.

357+

358+ THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF

359+ GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,

360+ INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND

361+ FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE

362+ UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE

363+ FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL

364+ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR

365+ SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER

366+ CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT

367+ LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY

368+ OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH

369+ DAMAGE.

370+

371+optparse-applicative LICENSE file:

372+

374+

376+

377+ Redistribution and use in source and binary forms, with or without

378+ modification, are permitted provided that the following conditions are met:

379+

380+ * Redistributions of source code must retain the above copyright

381+ notice, this list of conditions and the following disclaimer.

382+

383+ * Redistributions in binary form must reproduce the above

384+ copyright notice, this list of conditions and the following

385+ disclaimer in the documentation and/or other materials provided

386+ with the distribution.

387+

388+ * Neither the name of Paolo Capriotti nor the names of other

389+ contributors may be used to endorse or promote products derived

390+ from this software without specific prior written permission.

391+

392+ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS

393+ "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT

394+ LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR

395+ A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT

396+ OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,

397+ SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT

398+ LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,

399+ DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY

400+ THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT

401+ (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE

402+ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

403+

404+parsec LICENSE file:

405+

407+

408+ Redistribution and use in source and binary forms, with or without

409+ modification, are permitted provided that the following conditions are met:

410+

411+ * Redistributions of source code must retain the above copyright notice,

412+ this list of conditions and the following disclaimer.

413+ * Redistributions in binary form must reproduce the above copyright

414+ notice, this list of conditions and the following disclaimer in the

415+ documentation and/or other materials provided with the distribution.

416+

417+ This software is provided by the copyright holders "as is" and any express or

418+ implied warranties, including, but not limited to, the implied warranties of

419+ merchantability and fitness for a particular purpose are disclaimed. In no

420+ event shall the copyright holders be liable for any direct, indirect,

421+ incidental, special, exemplary, or consequential damages (including, but not

422+ limited to, procurement of substitute goods or services; loss of use, data,

423+ or profits; or business interruption) however caused and on any theory of

424+ liability, whether in contract, strict liability, or tort (including

425+ negligence or otherwise) arising in any way out of the use of this software,

426+ even if advised of the possibility of such damage.

427+

428+pattern-arrows LICENSE file:

429+

430+ The MIT License (MIT)

431+

433+

434+ Permission is hereby granted, free of charge, to any person obtaining a copy of

435+ this software and associated documentation files (the "Software"), to deal in

436+ the Software without restriction, including without limitation the rights to

437+ use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of

438+ the Software, and to permit persons to whom the Software is furnished to do so,

439+ subject to the following conditions:

440+

441+ The above copyright notice and this permission notice shall be included in all

442+ copies or substantial portions of the Software.

443+

444+ THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR

445+ IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS

446+ FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR

447+ COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER

448+ IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN

449+ CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

450+

451+process LICENSE file:

452+

453+ This library (libraries/process) is derived from code from two

454+ sources:

455+

456+ * Code from the GHC project which is largely (c) The University of

457+ Glasgow, and distributable under a BSD-style license (see below),

458+

459+ * Code from the Haskell 98 Report which is (c) Simon Peyton Jones

460+ and freely redistributable (but see the full license for

461+ restrictions).

462+

463+ The full text of these licenses is reproduced below. Both of the

464+ licenses are BSD-style or compatible.

465+

466+ -----------------------------------------------------------------------------

467+

468+ The Glasgow Haskell Compiler License

469+

472+

473+ Redistribution and use in source and binary forms, with or without

474+ modification, are permitted provided that the following conditions are met:

475+

476+ - Redistributions of source code must retain the above copyright notice,

477+ this list of conditions and the following disclaimer.

478+

479+ - Redistributions in binary form must reproduce the above copyright notice,

480+ this list of conditions and the following disclaimer in the documentation

481+ and/or other materials provided with the distribution.

482+

483+ - Neither name of the University nor the names of its contributors may be

484+ used to endorse or promote products derived from this software without

485+ specific prior written permission.

486+

487+ THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF

488+ GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,

489+ INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND

490+ FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE

491+ UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE

492+ FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL

493+ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR

494+ SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER

495+ CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT

496+ LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY

497+ OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH

498+ DAMAGE.

499+

500+ -----------------------------------------------------------------------------

501+

502+ Code derived from the document "Report on the Programming Language

503+ Haskell 98", is distributed under the following license:

504+

506+

507+ The authors intend this Report to belong to the entire Haskell

508+ community, and so we grant permission to copy and distribute it for

509+ any purpose, provided that it is reproduced in its entirety,

510+ including this Notice. Modified versions of this Report may also be

511+ copied and distributed for any purpose, provided that the modified

512+ version is clearly presented as such, and that it does not claim to

513+ be a definition of the Haskell 98 Language.

514+

515+ -----------------------------------------------------------------------------

516+

517+time LICENSE file:

518+

521+

522+ Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:

523+

524+ - Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.

525+

526+ - Neither name of the copyright holders nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.

527+

528+ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

529+

530+transformers LICENSE file:

531+

532+ The Glasgow Haskell Compiler License

533+

536+

537+ Redistribution and use in source and binary forms, with or without

538+ modification, are permitted provided that the following conditions are met:

539+

540+ - Redistributions of source code must retain the above copyright notice,

541+ this list of conditions and the following disclaimer.

542+

543+ - Redistributions in binary form must reproduce the above copyright notice,

544+ this list of conditions and the following disclaimer in the documentation

545+ and/or other materials provided with the distribution.

546+

547+ - Neither name of the University nor the names of its contributors may be

548+ used to endorse or promote products derived from this software without

549+ specific prior written permission.

550+

551+ THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF

552+ GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,

553+ INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND

554+ FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE

555+ UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE

556+ FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL

557+ DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR

558+ SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER

559+ CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT

560+ LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY

561+ OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH

562+ DAMAGE.

563+

564+unordered-containers LICENSE file:

565+

567+

569+

570+ Redistribution and use in source and binary forms, with or without

571+ modification, are permitted provided that the following conditions are met:

572+

573+ * Redistributions of source code must retain the above copyright

574+ notice, this list of conditions and the following disclaimer.

575+

576+ * Redistributions in binary form must reproduce the above

577+ copyright notice, this list of conditions and the following

578+ disclaimer in the documentation and/or other materials provided

579+ with the distribution.

580+

581+ * Neither the name of Johan Tibell nor the names of other

582+ contributors may be used to endorse or promote products derived

583+ from this software without specific prior written permission.

584+

585+ THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS

586+ "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT

587+ LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR

588+ A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT

589+ OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,

590+ SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT

591+ LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,

592+ DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY

593+ THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT

594+ (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE

595+ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

596+

597+utf8-string LICENSE file:

598+

601+ *

602+ * Redistribution and use in source and binary forms, with or without

603+ * modification, are permitted provided that the following conditions are met:

604+ * * Redistributions of source code must retain the above copyright

605+ * notice, this list of conditions and the following disclaimer.

606+ * * Redistributions in binary form must reproduce the above copyright

607+ * notice, this list of conditions and the following disclaimer in the

608+ * documentation and/or other materials provided with the distribution.

609+ * * Neither the name of Galois Inc. nor the

610+ * names of its contributors may be used to endorse or promote products

611+ * derived from this software without specific prior written permission.

612+ *

613+ * THIS SOFTWARE IS PROVIDED BY Galois Inc. ``AS IS'' AND ANY

614+ * EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED

615+ * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE

616+ * DISCLAIMED. IN NO EVENT SHALL Galois Inc. BE LIABLE FOR ANY

617+ * DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES

618+ * (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;

619+ * LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND

620+ * ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT

621+ * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS

622+ * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

README-go.mddeleted−48

@@ -1,48 +0,0 @@

1−

2−### psgo

3−

4−#### Performance

5−

6−* No runtime system beyond some support types and functions

7−* Uses PureScript's normal tail call optimization techniques for generated Go code

8−

9−#### Differences from PureScript:

10−

11−* Foreign imports/exports are Go instead of JavaScript – see [standard library foreign implementations](https://github.com/andyarvanitis/purescript-native-go-ffi)

12−* No Go-specific REPL

13−

14−#### Other notes:

15−

16−* The provided `Any` type is just an alias for `interface{}`

17−* PureScript types are represented in Go with:

18−

19− | PureScript | Go |

20− |------------|----|

21− |`Array` | `[]Any`|

22− |`String` | `string`|

23− |`Number` | `float64`|

24− |`Int` | `int`|

25− |`Char` | `string` (single UTF-8 entity)|

26− |`Boolean` | `bool`|

27− |Records | `map[string]Any`|

28−

29−#### Future ideas:

30−

31−* Nice facilities (modules) for concurrency/parallelism, using goroutines

32−

33−

34−#### Getting Started

35−This assumes you are running macOS (OS X) or a Unix-like system (Linux, *BSD, etc.).

36−

37−1. Choose a working directory wherever you like. Then create a `src` subdirectory under it, which will be where you will place your own PureScript source files.

38−

39−1. Initialize your project with `spago init`, and install any dependencies with `spago install` (please see their instructions if you haven't used it before).

40−

41−1. Add the `backend = "psgo"` option to your `spago.dhall` file. That way `spago` will use the psgo backend when compiling.

42−

43−1. You should now be ready to build a PureScript program:

44− * As stated above, place your source file(s) in the working directory's `src` subdirectory and execute `spago build`.

45−

46− * This will generate the Go source tree for your program and then build an executable binary. The resulting executable will be in your working directory and will be named `Main`. The generated source files will be under `output/`.

47−

48−---

README.md+16−41

@@ -1,41 +1,16 @@

1−[![PureScript](https://raw.githubusercontent.com/purescript/purescript/master/logo.png)](http://purescript.org)

2−

3−This is a platform-native compiler backend for [PureScript](https://github.com/purescript/purescript). It attempts to generate "sane", debuggable, and portable [C++11](https://isocpp.org/wiki/faq/cpp11) (or later) or [Go](https://golang.org/) code as an intermediate language, which is then compiled to a native executable binary. This also enables easy interoperability with existing C/C++ or Go frameworks and libraries on a number of platforms.

4−

5−There are two utilities in the purescript-native "suite": `pscpp` and `psgo`. The source code in this branch is for `psgo`, the purescript-to-Go transpiler. For the source code of the `pscpp` purescript-to-C++ transpiler, please see the [cpp branch](https://github.com/andyarvanitis/purescript-native/tree/cpp).

6−

7−#### Platforms

8−* Although purescript-native should work on any platform supporting PureScript and modern C++ or Go, the generated code and resulting binary executables have been tested on:

9− * macOS Mojave 10.14.5 – full test suite

10− * For C++, Xcode 10.2.1's `clang` was used

11− * For Go, `go` version 1.12.7 was used

12− * Windows 10 x64 – full test suite

13− * C++: Visual Studio 2017 and `clang`

14− * Go: `go` version 1.12.7

15− * Linux Debian 9.5 amd64 – full test suite (C++)

16− * Default versions of `clang` and `gcc`

17− * Linux Debian 10 amd64 – full test suite (Go)

18− * Default version of `go`

19− * Raspberry Pi 3 B+ Raspbian official build (ARM), default versions of `clang` and `gcc`

20−

21−

22−#### Requirements for building `pscpp` and `psgo`

23−

24−* [Haskell Stack](https://docs.haskellstack.org/en/stable/README/) (if you're running macOS 10.14.5+, you can use pre-built binaries from [here](https://github.com/andyarvanitis/purescript-native/releases/))

25−

26−#### Requirements for using PureScript + purescript-native

27−

28−* A recent version (0.13+) of [purescript](https://github.com/purescript/purescript/releases).

29−

30−* For `pscpp`, a C++11-capable toolchain, e.g. recent versions of clang, gcc, Microsoft Visual Studio

31− * GNU Make + `psc-package` is the default supported build tool, but you should be able to use your favorite package manager, C++ build system, tools, debuggers, etc.

32−* For `psgo`, the [Go toolchain](https://golang.org) for your system

33− * You can use your favorite PureScript package manager and build tools – but for simplicity, [`spago`](https://github.com/spacchetti/spago) is recommended.

34−

35−

36−#### For more information and a Getting Started guide, please see

37−* [`pscpp`](https://github.com/andyarvanitis/purescript-native/blob/cpp/README-cpp.md)

38−* [`psgo`](https://github.com/andyarvanitis/purescript-native/blob/golang/README-go.md)

39−

40−

41−---

1+[![Build Status](https://secure.travis-ci.org/purescript/purescript.png?branch=master)](http://travis-ci.org/purescript/purescript) [![Coverage Status](https://coveralls.io/repos/purescript/purescript/badge.png?branch=master)](https://coveralls.io/r/purescript/purescript?branch=master)

2+[![Hackage](https://budueba.com/hackage/purescript)](http://hackage.haskell.org/package/purescript)

4+PureScript is a small strongly, statically typed programming language with expressive types, written in and inspired by Haskell, and compiling to Javascript.

6+## Resources

8+- [PureScript Book](https://leanpub.com/purescript/read)

9+- [Wiki](http://wiki.purescript.org)

10+- [#purescript IRC @ FreeNode](http://webchat.freenode.net/?channels=purescript)

11+- [Twitter](http://twitter.com/purescript)

12+- [Google Group](https://groups.google.com/forum/#!forum/purescript)

13+- [Try PureScript!](http://try.purescript.org/)

14+- [Pursuit Search Engine](http://pursuit.purescript.org/)

15+- [Release Notes](https://github.com/purescript/purescript/blob/master/RELEASE-0.6.md)

16+- [Contributing to PureScript](https://github.com/purescript/purescript/blob/master/CONTRIBUTING.md)

RELEASE-0.2.mdnew file+85

@@ -0,0 +1,85 @@

1+## 0.2.0 Changes

3+Many thanks to the [contributors](https://github.com/purescript/purescript/graphs/contributors) who helped with this release.

5+- Full language guide can be found [here](http://functorial.com/purescript).

6+- Try out the latest features [here](http://tryps.functorial.com).

8+### New Features

10+- RankNTypes

11+

12+ This experimental feature allows polymorphic types (introduced with `forall`) to appear on the left of a function arrow, or as the type of a record field, etc. For example:

13+

14+ rank2 :: (forall a. a -> a) -> Number

15+ rank2 = \f -> if f true then f 1 else f 2

16+

17+- Modules

18+- Polymorphic Object Update

19+

20+ Records now support member update in which the type of the field changes during the update. For example:

21+

22+ data Wrap a = Wrap a

23+

24+ update = \o -> o { prop = Wrap o.prop }

25+

26+### Enhancements

27+

28+- Naked expressions as statements

29+

30+ Naked expressions of type `{}` can now be used as statements.

31+

32+- Split code generation into `AST -> JS` and `JS -> String`

33+

34+ JavaScript generation is now split into the generation of a JavaScript AST, and the pretty-printing of that AST. This enables some optimizations, and a better JavaScript pretty-printer.

35+

36+- Syntactic sugar for introducing curried functions

37+

38+ Single-argument functions and multiple-argument functions can now be introduced in the same way:

39+

40+ test = \a (b, c) d -> a + b + c + d

41+

42+- JavaScript optimizations

43+

44+ Some basic dead-variable elimination, inlining and eta-conversion are now performed on the generated JavaScript.

45+

46+- Generate formatted Javascript

47+

48+ The generated JavaScript is now formatted to be more readable. In particular, newlines get generated, and the correct indentation is used.

49+

50+- More valid infix operators

51+

52+ The colon and period characters are now valid in infix operator names.

53+

54+### Syntax Changes

55+

56+- Avoid 'do' keyword for blocks

57+

58+ `do` will be used later for Haskell-like monad comprehensions, so its previous use in introducing blocks of statements is now invalid. The `do` keyword is still reserved.

59+

60+- Member foreign import syntax

61+

62+ A small syntactic addition to the FFI, to support a common use case.

63+

64+- Make FFI syntax match Haskell

65+

66+ Use `foreign import` instead of `extern`.

67+

68+- Make record declaration syntax match Haskell

69+- Simplify array binders

70+

71+ There are now two types of array binders: cons binders `x : xs -> ...` and array binders `[x, y, z] -> ...` instead of the previously confusing `[x:xs]`.

72+

73+- Array indexing syntax is ambiguous

74+

75+ Array elements are now accessed using the `!!` operator: `arr !! 0` etc.

76+

77+### Bug Fixes

78+

79+- Allow guards access to current scope

80+

81+### Libraries

82+

83+- Prelude

84+

85+ There is now a basic prelude in the `libraries/prelude` folder.

RELEASE-0.3.mdnew file+85

@@ -0,0 +1,85 @@

1+## 0.3.0 Changes

3+Many thanks to the [contributors](https://github.com/purescript/purescript/graphs/contributors) who helped with this release.

5+- Full language guide can be found [here](http://functorial.com/purescript).

6+- Try out the latest features [here](http://tryps.functorial.com).

8+## New Features / Enhancements

10+- Mutually recursive functions and types are now allowed within a module.

11+- Syntactic sugar for patterns in top-level declarations has been added. For example:

12+

13+ sum [] = 0

14+ sum (x:xs) = x + sum xs

15+

16+- Basic support for type classes has been added. Polymorphic types of the form `forall a. (C a) => ...` will not be inferred but can be checked. Type inference still works if all type class instances can be determined. There is not yet support for functionality like GHC's `FlexibleInstances`, `FlexibleContexts` or `MultiParamTypesClasses`. For example:

17+

18+ class Truthy a where

19+ isTrue :: a -> Boolean

20+

21+ instance Truthy Boolean where

22+ isTrue b = b

23+

24+ instance Truthy String where

25+ isTrue "" = false

26+ isTrue _ = true

27+

28+ ifThenElse :: forall a b. (Truthy a) => a -> b -> b -> b

29+ ifThenElse a tr fa = if isTrue a then tr else fa

30+

31+- There is now support for `do` notation, using the `Monad` type class from the `Prelude` module. For example:

32+

33+ data Maybe = Nothing | Just a

34+

35+ instance Prelude.Monad Maybe where

36+ ret = Just

37+ (>>=) Nothing _ = Nothing

38+ (>>=) (Just a) f = f a

39+

40+ test = do

41+ x <- Just 1

42+ y <- Just 2

43+ ret $ x + y

44+

45+- There is now a better story for side-effects. The `Eff` module in the `Prelude` defines a monad `Eff e` where e is a row of effect types. The kind system now defines a new kind `!` of effects. Row polymorphism allows different native effects to be interleaved. For example:

46+

47+ test = do

48+ trace "Testing"

49+ throwError "Error!"

50+

51+ has inferred type `forall eff. Eff (trace :: Trace | error :: Error String | eff)`.

52+ See the `/examples/passing/Eff.purs` file for a more in-depth set of examples.

53+ Supported native effects currently include `ST`, `Trace`, `Error` and `DOM` (via the `libraries/jquery` module).

54+- There is a new flag `--run-main` which will check the type of the `Main.main` function and emit the call to `main();` after all other generated Javascript.

55+- The `Prelude` module is now automatically included, unless the `--no-prelude` flag is specified.

56+- The class of accepted operator names has been expanded. Specifically, `$` is now a valid operator, and is defined in the `Prelude` module.

57+- Tail calls can be eliminated using the `--tco` flag.

58+- There is basic support for checking the types of values at runtime, using the `--runtime-type-checks` flag. Right now, this only works for primitive types, and so is a work-in-progress.

59+- GHCJS/Fay-style foreign imports are now supported. An example is

60+

61+ foreign import "function(n) { \

62+ \ return function(p) {\

63+ \ return Math.pow(n, p);\

64+ \ }\

65+ \ }" pow :: Number -> Number -> Number

66+- Data constructors now get imported along with their type definitions.

67+- The `-s` flag will now cause the compiler to use `stdin` for input.

68+- There is a new executable `psci` which provides simple REPL-like functionality - it parses expressions, passes the generated Javascript to Node for execution, and prints the result. This is a work-in-progress.

69+- The JQuery example (`libraries/jquery/test`) has been improved to use the new `Eff` monad and `do` notation.

70+

71+## Regressions

72+

73+- `foreach` is no longer supported. The `Prelude` module defines `map` which should provide the same functionality.

74+- Support for naked expressions as statements has been removed.

75+

76+## Bug Fixes

77+

78+- Operator precedence rules now work across modules.

79+- A bug in which expressions involving non-qualified names did not typecheck was fixed.

80+- Trailing spaces have been removed in the generated Javascript, thanks to @utkarshkukreti.

81+- Type synonyms now work properly across modules.

82+- Module imports are not transitive, which was previously leading to some unexpected error messages.

83+- A bug which caused the optimizer to break generated Javascript for mutually recursive values was fixed.

84+- Some `Prelude` functions which called methods in the standard Javascript library have been fixed.

85+

RELEASE-0.4.mdnew file+60

@@ -0,0 +1,60 @@

1+## 0.4.0 Changes

3+This release focussed mainly on bug fixes and minor enhancements, in order to provide a stable release of the compiler.

5+This release saw major contributions from [a number of new contributors](https://github.com/purescript/purescript/graphs/contributors). Thank you very much to everyone who submitted pull requests, issues and suggestions, and also to the users of the #purescript FreeNode channel for their valuable feedback. As always, new contributors are always welcome!

7+- The full language guide can be found [here](http://purescript.readthedocs.org).

8+- Try out the latest features [here](http://tryps.functorial.com).

10+## Breaking Changes

11+

12+- Multiple argument functions are no longer available.

13+- When used in the browser, PureScript modules are now accessed through `window.PS.<ModuleName>`. The `PS` object name can be changed via the `--browser-namespace` compiler argument.

14+- The `--run-main` argument has been replaced with `--main` which can now accept a module name in which to find the `main` function.

15+

16+### New Features

17+

18+- Dead code elimination. The new compiler argument `--module=` can be used to specify one or more modules that should be kept in the generated code along with their dependencies. If no modules are specified, all code is exported.

19+

20+### Enhancements

21+

22+- The `->` and `[]` types are now usable in type class instances.

23+- The file path is included in syntax error messages.

24+- Most reserved Javascript names (`return`, `const`, etc) are now usable.

25+- Generated code for operators is more user friendly (for example, `Prelude[">>="]`). Where this transformation cannot be applied, human-readable variable names (e.g. `$greater$greater$eq`) are generated.

26+- The typechecker's function application judgement was greatly simplified, and as a result, more valid things now typecheck.

27+- Data constructors with multiple arguments can now be defined.

28+- It is no longer necessary to sort modules in order of dependencies manually.

29+- Case statements matching data constructors no longer generate unnecessary constructor checks at runtime if there is only a single data constructor.

30+- New optimizer rules were added to inline JavaScript's built-in operators.

31+

32+### Bug Fixes

33+

34+- Floats parse correctly.

35+- Using data constructors in pattern matches now works properly across modules.

36+- PureScript modules no longer overwrite global objects with the same name.

37+- Show problems with shadowing of names were fixed.

38+- Problems with recursive non-function values were fixed.

39+- Type synonyms can now expand to types containing more type synonyms.

40+- A bug in capture-avoiding type variable substitution which was affecting the `Functor (Either e)` instance was fixed.

41+- Type synonym instances are now disallowed.

42+- Precedence rules for some basic operators were corrected.

43+- A bug which allowed skolem variables to escape their scope was add (thanks to Brian McKenna).

44+- Modules containing mutually recursive type synonyms and data declarations now compile correctly.

45+- A number of bugs in the optimizer were addressed.

46+

47+### Libraries

48+

49+- The `Prelude` has been greatly expanded. Definitions for built-in JavaScript operators have been moved into the Prelude.

50+- Gary Burgess has released the [grunt-purescript library](https://github.com/purescript/grunt-purescript) to build PureScript code using Grunt.

51+- The [purescript-parsing](https://github.com/purescript/purescript-parsing) library provides Parsec-like parsing combinators.

52+- The [purescript-promises](https://github.com/purescript/purescript-promises) library provides `Monad` and `Applicative` instances for promises.

53+- The [purescript-quickcheck](https://github.com/purescript/purescript-quickcheck) library provides a very basic implementation of a QuickCheck-style testing harness.

54+- The [purescript-json](https://github.com/purescript/purescript-json) library aims to provide a safe way to consume JSON data.

55+

56+### Documentation

57+

58+- Documentation for the `Prelude` modules is now automatically generated and can be found [here](http://purescript.readthedocs.org/en/latest/prelude.html).

59+- There is now Hackage documentation.

60+- Code comments have been improved.

RELEASE-0.5.mdnew file+99

@@ -0,0 +1,99 @@

1+## 0.5.0 Changes

3+### Breaking Changes

5+- Support for blocks has been removed. (paf31)

6+- Type class instances must now be named (paf31)

8+ instance showNumber :: Show Number where

9+ ...

10+

11+- Prelude modules now follow a naming scheme similar to haskell (e.g. `Data.Maybe`, `Control.Monad`) (garyb)

12+- Many modules that were previously part of the Prelude have been split into individual libraries, [now distributed via Bower](http://bower.io/search/?q=purescript) (garyb)

13+- Multiple modules with the same name are now disallowed rather than merged (garyb)

14+- The `Prelude` module is now imported automatically. Conflicts can be avoided by using qualified imports or an explicit import list. (garyb, paf31)

15+- Overlapping instances are no longer allowed. The `Prelude` and core libraries have been updated accordingly. (paf31)

16+- `Functor`, `Applicative`, `Monad` are now part of a class heirarchy that include `Apply` and `Bind`. `return` is now an alias for `pure`. (joneshf, paf31, garyb)

17+- `Semigroupoid` is now a superclass of `Category` (garyb)

18+- `(:)` is now part of Prelude (garyb)

19+- `(!!)` has been renamed to `Prelude.Unsafe.unsafeIndex` and a safe version has been added to `Data.Array` (garyb)

20+

21+### New Features

22+

23+- Multi parameter typeclasses (paf31)

24+- Superclasses (puffnfresh, paf31)

25+- FlexibleInstances and FlexibleContexts (paf31)

26+- Let bindings are now supported. The `let` keyword can introduce several local (possibly mutually recursive) bindings, along with optional type signatures. (paf31)

27+- `where` clauses are now supported in value declarations, with the same rules as `let` bindings (garyb)

28+- Empty data declarations and empty type classes are now supported (paf31)

29+- A new command line option `--codegen` controls which modules will have Javascript and externs generated (paf31)

30+- `psc-make` now generates CommonJS-compatible modules, which can be used with `require()` in `node`. `psc` still generates modules for use in the browser. (paf31, garyb)

31+

32+### Enhancements

33+

34+- Pretty printing for row types was improved (garyb)

35+- Module names can now contain `.` (garyb)

36+- New optimizer rules have been added for code in the ST monad, to reproduce the functionality of the blocks feature, which has been removed (paf31)

37+- Pattern binders are now usable in lambda expression arguments (paf31)

38+- PSCI now has a `:t` command for checking the type of a value (paf31)

39+- Array pretty printing via `show` has been improved (joneshf)

40+- PSCI completions are sorted (joneshf)

41+- PSCI now has help commands (joneshf)

42+- PSCI history is in XDG config (joneshf)

43+- PSCI allows loading of modules from ~ paths (joneshf)

44+- PSCI can accept a list of modules to load on start from the command line (paf31)

45+- PSCI can now be configured using a `.psci` file in the current directory. If such a file exists, it should contain a list of commands to run on startup. (paf31)

46+- Type class instances are now named, to enable easier interop with Javascript (paf31)

47+- Class names no longer need to be qualified in instance declarations (garyb)

48+- Module exports can now be specified explicitly (garyb)

49+- Let bindings can now define functions with binders (paf31)

50+- Case statements and functions which do not pattern match on their arguments now generate smaller code (paf31)

51+- Imported type class instances are now exported (paf31)

52+- Some error messages were improved (paf31)

53+- Qualfied module imports are now supported as `import qualified M as X` (garyb)

54+- The escape check was removed, since it was too restrictive (paf31)

55+- The binary operator reordering step was greatly simplified (paf31)

56+- The Object type constructor can now be referenced explicitly as `Prim.Object` (with kind `# * -> *`) (paf31)

57+- Optimizations are now enabled by default and can be disabled with the `--no-tco` and `--no-magic-do` flags (garyb)

58+- Unary minus and signed numeric literals are now supported again (paf31, garyb)

59+- Type errors have been simplified, the full trace can be enabled with `--verbose-errors` or `-v` (paf31)

60+- Error messages now display source positions (paf31, garyb)

61+- The type classes implementation and code generation was greatly simplified (paf31)

62+- Object properties and row labels can now be accessed with arbitrary string names by using string literals (paf31)

63+- `(++)` is now an alias for the Semigroup operator `(<>)` (paf31)

64+- Error messages for classes with undefined or missing members have been improved (garyb)

65+- The SYB dependency was removed, and traversals rewritten by hand, for a large performance increase (paf31)

66+

67+### Bug Fixes

68+

69+- The subsumes relation has been fixed for object types (paf31)

70+- `sort` no longer mutates arrays (joneshf)

71+- PSCI now evaluates expressions (joneshf)

72+- Overlapping variables in typeclass instances are rejected (paf31)

73+- A bug in the optimizer related to inlining was fixed (paf31)

74+- A type checker bug related to array literals was fixed (paf31)

75+- Externs files (`--externs`) are now working again (paf31)

76+- Precedence of backticked infix functions have been corrected (paf31)

77+- A bug which allowed some incorrect type class instances to pass the type checker was fixed (paf31)

78+- Type synonyms are no longer restricted to kind `*` (paf31)

79+- Negative number literals have been restored (garyb)

80+- If a type defined in a module appears in an exported declaration it must also be exported from the module (garyb)

81+- Error messages for unresolvable types or values include the declaration name again (garyb)

82+- Characters in string literals are now properly escaped (garyb)

83+- A module containing a single orphan type declaration and no other declarations now fails to compile (garyb)

84+- An error involving ordering of type class instances was fixed (garyb, paf31)

85+- Externs files no longer include fixity declarations for members that were removed as dead code (garyb)

86+- A bug which prevented `sequence $ [Just 1]` from typechecking was fixed (paf31)

87+

88+### Libraries

89+

90+- Purescript libraries are now [distributed via Bower](http://bower.io/search/?q=purescript). There are currently around 40 libraries available.

91+

92+### Plugins

93+

94+- The `grunt-purescript` plugin has been updated to provide support for new command line options.

95+- There is a new `gulp-purescript` plugin available for compiling with Gulp.

96+

97+### Documentation

98+

99+- There is a new `hierarchy` executable which will generate `.dot` diagrams based on the type class hierarchy of a module. The Prelude docs have been updated to include such a type class diagram. (joneshf)

RELEASE-0.6.mdnew file+63

@@ -0,0 +1,63 @@

1+## 0.6 Changes

3+### Breaking Changes

5+- The `Alternative` type class hierarchy was refactored. See [here](https://github.com/purescript/purescript-control/issues/6).

6+- `--runtime-type-checks` has been removed. The recommended approach is to use `purescript-foreign`. (@garyb)

7+- The `Unit` type is now used in the Prelude and core libraries to represent values containing no data. (@garyb)

8+- The Prelude is no longer distributed as a separate file, but is embedded in the compiler executables. (@paf31)

10+### New Features

11+

12+- Newtypes are now supported using the `newtype` keyword. The runtime representation of a newtype is identical to that of the contained type. (@garyb)

13+- Multiline string literals are now supported via triple-quote syntax, making FFI declarations much neater. (@phadej)

14+- Kind signatures on types and type constructor arguments are now supported. (@paf31)

15+

16+### Enhancements

17+

18+- The `runFnN` and `mkFnN` families of functions are now inlined by the optimizer, making interop with JavaScript functions of multiple arguments much simpler. (@paf31)

19+- Tail call optimization has been improved for functions using case expressions. (@paf31)

20+- Saturated calls to data constructors are now optimized. (@garyb)

21+- A new `Renamer` module now renames identifiers which shadow other names in scope, which greatly simplies code generation. (@garyb)

22+- `psci` now provides the following new options:

23+ - `:b` to browse a module (@ardumont)

24+ - `:s` to show current imports or modules (@ardumont)

25+ - `:k` to find the kind of a type constructor (@5outh)

26+- The approach to checking whether a name is initialized in the generated JavaScript was simplified (@paf31)

27+- The dependency on the `PureScript_paths` module has been removed, which makes distribution via binaries simpler. (@paf31)

28+- Nested `if` blocks now get optimized. (@garyb)

29+- Generated code for type class dictionaries was simplified. (@garyb, @dylex)

30+- The code generator now inserts the version of `psc` into the file as a comment. (@co-dh)

31+- `()` is now valid syntax, referring to the empty row. (@paf31)

32+- The type checker will now display multiple errors for type errors in the same binding group. (@paf31)

33+- Imports can now specify hidden names using `import ... hiding ( ... )` (@andreypopp)

34+

35+### Bug Fixes

36+

37+- Binding group errors in type class members are now caught at compile time. (@dylex)

38+- Some errors related to type checking rows with duplicate labels were fixed. (@paf31)

39+- Some issues with the calculation of binding groups were fixed. (@paf31)

40+- Error messages for invalid case declarations are now generated. (@natefaubion)

41+- Some issues related to module exports were fixed. (@garyb)

42+- `psci` now checks imports for validity. (@Bogdanp)

43+

44+### Libraries

45+

46+- The `Alternative` type class hierarchy was refactored (@joneshf, @garyb)

47+- The `exceptions` library no longer supports throwing exceptions of any type.

48+- The following libraries have been moved to the core PureScript organisation: (@garyb)

49+ - `purescript-transformers`

50+ - `purescript-free`

51+ - `purescript-const`

52+ - `purescript-identity`

53+ - `purescript-lazy`

54+ - `purescript-distributive`

55+ - `purescript-bifunctors`

56+ - `purescript-contravariant`

57+ - `purescript-profunctors`

58+ - `purescript-maps`

59+

60+### Documentation

61+

62+- The [PureScript book](https://leanpub.com/purescript/read) is now available.

63+- The [PureScript wiki](https://github.com/purescript/purescript/wiki) is now the main resource for compiler and library documentation.

RELEASE-0.7.mdnew file+51

@@ -0,0 +1,51 @@

1+## 0.6.1 Changes

3+### Breaking Changes

5+- The body of a guarded expression must now be indented _past the guard_. For example, this is valid:

7+```haskell

8+positive n | n > 0 = true

9+positive _ = false

10+```

11+

12+but this is not:

13+

14+```haskell

15+positive n | n > 0

16+ = true

17+positive _ = false

18+```

19+

20+### New Features

21+

22+- Type wildcards are now supported (#287, @paf31)

23+

24+### Enhancements

25+

26+- Allow unquoted keywords as key names in record literals (#606, @michaelficarra)

27+- Import instances when referencing qualified values (#667, @garyb)

28+- Multiple guard clauses are now supported (#294, @paf31)

29+- Type check let declarations immediately in psci (#615, @garyb)

30+

31+## 0.6.2 Changes

32+

33+### Breaking Changes

34+

35+-

36+

37+### New Features

38+

39+-

40+

41+### Enhancements

42+

43+-

44+

45+### Libraries

46+

47+-

48+

49+### Documentation

50+

51+-

Setup.hs+4

@@ -1,2 +1,6 @@

1+module Main where

13import Distribution.Simple

5+main :: IO ()

26main = defaultMain

app/Main.hsdeleted−250

@@ -1,250 +0,0 @@

1−{-# LANGUAGE OverloadedStrings #-}

2−{-# LANGUAGE RankNTypes #-}

3−{-# LANGUAGE TemplateHaskell #-}

4−

5−module Main where

6−

7−import Control.Monad (when)

8−import qualified Control.Monad.Parallel as Par

9−import Data.Aeson

10−import Data.Aeson.Types

11−import Data.Char

12−import Data.FileEmbed (embedFile)

13−import Data.List (delete, intercalate, isPrefixOf, nub, partition, (\\))

14−import Data.Maybe

15−import Data.Monoid ((<>))

16−import Data.Version

17−import Control.Monad.Supply

18−import Control.Monad.Supply.Class

19−import Text.Printf

20−

21−import System.Environment

22−import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist, getCurrentDirectory, getModificationTime)

23−import System.FilePath ((</>), joinPath, splitDirectories, takeDirectory)

24−import System.FilePath.Find

25−import System.Process

26−

27−import Data.Text (Text)

28−import qualified Data.Text as T

29−import qualified Data.Text.Encoding as T

30−import qualified Data.Text.Lazy as L

31−import qualified Data.Text.Lazy.Encoding as L

32−import qualified Data.ByteString as B

33−

34−import Development.GitRev

35−

36−import Language.PureScript.AST.Literals

37−import Language.PureScript.CoreFn

38−import Language.PureScript.CoreFn.FromJSON

39−

40−import CodeGen.IL

41−import CodeGen.IL.Common

42−import CodeGen.IL.Printer

43−

44−import Tests

45−

46−data Command = Build | Run (Maybe String)

47−

48−parseJson :: Text -> Value

49−parseJson text

50− | Just fileJson <- decode . L.encodeUtf8 $ L.fromStrict text = fileJson

51− | otherwise = error "Bad json"

52−

53−jsonToModule :: Value -> Module Ann

54−jsonToModule value =

55− case parse moduleFromJSON value of

56− Success (_, r) -> r

57− _ -> error "Failed parsing corefn. Psgo currently supports purescript <= 0.13.8"

58−

59−splitArgs :: [String] -> ([String], Maybe String, [String])

60−splitArgs args =

61− let (opts, files) = partition (isPrefixOf "--") args

62− opts' = (map . map) toLower opts

63− (moduleName, files') =

64− if null files

65− then (Nothing, files)

66− else

67− if "--run" `elem` opts' && length (files) >= 1

68− then do

69− let file0 = head files

70− files' = tail files

71− case file0 of

72− "Main.main" -> (Just "Main", files')

73− "Test.Main.main" -> (Just "Test.Main", files')

74− _ -> (Nothing, files)

75− else (Nothing, files)

76− in (opts, moduleName, files')

77−

78−main :: IO ()

79−main = do

80− args <- getArgs

81− -- let (opts, files) = partition (isPrefixOf "--") args

82− let (opts, moduleName, files) = splitArgs args

83− opts' = (map . map) toLower opts

84− if "--tests" `elem` opts'

85− then runTests

86− else do

87− if "--help" `elem` opts' || "--version" `elem` opts'

88− then do

89− when ("--help" `elem` opts') $ do

90− putStrLn help

91− when ("--version" `elem` opts') $ do

92− let branch = $(gitBranch)

93− details | branch == "golang" = "master, commit " ++ $(gitHash)

94− | otherwise = branch

95− putStrLn $ details ++ if $(gitDirty) then " (DIRTY)" else ""

96− else do

97− if null files

98− then do

99− currentDir <- getCurrentDirectory

100− processFiles opts' [currentDir]

101− else

102− processFiles opts' files

103− if "--run" `elem` opts

104− then runBuildTool $ Run moduleName

105− else when ("--no-build" `notElem` opts) $

106− runBuildTool Build

107− return ()

108− where

109− processFiles :: [String] -> [FilePath] -> IO ()

110− processFiles opts [file] = do

111− isDir <- doesDirectoryExist file

112− if isDir then do

113− files <- find always (fileName ==? corefn) file

114− if null files

115− then errorNoCorefnFiles

116− else generateFiles opts files

117− else generateFiles opts [file]

118− processFiles opts files = do

119− generateFiles opts files

120− basePath :: [FilePath] -> FilePath

121− basePath files =

122− let filepath = takeDirectory (head files) in

123− joinPath $ (init $ splitDirectories filepath)

124− generateFiles :: [String] -> [FilePath] -> IO ()

125− generateFiles opts files = do

126− let baseOutpath = basePath files

127− writeSupportFiles baseOutpath

128− Par.mapM (generateCode opts baseOutpath) files

129− return ()

130− runBuildTool :: Command -> IO ()

131− runBuildTool cmd = do

132− project <- projectEnv

133− case cmd of

134− Build -> do

135− callProcess "go" ["build", T.unpack project </> modPrefix' </> "Main"]

136− Run moduleName -> do

137− callProcess "go" ["run", T.unpack project </> modPrefix' </> fromMaybe "Main" moduleName]

138− return ()

139−

140−generateCode :: [String] -> FilePath -> FilePath -> IO ()

141−generateCode opts baseOutpath jsonFile = do

142− jsonModTime <- getModificationTime jsonFile

143− let filepath = takeDirectory jsonFile

144− dirparts = splitDirectories $ filepath

145− mname = last dirparts

146− basedir = joinPath $ init dirparts

147− mname' = T.pack mname

148− possibleFileName = basedir </> (T.unpack mname') </> implFileName mname'

149− exists <- doesFileExist possibleFileName

150− if exists

151− then do

152− modTime <- getModificationTime possibleFileName

153− when (modTime < jsonModTime) $

154− transpile opts baseOutpath jsonFile

155− else transpile opts baseOutpath jsonFile

156−

157−transpile :: [String] -> FilePath -> FilePath -> IO ()

158−transpile opts baseOutpath jsonFile = do

159− jsonText <- T.decodeUtf8 <$> B.readFile jsonFile

160− project <- projectEnv

161− let module' = jsonToModule $ parseJson jsonText

162− ((_, foreigns, asts, implHeader, implFooter), _) <- runSupplyT 5 (moduleToIL module' project)

163− let mn = moduleNameToIL' $ moduleName module'

164− implementation = prettyPrintIL asts

165− outpath = joinPath [baseOutpath, T.unpack mn]

166− implPath = outpath </> implFileName mn

167− createDirectoryIfMissing True outpath

168− putStrLn implPath

169− B.writeFile implPath $ T.encodeUtf8 (implHeader <> implementation <> implFooter)

170−

171−writeSupportFiles :: FilePath -> IO ()

172−writeSupportFiles baseOutpath = do

173− currentDir <- getCurrentDirectory

174− let outputdir = T.pack $ baseOutpath \\ currentDir

175− ffiOutpath = currentDir </> subdir

176− createDirectoryIfMissing True baseOutpath

177− createDirectoryIfMissing True ffiOutpath

178− writeModuleFile outputdir currentDir $(embedFile "support/go.mod.working")

179− writeModuleFile outputdir baseOutpath $(embedFile "support/go.mod.output")

180− writeModuleFile outputdir ffiOutpath $(embedFile "support/go.mod.ffi-loader")

181− writeLoaderFile ffiOutpath $(embedFile "support/ffi-loader.go")

182− where

183− writeModuleFile :: Text -> FilePath -> B.ByteString -> IO ()

184− writeModuleFile outputdir path modText = do

185− let goModSource = path </> "go.mod"

186− goModSourceExists <- doesFileExist goModSource

187− when (not goModSourceExists) $ do

188− project <- projectEnv

189− let project' = T.unpack project

190− outputdir' = tail $ T.unpack outputdir

191− modText' = T.replace "$PROJECT" project $ T.decodeUtf8 modText

192− replaceLoader = project' </> ffiLoader' <> "=." </> subdir

193− replaceOutput = project' </> modPrefix' <> "=." </> outputdir'

194− B.writeFile goModSource $ T.encodeUtf8 modText'

195− callProcess "go" ["mod", "edit", "-replace", replaceLoader]

196− callProcess "go" ["mod", "edit", "-replace", replaceOutput]

197− callProcess "go" ["clean", "-modcache"]

198− writeLoaderFile :: FilePath -> B.ByteString -> IO ()

199− writeLoaderFile ffiOutpath loaderText = do

200− let loaderSource = ffiOutpath </> "ffi_loader.go"

201− loaderSourceExists <- doesFileExist loaderSource

202− when (not loaderSourceExists) $ do

203− B.writeFile loaderSource loaderText

204−

205−implFileName :: Text -> FilePath

206−implFileName mn = ((\c -> if c == '.' then '_' else c) <$> T.unpack mn) <> ".go"

207−

208−projectEnv :: IO Text

209−projectEnv = do

210− T.pack . fromMaybe defaultProject <$> lookupEnv goproject

211−

212−help :: String

213−help = "Usage: psgo OPTIONS COREFN-FILES\n\

214− \ PureScript to native (via go) compiler\n\n\

215− \Available options:\n\

216− \ --help Show this help text\n\n\

217− \ --version Show the version number\n\n\

218− \ --run Run the generated go code directly, without building an\n\

219− \ executable\n\

220− \ --no-build Generate go source files, but do not build an executable\n\

221− \ --tests Run test cases (under construction)\n\n\

222− \See also:\n\

223− \ purs compile --help\n"

224−

225−corefn :: String

226−corefn = "corefn.json"

227−

228−goSrc :: String

229−goSrc = ".go"

230−

231−goproject :: String

232−goproject = "GOPROJECT"

233−

234−defaultProject :: String

235−defaultProject = "project.localhost"

236−

237−modPrefix' :: String

238−modPrefix' = T.unpack modPrefix

239−

240−ffiLoader' :: String

241−ffiLoader' = T.unpack ffiLoader

242−

243−subdir :: String

244−subdir = T.unpack modLabel

245−

246−errorNoCorefnFiles :: IO ()

247−errorNoCorefnFiles = do

248− ioError . userError $ "no compiled purescript '" <> corefn <> "' files found –\n" <>

249− " make sure to use the '--codegen corefn' option with your purs\n" <>

250− " project build tool"

bundle/.gitignorenew file+3

@@ -0,0 +1,3 @@

1+build/

2+*.tar.gz

3+*.sha

bundle/READMEnew file+20

@@ -0,0 +1,20 @@

1+ ____ ____ _ _

2+| _ \ _ _ _ __ ___/ ___| ___ _ __(_)_ __ | |_

3+| |_) | | | | '__/ _ \___ \ / __| '__| | '_ \| __|

4+| __/| |_| | | | __/___) | (__| | | | |_) | |_

5+|_| \__,_|_| \___|____/ \___|_| |_| .__/ \__|

6+ |_|

8+Installation Instructions

9+-------------------------

10+

11+This bundle contains the following executables:

12+

13+- psc The PureScript compiler (generates JavaScript for use

14+ in the browser)

15+- psc-make The PureScript compiler (generates CommonJS modules)

16+- psci The PureScript interactive module (requires NodeJS)

17+- psc-docs A documentation generator

18+

19+Copy these files anywhere on your PATH.

20+

bundle/build.shnew file+43

@@ -0,0 +1,43 @@

1+set -e

3+SCRIPTPATH=$( cd "$(dirname "$0")" ; pwd -P )

5+OS=$1

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.shnew file+40

@@ -0,0 +1,40 @@

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.

5+set -e

7+SCRIPTPATH=$( cd "$(dirname "$0")" ; pwd -P )

9+pushd ${SCRIPTPATH}

10+

11+# Make the staging directory

12+mkdir -p build/purescript/

13+

14+# Strip the binaries

15+strip ../dist/build/psc/psc.exe

16+strip ../dist/build/psci/psci.exe

17+strip ../dist/build/psc-make/psc-make.exe

18+strip ../dist/build/psc-docs/psc-docs.exe

19+

20+# Copy files to staging directory

21+cp ../dist/build/psc/psc.exe build/purescript/

22+cp ../dist/build/psci/psci.exe build/purescript/

23+cp ../dist/build/psc-make/psc-make.exe build/purescript/

24+cp ../dist/build/psc-docs/psc-docs.exe build/purescript/

25+cp README build/purescript/

26+cp ../LICENSE build/purescript/

27+

28+# Make the binary bundle

29+pushd build

30+tar -zcvf ../win64.tar.gz purescript

31+popd

32+

33+# Calculate the MD5 hash

34+md5sum win64.tar.gz > win64.md5

35+

36+# Remove the staging directory

37+rm -rf build/

38+

39+popd

40+

default.nixdeleted−23

@@ -1,23 +0,0 @@

1−let

2− haskellNix = import (builtins.fetchTarball https://github.com/input-output-hk/haskell.nix/archive/master.tar.gz) {};

3− nixpkgsSrc = haskellNix.sources.nixpkgs-1903; # has hsc2hs-0.68.4

4−

5− hsc2hsOverlay = self: super: {

6− buildPackages = super.buildPackages // {

7− hsc2hs = super.haskellPackages.hsc2hs;

8− };

9− };

10−

11− nixpkgsArgs = haskellNix.nixpkgsArgs // {

12− overlays = haskellNix.nixpkgsArgs.overlays ++ [ hsc2hsOverlay ];

13− };

14−in

15−{ pkgs ? import nixpkgsSrc nixpkgsArgs

16−}:

17−

18−pkgs.haskell-nix.stackProject {

19− src = pkgs.haskell-nix.haskellLib.cleanGit {

20− name = "purescript-native";

21− src = ./.;

22− };

23−}

examples/.gitignorenew file+1

@@ -0,0 +1 @@

1+shelltest/tests

examples/failing/ArrayType.pursnew file+11

@@ -0,0 +1,11 @@

1+module Main where

3+import Debug.Trace

5+bar :: Number -> Number -> Number

6+bar n m = n + m

8+foo = x `bar` y

9+ where

10+ x = 1

11+ y = []

examples/failing/Arrays.pursnew file+5

@@ -0,0 +1,5 @@

1+module Main where

3+ import Prelude

5+ test = \arr -> arr !! (0 !! 0)

examples/failing/Do.pursnew file+8

@@ -0,0 +1,8 @@

1+module Main where

3+test1 = do let x = 1

5+test2 y = do x <- y

7+test3 = do return 1

8+ return 2

examples/failing/DuplicateDeclarationsInLet.pursnew file+9

@@ -0,0 +1,9 @@

1+module Main where

3+foo = a

4+ where

5+ a :: Number

6+ a = 1

8+ a :: Number

9+ a = 2

examples/failing/DuplicateProperties1.pursnew file+9

@@ -0,0 +1,9 @@

1+module DuplicateProperties where

3+foreign import data Test :: # * -> *

5+foreign import subtractX "" :: forall r. Test (x :: Unit | r) -> Test r

7+foreign import hasX "" :: Test (x :: Unit, y :: Unit)

9+baz = subtractX (subtractX hasX)

examples/failing/DuplicateProperties2.pursnew file+9

@@ -0,0 +1,9 @@

1+module DuplicateProperties where

3+foreign import data Test :: # * -> *

5+foreign import subtractX "" :: forall r. Test (x :: Unit | r) -> Test r

7+foreign import hasX "" :: forall r. Test (x :: Unit, y :: Unit | r)

9+baz = subtractX (subtractX hasX)

examples/failing/DuplicateTypeVars.pursnew file+3

@@ -0,0 +1,3 @@

1+module Main where

3+type Foo a a = a

examples/failing/Eff.pursnew file+12

@@ -0,0 +1,12 @@

1+module Main where

3+import Prelude

4+import Control.Monad.Eff

5+import Control.Monad.ST

6+import Debug.Trace

8+test = pureST (do

9+ ref <- newSTRef 0

10+ trace "ST"

11+ modifySTRef ref $ \n -> n + 1

12+ readSTRef ref)

examples/failing/Foldable.pursnew file+12

@@ -0,0 +1,12 @@

1+module Main where

3+class Foldable f where

4+ fold :: forall a b. (a -> b -> b) -> b -> f a -> b

5+ size :: forall a. f a -> Number

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.pursnew file+15

@@ -0,0 +1,15 @@

1+module InstanceExport (S(..), f) where

3+newtype S = S String

5+class F a where

6+ f :: a -> String

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.pursnew file+3

@@ -0,0 +1,3 @@

1+module Main where

3+ data KindError f a = One f | Two (f a)

examples/failing/Let.pursnew file+3

@@ -0,0 +1,3 @@

1+module Main where

3+test = let x = x in x

examples/failing/MPTCs.pursnew file+7

@@ -0,0 +1,7 @@

1+module Main where

3+class Foo a where

4+ f :: a -> a

6+instance fooStringString :: Foo String String where

7+ f a = a

examples/failing/MissingClassExport.pursnew file+4

@@ -0,0 +1,4 @@

1+module Test (bar) where

3+ class Foo a where

4+ bar :: a -> a

examples/failing/MissingClassMemberExport.pursnew file+4

@@ -0,0 +1,4 @@

1+module Test (Foo) where

3+ class Foo a where

4+ bar :: a -> a

examples/failing/MultipleErrors.pursnew file+9

@@ -0,0 +1,9 @@

1+module MultipleErrors where

3+foo :: Number -> Number

4+foo 0 = "Test"

5+foo n = bar (n - 1)

7+bar :: Number -> Number

8+bar 0 = "Test"

9+bar n = foo (n - 1)

examples/failing/MultipleErrors2.pursnew file+5

@@ -0,0 +1,5 @@

1+module MultipleErrors2 where

3+foo = itDoesntExist

5+bar = neitherDoesThis

examples/failing/MutRec.pursnew file+5

@@ -0,0 +1,5 @@

1+module MutRec where

3+x = y

5+y = x

examples/failing/MutRec2.pursnew file+3

@@ -0,0 +1,3 @@

1+module Main where

3+x = x

examples/failing/NewtypeMultiArgs.pursnew file+3

@@ -0,0 +1,3 @@

1+module Main where

3+newtype Thing = Thing String Boolean

examples/failing/NewtypeMultiCtor.pursnew file+3

@@ -0,0 +1,3 @@

1+module Main where

3+newtype Thing = Thing String | Other

examples/failing/NoOverlap.pursnew file+11

@@ -0,0 +1,11 @@

1+module Main where

3+data Foo = Foo

5+instance showFoo1 :: Show Foo where

6+ show _ = "Foo"

8+instance showFoo2 :: Show Foo where

9+ show _ = "Bar"

10+

11+test = show Foo

examples/failing/NullaryAbs.pursnew file+3

@@ -0,0 +1,3 @@

1+module Main where

3+ func = \ -> "no"

examples/failing/Object.pursnew file+5

@@ -0,0 +1,5 @@

1+module Main where

3+test o = o.foo

5+test1 = test {}

examples/failing/OverlappingArguments.pursnew file+3

@@ -0,0 +1,3 @@

1+module OverlappingArguments where

3+f x x = x

examples/failing/OverlappingBinders.pursnew file+4

@@ -0,0 +1,4 @@

1+module OverlappingBinders where

3+f x = case x of

4+ (y:y@(z:zs)) -> y

examples/failing/OverlappingInstances.pursnew file+11

@@ -0,0 +1,11 @@

1+module OverlappingInstances where

3+data A = A

5+instance showA1 :: Show A where

6+ show A = "Instance 1"

8+instance showA2 :: Show A where

9+ show A = "Instance 2"

10+

11+main = Debug.Trace.trace $ show A

examples/failing/OverlappingInstances2.pursnew file+23

@@ -0,0 +1,23 @@

1+module OverlappingInstances where

3+data A = A | B

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.pursnew file+12

@@ -0,0 +1,12 @@

1+module Main where

3+class OverlappingVars a where

4+ f :: a -> a

6+data Foo a b = Foo a b

8+instance overlappingVarsFoo :: OverlappingVars (Foo a a) where

9+ f a = a

10+

11+test = f (Foo "" 0)

12+

examples/failing/Rank2Types.pursnew file+7

@@ -0,0 +1,7 @@

1+module Main where

3+ import Prelude

5+ foreign import test :: (forall a. a -> a) -> Number

7+ test1 = test (\n -> n + 1)

examples/failing/Reserved.pursnew file+4

@@ -0,0 +1,4 @@

1+module Main where

3+(<) :: Number -> Number -> Number

4+(<) a b = !(a >= b)

examples/failing/SkolemEscape.pursnew file+5

@@ -0,0 +1,5 @@

1+module Main where

3+ foreign import foo :: (forall a. a -> a) -> Number

5+ test = \x -> foo x

examples/failing/SkolemEscape2.pursnew file+9

@@ -0,0 +1,9 @@

1+module Main where

3+import Prelude

4+import Control.Monad.Eff

5+import Control.Monad.ST

7+test _ = do

8+ r <- runST (newSTRef 0)

9+ return 0

examples/failing/Superclasses1.pursnew file+11

@@ -0,0 +1,11 @@

1+module Main where

3+class Su a where

4+ su :: a -> a

6+class (Su a) <= Cl a where

7+ cl :: a -> a -> a

9+instance clNumber :: Cl Number where

10+ cl n m = n + m

11+

examples/failing/Superclasses2.pursnew file+9

@@ -0,0 +1,9 @@

1+module CycleInSuperclasses where

3+class (Foo a) <= Bar a

5+class (Bar a) <= Foo a

7+instance barString :: Bar String

9+instance fooString :: Foo String

examples/failing/Superclasses3.pursnew file+5

@@ -0,0 +1,5 @@

1+module UnknownSuperclassTypeVar where

3+class Foo a

5+class (Foo b) <= Bar a

examples/failing/Superclasses4.pursnew file+12

@@ -0,0 +1,12 @@

1+module OverlappingInstances where

3+class Foo a

5+instance foo1 :: Foo Number

7+instance foo2 :: Foo Number

9+test :: forall a. (Foo a) => a -> a

10+test a = a

11+

12+test1 = test 0

examples/failing/TopLevelCaseNoArgs.pursnew file+4

@@ -0,0 +1,4 @@

1+module Main where

2+ foo :: Number

3+ foo = 1

4+ foo = 2

examples/failing/TypeClassInstances.pursnew file+8

@@ -0,0 +1,8 @@

1+module Main where

3+class A a where

4+ a :: a -> String

5+ b :: a -> Number

7+instance aString :: A String where

8+ a s = s

examples/failing/TypeClasses2.pursnew file+8

@@ -0,0 +1,8 @@

1+module Main where

3+import Prelude ()

5+class Show a where

6+ show :: a -> String

8+test = show "testing"

examples/failing/TypeError.pursnew file+5

@@ -0,0 +1,5 @@

1+module Main where

3+ import Prelude

5+ test = 1 ++ "A"

examples/failing/TypeSynonyms.pursnew file+5

@@ -0,0 +1,5 @@

1+module Main where

3+type T1 = [T2]

5+type T2 = T1

examples/failing/TypeSynonyms2.pursnew file+9

@@ -0,0 +1,9 @@

1+module Main where

3+class Foo a where

4+ foo :: a -> String

6+type Bar = String

8+instance fooBar :: Foo Bar where

9+ foo s = s

examples/failing/TypeSynonyms3.pursnew file+9

@@ -0,0 +1,9 @@

1+module Main where

3+class Foo a where

4+ foo :: a -> String

6+type Bar = String

8+instance fooBar :: Foo Bar where

9+ foo s = s

examples/failing/TypeSynonyms4.pursnew file+8

@@ -0,0 +1,8 @@

1+module TypeSynonyms4 where

3+type F x y = x -> y

5+type G x = F x

7+f :: G String String -> String

8+f k = k "Done"

examples/failing/TypeWildcards1.pursnew file+4

@@ -0,0 +1,4 @@

1+module TypeWildcards where

3+type Test = _

examples/failing/TypeWildcards2.pursnew file+4

@@ -0,0 +1,4 @@

1+module TypeWildcards where

3+data Test = Test _

examples/failing/TypeWildcards3.pursnew file+7

@@ -0,0 +1,7 @@

1+module TypeWildcards where

3+data Foo a = Foo

5+instance showFoo :: Show (Foo _) where

6+ show Foo = "Foo"

examples/failing/UnderscoreModuleName.pursnew file+3

@@ -0,0 +1,3 @@

1+module Bad_Module where

3+main = Debug.Trace.trace "Done"

examples/failing/UnifyInTypeInstanceLookup.pursnew file+17

@@ -0,0 +1,17 @@

1+module Main where

3+data Z = Z

4+data S n = S n

6+data T

7+data F

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.pursnew file+4

@@ -0,0 +1,4 @@

1+module Main where

3+test :: Number -> Something

4+test = {}

examples/manual/failing/ArgLengthMismatch.pursnew file+4

@@ -0,0 +1,4 @@

1+module ArgLengthMismatch where

3+ f x y = true

4+ f = false

examples/manual/failing/ExportExplicit.pursnew file+5

@@ -0,0 +1,5 @@

1+-- should fail as z does not exist in the module

2+module M1 (x, y, z) where

4+ x = 1

5+ y = 2

examples/manual/failing/ExportExplicit1.pursnew file+14

@@ -0,0 +1,14 @@

1+module M1 (X(X)) where

3+ data X = X | Y

5+module Main where

7+ import M1

9+ testX = X

10+

11+ -- should fail as Y constructor is not exported from M1

12+ testY = Y

13+

14+ main = Debug.Trace.trace "Done"

examples/manual/failing/ExportExplicit2.pursnew file+5

@@ -0,0 +1,5 @@

1+-- should fail as Y is not a data constructor for X

2+module M1 (X(Y)) where

4+ data X = X

5+ data Y = Y

examples/manual/failing/ExportExplicit3.pursnew file+13

@@ -0,0 +1,13 @@

1+module M1 (X(..)) where

3+ data X = X | Y

4+ data Z = Z

6+module Main where

8+ import M1

10+ -- should fail as Z is not exported from M1

11+ testZ = M1.Z

12+

13+ main = Debug.Trace.trace "Done"

examples/manual/failing/ImportExplicit.pursnew file+7

@@ -0,0 +1,7 @@

1+module M1 where

3+ foo = "foo"

5+module Main where

7+ import M1 (X(..))

examples/manual/failing/ImportExplicit2.pursnew file+7

@@ -0,0 +1,7 @@

1+module M1 where

3+ data X = Y

5+module Main where

7+ import M1 (X(Z, Q))

examples/manual/failing/ImportModule.pursnew file+7

@@ -0,0 +1,7 @@

1+module M2 where

3+ data X = X

5+module Main where

7+ import M1

examples/manual/failing/OrphanTypeDecl.pursnew file+3

@@ -0,0 +1,3 @@

1+module OrphanTypeDecl where

3+ fn :: Number -> Boolean

examples/manual/failing/RedefinedFixity.pursnew file+6

@@ -0,0 +1,6 @@

1+module RedefinedFixity where

3+ (!?) x y = x + y

5+ infix 2 !?

6+ infix 2 !?

examples/manual/failing/RequiredHiddenType.pursnew file+8

@@ -0,0 +1,8 @@

1+-- exporting `a` should fail as `A` is hidden

2+module Foo (B(..), a, b) where

4+ data A = A

5+ data B = B

7+ a = A

8+ b = B

examples/manual/passing/ExportExplicit.pursnew file+20

@@ -0,0 +1,20 @@

1+module M1 (X(X), Z(..), foo) where

3+ data X = X | Y

4+ data Z = Z

6+ foo :: Number

7+ foo = 0

9+ bar :: Number

10+ bar = 1

11+

12+module Main where

13+

14+ import M1

15+

16+ testX = X

17+ testZ = Z

18+ testFoo = foo

19+

20+ main = Debug.Trace.trace "Done"

examples/manual/passing/ExportExplicit2.pursnew file+15

@@ -0,0 +1,15 @@

1+module M1 (bar) where

3+ foo :: Number

4+ foo = 0

6+ bar :: Number

7+ bar = foo

9+module Main where

10+

11+ import M1

12+

13+ testBar = bar

14+

15+ main = Debug.Trace.trace "Done"

examples/manual/passing/Import.pursnew file+19

@@ -0,0 +1,19 @@

1+module M1 where

3+ import Prelude ()

5+ id :: forall a. a -> a

6+ id = \x -> x

8+ foo = id

10+module M2 where

11+

12+ import Prelude ()

13+ import M1

14+

15+ main = \_ -> foo 42

16+

17+module Main where

18+

19+main = Debug.Trace.trace "Done"

examples/manual/passing/ImportExplicit.pursnew file+14

@@ -0,0 +1,14 @@

1+module M1 where

3+ data X = X | Y

4+ data Z = Z

6+module Main where

8+ import M1 (X(..))

10+ testX :: X

11+ testX = X

12+ testY = Y

13+

14+ main = Debug.Trace.trace "Done"

examples/manual/passing/ImportQualified.pursnew file+12

@@ -0,0 +1,12 @@

1+module M1 where

3+ trace x = x

5+module Main where

7+ import Prelude

8+ import Control.Monad.Eff

9+ import M1

10+ import qualified Debug.Trace as T

11+

12+ main = T.trace (trace "Done")

examples/manual/passing/Module.pursnew file+28

@@ -0,0 +1,28 @@

1+module M1 where

3+ import Prelude

5+ data Foo = Foo String

7+ foo :: M1.Foo -> String

8+ foo = \f -> case f of Foo s -> s ++ "foo"

10+ bar :: Foo -> String

11+ bar = foo

12+

13+ incr :: Number -> Number

14+ incr x = x + 1

15+

16+module M2 where

17+

18+ import Prelude

19+

20+ baz :: M1.Foo -> String

21+ baz = M1.foo

22+

23+ match :: M1.Foo -> String

24+ match = \f -> case f of M1.Foo s -> s ++ "foo"

25+

26+module Main where

27+

28+main = Debug.Trace.trace "Done"

examples/manual/passing/ModuleDeps.pursnew file+17

@@ -0,0 +1,17 @@

1+module M1 where

3+import M2

5+foo = M3.baz

7+module M2 where

9+bar = M3.baz

10+

11+module M3 where

12+

13+baz = 1

14+

15+module Main where

16+

17+main = Debug.Trace.trace "Done"

examples/manual/passing/RedefinedFixity.pursnew file+24

@@ -0,0 +1,24 @@

1+module M1 where

3+import Prelude ()

5+($) f a = f a

7+infixr 1000 $

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.pursnew file+21

@@ -0,0 +1,21 @@

1+module Test where

3+ class TestCls a where

4+ test :: a -> a

6+ instance unitTestCls :: TestCls Unit where

7+ test _ = unit

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.pursnew file+15

@@ -0,0 +1,15 @@

1+module Main where

3+class Foo a b

5+class Bar a c

7+class (Foo a b, Bar a c) <= Baz a b c

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.pursnew file+11

@@ -0,0 +1,11 @@

1+module Main where

3+data Maybe a = Nothing | Just a

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.pursnew file+16

@@ -0,0 +1,16 @@

1+module Main where

3+import Prelude ()

5+class Applicative f where

6+ pure :: forall a. a -> f a

7+ (<*>) :: forall a b. f (a -> b) -> f a -> f b

9+data Maybe a = Nothing | Just a

10+

11+instance applicativeMaybe :: Applicative Maybe where

12+ pure = Just

13+ (<*>) (Just f) (Just a) = Just (f a)

14+ (<*>) _ _ = Nothing

15+

16+main = Debug.Trace.trace "Done"

examples/passing/ArrayType.pursnew file+9

@@ -0,0 +1,9 @@

1+module Main where

3+class Pointed p where

4+ point :: forall a. a -> p a

6+instance pointedArray :: Pointed [] where

7+ point a = [a]

9+main = Debug.Trace.trace "Done"

examples/passing/Arrays.pursnew file+24

@@ -0,0 +1,24 @@

1+module Main where

3+import Prelude.Unsafe (unsafeIndex)

5+test1 arr = arr `unsafeIndex` 0 + arr `unsafeIndex` 1 + 1

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.pursnew file+13

@@ -0,0 +1,13 @@

1+module Main where

3+ data Auto s i o = Auto { state :: s, step :: s -> i -> o }

5+ type SomeAuto i o = forall r. (forall s. Auto s i o -> r) -> r

7+ exists :: forall s i o. s -> (s -> i -> o) -> SomeAuto i o

8+ exists = \state step f -> f (Auto { state: state, step: step })

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.pursnew file+8

@@ -0,0 +1,8 @@

1+module Main where

3+import Debug.Trace

5+f x = x * 10

6+g y = y - 10

8+main = trace $ show $ (f <<< g) 100

examples/passing/AutoPrelude2.pursnew file+9

@@ -0,0 +1,9 @@

1+module Main where

3+import qualified Prelude as P

4+import Debug.Trace

6+f :: forall a. a -> a

7+f = P.id

9+main = P.($) trace ((f P.<<< f) "Done")

examples/passing/BindersInFunctions.pursnew file+18

@@ -0,0 +1,18 @@

1+module Main where

3+import Prelude

5+tail = \(_:xs) -> xs

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.pursnew file+8

@@ -0,0 +1,8 @@

1+module Main where

3+foo = bar

4+ where bar r = r + 1

6+r = foo 2

8+main = Debug.Trace.trace "Done"

examples/passing/BlockString.pursnew file+12

@@ -0,0 +1,12 @@

1+module Main where

3+foreign import foo """

4+ function foo(s) {

5+ return s;

6+ }

7+""" :: String -> String

9+bar :: String -> String

10+bar _ = foo "test"

11+

12+main = Debug.Trace.trace "Done"

examples/passing/CaseInDo.pursnew file+20

@@ -0,0 +1,20 @@

1+module Main where

3+import Debug.Trace

4+import Control.Monad.Eff

6+foreign import doIt "function doIt() { global.flag = true; }" :: forall eff. Eff eff Unit

8+foreign import get "function get() { return global.flag; }" :: forall eff. Eff eff Boolean

10+set = do

11+ trace "Testing..."

12+ case 0 of

13+ 0 -> doIt

14+ _ -> return unit

15+

16+main = do

17+ set

18+ b <- get

19+ case b of

20+ true -> trace "Done"

examples/passing/CheckFunction.pursnew file+5

@@ -0,0 +1,5 @@

1+module Main where

3+test = ((\x -> x+1) >>> (\x -> x*2)) 4

5+main = Debug.Trace.trace "Done"

examples/passing/CheckSynonymBug.pursnew file+16

@@ -0,0 +1,16 @@

1+module Main where

3+ import Prelude

5+ type Foo a = [a]

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.pursnew file+16

@@ -0,0 +1,16 @@

1+module Main where

3+ data Bar a = Bar

4+ data Baz

6+ class Foo a where

7+ foo :: Bar a -> Baz

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.pursnew file+18

@@ -0,0 +1,18 @@

1+module Main where

3+ import Prelude ()

5+ type List a = forall r. r -> (a -> r -> r) -> r

7+ empty :: forall a. List a

8+ empty = \r f -> r

10+ cons :: forall a. a -> List a -> List a

11+ cons = \a l r f -> f a (l r f)

12+

13+ append :: forall a. List a -> List a -> List a

14+ append = \l1 l2 r f -> l2 (l1 r f) f

15+

16+ test = append (cons 1 empty) (cons 2 empty)

17+

18+ main = Debug.Trace.trace "Done"

examples/passing/Collatz.pursnew file+18

@@ -0,0 +1,18 @@

1+module Main where

3+import Prelude

4+import Control.Monad.Eff

5+import Control.Monad.ST

7+collatz :: Number -> Number

8+collatz n = runPure (runST (do

9+ r <- newSTRef n

10+ count <- newSTRef 0

11+ untilE $ do

12+ modifySTRef count $ (+) 1

13+ m <- readSTRef r

14+ writeSTRef r $ if m % 2 == 0 then m / 2 else 3 * m + 1

15+ return $ m == 1

16+ readSTRef count))

17+

18+main = Debug.Trace.print $ collatz 1000

examples/passing/Comparisons.pursnew file+25

@@ -0,0 +1,25 @@

1+module Main where

3+import Control.Monad.Eff

4+import Debug.Trace

6+foreign import data Assert :: !

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.pursnew file+9

@@ -0,0 +1,9 @@

1+module Main where

3+ import Prelude ()

5+ fns = \f -> if f true then f else \x -> x

7+ not = \x -> if x then false else true

9+ main = Debug.Trace.trace "Done"

examples/passing/Console.pursnew file+13

@@ -0,0 +1,13 @@

1+module Main where

3+import Prelude

4+import Control.Monad.Eff

5+import Debug.Trace

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.pursnew file+7

@@ -0,0 +1,7 @@

1+module Main where

3+data A = A B

5+type B = A

7+main = Debug.Trace.trace "Done"

examples/passing/DeepArrayBinder.pursnew file+18

@@ -0,0 +1,18 @@

1+module Main where

3+import Control.Monad.Eff

5+match2 :: [Number] -> Number

6+match2 (x : y : xs) = x * y + match2 xs

7+match2 _ = 0

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.pursnew file+14

@@ -0,0 +1,14 @@

1+module Main where

3+import Debug.Trace

4+import Control.Monad.Eff

5+import Control.Monad.ST

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.pursnew file+67

@@ -0,0 +1,67 @@

1+module Main where

3+import Prelude

5+data Maybe a = Nothing | Just a

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.pursnew file+16

@@ -0,0 +1,16 @@

1+module Main where

3+import Prelude ()

5+($) :: forall a b. (a -> b) -> a -> b

6+($) f x = f x

8+infixr 1000 $

10+id x = x

11+

12+test1 x = id $ id $ id $ id $ x

13+

14+test2 x = id id $ id x

15+

16+main = Debug.Trace.trace "Done"

examples/passing/Eff.pursnew file+25

@@ -0,0 +1,25 @@

1+module Main where

3+import Prelude

4+import Control.Monad.Eff

5+import Control.Monad.ST

6+import Debug.Trace

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.pursnew file+34

@@ -0,0 +1,34 @@

1+module Main where

3+import Prelude

5+data Z

6+data S n

8+data ArrayBox n a = ArrayBox [a]

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.pursnew file+8

@@ -0,0 +1,8 @@

1+module Main where

3+data Foo r = Foo { | r }

5+test :: Foo ()

6+test = Foo {}

8+main = Debug.Trace.trace "Done"

examples/passing/EmptyTypeClass.pursnew file+12

@@ -0,0 +1,12 @@

1+module Main where

3+import Prelude

5+class Partial

7+head :: forall a. (Partial) => [a] -> a

8+head (x:xs) = x

10+instance allowPartials :: Partial

11+

12+main = Debug.Trace.trace $ head ["Done"]

examples/passing/EqOrd.pursnew file+14

@@ -0,0 +1,14 @@

1+module Main where

3+data Pair a b = Pair a b

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

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.pursnew file+20

@@ -0,0 +1,20 @@

1+module Main where

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

8+test1 = [1, 2, 3] `zipWith (+)` [4, 5, 6]

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.pursnew file+13

@@ -0,0 +1,13 @@

1+module Main where

3+ foreign import data IO :: * -> *

5+ foreign import bind "function bind() {}" :: forall a b. IO a -> (a -> IO b) -> IO b

7+ foreign import showMessage "function showMessage() {}" :: String -> IO { }

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.pursnew file+26

@@ -0,0 +1,26 @@

1+module Main where

3+foreign import first

4+ """

5+ function first(xs) {

6+ return xs[0];

7+ }

8+ """ :: forall a. [a] -> a

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.pursnew file+13

@@ -0,0 +1,13 @@

1+module Main where

3+foreign import foo

4+ """

5+ function foo(s) {

6+ return s;

7+ }

8+ """ :: String -> String

10+bar :: String -> String

11+bar _ = foo "test"

12+

13+main = Debug.Trace.trace "Done"

examples/passing/Fib.pursnew file+15

@@ -0,0 +1,15 @@

1+module Main where

3+import Prelude

4+import Control.Monad.Eff

5+import Control.Monad.ST

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.pursnew file+22

@@ -0,0 +1,22 @@

1+module Main where

3+import Prelude

5+class E e where

6+ num :: Number -> e Number

7+ add :: e Number -> e Number -> e Number

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.pursnew file+20

@@ -0,0 +1,20 @@

1+module Main where

3+class Foo a where

4+ foo :: a -> String

6+foreign import instance fooArray :: (Foo a) => Foo [a]

8+foreign import instance fooNumber :: Foo Number

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.pursnew file+19

@@ -0,0 +1,19 @@

1+module Main where

3+ import Prelude

5+ mkValue :: Number -> Number

6+ mkValue id = id

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.pursnew file+15

@@ -0,0 +1,15 @@

1+module Main where

3+ import Prelude

5+ test1 = \_ -> 0

7+ test2 = \a b -> a + b + 1

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.pursnew file+19

@@ -0,0 +1,19 @@

1+module Main where

3+ import Prelude

5+ test :: forall a b. a -> b -> a

6+ test = \const _ -> const

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.pursnew file+29

@@ -0,0 +1,29 @@

1+module Main where

3+ import Prelude

5+ collatz = \x -> case x of

6+ y | y % 2 == 0 -> y / 2

7+ y -> y * 3 + 1

9+ -- Guards have access to current scope

10+ collatz2 = \x y -> case x of

11+ z | y > 0 -> z / 2

12+ z -> z * 3 + 1

13+

14+ min :: forall a. (Ord a) => a -> a -> a

15+ min n m | n < m = n

16+ | otherwise = m

17+

18+ max :: forall a. (Ord a) => a -> a -> a

19+ max n m = case unit of

20+ _ | m < n -> n

21+ | otherwise -> m

22+

23+ testIndentation :: Number -> Number -> Number

24+ testIndentation x y | x > 0

25+ = x + y

26+ | otherwise

27+ = y - x

28+

29+ main = Debug.Trace.trace $ min "Done" "ZZZZ"

examples/passing/HoistError.pursnew file+19

@@ -0,0 +1,19 @@

1+module Main where

3+import Control.Monad.Eff

4+import Debug.Trace

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.pursnew file+9

@@ -0,0 +1,9 @@

1+module Main where

3+data Maybe a = Nothing | Just a

5+test1 = if true then Just 10 else Nothing

7+test2 = if true then Nothing else Just 10

9+main = Debug.Trace.trace "Done"

examples/passing/ImplicitEmptyImport.pursnew file+6

@@ -0,0 +1,6 @@

1+module Main where

3+main = do

4+ Debug.Trace.trace "Hello"

5+ Debug.Trace.trace "Goodbye"

6+ Debug.Trace.trace "Done"

examples/passing/ImportHiding.pursnew file+18

@@ -0,0 +1,18 @@

1+module Main where

3+import Debug.Trace

4+import Prelude hiding (

5+ show, -- a value

6+ Show, -- a type class

7+ Unit(..) -- a constructor

8+ )

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.pursnew file+8

@@ -0,0 +1,8 @@

1+module Main where

3+import Prelude

5+test 100 = 100

6+test n = test(1 + n)

8+main = Debug.Trace.print $ test 0

examples/passing/InstanceBeforeClass.pursnew file+9

@@ -0,0 +1,9 @@

1+module Main where

3+instance fooNumber :: Foo Number where

4+ foo = 0

6+class Foo a where

7+ foo :: a

9+main = Debug.Trace.trace "Done"

examples/passing/JSReserved.pursnew file+12

@@ -0,0 +1,12 @@

1+module Main where

3+ import Prelude

5+ yield = 0

6+ member = 1

8+ public = \return -> return

10+ this catch = catch

11+

12+ main = Debug.Trace.trace "Done"

examples/passing/KindedType.pursnew file+31

@@ -0,0 +1,31 @@

1+module Main where

3+type Star2Star f = f :: * -> *

5+type Star t = t :: *

7+test1 :: Star2Star [] String

8+test1 = ["test"]

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.pursnew file+64

@@ -0,0 +1,64 @@

1+module Main where

3+import Prelude

4+import Control.Monad.Eff

5+import Control.Monad.ST

7+test1 x = let

8+ y :: Number

9+ y = x + 1

10+ in y

11+

12+test2 x y =

13+ let x' = x + 1 in

14+ let y' = y + 1 in

15+ x' + y'

16+

17+test3 = let f x y z = x + y + z in

18+ f 1 2 3

19+

20+test4 = let f x [y, z] = x y z in

21+ f (+) [1, 2]

22+

23+test5 = let

24+ f x | x > 0 = g (x / 2) + 1

25+ f x = 0

26+ g x = f (x - 1) + 1

27+ in f 10

28+

29+test6 = runPure (runST (do

30+ r <- newSTRef 0

31+ (let

32+ go [] = readSTRef r

33+ go (n : ns) = do

34+ modifySTRef r ((+) n)

35+ go ns

36+ in go [1, 2, 3, 4, 5])

37+ ))

38+

39+test7 = let

40+ f :: forall a. a -> a

41+ f x = x

42+ in if f true then f 1 else f 2

43+

44+test8 :: Number -> Number

45+test8 x = let

46+ go y | (x - 0.1 < y * y) && (y * y < x + 0.1) = y

47+ go y = go $ (y + x / y) / 2

48+ in go x

49+

50+test10 _ =

51+ let

52+ f x = g x * 3

53+ g x = f x / 2

54+ in f 10

55+

56+main = do

57+ Debug.Trace.print (test1 1)

58+ Debug.Trace.print (test2 1 2)

59+ Debug.Trace.print test3

60+ Debug.Trace.print test4

61+ Debug.Trace.print test5

62+ Debug.Trace.print test6

63+ Debug.Trace.print test7

64+ Debug.Trace.print (test8 100)

examples/passing/LetInInstance.pursnew file+12

@@ -0,0 +1,12 @@

1+module Main where

3+class Foo a where

4+ foo :: a -> String

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.pursnew file+19

@@ -0,0 +1,19 @@

1+module Main where

3+type Reader = (->) String

5+foo :: Reader String

6+foo s = s

8+type AndFoo r = (foo :: String | r)

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.pursnew file+20

@@ -0,0 +1,20 @@

1+module Main where

3+import Prelude

5+class NullaryTypeClass where

6+ greeting :: String

8+instance nullaryTypeClass :: NullaryTypeClass where

9+ greeting = "Hello, World!"

10+

11+class Coerce a b where

12+ coerce :: a -> b

13+

14+instance coerceRefl :: Coerce a a where

15+ coerce a = a

16+

17+instance coerceShow :: (Prelude.Show a) => Coerce a String where

18+ coerce = show

19+

20+main = Debug.Trace.trace "Done"

examples/passing/Match.pursnew file+7

@@ -0,0 +1,7 @@

1+module Main where

3+ data Foo a = Foo

5+ foo = \f -> case f of Foo -> "foo"

7+ main = Debug.Trace.trace "Done"

examples/passing/Monad.pursnew file+32

@@ -0,0 +1,32 @@

1+module Main where

3+ import Prelude ()

5+ type Monad m = { return :: forall a. a -> m a

6+ , bind :: forall a b. m a -> (a -> m b) -> m b }

8+ data Id a = Id a

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.pursnew file+48

@@ -0,0 +1,48 @@

1+module Main where

3+import Prelude

5+data Tuple a b = Tuple a b

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.pursnew file+26

@@ -0,0 +1,26 @@

1+module Main where

3+import Data.Function

4+import Control.Monad.Eff

5+import Debug.Trace

7+f = mkFn2 $ \a b -> runFn2 g a b + runFn2 g b a

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.pursnew file+21

@@ -0,0 +1,21 @@

1+module Main where

3+import Prelude

4+import Control.Monad.Eff

6+data P a b = P a b

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.pursnew file+19

@@ -0,0 +1,19 @@

1+module Main where

3+ import Prelude

5+ f 0 = 0

6+ f x = g x + 1

8+ g x = f (x / 2)

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.pursnew file+17

@@ -0,0 +1,17 @@

1+module Main where

3+data A = A B

5+data B = B A

7+foreign import data S :: *

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.pursnew file+17

@@ -0,0 +1,17 @@

1+module Main where

3+data A = A B

5+data B = B A

7+foreign import data S :: *

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.pursnew file+7

@@ -0,0 +1,7 @@

1+module Main where

3+ foo = \x -> case x of

4+ y@{ foo = "Foo" } -> y

5+ y -> y

7+ main = Debug.Trace.trace "Done"

examples/passing/NegativeBinder.pursnew file+7

@@ -0,0 +1,7 @@

1+module Main where

3+test :: Number -> Boolean

4+test -1 = false

5+test _ = true

7+main = Debug.Trace.trace "Done"

examples/passing/Nested.pursnew file+7

@@ -0,0 +1,7 @@

1+module Main where

3+ data Extend r a = Extend { prev :: r a, next :: a }

5+ data Matrix r a = Square (r (r a)) | Bigger (Matrix (Extend r) a)

7+ main = Debug.Trace.trace "Done"

examples/passing/NestedTypeSynonyms.pursnew file+11

@@ -0,0 +1,11 @@

1+module Main where

3+ import Prelude

5+ type X = String

6+ type Y = X -> X

8+ fn :: Y

9+ fn a = a

10+

11+ main = Debug.Trace.print (fn "Done")

examples/passing/NestedWhere.pursnew file+10

@@ -0,0 +1,10 @@

1+module Main where

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

10+main = Debug.Trace.trace "Done"

examples/passing/Newtype.pursnew file+22

@@ -0,0 +1,22 @@

1+module Main where

3+import Control.Monad.Eff

4+import Debug.Trace

6+newtype Thing = Thing String

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.pursnew file+28

@@ -0,0 +1,28 @@

1+module Main where

3+import Debug.Trace

4+import Control.Monad.Eff

6+newtype T a = T (Eff (trace :: Trace) a)

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.pursnew file+15

@@ -0,0 +1,15 @@

1+-- https://github.com/purescript/purescript/issues/812

3+module Main where

5+import Debug.Trace

7+newtype NewType a = NewType (Object a)

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.pursnew file+11

@@ -0,0 +1,11 @@

1+module Main where

3+getX = _.x

5+point = { x: 1, y: 0 }

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.pursnew file+13

@@ -0,0 +1,13 @@

1+module Main where

3+type Inner = Number

5+inner :: Inner

6+inner = 0

8+type Outer = { inner :: Inner }

10+outer :: Outer

11+outer = { inner: inner }

12+

13+main = Debug.Trace.trace "Done"

examples/passing/ObjectUpdate.pursnew file+18

@@ -0,0 +1,18 @@

1+module Main where

3+ update1 = \o -> o { foo = "Foo" }

5+ update2 :: forall r. { foo :: String | r } -> { foo :: String | r }

6+ update2 = \o -> o { foo = "Foo" }

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.pursnew file+14

@@ -0,0 +1,14 @@

1+module Main where

3+type X r = { | r }

5+foreign import x "var x = {};" :: forall r. X r

7+blah :: forall r. X r -> X r

8+blah x = x

10+test = blah x

11+ { baz = "blah"

12+ }

13+

14+main = Debug.Trace.trace "Done"

examples/passing/ObjectUpdater.pursnew file+35

@@ -0,0 +1,35 @@

1+module Main where

3+import Control.Monad.Eff

4+import Debug.Trace

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.pursnew file+31

@@ -0,0 +1,31 @@

1+module Main where

3+import Control.Monad.Eff

4+import Debug.Trace

6+mkRecord = { foo: _, bar: _, baz: "baz" }

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.pursnew file+35

@@ -0,0 +1,35 @@

1+module Main where

3+ import Prelude

5+ test = \x -> x.foo + x.bar + 1

7+ append = \o -> { foo: o.foo, bar: 1 }

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.pursnew file+7

@@ -0,0 +1,7 @@

1+module Main where

3+data One a = One a

5+one' (One a) = a

7+main = Debug.Trace.trace "Done"

examples/passing/OperatorAssociativity.pursnew file+42

@@ -0,0 +1,42 @@

1+module Main where

3+import Control.Monad.Eff

4+import Debug.Trace

6+foreign import data Assert :: !

8+foreign import assert

9+ """

10+ function assert(x) {

11+ return function(desc) {

12+ return function() {

13+ if (!x) throw new Error('assertion (' + desc + ') failed');

14+ return {};

15+ };

16+ };

17+ }

18+ """ :: forall e. Boolean -> String -> Eff (assert :: Assert | e) Unit

19+

20+bug :: Number -> Number -> Number

21+bug a b = 0 - (a - b)

22+

23+foreign import explode

24+ """

25+ function explode() {

26+ throw new Error('Assertion failed!');

27+ }

28+ """ :: forall eff a. Eff eff a

29+

30+main = do

31+ assert (bug 0 2 == 2) "bug 0 2 == 2"

32+ assert (0 - (0 - 2) == 2) "0 - (0 - 2) == 2"

33+ assert (0 - (0 + 2) == -2) "0 - (0 + 2) == -2"

34+

35+ assert (6 / (3 * 2) == 1) "6 / (3 * 2) == 1"

36+ assert ((6 / 3) * 2 == 4) "(6 / 3) * 2 == 4"

37+

38+ assert (6 % (2 * 2) == 2) "6 % (2 * 2) == 2"

39+ assert ((6 % 2) * 2 == 0) "(6 % 2) * 2 == 0"

40+

41+ assert (4 % (9 / 3) == 1) "4 % (9 / 3) == 1"

42+ assert ((4 % 9) / 2 == 2) "(4 % 9) / 2 == 2"

examples/passing/OperatorSections.pursnew file+21

@@ -0,0 +1,21 @@

1+module Main where

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.pursnew file+102

@@ -0,0 +1,102 @@

1+module Main where

3+ import Control.Monad.Eff

4+ import Debug.Trace

6+ (?!) :: forall a. a -> a -> a

7+ (?!) x _ = x

9+ bar :: String -> String -> String

10+ bar = \s1 s2 -> s1 ++ s2

11+

12+ test1 :: forall n. (Num n) => n -> n -> (n -> n -> n) -> n

13+ test1 x y z = x * y + z x y

14+

15+ test2 = (\x -> x.foo false) { foo : \_ -> 1 }

16+

17+ test3 = (\x y -> x)(1 + 2 * (1 + 2)) (true && (false || false))

18+

19+ k = \x -> \y -> x

20+

21+ test4 = 1 `k` 2

22+

23+ infixl 5 %%

24+

25+ (%%) :: Number -> Number -> Number

26+ (%%) x y = x * y + y

27+

28+ test5 = 1 %% 2 %% 3

29+

30+ test6 = ((\x -> x) `k` 2) 3

31+

32+ (<+>) :: String -> String -> String

33+ (<+>) = \s1 s2 -> s1 ++ s2

34+

35+ test7 = "Hello" <+> "World!"

36+

37+ (@@) :: forall a b. (a -> b) -> a -> b

38+ (@@) = \f x -> f x

39+

40+ foo :: String -> String

41+ foo = \s -> s

42+

43+ test8 = foo @@ "Hello World"

44+

45+ test9 = Main.foo @@ "Hello World"

46+

47+ test10 = "Hello" `Main.bar` "World"

48+

49+ (...) :: forall a. [a] -> [a] -> [a]

50+ (...) = \as -> \bs -> as

51+

52+ test11 = [1, 2, 3] ... [4, 5, 6]

53+

54+ test12 (<%>) a b = a <%> b

55+

56+ test13 = \(<%>) a b -> a <%> b

57+

58+ test14 :: Number -> Number -> Boolean

59+ test14 a b = a < b

60+

61+ test15 :: Number -> Number -> Boolean

62+ test15 a b = const false $ a `test14` b

63+

64+ test16 :: Number -> Number -> Number

65+ test16 x y = x .|. y .&. y

66+

67+ test17 :: Number

68+ test17 = negate (-1)

69+

70+ test18 :: Number

71+ test18 = negate $ negate 1

72+

73+ test19 :: Number

74+ test19 = negate $ negate (-1)

75+

76+ test20 :: Number

77+ test20 = 1 @ 2

78+ where

79+ (@) x y = x + y * y

80+

81+ main = do

82+ let t1 = test1 1 2 (\x y -> x + y)

83+ let t2 = test2

84+ let t3 = test3

85+ let t4 = test4

86+ let t5 = test5

87+ let t6 = test6

88+ let t7 = test7

89+ let t8 = test8

90+ let t9 = test9

91+ let t10 = test10

92+ let t11 = test11

93+ let t12 = test12 k 1 2

94+ let t13 = test13 k 1 2

95+ let t14 = test14 1 2

96+ let t15 = test15 1 2

97+ let t16 = test16 1 2

98+ let t17 = test17

99+ let t18 = test18

100+ let t19 = test19

101+ let t20 = test20

102+ trace "Done"

examples/passing/OptimizerBug.pursnew file+9

@@ -0,0 +1,9 @@

1+module Main where

3+import Prelude

5+x a = 1 + y a

7+y a = x a

9+main = Debug.Trace.trace "Done"

examples/passing/PartialFunction.pursnew file+19

@@ -0,0 +1,19 @@

1+module Main where

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.pursnew file+28

@@ -0,0 +1,28 @@

1+module Main where

3+ import Prelude

5+ test = \x -> case x of

6+ { str = "Foo", bool = true } -> true

7+ { str = "Bar", bool = b } -> b

8+ _ -> false

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.pursnew file+18

@@ -0,0 +1,18 @@

1+module Main where

3+ import Prelude ((++))

5+ data Person = Person { name :: String, age :: Number }

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.pursnew file+29

@@ -0,0 +1,29 @@

1+module Main where

3+ import Prelude

5+ data Id = Id forall a. a -> a

7+ runId = \id a -> case id of

8+ Id f -> f a

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.pursnew file+10

@@ -0,0 +1,10 @@

1+module Main where

3+import Debug.Trace

5+data Foo = Foo { id :: forall a. a -> a }

7+foo :: Foo -> Number

8+foo (Foo { id = f }) = f 0

10+main = trace "Done"

examples/passing/Rank2TypeSynonym.pursnew file+15

@@ -0,0 +1,15 @@

1+module Main where

3+import Control.Monad.Eff

5+type Foo a = forall f. (Monad f) => f a

7+foo :: forall a. a -> Foo a

8+foo x = pure x

10+bar :: Foo Number

11+bar = foo 3

12+

13+main = do

14+ x <- bar

15+ Debug.Trace.print x

examples/passing/Rank2Types.pursnew file+11

@@ -0,0 +1,11 @@

1+module Main where

3+ import Prelude

5+ test1 :: (forall a. (a -> a)) -> Number

6+ test1 = \f -> f 0

8+ forever :: forall m a b. (forall a b. m a -> (a -> m b) -> m b) -> m a -> m b

9+ forever = \bind action -> bind action $ \_ -> forever bind action

10+

11+ main = Debug.Trace.trace "Done"

examples/passing/Recursion.pursnew file+10

@@ -0,0 +1,10 @@

1+module Main where

3+ import Prelude

5+ fib = \n -> case n of

6+ 0 -> 1

7+ 1 -> 1

8+ n -> fib (n - 1) + fib (n - 2)

10+ main = Debug.Trace.trace "Done"

examples/passing/ReservedWords.pursnew file+13

@@ -0,0 +1,13 @@

1+-- See https://github.com/purescript/purescript/issues/606

2+module Main where

4+ o :: { type :: String }

5+ o = { type: "o" }

7+ p :: { type :: String }

8+ p = o { type = "p" }

10+ f :: forall r. { type :: String | r } -> String

11+ f { type = "p" } = "Done"

12+

13+ main = Debug.Trace.trace $ f { type: p.type, foo: "bar" }

examples/passing/RowPolyInstanceContext.pursnew file+20

@@ -0,0 +1,20 @@

1+module Main where

3+class T s m where

4+ state :: (s -> s) -> m Unit

6+data S s a = S (s -> { new :: s, ret :: a })

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.pursnew file+46

@@ -0,0 +1,46 @@

1+module Main where

3+import Control.Monad.Eff

4+import Control.Monad.ST

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.pursnew file+19

@@ -0,0 +1,19 @@

1+module Main where

3+import Prelude

5+class A a where

6+ a :: a -> Boolean

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.pursnew file+34

@@ -0,0 +1,34 @@

1+module Main where

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)

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.pursnew file+12

@@ -0,0 +1,12 @@

1+module Main where

3+import Control.Monad.Eff

5+class Sequence t where

6+ sequence :: forall m a. (Monad m) => t (m a) -> m (t a)

8+instance sequenceArray :: Sequence [] where

9+ sequence [] = pure []

10+ sequence (x:xs) = (:) <$> x <*> sequence xs

11+

12+main = sequence $ [Debug.Trace.trace "Done"]

examples/passing/ShadowedRename.pursnew file+21

@@ -0,0 +1,21 @@

1+module Main where

3+import Control.Monad.Eff

4+import Debug.Trace

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.pursnew file+16

@@ -0,0 +1,16 @@

1+module Main where

3+runNat f = f 0 (\n -> n + 1)

5+zero' z _ = z

7+succ f zero' succ = succ (f zero' succ)

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.pursnew file+7

@@ -0,0 +1,7 @@

1+module Main where

3+f x y z =

4+ let f 1 2 3 = 1

5+ in f x z y

7+main = Debug.Trace.trace $ show $ f 1 3 2

examples/passing/SignedNumericLiterals.pursnew file+15

@@ -0,0 +1,15 @@

1+module Main where

3+ p = 0.5

4+ q = 1

5+ x = -1

6+ y = -0.5

7+ z = 0.5

8+ w = 1

10+ f :: Number -> Number

11+ f x = -x

12+

13+ test1 = 2 - 1

14+

15+ main = Debug.Trace.trace "Done"

examples/passing/Superclasses1.pursnew file+18

@@ -0,0 +1,18 @@

1+module Main where

3+class Su a where

4+ su :: a -> a

6+class (Su a) <= Cl a where

7+ cl :: a -> a -> a

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.pursnew file+23

@@ -0,0 +1,23 @@

1+module Main where

3+import Prelude.Unsafe (unsafeIndex)

5+class Su a where

6+ su :: a -> a

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.pursnew file+41

@@ -0,0 +1,41 @@

1+module Main where

3+import Debug.Trace

5+import Control.Monad.Eff

7+class (Monad m) <= MonadWriter w m where

8+ tell :: w -> m Unit

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.pursnew file+10

@@ -0,0 +1,10 @@

1+module Main where

3+data Data = One | More Data

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.pursnew file+15

@@ -0,0 +1,15 @@

1+module Main where

3+import Prelude

5+test :: Number -> [Number] -> Number

6+test n [] = n

7+test n (x:xs) = test (n + x) xs

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.pursnew file+5

@@ -0,0 +1,5 @@

1+module Main where

3+test' x = x

5+main = Debug.Trace.trace "Done"

examples/passing/TopLevelCase.pursnew file+18

@@ -0,0 +1,18 @@

1+module Main where

3+ import Prelude

5+ gcd :: Number -> Number -> Number

6+ gcd 0 x = x

7+ gcd x 0 = x

8+ gcd x y | x > y = gcd (x % y) y

9+ gcd x y = gcd (y % x) x

10+

11+ guardsTest (x:xs) | x > 0 = guardsTest xs

12+ guardsTest xs = xs

13+

14+ data A = A

15+

16+ parseTest A 0 = 0

17+

18+ main = Debug.Trace.trace "Done"

examples/passing/TypeClassImport.pursnew file+18

@@ -0,0 +1,18 @@

1+module Main where

3+foreign import data T :: *

5+foreign import data C :: *

7+foreign import t "var t = null;" :: T

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.pursnew file+11

@@ -0,0 +1,11 @@

1+module Main where

3+class Test a where

4+ fn :: a -> a -> a

5+ val :: a

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.pursnew file+69

@@ -0,0 +1,69 @@

1+module Main where

3+import Prelude

5+test1 = \_ -> show "testing"

7+f :: forall a. (Prelude.Show a) => a -> String

8+f x = show x

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.pursnew file+11

@@ -0,0 +1,11 @@

1+module Main where

3+import Prelude

5+class Foo a where

6+ foo :: a -> String

8+instance fooString :: Foo String where

9+ foo s = s

10+

11+main = Debug.Trace.trace $ foo "Done"

examples/passing/TypeClassesWithOverlappingTypeVariables.pursnew file+11

@@ -0,0 +1,11 @@

1+module Main where

3+ import Prelude

5+ data Either a b = Left a | Right b

7+ instance functorEither :: Prelude.Functor (Either a) where

8+ (<$>) _ (Left x) = Left x

9+ (<$>) f (Right y) = Right (f y)

10+

11+ main = Debug.Trace.trace "Done"

examples/passing/TypeDecl.pursnew file+12

@@ -0,0 +1,12 @@

1+module Main where

3+ import Prelude

5+ k :: String -> Number -> String

6+ k x y = x

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.pursnew file+9

@@ -0,0 +1,9 @@

1+module Main where

3+type A a = [a]

5+data Foo a = Foo (A a) | Bar

7+foo (Foo []) = Bar

9+main = Debug.Trace.trace "Done"

examples/passing/TypeSynonyms.pursnew file+25

@@ -0,0 +1,25 @@

1+module Main where

3+ type Lens a b =

4+ { get :: a -> b

5+ , set :: a -> b -> a

6+ }

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.pursnew file+13

@@ -0,0 +1,13 @@

1+module Main where

3+testTopLevel :: _ -> _

4+testTopLevel n = n + 1

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.pursnew file+6

@@ -0,0 +1,6 @@

1+module Main where

3+foo :: forall a. {b :: Number | a} -> {b :: Number | _}

4+foo f = f

6+main = Debug.Trace.trace "Done"

examples/passing/TypedWhere.pursnew file+13

@@ -0,0 +1,13 @@

1+module Main where

3+data E a b = L a | R b

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.pursnew file+9

@@ -0,0 +1,9 @@

1+module Main where

3+data Data_type = Con_Structor | Con_2 String

5+type Type_name = Data_type

7+done (Con_2 s) = s

9+main = Debug.Trace.trace (done (Con_2 "Done"))

examples/passing/Unit.pursnew file+6

@@ -0,0 +1,6 @@

1+module Main where

3+import Prelude

4+import Debug.Trace

6+main = print (const unit $ "Hello world")

examples/passing/UnknownInTypeClassLookup.pursnew file+12

@@ -0,0 +1,12 @@

1+module Main where

3+class EQ a b

5+instance eqAA :: EQ a a

7+test :: forall a b. (EQ a b) => a -> b -> String

8+test _ _ = "Done"

10+runTest a = test a a

11+

12+main = Debug.Trace.trace $ runTest 0

examples/passing/Where.pursnew file+49

@@ -0,0 +1,49 @@

1+module Main where

3+import Prelude

4+import Control.Monad.Eff

5+import Control.Monad.ST

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.pursnew file+9

@@ -0,0 +1,9 @@

1+module Main where

3+ s = \x -> \y -> \z -> x z (y z)

5+ k = \x -> \y -> x

7+ iota = \x -> x s k

9+ main = Debug.Trace.trace "Done"

examples/passing/s.pursnew file+5

@@ -0,0 +1,5 @@

1+module Main where

3+ s = \x y z -> x z (y z)

5+ main = Debug.Trace.trace "Done"

hierarchy/Main.hsnew file+113

@@ -0,0 +1,113 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : Main

4+-- Copyright : (c) Hardy Jones 2014

5+-- License : MIT

6+--

7+-- Maintainer : Hardy Jones <jones3.hardy@gmail.com>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- |

12+-- Generate Directed Graphs of PureScript TypeClasses

13+--

14+-----------------------------------------------------------------------------

15+

16+module Main where

17+

18+import Control.Monad (unless)

19+

20+import Data.List (intercalate,nub,sort)

21+import Data.Foldable (for_)

22+import Data.Version (showVersion)

23+

24+import Options.Applicative

25+import System.Directory (createDirectoryIfMissing)

26+import System.FilePath ((</>))

27+import System.Exit (exitFailure, exitSuccess)

28+import System.IO (hPutStr, stderr)

29+

30+import Text.Parsec as Par (ParseError)

31+

32+import qualified Language.PureScript as P

33+import qualified Paths_purescript as Paths

34+

35+

36+data HierarchyOptions = HierarchyOptions

37+ { hierachyInput :: FilePath

38+ , hierarchyOutput :: Maybe FilePath

39+ }

40+

41+newtype SuperMap = SuperMap { unSuperMap :: Either P.ProperName (P.ProperName, P.ProperName) }

42+ deriving Eq

43+

44+instance Show SuperMap where

45+ show (SuperMap (Left sub)) = show sub

46+ show (SuperMap (Right (super, sub))) = show super ++ " -> " ++ show sub

47+

48+instance Ord SuperMap where

49+ compare (SuperMap s) (SuperMap s') = getCls s `compare` getCls s'

50+ where

51+ getCls = either id snd

52+

53+runModuleName :: P.ModuleName -> String

54+runModuleName (P.ModuleName pns) = intercalate "_" (P.runProperName `map` pns)

55+

56+readInput :: FilePath -> IO (Either Par.ParseError [P.Module])

57+readInput filename = do

58+ content <- readFile filename

59+ return $ fmap (map snd) $ P.parseModulesFromFiles id [(filename, content)]

60+

61+compile :: HierarchyOptions -> IO ()

62+compile (HierarchyOptions input mOutput) = do

63+ modules <- readInput input

64+ case modules of

65+ Left err -> hPutStr stderr (show err) >> exitFailure

66+ Right ms -> do

67+ for_ ms $ \(P.Module _ moduleName decls _) ->

68+ let name = runModuleName moduleName

69+ tcs = filter P.isTypeClassDeclaration decls

70+ supers = sort . nub . filter (not . null) $ fmap superClasses tcs

71+ prologue = "digraph " ++ name ++ " {\n"

72+ body = intercalate "\n" (concatMap (fmap (\s -> " " ++ show s ++ ";")) supers)

73+ epilogue = "\n}"

74+ hier = prologue ++ body ++ epilogue

75+ in unless (null supers) $ case mOutput of

76+ Just output -> do

77+ createDirectoryIfMissing True output

78+ writeFile (output </> name) hier

79+ Nothing -> putStrLn hier

80+ exitSuccess

81+

82+superClasses :: P.Declaration -> [SuperMap]

83+superClasses (P.TypeClassDeclaration sub _ supers@(_:_) _) =

84+ fmap (\(P.Qualified _ super, _) -> SuperMap (Right (super, sub))) supers

85+superClasses (P.TypeClassDeclaration sub _ _ _) = [SuperMap (Left sub)]

86+superClasses (P.PositionedDeclaration _ _ decl) = superClasses decl

87+superClasses _ = []

88+

89+inputFile :: Parser FilePath

90+inputFile = strArgument $

91+ metavar "FILE"

92+ <> value "main.purs"

93+ <> showDefault

94+ <> help "The input file to generate a hierarchy from"

95+

96+outputFile :: Parser (Maybe FilePath)

97+outputFile = optional . strOption $

98+ short 'o'

99+ <> long "output"

100+ <> help "The output directory"

101+

102+pscOptions :: Parser HierarchyOptions

103+pscOptions = HierarchyOptions <$> inputFile

104+ <*> outputFile

105+

106+main :: IO ()

107+main = execParser opts >>= compile

108+ where

109+ opts = info (helper <*> pscOptions) infoModList

110+ infoModList = fullDesc <> headerInfo <> footerInfo

111+ headerInfo = header "hierarchy - Creates a GraphViz directed graph of PureScript TypeClasses"

112+ footerInfo = footer $ "hierarchy " ++ showVersion Paths.version

113+

package.yamldeleted−86

@@ -1,86 +0,0 @@

1−name: psgo

2−version: 0.1.0.0

3−github: "andyarvanitis/purescript-native"

4−license: BSD3

5−author: "Andy Arvanitis"

6−maintainer: "example@example.com"

7−copyright: "2018 Andy Arvanitis"

8−

9−extra-source-files:

10−- README.md

11−- ChangeLog.md

12−- stack.yaml

13−- support/*

14−

15−# Metadata used when publishing your package

16−# synopsis: Short description of your package

17−# category: Web

18−

19−# To avoid duplicated efforts in documentation and dealing with the

20−# complications of embedding Haddock markup inside cabal files, it is

21−# common to point users to the README.md file.

22−description: Please see the README on Github at <https://github.com/andyarvanitis/purescript-native#readme>

23−

24−dependencies:

25−- base >= 4.7 && < 5

26−- bytestring >= 0.10.8.2 && < 0.11

27−- purescript

28−- base-compat >=0.6.0

29−- protolude >=0.1.6

30−- text

31−- containers

32−- filepath

33−- monad-parallel >= 0.7.2.2 && <0.8

34−- pattern-arrows >=0.0.2 && <0.1

35−- safe >=0.3.9 && <0.4

36−- transformers >=0.3.0 && <0.6

37−- mtl >=2.1.0 && <2.3.0

38−- aeson >=1.0 && <1.5

39−- directory

40−- process

41−- file-embed

42−- filemanip

43−- gitrev

44−

45−library:

46− source-dirs: src

47− default-extensions:

48− - ConstraintKinds

49− - DataKinds

50− - DeriveFunctor

51− - EmptyDataDecls

52− - FlexibleContexts

53− - KindSignatures

54− - LambdaCase

55− - MultiParamTypeClasses

56− - NoImplicitPrelude

57− - PatternGuards

58− - PatternSynonyms

59− - RankNTypes

60− - RecordWildCards

61− - OverloadedStrings

62− - ScopedTypeVariables

63− - TupleSections

64− - ViewPatterns

65−

66−executables:

67− psgo:

68− main: Main.hs

69− source-dirs: app

70− ghc-options:

71− - -threaded

72− - -rtsopts

73− - -with-rtsopts=-N

74− dependencies:

75− - psgo

76−

77−tests:

78− psgo-test:

79− main: Spec.hs

80− source-dirs: test

81− ghc-options:

82− - -threaded

83− - -rtsopts

84− - -with-rtsopts=-N

85− dependencies:

86− - psgo

prelude/README.mdnew file+1183

@@ -0,0 +1,1183 @@

1+# Module Documentation

3+## Module Prelude

7+#### `otherwise`

9+``` purescript

10+otherwise :: Boolean

11+```

12+

13+An alias for `true`, which can be useful in guard clauses:

14+

15+E.g.

16+

17+ max x y | x >= y = x

18+ | otherwise = y

19+

20+#### `flip`

21+

22+``` purescript

23+flip :: forall a b c. (a -> b -> c) -> b -> a -> c

24+```

25+

26+Flips the order of the arguments to a function of two arguments.

27+

28+E.g.

29+

30+ flip const 1 2 = const 2 1 = 2

31+

32+

33+#### `const`

34+

35+``` purescript

36+const :: forall a b. a -> b -> a

37+```

38+

39+Returns its first argument and ignores its second.

40+

41+E.g.

42+

43+ const 1 2 = 1

44+

45+

46+#### `asTypeOf`

47+

48+``` purescript

49+asTypeOf :: forall a. a -> a -> a

50+```

51+

52+This function returns its first argument, and can be used to assert type equalities.

53+This can be useful when types are otherwise ambiguous.

54+

55+E.g.

56+

57+ main = print $ [] `asTypeOf` [0]

58+

59+If instead, we had written `main = print []`, the type of the argument `[]` would have

60+been ambiguous, resulting in a compile-time error.

61+

62+#### `Semigroupoid`

63+

64+``` purescript

65+class Semigroupoid a where

66+ (<<<) :: forall b c d. a c d -> a b c -> a b d

67+```

68+

69+A `Semigroupoid` is similar to a [`Category`](#category) but does not require an identity

70+element `id`, just composable morphisms.

71+

72+`Semigroupoid`s should obey the following rule:

73+

74+Association:

75+ `forall p q r. p <<< (q <<< r) = (p <<< q) <<< r`

76+

77+

78+#### `semigroupoidArr`

79+

80+``` purescript

81+instance semigroupoidArr :: Semigroupoid Prim.Function

82+```

83+

84+

85+#### `(>>>)`

86+

87+``` purescript

88+(>>>) :: forall a b c d. (Semigroupoid a) => a b c -> a c d -> a b d

89+```

90+

91+

92+#### `Category`

93+

94+``` purescript

95+class (Semigroupoid a) <= Category a where

96+ id :: forall t. a t t

97+```

98+

99+`Category`s consist of objects and composable morphisms between them, and as such are

100+[`Semigroupoids`](#semigroupoid), but unlike `semigroupoids` must have an identity element.

101+

102+`Category`s should obey the following rules.

103+

104+Left Identity:

105+ `forall p. id <<< p = p`

106+

107+Right Identity:

108+ `forall p. p <<< id = p`

109+

110+

111+#### `categoryArr`

112+

113+``` purescript

114+instance categoryArr :: Category Prim.Function

115+```

116+

117+

118+#### `($)`

119+

120+``` purescript

121+($) :: forall a b. (a -> b) -> a -> b

122+```

123+

124+Applies a function to its argument

125+

126+E.g.

127+

128+ const $ 1 2 = const 1 2 = 1

129+

130+`($)` is different from [`(#)`](#-2) because it is right-infix instance instead of left.

131+Right-infix operators parse like (a $ (b $ (c $ (d ...)))) whereas left-infix operators parse

132+like (((a # b) # c) # d ...).

133+

134+

135+#### `(#)`

136+

137+``` purescript

138+(#) :: forall a b. a -> (a -> b) -> b

139+```

140+

141+Applies a function to its argument

142+

143+E.g.

144+

145+ 3 # ((+) 1) = 3 + 1 = 4

146+

147+`(#)` is different from [`($)`](#-1) because it is left-infix instance instead of right.

148+Right-infix operators parse like (a $ (b $ (c $ (d ...)))) whereas left-infix operators parse

149+like (((a # b) # c) # d ...).

150+

151+

152+#### `(:)`

153+

154+``` purescript

155+(:) :: forall a. a -> [a] -> [a]

156+```

157+

158+Attaches an element to the front of a list.

159+

160+E.g.

161+

162+ 1 : [2, 3, 4] = [1, 2, 3, 4]

163+

164+

165+#### `cons`

166+

167+``` purescript

168+cons :: forall a. a -> [a] -> [a]

169+```

170+

171+

172+#### `Show`

173+

174+``` purescript

175+class Show a where

176+ show :: a -> String

177+```

178+

179+

180+#### `showUnit`

181+

182+``` purescript

183+instance showUnit :: Show Unit

184+```

185+

186+

187+#### `showString`

188+

189+``` purescript

190+instance showString :: Show String

191+```

192+

193+

194+#### `showBoolean`

195+

196+``` purescript

197+instance showBoolean :: Show Boolean

198+```

199+

200+

201+#### `showNumber`

202+

203+``` purescript

204+instance showNumber :: Show Number

205+```

206+

207+

208+#### `showArray`

209+

210+``` purescript

211+instance showArray :: (Show a) => Show [a]

212+```

213+

214+

215+#### `Functor`

216+

217+``` purescript

218+class Functor f where

219+ (<$>) :: forall a b. (a -> b) -> f a -> f b

220+```

221+

222+A `Functor` is intuitively a type which can be mapped over, and more formally a mapping

223+between [`Category`](#category)s that preserves structure.

224+

225+`Functor`s should obey the following rules.

226+

227+Identity:

228+ `(<$>) id = id`

229+

230+Composition:

231+ `forall f g. (<$>) (f . g) = ((<$>) f) . ((<$>) g)`

232+

233+

234+#### `(<#>)`

235+

236+``` purescript

237+(<#>) :: forall f a b. (Functor f) => f a -> (a -> b) -> f b

238+```

239+

240+

241+#### `void`

242+

243+``` purescript

244+void :: forall f a. (Functor f) => f a -> f Unit

245+```

246+

247+

248+#### `Apply`

249+

250+``` purescript

251+class (Functor f) <= Apply f where

252+ (<*>) :: forall a b. f (a -> b) -> f a -> f b

253+```

254+

255+`Apply`s are intuitively [`Applicative`](#applicative)s less `pure`, and more formally a

256+strong lax semi-monoidal endofunctor.

257+

258+`Apply`s should obey the following rules.

259+

260+Associative Composition:

261+ `forall f g h. (.) <$> f <*> g <*> h = f <*> (g <*> h)`

262+

263+

264+#### `Applicative`

265+

266+``` purescript

267+class (Apply f) <= Applicative f where

268+ pure :: forall a. a -> f a

269+```

270+

271+`Applicative`s are [`Functor`](#functor)s which can be "applied" by sequencing composition

272+(`<*>`) or embedding pure expressions (`pure`).

273+

274+`Applicative`s should obey the following rules.

275+

276+Identity:

277+ `forall v. (pure id) <*> v = v`

278+

279+Composition:

280+ `forall f g h. (pure (.)) <*> f <*> g <*> h = f <*> (g <*> h)`

281+

282+Homomorphism:

283+ `forall f x. (pure f) <*> (pure x) = pure (f x)`

284+

285+Interchange:

286+ `forall u y. u <*> (pure y) = (pure (($) y)) <*> u`

287+

288+

289+#### `liftA1`

290+

291+``` purescript

292+liftA1 :: forall f a b. (Applicative f) => (a -> b) -> f a -> f b

293+```

294+

295+

296+#### `Bind`

297+

298+``` purescript

299+class (Apply m) <= Bind m where

300+ (>>=) :: forall a b. m a -> (a -> m b) -> m b

301+```

302+

303+A `Bind` is an [`Apply`](#apply) with a bind operation which sequentially composes actions.

304+

305+`Bind`s should obey the following rule.

306+

307+Associativity:

308+ `forall f g x. (x >>= f) >>= g = x >>= (\k => f k >>= g)`

309+

310+

311+#### `Monad`

312+

313+``` purescript

314+class (Applicative m, Bind m) <= Monad m where

315+```

316+

317+`Monad` is a class which can be intuitively thought of as an abstract datatype of actions or

318+more formally though of as a monoid in the category of endofunctors.

319+

320+`Monad`s should obey the following rules.

321+

322+Left Identity:

323+ `forall f x. pure x >>= f = f x`

324+

325+Right Identity:

326+ `forall x. x >>= pure = x`

327+

328+

329+#### `return`

330+

331+``` purescript

332+return :: forall m a. (Monad m) => a -> m a

333+```

334+

335+

336+#### `liftM1`

337+

338+``` purescript

339+liftM1 :: forall m a b. (Monad m) => (a -> b) -> m a -> m b

340+```

341+

342+

343+#### `ap`

344+

345+``` purescript

346+ap :: forall m a b. (Monad m) => m (a -> b) -> m a -> m b

347+```

348+

349+

350+#### `functorArr`

351+

352+``` purescript

353+instance functorArr :: Functor (Prim.Function r)

354+```

355+

356+

357+#### `applyArr`

358+

359+``` purescript

360+instance applyArr :: Apply (Prim.Function r)

361+```

362+

363+

364+#### `applicativeArr`

365+

366+``` purescript

367+instance applicativeArr :: Applicative (Prim.Function r)

368+```

369+

370+

371+#### `bindArr`

372+

373+``` purescript

374+instance bindArr :: Bind (Prim.Function r)

375+```

376+

377+

378+#### `monadArr`

379+

380+``` purescript

381+instance monadArr :: Monad (Prim.Function r)

382+```

383+

384+

385+#### `Semiring`

386+

387+``` purescript

388+class Semiring a where

389+ (+) :: a -> a -> a

390+ zero :: a

391+ (*) :: a -> a -> a

392+ one :: a

393+```

394+

395+Addition and multiplication

396+

397+#### `ModuloSemiring`

398+

399+``` purescript

400+class (Semiring a) <= ModuloSemiring a where

401+ (/) :: a -> a -> a

402+ mod :: a -> a -> a

403+```

404+

405+Semiring with modulo operation and division where

406+```a / b * b + (a `mod` b) = a```

407+

408+#### `Ring`

409+

410+``` purescript

411+class (Semiring a) <= Ring a where

412+ (-) :: a -> a -> a

413+```

414+

415+Addition, multiplication, and subtraction

416+

417+#### `negate`

418+

419+``` purescript

420+negate :: forall a. (Ring a) => a -> a

421+```

422+

423+

424+#### `DivisionRing`

425+

426+``` purescript

427+class (Ring a, ModuloSemiring a) <= DivisionRing a where

428+```

429+

430+Ring where every nonzero element has a multiplicative inverse (possibly

431+a non-commutative field) so that ```a `mod` b = zero```

432+

433+#### `Num`

434+

435+``` purescript

436+class (DivisionRing a) <= Num a where

437+```

438+

439+A commutative field

440+

441+#### `semiringNumber`

442+

443+``` purescript

444+instance semiringNumber :: Semiring Number

445+```

446+

447+

448+#### `ringNumber`

449+

450+``` purescript

451+instance ringNumber :: Ring Number

452+```

453+

454+

455+#### `moduloSemiringNumber`

456+

457+``` purescript

458+instance moduloSemiringNumber :: ModuloSemiring Number

459+```

460+

461+

462+#### `divisionRingNumber`

463+

464+``` purescript

465+instance divisionRingNumber :: DivisionRing Number

466+```

467+

468+

469+#### `numNumber`

470+

471+``` purescript

472+instance numNumber :: Num Number

473+```

474+

475+

476+#### `Unit`

477+

478+``` purescript

479+newtype Unit

480+ = Unit { }

481+```

482+

483+

484+#### `unit`

485+

486+``` purescript

487+unit :: Unit

488+```

489+

490+

491+#### `Eq`

492+

493+``` purescript

494+class Eq a where

495+ (==) :: a -> a -> Boolean

496+ (/=) :: a -> a -> Boolean

497+```

498+

499+

500+#### `refEq`

501+

502+``` purescript

503+refEq :: forall a. a -> a -> Boolean

504+```

505+

506+

507+#### `refIneq`

508+

509+``` purescript

510+refIneq :: forall a. a -> a -> Boolean

511+```

512+

513+

514+#### `eqUnit`

515+

516+``` purescript

517+instance eqUnit :: Eq Unit

518+```

519+

520+

521+#### `eqString`

522+

523+``` purescript

524+instance eqString :: Eq String

525+```

526+

527+

528+#### `eqNumber`

529+

530+``` purescript

531+instance eqNumber :: Eq Number

532+```

533+

534+

535+#### `eqBoolean`

536+

537+``` purescript

538+instance eqBoolean :: Eq Boolean

539+```

540+

541+

542+#### `eqArray`

543+

544+``` purescript

545+instance eqArray :: (Eq a) => Eq [a]

546+```

547+

548+

549+#### `Ordering`

550+

551+``` purescript

552+data Ordering

553+ = LT

554+ | GT

555+ | EQ

556+```

557+

558+

559+#### `eqOrdering`

560+

561+``` purescript

562+instance eqOrdering :: Eq Ordering

563+```

564+

565+

566+#### `showOrdering`

567+

568+``` purescript

569+instance showOrdering :: Show Ordering

570+```

571+

572+

573+#### `semigroupOrdening`

574+

575+``` purescript

576+instance semigroupOrdening :: Semigroup Ordering

577+```

578+

579+

580+#### `Ord`

581+

582+``` purescript

583+class (Eq a) <= Ord a where

584+ compare :: a -> a -> Ordering

585+```

586+

587+

588+#### `(<)`

589+

590+``` purescript

591+(<) :: forall a. (Ord a) => a -> a -> Boolean

592+```

593+

594+

595+#### `(>)`

596+

597+``` purescript

598+(>) :: forall a. (Ord a) => a -> a -> Boolean

599+```

600+

601+

602+#### `(<=)`

603+

604+``` purescript

605+(<=) :: forall a. (Ord a) => a -> a -> Boolean

606+```

607+

608+

609+#### `(>=)`

610+

611+``` purescript

612+(>=) :: forall a. (Ord a) => a -> a -> Boolean

613+```

614+

615+

616+#### `ordUnit`

617+

618+``` purescript

619+instance ordUnit :: Ord Unit

620+```

621+

622+

623+#### `ordBoolean`

624+

625+``` purescript

626+instance ordBoolean :: Ord Boolean

627+```

628+

629+

630+#### `ordNumber`

631+

632+``` purescript

633+instance ordNumber :: Ord Number

634+```

635+

636+

637+#### `ordString`

638+

639+``` purescript

640+instance ordString :: Ord String

641+```

642+

643+

644+#### `ordArray`

645+

646+``` purescript

647+instance ordArray :: (Ord a) => Ord [a]

648+```

649+

650+

651+#### `Bits`

652+

653+``` purescript

654+class Bits b where

655+ (.&.) :: b -> b -> b

656+ (.|.) :: b -> b -> b

657+ (.^.) :: b -> b -> b

658+ shl :: b -> Number -> b

659+ shr :: b -> Number -> b

660+ zshr :: b -> Number -> b

661+ complement :: b -> b

662+```

663+

664+

665+#### `bitsNumber`

666+

667+``` purescript

668+instance bitsNumber :: Bits Number

669+```

670+

671+

672+#### `BoolLike`

673+

674+``` purescript

675+class BoolLike b where

676+ (&&) :: b -> b -> b

677+ (||) :: b -> b -> b

678+ not :: b -> b

679+```

680+

681+

682+#### `boolLikeBoolean`

683+

684+``` purescript

685+instance boolLikeBoolean :: BoolLike Boolean

686+```

687+

688+

689+#### `Semigroup`

690+

691+``` purescript

692+class Semigroup a where

693+ (<>) :: a -> a -> a

694+```

695+

696+

697+#### `semigroupUnit`

698+

699+``` purescript

700+instance semigroupUnit :: Semigroup Unit

701+```

702+

703+

704+#### `semigroupString`

705+

706+``` purescript

707+instance semigroupString :: Semigroup String

708+```

709+

710+

711+#### `semigroupArr`

712+

713+``` purescript

714+instance semigroupArr :: (Semigroup s') => Semigroup (s -> s')

715+```

716+

717+

718+#### `(++)`

719+

720+``` purescript

721+(++) :: forall s. (Semigroup s) => s -> s -> s

722+```

723+

724+

725+

726+## Module Data.Function

727+

728+

729+

730+#### `on`

731+

732+``` purescript

733+on :: forall a b c. (b -> b -> c) -> (a -> b) -> a -> a -> c

734+```

735+

736+

737+#### `Fn0`

738+

739+``` purescript

740+data Fn0 :: * -> *

741+```

742+

743+

744+#### `Fn1`

745+

746+``` purescript

747+data Fn1 :: * -> * -> *

748+```

749+

750+

751+#### `Fn2`

752+

753+``` purescript

754+data Fn2 :: * -> * -> * -> *

755+```

756+

757+

758+#### `Fn3`

759+

760+``` purescript

761+data Fn3 :: * -> * -> * -> * -> *

762+```

763+

764+

765+#### `Fn4`

766+

767+``` purescript

768+data Fn4 :: * -> * -> * -> * -> * -> *

769+```

770+

771+

772+#### `Fn5`

773+

774+``` purescript

775+data Fn5 :: * -> * -> * -> * -> * -> * -> *

776+```

777+

778+

779+#### `Fn6`

780+

781+``` purescript

782+data Fn6 :: * -> * -> * -> * -> * -> * -> * -> *

783+```

784+

785+

786+#### `Fn7`

787+

788+``` purescript

789+data Fn7 :: * -> * -> * -> * -> * -> * -> * -> * -> *

790+```

791+

792+

793+#### `Fn8`

794+

795+``` purescript

796+data Fn8 :: * -> * -> * -> * -> * -> * -> * -> * -> * -> *

797+```

798+

799+

800+#### `Fn9`

801+

802+``` purescript

803+data Fn9 :: * -> * -> * -> * -> * -> * -> * -> * -> * -> * -> *

804+```

805+

806+

807+#### `Fn10`

808+

809+``` purescript

810+data Fn10 :: * -> * -> * -> * -> * -> * -> * -> * -> * -> * -> * -> *

811+```

812+

813+

814+#### `mkFn0`

815+

816+``` purescript

817+mkFn0 :: forall a. (Unit -> a) -> Fn0 a

818+```

819+

820+

821+#### `mkFn1`

822+

823+``` purescript

824+mkFn1 :: forall a b. (a -> b) -> Fn1 a b

825+```

826+

827+

828+#### `mkFn2`

829+

830+``` purescript

831+mkFn2 :: forall a b c. (a -> b -> c) -> Fn2 a b c

832+```

833+

834+

835+#### `mkFn3`

836+

837+``` purescript

838+mkFn3 :: forall a b c d. (a -> b -> c -> d) -> Fn3 a b c d

839+```

840+

841+

842+#### `mkFn4`

843+

844+``` purescript

845+mkFn4 :: forall a b c d e. (a -> b -> c -> d -> e) -> Fn4 a b c d e

846+```

847+

848+

849+#### `mkFn5`

850+

851+``` purescript

852+mkFn5 :: forall a b c d e f. (a -> b -> c -> d -> e -> f) -> Fn5 a b c d e f

853+```

854+

855+

856+#### `mkFn6`

857+

858+``` purescript

859+mkFn6 :: forall a b c d e f g. (a -> b -> c -> d -> e -> f -> g) -> Fn6 a b c d e f g

860+```

861+

862+

863+#### `mkFn7`

864+

865+``` purescript

866+mkFn7 :: forall a b c d e f g h. (a -> b -> c -> d -> e -> f -> g -> h) -> Fn7 a b c d e f g h

867+```

868+

869+

870+#### `mkFn8`

871+

872+``` purescript

873+mkFn8 :: forall a b c d e f g h i. (a -> b -> c -> d -> e -> f -> g -> h -> i) -> Fn8 a b c d e f g h i

874+```

875+

876+

877+#### `mkFn9`

878+

879+``` purescript

880+mkFn9 :: forall a b c d e f g h i j. (a -> b -> c -> d -> e -> f -> g -> h -> i -> j) -> Fn9 a b c d e f g h i j

881+```

882+

883+

884+#### `mkFn10`

885+

886+``` purescript

887+mkFn10 :: forall a b c d e f g h i j k. (a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k) -> Fn10 a b c d e f g h i j k

888+```

889+

890+

891+#### `runFn0`

892+

893+``` purescript

894+runFn0 :: forall a. Fn0 a -> a

895+```

896+

897+

898+#### `runFn1`

899+

900+``` purescript

901+runFn1 :: forall a b. Fn1 a b -> a -> b

902+```

903+

904+

905+#### `runFn2`

906+

907+``` purescript

908+runFn2 :: forall a b c. Fn2 a b c -> a -> b -> c

909+```

910+

911+

912+#### `runFn3`

913+

914+``` purescript

915+runFn3 :: forall a b c d. Fn3 a b c d -> a -> b -> c -> d

916+```

917+

918+

919+#### `runFn4`

920+

921+``` purescript

922+runFn4 :: forall a b c d e. Fn4 a b c d e -> a -> b -> c -> d -> e

923+```

924+

925+

926+#### `runFn5`

927+

928+``` purescript

929+runFn5 :: forall a b c d e f. Fn5 a b c d e f -> a -> b -> c -> d -> e -> f

930+```

931+

932+

933+#### `runFn6`

934+

935+``` purescript

936+runFn6 :: forall a b c d e f g. Fn6 a b c d e f g -> a -> b -> c -> d -> e -> f -> g

937+```

938+

939+

940+#### `runFn7`

941+

942+``` purescript

943+runFn7 :: forall a b c d e f g h. Fn7 a b c d e f g h -> a -> b -> c -> d -> e -> f -> g -> h

944+```

945+

946+

947+#### `runFn8`

948+

949+``` purescript

950+runFn8 :: forall a b c d e f g h i. Fn8 a b c d e f g h i -> a -> b -> c -> d -> e -> f -> g -> h -> i

951+```

952+

953+

954+#### `runFn9`

955+

956+``` purescript

957+runFn9 :: forall a b c d e f g h i j. Fn9 a b c d e f g h i j -> a -> b -> c -> d -> e -> f -> g -> h -> i -> j

958+```

959+

960+

961+#### `runFn10`

962+

963+``` purescript

964+runFn10 :: forall a b c d e f g h i j k. Fn10 a b c d e f g h i j k -> a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k

965+```

966+

967+

968+

969+## Module Prelude.Unsafe

970+

971+

972+

973+#### `unsafeIndex`

974+

975+``` purescript

976+unsafeIndex :: forall a. [a] -> Number -> a

977+```

978+

979+

980+

981+## Module Control.Monad.Eff

982+

983+

984+

985+#### `Eff`

986+

987+``` purescript

988+data Eff :: # ! -> * -> *

989+```

990+

991+

992+#### `returnE`

993+

994+``` purescript

995+returnE :: forall e a. a -> Eff e a

996+```

997+

998+

999+#### `bindE`

1000+

1001+``` purescript

1002+bindE :: forall e a b. Eff e a -> (a -> Eff e b) -> Eff e b

1003+```

1004+

1005+

1006+#### `Pure`

1007+

1008+``` purescript

1009+type Pure a = forall e. Eff e a

1010+```

1011+

1012+

1013+#### `runPure`

1014+

1015+``` purescript

1016+runPure :: forall a. Pure a -> a

1017+```

1018+

1019+

1020+#### `functorEff`

1021+

1022+``` purescript

1023+instance functorEff :: Functor (Eff e)

1024+```

1025+

1026+

1027+#### `applyEff`

1028+

1029+``` purescript

1030+instance applyEff :: Apply (Eff e)

1031+```

1032+

1033+

1034+#### `applicativeEff`

1035+

1036+``` purescript

1037+instance applicativeEff :: Applicative (Eff e)

1038+```

1039+

1040+

1041+#### `bindEff`

1042+

1043+``` purescript

1044+instance bindEff :: Bind (Eff e)

1045+```

1046+

1047+

1048+#### `monadEff`

1049+

1050+``` purescript

1051+instance monadEff :: Monad (Eff e)

1052+```

1053+

1054+

1055+#### `untilE`

1056+

1057+``` purescript

1058+untilE :: forall e. Eff e Boolean -> Eff e Unit

1059+```

1060+

1061+

1062+#### `whileE`

1063+

1064+``` purescript

1065+whileE :: forall e a. Eff e Boolean -> Eff e a -> Eff e Unit

1066+```

1067+

1068+

1069+#### `forE`

1070+

1071+``` purescript

1072+forE :: forall e. Number -> Number -> (Number -> Eff e Unit) -> Eff e Unit

1073+```

1074+

1075+

1076+#### `foreachE`

1077+

1078+``` purescript

1079+foreachE :: forall e a. [a] -> (a -> Eff e Unit) -> Eff e Unit

1080+```

1081+

1082+

1083+

1084+## Module Control.Monad.Eff.Unsafe

1085+

1086+

1087+

1088+#### `unsafeInterleaveEff`

1089+

1090+``` purescript

1091+unsafeInterleaveEff :: forall eff1 eff2 a. Eff eff1 a -> Eff eff2 a

1092+```

1093+

1094+

1095+

1096+## Module Debug.Trace

1097+

1098+

1099+

1100+#### `Trace`

1101+

1102+``` purescript

1103+data Trace :: !

1104+```

1105+

1106+

1107+#### `trace`

1108+

1109+``` purescript

1110+trace :: forall r. String -> Eff (trace :: Trace | r) Unit

1111+```

1112+

1113+

1114+#### `print`

1115+

1116+``` purescript

1117+print :: forall a r. (Show a) => a -> Eff (trace :: Trace | r) Unit

1118+```

1119+

1120+

1121+

1122+## Module Control.Monad.ST

1123+

1124+

1125+

1126+#### `ST`

1127+

1128+``` purescript

1129+data ST :: * -> !

1130+```

1131+

1132+

1133+#### `STRef`

1134+

1135+``` purescript

1136+data STRef :: * -> * -> *

1137+```

1138+

1139+

1140+#### `newSTRef`

1141+

1142+``` purescript

1143+newSTRef :: forall a h r. a -> Eff (st :: ST h | r) (STRef h a)

1144+```

1145+

1146+

1147+#### `readSTRef`

1148+

1149+``` purescript

1150+readSTRef :: forall a h r. STRef h a -> Eff (st :: ST h | r) a

1151+```

1152+

1153+

1154+#### `modifySTRef`

1155+

1156+``` purescript

1157+modifySTRef :: forall a h r. STRef h a -> (a -> a) -> Eff (st :: ST h | r) a

1158+```

1159+

1160+

1161+#### `writeSTRef`

1162+

1163+``` purescript

1164+writeSTRef :: forall a h r. STRef h a -> a -> Eff (st :: ST h | r) a

1165+```

1166+

1167+

1168+#### `runST`

1169+

1170+``` purescript

1171+runST :: forall a r. (forall h. Eff (st :: ST h | r) a) -> Eff r a

1172+```

1173+

1174+

1175+#### `pureST`

1176+

1177+``` purescript

1178+pureST :: forall a. (forall h r. Eff (st :: ST h | r) a) -> a

1179+```

1180+

1181+

1182+

1183+

prelude/images/Prelude.pngnew file

Binary file not shown.

prelude/prelude.pursnew file+1219

@@ -0,0 +1,1219 @@

1+module Prelude

2+ ( otherwise

3+ , flip

4+ , const

5+ , asTypeOf

6+ , Semigroupoid, (<<<), (>>>)

7+ , Category, id

8+ , ($), (#)

9+ , (:), cons

10+ , Show, show

11+ , Functor, (<$>), (<#>), void

12+ , Apply, (<*>)

13+ , Applicative, pure, liftA1

14+ , Bind, (>>=)

15+ , Monad, return, liftM1, ap

16+ , Semiring, (+), zero, (*), one

17+ , ModuloSemiring, (/), mod

18+ , Ring, (-)

19+ , (%)

20+ , negate

21+ , DivisionRing

22+ , Num

23+ , Eq, (==), (/=), refEq, refIneq

24+ , Ord, Ordering(..), compare, (<), (>), (<=), (>=)

25+ , Bits, (.&.), (.|.), (.^.), shl, shr, zshr, complement

26+ , BoolLike, (&&), (||)

27+ , not

28+ , Semigroup, (<>), (++)

29+ , Unit(..), unit

30+ ) where

31+

32+ -- | An alias for `true`, which can be useful in guard clauses:

33+ -- |

34+ -- | E.g.

35+ -- |

36+ -- | max x y | x >= y = x

37+ -- | | otherwise = y

38+ otherwise :: Boolean

39+ otherwise = true

40+

41+ -- | Flips the order of the arguments to a function of two arguments.

42+ -- |

43+ -- | E.g.

44+ -- |

45+ -- | flip const 1 2 = const 2 1 = 2

46+ -- |

47+ flip :: forall a b c. (a -> b -> c) -> b -> a -> c

48+ flip f b a = f a b

49+

50+ -- | Returns its first argument and ignores its second.

51+ -- |

52+ -- | E.g.

53+ -- |

54+ -- | const 1 2 = 1

55+ -- |

56+ const :: forall a b. a -> b -> a

57+ const a _ = a

58+

59+ -- | This function returns its first argument, and can be used to assert type equalities.

60+ -- | This can be useful when types are otherwise ambiguous.

61+ -- |

62+ -- | E.g.

63+ -- |

64+ -- | main = print $ [] `asTypeOf` [0]

65+ -- |

66+ -- | If instead, we had written `main = print []`, the type of the argument `[]` would have

67+ -- | been ambiguous, resulting in a compile-time error.

68+ asTypeOf :: forall a. a -> a -> a

69+ asTypeOf x _ = x

70+

71+ infixr 9 >>>

72+ infixr 9 <<<

73+

74+ -- | A `Semigroupoid` is similar to a [`Category`](#category) but does not require an identity

75+ -- | element `id`, just composable morphisms.

76+ -- |

77+ -- | `Semigroupoid`s should obey the following rule:

78+ -- |

79+ -- | Association:

80+ -- | `forall p q r. p <<< (q <<< r) = (p <<< q) <<< r`

81+ -- |

82+ class Semigroupoid a where

83+ (<<<) :: forall b c d. a c d -> a b c -> a b d

84+

85+ instance semigroupoidArr :: Semigroupoid (->) where

86+ (<<<) f g x = f (g x)

87+

88+ (>>>) :: forall a b c d. (Semigroupoid a) => a b c -> a c d -> a b d

89+ (>>>) f g = g <<< f

90+

91+ -- | `Category`s consist of objects and composable morphisms between them, and as such are

92+ -- | [`Semigroupoids`](#semigroupoid), but unlike `semigroupoids` must have an identity element.

93+ -- |

94+ -- | `Category`s should obey the following rules.

95+ -- |

96+ -- | Left Identity:

97+ -- | `forall p. id <<< p = p`

98+ -- |

99+ -- | Right Identity:

100+ -- | `forall p. p <<< id = p`

101+ -- |

102+ class (Semigroupoid a) <= Category a where

103+ id :: forall t. a t t

104+

105+ instance categoryArr :: Category (->) where

106+ id x = x

107+

108+ infixr 0 $

109+ infixl 0 #

110+

111+ -- | Applies a function to its argument

112+ -- |

113+ -- | E.g.

114+ -- |

115+ -- | const $ 1 2 = const 1 2 = 1

116+ -- |

117+ -- | `($)` is different from [`(#)`](#-2) because it is right-infix instance instead of left.

118+ -- | Right-infix operators parse like (a $ (b $ (c $ (d ...)))) whereas left-infix operators parse

119+ -- | like (((a # b) # c) # d ...).

120+ -- |

121+ ($) :: forall a b. (a -> b) -> a -> b

122+ ($) f x = f x

123+

124+ -- | Applies a function to its argument

125+ -- |

126+ -- | E.g.

127+ -- |

128+ -- | 3 # ((+) 1) = 3 + 1 = 4

129+ -- |

130+ -- | `(#)` is different from [`($)`](#-1) because it is left-infix instance instead of right.

131+ -- | Right-infix operators parse like (a $ (b $ (c $ (d ...)))) whereas left-infix operators parse

132+ -- | like (((a # b) # c) # d ...).

133+ -- |

134+ (#) :: forall a b. a -> (a -> b) -> b

135+ (#) x f = f x

136+

137+ infixr 6 :

138+

139+ -- | Attaches an element to the front of a list.

140+ -- |

141+ -- | E.g.

142+ -- |

143+ -- | 1 : [2, 3, 4] = [1, 2, 3, 4]

144+ -- |

145+ (:) :: forall a. a -> [a] -> [a]

146+ (:) = cons

147+

148+ foreign import cons

149+ """

150+ function cons(e) {

151+ return function(l) {

152+ return [e].concat(l);

153+ };

154+ }

155+ """ :: forall a. a -> [a] -> [a]

156+

157+ class Show a where

158+ show :: a -> String

159+

160+ foreign import showStringImpl

161+ """

162+ function showStringImpl(s) {

163+ return JSON.stringify(s);

164+ }

165+ """ :: String -> String

166+

167+ instance showUnit :: Show Unit where

168+ show (Unit {}) = "Unit {}"

169+

170+ instance showString :: Show String where

171+ show = showStringImpl

172+

173+ instance showBoolean :: Show Boolean where

174+ show true = "true"

175+ show false = "false"

176+

177+ foreign import showNumberImpl

178+ """

179+ function showNumberImpl(n) {

180+ return n.toString();

181+ }

182+ """ :: Number -> String

183+

184+ instance showNumber :: Show Number where

185+ show = showNumberImpl

186+

187+ foreign import showArrayImpl

188+ """

189+ function showArrayImpl(f) {

190+ return function(xs) {

191+ var ss = [];

192+ for (var i = 0, l = xs.length; i < l; i++) {

193+ ss[i] = f(xs[i]);

194+ }

195+ return '[' + ss.join(',') + ']';

196+ };

197+ }

198+ """ :: forall a. (a -> String) -> [a] -> String

199+

200+ instance showArray :: (Show a) => Show [a] where

201+ show = showArrayImpl show

202+

203+ infixl 4 <$>

204+ infixl 1 <#>

205+

206+ -- | A `Functor` is intuitively a type which can be mapped over, and more formally a mapping

207+ -- | between [`Category`](#category)s that preserves structure.

208+ -- |

209+ -- | `Functor`s should obey the following rules.

210+ -- |

211+ -- | Identity:

212+ -- | `(<$>) id = id`

213+ -- |

214+ -- | Composition:

215+ -- | `forall f g. (<$>) (f . g) = ((<$>) f) . ((<$>) g)`

216+ -- |

217+ class Functor f where

218+ (<$>) :: forall a b. (a -> b) -> f a -> f b

219+

220+ (<#>) :: forall f a b. (Functor f) => f a -> (a -> b) -> f b

221+ (<#>) fa f = f <$> fa

222+

223+ void :: forall f a. (Functor f) => f a -> f Unit

224+ void fa = const unit <$> fa

225+

226+ infixl 4 <*>

227+

228+ -- | `Apply`s are intuitively [`Applicative`](#applicative)s less `pure`, and more formally a

229+ -- | strong lax semi-monoidal endofunctor.

230+ -- |

231+ -- | `Apply`s should obey the following rules.

232+ -- |

233+ -- | Associative Composition:

234+ -- | `forall f g h. (.) <$> f <*> g <*> h = f <*> (g <*> h)`

235+ -- |

236+ class (Functor f) <= Apply f where

237+ (<*>) :: forall a b. f (a -> b) -> f a -> f b

238+

239+ -- | `Applicative`s are [`Functor`](#functor)s which can be "applied" by sequencing composition

240+ -- | (`<*>`) or embedding pure expressions (`pure`).

241+ -- |

242+ -- | `Applicative`s should obey the following rules.

243+ -- |

244+ -- | Identity:

245+ -- | `forall v. (pure id) <*> v = v`

246+ -- |

247+ -- | Composition:

248+ -- | `forall f g h. (pure (.)) <*> f <*> g <*> h = f <*> (g <*> h)`

249+ -- |

250+ -- | Homomorphism:

251+ -- | `forall f x. (pure f) <*> (pure x) = pure (f x)`

252+ -- |

253+ -- | Interchange:

254+ -- | `forall u y. u <*> (pure y) = (pure (($) y)) <*> u`

255+ -- |

256+ class (Apply f) <= Applicative f where

257+ pure :: forall a. a -> f a

258+

259+ liftA1 :: forall f a b. (Applicative f) => (a -> b) -> f a -> f b

260+ liftA1 f a = pure f <*> a

261+

262+ infixl 1 >>=

263+

264+ -- | A `Bind` is an [`Apply`](#apply) with a bind operation which sequentially composes actions.

265+ -- |

266+ -- | `Bind`s should obey the following rule.

267+ -- |

268+ -- | Associativity:

269+ -- | `forall f g x. (x >>= f) >>= g = x >>= (\k => f k >>= g)`

270+ -- |

271+ class (Apply m) <= Bind m where

272+ (>>=) :: forall a b. m a -> (a -> m b) -> m b

273+

274+ -- | `Monad` is a class which can be intuitively thought of as an abstract datatype of actions or

275+ -- | more formally though of as a monoid in the category of endofunctors.

276+ -- |

277+ -- | `Monad`s should obey the following rules.

278+ -- |

279+ -- | Left Identity:

280+ -- | `forall f x. pure x >>= f = f x`

281+ -- |

282+ -- | Right Identity:

283+ -- | `forall x. x >>= pure = x`

284+ -- |

285+ class (Applicative m, Bind m) <= Monad m

286+

287+ return :: forall m a. (Monad m) => a -> m a

288+ return = pure

289+

290+ liftM1 :: forall m a b. (Monad m) => (a -> b) -> m a -> m b

291+ liftM1 f a = do

292+ a' <- a

293+ return (f a')

294+

295+ ap :: forall m a b. (Monad m) => m (a -> b) -> m a -> m b

296+ ap f a = do

297+ f' <- f

298+ a' <- a

299+ return (f' a')

300+

301+ instance functorArr :: Functor ((->) r) where

302+ (<$>) = (<<<)

303+

304+ instance applyArr :: Apply ((->) r) where

305+ (<*>) f g x = f x (g x)

306+

307+ instance applicativeArr :: Applicative ((->) r) where

308+ pure = const

309+

310+ instance bindArr :: Bind ((->) r) where

311+ (>>=) m f x = f (m x) x

312+

313+ instance monadArr :: Monad ((->) r)

314+

315+ infixl 7 *

316+ infixl 7 /

317+ infixl 7 %

318+

319+ infixl 6 -

320+ infixl 6 +

321+

322+ -- | Addition and multiplication

323+ class Semiring a where

324+ (+) :: a -> a -> a

325+ zero :: a

326+ (*) :: a -> a -> a

327+ one :: a

328+

329+ -- | Semiring with modulo operation and division where

330+ -- | ```a / b * b + (a `mod` b) = a```

331+ class (Semiring a) <= ModuloSemiring a where

332+ (/) :: a -> a -> a

333+ mod :: a -> a -> a

334+

335+ -- | Addition, multiplication, and subtraction

336+ class (Semiring a) <= Ring a where

337+ (-) :: a -> a -> a

338+

339+ negate :: forall a. (Ring a) => a -> a

340+ negate a = zero - a

341+

342+ -- | Ring where every nonzero element has a multiplicative inverse (possibly

343+ -- | a non-commutative field) so that ```a `mod` b = zero```

344+ class (Ring a, ModuloSemiring a) <= DivisionRing a

345+

346+ -- | A commutative field

347+ class (DivisionRing a) <= Num a

348+

349+ foreign import numAdd

350+ """

351+ function numAdd(n1) {

352+ return function(n2) {

353+ return n1 + n2;

354+ };

355+ }

356+ """ :: Number -> Number -> Number

357+

358+ foreign import numSub

359+ """

360+ function numSub(n1) {

361+ return function(n2) {

362+ return n1 - n2;

363+ };

364+ }

365+ """ :: Number -> Number -> Number

366+

367+ foreign import numMul

368+ """

369+ function numMul(n1) {

370+ return function(n2) {

371+ return n1 * n2;

372+ };

373+ }

374+ """ :: Number -> Number -> Number

375+

376+ foreign import numDiv

377+ """

378+ function numDiv(n1) {

379+ return function(n2) {

380+ return n1 / n2;

381+ };

382+ }

383+ """ :: Number -> Number -> Number

384+

385+ foreign import numMod

386+ """

387+ function numMod(n1) {

388+ return function(n2) {

389+ return n1 % n2;

390+ };

391+ }

392+ """ :: Number -> Number -> Number

393+

394+ (%) = numMod

395+

396+ instance semiringNumber :: Semiring Number where

397+ (+) = numAdd

398+ zero = 0

399+ (*) = numMul

400+ one = 1

401+

402+ instance ringNumber :: Ring Number where

403+ (-) = numSub

404+

405+ instance moduloSemiringNumber :: ModuloSemiring Number where

406+ (/) = numDiv

407+ mod _ _ = 0

408+

409+ instance divisionRingNumber :: DivisionRing Number

410+

411+ instance numNumber :: Num Number

412+

413+ newtype Unit = Unit {}

414+

415+ unit :: Unit

416+ unit = Unit {}

417+

418+ infix 4 ==

419+ infix 4 /=

420+

421+ class Eq a where

422+ (==) :: a -> a -> Boolean

423+ (/=) :: a -> a -> Boolean

424+

425+ foreign import refEq

426+ """

427+ function refEq(r1) {

428+ return function(r2) {

429+ return r1 === r2;

430+ };

431+ }

432+ """ :: forall a. a -> a -> Boolean

433+

434+ foreign import refIneq

435+ """

436+ function refIneq(r1) {

437+ return function(r2) {

438+ return r1 !== r2;

439+ };

440+ }

441+ """ :: forall a. a -> a -> Boolean

442+

443+ instance eqUnit :: Eq Unit where

444+ (==) (Unit {}) (Unit {}) = true

445+ (/=) (Unit {}) (Unit {}) = false

446+

447+ instance eqString :: Eq String where

448+ (==) = refEq

449+ (/=) = refIneq

450+

451+ instance eqNumber :: Eq Number where

452+ (==) = refEq

453+ (/=) = refIneq

454+

455+ instance eqBoolean :: Eq Boolean where

456+ (==) = refEq

457+ (/=) = refIneq

458+

459+ foreign import eqArrayImpl

460+ """

461+ function eqArrayImpl(f) {

462+ return function(xs) {

463+ return function(ys) {

464+ if (xs.length !== ys.length) return false;

465+ for (var i = 0; i < xs.length; i++) {

466+ if (!f(xs[i])(ys[i])) return false;

467+ }

468+ return true;

469+ };

470+ };

471+ }

472+ """ :: forall a. (a -> a -> Boolean) -> [a] -> [a] -> Boolean

473+

474+ instance eqArray :: (Eq a) => Eq [a] where

475+ (==) xs ys = eqArrayImpl (==) xs ys

476+ (/=) xs ys = not (xs == ys)

477+

478+ data Ordering = LT | GT | EQ

479+

480+ instance eqOrdering :: Eq Ordering where

481+ (==) LT LT = true

482+ (==) GT GT = true

483+ (==) EQ EQ = true

484+ (==) _ _ = false

485+ (/=) x y = not (x == y)

486+

487+ instance showOrdering :: Show Ordering where

488+ show LT = "LT"

489+ show GT = "GT"

490+ show EQ = "EQ"

491+

492+ instance semigroupOrdening :: Semigroup Ordering where

493+ (<>) LT _ = LT

494+ (<>) GT _ = GT

495+ (<>) EQ y = y

496+

497+

498+ class (Eq a) <= Ord a where

499+ compare :: a -> a -> Ordering

500+

501+ infixl 4 <

502+

503+ (<) :: forall a. (Ord a) => a -> a -> Boolean

504+ (<) a1 a2 = case a1 `compare` a2 of

505+ LT -> true

506+ _ -> false

507+

508+ infixl 4 >

509+

510+ (>) :: forall a. (Ord a) => a -> a -> Boolean

511+ (>) a1 a2 = case a1 `compare` a2 of

512+ GT -> true

513+ _ -> false

514+

515+ infixl 4 <=

516+

517+ (<=) :: forall a. (Ord a) => a -> a -> Boolean

518+ (<=) a1 a2 = case a1 `compare` a2 of

519+ GT -> false

520+ _ -> true

521+

522+ infixl 4 >=

523+

524+ (>=) :: forall a. (Ord a) => a -> a -> Boolean

525+ (>=) a1 a2 = case a1 `compare` a2 of

526+ LT -> false

527+ _ -> true

528+

529+ foreign import unsafeCompareImpl

530+ """

531+ function unsafeCompareImpl(lt) {

532+ return function(eq) {

533+ return function(gt) {

534+ return function(x) {

535+ return function(y) {

536+ return x < y ? lt : x > y ? gt : eq;

537+ };

538+ };

539+ };

540+ };

541+ }

542+ """ :: forall a. Ordering -> Ordering -> Ordering -> a -> a -> Ordering

543+

544+ unsafeCompare :: forall a. a -> a -> Ordering

545+ unsafeCompare = unsafeCompareImpl LT EQ GT

546+

547+ instance ordUnit :: Ord Unit where

548+ compare (Unit {}) (Unit {}) = EQ

549+

550+ instance ordBoolean :: Ord Boolean where

551+ compare false false = EQ

552+ compare false true = LT

553+ compare true true = EQ

554+ compare true false = GT

555+

556+ instance ordNumber :: Ord Number where

557+ compare = unsafeCompare

558+

559+ instance ordString :: Ord String where

560+ compare = unsafeCompare

561+

562+ instance ordArray :: (Ord a) => Ord [a] where

563+ compare [] [] = EQ

564+ compare [] _ = LT

565+ compare _ [] = GT

566+ compare (x:xs) (y:ys) = case compare x y of

567+ EQ -> compare xs ys

568+ other -> other

569+

570+ infixl 10 .&.

571+ infixl 10 .|.

572+ infixl 10 .^.

573+

574+ class Bits b where

575+ (.&.) :: b -> b -> b

576+ (.|.) :: b -> b -> b

577+ (.^.) :: b -> b -> b

578+ shl :: b -> Number -> b

579+ shr :: b -> Number -> b

580+ zshr :: b -> Number -> b

581+ complement :: b -> b

582+

583+ foreign import numShl

584+ """

585+ function numShl(n1) {

586+ return function(n2) {

587+ return n1 << n2;

588+ };

589+ }

590+ """ :: Number -> Number -> Number

591+

592+ foreign import numShr

593+ """

594+ function numShr(n1) {

595+ return function(n2) {

596+ return n1 >> n2;

597+ };

598+ }

599+ """ :: Number -> Number -> Number

600+

601+ foreign import numZshr

602+ """

603+ function numZshr(n1) {

604+ return function(n2) {

605+ return n1 >>> n2;

606+ };

607+ }

608+ """ :: Number -> Number -> Number

609+

610+ foreign import numAnd

611+ """

612+ function numAnd(n1) {

613+ return function(n2) {

614+ return n1 & n2;

615+ };

616+ }

617+ """ :: Number -> Number -> Number

618+

619+ foreign import numOr

620+ """

621+ function numOr(n1) {

622+ return function(n2) {

623+ return n1 | n2;

624+ };

625+ }

626+ """ :: Number -> Number -> Number

627+

628+ foreign import numXor

629+ """

630+ function numXor(n1) {

631+ return function(n2) {

632+ return n1 ^ n2;

633+ };

634+ }

635+ """ :: Number -> Number -> Number

636+

637+ foreign import numComplement

638+ """

639+ function numComplement(n) {

640+ return ~n;

641+ }

642+ """ :: Number -> Number

643+

644+ instance bitsNumber :: Bits Number where

645+ (.&.) = numAnd

646+ (.|.) = numOr

647+ (.^.) = numXor

648+ shl = numShl

649+ shr = numShr

650+ zshr = numZshr

651+ complement = numComplement

652+

653+ infixr 2 ||

654+ infixr 3 &&

655+

656+ class BoolLike b where

657+ (&&) :: b -> b -> b

658+ (||) :: b -> b -> b

659+ not :: b -> b

660+

661+ foreign import boolAnd

662+ """

663+ function boolAnd(b1) {

664+ return function(b2) {

665+ return b1 && b2;

666+ };

667+ }

668+ """ :: Boolean -> Boolean -> Boolean

669+

670+ foreign import boolOr

671+ """

672+ function boolOr(b1) {

673+ return function(b2) {

674+ return b1 || b2;

675+ };

676+ }

677+ """ :: Boolean -> Boolean -> Boolean

678+

679+ foreign import boolNot

680+ """

681+ function boolNot(b) {

682+ return !b;

683+ }

684+ """ :: Boolean -> Boolean

685+

686+ instance boolLikeBoolean :: BoolLike Boolean where

687+ (&&) = boolAnd

688+ (||) = boolOr

689+ not = boolNot

690+

691+ infixr 5 <>

692+

693+ class Semigroup a where

694+ (<>) :: a -> a -> a

695+

696+ foreign import concatString

697+ """

698+ function concatString(s1) {

699+ return function(s2) {

700+ return s1 + s2;

701+ };

702+ }

703+ """ :: String -> String -> String

704+

705+ instance semigroupUnit :: Semigroup Unit where

706+ (<>) (Unit {}) (Unit {}) = Unit {}

707+

708+ instance semigroupString :: Semigroup String where

709+ (<>) = concatString

710+

711+ instance semigroupArr :: (Semigroup s') => Semigroup (s -> s') where

712+ (<>) f g = \x -> f x <> g x

713+

714+ infixr 5 ++

715+

716+ (++) :: forall s. (Semigroup s) => s -> s -> s

717+ (++) = (<>)

718+

719+module Data.Function where

720+

721+ on :: forall a b c. (b -> b -> c) -> (a -> b) -> a -> a -> c

722+ on f g x y = g x `f` g y

723+

724+ foreign import data Fn0 :: * -> *

725+ foreign import data Fn1 :: * -> * -> *

726+ foreign import data Fn2 :: * -> * -> * -> *

727+ foreign import data Fn3 :: * -> * -> * -> * -> *

728+ foreign import data Fn4 :: * -> * -> * -> * -> * -> *

729+ foreign import data Fn5 :: * -> * -> * -> * -> * -> * -> *

730+ foreign import data Fn6 :: * -> * -> * -> * -> * -> * -> * -> *

731+ foreign import data Fn7 :: * -> * -> * -> * -> * -> * -> * -> * -> *

732+ foreign import data Fn8 :: * -> * -> * -> * -> * -> * -> * -> * -> * -> *

733+ foreign import data Fn9 :: * -> * -> * -> * -> * -> * -> * -> * -> * -> * -> *

734+ foreign import data Fn10 :: * -> * -> * -> * -> * -> * -> * -> * -> * -> * -> * -> *

735+

736+ foreign import mkFn0

737+ """

738+ function mkFn0(fn) {

739+ return function() {

740+ return fn({});

741+ };

742+ }

743+ """ :: forall a. (Unit -> a) -> Fn0 a

744+

745+ foreign import mkFn1

746+ """

747+ function mkFn1(fn) {

748+ return function(a) {

749+ return fn(a);

750+ };

751+ }

752+ """ :: forall a b. (a -> b) -> Fn1 a b

753+

754+ foreign import mkFn2

755+ """

756+ function mkFn2(fn) {

757+ return function(a, b) {

758+ return fn(a)(b);

759+ };

760+ }

761+ """ :: forall a b c. (a -> b -> c) -> Fn2 a b c

762+

763+ foreign import mkFn3

764+ """

765+ function mkFn3(fn) {

766+ return function(a, b, c) {

767+ return fn(a)(b)(c);

768+ };

769+ }

770+ """ :: forall a b c d. (a -> b -> c -> d) -> Fn3 a b c d

771+

772+ foreign import mkFn4

773+ """

774+ function mkFn4(fn) {

775+ return function(a, b, c, d) {

776+ return fn(a)(b)(c)(d);

777+ };

778+ }

779+ """ :: forall a b c d e. (a -> b -> c -> d -> e) -> Fn4 a b c d e

780+

781+ foreign import mkFn5

782+ """

783+ function mkFn5(fn) {

784+ return function(a, b, c, d, e) {

785+ return fn(a)(b)(c)(d)(e);

786+ };

787+ }

788+ """ :: forall a b c d e f. (a -> b -> c -> d -> e -> f) -> Fn5 a b c d e f

789+

790+ foreign import mkFn6

791+ """

792+ function mkFn6(fn) {

793+ return function(a, b, c, d, e, f) {

794+ return fn(a)(b)(c)(d)(e)(f);

795+ };

796+ }

797+ """ :: forall a b c d e f g. (a -> b -> c -> d -> e -> f -> g) -> Fn6 a b c d e f g

798+

799+ foreign import mkFn7

800+ """

801+ function mkFn7(fn) {

802+ return function(a, b, c, d, e, f, g) {

803+ return fn(a)(b)(c)(d)(e)(f)(g);

804+ };

805+ }

806+ """ :: forall a b c d e f g h. (a -> b -> c -> d -> e -> f -> g -> h) -> Fn7 a b c d e f g h

807+

808+ foreign import mkFn8

809+ """

810+ function mkFn8(fn) {

811+ return function(a, b, c, d, e, f, g, h) {

812+ return fn(a)(b)(c)(d)(e)(f)(g)(h);

813+ };

814+ }

815+ """ :: forall a b c d e f g h i. (a -> b -> c -> d -> e -> f -> g -> h -> i) -> Fn8 a b c d e f g h i

816+

817+ foreign import mkFn9

818+ """

819+ function mkFn9(fn) {

820+ return function(a, b, c, d, e, f, g, h, i) {

821+ return fn(a)(b)(c)(d)(e)(f)(g)(h)(i);

822+ };

823+ }

824+ """ :: forall a b c d e f g h i j. (a -> b -> c -> d -> e -> f -> g -> h -> i -> j) -> Fn9 a b c d e f g h i j

825+

826+ foreign import mkFn10

827+ """

828+ function mkFn10(fn) {

829+ return function(a, b, c, d, e, f, g, h, i, j) {

830+ return fn(a)(b)(c)(d)(e)(f)(g)(h)(i)(j);

831+ };

832+ }

833+ """ :: forall a b c d e f g h i j k. (a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k) -> Fn10 a b c d e f g h i j k

834+

835+ foreign import runFn0

836+ """

837+ function runFn0(fn) {

838+ return fn();

839+ }

840+ """ :: forall a. Fn0 a -> a

841+

842+ foreign import runFn1

843+ """

844+ function runFn1(fn) {

845+ return function(a) {

846+ return fn(a);

847+ };

848+ }

849+ """ :: forall a b. Fn1 a b -> a -> b

850+

851+ foreign import runFn2

852+ """

853+ function runFn2(fn) {

854+ return function(a) {

855+ return function(b) {

856+ return fn(a, b);

857+ };

858+ };

859+ }

860+ """ :: forall a b c. Fn2 a b c -> a -> b -> c

861+

862+ foreign import runFn3

863+ """

864+ function runFn3(fn) {

865+ return function(a) {

866+ return function(b) {

867+ return function(c) {

868+ return fn(a, b, c);

869+ };

870+ };

871+ };

872+ }

873+ """ :: forall a b c d. Fn3 a b c d -> a -> b -> c -> d

874+

875+ foreign import runFn4

876+ """

877+ function runFn4(fn) {

878+ return function(a) {

879+ return function(b) {

880+ return function(c) {

881+ return function(d) {

882+ return fn(a, b, c, d);

883+ };

884+ };

885+ };

886+ };

887+ }

888+ """ :: forall a b c d e. Fn4 a b c d e -> a -> b -> c -> d -> e

889+

890+ foreign import runFn5

891+ """

892+ function runFn5(fn) {

893+ return function(a) {

894+ return function(b) {

895+ return function(c) {

896+ return function(d) {

897+ return function(e) {

898+ return fn(a, b, c, d, e);

899+ };

900+ };

901+ };

902+ };

903+ };

904+ }

905+ """ :: forall a b c d e f. Fn5 a b c d e f -> a -> b -> c -> d -> e -> f

906+

907+ foreign import runFn6

908+ """

909+ function runFn6(fn) {

910+ return function(a) {

911+ return function(b) {

912+ return function(c) {

913+ return function(d) {

914+ return function(e) {

915+ return function(f) {

916+ return fn(a, b, c, d, e, f);

917+ };

918+ };

919+ };

920+ };

921+ };

922+ };

923+ }

924+ """ :: forall a b c d e f g. Fn6 a b c d e f g -> a -> b -> c -> d -> e -> f -> g

925+

926+ foreign import runFn7

927+ """

928+ function runFn7(fn) {

929+ return function(a) {

930+ return function(b) {

931+ return function(c) {

932+ return function(d) {

933+ return function(e) {

934+ return function(f) {

935+ return function(g) {

936+ return fn(a, b, c, d, e, f, g);

937+ };

938+ };

939+ };

940+ };

941+ };

942+ };

943+ };

944+ }

945+ """ :: forall a b c d e f g h. Fn7 a b c d e f g h -> a -> b -> c -> d -> e -> f -> g -> h

946+

947+ foreign import runFn8

948+ """

949+ function runFn8(fn) {

950+ return function(a) {

951+ return function(b) {

952+ return function(c) {

953+ return function(d) {

954+ return function(e) {

955+ return function(f) {

956+ return function(g) {

957+ return function(h) {

958+ return fn(a, b, c, d, e, f, g, h);

959+ };

960+ };

961+ };

962+ };

963+ };

964+ };

965+ };

966+ };

967+ }

968+ """ :: forall a b c d e f g h i. Fn8 a b c d e f g h i -> a -> b -> c -> d -> e -> f -> g -> h -> i

969+

970+ foreign import runFn9

971+ """

972+ function runFn9(fn) {

973+ return function(a) {

974+ return function(b) {

975+ return function(c) {

976+ return function(d) {

977+ return function(e) {

978+ return function(f) {

979+ return function(g) {

980+ return function(h) {

981+ return function(i) {

982+ return fn(a, b, c, d, e, f, g, h, i);

983+ };

984+ };

985+ };

986+ };

987+ };

988+ };

989+ };

990+ };

991+ };

992+ }

993+ """ :: forall a b c d e f g h i j. Fn9 a b c d e f g h i j -> a -> b -> c -> d -> e -> f -> g -> h -> i -> j

994+

995+ foreign import runFn10

996+ """

997+ function runFn10(fn) {

998+ return function(a) {

999+ return function(b) {

1000+ return function(c) {

1001+ return function(d) {

1002+ return function(e) {

1003+ return function(f) {

1004+ return function(g) {

1005+ return function(h) {

1006+ return function(i) {

1007+ return function(j) {

1008+ return fn(a, b, c, d, e, f, g, h, i, j);

1009+ };

1010+ };

1011+ };

1012+ };

1013+ };

1014+ };

1015+ };

1016+ };

1017+ };

1018+ };

1019+ }

1020+ """ :: forall a b c d e f g h i j k. Fn10 a b c d e f g h i j k -> a -> b -> c -> d -> e -> f -> g -> h -> i -> j -> k

1021+

1022+module Prelude.Unsafe where

1023+

1024+ foreign import unsafeIndex

1025+ """

1026+ function unsafeIndex(xs) {

1027+ return function(n) {

1028+ return xs[n];

1029+ };

1030+ }

1031+ """ :: forall a. [a] -> Number -> a

1032+

1033+module Control.Monad.Eff where

1034+

1035+ foreign import data Eff :: # ! -> * -> *

1036+

1037+ foreign import returnE

1038+ """

1039+ function returnE(a) {

1040+ return function() {

1041+ return a;

1042+ };

1043+ }

1044+ """ :: forall e a. a -> Eff e a

1045+

1046+ foreign import bindE

1047+ """

1048+ function bindE(a) {

1049+ return function(f) {

1050+ return function() {

1051+ return f(a())();

1052+ };

1053+ };

1054+ }

1055+ """ :: forall e a b. Eff e a -> (a -> Eff e b) -> Eff e b

1056+

1057+ type Pure a = forall e. Eff e a

1058+

1059+ foreign import runPure

1060+ """

1061+ function runPure(f) {

1062+ return f();

1063+ }

1064+ """ :: forall a. Pure a -> a

1065+

1066+ instance functorEff :: Functor (Eff e) where

1067+ (<$>) = liftA1

1068+

1069+ instance applyEff :: Apply (Eff e) where

1070+ (<*>) = ap

1071+

1072+ instance applicativeEff :: Applicative (Eff e) where

1073+ pure = returnE

1074+

1075+ instance bindEff :: Bind (Eff e) where

1076+ (>>=) = bindE

1077+

1078+ instance monadEff :: Monad (Eff e)

1079+

1080+ foreign import untilE

1081+ """

1082+ function untilE(f) {

1083+ return function() {

1084+ while (!f());

1085+ return {};

1086+ };

1087+ }

1088+ """ :: forall e. Eff e Boolean -> Eff e Unit

1089+

1090+ foreign import whileE

1091+ """

1092+ function whileE(f) {

1093+ return function(a) {

1094+ return function() {

1095+ while (f()) {

1096+ a();

1097+ }

1098+ return {};

1099+ };

1100+ };

1101+ }

1102+ """ :: forall e a. Eff e Boolean -> Eff e a -> Eff e Unit

1103+

1104+ foreign import forE

1105+ """

1106+ function forE(lo) {

1107+ return function(hi) {

1108+ return function(f) {

1109+ return function() {

1110+ for (var i = lo; i < hi; i++) {

1111+ f(i)();

1112+ }

1113+ };

1114+ };

1115+ };

1116+ }

1117+ """ :: forall e. Number -> Number -> (Number -> Eff e Unit) -> Eff e Unit

1118+

1119+

1120+ foreign import foreachE

1121+ """

1122+ function foreachE(as) {

1123+ return function(f) {

1124+ return function() {

1125+ for (var i = 0; i < as.length; i++) {

1126+ f(as[i])();

1127+ }

1128+ };

1129+ };

1130+ }

1131+ """ :: forall e a. [a] -> (a -> Eff e Unit) -> Eff e Unit

1132+

1133+module Control.Monad.Eff.Unsafe where

1134+

1135+ import Control.Monad.Eff

1136+

1137+ foreign import unsafeInterleaveEff

1138+ """

1139+ function unsafeInterleaveEff(f) {

1140+ return f;

1141+ }

1142+ """ :: forall eff1 eff2 a. Eff eff1 a -> Eff eff2 a

1143+

1144+module Debug.Trace where

1145+

1146+ import Control.Monad.Eff

1147+

1148+ foreign import data Trace :: !

1149+

1150+ foreign import trace

1151+ """

1152+ function trace(s) {

1153+ return function() {

1154+ console.log(s);

1155+ return {};

1156+ };

1157+ }

1158+ """ :: forall r. String -> Eff (trace :: Trace | r) Unit

1159+

1160+ print :: forall a r. (Show a) => a -> Eff (trace :: Trace | r) Unit

1161+ print o = trace (show o)

1162+

1163+module Control.Monad.ST where

1164+

1165+ import Control.Monad.Eff

1166+

1167+ foreign import data ST :: * -> !

1168+

1169+ foreign import data STRef :: * -> * -> *

1170+

1171+ foreign import newSTRef

1172+ """

1173+ function newSTRef(val) {

1174+ return function() {

1175+ return { value: val };

1176+ };

1177+ }

1178+ """ :: forall a h r. a -> Eff (st :: ST h | r) (STRef h a)

1179+

1180+ foreign import readSTRef

1181+ """

1182+ function readSTRef(ref) {

1183+ return function() {

1184+ return ref.value;

1185+ };

1186+ }

1187+ """ :: forall a h r. STRef h a -> Eff (st :: ST h | r) a

1188+

1189+ foreign import modifySTRef

1190+ """

1191+ function modifySTRef(ref) {

1192+ return function(f) {

1193+ return function() {

1194+ return ref.value = f(ref.value);

1195+ };

1196+ };

1197+ }

1198+ """ :: forall a h r. STRef h a -> (a -> a) -> Eff (st :: ST h | r) a

1199+

1200+ foreign import writeSTRef

1201+ """

1202+ function writeSTRef(ref) {

1203+ return function(a) {

1204+ return function() {

1205+ return ref.value = a;

1206+ };

1207+ };

1208+ }

1209+ """ :: forall a h r. STRef h a -> a -> Eff (st :: ST h | r) a

1210+

1211+ foreign import runST

1212+ """

1213+ function runST(f) {

1214+ return f;

1215+ }

1216+ """ :: forall a r. (forall h. Eff (st :: ST h | r) a) -> Eff r a

1217+

1218+ pureST :: forall a. (forall h r. Eff (st :: ST h | r) a) -> a

1219+ pureST st = runPure (runST st)

prelude/updateDocs.shnew file+11

@@ -0,0 +1,11 @@

1+../dist/build/psc-docs/psc-docs prelude.purs > README.md

2+../dist/build/psc-hierarchy/psc-hierarchy prelude.purs -o prelude

4+mkdir -p images

6+for f in prelude/*; do

7+ BASE=$(basename "$f")

8+ dot -Tpng -o images/"$BASE".png "$f"

9+done

10+

11+rm -r prelude

psc-docs/Main.hsnew file+237

@@ -0,0 +1,237 @@

1+----------------------------------------------------------------------------

2+--

3+-- Module : Main

4+-- Copyright : (c) Phil Freeman 2013

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- |

12+--

13+-----------------------------------------------------------------------------

14+

15+module Main where

16+

17+import Control.Applicative

18+import Control.Monad

19+import Control.Monad.Writer

20+import Control.Arrow (first)

21+import Data.List

22+import Data.Maybe (fromMaybe)

23+import Data.Version (showVersion)

24+import Data.Foldable (traverse_)

25+

26+import Options.Applicative

27+

28+import qualified Language.PureScript as P

29+import qualified Paths_purescript as Paths

30+import System.Exit (exitSuccess, exitFailure)

31+import System.IO (hPutStrLn, stderr)

32+

33+data PSCDocsOptions = PSCDocsOptions

34+ { pscdInputFiles :: [FilePath]

35+ }

36+

37+docgen :: PSCDocsOptions -> IO ()

38+docgen (PSCDocsOptions input) = do

39+ e <- P.parseModulesFromFiles (fromMaybe "") <$> mapM (fmap (first Just) . parseFile) (nub input)

40+ case e of

41+ Left err -> do

42+ hPutStrLn stderr $ show err

43+ exitFailure

44+ Right ms -> do

45+ putStrLn . runDocs $ renderModules (map snd ms)

46+ exitSuccess

47+

48+parseFile :: FilePath -> IO (FilePath, String)

49+parseFile input = (,) input <$> readFile input

50+

51+type Docs = Writer [String] ()

52+

53+runDocs :: Docs -> String

54+runDocs = unlines . execWriter

55+

56+spacer :: Docs

57+spacer = tell [""]

58+

59+headerLevel :: Int -> String -> Docs

60+headerLevel level hdr = tell [replicate level '#' ++ ' ' : hdr]

61+

62+withIndent :: Int -> Docs -> Docs

63+withIndent indent = censor (map (replicate indent ' ' ++ ))

64+

65+atIndent :: Int -> String -> Docs

66+atIndent indent text =

67+ let ls = lines text in

68+ withIndent indent (tell ls)

69+

70+fenced :: String -> Docs

71+fenced text = fencedBlock (tell $ lines text)

72+

73+fencedBlock :: Docs -> Docs

74+fencedBlock inner = do

75+ tell ["``` purescript"]

76+ inner

77+ tell ["```"]

78+

79+ticks :: String -> String

80+ticks = ("`" ++) . (++ "`")

81+

82+renderModules :: [P.Module] -> Docs

83+renderModules ms = do

84+ headerLevel 1 "Module Documentation"

85+ spacer

86+ mapM_ renderModule ms

87+

88+renderModule :: P.Module -> Docs

89+renderModule mdl@(P.Module coms moduleName _ exps) = do

90+ headerLevel 2 $ "Module " ++ P.runModuleName moduleName

91+ spacer

92+ unless (null coms) $ do

93+ renderComments coms

94+ spacer

95+ renderTopLevel exps (P.exportedDeclarations mdl)

96+ spacer

97+

98+renderTopLevel :: Maybe [P.DeclarationRef] -> [P.Declaration] -> Docs

99+renderTopLevel exps decls = forM_ decls $ \decl ->

100+ when (canRenderDecl decl) $ do

101+ traverse_ (headerLevel 4) (ticks `fmap` getDeclarationTitle decl)

102+ spacer

103+ renderDeclaration exps decl

104+ spacer

105+

106+renderTypeclassImage :: P.ModuleName -> Docs

107+renderTypeclassImage name =

108+ let name' = P.runModuleName name

109+ in tell ["![" ++ name' ++ "](images/" ++ name' ++ ".png)"]

110+

111+getDeclarationTitle :: P.Declaration -> Maybe String

112+getDeclarationTitle (P.TypeDeclaration name _) = Just (show name)

113+getDeclarationTitle (P.ExternDeclaration _ name _ _) = Just (show name)

114+getDeclarationTitle (P.DataDeclaration _ name _ _) = Just (show name)

115+getDeclarationTitle (P.ExternDataDeclaration name _) = Just (show name)

116+getDeclarationTitle (P.TypeSynonymDeclaration name _ _) = Just (show name)

117+getDeclarationTitle (P.TypeClassDeclaration name _ _ _) = Just (show name)

118+getDeclarationTitle (P.TypeInstanceDeclaration name _ _ _ _) = Just (show name)

119+getDeclarationTitle (P.PositionedDeclaration _ _ d) = getDeclarationTitle d

120+getDeclarationTitle _ = Nothing

121+

122+renderDeclaration :: Maybe [P.DeclarationRef] -> P.Declaration -> Docs

123+renderDeclaration _ (P.TypeDeclaration ident ty) =

124+ fenced $ show ident ++ " :: " ++ prettyPrintType' ty

125+renderDeclaration _ (P.ExternDeclaration _ ident _ ty) =

126+ fenced $ show ident ++ " :: " ++ prettyPrintType' ty

127+renderDeclaration exps (P.DataDeclaration dtype name args ctors) = do

128+ let

129+ typeApp = foldl P.TypeApp (P.TypeConstructor (P.Qualified Nothing name)) (map toTypeVar args)

130+ typeName = prettyPrintType' typeApp

131+ exported = filter (P.isDctorExported name exps . fst) ctors

132+ fencedBlock $ do

133+ tell [show dtype ++ " " ++ typeName]

134+ zipWithM_ (\isFirst (ctor, tys) ->

135+ atIndent 2 $ (if isFirst then "= " else "| ") ++ P.runProperName ctor ++ " " ++ unwords (map P.prettyPrintTypeAtom tys))

136+ (True : repeat False) exported

137+renderDeclaration _ (P.ExternDataDeclaration name kind) =

138+ fenced $ "data " ++ P.runProperName name ++ " :: " ++ P.prettyPrintKind kind

139+renderDeclaration _ (P.TypeSynonymDeclaration name args ty) = do

140+ let

141+ typeApp = foldl P.TypeApp (P.TypeConstructor (P.Qualified Nothing name)) (map toTypeVar args)

142+ typeName = prettyPrintType' typeApp

143+ fenced $ "type " ++ typeName ++ " = " ++ prettyPrintType' ty

144+renderDeclaration _ (P.TypeClassDeclaration name args implies ds) = do

145+ let impliesText = case implies of

146+ [] -> ""

147+ is -> "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map P.prettyPrintTypeAtom tys')) is) ++ ") <= "

148+ classApp = foldl P.TypeApp (P.TypeConstructor (P.Qualified Nothing name)) (map toTypeVar args)

149+ className = prettyPrintType' classApp

150+ fencedBlock $ do

151+ tell ["class " ++ impliesText ++ className ++ " where"]

152+ mapM_ renderClassMember ds

153+ where

154+ renderClassMember (P.PositionedDeclaration _ _ d) = renderClassMember d

155+ renderClassMember (P.TypeDeclaration ident ty) = atIndent 2 $ show ident ++ " :: " ++ prettyPrintType' ty

156+ renderClassMember _ = error "Invalid argument to renderClassMember."

157+renderDeclaration _ (P.TypeInstanceDeclaration name constraints className tys _) = do

158+ let constraintsText = case constraints of

159+ [] -> ""

160+ cs -> "(" ++ intercalate ", " (map (\(pn, tys') -> show pn ++ " " ++ unwords (map P.prettyPrintTypeAtom tys')) cs) ++ ") => "

161+ fenced $ "instance " ++ show name ++ " :: " ++ constraintsText ++ show className ++ " " ++ unwords (map P.prettyPrintTypeAtom tys)

162+renderDeclaration exps (P.PositionedDeclaration _ com d) = do

163+ renderDeclaration exps d

164+ renderComments com

165+renderDeclaration _ _ = return ()

166+

167+renderComments :: [P.Comment] -> Docs

168+renderComments cs = do

169+ let raw = concatMap toLines cs

170+ when (all hasPipe raw) $ do

171+ spacer

172+ atIndent 0 . unlines . map stripPipes $ raw

173+ where

174+

175+ toLines (P.LineComment s) = [s]

176+ toLines (P.BlockComment s) = lines s

177+

178+ hasPipe s = case dropWhile (== ' ') s of { ('|':_) -> True; _ -> False }

179+

180+ stripPipes = dropPipe . dropWhile (== ' ')

181+

182+ dropPipe ('|':' ':s) = s

183+ dropPipe ('|':s) = s

184+ dropPipe s = s

185+

186+toTypeVar :: (String, Maybe P.Kind) -> P.Type

187+toTypeVar (s, Nothing) = P.TypeVar s

188+toTypeVar (s, Just k) = P.KindedType (P.TypeVar s) k

189+

190+prettyPrintType' :: P.Type -> String

191+prettyPrintType' = P.prettyPrintType . P.everywhereOnTypes dePrim

192+ where

193+ dePrim ty@(P.TypeConstructor (P.Qualified _ name))

194+ | ty == P.tyBoolean || ty == P.tyNumber || ty == P.tyString =

195+ P.TypeConstructor $ P.Qualified Nothing name

196+ dePrim other = other

197+

198+getName :: P.Declaration -> String

199+getName (P.TypeDeclaration ident _) = show ident

200+getName (P.ExternDeclaration _ ident _ _) = show ident

201+getName (P.DataDeclaration _ name _ _) = P.runProperName name

202+getName (P.ExternDataDeclaration name _) = P.runProperName name

203+getName (P.TypeSynonymDeclaration name _ _) = P.runProperName name

204+getName (P.TypeClassDeclaration name _ _ _) = P.runProperName name

205+getName (P.TypeInstanceDeclaration name _ _ _ _) = show name

206+getName (P.PositionedDeclaration _ _ d) = getName d

207+getName _ = error "Invalid argument to getName"

208+

209+canRenderDecl :: P.Declaration -> Bool

210+canRenderDecl P.TypeDeclaration{} = True

211+canRenderDecl P.ExternDeclaration{} = True

212+canRenderDecl P.DataDeclaration{} = True

213+canRenderDecl P.ExternDataDeclaration{} = True

214+canRenderDecl P.TypeSynonymDeclaration{} = True

215+canRenderDecl P.TypeClassDeclaration{} = True

216+canRenderDecl P.TypeInstanceDeclaration{} = True

217+canRenderDecl (P.PositionedDeclaration _ _ d) = canRenderDecl d

218+canRenderDecl _ = False

219+

220+inputFile :: Parser FilePath

221+inputFile = strArgument $

222+ metavar "FILE"

223+ <> help "The input .purs file(s)"

224+

225+pscDocsOptions :: Parser PSCDocsOptions

226+pscDocsOptions = PSCDocsOptions <$> many inputFile

227+

228+main :: IO ()

229+main = execParser opts >>= docgen

230+ where

231+ opts = info (version <*> helper <*> pscDocsOptions) infoModList

232+ infoModList = fullDesc <> headerInfo <> footerInfo

233+ headerInfo = header "psc-docs - Generate Markdown documentation from PureScript extern files"

234+ footerInfo = footer $ "psc-docs " ++ showVersion Paths.version

235+

236+ version :: Parser (a -> a)

237+ version = abortOption (InfoMsg (showVersion Paths.version)) $ long "version" <> help "Show the version number" <> hidden

psc-make/Main.hsnew file+177

@@ -0,0 +1,177 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : Main

4+-- Copyright : (c) Phil Freeman 2013

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- |

12+--

13+-----------------------------------------------------------------------------

14+

15+{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, TupleSections, RecordWildCards #-}

16+

17+module Main where

18+

19+import Control.Applicative

20+import Control.Monad.Except

21+import Control.Monad.Reader

22+

23+import Data.Version (showVersion)

24+import Data.Traversable (traverse)

25+

26+import Options.Applicative as Opts

27+

28+import System.Directory

29+ (doesFileExist, getModificationTime, createDirectoryIfMissing)

30+import System.FilePath (takeDirectory)

31+import System.Exit (exitSuccess, exitFailure)

32+import System.IO.Error (tryIOError)

33+

34+import qualified Language.PureScript as P

35+import qualified Paths_purescript as Paths

36+

37+

38+data PSCMakeOptions = PSCMakeOptions

39+ { pscmInput :: [FilePath]

40+ , pscmOutputDir :: FilePath

41+ , pscmOpts :: P.Options P.Make

42+ , pscmUsePrefix :: Bool

43+ }

44+

45+data InputOptions = InputOptions

46+ { ioNoPrelude :: Bool

47+ , ioInputFiles :: [FilePath]

48+ }

49+

50+readInput :: InputOptions -> IO [(Either P.RebuildPolicy FilePath, String)]

51+readInput InputOptions{..} = do

52+ content <- forM ioInputFiles $ \inFile -> (Right inFile, ) <$> readFile inFile

53+ return (if ioNoPrelude then content else (Left P.RebuildNever, P.prelude) : content)

54+

55+newtype Make a = Make { unMake :: ReaderT (P.Options P.Make) (ExceptT String IO) a }

56+ deriving (Functor, Applicative, Monad, MonadIO, MonadError String, MonadReader (P.Options P.Make))

57+

58+runMake :: P.Options P.Make -> Make a -> IO (Either String a)

59+runMake opts = runExceptT . flip runReaderT opts . unMake

60+

61+makeIO :: IO a -> Make a

62+makeIO = Make . lift . ExceptT . fmap (either (Left . show) Right) . tryIOError

63+

64+instance P.MonadMake Make where

65+ getTimestamp path = makeIO $ do

66+ exists <- doesFileExist path

67+ traverse (const $ getModificationTime path) $ guard exists

68+ readTextFile path = makeIO $ do

69+ putStrLn $ "Reading " ++ path

70+ readFile path

71+ writeTextFile path text = makeIO $ do

72+ mkdirp path

73+ putStrLn $ "Writing " ++ path

74+ writeFile path text

75+ progress = makeIO . putStrLn

76+

77+compile :: PSCMakeOptions -> IO ()

78+compile (PSCMakeOptions input outputDir opts usePrefix) = do

79+ modules <- P.parseModulesFromFiles (either (const "") id) <$> readInput (InputOptions (P.optionsNoPrelude opts) input)

80+ case modules of

81+ Left err -> do

82+ print err

83+ exitFailure

84+ Right ms -> do

85+ e <- runMake opts $ P.make outputDir ms prefix

86+ case e of

87+ Left err -> do

88+ putStrLn err

89+ exitFailure

90+ Right _ -> do

91+ exitSuccess

92+ where

93+ prefix = if usePrefix

94+ then ["Generated by psc-make version " ++ showVersion Paths.version]

95+ else []

96+

97+mkdirp :: FilePath -> IO ()

98+mkdirp = createDirectoryIfMissing True . takeDirectory

99+

100+inputFile :: Parser FilePath

101+inputFile = strArgument $

102+ metavar "FILE"

103+ <> help "The input .purs file(s)"

104+

105+outputDirectory :: Parser FilePath

106+outputDirectory = strOption $

107+ short 'o'

108+ <> long "output"

109+ <> Opts.value "output"

110+ <> showDefault

111+ <> help "The output directory"

112+

113+noTco :: Parser Bool

114+noTco = switch $

115+ long "no-tco"

116+ <> help "Disable tail call optimizations"

117+

118+noPrelude :: Parser Bool

119+noPrelude = switch $

120+ long "no-prelude"

121+ <> help "Omit the Prelude"

122+

123+noMagicDo :: Parser Bool

124+noMagicDo = switch $

125+ long "no-magic-do"

126+ <> help "Disable the optimization that overloads the do keyword to generate efficient code specifically for the Eff monad."

127+

128+noOpts :: Parser Bool

129+noOpts = switch $

130+ long "no-opts"

131+ <> help "Skip the optimization phase."

132+

133+comments :: Parser Bool

134+comments = switch $

135+ short 'c'

136+ <> long "comments"

137+ <> help "Include comments in the generated code."

138+

139+verboseErrors :: Parser Bool

140+verboseErrors = switch $

141+ short 'v'

142+ <> long "verbose-errors"

143+ <> help "Display verbose error messages"

144+

145+noPrefix :: Parser Bool

146+noPrefix = switch $

147+ short 'p'

148+ <> long "no-prefix"

149+ <> help "Do not include comment header"

150+

151+

152+options :: Parser (P.Options P.Make)

153+options = P.Options <$> noPrelude

154+ <*> noTco

155+ <*> noMagicDo

156+ <*> pure Nothing

157+ <*> noOpts

158+ <*> comments

159+ <*> verboseErrors

160+ <*> pure P.MakeOptions

161+

162+pscMakeOptions :: Parser PSCMakeOptions

163+pscMakeOptions = PSCMakeOptions <$> many inputFile

164+ <*> outputDirectory

165+ <*> options

166+ <*> (not <$> noPrefix)

167+

168+main :: IO ()

169+main = execParser opts >>= compile

170+ where

171+ opts = info (version <*> helper <*> pscMakeOptions) infoModList

172+ infoModList = fullDesc <> headerInfo <> footerInfo

173+ headerInfo = header "psc-make - Compiles PureScript to Javascript"

174+ footerInfo = footer $ "psc-make " ++ showVersion Paths.version

175+

176+ version :: Parser (a -> a)

177+ version = abortOption (InfoMsg (showVersion Paths.version)) $ long "version" <> help "Show the version number" <> hidden

psc/Main.hsnew file+209

@@ -0,0 +1,209 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : Main

4+-- Copyright : (c) Phil Freeman 2013

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- |

12+--

13+-----------------------------------------------------------------------------

14+

15+{-# LANGUAGE DataKinds, GeneralizedNewtypeDeriving, TupleSections, RecordWildCards #-}

16+

17+module Main where

18+

19+import Control.Applicative

20+import Control.Monad.Except

21+import Control.Monad.Reader

22+

23+import Data.Maybe (fromMaybe)

24+import Data.Version (showVersion)

25+

26+import Options.Applicative as Opts

27+import System.Directory (createDirectoryIfMissing)

28+import System.FilePath (takeDirectory)

29+import System.Exit (exitSuccess, exitFailure)

30+import System.IO (hPutStrLn, stderr)

31+

32+import qualified Language.PureScript as P

33+import qualified Paths_purescript as Paths

34+

35+

36+data PSCOptions = PSCOptions

37+ { pscInput :: [FilePath]

38+ , pscOpts :: P.Options P.Compile

39+ , pscStdIn :: Bool

40+ , pscOutput :: Maybe FilePath

41+ , pscExterns :: Maybe FilePath

42+ , pscUsePrefix :: Bool

43+ }

44+

45+data InputOptions = InputOptions

46+ { ioNoPrelude :: Bool

47+ , ioUseStdIn :: Bool

48+ , ioInputFiles :: [FilePath]

49+ }

50+

51+readInput :: InputOptions -> IO [(Maybe FilePath, String)]

52+readInput InputOptions{..}

53+ | ioUseStdIn = return . (Nothing ,) <$> getContents

54+ | otherwise = do content <- forM ioInputFiles $ \inFile -> (Just inFile, ) <$> readFile inFile

55+ return (if ioNoPrelude then content else (Nothing, P.prelude) : content)

56+

57+compile :: PSCOptions -> IO ()

58+compile (PSCOptions input opts stdin output externs usePrefix) = do

59+ modules <- P.parseModulesFromFiles (fromMaybe "") <$> readInput (InputOptions (P.optionsNoPrelude opts) stdin input)

60+ case modules of

61+ Left err -> do

62+ hPutStrLn stderr $ show err

63+ exitFailure

64+ Right ms -> do

65+ case P.compile (map snd ms) prefix `runReaderT` opts of

66+ Left err -> do

67+ hPutStrLn stderr err

68+ exitFailure

69+ Right (js, exts, _) -> do

70+ case output of

71+ Just path -> mkdirp path >> writeFile path js

72+ Nothing -> putStrLn js

73+ case externs of

74+ Just path -> mkdirp path >> writeFile path exts

75+ Nothing -> return ()

76+ exitSuccess

77+ where

78+ prefix = if usePrefix

79+ then ["Generated by psc version " ++ showVersion Paths.version]

80+ else []

81+

82+mkdirp :: FilePath -> IO ()

83+mkdirp = createDirectoryIfMissing True . takeDirectory

84+

85+codeGenModule :: Parser String

86+codeGenModule = strOption $

87+ long "codegen"

88+ <> help "A list of modules for which Javascript and externs should be generated. This argument can be used multiple times."

89+

90+dceModule :: Parser String

91+dceModule = strOption $

92+ short 'm'

93+ <> long "module"

94+ <> help "Enables dead code elimination, all code which is not a transitive dependency of a specified module will be removed. This argument can be used multiple times."

95+

96+browserNamespace :: Parser String

97+browserNamespace = strOption $

98+ long "browser-namespace"

99+ <> Opts.value "PS"

100+ <> showDefault

101+ <> help "Specify the namespace that PureScript modules will be exported to when running in the browser."

102+

103+verboseErrors :: Parser Bool

104+verboseErrors = switch $

105+ short 'v'

106+ <> long "verbose-errors"

107+ <> help "Display verbose error messages"

108+

109+noOpts :: Parser Bool

110+noOpts = switch $

111+ long "no-opts"

112+ <> help "Skip the optimization phase."

113+

114+runMain :: Parser (Maybe String)

115+runMain = optional $ noArgs <|> withArgs

116+ where

117+ defaultVal = "Main"

118+ noArgs = flag' defaultVal (long "main")

119+ withArgs = strOption $

120+ long "main"

121+ <> help (concat [

122+ "Generate code to run the main method in the specified module. ",

123+ "(no argument: \"", defaultVal, "\")"

124+ ])

125+

126+noMagicDo :: Parser Bool

127+noMagicDo = switch $

128+ long "no-magic-do"

129+ <> help "Disable the optimization that overloads the do keyword to generate efficient code specifically for the Eff monad."

130+

131+noTco :: Parser Bool

132+noTco = switch $

133+ long "no-tco"

134+ <> help "Disable tail call optimizations"

135+

136+noPrelude :: Parser Bool

137+noPrelude = switch $

138+ long "no-prelude"

139+ <> help "Omit the Prelude"

140+

141+comments :: Parser Bool

142+comments = switch $

143+ short 'c'

144+ <> long "comments"

145+ <> help "Include comments in the generated code."

146+

147+useStdIn :: Parser Bool

148+useStdIn = switch $

149+ short 's'

150+ <> long "stdin"

151+ <> help "Read from standard input"

152+

153+inputFile :: Parser FilePath

154+inputFile = strArgument $

155+ metavar "FILE"

156+ <> help "The input .purs file(s)"

157+

158+outputFile :: Parser (Maybe FilePath)

159+outputFile = optional . strOption $

160+ short 'o'

161+ <> long "output"

162+ <> help "The output .js file"

163+

164+externsFile :: Parser (Maybe FilePath)

165+externsFile = optional . strOption $

166+ short 'e'

167+ <> long "externs"

168+ <> help "The output .e.purs file"

169+

170+noPrefix :: Parser Bool

171+noPrefix = switch $

172+ short 'p'

173+ <> long "no-prefix"

174+ <> help "Do not include comment header"

175+

176+options :: Parser (P.Options P.Compile)

177+options = P.Options <$> noPrelude

178+ <*> noTco

179+ <*> noMagicDo

180+ <*> runMain

181+ <*> noOpts

182+ <*> verboseErrors

183+ <*> comments

184+ <*> additionalOptions

185+ where

186+ additionalOptions =

187+ P.CompileOptions <$> browserNamespace

188+ <*> many dceModule

189+ <*> many codeGenModule

190+

191+pscOptions :: Parser PSCOptions

192+pscOptions = PSCOptions <$> many inputFile

193+ <*> options

194+ <*> useStdIn

195+ <*> outputFile

196+ <*> externsFile

197+ <*> (not <$> noPrefix)

198+

199+main :: IO ()

200+main = execParser opts >>= compile

201+ where

202+ opts = info (version <*> helper <*> pscOptions) infoModList

203+ infoModList = fullDesc <> headerInfo <> footerInfo

204+ headerInfo = header "psc - Compiles PureScript to Javascript"

205+ footerInfo = footer $ "psc " ++ showVersion Paths.version

206+

207+ version :: Parser (a -> a)

208+ version = abortOption (InfoMsg (showVersion Paths.version)) $ long "version" <> help "Show the version number" <> hidden

209+

psci/Commands.hsnew file+87

@@ -0,0 +1,87 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : Commands

4+-- Copyright : (c) Phil Freeman 2014

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- |

12+-- Commands for PSCI.

13+--

14+-----------------------------------------------------------------------------

15+

16+module Commands where

17+

18+import Language.PureScript

19+

20+-- |

21+-- Valid Meta-commands for PSCI

22+--

23+data Command

24+ -- |

25+ -- A purescript expression

26+ --

27+ = Expression Expr

28+ -- |

29+ -- Show the help command

30+ --

31+ | Help

32+ -- |

33+ -- Import a module from a loaded file

34+ --

35+ | Import ModuleName

36+ -- |

37+ -- Browse a module

38+ --

39+ | Browse ModuleName

40+ -- |

41+ -- Load a file for use with importing

42+ --

43+ | LoadFile FilePath

44+ -- |

45+ -- Exit PSCI

46+ --

47+ | Quit

48+ -- |

49+ -- Reset the state of the REPL

50+ --

51+ | Reset

52+ -- |

53+ -- Binds a value to a name

54+ --

55+ | Let [Declaration]

56+ -- |

57+ -- Find the type of an expression

58+ --

59+ | TypeOf Expr

60+ -- |

61+ -- Find the kind of an expression

62+ --

63+ | KindOf Type

64+ -- |

65+ -- Show command

66+ --

67+ | Show String

68+

69+-- |

70+-- The help menu.

71+--

72+help :: [(String, String, String)]

73+help =

74+ [ (":?", "", "Show this help menu")

75+ , (":i", "<module>", "Import <module> for use in PSCI")

76+ , (":b", "<module>", "Browse <module>")

77+ , (":m", "<file>", "Load <file> for importing")

78+ , (":q", "", "Quit PSCi")

79+ , (":r", "", "Reset")

80+ , (":s", "import", "Show imported modules")

81+ , (":s", "loaded", "Show loaded modules")

82+ , (":t", "<expr>", "Show the type of <expr>")

83+ , (":k", "<type>", "Show the kind of <type>")

84+ ]

85+

86+commands :: [String]

87+commands = map (\ (a, _, _) -> a) help

psci/Main.hsnew file+661

@@ -0,0 +1,661 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : Main

4+-- Copyright : (c) Phil Freeman 2013

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- |

12+-- PureScript Compiler Interactive.

13+--

14+-----------------------------------------------------------------------------

15+

16+{-# LANGUAGE DataKinds #-}

17+{-# LANGUAGE DoAndIfThenElse #-}

18+{-# LANGUAGE FlexibleContexts #-}

19+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

20+{-# LANGUAGE RecordWildCards #-}

21+

22+module Main where

23+

24+import Data.Foldable (traverse_)

25+import Data.List (intercalate, isPrefixOf, nub, sortBy, sort)

26+import Data.Maybe (mapMaybe)

27+import Data.Traversable (traverse)

28+import Data.Version (showVersion)

29+import Data.Char (isSpace)

30+import qualified Data.Map as M

31+

32+import Control.Applicative

33+import Control.Monad

34+import Control.Monad.Except (ExceptT(..), MonadError, runExceptT)

35+import Control.Monad.Reader (MonadReader, ReaderT, runReaderT)

36+import Control.Monad.Trans.Class

37+import Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)

38+import Control.Monad.Trans.State.Strict

39+import qualified Control.Monad.Trans.State.Lazy as L

40+

41+import Options.Applicative as Opts

42+

43+import System.Console.Haskeline

44+import System.Directory (createDirectoryIfMissing, getModificationTime, doesFileExist, findExecutable, getHomeDirectory, getCurrentDirectory)

45+import System.Exit

46+import System.FilePath (pathSeparator, takeDirectory, (</>), isPathSeparator)

47+import System.IO.Error (tryIOError)

48+import System.Process (readProcessWithExitCode)

49+

50+import qualified Text.Parsec as Par (ParseError)

51+

52+import qualified Language.PureScript as P

53+import qualified Language.PureScript.AST as D

54+import qualified Language.PureScript.Names as N

55+import qualified Paths_purescript as Paths

56+

57+import Commands as C

58+import Parser

59+

60+data PSCiOptions = PSCiOptions

61+ { psciMultiLineMode :: Bool

62+ , psciInputFile :: [FilePath]

63+ , psciInputNodeFlags :: [String]

64+ }

65+

66+-- |

67+-- The PSCI state.

68+-- Holds a list of imported modules, loaded files, and partial let bindings.

69+-- The let bindings are partial,

70+-- because it makes more sense to apply the binding to the final evaluated expression.

71+--

72+data PSCiState = PSCiState

73+ { psciImportedFilenames :: [FilePath]

74+ , psciImportedModuleNames :: [P.ModuleName]

75+ , psciLoadedModules :: [(Either P.RebuildPolicy FilePath, P.Module)]

76+ , psciLetBindings :: [P.Declaration]

77+ , psciNodeFlags :: [String]

78+ }

79+

80+-- State helpers

81+

82+-- |

83+-- Updates the state to have more imported modules.

84+--

85+updateImportedFiles :: FilePath -> PSCiState -> PSCiState

86+updateImportedFiles filename st = st { psciImportedFilenames = filename : psciImportedFilenames st }

87+

88+-- |

89+-- Updates the state to have more imported modules.

90+--

91+updateImports :: P.ModuleName -> PSCiState -> PSCiState

92+updateImports name st = st { psciImportedModuleNames = name : psciImportedModuleNames st }

93+

94+-- |

95+-- Updates the state to have more loaded files.

96+--

97+updateModules :: [(Either P.RebuildPolicy FilePath, P.Module)] -> PSCiState -> PSCiState

98+updateModules modules st = st { psciLoadedModules = psciLoadedModules st ++ modules }

99+

100+-- |

101+-- Updates the state to have more let bindings.

102+--

103+updateLets :: [P.Declaration] -> PSCiState -> PSCiState

104+updateLets ds st = st { psciLetBindings = psciLetBindings st ++ ds }

105+

106+-- File helpers

107+-- |

108+-- Load the necessary modules.

109+--

110+defaultImports :: [P.ModuleName]

111+defaultImports = [P.ModuleName [P.ProperName "Prelude"]]

112+

113+-- |

114+-- Locates the node executable.

115+-- Checks for either @nodejs@ or @node@.

116+--

117+findNodeProcess :: IO (Maybe String)

118+findNodeProcess = runMaybeT . msum $ map (MaybeT . findExecutable) names

119+ where names = ["nodejs", "node"]

120+

121+-- |

122+-- Grabs the filename where the history is stored.

123+--

124+getHistoryFilename :: IO FilePath

125+getHistoryFilename = do

126+ home <- getHomeDirectory

127+ let filename = home </> ".purescript" </> "psci_history"

128+ mkdirp filename

129+ return filename

130+

131+-- |

132+-- Loads a file for use with imports.

133+--

134+loadModule :: FilePath -> IO (Either String [P.Module])

135+loadModule filename = do

136+ content <- readFile filename

137+ return $ either (Left . show) (Right . map snd) $ P.parseModulesFromFiles id [(filename, content)]

138+

139+-- |

140+-- Load all modules, including the Prelude

141+--

142+loadAllModules :: [FilePath] -> IO (Either Par.ParseError [(Either P.RebuildPolicy FilePath, P.Module)])

143+loadAllModules files = do

144+ filesAndContent <- forM files $ \filename -> do

145+ content <- readFile filename

146+ return (Right filename, content)

147+ return $ P.parseModulesFromFiles (either (const "") id) $ (Left P.RebuildNever, P.prelude) : filesAndContent

148+

149+-- |

150+-- Load all modules, updating the application state

151+--

152+loadAllImportedModules :: PSCI ()

153+loadAllImportedModules = do

154+ files <- PSCI . lift $ fmap psciImportedFilenames get

155+ modulesOrFirstError <- psciIO $ loadAllModules files

156+ case modulesOrFirstError of

157+ Left err -> psciIO $ print err

158+ Right modules -> PSCI . lift . modify $ \st -> st { psciLoadedModules = modules }

159+

160+-- |

161+-- Expands tilde in path.

162+--

163+expandTilde :: FilePath -> IO FilePath

164+expandTilde ('~':p:rest) | isPathSeparator p = (</> rest) <$> getHomeDirectory

165+expandTilde p = return p

166+-- Messages

167+

168+-- |

169+-- The help message.

170+--

171+helpMessage :: String

172+helpMessage = "The following commands are available:\n\n " ++

173+ intercalate "\n " (map line C.help)

174+ where line :: (String, String, String) -> String

175+ line (cmd, arg, desc) = intercalate " " [cmd, arg, replicate (11 - length arg) ' ', desc]

176+

177+-- |

178+-- The welcome prologue.

179+--

180+prologueMessage :: String

181+prologueMessage = intercalate "\n"

182+ [ " ____ ____ _ _ "

183+ , "| _ \\ _ _ _ __ ___/ ___| ___ _ __(_)_ __ | |_ "

184+ , "| |_) | | | | '__/ _ \\___ \\ / __| '__| | '_ \\| __|"

185+ , "| __/| |_| | | | __/___) | (__| | | | |_) | |_ "

186+ , "|_| \\__,_|_| \\___|____/ \\___|_| |_| .__/ \\__|"

187+ , " |_| "

188+ , ""

189+ , ":? shows help"

190+ ]

191+

192+-- |

193+-- The quit message.

194+--

195+quitMessage :: String

196+quitMessage = "See ya!"

197+

198+-- Haskeline completions

199+

200+data CompletionContext = Command String | FilePath String | Module | Identifier

201+ | Type | Fixed [String] | Multiple [CompletionContext]

202+ deriving (Show)

203+

204+-- |

205+-- Decide what kind of completion we need based on input.

206+completionContext :: String -> String -> Maybe CompletionContext

207+completionContext cmd@"" _ = Just $ Multiple [Command cmd, Identifier]

208+completionContext cmd@(':' : _ ) _

209+ | cmd `elem` C.commands || cmd == ":" = Just $ Command cmd

210+completionContext (':' : c : _) word = case c of

211+ 'i' -> Just Module

212+ 'b' -> Just Module

213+ 'm' -> Just $ FilePath word

214+ 'q' -> Nothing

215+ 'r' -> Nothing

216+ '?' -> Nothing

217+ 's' -> Just $ Fixed ["import", "loaded"]

218+ 't' -> Just Identifier

219+ 'k' -> Just Type

220+ _ -> Nothing

221+completionContext _ _ = Just Identifier

222+

223+-- |

224+-- Loads module, function, and file completions.

225+--

226+completion :: CompletionFunc (StateT PSCiState IO)

227+completion = completeWordWithPrev Nothing " \t\n\r" findCompletions

228+ where

229+ findCompletions :: String -> String -> StateT PSCiState IO [Completion]

230+ findCompletions prev word = do

231+ let ctx = completionContext ((dropWhile isSpace (reverse prev)) ++ word) word

232+ completions <- case ctx of

233+ Nothing -> return []

234+ (Just c) -> (mapMaybe $ either (\cand -> if word `isPrefixOf` cand

235+ then Just $ simpleCompletion cand

236+ else Nothing) Just)

237+ <$> getCompletion c

238+ return $ sortBy sorter completions

239+

240+ getCompletion :: CompletionContext -> StateT PSCiState IO [Either String Completion]

241+ getCompletion (Command s) = return $ (map Left) $ nub $ filter (isPrefixOf s) C.commands

242+ getCompletion (FilePath f) = (map Right) <$> listFiles f

243+ getCompletion Module = (map Left) <$> getModuleNames

244+ getCompletion Identifier = (map Left) <$> ((++) <$> getIdentNames <*> getDctorNames)

245+ getCompletion Type = (map Left) <$> getTypeNames

246+ getCompletion (Fixed list) = return $ (map Left) list

247+ getCompletion (Multiple contexts) = concat <$> mapM getCompletion contexts

248+

249+ getLoadedModules :: StateT PSCiState IO [P.Module]

250+ getLoadedModules = map snd . psciLoadedModules <$> get

251+

252+ getModuleNames :: StateT PSCiState IO [String]

253+ getModuleNames = moduleNames <$> getLoadedModules

254+

255+ mapLoadedModulesAndQualify :: (Show a) => (P.Module -> [a]) -> StateT PSCiState IO [String]

256+ mapLoadedModulesAndQualify f = do

257+ ms <- getLoadedModules

258+ q <- sequence [qualifyIfNeeded m (f m) | m <- ms]

259+ return $ concat q

260+

261+ getIdentNames :: StateT PSCiState IO [String]

262+ getIdentNames = mapLoadedModulesAndQualify identNames

263+

264+ getDctorNames :: StateT PSCiState IO [String]

265+ getDctorNames = mapLoadedModulesAndQualify dctorNames

266+

267+ getTypeNames :: StateT PSCiState IO [String]

268+ getTypeNames = mapLoadedModulesAndQualify typeDecls

269+

270+ qualifyIfNeeded :: (Show a) => P.Module -> [a] -> StateT PSCiState IO [String]

271+ qualifyIfNeeded m decls = do

272+ let name = P.getModuleName m

273+ imported <- psciImportedModuleNames <$> get

274+ let qualified = map (P.Qualified $ Just name) decls

275+ if name `elem` imported then

276+ return $ map show $ qualified ++ (map (P.Qualified Nothing) decls)

277+ else

278+ return $ map show qualified

279+

280+ typeDecls :: P.Module -> [N.ProperName]

281+ typeDecls m = mapMaybe getTypeName $ filter P.isDataDecl (P.exportedDeclarations m)

282+ where getTypeName :: P.Declaration -> Maybe N.ProperName

283+ getTypeName (P.TypeSynonymDeclaration name _ _) = Just name

284+ getTypeName (P.DataDeclaration _ name _ _) = Just name

285+ getTypeName (P.PositionedDeclaration _ _ d) = getTypeName d

286+ getTypeName _ = Nothing

287+

288+ identNames :: P.Module -> [N.Ident]

289+ identNames (P.Module _ _ ds exports) = nub [ ident | ident <- mapMaybe (getDeclName exports) (D.flattenDecls ds) ]

290+ where getDeclName :: Maybe [P.DeclarationRef] -> P.Declaration -> Maybe P.Ident

291+ getDeclName exts decl@(P.ValueDeclaration ident _ _ _) | P.isExported exts decl = Just ident

292+ getDeclName exts decl@(P.ExternDeclaration _ ident _ _) | P.isExported exts decl = Just ident

293+ getDeclName exts (P.PositionedDeclaration _ _ d) = getDeclName exts d

294+ getDeclName _ _ = Nothing

295+

296+ dctorNames :: P.Module -> [N.ProperName]

297+ dctorNames m = nub $ concat $ map (P.exportedDctors m) dnames

298+ where getDataDeclName :: P.Declaration -> Maybe N.ProperName

299+ getDataDeclName (P.DataDeclaration _ name _ _) = Just name

300+ getDataDeclName (P.PositionedDeclaration _ _ d) = getDataDeclName d

301+ getDataDeclName _ = Nothing

302+

303+ dnames :: [N.ProperName]

304+ dnames = (mapMaybe getDataDeclName onlyDataDecls)

305+

306+ onlyDataDecls :: [P.Declaration]

307+ onlyDataDecls = (filter P.isDataDecl (P.exportedDeclarations m))

308+

309+ moduleNames :: [P.Module] -> [String]

310+ moduleNames ms = nub [show moduleName | P.Module _ moduleName _ _ <- ms]

311+

312+ sorter :: Completion -> Completion -> Ordering

313+ sorter (Completion _ d1 _) (Completion _ d2 _) = if ":" `isPrefixOf` d1 then LT else compare d1 d2

314+

315+-- Compilation

316+

317+-- | Compilation options.

318+--

319+options :: P.Options P.Make

320+options = P.Options False False False Nothing False False False P.MakeOptions

321+

322+-- |

323+-- PSCI monad

324+--

325+newtype PSCI a = PSCI { runPSCI :: InputT (StateT PSCiState IO) a } deriving (Functor, Applicative, Monad)

326+

327+psciIO :: IO a -> PSCI a

328+psciIO io = PSCI . lift $ lift io

329+

330+newtype Make a = Make { unMake :: ReaderT (P.Options P.Make) (ExceptT String IO) a }

331+ deriving (Functor, Applicative, Monad, MonadError String, MonadReader (P.Options P.Make))

332+

333+runMake :: Make a -> IO (Either String a)

334+runMake = runExceptT . flip runReaderT options . unMake

335+

336+makeIO :: IO a -> Make a

337+makeIO = Make . lift . ExceptT . fmap (either (Left . show) Right) . tryIOError

338+

339+instance P.MonadMake Make where

340+ getTimestamp path = makeIO $ do

341+ exists <- doesFileExist path

342+ traverse (const $ getModificationTime path) $ guard exists

343+ readTextFile path = makeIO $ readFile path

344+ writeTextFile path text = makeIO $ do

345+ mkdirp path

346+ writeFile path text

347+ progress s = unless (s == "Compiling $PSCI") $ makeIO . putStrLn $ s

348+

349+mkdirp :: FilePath -> IO ()

350+mkdirp = createDirectoryIfMissing True . takeDirectory

351+

352+-- |

353+-- Makes a volatile module to execute the current expression.

354+--

355+createTemporaryModule :: Bool -> PSCiState -> P.Expr -> P.Module

356+createTemporaryModule exec PSCiState{psciImportedModuleNames = imports, psciLetBindings = lets} val =

357+ let

358+ moduleName = P.ModuleName [P.ProperName "$PSCI"]

359+ importDecl m = P.ImportDeclaration m P.Unqualified Nothing

360+ traceModule = P.ModuleName [P.ProperName "Debug", P.ProperName "Trace"]

361+ trace = P.Var (P.Qualified (Just traceModule) (P.Ident "print"))

362+ mainValue = P.App trace (P.Var (P.Qualified Nothing (P.Ident "it")))

363+ itDecl = P.ValueDeclaration (P.Ident "it") P.Value [] $ Right val

364+ mainDecl = P.ValueDeclaration (P.Ident "main") P.Value [] $ Right mainValue

365+ decls = if exec then [itDecl, mainDecl] else [itDecl]

366+ in

367+ P.Module [] moduleName ((importDecl `map` imports) ++ lets ++ decls) Nothing

368+

369+

370+-- |

371+-- Makes a volatile module to hold a non-qualified type synonym for a fully-qualified data type declaration.

372+--

373+createTemporaryModuleForKind :: PSCiState -> P.Type -> P.Module

374+createTemporaryModuleForKind PSCiState{psciImportedModuleNames = imports} typ =

375+ let

376+ moduleName = P.ModuleName [P.ProperName "$PSCI"]

377+ importDecl m = P.ImportDeclaration m P.Unqualified Nothing

378+ itDecl = P.TypeSynonymDeclaration (P.ProperName "IT") [] typ

379+ in

380+ P.Module [] moduleName ((importDecl `map` imports) ++ [itDecl]) Nothing

381+

382+-- |

383+-- Makes a volatile module to execute the current imports.

384+--

385+createTemporaryModuleForImports :: PSCiState -> P.Module

386+createTemporaryModuleForImports PSCiState{psciImportedModuleNames = imports} =

387+ let

388+ moduleName = P.ModuleName [P.ProperName "$PSCI"]

389+ importDecl m = P.ImportDeclaration m P.Unqualified Nothing

390+ in

391+ P.Module [] moduleName (importDecl `map` imports) Nothing

392+

393+modulesDir :: FilePath

394+modulesDir = ".psci_modules" ++ pathSeparator : "node_modules"

395+

396+indexFile :: FilePath

397+indexFile = ".psci_modules" ++ pathSeparator : "index.js"

398+

399+-- |

400+-- Takes a value declaration and evaluates it with the current state.

401+--

402+handleDeclaration :: P.Expr -> PSCI ()

403+handleDeclaration val = do

404+ st <- PSCI $ lift get

405+ let m = createTemporaryModule True st val

406+ let nodeArgs = psciNodeFlags st ++ [indexFile]

407+ e <- psciIO . runMake $ P.make modulesDir (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) []

408+ case e of

409+ Left err -> PSCI $ outputStrLn err

410+ Right _ -> do

411+ psciIO $ writeFile indexFile "require('$PSCI').main();"

412+ process <- psciIO findNodeProcess

413+ result <- psciIO $ traverse (\node -> readProcessWithExitCode node nodeArgs "") process

414+ case result of

415+ Just (ExitSuccess, out, _) -> PSCI $ outputStrLn out

416+ Just (ExitFailure _, _, err) -> PSCI $ outputStrLn err

417+ Nothing -> PSCI $ outputStrLn "Couldn't find node.js"

418+

419+-- |

420+-- Takes a let declaration and updates the environment, then run a make. If the declaration fails,

421+-- restore the pre-let environment.

422+--

423+handleLet :: [P.Declaration] -> PSCI ()

424+handleLet ds = do

425+ st <- PSCI $ lift get

426+ let st' = updateLets ds st

427+ let m = createTemporaryModule False st' (P.ObjectLiteral [])

428+ e <- psciIO . runMake $ P.make modulesDir (psciLoadedModules st' ++ [(Left P.RebuildAlways, m)]) []

429+ case e of

430+ Left err -> PSCI $ outputStrLn err

431+ Right _ -> PSCI $ lift (put st')

432+

433+-- |

434+-- Show actual loaded modules in psci.

435+--

436+handleShowLoadedModules :: PSCI ()

437+handleShowLoadedModules = do

438+ PSCiState { psciLoadedModules = loadedModules } <- PSCI $ lift get

439+ psciIO $ readModules loadedModules >>= putStrLn

440+ return ()

441+ where readModules = return . unlines . sort . nub . map toModuleName

442+ toModuleName = N.runModuleName . (\ (D.Module _ mdName _ _) -> mdName) . snd

443+

444+-- |

445+-- Show the imported modules in psci.

446+--

447+handleShowImportedModules :: PSCI ()

448+handleShowImportedModules = do

449+ PSCiState { psciImportedModuleNames = importedModuleNames } <- PSCI $ lift get

450+ psciIO $ readModules importedModuleNames >>= putStrLn

451+ return ()

452+ where readModules = return . unlines . sort . map N.runModuleName

453+

454+-- |

455+-- Imports a module, preserving the initial state on failure.

456+--

457+handleImport :: P.ModuleName -> PSCI ()

458+handleImport moduleName = do

459+ st <- updateImports moduleName <$> PSCI (lift get)

460+ let m = createTemporaryModuleForImports st

461+ e <- psciIO . runMake $ P.make modulesDir (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) []

462+ case e of

463+ Left err -> PSCI $ outputStrLn err

464+ Right _ -> do

465+ PSCI $ lift $ put st

466+ return ()

467+

468+-- |

469+-- Takes a value and prints its type

470+--

471+handleTypeOf :: P.Expr -> PSCI ()

472+handleTypeOf val = do

473+ st <- PSCI $ lift get

474+ let m = createTemporaryModule False st val

475+ e <- psciIO . runMake $ P.make modulesDir (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) []

476+ case e of

477+ Left err -> PSCI $ outputStrLn err

478+ Right env' ->

479+ case M.lookup (P.ModuleName [P.ProperName "$PSCI"], P.Ident "it") (P.names env') of

480+ Just (ty, _, _) -> PSCI . outputStrLn . P.prettyPrintType $ ty

481+ Nothing -> PSCI $ outputStrLn "Could not find type"

482+

483+-- |

484+-- Pretty print a module's signatures

485+--

486+printModuleSignatures :: P.ModuleName -> P.Environment -> PSCI ()

487+printModuleSignatures moduleName env =

488+ PSCI $ let namesEnv = P.names env

489+ moduleNamesIdent = (filter ((== moduleName) . fst) . M.keys) namesEnv

490+ in case moduleNamesIdent of

491+ [] -> outputStrLn $ "This module '"++ P.runModuleName moduleName ++"' does not export functions."

492+ _ -> ( outputStrLn

493+ . unlines

494+ . sort

495+ . map (showType . findType namesEnv)) moduleNamesIdent

496+ where findType :: M.Map (P.ModuleName, P.Ident) (P.Type, P.NameKind, P.NameVisibility) -> (P.ModuleName, P.Ident) -> (P.Ident, Maybe (P.Type, P.NameKind, P.NameVisibility))

497+ findType envNames m@(_, mIdent) = (mIdent, M.lookup m envNames)

498+ showType :: (P.Ident, Maybe (P.Type, P.NameKind, P.NameVisibility)) -> String

499+ showType (mIdent, Just (mType, _, _)) = show mIdent ++ " :: " ++ P.prettyPrintType mType

500+ showType _ = error "The impossible happened in printModuleSignatures."

501+

502+-- |

503+-- Browse a module and displays its signature (if module exists).

504+--

505+handleBrowse :: P.ModuleName -> PSCI ()

506+handleBrowse moduleName = do

507+ st <- PSCI $ lift get

508+ let loadedModules = psciLoadedModules st

509+ env <- psciIO . runMake $ P.make modulesDir loadedModules []

510+ case env of

511+ Left err -> PSCI $ outputStrLn err

512+ Right env' ->

513+ if moduleName `notElem` (nub . map ((\ (P.Module _ modName _ _ ) -> modName) . snd)) loadedModules

514+ then PSCI $ outputStrLn $ "Module '" ++ N.runModuleName moduleName ++ "' is not valid."

515+ else printModuleSignatures moduleName env'

516+

517+-- |

518+-- Takes a value and prints its kind

519+--

520+handleKindOf :: P.Type -> PSCI ()

521+handleKindOf typ = do

522+ st <- PSCI $ lift get

523+ let m = createTemporaryModuleForKind st typ

524+ mName = P.ModuleName [P.ProperName "$PSCI"]

525+ e <- psciIO . runMake $ P.make modulesDir (psciLoadedModules st ++ [(Left P.RebuildAlways, m)]) []

526+ case e of

527+ Left err -> PSCI $ outputStrLn err

528+ Right env' ->

529+ case M.lookup (P.Qualified (Just mName) $ P.ProperName "IT") (P.typeSynonyms env') of

530+ Just (_, typ') -> do

531+ let chk = P.CheckState env' 0 0 (Just mName)

532+ k = L.runStateT (P.unCheck (P.kindOf mName typ')) chk

533+ case k of

534+ Left errStack -> PSCI . outputStrLn . P.prettyPrintMultipleErrors False $ errStack

535+ Right (kind, _) -> PSCI . outputStrLn . P.prettyPrintKind $ kind

536+ Nothing -> PSCI $ outputStrLn "Could not find kind"

537+

538+-- Commands

539+

540+-- |

541+-- Parses the input and returns either a Metacommand or an expression.

542+--

543+getCommand :: Bool -> InputT (StateT PSCiState IO) (Either String (Maybe Command))

544+getCommand singleLineMode = do

545+ firstLine <- getInputLine "> "

546+ case firstLine of

547+ Nothing -> return (Right Nothing)

548+ Just "" -> return (Right Nothing)

549+ Just s | singleLineMode || head s == ':' -> return . either Left (Right . Just) $ parseCommand s

550+ Just s -> either Left (Right . Just) . parseCommand <$> go [s]

551+ where

552+ go :: [String] -> InputT (StateT PSCiState IO) String

553+ go ls = maybe (return . unlines $ reverse ls) (go . (:ls)) =<< getInputLine " "

554+

555+-- |

556+-- Performs an action for each meta-command given, and also for expressions..

557+--

558+handleCommand :: Command -> PSCI ()

559+handleCommand (Expression val) = handleDeclaration val

560+handleCommand Help = PSCI $ outputStrLn helpMessage

561+handleCommand (Import moduleName) = handleImport moduleName

562+handleCommand (Let l) = handleLet l

563+handleCommand (LoadFile filePath) = do

564+ absPath <- psciIO $ expandTilde filePath

565+ exists <- psciIO $ doesFileExist absPath

566+ if exists then do

567+ PSCI . lift $ modify (updateImportedFiles absPath)

568+ m <- psciIO $ loadModule absPath

569+ case m of

570+ Left err -> PSCI $ outputStrLn err

571+ Right mods -> PSCI . lift $ modify (updateModules (map ((,) (Right absPath)) mods))

572+ else

573+ PSCI . outputStrLn $ "Couldn't locate: " ++ filePath

574+handleCommand Reset = do

575+ files <- psciImportedFilenames <$> PSCI (lift get)

576+ PSCI . lift . modify $ \st -> st

577+ { psciImportedFilenames = files

578+ , psciImportedModuleNames = defaultImports

579+ , psciLetBindings = []

580+ }

581+ loadAllImportedModules

582+handleCommand (TypeOf val) = handleTypeOf val

583+handleCommand (KindOf typ) = handleKindOf typ

584+handleCommand (Browse moduleName) = handleBrowse moduleName

585+handleCommand (Show "loaded") = handleShowLoadedModules

586+handleCommand (Show "import") = handleShowImportedModules

587+handleCommand _ = PSCI $ outputStrLn "Unknown command"

588+

589+loadUserConfig :: IO (Maybe [Command])

590+loadUserConfig = do

591+ configFile <- (</> ".psci") <$> getCurrentDirectory

592+ exists <- doesFileExist configFile

593+ if exists

594+ then do

595+ ls <- lines <$> readFile configFile

596+ case mapM parseCommand ls of

597+ Left err -> print err >> exitFailure

598+ Right cs -> return $ Just cs

599+ else

600+ return Nothing

601+

602+-- |

603+-- The PSCI main loop.

604+--

605+loop :: PSCiOptions -> IO ()

606+loop PSCiOptions{..} = do

607+ config <- loadUserConfig

608+ modulesOrFirstError <- loadAllModules psciInputFile

609+ case modulesOrFirstError of

610+ Left err -> print err >> exitFailure

611+ Right modules -> do

612+ historyFilename <- getHistoryFilename

613+ let settings = defaultSettings { historyFile = Just historyFilename }

614+ flip evalStateT (PSCiState psciInputFile defaultImports modules [] psciInputNodeFlags) . runInputT (setComplete completion settings) $ do

615+ outputStrLn prologueMessage

616+ traverse_ (mapM_ (runPSCI . handleCommand)) config

617+ go

618+ where

619+ go :: InputT (StateT PSCiState IO) ()

620+ go = do

621+ c <- getCommand (not psciMultiLineMode)

622+ case c of

623+ Left err -> outputStrLn err >> go

624+ Right Nothing -> go

625+ Right (Just Quit) -> outputStrLn quitMessage

626+ Right (Just c') -> runPSCI (loadAllImportedModules >> handleCommand c') >> go

627+

628+multiLineMode :: Parser Bool

629+multiLineMode = switch $

630+ long "multi-line-mode"

631+ <> short 'm'

632+ <> Opts.help "Run in multi-line mode (use ^D to terminate commands)"

633+

634+inputFile :: Parser FilePath

635+inputFile = strArgument $

636+ metavar "FILE"

637+ <> Opts.help "Optional .purs files to load on start"

638+

639+nodeFlagsFlag :: Parser [String]

640+nodeFlagsFlag = option parser $

641+ long "node-opts"

642+ <> metavar "NODE_OPTS"

643+ <> Opts.help "Flags to pass to node, separated by spaces"

644+ where

645+ parser = words <$> str

646+

647+psciOptions :: Parser PSCiOptions

648+psciOptions = PSCiOptions <$> multiLineMode

649+ <*> many inputFile

650+ <*> nodeFlagsFlag

651+

652+main :: IO ()

653+main = execParser opts >>= loop

654+ where

655+ opts = info (version <*> helper <*> psciOptions) infoModList

656+ infoModList = fullDesc <> headerInfo <> footerInfo

657+ headerInfo = header "psci - Interactive mode for PureScript"

658+ footerInfo = footer $ "psci " ++ showVersion Paths.version

659+

660+ version :: Parser (a -> a)

661+ version = abortOption (InfoMsg (showVersion Paths.version)) $ long "version" <> Opts.help "Show the version number" <> hidden

psci/Parser.hsnew file+82

@@ -0,0 +1,82 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : Parser

4+-- Copyright : (c) Phil Freeman 2014

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- |

12+-- Parser for PSCI.

13+--

14+-----------------------------------------------------------------------------

15+

16+module Parser (

17+ parseCommand

18+ ) where

19+

20+import Prelude hiding (lex)

21+

22+import Commands

23+

24+import Data.Char (isSpace)

25+

26+import Control.Applicative hiding (many)

27+

28+import Text.Parsec hiding ((<|>))

29+

30+import qualified Language.PureScript as P

31+import qualified Language.PureScript.Parser.Common as C (mark, same)

32+

33+-- |

34+-- Parses PSCI metacommands or expressions input from the user.

35+--

36+parseCommand :: String -> Either String Command

37+parseCommand cmdString =

38+ case splitCommand cmdString of

39+ Just ('?', _) -> return Help

40+ Just ('q', _) -> return Quit

41+ Just ('r', _) -> return Reset

42+ Just ('i', moduleName) -> Import <$> parseRest P.moduleName moduleName

43+ Just ('b', moduleName) -> Browse <$> parseRest P.moduleName moduleName

44+ Just ('m', filename) -> return $ LoadFile (trimEnd filename)

45+ Just ('s', command) -> return $ Show (trimEnd command)

46+ Just ('t', expr) -> TypeOf <$> parseRest P.parseValue expr

47+ Just ('k', ty) -> KindOf <$> parseRest P.parseType ty

48+ Just _ -> Left $ "Unrecognized command. Type :? for help."

49+ Nothing -> parseRest (psciLet <|> psciExpression) cmdString

50+ where

51+ parseRest :: P.TokenParser a -> String -> Either String a

52+ parseRest p s = either (Left . show) Right $ do

53+ ts <- P.lex "" s

54+ P.runTokenParser "" (p <* eof) ts

55+

56+ trimEnd :: String -> String

57+ trimEnd = reverse . dropWhile isSpace . reverse

58+

59+ -- |

60+ -- Split a command into a command char and the trailing string

61+ --

62+ splitCommand :: String -> Maybe (Char, String)

63+ splitCommand (':' : c : s) = Just (c, dropWhile isSpace s)

64+ splitCommand _ = Nothing

65+

66+ -- |

67+ -- Parses expressions entered at the PSCI repl.

68+ --

69+ psciExpression :: P.TokenParser Command

70+ psciExpression = Expression <$> P.parseValue

71+

72+ -- |

73+ -- PSCI version of @let@.

74+ -- This is essentially let from do-notation.

75+ -- However, since we don't support the @Eff@ monad,

76+ -- we actually want the normal @let@.

77+ --

78+ psciLet :: P.TokenParser Command

79+ psciLet = Let <$> (P.reserved "let" *> P.indented *> manyDecls)

80+ where

81+ manyDecls :: P.TokenParser [P.Declaration]

82+ manyDecls = C.mark (many1 (C.same *> P.parseDeclaration))

psgo.cabaldeleted−145

@@ -1,145 +0,0 @@

1−cabal-version: 1.12

2−

3−-- This file has been generated from package.yaml by hpack version 0.35.0.

4−--

5−-- see: https://github.com/sol/hpack

6−

7−name: psgo

8−version: 0.1.0.0

9−description: Please see the README on Github at <https://github.com/andyarvanitis/purescript-native#readme>

10−homepage: https://github.com/andyarvanitis/purescript-native#readme

11−bug-reports: https://github.com/andyarvanitis/purescript-native/issues

12−author: Andy Arvanitis

13−maintainer: example@example.com

14−copyright: 2018 Andy Arvanitis

15−license: BSD3

16−license-file: LICENSE

17−build-type: Simple

18−extra-source-files:

19− README.md

20− ChangeLog.md

21− stack.yaml

22− support/ffi-loader.go

23− support/go.mod.ffi-loader

24− support/go.mod.output

25− support/go.mod.working

26−

27−source-repository head

28− type: git

29− location: https://github.com/andyarvanitis/purescript-native

30−

31−library

32− exposed-modules:

33− CodeGen.IL

34− CodeGen.IL.Common

35− CodeGen.IL.Optimizer

36− CodeGen.IL.Optimizer.Common

37− CodeGen.IL.Optimizer.Inliner

38− CodeGen.IL.Optimizer.MagicDo

39− CodeGen.IL.Optimizer.TCO

40− CodeGen.IL.Printer

41− Tests

42− other-modules:

43− Paths_psgo

44− hs-source-dirs:

45− src

46− default-extensions:

47− ConstraintKinds

48− DataKinds

49− DeriveFunctor

50− EmptyDataDecls

51− FlexibleContexts

52− KindSignatures

53− LambdaCase

54− MultiParamTypeClasses

55− NoImplicitPrelude

56− PatternGuards

57− PatternSynonyms

58− RankNTypes

59− RecordWildCards

60− OverloadedStrings

61− ScopedTypeVariables

62− TupleSections

63− ViewPatterns

64− build-depends:

65− aeson >=1.0 && <1.5

66− , base >=4.7 && <5

67− , base-compat >=0.6.0

68− , bytestring >=0.10.8.2 && <0.11

69− , containers

70− , directory

71− , file-embed

72− , filemanip

73− , filepath

74− , gitrev

75− , monad-parallel >=0.7.2.2 && <0.8

76− , mtl >=2.1.0 && <2.3.0

77− , pattern-arrows >=0.0.2 && <0.1

78− , process

79− , protolude >=0.1.6

80− , purescript

81− , safe >=0.3.9 && <0.4

82− , text

83− , transformers >=0.3.0 && <0.6

84− default-language: Haskell2010

85−

86−executable psgo

87− main-is: Main.hs

88− other-modules:

89− Paths_psgo

90− hs-source-dirs:

91− app

92− ghc-options: -threaded -rtsopts -with-rtsopts=-N

93− build-depends:

94− aeson >=1.0 && <1.5

95− , base >=4.7 && <5

96− , base-compat >=0.6.0

97− , bytestring >=0.10.8.2 && <0.11

98− , containers

99− , directory

100− , file-embed

101− , filemanip

102− , filepath

103− , gitrev

104− , monad-parallel >=0.7.2.2 && <0.8

105− , mtl >=2.1.0 && <2.3.0

106− , pattern-arrows >=0.0.2 && <0.1

107− , process

108− , protolude >=0.1.6

109− , psgo

110− , purescript

111− , safe >=0.3.9 && <0.4

112− , text

113− , transformers >=0.3.0 && <0.6

114− default-language: Haskell2010

115−

116−test-suite psgo-test

117− type: exitcode-stdio-1.0

118− main-is: Spec.hs

119− other-modules:

120− Paths_psgo

121− hs-source-dirs:

122− test

123− ghc-options: -threaded -rtsopts -with-rtsopts=-N

124− build-depends:

125− aeson >=1.0 && <1.5

126− , base >=4.7 && <5

127− , base-compat >=0.6.0

128− , bytestring >=0.10.8.2 && <0.11

129− , containers

130− , directory

131− , file-embed

132− , filemanip

133− , filepath

134− , gitrev

135− , monad-parallel >=0.7.2.2 && <0.8

136− , mtl >=2.1.0 && <2.3.0

137− , pattern-arrows >=0.0.2 && <0.1

138− , process

139− , protolude >=0.1.6

140− , psgo

141− , purescript

142− , safe >=0.3.9 && <0.4

143− , text

144− , transformers >=0.3.0 && <0.6

145− default-language: Haskell2010

purescript.cabalnew file+180

@@ -0,0 +1,180 @@

1+name: purescript

2+version: 0.6.8

3+cabal-version: >=1.8

4+build-type: Simple

5+license: MIT

6+license-file: LICENSE

8+maintainer: Phil Freeman <paf31@cantab.net>

9+stability: experimental

10+synopsis: PureScript Programming Language Compiler

11+description: A small strongly, statically typed programming language with expressive types, inspired by Haskell and compiling to Javascript.

12+category: Language

13+Homepage: http://www.purescript.org/

14+author: Phil Freeman <paf31@cantab.net>,

15+ Gary Burgess <gary.burgess@gmail.com>,

16+ Hardy Jones <jones3.hardy@gmail.com>

17+

18+extra-source-files: prelude/prelude.purs

19+ , examples/passing/*.purs

20+ , examples/failing/*.purs

21+

22+source-repository head

23+ type: git

24+ location: https://github.com/purescript/purescript.git

25+

26+library

27+ build-depends: base >=4.6 && <5,

28+ containers -any,

29+ unordered-containers -any,

30+ directory >= 1.2,

31+ filepath -any,

32+ mtl >= 2.1.0 && < 2.3.0,

33+ parsec -any,

34+ transformers >= 0.4.0 && < 0.5,

35+ utf8-string >= 1 && < 2,

36+ pattern-arrows >= 0.0.2 && < 0.1,

37+ file-embed >= 0.0.7 && < 0.0.8,

38+ time -any

39+ exposed-modules: Language.PureScript

40+ Language.PureScript.AST

41+ Language.PureScript.AST.Binders

42+ Language.PureScript.AST.Declarations

43+ Language.PureScript.AST.Operators

44+ Language.PureScript.AST.SourcePos

45+ Language.PureScript.AST.Traversals

46+ Language.PureScript.CodeGen

47+ Language.PureScript.CodeGen.Externs

48+ Language.PureScript.CodeGen.JS

49+ Language.PureScript.CodeGen.JS.AST

50+ Language.PureScript.CodeGen.JS.Common

51+ Language.PureScript.CodeGen.JS.Optimizer

52+ Language.PureScript.CodeGen.JS.Optimizer.Blocks

53+ Language.PureScript.CodeGen.JS.Optimizer.Common

54+ Language.PureScript.CodeGen.JS.Optimizer.Inliner

55+ Language.PureScript.CodeGen.JS.Optimizer.MagicDo

56+ Language.PureScript.CodeGen.JS.Optimizer.TCO

57+ Language.PureScript.CodeGen.JS.Optimizer.Unused

58+ Language.PureScript.Constants

59+ Language.PureScript.CoreFn

60+ Language.PureScript.CoreFn.Ann

61+ Language.PureScript.CoreFn.Binders

62+ Language.PureScript.CoreFn.Desugar

63+ Language.PureScript.CoreFn.Expr

64+ Language.PureScript.CoreFn.Literals

65+ Language.PureScript.CoreFn.Meta

66+ Language.PureScript.CoreFn.Module

67+ Language.PureScript.CoreFn.Traversals

68+ Language.PureScript.Comments

69+ Language.PureScript.DeadCodeElimination

70+ Language.PureScript.Environment

71+ Language.PureScript.Errors

72+ Language.PureScript.Kinds

73+ Language.PureScript.ModuleDependencies

74+ Language.PureScript.Names

75+ Language.PureScript.Options

76+ Language.PureScript.Parser

77+ Language.PureScript.Parser.Lexer

78+ Language.PureScript.Parser.Common

79+ Language.PureScript.Parser.Declarations

80+ Language.PureScript.Parser.Kinds

81+ Language.PureScript.Parser.State

82+ Language.PureScript.Parser.Types

83+ Language.PureScript.Pretty

84+ Language.PureScript.Pretty.Common

85+ Language.PureScript.Pretty.JS

86+ Language.PureScript.Pretty.Kinds

87+ Language.PureScript.Pretty.Types

88+ Language.PureScript.Pretty.Values

89+ Language.PureScript.Renamer

90+ Language.PureScript.Sugar

91+ Language.PureScript.Sugar.BindingGroups

92+ Language.PureScript.Sugar.CaseDeclarations

93+ Language.PureScript.Sugar.DoNotation

94+ Language.PureScript.Sugar.Names

95+ Language.PureScript.Sugar.ObjectWildcards

96+ Language.PureScript.Sugar.Operators

97+ Language.PureScript.Sugar.TypeClasses

98+ Language.PureScript.Sugar.TypeDeclarations

99+ Language.PureScript.Traversals

100+ Language.PureScript.TypeChecker

101+ Language.PureScript.TypeChecker.Entailment

102+ Language.PureScript.TypeChecker.Kinds

103+ Language.PureScript.TypeChecker.Monad

104+ Language.PureScript.TypeChecker.Rows

105+ Language.PureScript.TypeChecker.Skolems

106+ Language.PureScript.TypeChecker.Subsumption

107+ Language.PureScript.TypeChecker.Synonyms

108+ Language.PureScript.TypeChecker.Types

109+ Language.PureScript.TypeChecker.Unify

110+ Language.PureScript.TypeClassDictionaries

111+ Language.PureScript.Types

112+

113+ Control.Monad.Unify

114+ Control.Monad.Supply

115+ Control.Monad.Supply.Class

116+ exposed: True

117+ buildable: True

118+ hs-source-dirs: src

119+ other-modules: Paths_purescript

120+ ghc-options: -Wall -O2

121+

122+executable psc

123+ build-depends: base >=4 && <5, containers -any, directory -any, filepath -any,

124+ mtl -any, optparse-applicative >= 0.10.0, parsec -any, purescript -any,

125+ transformers -any

126+ main-is: Main.hs

127+ buildable: True

128+ hs-source-dirs: psc

129+ other-modules:

130+ ghc-options: -Wall -O2 -fno-warn-unused-do-bind

131+

132+executable psc-make

133+ build-depends: base >=4 && <5, containers -any, directory -any, filepath -any,

134+ mtl -any, optparse-applicative >= 0.10.0, parsec -any, purescript -any,

135+ transformers -any

136+ main-is: Main.hs

137+ buildable: True

138+ hs-source-dirs: psc-make

139+ other-modules:

140+ ghc-options: -Wall -O2 -fno-warn-unused-do-bind

141+

142+executable psci

143+ build-depends: base >=4 && <5, containers -any, directory -any, filepath -any,

144+ mtl -any, optparse-applicative >= 0.10.0, parsec -any,

145+ haskeline >= 0.7.0.0, purescript -any, transformers -any,

146+ process -any

147+

148+ main-is: Main.hs

149+ buildable: True

150+ hs-source-dirs: psci

151+ other-modules: Commands

152+ Parser

153+ ghc-options: -Wall -O2

154+

155+executable psc-docs

156+ build-depends: base >=4 && <5, purescript -any,

157+ optparse-applicative >= 0.10.0, process -any, mtl -any

158+ main-is: Main.hs

159+ buildable: True

160+ hs-source-dirs: psc-docs

161+ other-modules:

162+ ghc-options: -Wall -O2

163+

164+executable psc-hierarchy

165+ build-depends: base >=4 && <5, purescript -any, optparse-applicative >= 0.10.0,

166+ process -any, mtl -any, parsec -any, filepath -any, directory -any

167+ main-is: Main.hs

168+ buildable: True

169+ hs-source-dirs: hierarchy

170+ other-modules:

171+ ghc-options: -Wall -O2

172+

173+test-suite tests

174+ build-depends: base >=4 && <5, containers -any, directory -any,

175+ filepath -any, mtl -any, parsec -any, purescript -any,

176+ transformers -any, process -any

177+ type: exitcode-stdio-1.0

178+ main-is: Main.hs

179+ buildable: True

180+ hs-source-dirs: tests

src/CodeGen/IL.hsdeleted−321

@@ -1,321 +0,0 @@

1−-- | This module generates code in the core imperative representation from

2−-- elaborated PureScript code.

3−module CodeGen.IL

4− ( module AST

5− , module Common

6− , moduleToIL

7− ) where

8−

9−import Prelude.Compat

10−import Protolude (ordNub)

11−

12−import Control.Arrow ((&&&))

13−import Control.Monad (forM, liftM, replicateM, void)

14−import Control.Monad.Supply.Class

15−

16−import Data.List ((\\), delete, intersect, nub)

17−import qualified Data.Foldable as F

18−import qualified Data.Map as M

19−import Data.Maybe (fromMaybe, isNothing, mapMaybe)

20−import Data.Monoid ((<>))

21−import Data.String (fromString)

22−import Data.Text (Text)

23−import qualified Data.Text as T

24−

25−import Language.PureScript.AST.SourcePos

26−import Language.PureScript.CoreImp.AST (AST)

27−import qualified Language.PureScript.CoreImp.AST as AST

28−import Language.PureScript.CoreFn

29−import Language.PureScript.Crash

30−import Language.PureScript.Names

31−import Language.PureScript.Options

32−import Language.PureScript.PSString (PSString, mkString)

33−import Language.PureScript.Traversals (sndM)

34−import qualified Language.PureScript.Constants as C

35−

36−import System.FilePath.Posix ((</>))

37−

38−import CodeGen.IL.Common as Common

39−import CodeGen.IL.Optimizer

40−import CodeGen.IL.Printer

41−

42−data DeclType = ModuleDecl | LetDecl | RecLetDecl deriving (Eq)

43−

44−-- | Generate code in the simplified intermediate representation for all declarations in a

45−-- module.

46−moduleToIL

47− :: forall m

48− -- . (Monad m, MonadReader Options m, MonadSupply m, MonadError MultipleErrors m)

49− . (Monad m, MonadSupply m)

50− => Module Ann

51− -> Text

52− -> m (Text, [Text], [AST], Text, Text)

53−moduleToIL (Module _ coms mn _ imps _ foreigns decls) project =

54− do

55− ilDecls <- mapM (bindToIL ModuleDecl) decls

56− optimized <- traverse (traverse (optimize modName')) ilDecls

57− let optimized' = concat optimized

58− values = annotValue <$> optimized'

59− foreigns' = moduleIdentToIL <$> foreigns

60− interface = interfaceSource modName values foreigns

61− imports = nub . concat $ importToIL <$> optimized'

62− implHeader = implHeaderSource modName imports project

63− implFooter = implFooterSource (runModuleName mn) foreigns

64− return $ (interface, foreigns', optimized', implHeader, implFooter)

65− where

66− modName = moduleNameToIL mn

67− modName' = AST.Var Nothing modName

68−

69− annotValue :: AST -> (Text, Bool)

70− annotValue (AST.Function _ (Just name) [] (AST.Block _ [AST.Return _ ret]))

71− | isLiteral ret = (name, True)

72− annotValue (AST.Function _ (Just name) [] _) = (name, False)

73− annotValue _ = error "Unexpected top-level value form"

74−

75− -- | Extracts all declaration names from a binding group.

76− getNames :: Bind Ann -> [Ident]

77− getNames (NonRec _ ident _) = [ident]

78− getNames (Rec vals) = map (snd . fst) vals

79−

80− -- | Generates IL code for a module import

81− --

82− importToIL :: AST -> [Text]

83− importToIL = AST.everything (++) modRef

84− where

85− modRef (AST.Indexer _ (AST.Var _ _) (AST.Var _ mname))

86− | not $ T.null mname = [extract mname]

87− modRef _ = []

88− extract :: Text -> Text

89− extract = T.replace "_" "." . T.dropWhileEnd (=='_')

90−

91− -- |

92− -- Generate code in the simplified intermediate representation for a declaration

93− --

94− bindToIL :: DeclType -> Bind Ann -> m [AST]

95− bindToIL dt (NonRec ann ident val) = return <$> nonRecToIL dt ann ident val

96− bindToIL dt (Rec vals) = forM vals (uncurry . uncurry $ nonRecToIL dt')

97− where

98− dt' = if dt == LetDecl then RecLetDecl else dt

99−

100− -- | Generate code in the simplified intermediate representation for a single non-recursive

101− -- declaration.

102− --

103− -- The main purpose of this function is to handle code generation for comments.

104− nonRecToIL :: DeclType -> Ann -> Ident -> Expr Ann -> m AST

105− nonRecToIL dt a i e@(extractAnn -> (_, com, _, _)) | not (null com) = do

106− -- withoutComment <- asks optionsNoComments

107− let withoutComment = False

108− if withoutComment

109− then nonRecToIL dt a i (modifyAnn removeComments e)

110− else AST.Comment Nothing com <$> nonRecToIL dt a i (modifyAnn removeComments e)

111− nonRecToIL ModuleDecl (ss, _, _, _) ident val = do

112− il <- valueToIL val

113− pure $ AST.Function Nothing (Just $ moduleIdentToIL ident) [] (AST.Block Nothing [AST.Return Nothing il])

114− nonRecToIL RecLetDecl (ss, _, _, _) ident val = do

115− ilExpr <- valueToIL val

116− pure $ AST.Assignment Nothing (AST.Var Nothing $ identToIL ident) ilExpr

117− nonRecToIL _ (ss, _, _, _) ident val = do

118− il <- valueToIL val

119− pure $ AST.VariableIntroduction Nothing (identToIL ident) (Just il)

120−

121− -- | Generate code in the simplified intermediate representation for a variable based on a

122− -- PureScript identifier.

123− var :: Ident -> AST

124− var = AST.Var Nothing . identToIL

125−

126− accessorString :: PSString -> AST -> AST

127− accessorString prop = AST.Indexer Nothing (AST.StringLiteral Nothing prop)

128−

129− -- | Generate code in the simplified intermediate representation for a value or expression.

130−

131− valueToIL :: Expr Ann -> m AST

132− valueToIL (Literal (pos, _, _, _) l) = literalToValueIL pos l

133− valueToIL (Accessor _ prop val) =

134− accessorString prop <$> valueToIL val

135− valueToIL (ObjectUpdate _ o ps) = do

136− obj <- valueToIL o

137− updates <- mapM (sndM valueToIL) ps

138− obj' <- freshName'

139− let objVar = AST.Var Nothing obj'

140− copy = AST.VariableIntroduction Nothing obj' (Just $ copyDict obj)

141− assign (k, v) = AST.Assignment Nothing (accessorString k objVar) v

142− sts = copy : (assign <$> updates) ++ [AST.Return Nothing objVar]

143− return $ AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing sts)) []

144− valueToIL (Abs _ arg val) = do

145− ret <- valueToIL val

146− let ilArg = case arg of

147− UnusedIdent -> []

148− _ -> [identToIL arg]

149− return $ AST.Function Nothing Nothing ilArg (AST.Block Nothing [AST.Return Nothing ret])

150− valueToIL e@App{} = do

151− let (f, args) = unApp e []

152− args' <- mapM valueToIL args

153− fn <- valueToIL f

154− case f of

155− Var (_, _, _, Just IsNewtype) _ -> return (head args')

156− _ -> flip (foldl (\fn a -> AST.App Nothing fn [a])) args' <$> valueToIL f

157− where

158− unApp :: Expr Ann -> [Expr Ann] -> (Expr Ann, [Expr Ann])

159− unApp (App _ val arg) args = unApp val (arg : args)

160− unApp other args = (other, args)

161− valueToIL (Var _ ident) = return $ varToIL ident

162− valueToIL (Case (ss, _, _, _) values binders) = do

163− vals <- mapM valueToIL values

164− bindersToIL ss binders vals

165− valueToIL (Let _ ds val) = do

166− let recurs = concatMap getNames $ filter isRec ds

167− recurDs = (\v -> AST.VariableIntroduction Nothing (identToIL v) Nothing) <$> recurs

168− ds' <- concat <$> mapM (bindToIL LetDecl) ds

169− ret <- valueToIL val

170− return $ AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing (recurDs ++ ds' ++ [AST.Return Nothing ret]))) []

171− where

172− isRec :: Bind Ann -> Bool

173− isRec (Rec _) = True

174− isRec _ = False

175− valueToIL (Constructor (_, _, _, Just IsNewtype) _ (ProperName ctor) _) = error "IsNewtype"

176− valueToIL (Constructor _ _ (ProperName ctor) fields) =

177− let body = AST.ObjectLiteral Nothing $ (mkString ctor, AST.BooleanLiteral Nothing True) :

178− ((\field -> (mkString (identToIL field), var field)) `map` fields)

179− fn = foldr (\f inner -> AST.Function Nothing Nothing [identToIL f] (AST.Block Nothing [AST.Return Nothing inner])) body fields

180− in return fn

181−

182−

183− iife :: Text -> [AST] -> AST

184− iife v exprs = AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing $ exprs ++ [AST.Return Nothing $ AST.Var Nothing v])) []

185−

186− literalToValueIL :: SourceSpan -> Literal (Expr Ann) -> m AST

187− literalToValueIL ss (NumericLiteral (Left i)) = return $ AST.NumericLiteral (Just ss) (Left i)

188− literalToValueIL ss (NumericLiteral (Right n)) = return $ AST.NumericLiteral (Just ss) (Right n)

189− literalToValueIL ss (StringLiteral s) = return $ AST.StringLiteral (Just ss) s

190− literalToValueIL ss (CharLiteral c) = return $ AST.StringLiteral (Just ss) (fromString [c])

191− literalToValueIL ss (BooleanLiteral b) = return $ AST.BooleanLiteral (Just ss) b

192− literalToValueIL ss (ArrayLiteral xs) = AST.ArrayLiteral (Just ss) <$> mapM valueToIL xs

193− literalToValueIL ss (ObjectLiteral ps) = AST.ObjectLiteral (Just ss) <$> mapM (sndM valueToIL) ps

194−

195− -- | Generate code in the simplified intermediate representation for a reference to a

196− -- variable.

197− varToIL :: Qualified Ident -> AST

198− varToIL (Qualified Nothing ident) = var ident

199− varToIL qual = qualifiedToIL id qual

200−

201− -- | Generate code in the simplified intermediate representation for a reference to a

202− -- variable that may have a qualified name.

203− qualifiedToIL :: (a -> Ident) -> Qualified a -> AST

204− qualifiedToIL f (Qualified (Just (ModuleName mn')) a) | mn' == C.prim = AST.Var Nothing . moduleIdentToIL $ f a

205− qualifiedToIL f (Qualified (Just mn') a) | mn /= mn' = AST.Indexer Nothing (AST.Var Nothing . moduleIdentToIL $ f a) (AST.Var Nothing (moduleNameToIL mn'))

206− qualifiedToIL f (Qualified _ a) = AST.Indexer Nothing (AST.Var Nothing . moduleIdentToIL $ f a) (AST.Var Nothing "")

207−

208− -- foreignIdent :: Ident -> AST

209− -- foreignIdent ident = accessorString (mkString $ runIdent ident) (AST.Var Nothing "$foreign")

210−

211− -- | Generate code in the simplified intermediate representation for pattern match binders

212− -- and guards.

213− bindersToIL :: SourceSpan -> [CaseAlternative Ann] -> [AST] -> m AST

214− bindersToIL ss binders vals = do

215− valNames <- replicateM (length vals) freshName'

216− let assignments = zipWith (AST.VariableIntroduction Nothing) valNames (map Just vals)

217− ils <- forM binders $ \(CaseAlternative bs result) -> do

218− ret <- guardsToIL result

219− go valNames ret bs

220− return $ AST.App Nothing (AST.Function Nothing Nothing [] (AST.Block Nothing (assignments ++ concat ils ++ [AST.Throw Nothing (AST.StringLiteral Nothing $ mkString failedPatternMessage)])))

221− []

222− where

223− go :: [Text] -> [AST] -> [Binder Ann] -> m [AST]

224− go _ done [] = return done

225− go (v:vs) done' (b:bs) = do

226− done'' <- go vs done' bs

227− binderToIL v done'' b

228− go _ _ _ = internalError "Invalid arguments to bindersToIL"

229−

230− failedPatternMessage :: Text

231− failedPatternMessage = "Failed pattern match at " <> runModuleName mn <> " " <> displayStartEndPos ss

232−

233− guardsToIL :: Either [(Guard Ann, Expr Ann)] (Expr Ann) -> m [AST]

234− guardsToIL (Left gs) = traverse genGuard gs where

235− genGuard (cond, val) = do

236− cond' <- valueToIL cond

237− val' <- valueToIL val

238− return

239− (AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo cond' (AST.BooleanLiteral Nothing True))

240− (AST.Block Nothing [AST.Return Nothing val']) Nothing)

241−

242− guardsToIL (Right v) = return . AST.Return Nothing <$> valueToIL v

243−

244− -- | Generate code in the simplified intermediate representation for a pattern match

245− -- binder.

246− binderToIL :: Text -> [AST] -> Binder Ann -> m [AST]

247− binderToIL _ done NullBinder{} = return done

248− binderToIL varName done (LiteralBinder _ l) =

249− literalToBinderIL varName done l

250− binderToIL varName done (VarBinder _ ident) =

251− return (AST.VariableIntroduction Nothing (identToIL ident) (Just (AST.Var Nothing varName)) : done)

252− binderToIL varName done (ConstructorBinder (_, _, _, Just IsNewtype) _ _ [b]) =

253− binderToIL varName done b

254− binderToIL varName done (ConstructorBinder (_, _, _, Just (IsConstructor ctorType fields)) _ (Qualified _ (ProperName ctor)) bs) = do

255− il <- go (zip fields bs) done

256− return $ case ctorType of

257− ProductType -> il

258− SumType ->

259− [AST.IfElse Nothing (AST.InstanceOf Nothing (AST.Var Nothing varName) (AST.StringLiteral Nothing (mkString ctor)))

260− (AST.Block Nothing il)

261− Nothing]

262− where

263− go :: [(Ident, Binder Ann)] -> [AST] -> m [AST]

264− go [] done' = return done'

265− go ((field, binder) : remain) done' = do

266− argVar <- freshName'

267− done'' <- go remain done'

268− il <- binderToIL argVar done'' binder

269− return (AST.VariableIntroduction Nothing argVar (Just $ accessorString (mkString $ identToIL field) $ AST.Var Nothing varName) : il)

270−

271− binderToIL _ _ ConstructorBinder{} =

272− internalError "binderToIL: Invalid ConstructorBinder in binderToIL"

273− binderToIL varName done (NamedBinder _ ident binder) = do

274− il <- binderToIL varName done binder

275− return (AST.VariableIntroduction Nothing (identToIL ident) (Just (AST.Var Nothing varName)) : il)

276−

277− literalToBinderIL :: Text -> [AST] -> Literal (Binder Ann) -> m [AST]

278− literalToBinderIL varName done (NumericLiteral num) =

279− return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.NumericLiteral Nothing num)) (AST.Block Nothing done) Nothing]

280− literalToBinderIL varName done (CharLiteral c) =

281− return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.StringLiteral Nothing (fromString [c]))) (AST.Block Nothing done) Nothing]

282− literalToBinderIL varName done (StringLiteral str) =

283− return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.StringLiteral Nothing str)) (AST.Block Nothing done) Nothing]

284− literalToBinderIL varName done (BooleanLiteral True) =

285− return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.BooleanLiteral Nothing True)) (AST.Block Nothing done) Nothing]

286− literalToBinderIL varName done (BooleanLiteral False) =

287− return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo (AST.Var Nothing varName) (AST.BooleanLiteral Nothing False)) (AST.Block Nothing done) Nothing]

288− -- return [AST.IfElse Nothing (AST.Unary Nothing AST.Not (AST.Var Nothing varName)) (AST.Block Nothing done) Nothing]

289− literalToBinderIL varName done (ObjectLiteral bs) = go done bs

290− where

291− go :: [AST] -> [(PSString, Binder Ann)] -> m [AST]

292− go done' [] = return done'

293− go done' ((prop, binder):bs') = do

294− propVar <- freshName'

295− done'' <- go done' bs'

296− il <- binderToIL propVar done'' binder

297− return (AST.VariableIntroduction Nothing propVar (Just (accessorString prop (AST.Var Nothing varName))) : il)

298− literalToBinderIL varName done (ArrayLiteral bs) = do

299− il <- go done 0 bs

300− return [AST.IfElse Nothing (AST.Binary Nothing AST.EqualTo

301− (arrayLength $ AST.Var Nothing varName)

302− (AST.NumericLiteral Nothing (Left (fromIntegral $ length bs))))

303− (AST.Block Nothing il) Nothing]

304− where

305− go :: [AST] -> Integer -> [Binder Ann] -> m [AST]

306− go done' _ [] = return done'

307− go done' index (binder:bs') = do

308− elVar <- freshName'

309− done'' <- go done' (index + 1) bs'

310− il <- binderToIL elVar done'' binder

311− return (AST.VariableIntroduction Nothing elVar (Just (AST.Indexer Nothing (AST.NumericLiteral Nothing (Left index)) (AST.Var Nothing varName))) : il)

312−

313−emptyAnn :: Ann

314−emptyAnn = (SourceSpan "" (SourcePos 0 0) (SourcePos 0 0), [], Nothing, Nothing)

315−

316−arrayLength :: AST -> AST

317−arrayLength a = AST.App Nothing (AST.Var Nothing arrayLengthFn) [a]

318−-- arrayLength a = AST.Var Nothing (arrayLengthFn <> "(" <> prettyPrintIL1 a <> ")")

319−

320−copyDict :: AST -> AST

321−copyDict a = AST.App Nothing (AST.Var Nothing copyDictFn) [a]

src/CodeGen/IL/Common.hsdeleted−196

@@ -1,196 +0,0 @@

1−-- | Common code generation utility functions

2−module CodeGen.IL.Common where

3−

4−import Prelude.Compat

5−

6−import Control.Monad.Supply.Class (MonadSupply, freshName)

7−import Data.Char

8−import Data.Maybe (maybe)

9−import Data.Monoid ((<>))

10−import Data.Text (Text)

11−import qualified Data.Text as T

12−

13−import Language.PureScript.Crash

14−import Language.PureScript.Names

15−

16−import qualified Language.PureScript.Constants as C

17−

18−moduleNameToIL :: ModuleName -> Text

19−moduleNameToIL (ModuleName mn) =

20− let name = T.replace "." "_" mn

21− in if nameIsILBuiltIn name then (name <> moduleRenamerMarker) else name

22−

23−moduleNameToIL' :: ModuleName -> Text

24−moduleNameToIL' (ModuleName mn) = T.replace "_" "." mn

25−

26−-- | Convert an 'Ident' into a valid IL identifier:

27−--

28−-- * Alphanumeric characters are kept unmodified.

29−--

30−-- * Reserved IL identifiers are wrapped with '_'.

31−--

32−identToIL :: Ident -> Text

33−identToIL UnusedIdent = unusedName

34−identToIL (Ident "$__unused") = unusedName

35−identToIL (Ident name) | name == C.undefined = undefinedName -- Note: done in Printer.hs too

36−identToIL (Ident name) = properToIL name

37−identToIL (GenIdent _ _) = internalError "GenIdent in identToIL"

38−

39−moduleIdentToIL :: Ident -> Text

40−moduleIdentToIL UnusedIdent = unusedName

41−moduleIdentToIL (Ident name) | name == C.undefined = undefinedName

42−moduleIdentToIL (Ident name) = moduleProperToIL name

43−moduleIdentToIL (GenIdent _ _) = internalError "GenIdent in identToIL"

44−

45−undefinedName :: Text

46−undefinedName = "Undefined"

47−

48−unusedName :: Text

49−unusedName = "_"

50−

51−properToIL :: Text -> Text

52−properToIL name

53− | nameIsILReserved name = "ˉ" <> name

54− | otherwise = T.concatMap identCharToText name

55−

56−-- | Attempts to find a human-readable name for a symbol, if none has been specified returns the

57−-- ordinal value.

58−identCharToText :: Char -> Text

59−identCharToText 'ṩ' = "_ṩ"

60−identCharToText c | isAlphaNum c = T.singleton c

61−identCharToText '_' = "_"

62−identCharToText '\'' = "ꞌ" -- lowercase saltillo

63−identCharToText c = error (show (ord c)) -- TODO: should never occur now(?)

64−

65−moduleProperToIL :: Text -> Text

66−moduleProperToIL = T.concatMap identCharToText

67−

68−-- | Checks whether an identifier name is reserved in IL.

69−nameIsILReserved :: Text -> Bool

70−nameIsILReserved name =

71− name `elem` ilAnyReserved

72−

73−-- | Checks whether a name matches a built-in value in IL.

74−nameIsILBuiltIn :: Text -> Bool

75−nameIsILBuiltIn name =

76− name `elem`

77− [ "Any"

78− , "Apply"

79− , "Contains"

80− , "CopyDict"

81− , "Dict"

82− , "EffFn"

83− , "Fn"

84− , "Foreign"

85− , "Get"

86− , "Index"

87− , "Is"

88− , "Length"

89− , "Once"

90− , "Run"

91− , "Undefined"

92− ]

93−

94−ilAnyReserved :: [Text]

95−ilAnyReserved =

96− concat

97− [ ilKeywords

98− , ilLiterals

99− ]

100−

101−ilKeywords :: [Text]

102−ilKeywords =

103− [ "break"

104− , "case"

105− , "chan"

106− , "const"

107− , "continue"

108− , "default"

109− , "defer"

110− , "else"

111− , "fallthrough"

112− , "for"

113− , "func"

114− , "go"

115− , "goto"

116− , "if"

117− , "import"

118− , "interface"

119− , "map"

120− , "package"

121− , "range"

122− , "return"

123− , "select"

124− , "struct"

125− , "switch"

126− , "type"

127− , "var"

128− ]

129−

130−ilLiterals :: [Text]

131−ilLiterals =

132− [ "init"

133− , "nil"

134− , "int"

135− , "int8"

136− , "int16"

137− , "int32"

138− , "int64"

139− , "uint"

140− , "uint8"

141− , "uint16"

142− , "uint32"

143− , "uint64"

144− , "uintptr"

145− , "float32"

146− , "float64"

147− , "complex64"

148− , "complex128"

149− , "byte"

150− , "rune"

151− , "string"

152− ]

153−

154−withPrefix :: Text -> Text

155−withPrefix s = "Ꞌ" <> s -- uppercase saltillo

156−

157−anyType :: Text

158−anyType = "Any"

159−

160−dictType :: Text

161−dictType = "Dict"

162−

163−arrayType :: Text

164−arrayType = "[]" <> anyType

165−

166−uncurriedFnType :: Int -> Text

167−uncurriedFnType i = "Fn" <> (T.pack . show $ i)

168−

169−int :: Text

170−int = "int"

171−

172−float :: Text

173−float = "float64"

174−

175−bool :: Text

176−bool = "bool"

177−

178−string :: Text

179−string = "string"

180−

181−arrayLengthFn :: Text

182−arrayLengthFn = "Length"

183−

184−indexFn :: Text

185−indexFn = "Index"

186−

187−copyDictFn :: Text

188−copyDictFn = "CopyDict"

189−

190−freshName' :: MonadSupply m => m Text

191−freshName' = do

192− name <- freshName

193− return $ T.replace "$" "ṩ" name

194−

195−moduleRenamerMarker :: Text

196−moduleRenamerMarker = "__"

src/CodeGen/IL/Optimizer.hsdeleted−81

@@ -1,81 +0,0 @@

1−-- | This module optimizes code in the intermediate representation.

2−module CodeGen.IL.Optimizer (optimize) where

3−

4−import Prelude.Compat

5−

6−import Control.Monad.Supply.Class (MonadSupply)

7−import Data.Text (Text)

8−import Language.PureScript.CoreImp.AST

9−import Language.PureScript.CoreImp.Optimizer.Blocks

10−import Language.PureScript.CoreImp.Optimizer.Common hiding (isDict)

11−import Language.PureScript.CoreImp.Optimizer.Inliner (etaConvert, evaluateIifes, inlineVariables, unThunk)

12−import Language.PureScript.CoreImp.Optimizer.Unused

13−

14−import CodeGen.IL.Common (unusedName)

15−import CodeGen.IL.Optimizer.Inliner

16−import CodeGen.IL.Optimizer.MagicDo

17−import CodeGen.IL.Optimizer.TCO

18−

19−import qualified Language.PureScript.Constants as C

20−

21−-- | Apply a series of optimizer passes to simplified IL code

22−optimize :: MonadSupply m => AST -> AST -> m AST

23−optimize mn il = do

24− il' <- untilFixedPoint (inlineFnComposition . inlineUnsafeCoerce . inlineUnsafePartial . tidyUp) il

25− il'' <- untilFixedPoint (return . ignoreUnusedResults . inlineCommonValues . inlineCommonOperators . tidyUp) . tco mn . inlineST

26− =<< untilFixedPoint (return . magicDoST)

27− =<< untilFixedPoint (return . magicDoEff)

28− =<< untilFixedPoint (return . magicDoEffect) il'

29− untilFixedPoint (return . collapseVarDeclarations) il''

30− where

31− tidyUp :: AST -> AST

32− tidyUp = applyAll

33− [ collapseNestedBlocks

34− , collapseNestedIfs

35− , collapseIfChecks

36− , removeCodeAfterReturnStatements

37− , unThunk

38− , etaConvert

39− , evaluateIifes

40− , inlineVariables

41− ]

42−

43−untilFixedPoint :: (Monad m, Eq a) => (a -> m a) -> a -> m a

44−untilFixedPoint f = go

45− where

46− go a = do

47− a' <- f a

48− if a' == a then return a' else go a'

49−

50−collapseIfChecks :: AST -> AST

51−collapseIfChecks = everywhere collapse where

52− collapse :: AST -> AST

53− collapse (IfElse _ (Binary _ EqualTo (BooleanLiteral _ True) (BooleanLiteral _ True)) (Block _ [exprs]) _) = exprs

54− collapse (IfElse _ (Binary _ EqualTo (Indexer _ (Var _ prop) (Var _ val)) (BooleanLiteral _ True)) (Block _ [exprs]) _)

55− | prop == "otherwise" && val == "Data_Boolean" = exprs

56− collapse exprs = exprs

57−

58−collapseVarDeclarations :: AST -> AST

59−collapseVarDeclarations = everywhere collapse where

60− collapse :: AST -> AST

61− collapse (Block ss sts) = Block ss (go Nothing sts)

62− collapse s = s

63−

64− go :: Maybe Text -> [AST] -> [AST]

65− go _ [] = []

66− go Nothing (decl@(VariableIntroduction _ var (Just _)) : sts) = decl : go (Just var) (go Nothing sts)

67− go (Just var') ((VariableIntroduction ss var (Just val)) : sts)

68− | var == var' = (Assignment ss (Var Nothing var) val) : go (Just var') sts

69− go var' (s:sts) = s : go var' sts

70−

71−ignoreUnusedResults :: AST -> AST

72−ignoreUnusedResults = everywhere $ removeFromBlock go

73− where

74− go :: [AST] -> [AST]

75− go [] = []

76− go (VariableIntroduction ss var (Just s) : sts)

77− | not $ any (everything (||) (isUsed var)) sts = sts'

78− where

79− sts' | App{} <- s = s : (go sts)

80− | otherwise = go sts

81− go (s:sts) = s : go sts

src/CodeGen/IL/Optimizer/Common.hsdeleted−18

@@ -1,18 +0,0 @@

1−-- | Common functions used by the various optimizer phases

2−module CodeGen.IL.Optimizer.Common where

3−

4−import Prelude.Compat

5−

6−import Data.Text (Text)

7−

8−import Language.PureScript.CoreImp.AST

9−import Language.PureScript.PSString (PSString, decodeString)

10−

11−isDict :: (Text, PSString) -> AST -> Bool

12−isDict (moduleName, dictName) (Indexer _ (Var _ x) (Var _ y)) =

13− Just x == decodeString dictName && y == moduleName

14−isDict _ _ = False

15−

16−isDict' :: [(Text, PSString)] -> AST -> Bool

17−isDict' xs il = any (`isDict` il) xs

18−

src/CodeGen/IL/Optimizer/Inliner.hsdeleted−435

@@ -1,435 +0,0 @@

1−-- | This module performs basic inlining of known functions

2−module CodeGen.IL.Optimizer.Inliner

3− ( inlineCommonValues

4− , inlineCommonOperators

5− , inlineFnComposition

6− , inlineUnsafeCoerce

7− , inlineUnsafePartial

8− ) where

9−

10−import Prelude.Compat

11−

12−import Control.Monad.Supply.Class (MonadSupply)

13−

14−import Data.Either (rights)

15−import Data.Maybe (fromMaybe)

16−import Data.String (IsString, fromString)

17−import Data.Text (Text)

18−import qualified Data.Text as T

19−

20−import Language.PureScript.PSString (PSString, decodeString, mkString)

21−import Language.PureScript.CoreImp.AST

22−import Language.PureScript.CoreImp.Optimizer.Common hiding (isDict, isDict')

23−import Language.PureScript.AST (SourceSpan(..))

24−import qualified Language.PureScript.Constants as C

25−

26−import CodeGen.IL.Common

27−import CodeGen.IL.Optimizer.Common

28−

29−-- TODO: Potential bug:

30−-- Shouldn't just inline this case: { var x = 0; x.toFixed(10); }

31−-- Needs to be: { 0..toFixed(10); }

32−-- Probably needs to be fixed in pretty-printer instead.

33−shouldInline :: AST -> Bool

34−shouldInline (Var _ _) = True

35−shouldInline (NumericLiteral _ _) = True

36−shouldInline (StringLiteral _ _) = True

37−shouldInline (BooleanLiteral _ _) = True

38−shouldInline (Indexer _ index val) = shouldInline index && shouldInline val

39−shouldInline _ = False

40−

41−inlineCommonValues :: AST -> AST

42−inlineCommonValues = everywhere convert

43− where

44− convert :: AST -> AST

45− convert (App ss fn [dict])

46− | isDict' [semiringNumber, semiringInt] dict && isDict fnZero fn = NumericLiteral ss (Left 0)

47− | isDict' [semiringNumber, semiringInt] dict && isDict fnOne fn = NumericLiteral ss (Left 1)

48− | isDict boundedBoolean dict && isDict fnBottom fn = BooleanLiteral ss False

49− | isDict boundedBoolean dict && isDict fnTop fn = BooleanLiteral ss True

50− convert (App ss (App _ fn [dict]) [x])

51− | isDict ringInt dict && isDict fnNegate fn = Unary ss Negate (unbox x $ snd ringInt)

52− convert (App ss (App _ (App _ fn [dict]) [x]) [y])

53− | isDict semiringInt dict && isDict fnAdd fn = intOp ss Add semiringInt x y

54− | isDict semiringInt dict && isDict fnMultiply fn = intOp ss Multiply semiringInt x y

55− | isDict ringInt dict && isDict fnSubtract fn = intOp ss Subtract ringInt x y

56− convert other = other

57− fnZero = (C.dataSemiring, C.zero)

58− fnOne = (C.dataSemiring, C.one)

59− fnBottom = (C.dataBounded, C.bottom)

60− fnTop = (C.dataBounded, C.top)

61− fnAdd = (C.dataSemiring, C.add)

62− fnMultiply = (C.dataSemiring, C.mul)

63− fnSubtract = (C.dataRing, C.sub)

64− fnNegate = (C.dataRing, C.negate)

65− intOp ss op (_, d) x y = Binary ss op (unbox x d) (unbox y d)

66−

67−inlineCommonOperators :: AST -> AST

68−inlineCommonOperators = everywhereTopDown $ applyAll $

69− [ binary semiringNumber opAdd Add

70− , binary semiringNumber opMul Multiply

71−

72− , binary ringNumber opSub Subtract

73− , unary ringNumber opNegate Negate

74−

75− , binary euclideanRingNumber opDiv Divide

76−

77− -- , binary eqNumber opEq EqualTo

78− -- , binary eqNumber opNotEq NotEqualTo

79− , binary eqInt opEq EqualTo

80− , binary eqInt opNotEq NotEqualTo

81− , binary eqString opEq EqualTo

82− , binary eqString opNotEq NotEqualTo

83− , binary eqChar opEq EqualTo

84− , binary eqChar opNotEq NotEqualTo

85− , binary eqBoolean opEq EqualTo

86− , binary eqBoolean opNotEq NotEqualTo

87−

88− , binary ordBoolean opLessThan LessThan

89− , binary ordBoolean opLessThanOrEq LessThanOrEqualTo

90− , binary ordBoolean opGreaterThan GreaterThan

91− , binary ordBoolean opGreaterThanOrEq GreaterThanOrEqualTo

92− , binary ordChar opLessThan LessThan

93− , binary ordChar opLessThanOrEq LessThanOrEqualTo

94− , binary ordChar opGreaterThan GreaterThan

95− , binary ordChar opGreaterThanOrEq GreaterThanOrEqualTo

96− , binary ordInt opLessThan LessThan

97− , binary ordInt opLessThanOrEq LessThanOrEqualTo

98− , binary ordInt opGreaterThan GreaterThan

99− , binary ordInt opGreaterThanOrEq GreaterThanOrEqualTo

100− , binary ordNumber opLessThan LessThan

101− , binary ordNumber opLessThanOrEq LessThanOrEqualTo

102− , binary ordNumber opGreaterThan GreaterThan

103− , binary ordNumber opGreaterThanOrEq GreaterThanOrEqualTo

104− , binary ordString opLessThan LessThan

105− , binary ordString opLessThanOrEq LessThanOrEqualTo

106− , binary ordString opGreaterThan GreaterThan

107− , binary ordString opGreaterThanOrEq GreaterThanOrEqualTo

108−

109− , binary semigroupString opAppend Add

110−

111− , binary heytingAlgebraBoolean opConj And

112− , binary heytingAlgebraBoolean opDisj Or

113− , unary heytingAlgebraBoolean opNot Not

114−

115− , binary' C.dataIntBits C.or BitwiseOr

116− , binary' C.dataIntBits C.and BitwiseAnd

117− , binary' C.dataIntBits C.xor BitwiseXor

118− , binary' C.dataIntBits C.shl ShiftLeft

119− , binary' C.dataIntBits C.shr ShiftRight

120− , unary' C.dataIntBits C.complement BitwiseNot

121−

122− , inlineNonClassFunction (isModFn (C.dataFunction, C.apply)) $ \f x -> App Nothing f [x]

123− , inlineNonClassFunction (isModFn (C.dataFunction, C.applyFlipped)) $ \x f -> App Nothing f [x]

124− , inlineUnsafeIndex (isModFnWithDict (C.dataArray, C.unsafeIndex)) $ flip (Indexer Nothing)

125− ] ++

126− [ fn | i <- [0..10], fn <- [ mkFn i, runFn i ] ] ++

127− [ fn | i <- [0..10], fn <- [ mkEffFn C.controlMonadEffUncurried C.mkEffFn i, runEffFn C.controlMonadEffUncurried C.runEffFn i ] ] ++

128− [ fn | i <- [0..10], fn <- [ mkEffFn C.effectUncurried C.mkEffectFn i, runEffFn C.effectUncurried C.runEffectFn i ] ]

129− where

130− binary :: (Text, PSString) -> (Text, PSString) -> BinaryOperator -> AST -> AST

131− binary dict@(_, d) fns op = convert where

132− convert :: AST -> AST

133− convert (App ss (App _ (App _ fn [dict']) [x]) [y])

134− | isDict dict dict' && isDict fns fn = Binary ss op (unbox x d) (unbox y d)

135− convert other = other

136− binary' :: Text -> PSString -> BinaryOperator -> AST -> AST

137− binary' moduleName opString op = convert where

138− convert :: AST -> AST

139− convert (App ss (App _ fn [x]) [y]) | isDict (moduleName, opString) fn = Binary ss op (unbox x mn) (unbox y mn)

140− convert other = other

141− mn :: PSString

142− mn = mkString moduleName

143− unary :: (Text, PSString) -> (Text, PSString) -> UnaryOperator -> AST -> AST

144− unary dicts@(_, d) fns op = convert where

145− convert :: AST -> AST

146− convert (App ss (App _ fn [dict']) [x]) | isDict dicts dict' && isDict fns fn = Unary ss op (unbox x d)

147− convert other = other

148− unary' :: Text -> PSString -> UnaryOperator -> AST -> AST

149− unary' moduleName fnName op = convert where

150− convert :: AST -> AST

151− convert (App ss fn [x]) | isDict (moduleName, fnName) fn = Unary ss op (unbox x fnName)

152− convert other = other

153−

154− mkFn :: Int -> AST -> AST

155− mkFn = mkFn' C.dataFunctionUncurried C.mkFn $ \ss1 ss2 ss3 args il ->

156− Function ss1 Nothing args (Block ss2 [Return ss3 il])

157−

158− mkEffFn :: Text -> Text -> Int -> AST -> AST

159− mkEffFn modName fnName = mkFn' modName fnName $ \ss1 ss2 ss3 args il ->

160− Function ss1 Nothing args (Block ss2 [Return ss3 (App ss3 il [])])

161−

162− mkFn' :: Text -> Text -> (Maybe SourceSpan -> Maybe SourceSpan -> Maybe SourceSpan -> [Text] -> AST -> AST) -> Int -> AST -> AST

163− mkFn' modName fnName res 0 = convert where

164− convert :: AST -> AST

165− convert (App _ mkFnN [Function s1 Nothing [_] (Block s2 [Return s3 il])]) | isNFn modName fnName 0 mkFnN =

166− res s1 s2 s3 [] il

167− convert other = other

168− mkFn' modName fnName res n = convert where

169− convert :: AST -> AST

170− convert orig@(App ss mkFnN [fn]) | isNFn modName fnName n mkFnN =

171− case collectArgs n [] fn of

172− Just (args, [Return ss' ret]) -> res ss ss ss' args ret

173− _ -> orig

174− convert other = other

175− collectArgs :: Int -> [Text] -> AST -> Maybe ([Text], [AST])

176− collectArgs 1 acc (Function _ Nothing [oneArg] (Block _ il)) | length acc == n - 1 = Just (reverse (oneArg : acc), il)

177− collectArgs m acc (Function _ Nothing [oneArg] (Block _ [Return _ ret])) = collectArgs (m - 1) (oneArg : acc) ret

178− collectArgs _ _ _ = Nothing

179−

180− isNFn :: Text -> Text -> Int -> AST -> Bool

181− isNFn expectMod prefix n (Indexer _ (Var _ name) (Var _ modName)) | modName == expectMod =

182− name == fromString (T.unpack prefix <> show n)

183− isNFn _ _ _ _ = False

184−

185− runFn :: Int -> AST -> AST

186− runFn = runFn' C.dataFunctionUncurried C.runFn (\ss f args ->

187− let len = length args

188− typ = mkString $ uncurriedFnType len in

189− if len > 0

190− then App ss (App Nothing (StringLiteral Nothing typ) [f]) args

191− else App ss f args)

192− runEffFn :: Text -> Text -> Int -> AST -> AST

193− runEffFn modName fnName = runFn' modName fnName $ \ss fn acc ->

194− let typ = mkString . uncurriedFnType $ length acc in

195− Function ss Nothing [] (Block ss [Return ss (App ss (App Nothing (StringLiteral Nothing typ) [fn]) acc)])

196−

197− runFn' :: Text -> Text -> (Maybe SourceSpan -> AST -> [AST] -> AST) -> Int -> AST -> AST

198− runFn' modName runFnName res n = convert where

199− convert :: AST -> AST

200− convert il = fromMaybe il $ go n [] il

201−

202− go :: Int -> [AST] -> AST -> Maybe AST

203− go 0 acc (App ss runFnN [fn]) | isNFn modName runFnName n runFnN && length acc == n =

204− Just $ res ss fn acc

205− go m acc (App _ lhs [arg]) = go (m - 1) (arg : acc) lhs

206− go _ _ _ = Nothing

207−

208− inlineNonClassFunction :: (AST -> Bool) -> (AST -> AST -> AST) -> AST -> AST

209− inlineNonClassFunction p f = convert where

210− convert :: AST -> AST

211− convert (App _ (App _ op' [x]) [y]) | p op' = f x y

212− convert other = other

213−

214− inlineUnsafeIndex :: (AST -> Bool) -> (AST -> AST -> AST) -> AST -> AST

215− inlineUnsafeIndex p _ = convert where

216− convert :: AST -> AST

217− convert (App _ (App ss op' [x]) [y@NumericLiteral{}])

218− | p op' = Indexer ss y x

219− convert (App _ (App ss op' [x]) [y])

220− | p op' = App ss (Var Nothing indexFn) [x, y]

221− convert other = other

222−

223− isModFn :: (Text, PSString) -> AST -> Bool

224− isModFn (m, op) (Indexer _ (Var _ op') (Var _ m')) =

225− m == m' && decodeString op == Just op'

226− isModFn _ _ = False

227−

228− isModFnWithDict :: (Text, PSString) -> AST -> Bool

229− isModFnWithDict (m, op) (App _ (Indexer _ (Var _ op') (Var _ m')) [Var _ _]) =

230− m == m' && decodeString op == Just op'

231− isModFnWithDict _ _ = False

232−

233−-- (f <<< g $ x) = f (g x)

234−-- (f <<< g) = \x -> f (g x)

235−inlineFnComposition :: forall m. MonadSupply m => AST -> m AST

236−inlineFnComposition = everywhereTopDownM convert where

237− convert :: AST -> m AST

238− convert (App s1 (App s2 (App _ (App _ fn [dict']) [x]) [y]) [z])

239− | isFnCompose dict' fn = return $ App s1 x [App s2 y [z]]

240− | isFnComposeFlipped dict' fn = return $ App s2 y [App s1 x [z]]

241− convert app@(App ss (App _ (App _ fn [dict']) _) _)

242− | isFnCompose dict' fn || isFnComposeFlipped dict' fn = mkApps ss <$> goApps app <*> freshName'

243− convert other = return other

244−

245− mkApps :: Maybe SourceSpan -> [Either AST (Text, AST)] -> Text -> AST

246− mkApps ss fns a = App ss (Function ss Nothing [] (Block ss $ vars <> [Return Nothing comp])) []

247− where

248− vars = uncurry (VariableIntroduction ss) . fmap Just <$> rights fns

249− comp = Function ss Nothing [a] (Block ss [Return Nothing apps])

250− apps = foldr (\fn acc -> App ss (mkApp fn) [acc]) (Var ss a) fns

251−

252− mkApp :: Either AST (Text, AST) -> AST

253− mkApp = either id $ \(name, arg) -> Var (getSourceSpan arg) name

254−

255− goApps :: AST -> m [Either AST (Text, AST)]

256− goApps (App _ (App _ (App _ fn [dict']) [x]) [y])

257− | isFnCompose dict' fn = mappend <$> goApps x <*> goApps y

258− | isFnComposeFlipped dict' fn = mappend <$> goApps y <*> goApps x

259− goApps app@(App {}) = pure . Right . (,app) <$> freshName'

260− goApps other = pure [Left other]

261−

262− isFnCompose :: AST -> AST -> Bool

263− isFnCompose dict' fn = isDict semigroupoidFn dict' && isDict fnCompose fn

264−

265− isFnComposeFlipped :: AST -> AST -> Bool

266− isFnComposeFlipped dict' fn = isDict semigroupoidFn dict' && isDict fnComposeFlipped fn

267−

268− fnCompose :: forall a b. (IsString a, IsString b) => (a, b)

269− fnCompose = (C.controlSemigroupoid, C.compose)

270−

271− fnComposeFlipped :: forall a b. (IsString a, IsString b) => (a, b)

272− fnComposeFlipped = (C.controlSemigroupoid, C.composeFlipped)

273−

274−inlineUnsafeCoerce :: AST -> AST

275−inlineUnsafeCoerce = everywhereTopDown convert where

276− convert (App _ (Indexer _ (Var _ unsafeCoerceFn) (Var _ unsafeCoerce)) [ comp ])

277− | unsafeCoerceFn == C.unsafeCoerceFn && unsafeCoerce == C.unsafeCoerce

278− = comp

279− convert other = other

280−

281−inlineUnsafePartial :: AST -> AST

282−inlineUnsafePartial = everywhereTopDown convert where

283− convert (App ss fn [ comp ])

284− | isDict fnUnsafePartial fn

285− = App ss comp []

286− where

287− fnUnsafePartial :: forall a b. (IsString a, IsString b) => (a, b)

288− fnUnsafePartial = (C.partialUnsafe, C.unsafePartial)

289− convert other = other

290−

291−semiringNumber :: forall a b. (IsString a, IsString b) => (a, b)

292−semiringNumber = (C.dataSemiring, C.semiringNumber)

293−

294−semiringInt :: forall a b. (IsString a, IsString b) => (a, b)

295−semiringInt = (C.dataSemiring, C.semiringInt)

296−

297−ringNumber :: forall a b. (IsString a, IsString b) => (a, b)

298−ringNumber = (C.dataRing, C.ringNumber)

299−

300−ringInt :: forall a b. (IsString a, IsString b) => (a, b)

301−ringInt = (C.dataRing, C.ringInt)

302−

303−euclideanRingNumber :: forall a b. (IsString a, IsString b) => (a, b)

304−euclideanRingNumber = (C.dataEuclideanRing, C.euclideanRingNumber)

305−

306−-- eqNumber :: forall a b. (IsString a, IsString b) => (a, b)

307−-- eqNumber = (C.dataEq, C.eqNumber)

308−

309−eqInt :: forall a b. (IsString a, IsString b) => (a, b)

310−eqInt = (C.dataEq, C.eqInt)

311−

312−eqString :: forall a b. (IsString a, IsString b) => (a, b)

313−eqString = (C.dataEq, C.eqString)

314−

315−eqChar :: forall a b. (IsString a, IsString b) => (a, b)

316−eqChar = (C.dataEq, C.eqChar)

317−

318−eqBoolean :: forall a b. (IsString a, IsString b) => (a, b)

319−eqBoolean = (C.dataEq, C.eqBoolean)

320−

321−ordBoolean :: forall a b. (IsString a, IsString b) => (a, b)

322−ordBoolean = (C.dataOrd, C.ordBoolean)

323−

324−ordNumber :: forall a b. (IsString a, IsString b) => (a, b)

325−ordNumber = (C.dataOrd, C.ordNumber)

326−

327−ordInt :: forall a b. (IsString a, IsString b) => (a, b)

328−ordInt = (C.dataOrd, C.ordInt)

329−

330−ordString :: forall a b. (IsString a, IsString b) => (a, b)

331−ordString = (C.dataOrd, C.ordString)

332−

333−ordChar :: forall a b. (IsString a, IsString b) => (a, b)

334−ordChar = (C.dataOrd, C.ordChar)

335−

336−semigroupString :: forall a b. (IsString a, IsString b) => (a, b)

337−semigroupString = (C.dataSemigroup, C.semigroupString)

338−

339−boundedBoolean :: forall a b. (IsString a, IsString b) => (a, b)

340−boundedBoolean = (C.dataBounded, C.boundedBoolean)

341−

342−heytingAlgebraBoolean :: forall a b. (IsString a, IsString b) => (a, b)

343−heytingAlgebraBoolean = (C.dataHeytingAlgebra, C.heytingAlgebraBoolean)

344−

345−semigroupoidFn :: forall a b. (IsString a, IsString b) => (a, b)

346−semigroupoidFn = (C.controlSemigroupoid, C.semigroupoidFn)

347−

348−opAdd :: forall a b. (IsString a, IsString b) => (a, b)

349−opAdd = (C.dataSemiring, C.add)

350−

351−opMul :: forall a b. (IsString a, IsString b) => (a, b)

352−opMul = (C.dataSemiring, C.mul)

353−

354−opEq :: forall a b. (IsString a, IsString b) => (a, b)

355−opEq = (C.dataEq, C.eq)

356−

357−opNotEq :: forall a b. (IsString a, IsString b) => (a, b)

358−opNotEq = (C.dataEq, C.notEq)

359−

360−opLessThan :: forall a b. (IsString a, IsString b) => (a, b)

361−opLessThan = (C.dataOrd, C.lessThan)

362−

363−opLessThanOrEq :: forall a b. (IsString a, IsString b) => (a, b)

364−opLessThanOrEq = (C.dataOrd, C.lessThanOrEq)

365−

366−opGreaterThan :: forall a b. (IsString a, IsString b) => (a, b)

367−opGreaterThan = (C.dataOrd, C.greaterThan)

368−

369−opGreaterThanOrEq :: forall a b. (IsString a, IsString b) => (a, b)

370−opGreaterThanOrEq = (C.dataOrd, C.greaterThanOrEq)

371−

372−opAppend :: forall a b. (IsString a, IsString b) => (a, b)

373−opAppend = (C.dataSemigroup, C.append)

374−

375−opSub :: forall a b. (IsString a, IsString b) => (a, b)

376−opSub = (C.dataRing, C.sub)

377−

378−opNegate :: forall a b. (IsString a, IsString b) => (a, b)

379−opNegate = (C.dataRing, C.negate)

380−

381−opDiv :: forall a b. (IsString a, IsString b) => (a, b)

382−opDiv = (C.dataEuclideanRing, C.div)

383−

384−opConj :: forall a b. (IsString a, IsString b) => (a, b)

385−opConj = (C.dataHeytingAlgebra, C.conj)

386−

387−opDisj :: forall a b. (IsString a, IsString b) => (a, b)

388−opDisj = (C.dataHeytingAlgebra, C.disj)

389−

390−opNot :: forall a b. (IsString a, IsString b) => (a, b)

391−opNot = (C.dataHeytingAlgebra, C.not)

392−

393−unbox :: AST -> PSString -> AST

394−unbox e d = select . inlineCommonValues $ inlineCommonOperators e

395− where

396− select :: AST -> AST

397− select e' =

398− case e' of

399− Var{} -> unbox' e'

400− App{} -> unbox' e'

401− Indexer{} -> unbox' e'

402− _ -> e'

403− unbox' :: AST -> AST

404− unbox' e' = maybe e' (\t -> App Nothing (StringLiteral Nothing t) [e']) $ unboxType d

405−

406−unboxType :: PSString -> Maybe PSString

407−unboxType s = do

408− t <- decodeString s

409− t' <- unboxType' t

410− return $ mkString t'

411− where

412− unboxType' :: Text -> Maybe Text

413− unboxType' t

414− | t == C.eqInt ||

415− t == C.semiringInt ||

416− t == C.ringInt ||

417− t == C.ordInt ||

418− t == C.dataIntBits

419− = Just int

420− | t == C.semiringNumber ||

421− t == C.ringNumber ||

422− t == C.ordNumber ||

423− t == C.euclideanRingNumber

424− = Just float

425− | t == C.eqBoolean ||

426− t == C.ordBoolean ||

427− t == C.heytingAlgebraBoolean

428− = Just bool

429− | t == C.eqChar ||

430− t == C.eqString ||

431− t == C.ordChar ||

432− t == C.ordString ||

433− t == C.semigroupString

434− = Just string

435− | otherwise = Nothing

src/CodeGen/IL/Optimizer/MagicDo.hsdeleted−146

@@ -1,146 +0,0 @@

1−-- | This module implements the "Magic Do" optimization, which inlines calls to return

2−-- and bind for the Eff monad, as well as some of its actions.

3−module CodeGen.IL.Optimizer.MagicDo (magicDoEffect, magicDoEff, magicDoST, inlineST) where

4−

5−import Prelude.Compat

6−import Protolude (ordNub)

7−

8−import Data.Maybe (fromJust, isJust)

9−import Data.Text (Text)

10−

11−import Language.PureScript.CoreImp.AST

12−import Language.PureScript.CoreImp.Optimizer.Common hiding (isDict)

13−import Language.PureScript.PSString (PSString, decodeString, mkString)

14−import qualified Language.PureScript.Constants as C

15−

16−import CodeGen.IL.Common (undefinedName, unusedName)

17−import CodeGen.IL.Optimizer.Common

18−

19−-- | Inline type class dictionaries for >>= and return for the Eff monad

20−--

21−-- E.g.

22−--

23−-- Prelude[">>="](dict)(m1)(function(x) {

24−-- return ...;

25−-- })

26−--

27−-- becomes

28−--

29−-- function __do {

30−-- var x = m1();

31−-- ...

32−-- }

33−magicDoEff :: AST -> AST

34−magicDoEff = magicDo C.eff C.effDictionaries

35−

36−magicDoEffect :: AST -> AST

37−magicDoEffect = magicDo C.effect C.effectDictionaries

38−

39−magicDoST :: AST -> AST

40−magicDoST = magicDo C.st C.stDictionaries

41−

42−magicDo :: Text -> C.EffectDictionaries -> AST -> AST

43−magicDo effectModule C.EffectDictionaries{..} = everywhereTopDown convert

44− where

45− -- Desugar monomorphic calls to >>= and return for the Eff monad

46− convert :: AST -> AST

47− -- Desugar pure

48− convert (App _ (App _ pure' [val]) []) | isPure pure' = val

49− -- Desugar discard

50− convert (App _ (App _ bind [m]) [Function s1 Nothing [unused] (Block s2 il)]) | isDiscard bind && unused == unusedName =

51− Function s1 Nothing [] $ Block s2 (App s2 m [] : map applyReturns il )

52− -- Desugar bind

53− convert (App _ (App _ bind [m]) [Function s1 Nothing [arg] (Block s2 il)]) | isBind bind =

54− Function s1 Nothing [] $ Block s2 (VariableIntroduction s2 arg (Just (App s2 m [])) : map applyReturns il)

55− -- Desugar untilE

56− convert (App s1 (App _ f [arg]) []) | isEffFunc edUntil f =

57− App s1 (Function s1 Nothing [] (Block s1 [ While s1 (Unary s1 Not (App s1 arg [])) (Block s1 []), Return s1 $ ObjectLiteral s1 []])) []

58− -- Desugar whileE

59− convert (App _ (App _ (App s1 f [arg1]) [arg2]) []) | isEffFunc edWhile f =

60− App s1 (Function s1 Nothing [] (Block s1 [ While s1 (App s1 arg1 []) (Block s1 [ App s1 arg2 [] ]), Return s1 $ ObjectLiteral s1 []])) []

61− -- -- Inline __do returns

62− -- convert (Return _ (App _ (Function _ (Just ident) [] body) [])) | ident == fnName = body

63− -- Inline double applications

64− convert (App _ (App s1 (Function s2 Nothing [] (Block ss body)) []) []) =

65− App s1 (Function s2 Nothing [] (Block ss (applyReturns `fmap` body))) []

66− convert other = other

67− -- Check if an expression represents a monomorphic call to >>= for the Eff monad

68− isBind (App _ fn [dict]) | isDict (effectModule, edBindDict) dict && isBindPoly fn = True

69− isBind _ = False

70− -- Check if an expression represents a call to @discard@

71− isDiscard (App _ (App _ fn [dict1]) [dict2])

72− | isDict (C.controlBind, C.discardUnitDictionary) dict1 &&

73− isDict (effectModule, edBindDict) dict2 &&

74− isDiscardPoly fn = True

75− isDiscard _ = False

76−

77− -- Check if an expression represents a monomorphic call to pure or return for the Eff applicative

78− isPure (App _ fn [dict]) | isDict (effectModule, edApplicativeDict) dict && isPurePoly fn = True

79− isPure _ = False

80− -- Check if an expression represents the polymorphic >>= function

81− isBindPoly = isDict (C.controlBind, C.bind)

82− -- Check if an expression represents the polymorphic pure function

83− isPurePoly = isDict (C.controlApplicative, C.pure')

84− -- Check if an expression represents the polymorphic discard function

85− isDiscardPoly = isDict (C.controlBind, C.discard)

86− -- Check if an expression represents a function in the Effect module

87− isEffFunc name (Indexer _ (StringLiteral _ name') (Var _ eff)) = eff == effectModule && name == name'

88− isEffFunc _ _ = False

89−

90− applyReturns :: AST -> AST

91− applyReturns (Return ss ret) = Return ss (App ss ret [])

92− applyReturns (Block ss ils) = Block ss (map applyReturns ils)

93− applyReturns (While ss cond il) = While ss cond (applyReturns il)

94− applyReturns (For ss v lo hi il) = For ss v lo hi (applyReturns il)

95− applyReturns (ForIn ss v xs il) = ForIn ss v xs (applyReturns il)

96− applyReturns (IfElse ss cond t f) = IfElse ss cond (applyReturns t) (applyReturns `fmap` f)

97− applyReturns other = other

98−

99−-- | Inline functions in the ST module

100−inlineST :: AST -> AST

101−inlineST = everywhere convertBlock

102− where

103− -- Look for runST blocks and inline the STRefs there.

104− -- If all STRefs are used in the scope of the same runST, only using { read, write, modify }STRef then

105− -- we can be more aggressive about inlining, and actually turn STRefs into local variables.

106− convertBlock (App s1 f [arg]) | isSTFunc C.runST f =

107− let refs = ordNub . findSTRefsIn $ arg

108− usages = findAllSTUsagesIn arg

109− allUsagesAreLocalVars = all (\u -> let v = toVar u in isJust v && fromJust v `elem` refs) usages

110− localVarsDoNotEscape = all (\r -> length (r `appearingIn` arg) == length (filter (\u -> let v = toVar u in v == Just r) usages)) refs

111− in App s1 (everywhere (convert (allUsagesAreLocalVars && localVarsDoNotEscape)) arg) []

112− convertBlock other = other

113− -- Convert a block in a safe way, preserving object wrappers of references,

114− -- or in a more aggressive way, turning wrappers into local variables depending on the

115− -- agg(ressive) parameter.

116− convert agg (App s1 f [arg]) | isSTFunc C.newSTRef f =

117− Function s1 Nothing [] (Block s1 [Return s1 $ if agg then arg else ObjectLiteral s1 [(mkString C.stRefValue, arg)]])

118− convert agg (App _ (App s1 f [ref]) []) | isSTFunc C.readSTRef f =

119− if agg then ref else Indexer s1 (StringLiteral s1 C.stRefValue) ref

120− convert agg (App _ (App _ (App s1 f [arg]) [ref]) []) | isSTFunc C.writeSTRef f =

121− if agg then Assignment s1 ref arg else Assignment s1 (Indexer s1 (StringLiteral s1 C.stRefValue) ref) arg

122− convert agg (App _ (App _ (App s1 f [func]) [ref]) []) | isSTFunc C.modifySTRef f =

123− if agg then Assignment s1 ref (App s1 func [ref]) else Assignment s1 (Indexer s1 (StringLiteral s1 C.stRefValue) ref) (App s1 func [Indexer s1 (StringLiteral s1 C.stRefValue) ref])

124− convert _ other = other

125− -- Check if an expression represents a function in the ST module

126− isSTFunc name (Indexer _ (StringLiteral _ name') (Var _ st)) = st == C.st && name == name'

127− isSTFunc _ _ = False

128− -- Find all ST Refs initialized in this block

129− findSTRefsIn = everything (++) isSTRef

130− where

131− isSTRef (VariableIntroduction _ ident (Just (App _ (App _ f [_]) []))) | isSTFunc C.newSTRef f = [ident]

132− isSTRef _ = []

133− -- Find all STRefs used as arguments to readSTRef, writeSTRef, modifySTRef

134− findAllSTUsagesIn = everything (++) isSTUsage

135− where

136− isSTUsage (App _ (App _ f [ref]) []) | isSTFunc C.readSTRef f = [ref]

137− isSTUsage (App _ (App _ (App _ f [_]) [ref]) []) | isSTFunc C.writeSTRef f || isSTFunc C.modifySTRef f = [ref]

138− isSTUsage _ = []

139− -- Find all uses of a variable

140− appearingIn ref = everything (++) isVar

141− where

142− isVar e@(Var _ v) | v == ref = [e]

143− isVar _ = []

144− -- Convert a AST value to a String if it is a Var

145− toVar (Var _ v) = Just v

146− toVar _ = Nothing

src/CodeGen/IL/Optimizer/TCO.hsdeleted−141

@@ -1,141 +0,0 @@

1−module CodeGen.IL.Optimizer.TCO (tco, tcoLoop) where

2−

3−import Prelude.Compat

4−

5−import Data.Text (Text)

6−import Data.Monoid ((<>))

7−import Language.PureScript.CoreImp.AST

8−import Language.PureScript.AST.SourcePos (SourceSpan)

9−import Safe (headDef, tailSafe)

10−import CodeGen.IL.Common

11−

12−import qualified Language.PureScript.Constants as C

13−

14−tcoLoop :: Text

15−tcoLoop = "ṩtco_loop"

16−

17−tco :: AST -> AST -> AST

18−tco mn = everywhere convert where

19− tcoVar :: Text -> Text

20− tcoVar arg = "ṩtco_var_" <> arg

21−

22− copyVar :: Text -> Text

23− copyVar arg = "ṩcopy_" <> arg

24−

25− tcoDone :: Text

26− tcoDone = "ṩtco_done"

27−

28− tcoResult :: Text

29− tcoResult = "ṩtco_result"

30−

31− convert :: AST -> AST

32− convert fn@(Function ss (Just name) args _)

33− | isTailRecursive name body'

34− = replace (toLoop name outerArgs innerArgs body')

35− where

36− innerArgs = headDef [] argss

37− outerArgs = concat . reverse $ tailSafe argss

38− (argss, body', replace) = collectAllFunctionArgs [] id fn

39− convert (Assignment ss (Var _ name) fn@(Function _ Nothing _ _))

40− | isTailRecursive name body'

41− = Assignment ss (Var ss name) (replace (toLoop name outerArgs innerArgs body'))

42− where

43− innerArgs = headDef [] argss

44− outerArgs = concat . reverse $ tailSafe argss

45− (argss, body', replace) = collectAllFunctionArgs [] id fn

46− convert js = js

47−

48− collectAllFunctionArgs :: [[Text]] -> (AST -> AST) -> AST -> ([[Text]], AST, AST -> AST)

49− collectAllFunctionArgs allArgs f (Function s1 ident args (Block s2 (body@(Return _ _):_))) =

50− collectAllFunctionArgs (args : allArgs) (\b -> f (Function s1 ident (map copyVar args) (Block s2 [b]))) body

51− collectAllFunctionArgs allArgs f (Function ss ident args body@(Block _ _)) =

52− (args : allArgs, body, f . Function ss ident (map copyVar args))

53− collectAllFunctionArgs allArgs f (Return s1 (Function s2 ident args (Block s3 [body]))) =

54− collectAllFunctionArgs (args : allArgs) (\b -> f (Return s1 (Function s2 ident (map copyVar args) (Block s3 [b])))) body

55− collectAllFunctionArgs allArgs f (Return s1 (Function s2 ident args body@(Block _ _))) =

56− (args : allArgs, body, f . Return s1 . Function s2 ident (map copyVar args))

57− collectAllFunctionArgs allArgs f body = (allArgs, body, f)

58−

59− isTailRecursive :: Text -> AST -> Bool

60− isTailRecursive ident js = countSelfReferences js > 0 && allInTailPosition js where

61− countSelfReferences = everything (+) match where

62− match :: AST -> Int

63− match (Var _ ident') | ident == ident' = 1

64− match _ = 0

65−

66− allInTailPosition (Return _ expr)

67− | isSelfCall ident expr = countSelfReferences expr == 1

68− | otherwise = countSelfReferences expr == 0

69− allInTailPosition (While _ js1 body)

70− = countSelfReferences js1 == 0 && allInTailPosition body

71− allInTailPosition (For _ _ js1 js2 body)

72− = countSelfReferences js1 == 0 && countSelfReferences js2 == 0 && allInTailPosition body

73− allInTailPosition (ForIn _ _ js1 body)

74− = countSelfReferences js1 == 0 && allInTailPosition body

75− allInTailPosition (IfElse _ js1 body el)

76− = countSelfReferences js1 == 0 && allInTailPosition body && all allInTailPosition el

77− allInTailPosition (Block _ body)

78− = all allInTailPosition body

79− allInTailPosition (Throw _ js1)

80− = countSelfReferences js1 == 0

81− allInTailPosition (ReturnNoResult _)

82− = True

83− allInTailPosition (VariableIntroduction _ _ js1)

84− = all ((== 0) . countSelfReferences) js1

85− allInTailPosition (Assignment _ _ js1)

86− = countSelfReferences js1 == 0

87− allInTailPosition (Comment _ _ js1)

88− = allInTailPosition js1

89− allInTailPosition _

90− = False

91−

92− toLoop :: Text -> [Text] -> [Text] -> AST -> AST

93− toLoop ident outerArgs innerArgs js =

94− Block rootSS $

95− concatMap (\arg -> [ VariableIntroduction rootSS (tcoVar arg) . Just $

96− Var rootSS (copyVar arg) ]) (outerArgs ++ innerArgs) ++

97− [ Assignment rootSS (Var rootSS $ "var " <> tcoDone) $ BooleanLiteral Nothing False

98− , VariableIntroduction rootSS tcoResult Nothing

99− , Assignment rootSS (Var rootSS $ "var " <> tcoLoop) (Function rootSS (Just tcoLoop) (outerArgs ++ innerArgs) (Block rootSS [loopify js]))

100− , While rootSS (Unary Nothing Not (Var rootSS tcoDone))

101− (Block rootSS

102− [(Assignment rootSS (Var rootSS tcoResult) (App rootSS (Var rootSS tcoLoop) ((map (Var rootSS . tcoVar) outerArgs) ++ (map (Var rootSS . copyVar) innerArgs))))])

103− , Return rootSS (Var rootSS tcoResult)

104− ]

105− where

106− rootSS = Nothing

107−

108− loopify :: AST -> AST

109− loopify (Return ss ret)

110− | isSelfCall ident ret =

111− let

112− allArgumentValues = concat $ collectArgs [] ret

113− in

114− Block ss $

115− zipWith (\val arg ->

116− Assignment ss (Var ss (tcoVar arg)) val) allArgumentValues outerArgs

117− ++ zipWith (\val arg ->

118− Assignment ss (Var ss (copyVar arg)) val) (drop (length outerArgs) allArgumentValues) innerArgs

119− ++ [ ReturnNoResult ss ]

120− | otherwise = Block ss [ markDone ss, Return ss ret ]

121− loopify (ReturnNoResult ss) = Block ss [ markDone ss, ReturnNoResult ss ]

122− loopify (While ss cond body) = While ss cond (loopify body)

123− loopify (For ss i js1 js2 body) = For ss i js1 js2 (loopify body)

124− loopify (ForIn ss i js1 body) = ForIn ss i js1 (loopify body)

125− loopify (IfElse ss cond body el) = IfElse ss cond (loopify body) (fmap loopify el)

126− loopify (Block ss body) = Block ss (map loopify body)

127− loopify other = other

128−

129− markDone :: Maybe SourceSpan -> AST

130− markDone ss = Assignment ss (Var ss tcoDone) (BooleanLiteral ss True)

131−

132− collectArgs :: [[AST]] -> AST -> [[AST]]

133− collectArgs acc (App _ fn args') = collectArgs (args' : acc) fn

134− collectArgs acc _ = acc

135−

136− isSelfCall :: Text -> AST -> Bool

137− isSelfCall ident (App _ (Var _ ident') _) = ident == ident'

138− isSelfCall ident (App _ (Indexer _ (Var _ ident') (Var _ mn')) _) = mn' == "" && ident == ident'

139− isSelfCall ident (App _ (Indexer _ (Var _ ident') mn') _) = mn' == mn && ident == ident'

140− isSelfCall ident (App _ fn _) = isSelfCall ident fn

141− isSelfCall _ _ = False

src/CodeGen/IL/Printer.hsdeleted−527

@@ -1,527 +0,0 @@

1−-- | Pretty printer for the AST

2−module CodeGen.IL.Printer

3− ( prettyPrintIL

4− , prettyPrintIL1

5− , prettyPrintILWithSourceMaps

6− , interfaceSource

7− , implHeaderSource

8− , implFooterSource

9− , isLiteral

10− , modLabel

11− , modPrefix

12− , ffiLoader

13− ) where

14−

15−import Prelude.Compat

16−

17−import Control.Arrow ((<+>))

18−import Control.Monad (forM, mzero)

19−import Control.Monad.State (StateT, evalStateT)

20−import Control.PatternArrows

21−import Data.List (filter, (\\))

22−import qualified Control.Arrow as A

23−

24−import Data.Maybe (fromMaybe)

25−import Data.Monoid ((<>))

26−import Data.Text (Text)

27−import qualified Data.Text as T

28−

29−import Language.PureScript.AST (SourceSpan(..))

30−import Language.PureScript.CoreImp.AST

31−import Language.PureScript.Comments

32−import Language.PureScript.Crash

33−import Language.PureScript.Names (Ident, runIdent)

34−import Language.PureScript.Pretty.Common

35−import Language.PureScript.PSString (PSString, decodeString, mkString)

36−

37−import CodeGen.IL.Common

38−import CodeGen.IL.Optimizer.TCO (tcoLoop)

39−

40−import qualified Language.PureScript.Constants as C

41−

42−-- TODO (Christoph): Get rid of T.unpack / pack

43−

44−literals :: (Emit gen) => Pattern PrinterState AST gen

45−literals = mkPattern' match'

46− where

47− match' :: (Emit gen) => AST -> StateT PrinterState Maybe gen

48− match' il = (addMapping' (getSourceSpan il) <>) <$> match il

49−

50− match :: (Emit gen) => AST -> StateT PrinterState Maybe gen

51− match (NumericLiteral _ n) = return $ emit $ T.pack $ either show show n

52− match (StringLiteral _ s) = return $ emit $ stringLiteral s

53− match (BooleanLiteral _ True) = return $ emit "true"

54− match (BooleanLiteral _ False) = return $ emit "false"

55− match (ArrayLiteral _ xs) = mconcat <$> sequence

56− [ return . emit $ arrayType <> "{"

57− , intercalate (emit ", ") <$> forM xs prettyPrintIL'

58− , return $ emit "}"

59− ]

60− -- match (ObjectLiteral _ []) = return $ emit "std::initializer_list<std::pair<const string, boxed>>{}"

61− match (ObjectLiteral _ ps) = mconcat <$> sequence

62− [ return . emit $ dictType <> "{"

63− , withIndent $ do

64− ils <- forM ps $ \(key, value) -> do

65− value' <- prettyPrintIL' value

66− return $ objectPropertyToString key <> value'

67− return $ intercalate (emit " ") $ map (<> emit ",") ils

68− , return $ emit "}"

69− ]

70− where

71− objectPropertyToString :: (Emit gen) => PSString -> gen

72− objectPropertyToString s = emit $ stringLiteral s <> ": "

73− match (Block _ sts) = mconcat <$> sequence

74− [ return $ emit "{\n"

75− , withIndent $ prettyStatements sts

76− , return $ emit "\n"

77− , currentIndent

78− , return $ emit "}"

79− ]

80− match (Var _ ident) | ident == C.undefined = return $ emit undefinedName

81− match (Var _ ident) = return $ emit ident

82− match (VariableIntroduction _ ident value) = mconcat <$> sequence

83− [ return . emit $ varDecl <> " " <> ident <> " " <> anyType

84− , maybe (return mempty) (fmap (emit " = " <>) . prettyPrintIL') value

85− ]

86− match (Assignment _ target value) = mconcat <$> sequence

87− [ prettyPrintIL' target

88− , return $ emit " = "

89− , prettyPrintIL' value

90− ]

91− match (App _ val []) = mconcat <$> sequence

92− [ return $ emit "Run("

93− , prettyPrintIL' val

94− , return $ emit ")"

95− ]

96− match (App _ (StringLiteral _ u) [arg])

97− | Just ty <- decodeString u = mconcat <$> sequence

98− [ prettyPrintIL' arg

99− , return $ emit ".("

100− , return $ emit ty

101− , return $ emit ")"

102− ]

103− match (App _ (Var _ fn) [arg]) | fn == arrayLengthFn = mconcat <$> sequence

104− [ return $ emit fn

105− , return $ emit "("

106− , prettyPrintIL' arg

107− , return $ emit ")"

108− ]

109− match (App _ (Var _ fn) args) | fn == indexFn = mconcat <$> sequence

110− [ return $ emit fn

111− , return $ emit "("

112− , intercalate (emit ", ") <$> forM args prettyPrintIL'

113− , return $ emit ")"

114− ]

115− match (App _ (Var _ fn) args) | fn == tcoLoop = mconcat <$> sequence

116− [ return $ emit fn

117− , return $ emit "("

118− , intercalate (emit ", ") <$> forM args prettyPrintIL'

119− , return $ emit ")"

120− ]

121− match (App _ (App Nothing (StringLiteral Nothing fnx) [fn@Function{}]) args)

122− | Just ftype <- decodeString fnx

123− , "Fn" `T.isPrefixOf` ftype = mconcat <$> sequence

124− [ prettyPrintIL' fn

125− , return $ emit "("

126− , intercalate (emit ", ") <$> forM args prettyPrintIL'

127− , return $ emit ")"

128− ]

129− match (App _ (App Nothing (StringLiteral Nothing fnx) [fn]) args)

130− | Just ftype <- decodeString fnx

131− , "Fn" `T.isPrefixOf` ftype = mconcat <$> sequence

132− [ prettyPrintIL' fn

133− , return $ emit ".("

134− , return $ emit ftype

135− , return $ emit ")("

136− , intercalate (emit ", ") <$> forM args prettyPrintIL'

137− , return $ emit ")"

138− ]

139− match app@(App{})

140− | (val, args) <- unApp app []

141− , length args > 1

142− = mconcat <$> sequence

143− [ return $ emit "Apply("

144− , prettyPrintIL' val

145− , return $ emit ", "

146− , intercalate (emit ", ") <$> forM args prettyPrintIL'

147− , return $ emit ")"

148− ]

149− match (App _ val args) = mconcat <$> sequence

150− [ return $ emit "Apply("

151− , prettyPrintIL' val

152− , return $ emit ", "

153− , intercalate (emit ", ") <$> forM args prettyPrintIL'

154− , return $ emit ")"

155− ]

156− match (Function _ (Just name) [] (Block _ [Return _ ret]))

157− | isComplexLiteral ret = mconcat <$> sequence

158− [ return $ emit "\n"

159− , return . emit $ varDecl <> " " <> initName name <> " Once\n"

160− , prettyPrintIL' $ VariableIntroduction Nothing (valueName name) Nothing

161− , return $ emit "\n\n"

162− , return $ emit "func "

163− , return . emit $ withPrefix name

164− , return . emit $ "() " <> anyType <> " "

165− , return $ emit "{\n"

166− , withIndent $ do

167− indentString <- currentIndent

168− return $ indentString <> (emit $ initName name <> ".Do(func() {\n") <>

169− indentString <> indentString <> (emit $ valueName name <> " = ")

170− , withIndent $ do

171− case ret of

172− Function _ Nothing args body -> mconcat <$> sequence

173− [ return $ emit "func("

174− , return . emit $ intercalate ", " (renderArg anyType <$> args)

175− , return . emit $ ") " <> anyType <> " "

176− , prettyPrintIL' body

177− ]

178− _ -> do

179− prettyPrintIL' ret

180− , return $ emit "\n"

181− , withIndent $ do

182− indentString <- currentIndent

183− return $ indentString <> (emit $ "})\n" <> "return " <> valueName name <>"\n")

184− , return $ emit "}\n\n"

185− ]

186− match (Function _ (Just name) [] ret) = mconcat <$> sequence

187− [ return $ emit "func "

188− , return . emit $ withPrefix name

189− , return . emit $ "() " <> anyType <> " "

190− , prettyPrintIL' ret

191− ]

192− match (Function _ _ args ret) = mconcat <$> sequence

193− [ return $ emit "func("

194− , return . emit $ intercalate ", " (renderArg anyType <$> args)

195− , return . emit $ ") " <> anyType <> " "

196− , prettyPrintIL' ret

197− ]

198− match (Indexer _ (Var _ name) (Var _ "")) = mconcat <$> sequence

199− [ prettyPrintIL' (Var Nothing $ withPrefix name)

200− , return $ emit "()"

201− ]

202− match (Indexer _ (Var _ name) val) = mconcat <$> sequence

203− [ prettyPrintIL' val

204− , return $ emit "."

205− , prettyPrintIL' (Var Nothing $ withPrefix name)

206− , return $ emit "()"

207− ]

208− match (Indexer _ prop@StringLiteral{} val@ObjectLiteral{}) = mconcat <$> sequence

209− [ prettyPrintIL' val

210− , return $ emit "["

211− , prettyPrintIL' prop

212− , return $ emit "]"

213− ]

214− match (Indexer _ prop@StringLiteral{} val) = mconcat <$> sequence

215− [ prettyPrintIL' val

216− , return $ emit ".("

217− , return $ emit dictType

218− , return $ emit ")["

219− , prettyPrintIL' prop

220− , return $ emit "]"

221− ]

222− match (Indexer _ index val@ArrayLiteral{}) = mconcat <$> sequence

223− [ prettyPrintIL' val

224− , return $ emit "["

225− , prettyPrintIL' index

226− , return $ emit "]"

227− ]

228− match (Indexer _ index val) = mconcat <$> sequence

229− [ prettyPrintIL' val

230− , return $ emit ".("

231− , return $ emit arrayType

232− , return $ emit ")["

233− , prettyPrintIL' index

234− , return $ emit "]"

235− ]

236− match (InstanceOf _ val ty) = mconcat <$> sequence

237− [ return $ emit "Is("

238− , prettyPrintIL' val

239− , return $ emit ", "

240− , prettyPrintIL' ty

241− , return $ emit ")"

242− ]

243− match (While _ cond sts) = mconcat <$> sequence

244− [ return $ emit "for "

245− , prettyPrintIL' cond

246− , return $ emit " "

247− , prettyPrintIL' sts

248− ]

249− match (For _ ident start end sts) = mconcat <$> sequence

250− [ return $ emit $ "for var " <> ident <> " = "

251− , prettyPrintIL' start

252− , return $ emit $ "; " <> ident <> " < "

253− , prettyPrintIL' end

254− , return $ emit $ "; " <> ident <> "++ "

255− , prettyPrintIL' sts

256− ]

257− match (ForIn _ ident obj sts) = mconcat <$> sequence

258− [ return $ emit $ "for var " <> ident <> " in "

259− , prettyPrintIL' obj

260− , return $ emit " "

261− , prettyPrintIL' sts

262− ]

263− match (IfElse _ (Binary _ EqualTo cond@Binary{} (BooleanLiteral Nothing True)) thens elses) = mconcat <$> sequence

264− [ return $ emit "if "

265− , prettyPrintIL' cond

266− , return $ emit " "

267− , prettyPrintIL' thens

268− , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintIL') elses

269− ]

270− match (IfElse _ (Binary _ EqualTo cond@Binary{} (BooleanLiteral Nothing False)) thens elses) = mconcat <$> sequence

271− [ return $ emit "if !("

272− , prettyPrintIL' cond

273− , return $ emit ") "

274− , prettyPrintIL' thens

275− , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintIL') elses

276− ]

277− match (IfElse _ cond thens elses) = mconcat <$> sequence

278− [ return $ emit "if "

279− , prettyPrintIL' cond

280− , return $ emit " "

281− , prettyPrintIL' thens

282− , maybe (return mempty) (fmap (emit " else " <>) . prettyPrintIL') elses

283− ]

284− match (Return _ value) = mconcat <$> sequence

285− [ return $ emit "return "

286− , prettyPrintIL' value

287− ]

288− match (ReturnNoResult _) = return . emit $ "return " <> undefinedName

289− -- match (Throw _ _) = return mempty

290− match (Throw _ value) = mconcat <$> sequence

291− [ return $ emit "panic("

292− , prettyPrintIL' value

293− , return $ emit ")"

294− ]

295− match (Comment _ com il) = mconcat <$> sequence

296− [ return $ emit "\n"

297− , mconcat <$> forM com comment

298− , prettyPrintIL' il

299− ]

300− match _ = mzero

301−

302− comment :: (Emit gen) => Comment -> StateT PrinterState Maybe gen

303− comment (LineComment com) = fmap mconcat $ sequence $

304− [ currentIndent

305− , return $ emit "//" <> emit com <> emit "\n"

306− ]

307− comment (BlockComment com) = fmap mconcat $ sequence $

308− [ currentIndent

309− , return $ emit "/**\n"

310− ] ++

311− map asLine (T.lines com) ++

312− [ currentIndent

313− , return $ emit " */\n"

314− , currentIndent

315− ]

316− where

317− asLine :: (Emit gen) => Text -> StateT PrinterState Maybe gen

318− asLine s = do

319− i <- currentIndent

320− return $ i <> emit " * " <> (emit . removeComments) s <> emit "\n"

321−

322− removeComments :: Text -> Text

323− removeComments t =

324− case T.stripPrefix "*/" t of

325− Just rest -> removeComments rest

326− Nothing -> case T.uncons t of

327− Just (x, xs) -> x `T.cons` removeComments xs

328− Nothing -> ""

329−

330−unary' :: (Emit gen) => UnaryOperator -> (AST -> Text) -> Operator PrinterState AST gen

331−unary' op mkStr = Wrap match (<>)

332− where

333− match :: (Emit gen) => Pattern PrinterState AST (gen, AST)

334− match = mkPattern match'

335− where

336− match' (Unary _ op' val) | op' == op = Just (emit $ mkStr val, val)

337− match' _ = Nothing

338−

339−unary :: (Emit gen) => UnaryOperator -> Text -> Operator PrinterState AST gen

340−unary op str = unary' op (const str)

341−

342−negateOperator :: (Emit gen) => Operator PrinterState AST gen

343−negateOperator = unary' Negate (\v -> if isNegate v then "- " else "-")

344− where

345− isNegate (Unary _ Negate _) = True

346− isNegate _ = False

347−

348−binary :: (Emit gen) => BinaryOperator -> Text -> Operator PrinterState AST gen

349−binary op str = AssocL match (\v1 v2 -> v1 <> emit (" " <> str <> " ") <> v2)

350− where

351− match :: Pattern PrinterState AST (AST, AST)

352− match = mkPattern match'

353− where

354− match' (Binary _ op' v1 v2) | op' == op = Just (v1, v2)

355− match' _ = Nothing

356−

357−isLiteral :: AST -> Bool

358−isLiteral Function{} = True

359−isLiteral NumericLiteral{} = True

360−isLiteral StringLiteral{} = True

361−isLiteral BooleanLiteral{} = True

362−isLiteral ObjectLiteral{} = True

363−isLiteral ArrayLiteral{} = True

364−isLiteral _ = False

365−

366−isComplexLiteral :: AST -> Bool

367−-- isComplexLiteral Function{} = True

368−isComplexLiteral ObjectLiteral{} = True

369−isComplexLiteral ArrayLiteral{} = True

370−isComplexLiteral _ = False

371−

372−unApp :: AST -> [AST] -> (AST, [AST])

373−unApp (App _ val [arg]) args = unApp val (arg : args)

374−unApp other args = (other, args)

375−

376−prettyStatements :: (Emit gen) => [AST] -> StateT PrinterState Maybe gen

377−prettyStatements sts = do

378− ils <- forM sts prettyPrintIL'

379− indentString <- currentIndent

380− return $ intercalate (emit "\n") $ map (indentString <>) ils

381−

382−-- | Generate a pretty-printed string representing a collection of C++ expressions at the same indentation level

383−prettyPrintILWithSourceMaps :: [AST] -> (Text, [SMap])

384−prettyPrintILWithSourceMaps il =

385− let StrPos (_, s, mp) = (fromMaybe (internalError "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyStatements) il

386− in (s, mp)

387−

388−prettyPrintIL :: [AST] -> Text

389−prettyPrintIL = maybe (internalError "Incomplete pattern") runPlainString . flip evalStateT (PrinterState 0) . prettyStatements

390−

391−-- | Generate an indented, pretty-printed string representing a C++ expression

392−prettyPrintIL' :: (Emit gen) => AST -> StateT PrinterState Maybe gen

393−prettyPrintIL' = A.runKleisli $ runPattern matchValue

394− where

395− matchValue :: (Emit gen) => Pattern PrinterState AST gen

396− matchValue = buildPrettyPrinter operators (literals <+> fmap parensPos matchValue)

397− operators :: (Emit gen) => OperatorTable PrinterState AST gen

398− operators =

399− OperatorTable [ [ unary New "?" ]

400− , [ unary Not "!"

401− , unary BitwiseNot "~"

402− , unary Positive "+"

403− , negateOperator ]

404− , [ binary Multiply "*"

405− , binary Divide "/"

406− , binary Modulus "%" ]

407− , [ binary Add "+"

408− , binary Subtract "-" ]

409− , [ binary ShiftLeft "<<"

410− , binary ShiftRight ">>" ]

411− , [ binary LessThan "<"

412− , binary LessThanOrEqualTo "<="

413− , binary GreaterThan ">"

414− , binary GreaterThanOrEqualTo ">=" ]

415− , [ binary EqualTo "=="

416− , binary NotEqualTo "!=" ]

417− , [ binary BitwiseAnd "&" ]

418− , [ binary BitwiseXor "^" ]

419− , [ binary BitwiseOr "|" ]

420− , [ binary And "&&" ]

421− , [ binary Or "||" ]

422− ]

423−

424−prettyPrintIL1 :: AST -> Text

425−prettyPrintIL1 = maybe (internalError "Incomplete pattern") runPlainString . flip evalStateT (PrinterState 0) . prettyPrintIL'

426−

427−stringLiteral :: PSString -> Text

428−stringLiteral pss | Just s <- decodeString pss = stringLiteral' s

429− where

430− stringLiteral' :: Text -> Text

431− stringLiteral' s = "\"" <> T.concatMap encodeChar s <> "\""

432− encodeChar :: Char -> Text

433− encodeChar '\0' = "\\x00"

434− encodeChar '\b' = "\\b"

435− encodeChar '\t' = "\\t"

436− encodeChar '\n' = "\\n"

437− encodeChar '\v' = "\\v"

438− encodeChar '\f' = "\\f"

439− encodeChar '\r' = "\\r"

440− encodeChar '"' = "\\\""

441− encodeChar '\\' = "\\\\"

442− encodeChar c = T.singleton $ c

443−stringLiteral _ = "\"\\uFFFD\""

444−

445−interfaceSource :: Text -> [(Text,Bool)] -> [Ident] -> Text

446−interfaceSource _ _ _ = ""

447−

448−implHeaderSource :: Text -> [Text] -> Text -> Text

449−implHeaderSource mn imports otherPrefix =

450− "// Code generated by psgo. DO NOT EDIT.\n\n" <>

451− "package " <> (if mn == "Main" || mn == "Test_Main" then "main" else mn) <> "\n\n" <>

452− "import . \"" <> runtime <> "\"\n" <>

453− (if mn == "Main" || mn == "Test_Main"

454− then "import _ \"" <> otherPrefix <> "/" <> ffiLoader <> "\"\n"

455− else "\n") <>

456− "import (\n" <>

457− (T.concat $ formatImport <$> imports) <> ")\n\n" <>

458− "type _ = Any\n\n"

459− where

460− formatImport :: Text -> Text

461− formatImport s =

462− "\t\"" <> otherPrefix <> "/" <> modPrefix <> "/" <> moduleRenamer s <> "\"\n"

463− moduleRenamer :: Text -> Text

464− moduleRenamer s

465− | (s', sfx) <- T.breakOn moduleRenamerMarker s,

466− not $ T.null sfx = s'

467− moduleRenamer s = s

468−

469−implFooterSource :: Text -> [Ident] -> Text

470−implFooterSource mn foreigns =

471− "\n\n\n" <>

472− (if null foreigns

473− then ""

474− else ("// Foreign values\n\n" <>

475− "var " <> foreignDict <> " = "<> foreignMod <> "(\"" <> mn <> "\")\n\n" <>

476− (T.concat $ (\foreign' ->

477− let name = moduleIdentToIL foreign' in

478− varDecl <> " " <> initName name <> " Once\n" <>

479− varDecl <> " " <> valueName name <> " " <> anyType <> "\n\n" <>

480− "func " <>

481− withPrefix name <>

482− "() Any { \n" <>

483− " " <> initName name <> ".Do(func() {\n" <>

484− " " <> valueName name <> " = " <>

485− "Get(" <> foreignDict <> ", " <>

486− (stringLiteral . mkString $ runIdent foreign') <> ")\n" <>

487− " })\n" <>

488− " return " <> valueName name <> "\n" <>

489− "}\n\n") <$> foreigns))) <>

490− if mn == "Main" || mn == "Test.Main" then mainSource else "\n"

491− where

492− mainSource :: Text

493− mainSource = "\

494− \func main() {\n\

495− \ Run(Ꞌmain())\n\

496− \}\n\n\

497− \"

498−

499−varDecl :: Text

500−varDecl = "var"

501−

502−renderArg :: Text -> Text -> Text

503−renderArg decl arg = arg <> " " <> decl

504−

505−foreignMod :: Text

506−foreignMod = "Foreign"

507−

508−foreignDict :: Text

509−foreignDict = "foreign"

510−

511−modLabel :: Text

512−modLabel = "purescript-native"

513−

514−modPrefix :: Text

515−modPrefix = modLabel <> "/output"

516−

517−runtime :: Text

518−runtime = "github.com/" <> modLabel <> "/go-runtime"

519−

520−ffiLoader :: Text

521−ffiLoader = modLabel <> "/ffi-loader"

522−

523−initName :: Text -> Text

524−initName s = "ᛌ" <> s <> "_once"

525−

526−valueName :: Text -> Text

527−valueName s = "ᛧ" <> s

src/Control/Monad/Supply.hsnew file+43

@@ -0,0 +1,43 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : Control.Monad.Supply

4+-- Copyright : (c) Phil Freeman 2014

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- |

12+-- Fresh variable supply

13+--

14+-----------------------------------------------------------------------------

15+

16+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

17+

18+module Control.Monad.Supply where

19+

20+import Data.Functor.Identity

21+

22+import Control.Applicative

23+import Control.Monad.State

24+import Control.Monad.Except

25+import Control.Monad.Reader

26+import Control.Monad.Writer

27+

28+newtype SupplyT m a = SupplyT { unSupplyT :: StateT Integer m a }

29+ deriving (Functor, Applicative, Monad, MonadTrans, MonadError e, MonadWriter w, MonadReader r)

30+

31+runSupplyT :: Integer -> SupplyT m a -> m (a, Integer)

32+runSupplyT n = flip runStateT n . unSupplyT

33+

34+evalSupplyT :: (Functor m) => Integer -> SupplyT m a -> m a

35+evalSupplyT n = fmap fst . runSupplyT n

36+

37+type Supply = SupplyT Identity

38+

39+runSupply :: Integer -> Supply a -> (a, Integer)

40+runSupply n = runIdentity . runSupplyT n

41+

42+evalSupply :: Integer -> Supply a -> a

43+evalSupply n = runIdentity . evalSupplyT n

src/Control/Monad/Supply/Class.hsnew file+36

@@ -0,0 +1,36 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : Control.Monad.Supply.Class

4+-- Copyright : (c) PureScript 2015

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- |

12+-- A class for monads supporting a supply of fresh names

13+--

14+-----------------------------------------------------------------------------

15+

16+{-# LANGUAGE MultiParamTypeClasses #-}

17+

18+module Control.Monad.Supply.Class where

19+

20+import Control.Monad.Supply

21+import Control.Monad.State

22+

23+class (Monad m) => MonadSupply m where

24+ fresh :: m Integer

25+

26+instance (Monad m) => MonadSupply (SupplyT m) where

27+ fresh = SupplyT $ do

28+ n <- get

29+ put (n + 1)

30+ return n

31+

32+instance (MonadSupply m) => MonadSupply (StateT s m) where

33+ fresh = lift fresh

34+

35+freshName :: (MonadSupply m) => m String

36+freshName = liftM (('_' :) . show) fresh

src/Control/Monad/Unify.hsnew file+159

@@ -0,0 +1,159 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : Control.Monad.Unify

4+-- Copyright : (c) Phil Freeman 2013

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- |

12+--

13+--

14+-----------------------------------------------------------------------------

15+

16+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

17+{-# LANGUAGE FlexibleInstances #-}

18+{-# LANGUAGE FlexibleContexts #-}

19+{-# LANGUAGE DeriveDataTypeable #-}

20+{-# LANGUAGE MultiParamTypeClasses #-}

21+{-# LANGUAGE FunctionalDependencies #-}

22+{-# LANGUAGE UndecidableInstances #-}

23+

24+module Control.Monad.Unify where

25+

26+import Data.Monoid

27+

28+import Control.Applicative

29+import Control.Monad.State

30+import Control.Monad.Error.Class

31+

32+import Data.HashMap.Strict as M

33+

34+-- |

35+-- Untyped unification variables

36+--

37+type Unknown = Int

38+

39+-- |

40+-- A type which can contain unification variables

41+--

42+class Partial t where

43+ unknown :: Unknown -> t

44+ isUnknown :: t -> Maybe Unknown

45+ unknowns :: t -> [Unknown]

46+ ($?) :: Substitution t -> t -> t

47+

48+-- |

49+-- Identifies types which support unification

50+--

51+class (Partial t) => Unifiable m t | t -> m where

52+ (=?=) :: t -> t -> UnifyT t m ()

53+

54+-- |

55+-- A substitution maintains a mapping from unification variables to their values

56+--

57+data Substitution t = Substitution { runSubstitution :: M.HashMap Int t }

58+

59+instance (Partial t) => Monoid (Substitution t) where

60+ mempty = Substitution M.empty

61+ s1 `mappend` s2 = Substitution $

62+ M.map (s2 $?) (runSubstitution s1) `M.union`

63+ M.map (s1 $?) (runSubstitution s2)

64+

65+-- |

66+-- State required for type checking

67+--

68+data UnifyState t = UnifyState {

69+ -- |

70+ -- The next fresh unification variable

71+ --

72+ unifyNextVar :: Int

73+ -- |

74+ -- The current substitution

75+ --

76+ , unifyCurrentSubstitution :: Substitution t

77+ }

78+

79+-- |

80+-- An empty @UnifyState@

81+--

82+defaultUnifyState :: (Partial t) => UnifyState t

83+defaultUnifyState = UnifyState 0 mempty

84+

85+-- |

86+-- A class for errors which support unification errors

87+--

88+class UnificationError t e where

89+ occursCheckFailed :: t -> e

90+

91+-- |

92+-- The type checking monad, which provides the state of the type checker, and error reporting capabilities

93+--

94+newtype UnifyT t m a = UnifyT { unUnify :: StateT (UnifyState t) m a }

95+ deriving (Functor, Monad, Applicative, Alternative, MonadPlus)

96+

97+instance (MonadState s m) => MonadState s (UnifyT t m) where

98+ get = UnifyT . lift $ get

99+ put = UnifyT . lift . put

100+

101+instance (MonadError e m) => MonadError e (UnifyT t m) where

102+ throwError = UnifyT . throwError

103+ catchError e f = UnifyT $ catchError (unUnify e) (unUnify . f)

104+

105+-- |

106+-- Run a computation in the Unify monad, failing with an error, or succeeding with a return value and the new next unification variable

107+--

108+runUnify :: UnifyState t -> UnifyT t m a -> m (a, UnifyState t)

109+runUnify s = flip runStateT s . unUnify

110+

111+-- |

112+-- Substitute a single unification variable

113+--

114+substituteOne :: (Partial t) => Unknown -> t -> Substitution t

115+substituteOne u t = Substitution $ M.singleton u t

116+

117+-- |

118+-- Replace a unification variable with the specified value in the current substitution

119+--

120+(=:=) :: (UnificationError t e, Monad m, MonadError e m, Unifiable m t) => Unknown -> t -> UnifyT t m ()

121+(=:=) u t' = do

122+ st <- UnifyT get

123+ let sub = unifyCurrentSubstitution st

124+ let t = sub $? t'

125+ occursCheck u t

126+ let current = sub $? unknown u

127+ case isUnknown current of

128+ Just u1 | u1 == u -> return ()

129+ _ -> current =?= t

130+ UnifyT $ modify $ \s -> s { unifyCurrentSubstitution = substituteOne u t <> unifyCurrentSubstitution s }

131+

132+-- |

133+-- Perform the occurs check, to make sure a unification variable does not occur inside a value

134+--

135+occursCheck :: (UnificationError t e, Monad m, MonadError e m, Partial t) => Unknown -> t -> UnifyT t m ()

136+occursCheck u t =

137+ case isUnknown t of

138+ Nothing -> when (u `elem` unknowns t) $ UnifyT . lift . throwError $ occursCheckFailed t

139+ _ -> return ()

140+

141+-- |

142+-- Generate a fresh untyped unification variable

143+--

144+fresh' :: (Monad m) => UnifyT t m Unknown

145+fresh' = do

146+ st <- UnifyT get

147+ UnifyT $ modify $ \s -> s { unifyNextVar = succ (unifyNextVar s) }

148+ return $ unifyNextVar st

149+

150+-- |

151+-- Generate a fresh unification variable at a specific type

152+--

153+fresh :: (Monad m, Partial t) => UnifyT t m t

154+fresh = do

155+ u <- fresh'

156+ return $ unknown u

157+

158+

159+

src/Language/PureScript.hsnew file+269

@@ -0,0 +1,269 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : Language.PureScript

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- |

12+-- The main compiler module

13+--

14+-----------------------------------------------------------------------------

15+

16+{-# LANGUAGE DataKinds #-}

17+{-# LANGUAGE QuasiQuotes #-}

18+{-# LANGUAGE TemplateHaskell #-}

19+{-# LANGUAGE FlexibleContexts #-}

20+{-# LANGUAGE ScopedTypeVariables #-}

21+

22+module Language.PureScript

23+ ( module P

24+ , compile

25+ , compile'

26+ , RebuildPolicy(..)

27+ , MonadMake(..)

28+ , make

29+ , prelude

30+ ) where

31+

32+import Data.FileEmbed (embedFile)

33+import Data.Function (on)

34+import Data.List (sortBy, groupBy, intercalate)

35+import Data.Maybe (fromMaybe)

36+import Data.Time.Clock

37+import qualified Data.Traversable as T (traverse)

38+import qualified Data.ByteString.UTF8 as BU

39+import qualified Data.Map as M

40+import qualified Data.Set as S

41+

42+import Control.Applicative

43+import Control.Arrow ((&&&))

44+import Control.Monad.Except

45+import Control.Monad.Reader

46+

47+import System.FilePath ((</>))

48+

49+import Language.PureScript.AST as P

50+import Language.PureScript.Comments as P

51+import Language.PureScript.CodeGen as P

52+import Language.PureScript.DeadCodeElimination as P

53+import Language.PureScript.Environment as P

54+import Language.PureScript.Errors as P

55+import Language.PureScript.Kinds as P

56+import Language.PureScript.ModuleDependencies as P

57+import Language.PureScript.Names as P

58+import Language.PureScript.Options as P

59+import Language.PureScript.Parser as P

60+import Language.PureScript.Pretty as P

61+import Language.PureScript.Renamer as P

62+import Language.PureScript.Sugar as P

63+import Control.Monad.Supply as P

64+import Language.PureScript.TypeChecker as P

65+import Language.PureScript.Types as P

66+import qualified Language.PureScript.CoreFn as CoreFn

67+import qualified Language.PureScript.Constants as C

68+

69+-- |

70+-- Compile a collection of modules

71+--

72+-- The compilation pipeline proceeds as follows:

73+--

74+-- * Sort the modules based on module dependencies, checking for cyclic dependencies.

75+--

76+-- * Perform a set of desugaring passes.

77+--

78+-- * Type check, and elaborate values to include type annotations and type class dictionaries.

79+--

80+-- * Regroup values to take into account new value dependencies introduced by elaboration.

81+--

82+-- * Eliminate dead code.

83+--

84+-- * Generate Javascript, and perform optimization passes.

85+--

86+-- * Pretty-print the generated Javascript

87+--

88+compile :: (Functor m, Applicative m, MonadError String m, MonadReader (Options Compile) m)

89+ => [Module] -> [String] -> m (String, String, Environment)

90+compile = compile' initEnvironment

91+

92+compile' :: (Functor m, Applicative m, MonadError String m, MonadReader (Options Compile) m)

93+ => Environment -> [Module] -> [String] -> m (String, String, Environment)

94+compile' env ms prefix = do

95+ noPrelude <- asks optionsNoPrelude

96+ additional <- asks optionsAdditional

97+ mainModuleIdent <- asks (fmap moduleNameFromString . optionsMain)

98+ (sorted, _) <- sortModules $ map importPrim $ if noPrelude then ms else map importPrelude ms

99+ (desugared, nextVar) <- interpretMultipleErrors True $ runSupplyT 0 $ desugar sorted

100+ (elaborated, env') <- runCheck' env $ forM desugared $ typeCheckModule mainModuleIdent

101+ regrouped <- interpretMultipleErrors True $ createBindingGroupsModule . collapseBindingGroupsModule $ elaborated

102+ let corefn = map (CoreFn.moduleToCoreFn env') regrouped

103+ let entryPoints = moduleNameFromString `map` entryPointModules additional

104+ let elim = if null entryPoints then corefn else eliminateDeadCode entryPoints corefn

105+ let renamed = renameInModules elim

106+ let codeGenModuleNames = moduleNameFromString `map` codeGenModules additional

107+ let modulesToCodeGen = if null codeGenModuleNames then renamed else filter (\(CoreFn.Module _ mn _ _ _ _) -> mn `elem` codeGenModuleNames) renamed

108+ js <- concat <$> (evalSupplyT nextVar $ T.traverse moduleToJs modulesToCodeGen)

109+ let exts = intercalate "\n" . map (`moduleToPs` env') $ regrouped

110+ js' <- generateMain env' js

111+ let pjs = unlines $ map ("// " ++) prefix ++ [prettyPrintJS js']

112+ return (pjs, exts, env')

113+

114+generateMain :: (MonadError String m, MonadReader (Options Compile) m) => Environment -> [JS] -> m [JS]

115+generateMain env js = do

116+ main <- asks optionsMain

117+ additional <- asks optionsAdditional

118+ case moduleNameFromString <$> main of

119+ Just mmi -> do

120+ when ((mmi, Ident C.main) `M.notMember` names env) $

121+ throwError $ show mmi ++ "." ++ C.main ++ " is undefined"

122+ return $ js ++ [JSApp (JSAccessor C.main (JSAccessor (moduleNameToJs mmi) (JSVar (browserNamespace additional)))) []]

123+ _ -> return js

124+

125+-- |

126+-- A type class which collects the IO actions we need to be able to run in "make" mode

127+--

128+class (MonadReader (P.Options P.Make) m, MonadError String m) => MonadMake m where

129+ -- |

130+ -- Get a file timestamp

131+ --

132+ getTimestamp :: FilePath -> m (Maybe UTCTime)

133+

134+ -- |

135+ -- Read a file as a string

136+ --

137+ readTextFile :: FilePath -> m String

138+

139+ -- |

140+ -- Write a text file

141+ --

142+ writeTextFile :: FilePath -> String -> m ()

143+

144+ -- |

145+ -- Respond to a progress update

146+ --

147+ progress :: String -> m ()

148+

149+-- |

150+-- Determines when to rebuild a module

151+--

152+data RebuildPolicy

153+ -- | Never rebuild this module

154+ = RebuildNever

155+ -- | Always rebuild this module

156+ | RebuildAlways deriving (Show, Eq, Ord)

157+

158+-- Traverse (Either e) instance (base 4.7)

159+traverseEither :: Applicative f => (a -> f b) -> Either e a -> f (Either e b)

160+traverseEither _ (Left x) = pure (Left x)

161+traverseEither f (Right y) = Right <$> f y

162+

163+-- |

164+-- Compiles in "make" mode, compiling each module separately to a js files and an externs file

165+--

166+-- If timestamps have not changed, the externs file can be used to provide the module's types without

167+-- having to typecheck the module again.

168+--

169+make :: forall m. (Functor m, Applicative m, Monad m, MonadMake m)

170+ => FilePath -> [(Either RebuildPolicy FilePath, Module)] -> [String] -> m Environment

171+make outputDir ms prefix = do

172+ noPrelude <- asks optionsNoPrelude

173+ let filePathMap = M.fromList (map (\(fp, Module _ mn _ _) -> (mn, fp)) ms)

174+

175+ (sorted, graph) <- sortModules $ map importPrim $ if noPrelude then map snd ms else map (importPrelude . snd) ms

176+

177+ toRebuild <- foldM (\s (Module _ moduleName' _ _) -> do

178+ let filePath = runModuleName moduleName'

179+

180+ jsFile = outputDir </> filePath </> "index.js"

181+ externsFile = outputDir </> filePath </> "externs.purs"

182+ inputFile = fromMaybe (error "Module has no filename in 'make'") $ M.lookup moduleName' filePathMap

183+

184+ jsTimestamp <- getTimestamp jsFile

185+ externsTimestamp <- getTimestamp externsFile

186+ inputTimestamp <- traverseEither getTimestamp inputFile

187+

188+ return $ case (inputTimestamp, jsTimestamp, externsTimestamp) of

189+ (Right (Just t1), Just t2, Just t3) | t1 < min t2 t3 -> s

190+ (Left RebuildNever, Just _, Just _) -> s

191+ _ -> S.insert moduleName' s) S.empty sorted

192+

193+ marked <- rebuildIfNecessary (reverseDependencies graph) toRebuild sorted

194+

195+ (desugared, nextVar) <- interpretMultipleErrors True $ runSupplyT 0 $ zip (map fst marked) <$> desugar (map snd marked)

196+

197+ evalSupplyT nextVar $ go initEnvironment desugared

198+

199+ where

200+ go :: Environment -> [(Bool, Module)] -> SupplyT m Environment

201+ go env [] = return env

202+ go env ((False, m) : ms') = do

203+ (_, env') <- lift . runCheck' env $ typeCheckModule Nothing m

204+

205+ go env' ms'

206+ go env ((True, m@(Module coms moduleName' _ exps)) : ms') = do

207+ let filePath = runModuleName moduleName'

208+ jsFile = outputDir </> filePath </> "index.js"

209+ externsFile = outputDir </> filePath </> "externs.purs"

210+

211+ lift . progress $ "Compiling " ++ runModuleName moduleName'

212+

213+ (Module _ _ elaborated _, env') <- lift . runCheck' env $ typeCheckModule Nothing m

214+

215+ regrouped <- interpretMultipleErrors True . createBindingGroups moduleName' . collapseBindingGroups $ elaborated

216+

217+ let mod' = Module coms moduleName' regrouped exps

218+ let corefn = CoreFn.moduleToCoreFn env' mod'

219+ let [renamed] = renameInModules [corefn]

220+

221+ pjs <- prettyPrintJS <$> moduleToJs renamed

222+ let js = unlines $ map ("// " ++) prefix ++ [pjs]

223+ let exts = unlines $ map ("-- " ++) prefix ++ [moduleToPs mod' env']

224+

225+ lift $ writeTextFile jsFile js

226+ lift $ writeTextFile externsFile exts

227+

228+ go env' ms'

229+

230+ rebuildIfNecessary :: M.Map ModuleName [ModuleName] -> S.Set ModuleName -> [Module] -> m [(Bool, Module)]

231+ rebuildIfNecessary _ _ [] = return []

232+ rebuildIfNecessary graph toRebuild (m@(Module _ moduleName' _ _) : ms') | moduleName' `S.member` toRebuild = do

233+ let deps = fromMaybe [] $ moduleName' `M.lookup` graph

234+ toRebuild' = toRebuild `S.union` S.fromList deps

235+ (:) (True, m) <$> rebuildIfNecessary graph toRebuild' ms'

236+ rebuildIfNecessary graph toRebuild (Module _ moduleName' _ _ : ms') = do

237+ let externsFile = outputDir </> runModuleName moduleName' </> "externs.purs"

238+ externs <- readTextFile externsFile

239+ externsModules <- fmap (map snd) . either (throwError . show) return $ P.parseModulesFromFiles id [(externsFile, externs)]

240+ case externsModules of

241+ [m'@(Module _ moduleName'' _ _)] | moduleName'' == moduleName' -> (:) (False, m') <$> rebuildIfNecessary graph toRebuild ms'

242+ _ -> throwError $ "Externs file " ++ externsFile ++ " was invalid"

243+

244+reverseDependencies :: ModuleGraph -> M.Map ModuleName [ModuleName]

245+reverseDependencies g = combine [ (dep, mn) | (mn, deps) <- g, dep <- deps ]

246+ where

247+ combine :: (Ord a) => [(a, b)] -> M.Map a [b]

248+ combine = M.fromList . map ((fst . head) &&& map snd) . groupBy ((==) `on` fst) . sortBy (compare `on` fst)

249+

250+-- |

251+-- Add an import declaration for a module if it does not already explicitly import it.

252+--

253+addDefaultImport :: ModuleName -> Module -> Module

254+addDefaultImport toImport m@(Module coms mn decls exps) =

255+ if isExistingImport `any` decls || mn == toImport then m

256+ else Module coms mn (ImportDeclaration toImport Unqualified Nothing : decls) exps

257+ where

258+ isExistingImport (ImportDeclaration mn' _ _) | mn' == toImport = True

259+ isExistingImport (PositionedDeclaration _ _ d) = isExistingImport d

260+ isExistingImport _ = False

261+

262+importPrim :: Module -> Module

263+importPrim = addDefaultImport (ModuleName [ProperName C.prim])

264+

265+importPrelude :: Module -> Module

266+importPrelude = addDefaultImport (ModuleName [ProperName C.prelude])

267+

268+prelude :: String

269+prelude = BU.toString $(embedFile "prelude/prelude.purs")

src/Language/PureScript/AST.hsnew file+23

@@ -0,0 +1,23 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : Language.PureScript.AST

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.hsnew file+87

@@ -0,0 +1,87 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : Language.PureScript.AST.Binders

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.hsnew file+454

@@ -0,0 +1,454 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : Language.PureScript.AST.Declarations

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- | Data types for modules and declarations

12+--

13+-----------------------------------------------------------------------------

14+

15+{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-}

16+

17+module Language.PureScript.AST.Declarations where

18+

19+import qualified Data.Data as D

20+

21+import Language.PureScript.AST.Binders

22+import Language.PureScript.AST.Operators

23+import Language.PureScript.AST.SourcePos

24+import Language.PureScript.Types

25+import Language.PureScript.Names

26+import Language.PureScript.Kinds

27+import Language.PureScript.TypeClassDictionaries

28+import Language.PureScript.Comments

29+import Language.PureScript.CodeGen.JS.AST

30+import Language.PureScript.Environment

31+

32+-- |

33+-- A module declaration, consisting of comments about the module, a module name,

34+-- a list of declarations, and a list of the declarations that are

35+-- explicitly exported. If the export list is Nothing, everything is exported.

36+--

37+data Module = Module [Comment] ModuleName [Declaration] (Maybe [DeclarationRef]) deriving (Show, D.Data, D.Typeable)

38+

39+-- | Return a module's name.

40+getModuleName :: Module -> ModuleName

41+getModuleName (Module _ name _ _) = name

42+

43+-- |

44+-- Test if a declaration is exported, given a module's export list.

45+--

46+isExported :: Maybe [DeclarationRef] -> Declaration -> Bool

47+isExported Nothing _ = True

48+isExported _ TypeInstanceDeclaration{} = True

49+isExported exps (PositionedDeclaration _ _ d) = isExported exps d

50+isExported (Just exps) decl = any (matches decl) exps

51+ where

52+ matches (TypeDeclaration ident _) (ValueRef ident') = ident == ident'

53+ matches (ValueDeclaration ident _ _ _) (ValueRef ident') = ident == ident'

54+ matches (ExternDeclaration _ ident _ _) (ValueRef ident') = ident == ident'

55+ matches (DataDeclaration _ ident _ _) (TypeRef ident' _) = ident == ident'

56+ matches (ExternDataDeclaration ident _) (TypeRef ident' _) = ident == ident'

57+ matches (TypeSynonymDeclaration ident _ _) (TypeRef ident' _) = ident == ident'

58+ matches (TypeClassDeclaration ident _ _ _) (TypeClassRef ident') = ident == ident'

59+ matches (PositionedDeclaration _ _ d) r = d `matches` r

60+ matches d (PositionedDeclarationRef _ _ r) = d `matches` r

61+ matches _ _ = False

62+

63+exportedDeclarations :: Module -> [Declaration]

64+exportedDeclarations (Module _ _ decls exps) = filter (isExported exps) (flattenDecls decls)

65+

66+-- |

67+-- Test if a data constructor for a given type is exported, given a module's export list.

68+--

69+isDctorExported :: ProperName -> Maybe [DeclarationRef] -> ProperName -> Bool

70+isDctorExported _ Nothing _ = True

71+isDctorExported ident (Just exps) ctor = test `any` exps

72+ where

73+ test (PositionedDeclarationRef _ _ d) = test d

74+ test (TypeRef ident' Nothing) = ident == ident'

75+ test (TypeRef ident' (Just ctors)) = ident == ident' && ctor `elem` ctors

76+ test _ = False

77+

78+-- |

79+-- Return the exported data constructors for a given type.

80+--

81+exportedDctors :: Module -> ProperName -> [ProperName]

82+exportedDctors (Module _ _ decls exps) ident =

83+ filter (isDctorExported ident exps) dctors

84+ where

85+ dctors = concatMap getDctors (flattenDecls decls)

86+ getDctors (DataDeclaration _ _ _ ctors) = map fst ctors

87+ getDctors (PositionedDeclaration _ _ d) = getDctors d

88+ getDctors _ = []

89+

90+-- |

91+-- An item in a list of explicit imports or exports

92+--

93+data DeclarationRef

94+ -- |

95+ -- A type constructor with data constructors

96+ --

97+ = TypeRef ProperName (Maybe [ProperName])

98+ -- |

99+ -- A value

100+ --

101+ | ValueRef Ident

102+ -- |

103+ -- A type class

104+ --

105+ | TypeClassRef ProperName

106+ -- |

107+ -- A type class instance, created during typeclass desugaring (name, class name, instance types)

108+ --

109+ | TypeInstanceRef Ident

110+ -- |

111+ -- A declaration reference with source position information

112+ --

113+ | PositionedDeclarationRef SourceSpan [Comment] DeclarationRef

114+ deriving (Show, D.Data, D.Typeable)

115+

116+instance Eq DeclarationRef where

117+ (TypeRef name dctors) == (TypeRef name' dctors') = name == name' && dctors == dctors'

118+ (ValueRef name) == (ValueRef name') = name == name'

119+ (TypeClassRef name) == (TypeClassRef name') = name == name'

120+ (TypeInstanceRef name) == (TypeInstanceRef name') = name == name'

121+ (PositionedDeclarationRef _ _ r) == r' = r == r'

122+ r == (PositionedDeclarationRef _ _ r') = r == r'

123+ _ == _ = False

124+

125+-- |

126+-- The data type which specifies type of import declaration

127+--

128+data ImportDeclarationType

129+ -- |

130+ -- Unqualified import

131+ --

132+ = Unqualified

133+ -- |

134+ -- Qualified import with a list of references to import

135+ --

136+ | Qualifying [DeclarationRef]

137+ -- |

138+ -- Import with hiding clause with a list of references to hide

139+ --

140+ | Hiding [DeclarationRef]

141+ deriving (Show, D.Data, D.Typeable)

142+

143+-- |

144+-- The data type of declarations

145+--

146+data Declaration

147+ -- |

148+ -- A data type declaration (data or newtype, name, arguments, data constructors)

149+ --

150+ = DataDeclaration DataDeclType ProperName [(String, Maybe Kind)] [(ProperName, [Type])]

151+ -- |

152+ -- A minimal mutually recursive set of data type declarations

153+ --

154+ | DataBindingGroupDeclaration [Declaration]

155+ -- |

156+ -- A type synonym declaration (name, arguments, type)

157+ --

158+ | TypeSynonymDeclaration ProperName [(String, Maybe Kind)] Type

159+ -- |

160+ -- A type declaration for a value (name, ty)

161+ --

162+ | TypeDeclaration Ident Type

163+ -- |

164+ -- A value declaration (name, top-level binders, optional guard, value)

165+ --

166+ | ValueDeclaration Ident NameKind [Binder] (Either [(Guard, Expr)] Expr)

167+ -- |

168+ -- A minimal mutually recursive set of value declarations

169+ --

170+ | BindingGroupDeclaration [(Ident, NameKind, Expr)]

171+ -- |

172+ -- A foreign import declaration (type, name, optional inline Javascript, type)

173+ --

174+ | ExternDeclaration ForeignImportType Ident (Maybe JS) Type

175+ -- |

176+ -- A data type foreign import (name, kind)

177+ --

178+ | ExternDataDeclaration ProperName Kind

179+ -- |

180+ -- A type class instance foreign import

181+ --

182+ | ExternInstanceDeclaration Ident [Constraint] (Qualified ProperName) [Type]

183+ -- |

184+ -- A fixity declaration (fixity data, operator name)

185+ --

186+ | FixityDeclaration Fixity String

187+ -- |

188+ -- A module import (module name, qualified/unqualified/hiding, optional "qualified as" name)

189+ --

190+ | ImportDeclaration ModuleName ImportDeclarationType (Maybe ModuleName)

191+ -- |

192+ -- A type class declaration (name, argument, implies, member declarations)

193+ --

194+ | TypeClassDeclaration ProperName [(String, Maybe Kind)] [Constraint] [Declaration]

195+ -- |

196+ -- A type instance declaration (name, dependencies, class name, instance types, member

197+ -- declarations)

198+ --

199+ | TypeInstanceDeclaration Ident [Constraint] (Qualified ProperName) [Type] [Declaration]

200+ -- |

201+ -- A declaration with source position information

202+ --

203+ | PositionedDeclaration SourceSpan [Comment] Declaration

204+ deriving (Show, D.Data, D.Typeable)

205+

206+-- |

207+-- Test if a declaration is a value declaration

208+--

209+isValueDecl :: Declaration -> Bool

210+isValueDecl ValueDeclaration{} = True

211+isValueDecl (PositionedDeclaration _ _ d) = isValueDecl d

212+isValueDecl _ = False

213+

214+-- |

215+-- Test if a declaration is a data type or type synonym declaration

216+--

217+isDataDecl :: Declaration -> Bool

218+isDataDecl DataDeclaration{} = True

219+isDataDecl TypeSynonymDeclaration{} = True

220+isDataDecl (PositionedDeclaration _ _ d) = isDataDecl d

221+isDataDecl _ = False

222+

223+-- |

224+-- Test if a declaration is a module import

225+--

226+isImportDecl :: Declaration -> Bool

227+isImportDecl ImportDeclaration{} = True

228+isImportDecl (PositionedDeclaration _ _ d) = isImportDecl d

229+isImportDecl _ = False

230+

231+-- |

232+-- Test if a declaration is a data type foreign import

233+--

234+isExternDataDecl :: Declaration -> Bool

235+isExternDataDecl ExternDataDeclaration{} = True

236+isExternDataDecl (PositionedDeclaration _ _ d) = isExternDataDecl d

237+isExternDataDecl _ = False

238+

239+-- |

240+-- Test if a declaration is a type class instance foreign import

241+--

242+isExternInstanceDecl :: Declaration -> Bool

243+isExternInstanceDecl ExternInstanceDeclaration{} = True

244+isExternInstanceDecl (PositionedDeclaration _ _ d) = isExternInstanceDecl d

245+isExternInstanceDecl _ = False

246+

247+-- |

248+-- Test if a declaration is a fixity declaration

249+--

250+isFixityDecl :: Declaration -> Bool

251+isFixityDecl FixityDeclaration{} = True

252+isFixityDecl (PositionedDeclaration _ _ d) = isFixityDecl d

253+isFixityDecl _ = False

254+

255+-- |

256+-- Test if a declaration is a foreign import

257+--

258+isExternDecl :: Declaration -> Bool

259+isExternDecl ExternDeclaration{} = True

260+isExternDecl (PositionedDeclaration _ _ d) = isExternDecl d

261+isExternDecl _ = False

262+

263+-- |

264+-- Test if a declaration is a type class 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.hsnew file+39

@@ -0,0 +1,39 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : Language.PureScript.AST.Operators

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.hsnew file+53

@@ -0,0 +1,53 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : Language.PureScript.AST.SourcePos

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, D.Data, D.Typeable)

34+

35+instance Show SourcePos where

36+ show sp = "line " ++ show (sourcePosLine sp) ++ ", column " ++ show (sourcePosColumn sp)

37+

38+data SourceSpan = SourceSpan

39+ { -- |

40+ -- Source name

41+ --

42+ spanName :: String

43+ -- |

44+ -- Start of the span

45+ --

46+ , spanStart :: SourcePos

47+ -- End of the span

48+ --

49+ , spanEnd :: SourcePos

50+ } deriving (Eq, D.Data, D.Typeable)

51+

52+instance Show SourceSpan where

53+ show sp = spanName sp ++ " " ++ show (spanStart sp) ++ " - " ++ show (spanEnd sp)

src/Language/PureScript/AST/Traversals.hsnew file+407

@@ -0,0 +1,407 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : Language.PureScript.AST.Traversals

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.hsnew file+25

@@ -0,0 +1,25 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : Language.PureScript.CodeGen

4+-- Copyright : (c) Phil Freeman 2013

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- |

12+-- A collection of modules related to code generation:

13+--

14+-- [@Language.PureScript.CodeGen.JS@] Code generator for Javascript

15+--

16+-- [@Language.PureScript.CodeGen.Externs@] Code generator for extern (foreign import) files

17+--

18+-- [@Language.PureScript.CodeGen.Optimize@] Optimization passes for generated Javascript

19+--

20+-----------------------------------------------------------------------------

21+

22+module Language.PureScript.CodeGen (module C) where

23+

24+import Language.PureScript.CodeGen.JS as C

25+import Language.PureScript.CodeGen.Externs as C

src/Language/PureScript/CodeGen/Externs.hsnew file+121

@@ -0,0 +1,121 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : Language.PureScript.CodeGen.Externs

4+-- Copyright : (c) Phil Freeman 2013

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- |

12+-- This module generates code for \"externs\" files, i.e. files containing only foreign import declarations.

13+--

14+-----------------------------------------------------------------------------

15+

16+module Language.PureScript.CodeGen.Externs (

17+ moduleToPs

18+) where

19+

20+import Data.List (intercalate, find)

21+import Data.Maybe (fromMaybe, mapMaybe)

22+import qualified Data.Map as M

23+

24+import Control.Monad.Writer

25+

26+import Language.PureScript.AST

27+import Language.PureScript.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.hsnew file+365

@@ -0,0 +1,365 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : Language.PureScript.CodeGen.JS

4+-- Copyright : (c) Phil Freeman 2013

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- |

12+-- This module generates code in the simplified Javascript intermediate representation from Purescript code

13+--

14+-----------------------------------------------------------------------------

15+

16+{-# LANGUAGE GADTs #-}

17+{-# LANGUAGE ViewPatterns #-}

18+{-# LANGUAGE FlexibleContexts #-}

19+{-# LANGUAGE ScopedTypeVariables #-}

20+

21+module Language.PureScript.CodeGen.JS (

22+ module AST,

23+ module Common,

24+ moduleToJs

25+) where

26+

27+import Data.List ((\\), delete)

28+import Data.Maybe (mapMaybe)

29+import qualified Data.Traversable as T (traverse)

30+

31+import Control.Applicative

32+import Control.Arrow ((&&&))

33+import Control.Monad (foldM, replicateM, forM)

34+import Control.Monad.Reader (MonadReader, asks)

35+import Control.Monad.Supply.Class

36+

37+import Language.PureScript.CodeGen.JS.AST as AST

38+import Language.PureScript.CodeGen.JS.Common as Common

39+import Language.PureScript.CoreFn

40+import Language.PureScript.Names

41+import Language.PureScript.CodeGen.JS.Optimizer

42+import Language.PureScript.Options

43+import Language.PureScript.Traversals (sndM)

44+import qualified Language.PureScript.Constants as C

45+

46+-- |

47+-- Generate code in the simplified Javascript intermediate representation for all declarations in a

48+-- module.

49+--

50+moduleToJs :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m, MonadSupply m)

51+ => Module Ann -> m [JS]

52+moduleToJs (Module coms name imps exps foreigns decls) = do

53+ additional <- asks optionsAdditional

54+ jsImports <- T.traverse importToJs . delete (ModuleName [ProperName C.prim]) . (\\ [name]) $ imps

55+ let foreigns' = mapMaybe (\(_, js, _) -> js) foreigns

56+ jsDecls <- mapM (bindToJs name) decls

57+ optimized <- T.traverse (T.traverse optimize) jsDecls

58+ let isModuleEmpty = null exps

59+ 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 name) (JSVar ns))

70+ (JSApp (JSFunction Nothing [] (JSBlock (moduleBody ++ [JSReturn exps']))) [])

71+ ]

72+ _ -> []

73+

74+-- |

75+-- Generates Javascript code for a module import.

76+--

77+importToJs :: (Monad m, MonadReader (Options mode) m) => ModuleName -> m JS

78+importToJs mn = do

79+ additional <- asks optionsAdditional

80+ let moduleBody = case additional of

81+ MakeOptions -> JSApp (JSVar "require") [JSStringLiteral (runModuleName mn)]

82+ CompileOptions ns _ _ -> JSAccessor (moduleNameToJs mn) (JSVar ns)

83+ return $ JSVariableIntroduction (moduleNameToJs mn) (Just moduleBody)

84+

85+-- |

86+-- Generate code in the simplified Javascript intermediate representation for a declaration

87+--

88+bindToJs :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m, MonadSupply m)

89+ => ModuleName -> Bind Ann -> m [JS]

90+bindToJs mp (NonRec ident val) = return <$> nonRecToJS mp ident val

91+bindToJs mp (Rec vals) = forM vals (uncurry (nonRecToJS mp))

92+

93+-- |

94+-- Generate code in the simplified Javascript intermediate representation for a single non-recursive

95+-- declaration.

96+--

97+-- The main purpose of this function is to handle code generation for comments.

98+--

99+nonRecToJS :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m, MonadSupply m)

100+ => ModuleName -> Ident -> Expr Ann -> m JS

101+nonRecToJS m i e@(extractAnn -> (_, com, _, _)) | not (null com) = do

102+ withoutComment <- asks optionsNoComments

103+ if withoutComment

104+ then nonRecToJS m i (modifyAnn removeComments e)

105+ else JSComment com <$> nonRecToJS m i (modifyAnn removeComments e)

106+nonRecToJS mp ident val = do

107+ js <- valueToJs mp val

108+ return $ JSVariableIntroduction (identToJs ident) (Just js)

109+

110+

111+-- |

112+-- Generate code in the simplified Javascript intermediate representation for a variable based on a

113+-- PureScript identifier.

114+--

115+var :: Ident -> JS

116+var = JSVar . identToJs

117+

118+-- |

119+-- Generate code in the simplified Javascript intermediate representation for an accessor based on

120+-- a PureScript identifier. If the name is not valid in Javascript (symbol based, reserved name) an

121+-- indexer is returned.

122+--

123+accessor :: Ident -> JS -> JS

124+accessor (Ident prop) = accessorString prop

125+accessor (Op op) = JSIndexer (JSStringLiteral op)

126+

127+accessorString :: String -> JS -> JS

128+accessorString prop | identNeedsEscaping prop = JSIndexer (JSStringLiteral prop)

129+ | otherwise = JSAccessor prop

130+

131+-- |

132+-- Generate code in the simplified Javascript intermediate representation for a value or expression.

133+--

134+valueToJs :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m, MonadSupply m)

135+ => ModuleName -> Expr Ann -> m JS

136+valueToJs m (Literal _ l) =

137+ literalToValueJS m l

138+valueToJs m (Var (_, _, _, Just (IsConstructor _ [])) name) =

139+ return $ JSAccessor "value" $ qualifiedToJS m id name

140+valueToJs m (Var (_, _, _, Just (IsConstructor _ _)) name) =

141+ return $ JSAccessor "create" $ qualifiedToJS m id name

142+valueToJs m (Accessor _ prop val) =

143+ accessorString prop <$> valueToJs m val

144+valueToJs m (ObjectUpdate _ o ps) = do

145+ obj <- valueToJs m o

146+ sts <- mapM (sndM $ valueToJs m) ps

147+ extendObj obj sts

148+valueToJs _ e@(Abs (_, _, _, Just IsTypeClassConstructor) _ _) =

149+ let args = unAbs e

150+ in return $ JSFunction Nothing (map identToJs args) (JSBlock $ map assign args)

151+ where

152+ unAbs :: Expr Ann -> [Ident]

153+ unAbs (Abs _ arg val) = arg : unAbs val

154+ unAbs _ = []

155+ assign :: Ident -> JS

156+ assign name = JSAssignment (accessorString (runIdent name) (JSVar "this"))

157+ (var name)

158+valueToJs m (Abs _ arg val) = do

159+ ret <- valueToJs m val

160+ return $ JSFunction Nothing [identToJs arg] (JSBlock [JSReturn ret])

161+valueToJs m e@App{} = do

162+ let (f, args) = unApp e []

163+ args' <- mapM (valueToJs m) args

164+ case f of

165+ Var (_, _, _, Just IsNewtype) _ -> return (head args')

166+ Var (_, _, _, Just (IsConstructor _ fields)) name | length args == length fields ->

167+ return $ JSUnary JSNew $ JSApp (qualifiedToJS m id name) args'

168+ Var (_, _, _, Just IsTypeClassConstructor) name ->

169+ return $ JSUnary JSNew $ JSApp (qualifiedToJS m id name) args'

170+ _ -> flip (foldl (\fn a -> JSApp fn [a])) args' <$> valueToJs m f

171+ where

172+ unApp :: Expr Ann -> [Expr Ann] -> (Expr Ann, [Expr Ann])

173+ unApp (App _ val arg) args = unApp val (arg : args)

174+ unApp other args = (other, args)

175+valueToJs m (Var _ ident) =

176+ return $ varToJs m ident

177+valueToJs m (Case _ values binders) = do

178+ vals <- mapM (valueToJs m) values

179+ bindersToJs m binders vals

180+valueToJs m (Let _ ds val) = do

181+ decls <- concat <$> mapM (bindToJs m) ds

182+ ret <- valueToJs m val

183+ return $ JSApp (JSFunction Nothing [] (JSBlock (decls ++ [JSReturn ret]))) []

184+valueToJs _ (Constructor (_, _, _, Just IsNewtype) _ (ProperName ctor) _) =

185+ return $ JSVariableIntroduction ctor (Just $

186+ JSObjectLiteral [("create",

187+ JSFunction Nothing ["value"]

188+ (JSBlock [JSReturn $ JSVar "value"]))])

189+valueToJs _ (Constructor _ _ (ProperName ctor) []) =

190+ return $ iife ctor [ JSFunction (Just ctor) [] (JSBlock [])

191+ , JSAssignment (JSAccessor "value" (JSVar ctor))

192+ (JSUnary JSNew $ JSApp (JSVar ctor) []) ]

193+valueToJs _ (Constructor _ _ (ProperName ctor) fields) =

194+ let constructor =

195+ let body = [ JSAssignment (JSAccessor (identToJs f) (JSVar "this")) (var f) | f <- fields ]

196+ in JSFunction (Just ctor) (identToJs `map` fields) (JSBlock body)

197+ createFn =

198+ let body = JSUnary JSNew $ JSApp (JSVar ctor) (var `map` fields)

199+ in foldr (\f inner -> JSFunction Nothing [identToJs f] (JSBlock [JSReturn inner])) body fields

200+ in return $ iife ctor [ constructor

201+ , JSAssignment (JSAccessor "create" (JSVar ctor)) createFn

202+ ]

203+

204+iife :: String -> [JS] -> JS

205+iife v exprs = JSApp (JSFunction Nothing [] (JSBlock $ exprs ++ [JSReturn $ JSVar v])) []

206+

207+literalToValueJS :: (Functor m, Applicative m, Monad m, MonadReader (Options mode) m, MonadSupply m)

208+ => ModuleName -> Literal (Expr Ann) -> m JS

209+literalToValueJS _ (NumericLiteral n) = return $ JSNumericLiteral n

210+literalToValueJS _ (StringLiteral s) = return $ JSStringLiteral s

211+literalToValueJS _ (BooleanLiteral b) = return $ JSBooleanLiteral b

212+literalToValueJS m (ArrayLiteral xs) = JSArrayLiteral <$> mapM (valueToJs m) xs

213+literalToValueJS m (ObjectLiteral ps) = JSObjectLiteral <$> mapM (sndM (valueToJs m)) ps

214+

215+-- |

216+-- Shallow copy an object.

217+--

218+extendObj :: (Applicative m, Monad m, MonadSupply m) => JS -> [(String, JS)] -> m JS

219+extendObj obj sts = do

220+ newObj <- freshName

221+ key <- freshName

222+ let

223+ jsKey = JSVar key

224+ jsNewObj = JSVar newObj

225+ block = JSBlock (objAssign:copy:extend ++ [JSReturn jsNewObj])

226+ objAssign = JSVariableIntroduction newObj (Just $ JSObjectLiteral [])

227+ copy = JSForIn key obj $ JSBlock [JSIfElse cond assign Nothing]

228+ cond = JSApp (JSAccessor "hasOwnProperty" obj) [jsKey]

229+ assign = JSBlock [JSAssignment (JSIndexer jsKey jsNewObj) (JSIndexer jsKey obj)]

230+ stToAssign (s, js) = JSAssignment (JSAccessor s jsNewObj) js

231+ extend = map stToAssign sts

232+ return $ JSApp (JSFunction Nothing [] block) []

233+

234+-- |

235+-- Generate code in the simplified Javascript intermediate representation for a reference to a

236+-- variable.

237+--

238+varToJs :: ModuleName -> Qualified Ident -> JS

239+varToJs _ (Qualified Nothing ident) = var ident

240+varToJs m qual = qualifiedToJS m id qual

241+

242+-- |

243+-- Generate code in the simplified Javascript intermediate representation for a reference to a

244+-- variable that may have a qualified name.

245+--

246+qualifiedToJS :: ModuleName -> (a -> Ident) -> Qualified a -> JS

247+qualifiedToJS _ f (Qualified (Just (ModuleName [ProperName mn])) a) | mn == C.prim = JSVar . runIdent $ f a

248+qualifiedToJS m f (Qualified (Just m') a) | m /= m' = accessor (f a) (JSVar (moduleNameToJs m'))

249+qualifiedToJS _ f (Qualified _ a) = JSVar $ identToJs (f a)

250+

251+-- |

252+-- Generate code in the simplified Javascript intermediate representation for pattern match binders

253+-- and guards.

254+--

255+bindersToJs :: forall m mode. (Functor m, Applicative m, Monad m, MonadReader (Options mode) m, MonadSupply m)

256+ => ModuleName -> [CaseAlternative Ann] -> [JS] -> m JS

257+bindersToJs m binders vals = do

258+ valNames <- replicateM (length vals) freshName

259+ let assignments = zipWith JSVariableIntroduction valNames (map Just vals)

260+ jss <- forM binders $ \(CaseAlternative bs result) -> do

261+ ret <- guardsToJs result

262+ go valNames ret bs

263+ return $ JSApp (JSFunction Nothing [] (JSBlock (assignments ++ concat jss ++ [JSThrow $ JSUnary JSNew $ JSApp (JSVar "Error") [JSStringLiteral "Failed pattern match"]])))

264+ []

265+ where

266+ go :: [String] -> [JS] -> [Binder Ann] -> m [JS]

267+ go _ done [] = return done

268+ go (v:vs) done' (b:bs) = do

269+ done'' <- go vs done' bs

270+ binderToJs m v done'' b

271+ go _ _ _ = error "Invalid arguments to bindersToJs"

272+

273+ guardsToJs :: Either [(Guard Ann, Expr Ann)] (Expr Ann) -> m [JS]

274+ guardsToJs (Left gs) = forM gs $ \(cond, val) -> do

275+ cond' <- valueToJs m cond

276+ done <- valueToJs m val

277+ return $ JSIfElse cond' (JSBlock [JSReturn done]) Nothing

278+ guardsToJs (Right v) = return . JSReturn <$> valueToJs m v

279+

280+-- |

281+-- Generate code in the simplified Javascript intermediate representation for a pattern match

282+-- binder.

283+--

284+binderToJs :: forall m mode. (Functor m, Applicative m, Monad m, MonadReader (Options mode) m, MonadSupply m)

285+ => ModuleName -> String -> [JS] -> Binder Ann -> m [JS]

286+binderToJs _ _ done (NullBinder{}) = return done

287+binderToJs m varName done (LiteralBinder _ l) =

288+ literalToBinderJS m varName done l

289+binderToJs _ varName done (VarBinder _ ident) =

290+ return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : done)

291+binderToJs m varName done (ConstructorBinder (_, _, _, Just IsNewtype) _ _ [b]) =

292+ binderToJs m varName done b

293+binderToJs m varName done (ConstructorBinder (_, _, _, Just (IsConstructor ctorType fields)) _ ctor bs) = do

294+ js <- go (zip fields bs) done

295+ return $ case ctorType of

296+ ProductType -> js

297+ SumType ->

298+ [JSIfElse (JSInstanceOf (JSVar varName) (qualifiedToJS m (Ident . runProperName) ctor))

299+ (JSBlock js)

300+ Nothing]

301+ where

302+ go :: [(Ident, Binder Ann)] -> [JS] -> m [JS]

303+ go [] done' = return done'

304+ go ((field, binder) : remain) done' = do

305+ argVar <- freshName

306+ done'' <- go remain done'

307+ js <- binderToJs m argVar done'' binder

308+ return (JSVariableIntroduction argVar (Just (JSAccessor (identToJs field) (JSVar varName))) : js)

309+binderToJs m varName done binder@(ConstructorBinder _ _ ctor _) | isCons ctor = do

310+ let (headBinders, tailBinder) = uncons [] binder

311+ numberOfHeadBinders = fromIntegral $ length headBinders

312+ js1 <- foldM (\done' (headBinder, index) -> do

313+ headVar <- freshName

314+ jss <- binderToJs m headVar done' headBinder

315+ return (JSVariableIntroduction headVar (Just (JSIndexer (JSNumericLiteral (Left index)) (JSVar varName))) : jss)) done (zip headBinders [0..])

316+ tailVar <- freshName

317+ js2 <- binderToJs m tailVar js1 tailBinder

318+ return [JSIfElse (JSBinary GreaterThanOrEqualTo (JSAccessor "length" (JSVar varName)) (JSNumericLiteral (Left numberOfHeadBinders))) (JSBlock

319+ ( JSVariableIntroduction tailVar (Just (JSApp (JSAccessor "slice" (JSVar varName)) [JSNumericLiteral (Left numberOfHeadBinders)])) :

320+ js2

321+ )) Nothing]

322+ where

323+ uncons :: [Binder Ann] -> Binder Ann -> ([Binder Ann], Binder Ann)

324+ uncons acc (ConstructorBinder _ _ ctor' [h, t]) | isCons ctor' = uncons (h : acc) t

325+ uncons acc tailBinder = (reverse acc, tailBinder)

326+binderToJs _ _ _ b@(ConstructorBinder{}) =

327+ error $ "Invalid ConstructorBinder in binderToJs: " ++ show b

328+binderToJs m varName done (NamedBinder _ ident binder) = do

329+ js <- binderToJs m varName done binder

330+ return (JSVariableIntroduction (identToJs ident) (Just (JSVar varName)) : js)

331+

332+literalToBinderJS :: forall m mode. (Functor m, Applicative m, Monad m, MonadReader (Options mode) m, MonadSupply m)

333+ => ModuleName -> String -> [JS] -> Literal (Binder Ann) -> m [JS]

334+literalToBinderJS _ varName done (NumericLiteral num) =

335+ return [JSIfElse (JSBinary EqualTo (JSVar varName) (JSNumericLiteral num)) (JSBlock done) Nothing]

336+literalToBinderJS _ varName done (StringLiteral str) =

337+ return [JSIfElse (JSBinary EqualTo (JSVar varName) (JSStringLiteral str)) (JSBlock done) Nothing]

338+literalToBinderJS _ varName done (BooleanLiteral True) =

339+ return [JSIfElse (JSVar varName) (JSBlock done) Nothing]

340+literalToBinderJS _ varName done (BooleanLiteral False) =

341+ return [JSIfElse (JSUnary Not (JSVar varName)) (JSBlock done) Nothing]

342+literalToBinderJS m varName done (ObjectLiteral bs) = go done bs

343+ where

344+ go :: [JS] -> [(String, Binder Ann)] -> m [JS]

345+ go done' [] = return done'

346+ go done' ((prop, binder):bs') = do

347+ propVar <- freshName

348+ done'' <- go done' bs'

349+ js <- binderToJs m propVar done'' binder

350+ return (JSVariableIntroduction propVar (Just (accessorString prop (JSVar varName))) : js)

351+literalToBinderJS m varName done (ArrayLiteral bs) = do

352+ js <- go done 0 bs

353+ return [JSIfElse (JSBinary EqualTo (JSAccessor "length" (JSVar varName)) (JSNumericLiteral (Left (fromIntegral $ length bs)))) (JSBlock js) Nothing]

354+ where

355+ go :: [JS] -> Integer -> [Binder Ann] -> m [JS]

356+ go done' _ [] = return done'

357+ go done' index (binder:bs') = do

358+ elVar <- freshName

359+ done'' <- go done' (index + 1) bs'

360+ js <- binderToJs m elVar done'' binder

361+ return (JSVariableIntroduction elVar (Just (JSIndexer (JSNumericLiteral (Left index)) (JSVar varName))) : js)

362+

363+isCons :: Qualified ProperName -> Bool

364+isCons (Qualified (Just mn) ctor) = mn == ModuleName [ProperName C.prim] && ctor == ProperName "Array"

365+isCons name = error $ "Unexpected argument in isCons: " ++ show name

src/Language/PureScript/CodeGen/JS/AST.hsnew file+337

@@ -0,0 +1,337 @@

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.hsnew file+181

@@ -0,0 +1,181 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : Language.PureScript.CodeGen.Common

4+-- Copyright : (c) Phil Freeman 2013

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- |

12+-- Common code generation utility functions

13+--

14+-----------------------------------------------------------------------------

15+

16+module Language.PureScript.CodeGen.JS.Common where

17+

18+import Data.Char

19+import Data.List (intercalate)

20+

21+import Language.PureScript.Names

22+

23+-- |

24+-- Convert an Ident into a valid Javascript identifier:

25+--

26+-- * Alphanumeric characters are kept unmodified.

27+--

28+-- * Reserved javascript identifiers are prefixed with '$$'.

29+--

30+-- * Symbols are prefixed with '$' followed by a symbol name or their ordinal value.

31+--

32+identToJs :: Ident -> String

33+identToJs (Ident name) | nameIsJsReserved name = "$$" ++ name

34+identToJs (Ident name) = concatMap identCharToString name

35+identToJs (Op op) = concatMap identCharToString op

36+

37+-- |

38+-- Test if a string is a valid JS identifier without escaping.

39+--

40+identNeedsEscaping :: String -> Bool

41+identNeedsEscaping s = s /= identToJs (Ident s)

42+

43+-- |

44+-- Attempts to find a human-readable name for a symbol, if none has been specified returns the

45+-- ordinal value.

46+--

47+identCharToString :: Char -> String

48+identCharToString c | isAlphaNum c = [c]

49+identCharToString '_' = "_"

50+identCharToString '.' = "$dot"

51+identCharToString '$' = "$dollar"

52+identCharToString '~' = "$tilde"

53+identCharToString '=' = "$eq"

54+identCharToString '<' = "$less"

55+identCharToString '>' = "$greater"

56+identCharToString '!' = "$bang"

57+identCharToString '#' = "$hash"

58+identCharToString '%' = "$percent"

59+identCharToString '^' = "$up"

60+identCharToString '&' = "$amp"

61+identCharToString '|' = "$bar"

62+identCharToString '*' = "$times"

63+identCharToString '/' = "$div"

64+identCharToString '+' = "$plus"

65+identCharToString '-' = "$minus"

66+identCharToString ':' = "$colon"

67+identCharToString '\\' = "$bslash"

68+identCharToString '?' = "$qmark"

69+identCharToString '@' = "$at"

70+identCharToString '\'' = "$prime"

71+identCharToString c = '$' : show (ord c)

72+

73+-- |

74+-- Checks whether an identifier name is reserved in Javascript.

75+--

76+nameIsJsReserved :: String -> Bool

77+nameIsJsReserved name =

78+ name `elem` [ "abstract"

79+ , "arguments"

80+ , "boolean"

81+ , "break"

82+ , "byte"

83+ , "case"

84+ , "catch"

85+ , "char"

86+ , "class"

87+ , "const"

88+ , "continue"

89+ , "debugger"

90+ , "default"

91+ , "delete"

92+ , "do"

93+ , "double"

94+ , "else"

95+ , "enum"

96+ , "eval"

97+ , "export"

98+ , "extends"

99+ , "final"

100+ , "finally"

101+ , "float"

102+ , "for"

103+ , "function"

104+ , "goto"

105+ , "if"

106+ , "implements"

107+ , "import"

108+ , "in"

109+ , "instanceof"

110+ , "int"

111+ , "interface"

112+ , "let"

113+ , "long"

114+ , "native"

115+ , "new"

116+ , "null"

117+ , "package"

118+ , "private"

119+ , "protected"

120+ , "public"

121+ , "return"

122+ , "short"

123+ , "static"

124+ , "super"

125+ , "switch"

126+ , "synchronized"

127+ , "this"

128+ , "throw"

129+ , "throws"

130+ , "transient"

131+ , "try"

132+ , "typeof"

133+ , "var"

134+ , "void"

135+ , "volatile"

136+ , "while"

137+ , "with"

138+ , "yield" ] || properNameIsJsReserved name

139+

140+moduleNameToJs :: ModuleName -> String

141+moduleNameToJs (ModuleName pns) =

142+ let name = intercalate "_" (runProperName `map` pns)

143+ in if properNameIsJsReserved name then "$$" ++ name else name

144+

145+-- |

146+-- Checks whether a proper name is reserved in Javascript.

147+--

148+properNameIsJsReserved :: String -> Bool

149+properNameIsJsReserved name =

150+ name `elem` [ "Infinity"

151+ , "NaN"

152+ , "Object"

153+ , "Function"

154+ , "Boolean"

155+ , "Error"

156+ , "EvalError"

157+ , "InternalError"

158+ , "RangeError"

159+ , "ReferenceError"

160+ , "SyntaxError"

161+ , "TypeError"

162+ , "URIError"

163+ , "Number"

164+ , "Math"

165+ , "Date"

166+ , "String"

167+ , "RegExp"

168+ , "Array"

169+ , "Int8Array"

170+ , "Uint8Array"

171+ , "Uint8ClampedArray"

172+ , "Int16Array"

173+ , "Uint16Array"

174+ , "Int32Array"

175+ , "Uint32Array"

176+ , "Float32Array"

177+ , "Float64Array"

178+ , "ArrayBuffer"

179+ , "DataView"

180+ , "JSON"

181+ , "Intl" ]

src/Language/PureScript/CodeGen/JS/Optimizer.hsnew file+86

@@ -0,0 +1,86 @@

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.hsnew file+42

@@ -0,0 +1,42 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : Language.PureScript.CodeGen.JS.Optimizer.Blocks

4+-- Copyright : (c) Phil Freeman 2013-14

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- |

12+-- Optimizer steps for simplifying Javascript blocks

13+--

14+-----------------------------------------------------------------------------

15+

16+module Language.PureScript.CodeGen.JS.Optimizer.Blocks

17+ ( collapseNestedBlocks

18+ , collapseNestedIfs

19+ ) where

20+

21+import Language.PureScript.CodeGen.JS.AST

22+

23+-- |

24+-- Collapse blocks which appear nested directly below another block

25+--

26+collapseNestedBlocks :: JS -> JS

27+collapseNestedBlocks = everywhereOnJS collapse

28+ where

29+ collapse :: JS -> JS

30+ collapse (JSBlock sts) = JSBlock (concatMap go sts)

31+ collapse js = js

32+ go :: JS -> [JS]

33+ go (JSBlock sts) = sts

34+ go s = [s]

35+

36+collapseNestedIfs :: JS -> JS

37+collapseNestedIfs = everywhereOnJS collapse

38+ where

39+ collapse :: JS -> JS

40+ collapse (JSIfElse cond1 (JSBlock [JSIfElse cond2 body Nothing]) Nothing) =

41+ JSIfElse (JSBinary And cond1 cond2) body Nothing

42+ collapse js = js

src/Language/PureScript/CodeGen/JS/Optimizer/Common.hsnew file+77

@@ -0,0 +1,77 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : Language.PureScript.CodeGen.JS.Optimizer.Common

4+-- Copyright : (c) Phil Freeman 2013-14

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- |

12+-- Common functions used by the various optimizer phases

13+--

14+-----------------------------------------------------------------------------

15+

16+module Language.PureScript.CodeGen.JS.Optimizer.Common where

17+

18+import Data.Maybe (fromMaybe)

19+

20+import Language.PureScript.CodeGen.JS.AST

21+

22+applyAll :: [a -> a] -> a -> a

23+applyAll = foldl1 (.)

24+

25+replaceIdent :: String -> JS -> JS -> JS

26+replaceIdent var1 js = everywhereOnJS replace

27+ where

28+ replace (JSVar var2) | var1 == var2 = js

29+ replace other = other

30+

31+replaceIdents :: [(String, JS)] -> JS -> JS

32+replaceIdents vars = everywhereOnJS replace

33+ where

34+ replace v@(JSVar var) = fromMaybe v $ lookup var vars

35+ replace other = other

36+

37+isReassigned :: String -> JS -> Bool

38+isReassigned var1 = everythingOnJS (||) check

39+ where

40+ check :: JS -> Bool

41+ check (JSFunction _ args _) | var1 `elem` args = True

42+ check (JSVariableIntroduction arg _) | var1 == arg = True

43+ check (JSAssignment (JSVar arg) _) | var1 == arg = True

44+ check (JSFor arg _ _ _) | var1 == arg = True

45+ check (JSForIn arg _ _) | var1 == arg = True

46+ check _ = False

47+

48+isRebound :: JS -> JS -> Bool

49+isRebound js d = any (\v -> isReassigned v d || isUpdated v d) (everythingOnJS (++) variablesOf js)

50+ where

51+ variablesOf (JSVar var) = [var]

52+ variablesOf _ = []

53+

54+isUsed :: String -> JS -> Bool

55+isUsed var1 = everythingOnJS (||) check

56+ where

57+ check :: JS -> Bool

58+ check (JSVar var2) | var1 == var2 = True

59+ check (JSAssignment target _) | var1 == targetVariable target = True

60+ check _ = False

61+

62+targetVariable :: JS -> String

63+targetVariable (JSVar var) = var

64+targetVariable (JSAccessor _ tgt) = targetVariable tgt

65+targetVariable (JSIndexer _ tgt) = targetVariable tgt

66+targetVariable _ = error "Invalid argument to targetVariable"

67+

68+isUpdated :: String -> JS -> Bool

69+isUpdated var1 = everythingOnJS (||) check

70+ where

71+ check :: JS -> Bool

72+ check (JSAssignment target _) | var1 == targetVariable target = True

73+ check _ = False

74+

75+removeFromBlock :: ([JS] -> [JS]) -> JS -> JS

76+removeFromBlock go (JSBlock sts) = JSBlock (go sts)

77+removeFromBlock _ js = js

src/Language/PureScript/CodeGen/JS/Optimizer/Inliner.hsnew file+201

@@ -0,0 +1,201 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : Language.PureScript.CodeGen.JS.Optimizer.Inliner

4+-- Copyright : (c) Phil Freeman 2013-14

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- |

12+-- This module provides basic inlining capabilities

13+--

14+-----------------------------------------------------------------------------

15+

16+module Language.PureScript.CodeGen.JS.Optimizer.Inliner (

17+ inlineVariables,

18+ inlineValues,

19+ inlineOperator,

20+ inlineCommonOperators,

21+ etaConvert,

22+ unThunk,

23+ evaluateIifes

24+) where

25+

26+import Data.Maybe (fromMaybe)

27+

28+import Language.PureScript.CodeGen.JS.AST

29+import Language.PureScript.CodeGen.JS.Common

30+import Language.PureScript.Names

31+import Language.PureScript.CodeGen.JS.Optimizer.Common

32+import qualified Language.PureScript.Constants as C

33+

34+shouldInline :: JS -> Bool

35+shouldInline (JSVar _) = True

36+shouldInline (JSNumericLiteral _) = True

37+shouldInline (JSStringLiteral _) = True

38+shouldInline (JSBooleanLiteral _) = True

39+shouldInline (JSAccessor _ val) = shouldInline val

40+shouldInline (JSIndexer index val) = shouldInline index && shouldInline val

41+shouldInline _ = False

42+

43+etaConvert :: JS -> JS

44+etaConvert = everywhereOnJS convert

45+ where

46+ convert :: JS -> JS

47+ convert (JSBlock [JSReturn (JSApp (JSFunction Nothing idents block@(JSBlock body)) args)])

48+ | all shouldInline args &&

49+ not (any (`isRebound` block) (map JSVar idents)) &&

50+ not (any (`isRebound` block) args)

51+ = JSBlock (map (replaceIdents (zip idents args)) body)

52+ convert (JSFunction Nothing [] (JSBlock [JSReturn (JSApp fn [])])) = fn

53+ convert js = js

54+

55+unThunk :: JS -> JS

56+unThunk = everywhereOnJS convert

57+ where

58+ convert :: JS -> JS

59+ convert (JSBlock []) = JSBlock []

60+ convert (JSBlock jss) =

61+ case last jss of

62+ JSReturn (JSApp (JSFunction Nothing [] (JSBlock body)) []) -> JSBlock $ init jss ++ body

63+ _ -> JSBlock jss

64+ convert js = js

65+

66+evaluateIifes :: JS -> JS

67+evaluateIifes = everywhereOnJS convert

68+ where

69+ convert :: JS -> JS

70+ convert (JSApp (JSFunction Nothing [] (JSBlock [JSReturn ret])) []) = ret

71+ convert js = js

72+

73+inlineVariables :: JS -> JS

74+inlineVariables = everywhereOnJS $ removeFromBlock go

75+ where

76+ go :: [JS] -> [JS]

77+ go [] = []

78+ go (JSVariableIntroduction var (Just js) : sts)

79+ | shouldInline js && not (any (isReassigned var) sts) && not (any (isRebound js) sts) && not (any (isUpdated var) sts) =

80+ go (map (replaceIdent var js) sts)

81+ go (s:sts) = s : go sts

82+

83+inlineValues :: JS -> JS

84+inlineValues = everywhereOnJS convert

85+ where

86+ convert :: JS -> JS

87+ convert (JSApp fn [dict]) | isPreludeDict C.semiringNumber dict && isPreludeFn C.zero fn = JSNumericLiteral (Left 0)

88+ convert (JSApp fn [dict]) | isPreludeDict C.semiringNumber dict && isPreludeFn C.one fn = JSNumericLiteral (Left 1)

89+ convert (JSApp (JSApp fn [x]) [y]) | isPreludeFn (C.%) fn = JSBinary Modulus x y

90+ convert other = other

91+

92+inlineOperator :: (String, String) -> (JS -> JS -> JS) -> JS -> JS

93+inlineOperator (m, op) f = everywhereOnJS convert

94+ where

95+ convert :: JS -> JS

96+ convert (JSApp (JSApp op' [x]) [y]) | isOp op' = f x y

97+ convert other = other

98+ isOp (JSAccessor longForm (JSVar m')) = m == m' && longForm == identToJs (Op op)

99+ isOp (JSIndexer (JSStringLiteral op') (JSVar m')) = m == m' && op == op'

100+ isOp _ = False

101+

102+inlineCommonOperators :: JS -> JS

103+inlineCommonOperators = applyAll $

104+ [ binary C.semiringNumber (C.+) Add

105+ , binary C.semiringNumber (C.*) Multiply

106+ , binary C.ringNumber (C.-) Subtract

107+ , unary C.ringNumber C.negate Negate

108+ , binary C.moduloSemiringNumber (C./) Divide

109+

110+ , binary C.ordNumber (C.<) LessThan

111+ , binary C.ordNumber (C.>) GreaterThan

112+ , binary C.ordNumber (C.<=) LessThanOrEqualTo

113+ , binary C.ordNumber (C.>=) GreaterThanOrEqualTo

114+

115+ , binary C.eqNumber (C.==) EqualTo

116+ , binary C.eqNumber (C./=) NotEqualTo

117+ , binary C.eqString (C.==) EqualTo

118+ , binary C.eqString (C./=) NotEqualTo

119+ , binary C.eqBoolean (C.==) EqualTo

120+ , binary C.eqBoolean (C./=) NotEqualTo

121+

122+ , binary C.semigroupString (C.<>) Add

123+ , binary C.semigroupString (C.++) Add

124+

125+ , binaryFunction C.bitsNumber C.shl ShiftLeft

126+ , binaryFunction C.bitsNumber C.shr ShiftRight

127+ , binaryFunction C.bitsNumber C.zshr ZeroFillShiftRight

128+ , binary C.bitsNumber (C..&.) BitwiseAnd

129+ , binary C.bitsNumber (C..|.) BitwiseOr

130+ , binary C.bitsNumber (C..^.) BitwiseXor

131+ , unary C.bitsNumber C.complement BitwiseNot

132+

133+ , binary C.boolLikeBoolean (C.&&) And

134+ , binary C.boolLikeBoolean (C.||) Or

135+ , unary C.boolLikeBoolean C.not Not

136+ ] ++

137+ [ fn | i <- [0..10], fn <- [ mkFn i, runFn i ] ]

138+ where

139+ binary :: String -> String -> BinaryOperator -> JS -> JS

140+ binary dictName opString op = everywhereOnJS convert

141+ where

142+ convert :: JS -> JS

143+ convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isPreludeDict dictName dict && isPreludeFn opString fn = JSBinary op x y

144+ convert other = other

145+ binaryFunction :: String -> String -> BinaryOperator -> JS -> JS

146+ binaryFunction dictName fnName op = everywhereOnJS convert

147+ where

148+ convert :: JS -> JS

149+ convert (JSApp (JSApp (JSApp fn [dict]) [x]) [y]) | isPreludeFn fnName fn && isPreludeDict dictName dict = JSBinary op x y

150+ convert other = other

151+ unary :: String -> String -> UnaryOperator -> JS -> JS

152+ unary dictName fnName op = everywhereOnJS convert

153+ where

154+ convert :: JS -> JS

155+ convert (JSApp (JSApp fn [dict]) [x]) | isPreludeFn fnName fn && isPreludeDict dictName dict = JSUnary op x

156+ convert other = other

157+ mkFn :: Int -> JS -> JS

158+ mkFn 0 = everywhereOnJS convert

159+ where

160+ convert :: JS -> JS

161+ convert (JSApp mkFnN [JSFunction Nothing [_] (JSBlock js)]) | isNFn C.mkFn 0 mkFnN =

162+ JSFunction Nothing [] (JSBlock js)

163+ convert other = other

164+ mkFn n = everywhereOnJS convert

165+ where

166+ convert :: JS -> JS

167+ convert orig@(JSApp mkFnN [fn]) | isNFn C.mkFn n mkFnN =

168+ case collectArgs n [] fn of

169+ Just (args, js) -> JSFunction Nothing args (JSBlock js)

170+ Nothing -> orig

171+ convert other = other

172+ collectArgs :: Int -> [String] -> JS -> Maybe ([String], [JS])

173+ collectArgs 1 acc (JSFunction Nothing [oneArg] (JSBlock js)) | length acc == n - 1 = Just (reverse (oneArg : acc), js)

174+ collectArgs m acc (JSFunction Nothing [oneArg] (JSBlock [JSReturn ret])) = collectArgs (m - 1) (oneArg : acc) ret

175+ collectArgs _ _ _ = Nothing

176+

177+ isNFn :: String -> Int -> JS -> Bool

178+ isNFn prefix n (JSVar name) = name == (prefix ++ show n)

179+ isNFn prefix n (JSAccessor name (JSVar dataFunction)) | dataFunction == C.dataFunction = name == (prefix ++ show n)

180+ isNFn _ _ _ = False

181+

182+ runFn :: Int -> JS -> JS

183+ runFn n = everywhereOnJS convert

184+ where

185+ convert :: JS -> JS

186+ convert js = fromMaybe js $ go n [] js

187+

188+ go :: Int -> [JS] -> JS -> Maybe JS

189+ go 0 acc (JSApp runFnN [fn]) | isNFn C.runFn n runFnN && length acc == n = Just (JSApp fn acc)

190+ go m acc (JSApp lhs [arg]) = go (m - 1) (arg : acc) lhs

191+ go _ _ _ = Nothing

192+

193+isPreludeDict :: String -> JS -> Bool

194+isPreludeDict dictName (JSAccessor prop (JSVar prelude)) = prelude == C.prelude && prop == dictName

195+isPreludeDict _ _ = False

196+

197+isPreludeFn :: String -> JS -> Bool

198+isPreludeFn fnName (JSAccessor fnName' (JSVar prelude)) = prelude == C.prelude && fnName' == fnName

199+isPreludeFn fnName (JSIndexer (JSStringLiteral fnName') (JSVar prelude)) = prelude == C.prelude && fnName' == fnName

200+isPreludeFn fnName (JSAccessor longForm (JSAccessor prelude (JSVar _))) = prelude == C.prelude && longForm == identToJs (Op fnName)

201+isPreludeFn _ _ = False

src/Language/PureScript/CodeGen/JS/Optimizer/MagicDo.hsnew file+165

@@ -0,0 +1,165 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : Language.PureScript.CodeGen.JS.Optimizer.MagicDo

4+-- Copyright : (c) Phil Freeman 2013-14

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- |

12+-- This module implements the "Magic Do" optimization, which inlines calls to return

13+-- and bind for the Eff monad, as well as some of its actions.

14+--

15+-----------------------------------------------------------------------------

16+

17+module Language.PureScript.CodeGen.JS.Optimizer.MagicDo (

18+ magicDo

19+) where

20+

21+import Data.List (nub)

22+import Data.Maybe (fromJust, isJust)

23+

24+import Language.PureScript.CodeGen.JS.AST

25+import Language.PureScript.CodeGen.JS.Common

26+import Language.PureScript.Names

27+import Language.PureScript.Options

28+import qualified Language.PureScript.Constants as C

29+

30+magicDo :: Options mode -> JS -> JS

31+magicDo opts | optionsNoMagicDo opts = id

32+ | otherwise = inlineST . magicDo'

33+

34+-- |

35+-- Inline type class dictionaries for >>= and return for the Eff monad

36+--

37+-- E.g.

38+--

39+-- Prelude[">>="](dict)(m1)(function(x) {

40+-- return ...;

41+-- })

42+--

43+-- becomes

44+--

45+-- function __do {

46+-- var x = m1();

47+-- ...

48+-- }

49+--

50+magicDo' :: JS -> JS

51+magicDo' = everywhereOnJS undo . everywhereOnJSTopDown convert

52+ where

53+ -- The name of the function block which is added to denote a do block

54+ fnName = "__do"

55+ -- Desugar monomorphic calls to >>= and return for the Eff monad

56+ convert :: JS -> JS

57+ -- Desugar return

58+ convert (JSApp (JSApp ret [val]) []) | isReturn ret = val

59+ -- Desugar pure

60+ convert (JSApp (JSApp pure' [val]) []) | isPure pure' = val

61+ -- Desugar >>

62+ convert (JSApp (JSApp bind [m]) [JSFunction Nothing [] (JSBlock js)]) | isBind bind =

63+ JSFunction (Just fnName) [] $ JSBlock (JSApp m [] : map applyReturns js )

64+ -- Desugar >>=

65+ convert (JSApp (JSApp bind [m]) [JSFunction Nothing [arg] (JSBlock js)]) | isBind bind =

66+ JSFunction (Just fnName) [] $ JSBlock (JSVariableIntroduction arg (Just (JSApp m [])) : map applyReturns js)

67+ -- Desugar untilE

68+ convert (JSApp (JSApp f [arg]) []) | isEffFunc C.untilE f =

69+ JSApp (JSFunction Nothing [] (JSBlock [ JSWhile (JSUnary Not (JSApp arg [])) (JSBlock []), JSReturn $ JSObjectLiteral []])) []

70+ -- Desugar whileE

71+ convert (JSApp (JSApp (JSApp f [arg1]) [arg2]) []) | isEffFunc C.whileE f =

72+ JSApp (JSFunction Nothing [] (JSBlock [ JSWhile (JSApp arg1 []) (JSBlock [ JSApp arg2 [] ]), JSReturn $ JSObjectLiteral []])) []

73+ convert other = other

74+ -- Check if an expression represents a monomorphic call to >>= for the Eff monad

75+ isBind (JSApp bindPoly [effDict]) | isBindPoly bindPoly && isEffDict C.bindEffDictionary effDict = True

76+ isBind _ = False

77+ -- Check if an expression represents a monomorphic call to return for the Eff monad

78+ isReturn (JSApp retPoly [effDict]) | isRetPoly retPoly && isEffDict C.monadEffDictionary effDict = True

79+ isReturn _ = False

80+ -- Check if an expression represents a monomorphic call to pure for the Eff applicative

81+ isPure (JSApp purePoly [effDict]) | isPurePoly purePoly && isEffDict C.applicativeEffDictionary effDict = True

82+ isPure _ = False

83+ -- Check if an expression represents the polymorphic >>= function

84+ isBindPoly (JSAccessor prop (JSVar prelude)) = prelude == C.prelude && prop == 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.hsnew file+103

@@ -0,0 +1,103 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : Language.PureScript.CodeGen.JS.Optimizer.TCO

4+-- Copyright : (c) Phil Freeman 2013-14

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- |

12+-- This module implements tail call elimination.

13+--

14+-----------------------------------------------------------------------------

15+

16+module Language.PureScript.CodeGen.JS.Optimizer.TCO (tco) where

17+

18+import Language.PureScript.Options

19+import Language.PureScript.CodeGen.JS.AST

20+

21+-- |

22+-- Eliminate tail calls

23+--

24+tco :: Options mode -> JS -> JS

25+tco opts | optionsNoTco opts = id

26+ | otherwise = tco'

27+

28+tco' :: JS -> JS

29+tco' = everywhereOnJS convert

30+ where

31+ tcoLabel :: String

32+ tcoLabel = "tco"

33+ tcoVar :: String -> String

34+ tcoVar arg = "__tco_" ++ arg

35+ copyVar :: String -> String

36+ copyVar arg = "__copy_" ++ arg

37+ convert :: JS -> JS

38+ convert js@(JSVariableIntroduction name (Just fn@JSFunction {})) =

39+ let

40+ (argss, body', replace) = collectAllFunctionArgs [] id fn

41+ in case () of

42+ _ | isTailCall name body' ->

43+ let

44+ allArgs = concat $ reverse argss

45+ in

46+ JSVariableIntroduction name (Just (replace (toLoop name allArgs body')))

47+ | otherwise -> js

48+ convert js = js

49+ collectAllFunctionArgs :: [[String]] -> (JS -> JS) -> JS -> ([[String]], JS, JS -> JS)

50+ collectAllFunctionArgs allArgs f (JSFunction ident args (JSBlock (body@(JSReturn _):_))) =

51+ collectAllFunctionArgs (args : allArgs) (\b -> f (JSFunction ident (map copyVar args) (JSBlock [b]))) body

52+ collectAllFunctionArgs allArgs f (JSFunction ident args body@(JSBlock _)) =

53+ (args : allArgs, body, f . JSFunction ident (map copyVar args))

54+ collectAllFunctionArgs allArgs f (JSReturn (JSFunction ident args (JSBlock [body]))) =

55+ collectAllFunctionArgs (args : allArgs) (\b -> f (JSReturn (JSFunction ident (map copyVar args) (JSBlock [b])))) body

56+ collectAllFunctionArgs allArgs f (JSReturn (JSFunction ident args body@(JSBlock _))) =

57+ (args : allArgs, body, f . JSReturn . JSFunction ident (map copyVar args))

58+ collectAllFunctionArgs allArgs f body = (allArgs, body, f)

59+ isTailCall :: String -> JS -> Bool

60+ isTailCall ident js =

61+ let

62+ numSelfCalls = everythingOnJS (+) countSelfCalls js

63+ numSelfCallsInTailPosition = everythingOnJS (+) countSelfCallsInTailPosition js

64+ numSelfCallsUnderFunctions = everythingOnJS (+) countSelfCallsUnderFunctions js

65+ in

66+ numSelfCalls > 0

67+ && numSelfCalls == numSelfCallsInTailPosition

68+ && numSelfCallsUnderFunctions == 0

69+ where

70+ countSelfCalls :: JS -> Int

71+ countSelfCalls (JSApp (JSVar ident') _) | ident == ident' = 1

72+ countSelfCalls _ = 0

73+ countSelfCallsInTailPosition :: JS -> Int

74+ countSelfCallsInTailPosition (JSReturn ret) | isSelfCall ident ret = 1

75+ countSelfCallsInTailPosition _ = 0

76+ countSelfCallsUnderFunctions (JSFunction _ _ js') = everythingOnJS (+) countSelfCalls js'

77+ countSelfCallsUnderFunctions _ = 0

78+ toLoop :: String -> [String] -> JS -> JS

79+ toLoop ident allArgs js = JSBlock $

80+ map (\arg -> JSVariableIntroduction arg (Just (JSVar (copyVar arg)))) allArgs ++

81+ [ JSLabel tcoLabel $ JSWhile (JSBooleanLiteral True) (JSBlock [ everywhereOnJS loopify js ]) ]

82+ where

83+ loopify :: JS -> JS

84+ loopify (JSReturn ret) | isSelfCall ident ret =

85+ let

86+ allArgumentValues = concat $ collectSelfCallArgs [] ret

87+ in

88+ JSBlock $ zipWith (\val arg ->

89+ JSVariableIntroduction (tcoVar arg) (Just val)) allArgumentValues allArgs

90+ ++ map (\arg ->

91+ JSAssignment (JSVar arg) (JSVar (tcoVar arg))) allArgs

92+ ++ [ JSContinue tcoLabel ]

93+ loopify other = other

94+ collectSelfCallArgs :: [[JS]] -> JS -> [[JS]]

95+ collectSelfCallArgs allArgumentValues (JSApp fn args') = collectSelfCallArgs (args' : allArgumentValues) fn

96+ collectSelfCallArgs allArgumentValues _ = allArgumentValues

97+ isSelfCall :: String -> JS -> Bool

98+ isSelfCall ident (JSApp (JSVar ident') args) | ident == ident' && not (any isFunction args) = True

99+ isSelfCall ident (JSApp fn args) | not (any isFunction args) = isSelfCall ident fn

100+ isSelfCall _ _ = False

101+ isFunction :: JS -> Bool

102+ isFunction (JSFunction _ _ _) = True

103+ isFunction _ = False

src/Language/PureScript/CodeGen/JS/Optimizer/Unused.hsnew file+46

@@ -0,0 +1,46 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : Language.PureScript.CodeGen.JS.Optimizer.Unused

4+-- Copyright : (c) Phil Freeman 2013-14

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- |

12+-- Removes unused variables

13+--

14+-----------------------------------------------------------------------------

15+

16+module Language.PureScript.CodeGen.JS.Optimizer.Unused

17+ ( removeCodeAfterReturnStatements

18+ , removeUnusedArg

19+ , removeUndefinedApp

20+ ) where

21+

22+import Language.PureScript.CodeGen.JS.AST

23+import Language.PureScript.CodeGen.JS.Optimizer.Common

24+

25+import qualified Language.PureScript.Constants as C

26+

27+removeCodeAfterReturnStatements :: JS -> JS

28+removeCodeAfterReturnStatements = everywhereOnJS (removeFromBlock go)

29+ where

30+ go :: [JS] -> [JS]

31+ go jss | not (any isJSReturn jss) = jss

32+ | otherwise = let (body, ret : _) = span (not . isJSReturn) jss in body ++ [ret]

33+ isJSReturn (JSReturn _) = True

34+ isJSReturn _ = False

35+

36+removeUnusedArg :: JS -> JS

37+removeUnusedArg = everywhereOnJS convert

38+ where

39+ convert (JSFunction name [arg] body) | arg == C.__unused = JSFunction name [] body

40+ convert js = js

41+

42+removeUndefinedApp :: JS -> JS

43+removeUndefinedApp = everywhereOnJS convert

44+ where

45+ convert (JSApp fn [JSVar arg]) | arg == C.undefined = JSApp fn []

46+ convert js = js

src/Language/PureScript/Comments.hsnew file+25

@@ -0,0 +1,25 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : Language.PureScript.Parser.Comments

4+-- Copyright : (c) Phil Freeman 2015

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- |

12+-- Defines the types of source code comments

13+--

14+-----------------------------------------------------------------------------

15+

16+{-# LANGUAGE DeriveDataTypeable #-}

17+

18+module Language.PureScript.Comments where

19+

20+import qualified Data.Data as D

21+

22+data Comment

23+ = LineComment String

24+ | BlockComment String

25+ deriving (Show, Eq, Ord, D.Data, D.Typeable)

src/Language/PureScript/Constants.hsnew file+239

@@ -0,0 +1,239 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : Language.PureScript.Constants

4+-- Copyright : (c) Phil Freeman 2013

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- |

12+-- Various constants which refer to things in the Prelude

13+--

14+-----------------------------------------------------------------------------

15+

16+module Language.PureScript.Constants where

17+

18+-- Prelude Operators

19+

20+($) :: String

21+($) = "$"

22+

23+(#) :: String

24+(#) = "#"

25+

26+(<>) :: String

27+(<>) = "<>"

28+

29+(++) :: String

30+(++) = "++"

31+

32+(>>=) :: String

33+(>>=) = ">>="

34+

35+(+) :: String

36+(+) = "+"

37+

38+(-) :: String

39+(-) = "-"

40+

41+(*) :: String

42+(*) = "*"

43+

44+(/) :: String

45+(/) = "/"

46+

47+(%) :: String

48+(%) = "%"

49+

50+(<) :: String

51+(<) = "<"

52+

53+(>) :: String

54+(>) = ">"

55+

56+(<=) :: String

57+(<=) = "<="

58+

59+(>=) :: String

60+(>=) = ">="

61+

62+(==) :: String

63+(==) = "=="

64+

65+(/=) :: String

66+(/=) = "/="

67+

68+(.&.) :: String

69+(.&.) = ".&."

70+

71+(.|.) :: String

72+(.|.) = ".|."

73+

74+(.^.) :: String

75+(.^.) = ".^."

76+

77+(&&) :: String

78+(&&) = "&&"

79+

80+(||) :: String

81+(||) = "||"

82+

83+unsafeIndex :: String

84+unsafeIndex = "unsafeIndex"

85+

86+-- Prelude Operator Functions

87+

88+negate :: String

89+negate = "negate"

90+

91+shl :: String

92+shl = "shl"

93+

94+shr :: String

95+shr = "shr"

96+

97+zshr :: String

98+zshr = "zshr"

99+

100+complement :: String

101+complement = "complement"

102+

103+not :: String

104+not = "not"

105+

106+-- Prelude Values

107+

108+zero :: String

109+zero = "zero"

110+

111+one :: String

112+one = "one"

113+

114+return :: String

115+return = "return"

116+

117+pure' :: String

118+pure' = "pure"

119+

120+returnEscaped :: String

121+returnEscaped = "$return"

122+

123+untilE :: String

124+untilE = "untilE"

125+

126+whileE :: String

127+whileE = "whileE"

128+

129+runST :: String

130+runST = "runST"

131+

132+stRefValue :: String

133+stRefValue = "value"

134+

135+newSTRef :: String

136+newSTRef = "newSTRef"

137+

138+readSTRef :: String

139+readSTRef = "readSTRef"

140+

141+writeSTRef :: String

142+writeSTRef = "writeSTRef"

143+

144+modifySTRef :: String

145+modifySTRef = "modifySTRef"

146+

147+mkFn :: String

148+mkFn = "mkFn"

149+

150+runFn :: String

151+runFn = "runFn"

152+

153+unit :: String

154+unit = "unit"

155+

156+-- Prim values

157+

158+undefined :: String

159+undefined = "undefined"

160+

161+-- Type Class Dictionary Names

162+

163+monadEffDictionary :: String

164+monadEffDictionary = "monadEff"

165+

166+applicativeEffDictionary :: String

167+applicativeEffDictionary = "applicativeEff"

168+

169+bindEffDictionary :: String

170+bindEffDictionary = "bindEff"

171+

172+semiringNumber :: String

173+semiringNumber = "semiringNumber"

174+

175+ringNumber :: String

176+ringNumber = "ringNumber"

177+

178+moduloSemiringNumber :: String

179+moduloSemiringNumber = "moduloSemiringNumber"

180+

181+numNumber :: String

182+numNumber = "numNumber"

183+

184+ordNumber :: String

185+ordNumber = "ordNumber"

186+

187+eqNumber :: String

188+eqNumber = "eqNumber"

189+

190+eqString :: String

191+eqString = "eqString"

192+

193+eqBoolean :: String

194+eqBoolean = "eqBoolean"

195+

196+bitsNumber :: String

197+bitsNumber = "bitsNumber"

198+

199+boolLikeBoolean :: String

200+boolLikeBoolean = "boolLikeBoolean"

201+

202+semigroupString :: String

203+semigroupString = "semigroupString"

204+

205+semigroupoidArr :: String

206+semigroupoidArr = "semigroupoidArr"

207+

208+-- Main module

209+

210+main :: String

211+main = "main"

212+

213+-- Code Generation

214+

215+__superclass_ :: String

216+__superclass_ = "__superclass_"

217+

218+__unused :: String

219+__unused = "__unused"

220+

221+-- Modules

222+

223+prim :: String

224+prim = "Prim"

225+

226+prelude :: String

227+prelude = "Prelude"

228+

229+preludeUnsafe :: String

230+preludeUnsafe = "Prelude_Unsafe"

231+

232+eff :: String

233+eff = "Control_Monad_Eff"

234+

235+st :: String

236+st = "Control_Monad_ST"

237+

238+dataFunction :: String

239+dataFunction = "Data_Function"

src/Language/PureScript/CoreFn.hsnew file+26

@@ -0,0 +1,26 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : Language.PureScript.CoreFn

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- | The core functional representation

12+--

13+-----------------------------------------------------------------------------

14+

15+module Language.PureScript.CoreFn (

16+ module C

17+) where

18+

19+import Language.PureScript.CoreFn.Ann as C

20+import Language.PureScript.CoreFn.Binders as C

21+import Language.PureScript.CoreFn.Desugar as C

22+import Language.PureScript.CoreFn.Expr as C

23+import Language.PureScript.CoreFn.Literals as C

24+import Language.PureScript.CoreFn.Meta as C

25+import Language.PureScript.CoreFn.Module as C

26+import Language.PureScript.CoreFn.Traversals as C

src/Language/PureScript/CoreFn/Ann.hsnew file+37

@@ -0,0 +1,37 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : Language.PureScript.CoreFn.Ann

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- | Type alias for basic annotations

12+--

13+-----------------------------------------------------------------------------

14+

15+module Language.PureScript.CoreFn.Ann where

16+

17+import Language.PureScript.AST.SourcePos

18+import Language.PureScript.CoreFn.Meta

19+import Language.PureScript.Types

20+import Language.PureScript.Comments

21+

22+-- |

23+-- Type alias for basic annotations

24+--

25+type Ann = (Maybe SourceSpan, [Comment], Maybe Type, Maybe Meta)

26+

27+-- |

28+-- Initial annotation with no metadata

29+--

30+nullAnn :: Ann

31+nullAnn = (Nothing, [], Nothing, Nothing)

32+

33+-- |

34+-- Remove the comments from an annotation

35+--

36+removeComments :: Ann -> Ann

37+removeComments (ss, _, ty, meta) = (ss, [], ty, meta)

src/Language/PureScript/CoreFn/Binders.hsnew file+48

@@ -0,0 +1,48 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : Language.PureScript.CoreFn.Binders

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- | The core functional representation for binders

12+--

13+-----------------------------------------------------------------------------

14+

15+{-# LANGUAGE DeriveDataTypeable #-}

16+{-# LANGUAGE DeriveFunctor #-}

17+

18+module Language.PureScript.CoreFn.Binders where

19+

20+import qualified Data.Data as D

21+

22+import Language.PureScript.CoreFn.Literals

23+import Language.PureScript.Names

24+

25+-- |

26+-- Data type for binders

27+--

28+data Binder a

29+ -- |

30+ -- Wildcard binder

31+ --

32+ = NullBinder a

33+ -- |

34+ -- A binder which matches a literal value

35+ --

36+ | LiteralBinder a (Literal (Binder a))

37+ -- |

38+ -- A binder which binds an identifier

39+ --

40+ | VarBinder a Ident

41+ -- |

42+ -- A binder which matches a data constructor (type name, constructor name, binders)

43+ --

44+ | ConstructorBinder a (Qualified ProperName) (Qualified ProperName) [Binder a]

45+ -- |

46+ -- A binder which binds its input to an identifier

47+ --

48+ | NamedBinder a Ident (Binder a) deriving (Show, D.Data, D.Typeable, Functor)

src/Language/PureScript/CoreFn/Desugar.hsnew file+249

@@ -0,0 +1,249 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : Language.PureScript.CoreFn.Desugar

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- | The AST -> CoreFn desugaring step

12+--

13+-----------------------------------------------------------------------------

14+

15+module Language.PureScript.CoreFn.Desugar (moduleToCoreFn) where

16+

17+import Data.Function (on)

18+import Data.List (sort, sortBy, nub)

19+import Data.Maybe (mapMaybe)

20+import qualified Data.Map as M

21+

22+import Control.Arrow (second, (***))

23+

24+import Language.PureScript.AST.SourcePos

25+import Language.PureScript.AST.Traversals

26+import Language.PureScript.CoreFn.Ann

27+import Language.PureScript.CoreFn.Binders

28+import Language.PureScript.CoreFn.Expr

29+import Language.PureScript.CoreFn.Literals

30+import Language.PureScript.CoreFn.Meta

31+import Language.PureScript.CoreFn.Module

32+import Language.PureScript.Environment

33+import Language.PureScript.Names

34+import Language.PureScript.Sugar.TypeClasses (typeClassMemberName, superClassDictionaryNames)

35+import Language.PureScript.Types

36+import Language.PureScript.Comments

37+import qualified Language.PureScript.AST as A

38+

39+-- |

40+-- Desugars a module from AST to CoreFn representation.

41+--

42+moduleToCoreFn :: Environment -> A.Module -> Module Ann

43+moduleToCoreFn _ (A.Module _ _ _ Nothing) =

44+ error "Module exports were not elaborated before moduleToCoreFn"

45+moduleToCoreFn env (A.Module coms mn decls (Just exps)) =

46+ let imports = nub $ mapMaybe importToCoreFn decls ++ findQualModules decls

47+ exps' = nub $ concatMap exportToCoreFn exps

48+ externs = nub $ mapMaybe externToCoreFn decls

49+ decls' = concatMap (declToCoreFn Nothing []) decls

50+ in Module coms mn imports exps' externs decls'

51+

52+ where

53+

54+ -- |

55+ -- Desugars member declarations from AST to CoreFn representation.

56+ --

57+ declToCoreFn :: Maybe SourceSpan -> [Comment] -> A.Declaration -> [Bind Ann]

58+ declToCoreFn ss com (A.DataDeclaration Newtype _ _ [(ctor, _)]) =

59+ [NonRec (properToIdent ctor) $

60+ Abs (ss, com, Nothing, Just IsNewtype) (Ident "x") (Var nullAnn $ Qualified Nothing (Ident "x"))]

61+ declToCoreFn _ _ d@(A.DataDeclaration Newtype _ _ _) =

62+ error $ "Found newtype with multiple constructors: " ++ show d

63+ declToCoreFn ss com (A.DataDeclaration Data tyName _ ctors) =

64+ flip map ctors $ \(ctor, _) ->

65+ let (_, _, _, fields) = lookupConstructor env (Qualified (Just mn) ctor)

66+ in NonRec (properToIdent ctor) $ Constructor (ss, com, Nothing, Nothing) tyName ctor fields

67+ declToCoreFn ss _ (A.DataBindingGroupDeclaration ds) = concatMap (declToCoreFn ss []) ds

68+ declToCoreFn ss com (A.ValueDeclaration name _ _ (Right e)) =

69+ [NonRec name (exprToCoreFn ss com Nothing e)]

70+ declToCoreFn ss _ (A.BindingGroupDeclaration ds) =

71+ [Rec $ map (\(name, _, e) -> (name, exprToCoreFn ss [] Nothing e)) ds]

72+ declToCoreFn ss com (A.TypeClassDeclaration name _ supers members) =

73+ [NonRec (properToIdent name) $ mkTypeClassConstructor ss com supers members]

74+ declToCoreFn _ com (A.PositionedDeclaration ss com1 d) =

75+ declToCoreFn (Just ss) (com ++ com1) d

76+ declToCoreFn _ _ _ = []

77+

78+ -- |

79+ -- Desugars expressions from AST to CoreFn representation.

80+ --

81+ exprToCoreFn :: Maybe SourceSpan -> [Comment] -> Maybe Type -> A.Expr -> Expr Ann

82+ exprToCoreFn ss com ty (A.NumericLiteral v) =

83+ Literal (ss, com, ty, Nothing) (NumericLiteral v)

84+ exprToCoreFn ss com ty (A.StringLiteral v) =

85+ Literal (ss, com, ty, Nothing) (StringLiteral v)

86+ exprToCoreFn ss com ty (A.BooleanLiteral v) =

87+ Literal (ss, com, ty, Nothing) (BooleanLiteral v)

88+ exprToCoreFn ss com ty (A.ArrayLiteral vs) =

89+ Literal (ss, com, ty, Nothing) (ArrayLiteral $ map (exprToCoreFn ss [] Nothing) vs)

90+ exprToCoreFn ss com ty (A.ObjectLiteral vs) =

91+ Literal (ss, com, ty, Nothing) (ObjectLiteral $ map (second (exprToCoreFn ss [] Nothing)) vs)

92+ exprToCoreFn ss com ty (A.Accessor name v) =

93+ Accessor (ss, com, ty, Nothing) name (exprToCoreFn ss [] Nothing v)

94+ exprToCoreFn ss com ty (A.ObjectUpdate obj vs) =

95+ ObjectUpdate (ss, com, ty, Nothing) (exprToCoreFn ss [] Nothing obj) $ map (second (exprToCoreFn ss [] Nothing)) vs

96+ exprToCoreFn ss com ty (A.Abs (Left name) v) =

97+ Abs (ss, com, ty, Nothing) name (exprToCoreFn ss [] Nothing v)

98+ exprToCoreFn _ _ _ (A.Abs _ _) =

99+ error "Abs with Binder argument was not desugared before exprToCoreFn mn"

100+ exprToCoreFn ss com ty (A.App v1 v2) =

101+ App (ss, com, ty, Nothing) (exprToCoreFn ss [] Nothing v1) (exprToCoreFn ss [] Nothing v2)

102+ exprToCoreFn ss com ty (A.Var ident) =

103+ Var (ss, com, ty, Nothing) ident

104+ exprToCoreFn ss com ty (A.IfThenElse v1 v2 v3) =

105+ Case (ss, com, ty, Nothing) [exprToCoreFn ss [] Nothing v1]

106+ [ CaseAlternative [LiteralBinder nullAnn $ BooleanLiteral True]

107+ (Right $ exprToCoreFn Nothing [] Nothing v2)

108+ , CaseAlternative [LiteralBinder nullAnn $ BooleanLiteral False]

109+ (Right $ exprToCoreFn Nothing [] Nothing v3) ]

110+ exprToCoreFn ss com ty (A.Constructor name) =

111+ Var (ss, com, ty, Just $ getConstructorMeta name) $ fmap properToIdent name

112+ exprToCoreFn ss com ty (A.Case vs alts) =

113+ Case (ss, com, ty, Nothing) (map (exprToCoreFn ss [] Nothing) vs) (map (altToCoreFn ss) alts)

114+ exprToCoreFn ss com _ (A.TypedValue _ v ty) =

115+ exprToCoreFn ss com (Just ty) v

116+ exprToCoreFn ss com ty (A.Let ds v) =

117+ Let (ss, com, ty, Nothing) (concatMap (declToCoreFn ss []) ds) (exprToCoreFn ss [] Nothing v)

118+ exprToCoreFn ss com _ (A.TypeClassDictionaryConstructorApp name (A.TypedValue _ (A.ObjectLiteral vs) _)) =

119+ let args = map (exprToCoreFn ss [] Nothing . snd) $ sortBy (compare `on` fst) vs

120+ ctor = Var (ss, [], Nothing, Just IsTypeClassConstructor) (fmap properToIdent name)

121+ in foldl (App (ss, com, Nothing, Nothing)) ctor args

122+ exprToCoreFn ss com ty (A.TypeClassDictionaryAccessor _ ident) =

123+ Abs (ss, com, ty, Nothing) (Ident "dict")

124+ (Accessor nullAnn (runIdent ident) (Var nullAnn $ Qualified Nothing (Ident "dict")))

125+ exprToCoreFn _ com ty (A.PositionedValue ss com1 v) =

126+ exprToCoreFn (Just ss) (com ++ com1) ty v

127+ exprToCoreFn _ _ _ e =

128+ error $ "Unexpected value in exprToCoreFn mn: " ++ show e

129+

130+ -- |

131+ -- Desugars case alternatives from AST to CoreFn representation.

132+ --

133+ altToCoreFn :: Maybe SourceSpan -> A.CaseAlternative -> CaseAlternative Ann

134+ altToCoreFn ss (A.CaseAlternative bs vs) = CaseAlternative (map (binderToCoreFn ss []) bs) (go vs)

135+ where

136+ go :: Either [(A.Guard, A.Expr)] A.Expr -> Either [(Guard Ann, Expr Ann)] (Expr Ann)

137+ go (Left ges) = Left $ map (exprToCoreFn ss [] Nothing *** exprToCoreFn ss [] Nothing) ges

138+ go (Right e) = Right (exprToCoreFn ss [] Nothing e)

139+

140+ -- |

141+ -- Desugars case binders from AST to CoreFn representation.

142+ --

143+ binderToCoreFn :: Maybe SourceSpan -> [Comment] -> A.Binder -> Binder Ann

144+ binderToCoreFn ss com (A.NullBinder) =

145+ NullBinder (ss, com, Nothing, Nothing)

146+ binderToCoreFn ss com (A.BooleanBinder b) =

147+ LiteralBinder (ss, com, Nothing, Nothing) (BooleanLiteral b)

148+ binderToCoreFn ss com (A.StringBinder s) =

149+ LiteralBinder (ss, com, Nothing, Nothing) (StringLiteral s)

150+ binderToCoreFn ss com (A.NumberBinder n) =

151+ LiteralBinder (ss, com, Nothing, Nothing) (NumericLiteral n)

152+ binderToCoreFn ss com (A.VarBinder name) =

153+ VarBinder (ss, com, Nothing, Nothing) name

154+ binderToCoreFn ss com (A.ConstructorBinder dctor@(Qualified mn' _) bs) =

155+ let (_, tctor, _, _) = lookupConstructor env dctor

156+ in ConstructorBinder (ss, com, Nothing, Just $ getConstructorMeta dctor) (Qualified mn' tctor) dctor (map (binderToCoreFn ss []) bs)

157+ binderToCoreFn ss com (A.ObjectBinder bs) =

158+ LiteralBinder (ss, com, Nothing, Nothing) (ObjectLiteral $ map (second (binderToCoreFn ss [])) bs)

159+ binderToCoreFn ss com (A.ArrayBinder bs) =

160+ LiteralBinder (ss, com, Nothing, Nothing) (ArrayLiteral $ map (binderToCoreFn ss []) bs)

161+ binderToCoreFn ss com (A.ConsBinder b1 b2) =

162+ let arrCtor = Qualified (Just $ ModuleName [ProperName "Prim"]) (ProperName "Array")

163+ in ConstructorBinder (ss, com, Nothing, Nothing) arrCtor arrCtor $ map (binderToCoreFn ss []) [b1, b2]

164+ binderToCoreFn ss com (A.NamedBinder name b) =

165+ NamedBinder (ss, com, Nothing, Nothing) name (binderToCoreFn ss [] b)

166+ binderToCoreFn _ com (A.PositionedBinder ss com1 b) =

167+ binderToCoreFn (Just ss) (com ++ com1) b

168+

169+ -- |

170+ -- Gets metadata for data constructors.

171+ --

172+ getConstructorMeta :: Qualified ProperName -> Meta

173+ getConstructorMeta ctor =

174+ case lookupConstructor env ctor of

175+ (Newtype, _, _, _) -> IsNewtype

176+ dc@(Data, _, _, fields) ->

177+ let constructorType = if numConstructors (ctor, dc) == 1 then ProductType else SumType

178+ in IsConstructor constructorType fields

179+ where

180+ numConstructors :: (Qualified ProperName, (DataDeclType, ProperName, Type, [Ident])) -> Int

181+ numConstructors ty = length $ filter (((==) `on` typeConstructor) ty) $ M.toList $ dataConstructors env

182+ typeConstructor :: (Qualified ProperName, (DataDeclType, ProperName, Type, [Ident])) -> (ModuleName, ProperName)

183+ typeConstructor (Qualified (Just mn') _, (_, tyCtor, _, _)) = (mn', tyCtor)

184+ typeConstructor _ = error "Invalid argument to typeConstructor"

185+

186+-- |

187+-- Find module names from qualified references to values. This is used to

188+-- ensure instances are imported from any module that is referenced by the

189+-- current module, not just from those that are imported explicitly (#667).

190+--

191+findQualModules :: [A.Declaration] -> [ModuleName]

192+findQualModules decls =

193+ let (f, _, _, _, _) = everythingOnValues (++) (const []) fqValues (const []) (const []) (const [])

194+ in f `concatMap` decls

195+ where

196+ fqValues :: A.Expr -> [ModuleName]

197+ fqValues (A.Var (Qualified (Just mn) _)) = [mn]

198+ fqValues _ = []

199+

200+-- |

201+-- Desugars import declarations from AST to CoreFn representation.

202+--

203+importToCoreFn :: A.Declaration -> Maybe ModuleName

204+importToCoreFn (A.ImportDeclaration name _ _) = Just name

205+importToCoreFn (A.PositionedDeclaration _ _ d) = importToCoreFn d

206+importToCoreFn _ = Nothing

207+

208+-- |

209+-- Desugars foreign declarations from AST to CoreFn representation.

210+--

211+externToCoreFn :: A.Declaration -> Maybe ForeignDecl

212+externToCoreFn (A.ExternDeclaration _ name js ty) = Just (name, js, ty)

213+externToCoreFn (A.ExternInstanceDeclaration name _ _ _) = Just (name, Nothing, tyObject)

214+externToCoreFn (A.PositionedDeclaration _ _ d) = externToCoreFn d

215+externToCoreFn _ = Nothing

216+

217+-- |

218+-- Desugars export declarations references from AST to CoreFn representation.

219+-- CoreFn modules only export values, so all data constructors, class

220+-- constructor, instances and values are flattened into one list.

221+--

222+exportToCoreFn :: A.DeclarationRef -> [Ident]

223+exportToCoreFn (A.TypeRef _ (Just dctors)) = map properToIdent dctors

224+exportToCoreFn (A.ValueRef name) = [name]

225+exportToCoreFn (A.TypeClassRef name) = [properToIdent name]

226+exportToCoreFn (A.TypeInstanceRef name) = [name]

227+exportToCoreFn (A.PositionedDeclarationRef _ _ d) = exportToCoreFn d

228+exportToCoreFn _ = []

229+

230+-- |

231+-- Makes a typeclass dictionary constructor function. The returned expression

232+-- is a function that accepts the superclass instances and member

233+-- implementations and returns a record for the instance dictionary.

234+--

235+mkTypeClassConstructor :: Maybe SourceSpan -> [Comment] -> [Constraint] -> [A.Declaration] -> Expr Ann

236+mkTypeClassConstructor ss com [] [] = Literal (ss, com, Nothing, Just IsTypeClassConstructor) (ObjectLiteral [])

237+mkTypeClassConstructor ss com supers members =

238+ let args@(a:as) = sort $ map typeClassMemberName members ++ superClassDictionaryNames supers

239+ props = [ (arg, Var nullAnn $ Qualified Nothing (Ident arg)) | arg <- args ]

240+ dict = Literal nullAnn (ObjectLiteral props)

241+ in Abs (ss, com, Nothing, Just IsTypeClassConstructor)

242+ (Ident a)

243+ (foldr (Abs nullAnn . Ident) dict as)

244+

245+-- |

246+-- Converts a ProperName to an Ident.

247+--

248+properToIdent :: ProperName -> Ident

249+properToIdent = Ident . runProperName

src/Language/PureScript/CoreFn/Expr.hsnew file+134

@@ -0,0 +1,134 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : Language.PureScript.CoreFn.Expr

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- | The core functional representation

12+--

13+-----------------------------------------------------------------------------

14+

15+{-# LANGUAGE DeriveDataTypeable #-}

16+{-# LANGUAGE DeriveFunctor #-}

17+

18+module Language.PureScript.CoreFn.Expr where

19+

20+import Control.Arrow ((***))

21+

22+import qualified Data.Data as D

23+

24+import Language.PureScript.CoreFn.Binders

25+import Language.PureScript.CoreFn.Literals

26+import Language.PureScript.Names

27+

28+-- |

29+-- Data type for expressions and terms

30+--

31+data Expr a

32+ -- |

33+ -- A literal value

34+ --

35+ = Literal a (Literal (Expr a))

36+ -- |

37+ -- A data constructor (type name, constructor name, field names)

38+ --

39+ | Constructor a ProperName ProperName [Ident]

40+ -- |

41+ -- A record property accessor

42+ --

43+ | Accessor a String (Expr a)

44+ -- |

45+ -- Partial record update

46+ --

47+ | ObjectUpdate a (Expr a) [(String, Expr a)]

48+ -- |

49+ -- Function introduction

50+ --

51+ | Abs a Ident (Expr a)

52+ -- |

53+ -- Function application

54+ --

55+ | App a (Expr a) (Expr a)

56+ -- |

57+ -- Variable

58+ --

59+ | Var a (Qualified Ident)

60+ -- |

61+ -- A case expression

62+ --

63+ | Case a [Expr a] [CaseAlternative a]

64+ -- |

65+ -- A let binding

66+ --

67+ | Let a [Bind a] (Expr a) deriving (Show, D.Data, D.Typeable, Functor)

68+

69+-- |

70+-- A let or module binding.

71+--

72+data Bind a

73+ -- |

74+ -- Non-recursive binding for a single value

75+ --

76+ = NonRec Ident (Expr a)

77+ -- |

78+ -- Mutually recursive binding group for several values

79+ --

80+ | Rec [(Ident, Expr a)] deriving (Show, D.Data, D.Typeable, Functor)

81+

82+-- |

83+-- A guard is just a boolean-valued expression that appears alongside a set of binders

84+--

85+type Guard a = Expr a

86+

87+-- |

88+-- An alternative in a case statement

89+--

90+data CaseAlternative a = CaseAlternative

91+ { -- |

92+ -- A collection of binders with which to match the inputs

93+ --

94+ caseAlternativeBinders :: [Binder a]

95+ -- |

96+ -- The result expression or a collect of guarded expressions

97+ --

98+ , caseAlternativeResult :: Either [(Guard a, Expr a)] (Expr a)

99+ } deriving (Show, D.Data, D.Typeable)

100+

101+instance Functor CaseAlternative where

102+

103+ fmap f (CaseAlternative cabs car) = CaseAlternative

104+ (fmap (fmap f) $ cabs)

105+ (either (Left . fmap (fmap f *** fmap f)) (Right . fmap f) car)

106+

107+-- |

108+-- Extract the annotation from a term

109+--

110+extractAnn :: Expr a -> a

111+extractAnn (Literal a _) = a

112+extractAnn (Constructor a _ _ _) = a

113+extractAnn (Accessor a _ _) = a

114+extractAnn (ObjectUpdate a _ _) = a

115+extractAnn (Abs a _ _) = a

116+extractAnn (App a _ _) = a

117+extractAnn (Var a _) = a

118+extractAnn (Case a _ _) = a

119+extractAnn (Let a _ _) = a

120+

121+

122+-- |

123+-- Modify the annotation on a term

124+--

125+modifyAnn :: (a -> a) -> Expr a -> Expr a

126+modifyAnn f (Literal a b) = Literal (f a) b

127+modifyAnn f (Constructor a b c d) = Constructor (f a) b c d

128+modifyAnn f (Accessor a b c) = Accessor (f a) b c

129+modifyAnn f (ObjectUpdate a b c) = ObjectUpdate (f a) b c

130+modifyAnn f (Abs a b c) = Abs (f a) b c

131+modifyAnn f (App a b c) = App (f a) b c

132+modifyAnn f (Var a b) = Var (f a) b

133+modifyAnn f (Case a b c) = Case (f a) b c

134+modifyAnn f (Let a b c) = Let (f a) b c

src/Language/PureScript/CoreFn/Literals.hsnew file+46

@@ -0,0 +1,46 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : Language.PureScript.CoreFn.Literals

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.hsnew file+51

@@ -0,0 +1,51 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : Language.PureScript.CoreFn.Meta

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.hsnew file+32

@@ -0,0 +1,32 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : Language.PureScript.CoreFn.Module

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.hsnew file+85

@@ -0,0 +1,85 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : Language.PureScript.CoreFn.Traversals

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- | CoreFn traversal helpers

12+--

13+-----------------------------------------------------------------------------

14+

15+module Language.PureScript.CoreFn.Traversals where

16+

17+import Control.Arrow (second, (***), (+++))

18+

19+import Language.PureScript.CoreFn.Binders

20+import Language.PureScript.CoreFn.Expr

21+import Language.PureScript.CoreFn.Literals

22+

23+everywhereOnValues :: (Bind a -> Bind a) ->

24+ (Expr a -> Expr a) ->

25+ (Binder a -> Binder a) ->

26+ (Bind a -> Bind a, Expr a -> Expr a, Binder a -> Binder a)

27+everywhereOnValues f g h = (f', g', h')

28+ where

29+ f' (NonRec name e) = f (NonRec name (g' e))

30+ f' (Rec es) = f (Rec (map (second g') es))

31+

32+ g' (Literal ann e) = g (Literal ann (handleLiteral g' e))

33+ g' (Accessor ann prop e) = g (Accessor ann prop (g' e))

34+ g' (ObjectUpdate ann obj vs) = g (ObjectUpdate ann (g' obj) (map (fmap g') vs))

35+ g' (Abs ann name e) = g (Abs ann name (g' e))

36+ g' (App ann v1 v2) = g (App ann (g' v1) (g' v2))

37+ g' (Case ann vs alts) = g (Case ann (map g' vs) (map handleCaseAlternative alts))

38+ g' (Let ann ds e) = g (Let ann (map f' ds) (g' e))

39+ g' e = g e

40+

41+ h' (LiteralBinder a b) = h (LiteralBinder a (handleLiteral h' b))

42+ h' (NamedBinder a name b) = h (NamedBinder a name (h' b))

43+ h' b = h b

44+

45+ handleCaseAlternative ca =

46+ ca { caseAlternativeBinders = map h' (caseAlternativeBinders ca)

47+ , caseAlternativeResult = (map (g' *** g') +++ g') (caseAlternativeResult ca)

48+ }

49+

50+ handleLiteral :: (a -> a) -> Literal a -> Literal a

51+ handleLiteral i (ArrayLiteral ls) = ArrayLiteral (map i ls)

52+ handleLiteral i (ObjectLiteral ls) = ObjectLiteral (map (fmap i) ls)

53+ handleLiteral _ other = other

54+

55+everythingOnValues :: (r -> r -> r) ->

56+ (Bind a -> r) ->

57+ (Expr a -> r) ->

58+ (Binder a -> r) ->

59+ (CaseAlternative a -> r) ->

60+ (Bind a -> r, Expr a -> r, Binder a -> r, CaseAlternative a -> r)

61+everythingOnValues (<>) f g h i = (f', g', h', i')

62+ where

63+ f' b@(NonRec _ e) = f b <> g' e

64+ f' b@(Rec es) = foldl (<>) (f b) (map (g' . snd) es)

65+

66+ g' v@(Literal _ l) = foldl (<>) (g v) (map g' (extractLiteral l))

67+ g' v@(Accessor _ _ e1) = g v <> g' e1

68+ g' v@(ObjectUpdate _ obj vs) = foldl (<>) (g v <> g' obj) (map (g' . snd) vs)

69+ g' v@(Abs _ _ e1) = g v <> g' e1

70+ g' v@(App _ e1 e2) = g v <> g' e1 <> g' e2

71+ g' v@(Case _ vs alts) = foldl (<>) (foldl (<>) (g v) (map g' vs)) (map i' alts)

72+ g' v@(Let _ ds e1) = foldl (<>) (g v) (map f' ds) <> g' e1

73+ g' v = g v

74+

75+ h' b@(LiteralBinder _ l) = foldl (<>) (h b) (map h' (extractLiteral l))

76+ h' b@(ConstructorBinder _ _ _ bs) = foldl (<>) (h b) (map h' bs)

77+ h' b@(NamedBinder _ _ b1) = h b <> h' b1

78+ h' b = h b

79+

80+ i' ca@(CaseAlternative bs (Right val)) = foldl (<>) (i ca) (map h' bs) <> g' val

81+ i' ca@(CaseAlternative bs (Left gs)) = foldl (<>) (i ca) (map h' bs ++ concatMap (\(grd, val) -> [g' grd, g' val]) gs)

82+

83+ extractLiteral (ArrayLiteral xs) = xs

84+ extractLiteral (ObjectLiteral xs) = map snd xs

85+ extractLiteral _ = []

src/Language/PureScript/DeadCodeElimination.hsnew file+102

@@ -0,0 +1,102 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : Language.PureScript.DeadCodeElimination

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.hsnew file+241

@@ -0,0 +1,241 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : Language.PureScript.Environment

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.hsnew file+416

@@ -0,0 +1,416 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : Language.PureScript.Error

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 (intersperse, intercalate)

23+import Data.Monoid

24+import Data.Foldable (fold, foldMap)

25+

26+import Control.Monad.Except

27+import Control.Monad.Unify

28+import Control.Applicative ((<$>))

29+

30+import Language.PureScript.AST

31+import Language.PureScript.Pretty

32+import Language.PureScript.Types

33+import Language.PureScript.Names

34+import Language.PureScript.Kinds

35+import Language.PureScript.TypeClassDictionaries

36+

37+-- |

38+-- A type of error messages

39+--

40+data ErrorMessage

41+ = InfiniteType Type

42+ | InfiniteKind Kind

43+ | CannotReorderOperators

44+ | MultipleFixities Ident

45+ | OrphanTypeDeclaration Ident

46+ | OrphanFixityDeclaration String

47+ | RedefinedModule ModuleName

48+ | RedefinedIdent Ident

49+ | OverlappingNamesInLet

50+ | UnknownModule ModuleName

51+ | UnknownType (Qualified ProperName)

52+ | UnknownTypeClass (Qualified ProperName)

53+ | UnknownValue (Qualified Ident)

54+ | UnknownDataConstructor (Qualified ProperName) (Maybe (Qualified ProperName))

55+ | UnknownTypeConstructor (Qualified ProperName)

56+ | ConflictingImport String ModuleName

57+ | ConflictingImports String ModuleName ModuleName

58+ | ConflictingTypeDecls ProperName

59+ | ConflictingCtorDecls ProperName

60+ | TypeConflictsWithClass ProperName

61+ | CtorConflictsWithClass ProperName

62+ | ClassConflictsWithType ProperName

63+ | ClassConflictsWithCtor ProperName

64+ | DuplicateClassExport ProperName

65+ | DuplicateValueExport Ident

66+ | DuplicateTypeArgument String

67+ | InvalidDoBind

68+ | InvalidDoLet

69+ | CycleInDeclaration Ident

70+ | CycleInTypeSynonym (Maybe ProperName)

71+ | NameIsUndefined Ident

72+ | NameNotInScope Ident

73+ | UndefinedTypeVariable ProperName

74+ | PartiallyAppliedSynonym (Qualified ProperName)

75+ | NotYetDefined [Ident] ErrorMessage

76+ | EscapedSkolem (Maybe Expr)

77+ | UnspecifiedSkolemScope

78+ | TypesDoNotUnify Type Type

79+ | KindsDoNotUnify Kind Kind

80+ | ConstrainedTypeUnified Type Type

81+ | OverlappingInstances (Qualified ProperName) [Type] [DictionaryValue]

82+ | NoInstanceFound (Qualified ProperName) [Type]

83+ | DuplicateLabel String (Maybe Expr)

84+ | DuplicateValueDeclaration Ident

85+ | ArgListLengthsDiffer Ident

86+ | OverlappingArgNames (Maybe Ident)

87+ | MissingClassMember Ident

88+ | ExpectedType Kind

89+ | IncorrectConstructorArity (Qualified ProperName)

90+ | SubsumptionCheckFailed

91+ | ExprDoesNotHaveType Expr Type

92+ | PropertyIsMissing String Type

93+ | ErrorUnifyingTypes Type Type ErrorMessage

94+ | CannotApplyFunction Type Expr

95+ | TypeSynonymInstance

96+ | InvalidNewtype

97+ | InvalidInstanceHead Type

98+ | TransitiveExportError DeclarationRef [DeclarationRef]

99+ | ErrorInExpression Expr ErrorMessage

100+ | ErrorInModule ModuleName ErrorMessage

101+ | ErrorInInstance (Qualified ProperName) [Type] ErrorMessage

102+ | ErrorInSubsumption Type Type ErrorMessage

103+ | ErrorCheckingType Expr Type ErrorMessage

104+ | ErrorCheckingKind Type ErrorMessage

105+ | ErrorInferringType Expr ErrorMessage

106+ | ErrorInApplication Expr Type Expr ErrorMessage

107+ | ErrorInDataConstructor ProperName ErrorMessage

108+ | ErrorInTypeConstructor ProperName ErrorMessage

109+ | ErrorInBindingGroup [Ident] ErrorMessage

110+ | ErrorInDataBindingGroup ErrorMessage

111+ | ErrorInTypeSynonym ProperName ErrorMessage

112+ | ErrorInValueDeclaration Ident ErrorMessage

113+ | ErrorInForeignImport Ident ErrorMessage

114+ | PositionedError SourceSpan ErrorMessage

115+ deriving (Show)

116+

117+instance UnificationError Type ErrorMessage where

118+ occursCheckFailed = InfiniteType

119+

120+instance UnificationError Kind ErrorMessage where

121+ occursCheckFailed = InfiniteKind

122+

123+-- |

124+-- Get the error code for a particular error type

125+--

126+errorCode :: ErrorMessage -> String

127+errorCode (InfiniteType _) = "InfiniteType"

128+errorCode (InfiniteKind _) = "InfiniteKind"

129+errorCode CannotReorderOperators = "CannotReorderOperators"

130+errorCode (MultipleFixities _) = "MultipleFixities"

131+errorCode (OrphanTypeDeclaration _) = "OrphanTypeDeclaration"

132+errorCode (OrphanFixityDeclaration _) = "OrphanFixityDeclaration"

133+errorCode (RedefinedModule _) = "RedefinedModule"

134+errorCode (RedefinedIdent _) = "RedefinedIdent"

135+errorCode OverlappingNamesInLet = "OverlappingNamesInLet"

136+errorCode (UnknownModule _) = "UnknownModule"

137+errorCode (UnknownType _) = "UnknownType"

138+errorCode (UnknownTypeClass _) = "UnknownTypeClass"

139+errorCode (UnknownValue _) = "UnknownValue"

140+errorCode (UnknownDataConstructor _ _) = "UnknownDataConstructor"

141+errorCode (UnknownTypeConstructor _) = "UnknownTypeConstructor"

142+errorCode (ConflictingImport _ _) = "ConflictingImport"

143+errorCode (ConflictingImports _ _ _) = "ConflictingImports"

144+errorCode (ConflictingTypeDecls _) = "ConflictingTypeDecls"

145+errorCode (ConflictingCtorDecls _) = "ConflictingCtorDecls"

146+errorCode (TypeConflictsWithClass _) = "TypeConflictsWithClass"

147+errorCode (CtorConflictsWithClass _) = "CtorConflictsWithClass"

148+errorCode (ClassConflictsWithType _) = "ClassConflictsWithType"

149+errorCode (ClassConflictsWithCtor _) = "ClassConflictsWithCtor"

150+errorCode (DuplicateClassExport _) = "DuplicateClassExport"

151+errorCode (DuplicateValueExport _) = "DuplicateValueExport"

152+errorCode (DuplicateTypeArgument _) = "DuplicateTypeArgument"

153+errorCode InvalidDoBind = "InvalidDoBind"

154+errorCode InvalidDoLet = "InvalidDoLet"

155+errorCode (CycleInDeclaration _) = "CycleInDeclaration"

156+errorCode (CycleInTypeSynonym _) = "CycleInTypeSynonym"

157+errorCode (NameIsUndefined _) = "NameIsUndefined"

158+errorCode (NameNotInScope _) = "NameNotInScope"

159+errorCode (UndefinedTypeVariable _) = "UndefinedTypeVariable"

160+errorCode (PartiallyAppliedSynonym _) = "PartiallyAppliedSynonym"

161+errorCode (EscapedSkolem _) = "EscapedSkolem"

162+errorCode UnspecifiedSkolemScope = "UnspecifiedSkolemScope"

163+errorCode (TypesDoNotUnify _ _) = "TypesDoNotUnify"

164+errorCode (KindsDoNotUnify _ _) = "KindsDoNotUnify"

165+errorCode (ConstrainedTypeUnified _ _) = "ConstrainedTypeUnified"

166+errorCode (OverlappingInstances _ _ _) = "OverlappingInstances"

167+errorCode (NoInstanceFound _ _) = "NoInstanceFound"

168+errorCode (DuplicateLabel _ _) = "DuplicateLabel"

169+errorCode (DuplicateValueDeclaration _) = "DuplicateValueDeclaration"

170+errorCode (ArgListLengthsDiffer _) = "ArgListLengthsDiffer"

171+errorCode (OverlappingArgNames _) = "OverlappingArgNames"

172+errorCode (MissingClassMember _) = "MissingClassMember"

173+errorCode (ExpectedType _) = "ExpectedType"

174+errorCode (IncorrectConstructorArity _) = "IncorrectConstructorArity"

175+errorCode SubsumptionCheckFailed = "SubsumptionCheckFailed"

176+errorCode (ExprDoesNotHaveType _ _) = "ExprDoesNotHaveType"

177+errorCode (PropertyIsMissing _ _) = "PropertyIsMissing"

178+errorCode (ErrorUnifyingTypes _ _ _) = "ErrorUnifyingTypes"

179+errorCode (CannotApplyFunction _ _) = "CannotApplyFunction"

180+errorCode TypeSynonymInstance = "TypeSynonymInstance"

181+errorCode InvalidNewtype = "InvalidNewtype"

182+errorCode (InvalidInstanceHead _) = "InvalidInstanceHead"

183+errorCode (TransitiveExportError _ _) = "TransitiveExportError"

184+errorCode (NotYetDefined _ e) = errorCode e

185+errorCode (ErrorInExpression _ e) = errorCode e

186+errorCode (ErrorInModule _ e) = errorCode e

187+errorCode (ErrorInInstance _ _ e) = errorCode e

188+errorCode (ErrorInSubsumption _ _ e) = errorCode e

189+errorCode (ErrorCheckingType _ _ e) = errorCode e

190+errorCode (ErrorCheckingKind _ e) = errorCode e

191+errorCode (ErrorInferringType _ e) = errorCode e

192+errorCode (ErrorInApplication _ _ _ e) = errorCode e

193+errorCode (ErrorInDataConstructor _ e) = errorCode e

194+errorCode (ErrorInTypeConstructor _ e) = errorCode e

195+errorCode (ErrorInBindingGroup _ e) = errorCode e

196+errorCode (ErrorInDataBindingGroup e) = errorCode e

197+errorCode (ErrorInTypeSynonym _ e) = errorCode e

198+errorCode (ErrorInValueDeclaration _ e) = errorCode e

199+errorCode (ErrorInForeignImport _ e) = errorCode e

200+errorCode (PositionedError _ e) = errorCode e

201+

202+-- |

203+-- Pretty print an ErrorMessage

204+--

205+prettyPrintErrorMessage :: ErrorMessage -> String

206+prettyPrintErrorMessage e =

207+ go e ++ "\n\nSee " ++ wikiUri ++ " for more information, or to contribute content related to this error."

208+ where

209+ wikiUri :: String

210+ wikiUri = "https://github.com/purescript/purescript/wiki/Error-Code-" ++ errorCode e

211+

212+ go :: ErrorMessage -> String

213+ go InvalidDoBind = "Bind statement cannot be the last statement in a do block"

214+ go InvalidDoLet = "Let statement cannot be the last statement in a do block"

215+ go CannotReorderOperators = "Unable to reorder operators"

216+ go UnspecifiedSkolemScope = "Skolem variable scope is unspecified"

217+ go OverlappingNamesInLet = "Overlapping names in let binding."

218+ go (InfiniteType ty) = "Infinite type detected: " ++ prettyPrintType ty

219+ go (InfiniteKind ki) = "Infinite kind detected: " ++ prettyPrintKind ki

220+ go (MultipleFixities name) = "Multiple fixity declarations for " ++ show name

221+ go (OrphanTypeDeclaration nm) = "Orphan type declaration for " ++ show nm

222+ go (OrphanFixityDeclaration op) = "Orphan fixity declaration for " ++ show op

223+ go (RedefinedModule name) = "Module " ++ show name ++ " has been defined multiple times"

224+ go (RedefinedIdent name) = "Name " ++ show name ++ " has been defined multiple times"

225+ go (UnknownModule mn) = "Unknown module " ++ show mn

226+ go (UnknownType name) = "Unknown type " ++ show name

227+ go (UnknownTypeClass name) = "Unknown type class " ++ show name

228+ go (UnknownValue name) = "Unknown value " ++ show name

229+ go (UnknownTypeConstructor name) = "Unknown type constructor " ++ show name

230+ go (UnknownDataConstructor dc tc) = "Unknown data constructor " ++ show dc ++ foldMap ((" for type constructor " ++) . show) tc

231+ go (ConflictingImport nm mn) = "Declaration " ++ nm ++ " conflicts with import " ++ show mn

232+ go (ConflictingImports nm m1 m2) = "Conflicting imports for " ++ nm ++ " from modules " ++ show m1 ++ " and " ++ show m2

233+ go (ConflictingTypeDecls nm) = "Conflicting type declarations for " ++ show nm

234+ go (ConflictingCtorDecls nm) = "Conflicting data constructor declarations for " ++ show nm

235+ go (TypeConflictsWithClass nm) = "Type " ++ show nm ++ " conflicts with type class declaration of the same name"

236+ go (CtorConflictsWithClass nm) = "Data constructor " ++ show nm ++ " conflicts with type class declaration of the same name"

237+ go (ClassConflictsWithType nm) = "Type class " ++ show nm ++ " conflicts with type declaration of the same name"

238+ go (ClassConflictsWithCtor nm) = "Type class " ++ show nm ++ " conflicts with data constructor declaration of the same name"

239+ go (DuplicateClassExport nm) = "Duplicate export declaration for type class " ++ show nm

240+ go (DuplicateValueExport nm) = "Duplicate export declaration for value " ++ show nm

241+ go (CycleInDeclaration nm) = "Cycle in declaration of " ++ show nm

242+ go (NotYetDefined names err) = "The following are not yet defined here: " ++ unwords (map show names) ++ "\n" ++ go err

243+ go (CycleInTypeSynonym pn) = "Cycle in type synonym" ++ foldMap ((" " ++) . show) pn

244+ go (NameIsUndefined ident) = show ident ++ " is undefined"

245+ go (NameNotInScope ident) = show ident ++ " may not be defined in the current scope"

246+ go (UndefinedTypeVariable name) = "Type variable " ++ show name ++ " is undefined"

247+ go (PartiallyAppliedSynonym name) = "Partially applied type synonym " ++ show name

248+ go (EscapedSkolem binding) = "Rigid/skolem type variable " ++ foldMap (("bound by " ++) . prettyPrintValue) binding ++ " has escaped."

249+ go (TypesDoNotUnify t1 t2) = "Cannot unify " ++ prettyPrintType t1 ++ " with " ++ prettyPrintType t2

250+ go (KindsDoNotUnify k1 k2) = "Cannot unify " ++ prettyPrintKind k1 ++ " with " ++ prettyPrintKind k2

251+ go (ConstrainedTypeUnified t1 t2) = "Cannot unify constrained type " ++ prettyPrintType t1 ++ " with " ++ prettyPrintType t2

252+ go (OverlappingInstances nm ts ds) = unlines ( ("Overlapping instances found for " ++ show nm ++ " " ++ unwords (map prettyPrintType ts) ++ ":")

253+ : map prettyPrintDictionaryValue ds)

254+ go (NoInstanceFound nm ts) = "No instance found for " ++ show nm ++ " " ++ unwords (map prettyPrintTypeAtom ts)

255+ go (DuplicateLabel l expr) = "Duplicate label " ++ show l ++ " in row." ++ foldMap ((" Relevant expression: " ++) . prettyPrintValue) expr

256+ go (DuplicateTypeArgument name) = "Duplicate type argument " ++ show name

257+ go (DuplicateValueDeclaration nm) = "Duplicate value declaration for " ++ show nm

258+ go (ArgListLengthsDiffer ident) = "Argument list lengths differ in declaration " ++ show ident

259+ go (OverlappingArgNames ident) = "Overlapping names in function/binder" ++ foldMap ((" in declaration" ++) . show) ident

260+ go (MissingClassMember ident) = "Member " ++ show ident ++ " has not been implemented"

261+ go (ExpectedType kind) = "Expected type of kind *, was " ++ prettyPrintKind kind

262+ go (IncorrectConstructorArity nm) = "Wrong number of arguments to constructor " ++ show nm

263+ go SubsumptionCheckFailed = "Unable to check type subsumption"

264+ go (ExprDoesNotHaveType expr ty) = "Expression " ++ prettyPrintValue expr ++ " does not have type " ++ prettyPrintType ty

265+ go (PropertyIsMissing prop row) = "Row " ++ prettyPrintRow row ++ " lacks required property " ++ show prop

266+ go (CannotApplyFunction fn arg) = "Cannot apply function of type " ++ prettyPrintType fn ++ " to argument " ++ prettyPrintValue arg

267+ go TypeSynonymInstance = "Type synonym instances are disallowed"

268+ go InvalidNewtype = "Newtypes must define a single constructor with a single argument"

269+ go (InvalidInstanceHead ty) = "Invalid type " ++ prettyPrintType ty ++ " in class instance head"

270+ go (TransitiveExportError x ys) = "An export for " ++ prettyPrintExport x ++ " requires the following to also be exported: " ++ intercalate ", " (map prettyPrintExport ys)

271+ go (ErrorUnifyingTypes t1 t2 err) = "Error unifying type " ++ prettyPrintType t1 ++ " with type " ++ prettyPrintType t2 ++ ":\n" ++ go err

272+ go (ErrorInExpression expr err) = "Error in expression " ++ prettyPrintValue expr ++ ":\n" ++ go err

273+ go (ErrorInModule mn err) = "Error in module " ++ show mn ++ ":\n" ++ go err

274+ go (ErrorInSubsumption t1 t2 err) = "Error checking that type " ++ prettyPrintType t1 ++ " subsumes type " ++ prettyPrintType t2 ++ ":\n" ++ go err

275+ go (ErrorInInstance name ts err) = "Error in type class instance " ++ show name ++ " " ++ unwords (map prettyPrintTypeAtom ts) ++ ":\n" ++ go err

276+ go (ErrorCheckingKind ty err) = "Error checking kind of type " ++ prettyPrintType ty ++ ":\n" ++ go err

277+ go (ErrorInferringType expr err) = "Error inferring type of value " ++ prettyPrintValue expr ++ ":\n" ++ go err

278+ go (ErrorCheckingType expr ty err) = "Error checking value " ++ prettyPrintValue expr ++ " has type " ++ prettyPrintType ty ++ ":\n" ++ go err

279+ go (ErrorInApplication f t a err) = "Error applying function " ++ prettyPrintValue f ++ " of type " ++ prettyPrintType t ++ " to argument " ++ prettyPrintValue a ++ ":\n" ++ go err

280+ go (ErrorInDataConstructor nm err) = "Error in data constructor " ++ show nm ++ ":\n" ++ go err

281+ go (ErrorInTypeConstructor nm err) = "Error in type constructor " ++ show nm ++ ":\n" ++ go err

282+ go (ErrorInBindingGroup nms err) = "Error in binding group " ++ intercalate ", " (map show nms) ++ ":\n" ++ go err

283+ go (ErrorInDataBindingGroup err) = "Error in data binding group:\n" ++ go err

284+ go (ErrorInTypeSynonym name err) = "Error in type synonym " ++ show name ++ ":\n" ++ go err

285+ go (ErrorInValueDeclaration n err) = "Error in value declaration " ++ show n ++ ":\n" ++ go err

286+ go (ErrorInForeignImport nm err) = "Error in foreign import " ++ show nm ++ ":\n" ++ go err

287+ go (PositionedError pos err) = "Error at " ++ show pos ++ ":\n" ++ go err

288+

289+-- |

290+-- Render a DictionaryValue fit for human consumption in error messages

291+--

292+prettyPrintDictionaryValue :: DictionaryValue -> String

293+prettyPrintDictionaryValue = unlines . indented 0

294+ where

295+ indented n (LocalDictionaryValue _) = [spaces n ++ "Dictionary in scope"]

296+ indented n (GlobalDictionaryValue nm) = [spaces n ++ show nm]

297+ indented n (DependentDictionaryValue nm args) = (spaces n ++ show nm ++ " via") : concatMap (indented (n + 2)) args

298+ indented n (SubclassDictionaryValue sup nm _) = (spaces n ++ show nm ++ " via superclass") : indented (n + 2) sup

299+

300+ spaces n = replicate n ' ' ++ "- "

301+

302+-- |

303+-- Pretty print and export declaration

304+--

305+prettyPrintExport :: DeclarationRef -> String

306+prettyPrintExport (TypeRef pn _) = show pn

307+prettyPrintExport (ValueRef ident) = show ident

308+prettyPrintExport (TypeClassRef pn) = show pn

309+prettyPrintExport (TypeInstanceRef ident) = show ident

310+prettyPrintExport (PositionedDeclarationRef _ _ ref) = prettyPrintExport ref

311+

312+-- |

313+-- A stack trace for an error

314+--

315+newtype MultipleErrors = MultipleErrors

316+ { runMultipleErrors :: [ErrorMessage] } deriving (Show, Monoid)

317+

318+instance UnificationError Type MultipleErrors where

319+ occursCheckFailed = errorMessage . occursCheckFailed

320+

321+instance UnificationError Kind MultipleErrors where

322+ occursCheckFailed = errorMessage . occursCheckFailed

323+

324+-- |

325+-- Simplify an error message

326+--

327+simplifyErrorMessage :: ErrorMessage -> ErrorMessage

328+simplifyErrorMessage = unwrap Nothing

329+ where

330+ unwrap :: Maybe SourceSpan -> ErrorMessage -> ErrorMessage

331+ unwrap pos (ErrorInExpression _ err) = unwrap pos err

332+ unwrap pos (ErrorInInstance name ts err) = ErrorInInstance name ts (unwrap pos err)

333+ unwrap pos (ErrorInSubsumption t1 t2 err) = ErrorInSubsumption t1 t2 (unwrap pos err)

334+ unwrap pos (ErrorUnifyingTypes _ _ err) = unwrap pos err

335+ unwrap pos (ErrorInferringType _ err) = unwrap pos err

336+ unwrap pos (ErrorCheckingType _ _ err) = unwrap pos err

337+ unwrap pos (ErrorCheckingKind ty err) = ErrorCheckingKind ty (unwrap pos err)

338+ unwrap pos (ErrorInModule mn err) = ErrorInModule mn (unwrap pos err)

339+ unwrap pos (ErrorInApplication _ _ _ err) = unwrap pos err

340+ unwrap pos (ErrorInDataConstructor nm err) = ErrorInDataConstructor nm (unwrap pos err)

341+ unwrap pos (ErrorInTypeConstructor nm err) = ErrorInTypeConstructor nm (unwrap pos err)

342+ unwrap pos (ErrorInBindingGroup nms err) = ErrorInBindingGroup nms (unwrap pos err)

343+ unwrap pos (ErrorInDataBindingGroup err) = ErrorInDataBindingGroup (unwrap pos err)

344+ unwrap pos (ErrorInTypeSynonym nm err) = ErrorInTypeSynonym nm (unwrap pos err)

345+ unwrap pos (ErrorInValueDeclaration nm err) = ErrorInValueDeclaration nm (unwrap pos err)

346+ unwrap pos (ErrorInForeignImport nm err) = ErrorInForeignImport nm (unwrap pos err)

347+ unwrap pos (NotYetDefined ns err) = NotYetDefined ns (unwrap pos err)

348+ unwrap _ (PositionedError pos err) = unwrap (Just pos) err

349+ unwrap pos other = wrap pos other

350+

351+ wrap :: Maybe SourceSpan -> ErrorMessage -> ErrorMessage

352+ wrap Nothing = id

353+ wrap (Just pos) = PositionedError pos

354+

355+-- |

356+-- Create an error set from a single error message

357+--

358+errorMessage :: ErrorMessage -> MultipleErrors

359+errorMessage err = MultipleErrors [err]

360+

361+-- |

362+-- Lift a function on ErrorMessage to a function on MultipleErrors

363+--

364+onErrorMessages :: (ErrorMessage -> ErrorMessage) -> MultipleErrors -> MultipleErrors

365+onErrorMessages f = MultipleErrors . map f . runMultipleErrors

366+

367+-- |

368+-- Pretty print a single error, simplifying if necessary

369+--

370+prettyPrintSingleError :: Bool -> ErrorMessage -> String

371+prettyPrintSingleError full e = prettyPrintErrorMessage (if full then e else simplifyErrorMessage e)

372+

373+-- |

374+-- Pretty print multiple errors

375+--

376+prettyPrintMultipleErrors :: Bool -> MultipleErrors -> String

377+prettyPrintMultipleErrors full (MultipleErrors [e]) =

378+ prettyPrintSingleError full e

379+prettyPrintMultipleErrors full (MultipleErrors es) =

380+ unlines $ intersperse "" $ "Multiple errors:" : map (prettyPrintSingleError full) es

381+

382+-- |

383+-- Interpret multiple errors in a monad supporting errors

384+--

385+interpretMultipleErrors :: (MonadError String m) => Bool -> Either MultipleErrors a -> m a

386+interpretMultipleErrors printFullStack = either (throwError . prettyPrintMultipleErrors printFullStack) return

387+

388+-- |

389+-- Rethrow an error with a more detailed error message in the case of failure

390+--

391+rethrow :: (MonadError e m) => (e -> e) -> m a -> m a

392+rethrow f = flip catchError $ \e -> throwError (f e)

393+

394+-- |

395+-- Rethrow an error with source position information

396+--

397+rethrowWithPosition :: (MonadError MultipleErrors m) => SourceSpan -> m a -> m a

398+rethrowWithPosition pos = rethrow (onErrorMessages withPosition)

399+ where

400+ withPosition :: ErrorMessage -> ErrorMessage

401+ withPosition (PositionedError _ err) = withPosition err

402+ withPosition err = PositionedError pos err

403+

404+-- |

405+-- Collect errors in in parallel

406+--

407+parU :: (MonadError MultipleErrors m, Functor m) => [a] -> (a -> m b) -> m [b]

408+parU xs f = forM xs (withError . f) >>= collectErrors

409+ where

410+ withError :: (MonadError MultipleErrors m, Functor m) => m a -> m (Either MultipleErrors a)

411+ withError u = catchError (Right <$> u) (return . Left)

412+

413+ collectErrors :: (MonadError MultipleErrors m, Functor m) => [Either MultipleErrors a] -> m [a]

414+ collectErrors es = case lefts es of

415+ [] -> return $ rights es

416+ errs -> throwError $ fold errs

src/Language/PureScript/Kinds.hsnew file+60

@@ -0,0 +1,60 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : Language.PureScript.Kinds

4+-- Copyright : (c) Phil Freeman 2013

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- |

12+--

13+-----------------------------------------------------------------------------

14+

15+{-# LANGUAGE DeriveDataTypeable #-}

16+

17+module Language.PureScript.Kinds where

18+

19+import Data.Data

20+

21+import Control.Monad.Unify (Unknown)

22+

23+-- |

24+-- The data type of kinds

25+--

26+data Kind

27+ -- |

28+ -- Unification variable of type Kind

29+ --

30+ = KUnknown Unknown

31+ -- |

32+ -- The kind of types

33+ --

34+ | Star

35+ -- |

36+ -- The kind of effects

37+ --

38+ | Bang

39+ -- |

40+ -- Kinds for labelled, unordered rows without duplicates

41+ --

42+ | Row Kind

43+ -- |

44+ -- Function kinds

45+ --

46+ | FunKind Kind Kind deriving (Show, Eq, Data, Typeable)

47+

48+everywhereOnKinds :: (Kind -> Kind) -> Kind -> Kind

49+everywhereOnKinds f = go

50+ where

51+ go (Row k1) = f (Row (go k1))

52+ go (FunKind k1 k2) = f (FunKind (go k1) (go k2))

53+ go other = f other

54+

55+everythingOnKinds :: (r -> r -> r) -> (Kind -> r) -> Kind -> r

56+everythingOnKinds (<>) f = go

57+ where

58+ go k@(Row k1) = f k <> go k1

59+ go k@(FunKind k1 k2) = f k <> go k1 <> go k2

60+ go other = f other

src/Language/PureScript/ModuleDependencies.hsnew file+76

@@ -0,0 +1,76 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : Language.PureScript.ModuleDependencies

4+-- Copyright : (c) Phil Freeman 2013

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- | Provides the ability to sort modules based on module dependencies

12+--

13+-----------------------------------------------------------------------------

14+

15+{-# LANGUAGE FlexibleContexts #-}

16+

17+module Language.PureScript.ModuleDependencies (

18+ sortModules,

19+ ModuleGraph

20+) where

21+

22+import Control.Monad.Except

23+

24+import Data.Graph

25+import Data.List (nub)

26+import Data.Maybe (mapMaybe)

27+

28+import Language.PureScript.AST

29+import Language.PureScript.Names

30+import Language.PureScript.Types

31+

32+-- |

33+-- A list of modules with their dependencies

34+--

35+type ModuleGraph = [(ModuleName, [ModuleName])]

36+

37+-- |

38+-- Sort a collection of modules based on module dependencies.

39+--

40+-- Reports an error if the module graph contains a cycle.

41+--

42+sortModules :: (MonadError String m) => [Module] -> m ([Module], ModuleGraph)

43+sortModules ms = do

44+ let verts = map (\m@(Module _ _ ds _) -> (m, getModuleName m, nub (concatMap usedModules ds))) ms

45+ ms' <- mapM toModule $ stronglyConnComp verts

46+ let moduleGraph = map (\(_, mn, deps) -> (mn, deps)) verts

47+ return (ms', moduleGraph)

48+

49+-- |

50+-- Calculate a list of used modules based on explicit imports and qualified names

51+--

52+usedModules :: Declaration -> [ModuleName]

53+usedModules = let (f, _, _, _, _) = everythingOnValues (++) forDecls forValues (const []) (const []) (const []) in nub . f

54+ where

55+ forDecls :: Declaration -> [ModuleName]

56+ forDecls (ImportDeclaration mn _ _) = [mn]

57+ forDecls _ = []

58+

59+ forValues :: Expr -> [ModuleName]

60+ forValues (Var (Qualified (Just mn) _)) = [mn]

61+ forValues (Constructor (Qualified (Just mn) _)) = [mn]

62+ forValues (TypedValue _ _ ty) = forTypes ty

63+ forValues _ = []

64+

65+ forTypes :: Type -> [ModuleName]

66+ forTypes (TypeConstructor (Qualified (Just mn) _)) = [mn]

67+ forTypes (ConstrainedType cs _) = mapMaybe (\(Qualified mn _, _) -> mn) cs

68+ forTypes _ = []

69+

70+-- |

71+-- Convert a strongly connected component of the module graph to a module

72+--

73+toModule :: (MonadError String m) => SCC Module -> m Module

74+toModule (AcyclicSCC m) = return m

75+toModule (CyclicSCC [m]) = return m

76+toModule (CyclicSCC ms) = throwError $ "Cycle in module dependencies: " ++ show (map getModuleName ms)

src/Language/PureScript/Names.hsnew file+85

@@ -0,0 +1,85 @@

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.hsnew file+92

@@ -0,0 +1,92 @@

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.hsnew file+35

@@ -0,0 +1,35 @@

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.hsnew file+134

@@ -0,0 +1,134 @@

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.hsnew file+519

@@ -0,0 +1,519 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : Language.PureScript.Parser.Declarations

4+-- Copyright : (c) Phil Freeman 2013

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- |

12+-- Parsers for module definitions and declarations

13+--

14+-----------------------------------------------------------------------------

15+

16+{-# LANGUAGE TupleSections #-}

17+

18+module Language.PureScript.Parser.Declarations (

19+ parseDeclaration,

20+ parseModule,

21+ parseModules,

22+ parseModulesFromFiles,

23+ parseValue,

24+ parseGuard,

25+ parseBinder,

26+ parseBinderNoParens,

27+) where

28+

29+import Prelude hiding (lex)

30+

31+import Data.Maybe (isJust, fromMaybe)

32+import Data.Traversable (forM)

33+

34+import Control.Applicative

35+import Control.Arrow ((+++))

36+

37+import Language.PureScript.Kinds

38+import Language.PureScript.AST

39+import Language.PureScript.Comments

40+import Language.PureScript.Parser.Common

41+import Language.PureScript.Parser.Types

42+import Language.PureScript.Parser.Kinds

43+import Language.PureScript.Parser.Lexer

44+import Language.PureScript.Names

45+import Language.PureScript.CodeGen.JS.AST

46+import Language.PureScript.Environment

47+

48+import qualified Language.PureScript.Parser.Common as C

49+import qualified Text.Parsec as P

50+import qualified Text.Parsec.Expr as P

51+

52+-- |

53+-- Read source position information

54+--

55+withSourceSpan :: (SourceSpan -> [Comment] -> a -> a) -> P.Parsec [PositionedToken] u a -> P.Parsec [PositionedToken] u a

56+withSourceSpan f p = do

57+ start <- P.getPosition

58+ comments <- C.readComments

59+ x <- p

60+ end <- P.getPosition

61+ let sp = SourceSpan (P.sourceName start) (toSourcePos start) (toSourcePos end)

62+ return $ f sp comments x

63+ where

64+ toSourcePos pos = SourcePos (P.sourceLine pos) (P.sourceColumn pos)

65+

66+kindedIdent :: TokenParser (String, Maybe Kind)

67+kindedIdent = (, Nothing) <$> identifier

68+ <|> parens ((,) <$> identifier <*> (Just <$> (indented *> doubleColon *> indented *> parseKind)))

69+

70+parseDataDeclaration :: TokenParser Declaration

71+parseDataDeclaration = do

72+ dtype <- (reserved "data" *> return Data) <|> (reserved "newtype" *> return Newtype)

73+ name <- indented *> properName

74+ tyArgs <- many (indented *> kindedIdent)

75+ ctors <- P.option [] $ do

76+ indented *> equals

77+ P.sepBy1 ((,) <$> properName <*> P.many (indented *> noWildcards parseTypeAtom)) pipe

78+ return $ DataDeclaration dtype name tyArgs ctors

79+

80+parseTypeDeclaration :: TokenParser Declaration

81+parseTypeDeclaration =

82+ TypeDeclaration <$> P.try (parseIdent <* indented <* doubleColon)

83+ <*> parsePolyType

84+

85+parseTypeSynonymDeclaration :: TokenParser Declaration

86+parseTypeSynonymDeclaration =

87+ TypeSynonymDeclaration <$> (P.try (reserved "type") *> indented *> properName)

88+ <*> many (indented *> kindedIdent)

89+ <*> (indented *> equals *> noWildcards parsePolyType)

90+

91+parseValueDeclaration :: TokenParser Declaration

92+parseValueDeclaration = do

93+ name <- parseIdent

94+ binders <- P.many parseBinderNoParens

95+ value <- Left <$> (C.indented *>

96+ P.many1 ((,) <$> parseGuard

97+ <*> (indented *> equals *> parseValueWithWhereClause)

98+ ))

99+ <|> Right <$> (indented *> equals *> parseValueWithWhereClause)

100+ return $ ValueDeclaration name Value binders value

101+ where

102+ parseValueWithWhereClause :: TokenParser Expr

103+ parseValueWithWhereClause = do

104+ value <- parseValue

105+ whereClause <- P.optionMaybe $ do

106+ C.indented

107+ reserved "where"

108+ C.indented

109+ C.mark $ P.many1 (C.same *> parseLocalDeclaration)

110+ return $ maybe value (`Let` value) whereClause

111+

112+parseExternDeclaration :: TokenParser Declaration

113+parseExternDeclaration = P.try (reserved "foreign") *> indented *> reserved "import" *> indented *>

114+ (ExternDataDeclaration <$> (P.try (reserved "data") *> indented *> properName)

115+ <*> (indented *> doubleColon *> parseKind)

116+ <|> (do reserved "instance"

117+ name <- parseIdent <* indented <* doubleColon

118+ deps <- P.option [] $ do

119+ deps <- parens (commaSep1 ((,) <$> parseQualified properName <*> P.many (noWildcards parseTypeAtom)))

120+ indented

121+ rfatArrow

122+ return deps

123+ className <- indented *> parseQualified properName

124+ tys <- P.many (indented *> noWildcards parseTypeAtom)

125+ return $ ExternInstanceDeclaration name deps className tys)

126+ <|> (do ident <- parseIdent

127+ js <- P.optionMaybe (JSRaw <$> stringLiteral)

128+ ty <- indented *> doubleColon *> noWildcards parsePolyType

129+ return $ ExternDeclaration (if isJust js then InlineJavascript else ForeignImport) ident js ty))

130+

131+parseAssociativity :: TokenParser Associativity

132+parseAssociativity =

133+ (P.try (reserved "infixl") >> return Infixl) <|>

134+ (P.try (reserved "infixr") >> return Infixr) <|>

135+ (P.try (reserved "infix") >> return Infix)

136+

137+parseFixity :: TokenParser Fixity

138+parseFixity = Fixity <$> parseAssociativity <*> (indented *> natural)

139+

140+parseFixityDeclaration :: TokenParser Declaration

141+parseFixityDeclaration = do

142+ fixity <- parseFixity

143+ indented

144+ name <- symbol

145+ return $ FixityDeclaration fixity name

146+

147+parseImportDeclaration :: TokenParser Declaration

148+parseImportDeclaration = do

149+ reserved "import"

150+ indented

151+ qualImport <|> stdImport

152+ where

153+ stdImport = do

154+ moduleName' <- moduleName

155+ stdImportHiding moduleName' <|> stdImportQualifying moduleName'

156+ where

157+ stdImportHiding mn = do

158+ reserved "hiding"

159+ declType <- importDeclarationType Hiding

160+ return $ ImportDeclaration mn declType Nothing

161+ stdImportQualifying mn = do

162+ declType <- importDeclarationType Qualifying

163+ return $ ImportDeclaration mn declType Nothing

164+ qualImport = do

165+ reserved "qualified"

166+ indented

167+ moduleName' <- moduleName

168+ declType <- importDeclarationType Qualifying

169+ reserved "as"

170+ asQ <- moduleName

171+ return $ ImportDeclaration moduleName' declType (Just asQ)

172+ importDeclarationType expectedType = do

173+ idents <- P.optionMaybe $ indented *> (parens $ commaSep parseDeclarationRef)

174+ return $ fromMaybe Unqualified (expectedType <$> idents)

175+

176+

177+parseDeclarationRef :: TokenParser DeclarationRef

178+parseDeclarationRef = withSourceSpan PositionedDeclarationRef $

179+ ValueRef <$> parseIdent

180+ <|> do name <- properName

181+ dctors <- P.optionMaybe $ parens (symbol' ".." *> pure Nothing <|> Just <$> commaSep properName)

182+ return $ maybe (TypeClassRef name) (TypeRef name) dctors

183+

184+parseTypeClassDeclaration :: TokenParser Declaration

185+parseTypeClassDeclaration = do

186+ reserved "class"

187+ implies <- P.option [] $ do

188+ indented

189+ implies <- parens (commaSep1 ((,) <$> parseQualified properName <*> P.many (noWildcards parseTypeAtom)))

190+ lfatArrow

191+ return implies

192+ className <- indented *> properName

193+ idents <- P.many (indented *> kindedIdent)

194+ members <- P.option [] . P.try $ do

195+ indented *> reserved "where"

196+ mark (P.many (same *> positioned parseTypeDeclaration))

197+ return $ TypeClassDeclaration className idents implies members

198+

199+parseTypeInstanceDeclaration :: TokenParser Declaration

200+parseTypeInstanceDeclaration = do

201+ reserved "instance"

202+ name <- parseIdent <* indented <* doubleColon

203+ deps <- P.optionMaybe $ do

204+ deps <- parens (commaSep1 ((,) <$> parseQualified properName <*> P.many (noWildcards parseTypeAtom)))

205+ indented

206+ rfatArrow

207+ return deps

208+ className <- indented *> parseQualified properName

209+ ty <- P.many (indented *> (noWildcards parseTypeAtom))

210+ members <- P.option [] . P.try $ do

211+ indented *> reserved "where"

212+ mark (P.many (same *> positioned parseValueDeclaration))

213+ return $ TypeInstanceDeclaration name (fromMaybe [] deps) className ty members

214+

215+positioned :: TokenParser Declaration -> TokenParser Declaration

216+positioned d = withSourceSpan PositionedDeclaration d

217+

218+-- |

219+-- Parse a single declaration

220+--

221+parseDeclaration :: TokenParser Declaration

222+parseDeclaration = positioned (P.choice

223+ [ parseDataDeclaration

224+ , parseTypeDeclaration

225+ , parseTypeSynonymDeclaration

226+ , parseValueDeclaration

227+ , parseExternDeclaration

228+ , parseFixityDeclaration

229+ , parseImportDeclaration

230+ , parseTypeClassDeclaration

231+ , parseTypeInstanceDeclaration

232+ ]) P.<?> "declaration"

233+

234+parseLocalDeclaration :: TokenParser Declaration

235+parseLocalDeclaration = positioned (P.choice

236+ [ parseTypeDeclaration

237+ , parseValueDeclaration

238+ ] P.<?> "local declaration")

239+

240+-- |

241+-- Parse a module header and a collection of declarations

242+--

243+parseModule :: TokenParser Module

244+parseModule = do

245+ comments <- C.readComments

246+ reserved "module"

247+ indented

248+ name <- moduleName

249+ exports <- P.optionMaybe $ parens $ commaSep1 parseDeclarationRef

250+ reserved "where"

251+ decls <- mark (P.many (same *> parseDeclaration))

252+ return $ Module comments name decls exports

253+

254+-- |

255+-- Parse a collection of modules

256+--

257+parseModulesFromFiles :: (k -> String) -> [(k, String)] -> Either P.ParseError [(k, Module)]

258+parseModulesFromFiles toFilePath input =

259+ fmap collect . forM input $ \(k, content) -> do

260+ let filename = toFilePath k

261+ ts <- lex filename content

262+ ms <- runTokenParser filename parseModules ts

263+ return (k, ms)

264+ where

265+ collect :: [(k, [v])] -> [(k, v)]

266+ collect vss = [ (k, v) | (k, vs) <- vss, v <- vs ]

267+

268+-- |

269+-- Parse a collection of modules

270+--

271+parseModules :: TokenParser [Module]

272+parseModules = mark (P.many (same *> parseModule)) <* P.eof

273+

274+booleanLiteral :: TokenParser Bool

275+booleanLiteral = (reserved "true" >> return True) P.<|> (reserved "false" >> return False)

276+

277+parseNumericLiteral :: TokenParser Expr

278+parseNumericLiteral = NumericLiteral <$> number

279+

280+parseStringLiteral :: TokenParser Expr

281+parseStringLiteral = StringLiteral <$> stringLiteral

282+

283+parseBooleanLiteral :: TokenParser Expr

284+parseBooleanLiteral = BooleanLiteral <$> booleanLiteral

285+

286+parseArrayLiteral :: TokenParser Expr

287+parseArrayLiteral = ArrayLiteral <$> squares (commaSep parseValue)

288+

289+parseObjectLiteral :: TokenParser Expr

290+parseObjectLiteral = ObjectConstructor <$> braces (commaSep parseIdentifierAndValue)

291+

292+parseIdentifierAndValue :: TokenParser (String, Maybe Expr)

293+parseIdentifierAndValue = (,) <$> (C.indented *> (lname <|> stringLiteral) <* C.indented <* colon)

294+ <*> (C.indented *> val)

295+ where

296+ val = (Just <$> parseValue) <|> (underscore *> pure Nothing)

297+

298+parseAbs :: TokenParser Expr

299+parseAbs = do

300+ symbol' "\\"

301+ args <- P.many1 (C.indented *> (Abs <$> (Left <$> P.try C.parseIdent <|> Right <$> parseBinderNoParens)))

302+ C.indented *> rarrow

303+ value <- parseValue

304+ return $ toFunction args value

305+ where

306+ toFunction :: [Expr -> Expr] -> Expr -> Expr

307+ toFunction args value = foldr ($) value args

308+

309+parseVar :: TokenParser Expr

310+parseVar = Var <$> C.parseQualified C.parseIdent

311+

312+parseConstructor :: TokenParser Expr

313+parseConstructor = Constructor <$> C.parseQualified C.properName

314+

315+parseCase :: TokenParser Expr

316+parseCase = Case <$> P.between (P.try (reserved "case")) (C.indented *> reserved "of") (return <$> parseValue)

317+ <*> (C.indented *> C.mark (P.many (C.same *> C.mark parseCaseAlternative)))

318+

319+parseCaseAlternative :: TokenParser CaseAlternative

320+parseCaseAlternative = CaseAlternative <$> (return <$> parseBinder)

321+ <*> (Left <$> (C.indented *>

322+ P.many1 ((,) <$> parseGuard

323+ <*> (indented *> rarrow *> parseValue)

324+ ))

325+ <|> Right <$> (indented *> rarrow *> parseValue))

326+ P.<?> "case alternative"

327+

328+parseIfThenElse :: TokenParser Expr

329+parseIfThenElse = IfThenElse <$> (P.try (reserved "if") *> C.indented *> parseValue)

330+ <*> (C.indented *> reserved "then" *> C.indented *> parseValue)

331+ <*> (C.indented *> reserved "else" *> C.indented *> parseValue)

332+

333+parseLet :: TokenParser Expr

334+parseLet = do

335+ reserved "let"

336+ C.indented

337+ ds <- C.mark $ P.many1 (C.same *> parseLocalDeclaration)

338+ C.indented

339+ reserved "in"

340+ result <- parseValue

341+ return $ Let ds result

342+

343+parseValueAtom :: TokenParser Expr

344+parseValueAtom = P.choice

345+ [ P.try parseNumericLiteral

346+ , P.try parseStringLiteral

347+ , P.try parseBooleanLiteral

348+ , parseArrayLiteral

349+ , P.try parseObjectLiteral

350+ , P.try parseObjectGetter

351+ , parseAbs

352+ , P.try parseConstructor

353+ , P.try parseVar

354+ , parseCase

355+ , parseIfThenElse

356+ , parseDo

357+ , parseLet

358+ , P.try $ Parens <$> parens parseValue

359+ , parseOperatorSection

360+ , P.try parseObjectUpdaterWildcard ]

361+

362+-- |

363+-- Parse an expression in backticks or an operator

364+--

365+parseInfixExpr :: TokenParser Expr

366+parseInfixExpr = P.between tick tick parseValue

367+ <|> Var <$> parseQualified (Op <$> symbol)

368+

369+parseOperatorSection :: TokenParser Expr

370+parseOperatorSection = parens $ left <|> right

371+ where

372+ right = OperatorSection <$> parseInfixExpr <* indented <*> (Right <$> parseValueAtom)

373+ left = flip OperatorSection <$> (Left <$> parseValueAtom) <* indented <*> parseInfixExpr

374+

375+parsePropertyUpdate :: TokenParser (String, Maybe Expr)

376+parsePropertyUpdate = do

377+ name <- lname <|> stringLiteral

378+ _ <- C.indented *> equals

379+ value <- C.indented *> (underscore *> pure Nothing) <|> (Just <$> parseValue)

380+ return (name, value)

381+

382+parseAccessor :: Expr -> TokenParser Expr

383+parseAccessor (Constructor _) = P.unexpected "constructor"

384+parseAccessor obj = P.try $ Accessor <$> (C.indented *> dot *> C.indented *> (lname <|> stringLiteral)) <*> pure obj

385+

386+parseDo :: TokenParser Expr

387+parseDo = do

388+ reserved "do"

389+ C.indented

390+ Do <$> C.mark (P.many (C.same *> C.mark parseDoNotationElement))

391+

392+parseDoNotationLet :: TokenParser DoNotationElement

393+parseDoNotationLet = DoNotationLet <$> (reserved "let" *> C.indented *> C.mark (P.many1 (C.same *> parseLocalDeclaration)))

394+

395+parseDoNotationBind :: TokenParser DoNotationElement

396+parseDoNotationBind = DoNotationBind <$> parseBinder <*> (C.indented *> larrow *> parseValue)

397+

398+parseDoNotationElement :: TokenParser DoNotationElement

399+parseDoNotationElement = P.choice

400+ [ P.try parseDoNotationBind

401+ , parseDoNotationLet

402+ , P.try (DoNotationValue <$> parseValue) ]

403+

404+parseObjectGetter :: TokenParser Expr

405+parseObjectGetter = ObjectGetter <$> (underscore *> C.indented *> dot *> C.indented *> (lname <|> stringLiteral))

406+

407+-- |

408+-- Parse a value

409+--

410+parseValue :: TokenParser Expr

411+parseValue = withSourceSpan PositionedValue

412+ (P.buildExpressionParser operators

413+ . C.buildPostfixParser postfixTable2

414+ $ indexersAndAccessors) P.<?> "expression"

415+ where

416+ indexersAndAccessors = C.buildPostfixParser postfixTable1 parseValueAtom

417+ postfixTable1 = [ parseAccessor

418+ , P.try . parseUpdaterBody . Just ]

419+ postfixTable2 = [ \v -> P.try (flip App <$> (C.indented *> indexersAndAccessors)) <*> pure v

420+ , \v -> flip (TypedValue True) <$> (P.try (C.indented *> doubleColon) *> parsePolyType) <*> pure v

421+ ]

422+ operators = [ [ P.Prefix (P.try (C.indented *> symbol' "-") >> return UnaryMinus)

423+ ]

424+ , [ P.Infix (P.try (C.indented *> parseInfixExpr P.<?> "infix expression") >>= \ident ->

425+ return (BinaryNoParens ident)) P.AssocRight

426+ ]

427+ ]

428+

429+parseUpdaterBody :: Maybe Expr -> TokenParser Expr

430+parseUpdaterBody v = ObjectUpdater v <$> (C.indented *> braces (commaSep1 (C.indented *> parsePropertyUpdate)))

431+

432+parseObjectUpdaterWildcard :: TokenParser Expr

433+parseObjectUpdaterWildcard = underscore *> C.indented *> parseUpdaterBody Nothing

434+

435+parseStringBinder :: TokenParser Binder

436+parseStringBinder = StringBinder <$> stringLiteral

437+

438+parseBooleanBinder :: TokenParser Binder

439+parseBooleanBinder = BooleanBinder <$> booleanLiteral

440+

441+parseNumberBinder :: TokenParser Binder

442+parseNumberBinder = NumberBinder <$> (sign <*> number)

443+ where

444+ sign :: TokenParser (Either Integer Double -> Either Integer Double)

445+ sign = (symbol' "-" >> return (negate +++ negate))

446+ <|> (symbol' "+" >> return id)

447+ <|> return id

448+

449+parseVarBinder :: TokenParser Binder

450+parseVarBinder = VarBinder <$> C.parseIdent

451+

452+parseNullaryConstructorBinder :: TokenParser Binder

453+parseNullaryConstructorBinder = ConstructorBinder <$> C.parseQualified C.properName <*> pure []

454+

455+parseConstructorBinder :: TokenParser Binder

456+parseConstructorBinder = ConstructorBinder <$> C.parseQualified C.properName <*> many (C.indented *> parseBinderNoParens)

457+

458+parseObjectBinder :: TokenParser Binder

459+parseObjectBinder = ObjectBinder <$> braces (commaSep (C.indented *> parseIdentifierAndBinder))

460+

461+parseArrayBinder :: TokenParser Binder

462+parseArrayBinder = squares $ ArrayBinder <$> commaSep (C.indented *> parseBinder)

463+

464+parseNamedBinder :: TokenParser Binder

465+parseNamedBinder = NamedBinder <$> (C.parseIdent <* C.indented <* at)

466+ <*> (C.indented *> parseBinder)

467+

468+parseNullBinder :: TokenParser Binder

469+parseNullBinder = underscore *> return NullBinder

470+

471+parseIdentifierAndBinder :: TokenParser (String, Binder)

472+parseIdentifierAndBinder = do

473+ name <- lname <|> stringLiteral

474+ C.indented *> (equals <|> colon)

475+ binder <- C.indented *> parseBinder

476+ return (name, binder)

477+

478+-- |

479+-- Parse a binder

480+--

481+parseBinder :: TokenParser Binder

482+parseBinder = withSourceSpan PositionedBinder (P.buildExpressionParser operators parseBinderAtom P.<?> "expression")

483+ where

484+ operators = [ [ P.Infix (P.try $ C.indented *> colon *> return ConsBinder) P.AssocRight ] ]

485+ parseBinderAtom :: TokenParser Binder

486+ parseBinderAtom = P.choice (map P.try

487+ [ parseNullBinder

488+ , parseStringBinder

489+ , parseBooleanBinder

490+ , parseNumberBinder

491+ , parseNamedBinder

492+ , parseVarBinder

493+ , parseConstructorBinder

494+ , parseObjectBinder

495+ , parseArrayBinder

496+ , parens parseBinder ]) P.<?> "binder"

497+

498+-- |

499+-- Parse a binder as it would appear in a top level declaration

500+--

501+parseBinderNoParens :: TokenParser Binder

502+parseBinderNoParens = P.choice (map P.try

503+ [ parseNullBinder

504+ , parseStringBinder

505+ , parseBooleanBinder

506+ , parseNumberBinder

507+ , parseNamedBinder

508+ , parseVarBinder

509+ , parseNullaryConstructorBinder

510+ , parseObjectBinder

511+ , parseArrayBinder

512+ , parens parseBinder ]) P.<?> "binder"

513+-- |

514+-- Parse a guard

515+--

516+parseGuard :: TokenParser Guard

517+parseGuard = pipe *> C.indented *> parseValue

518+

519+

src/Language/PureScript/Parser/Kinds.hsnew file+45

@@ -0,0 +1,45 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : Language.PureScript.Parser.Kinds

4+-- Copyright : (c) Phil Freeman 2013

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- |

12+-- A parser for kinds

13+--

14+-----------------------------------------------------------------------------

15+

16+module Language.PureScript.Parser.Kinds (

17+ parseKind

18+) where

19+

20+import Language.PureScript.Kinds

21+import Language.PureScript.Parser.Common

22+import Language.PureScript.Parser.Lexer

23+import Control.Applicative

24+import qualified Text.Parsec as P

25+import qualified Text.Parsec.Expr as P

26+

27+parseStar :: TokenParser Kind

28+parseStar = const Star <$> symbol' "*"

29+

30+parseBang :: TokenParser Kind

31+parseBang = const Bang <$> symbol' "!"

32+

33+parseTypeAtom :: TokenParser Kind

34+parseTypeAtom = indented *> P.choice (map P.try

35+ [ parseStar

36+ , parseBang

37+ , parens parseKind ])

38+-- |

39+-- Parse a kind

40+--

41+parseKind :: TokenParser Kind

42+parseKind = P.buildExpressionParser operators parseTypeAtom P.<?> "kind"

43+ where

44+ operators = [ [ P.Prefix (symbol' "#" >> return Row) ]

45+ , [ P.Infix ((P.try rarrow) >> return FunKind) P.AssocRight ] ]

src/Language/PureScript/Parser/Lexer.hsnew file+499

@@ -0,0 +1,499 @@

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.hsnew file+30

@@ -0,0 +1,30 @@

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.hsnew file+134

@@ -0,0 +1,134 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : Language.PureScript.Parser.Types

4+-- Copyright : (c) Phil Freeman 2013

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- |

12+-- Parsers for types

13+--

14+-----------------------------------------------------------------------------

15+

16+module Language.PureScript.Parser.Types (

17+ parseType,

18+ parsePolyType,

19+ noWildcards,

20+ parseTypeAtom

21+) where

22+

23+import Control.Applicative

24+import Control.Monad (when, unless)

25+

26+import Language.PureScript.Types

27+import Language.PureScript.Parser.Common

28+import Language.PureScript.Parser.Kinds

29+import Language.PureScript.Parser.Lexer

30+import Language.PureScript.Environment

31+

32+import qualified Text.Parsec as P

33+import qualified Text.Parsec.Expr as P

34+

35+parseArray :: TokenParser Type

36+parseArray = squares $ return tyArray

37+

38+parseArrayOf :: TokenParser Type

39+parseArrayOf = squares $ TypeApp tyArray <$> parseType

40+

41+parseFunction :: TokenParser Type

42+parseFunction = parens $ rarrow >> return tyFunction

43+

44+parseObject :: TokenParser Type

45+parseObject = braces $ TypeApp tyObject <$> parseRow

46+

47+parseTypeWildcard :: TokenParser Type

48+parseTypeWildcard = underscore >> return TypeWildcard

49+

50+parseTypeVariable :: TokenParser Type

51+parseTypeVariable = do

52+ ident <- identifier

53+ when (ident `elem` reservedTypeNames) $ P.unexpected ident

54+ return $ TypeVar ident

55+

56+parseTypeConstructor :: TokenParser Type

57+parseTypeConstructor = TypeConstructor <$> parseQualified properName

58+

59+parseForAll :: TokenParser Type

60+parseForAll = mkForAll <$> (P.try (reserved "forall") *> P.many1 (indented *> identifier) <* indented <* dot)

61+ <*> parseConstrainedType

62+

63+-- |

64+-- Parse a type as it appears in e.g. a data constructor

65+--

66+parseTypeAtom :: TokenParser Type

67+parseTypeAtom = indented *> P.choice (map P.try

68+ [ parseArray

69+ , parseArrayOf

70+ , parseFunction

71+ , parseObject

72+ , parseTypeWildcard

73+ , parseTypeVariable

74+ , parseTypeConstructor

75+ , parseForAll

76+ , parens parseRow

77+ , parens parsePolyType ])

78+

79+parseConstrainedType :: TokenParser Type

80+parseConstrainedType = do

81+ constraints <- P.optionMaybe . P.try $ do

82+ constraints <- parens . commaSep1 $ do

83+ className <- parseQualified properName

84+ indented

85+ ty <- P.many parseTypeAtom

86+ return (className, ty)

87+ _ <- rfatArrow

88+ return constraints

89+ indented

90+ ty <- parseType

91+ return $ maybe ty (flip ConstrainedType ty) constraints

92+

93+parseAnyType :: TokenParser Type

94+parseAnyType = P.buildExpressionParser operators (buildPostfixParser postfixTable parseTypeAtom) P.<?> "type"

95+ where

96+ operators = [ [ P.Infix (return TypeApp) P.AssocLeft ]

97+ , [ P.Infix (rarrow >> return function) P.AssocRight ] ]

98+ postfixTable = [ \t -> KindedType t <$> (P.try (indented *> doubleColon) *> parseKind)

99+ ]

100+

101+-- |

102+-- Parse a monotype

103+--

104+parseType :: TokenParser Type

105+parseType = do

106+ ty <- parseAnyType

107+ unless (isMonoType ty) $ P.unexpected "polymorphic type"

108+ return ty

109+

110+-- |

111+-- Parse a polytype

112+--

113+parsePolyType :: TokenParser Type

114+parsePolyType = parseAnyType

115+

116+-- |

117+-- Parse an atomic type with no wildcards

118+--

119+noWildcards :: TokenParser Type -> TokenParser Type

120+noWildcards p = do

121+ ty <- p

122+ when (containsWildcards ty) $ P.unexpected "type wildcard"

123+ return ty

124+

125+parseNameAndType :: TokenParser t -> TokenParser (String, t)

126+parseNameAndType p = (,) <$> (indented *> (lname <|> stringLiteral) <* indented <* doubleColon) <*> p

127+

128+parseRowEnding :: TokenParser Type

129+parseRowEnding = P.option REmpty $ indented *> pipe *> indented *> P.choice (map P.try

130+ [ parseTypeWildcard

131+ , TypeVar <$> identifier ])

132+

133+parseRow :: TokenParser Type

134+parseRow = (curry rowFromList <$> commaSep (parseNameAndType parsePolyType) <*> parseRowEnding) P.<?> "row"

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

@@ -0,0 +1,32 @@

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.hsnew file+69

@@ -0,0 +1,69 @@

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.hsnew file+301

@@ -0,0 +1,301 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : Language.PureScript.Pretty.JS

4+-- Copyright : (c) Phil Freeman 2013

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- |

12+-- Pretty printer for the Javascript AST

13+--

14+-----------------------------------------------------------------------------

15+

16+module Language.PureScript.Pretty.JS (

17+ prettyPrintJS

18+) where

19+

20+import Data.List

21+import Data.Maybe (fromMaybe)

22+

23+import Control.Applicative

24+import Control.Arrow ((<+>))

25+import Control.Monad.State

26+import Control.PatternArrows

27+import qualified Control.Arrow as A

28+

29+import Language.PureScript.CodeGen.JS.AST

30+import Language.PureScript.CodeGen.JS.Common

31+import Language.PureScript.Pretty.Common

32+import Language.PureScript.Comments

33+

34+import Numeric

35+

36+literals :: Pattern PrinterState JS String

37+literals = mkPattern' match

38+ where

39+ match :: JS -> StateT PrinterState Maybe String

40+ match (JSNumericLiteral n) = return $ either show show n

41+ match (JSStringLiteral s) = return $ string s

42+ match (JSBooleanLiteral True) = return "true"

43+ match (JSBooleanLiteral False) = return "false"

44+ match (JSArrayLiteral xs) = fmap concat $ sequence

45+ [ return "[ "

46+ , fmap (intercalate ", ") $ forM xs prettyPrintJS'

47+ , return " ]"

48+ ]

49+ match (JSObjectLiteral []) = return "{}"

50+ match (JSObjectLiteral ps) = fmap concat $ sequence

51+ [ return "{\n"

52+ , withIndent $ do

53+ jss <- forM ps $ \(key, value) -> fmap ((objectPropertyToString key ++ ": ") ++) . prettyPrintJS' $ value

54+ indentString <- currentIndent

55+ return $ intercalate ", \n" $ map (indentString ++) jss

56+ , return "\n"

57+ , currentIndent

58+ , return "}"

59+ ]

60+ where

61+ objectPropertyToString :: String -> String

62+ objectPropertyToString s | identNeedsEscaping s = show s

63+ | otherwise = s

64+ match (JSBlock sts) = fmap concat $ sequence

65+ [ return "{\n"

66+ , withIndent $ prettyStatements sts

67+ , return "\n"

68+ , currentIndent

69+ , return "}"

70+ ]

71+ match (JSVar ident) = return ident

72+ match (JSVariableIntroduction ident value) = fmap concat $ sequence

73+ [ return "var "

74+ , return ident

75+ , maybe (return "") (fmap (" = " ++) . prettyPrintJS') value

76+ ]

77+ match (JSAssignment target value) = fmap concat $ sequence

78+ [ prettyPrintJS' target

79+ , return " = "

80+ , prettyPrintJS' value

81+ ]

82+ match (JSWhile cond sts) = fmap concat $ sequence

83+ [ return "while ("

84+ , prettyPrintJS' cond

85+ , return ") "

86+ , prettyPrintJS' sts

87+ ]

88+ match (JSFor ident start end sts) = fmap concat $ sequence

89+ [ return $ "for (var " ++ ident ++ " = "

90+ , prettyPrintJS' start

91+ , return $ "; " ++ ident ++ " < "

92+ , prettyPrintJS' end

93+ , return $ "; " ++ ident ++ "++) "

94+ , prettyPrintJS' sts

95+ ]

96+ match (JSForIn ident obj sts) = fmap concat $ sequence

97+ [ return $ "for (var " ++ ident ++ " in "

98+ , prettyPrintJS' obj

99+ , return ") "

100+ , prettyPrintJS' sts

101+ ]

102+ match (JSIfElse cond thens elses) = fmap concat $ sequence

103+ [ return "if ("

104+ , prettyPrintJS' cond

105+ , return ") "

106+ , prettyPrintJS' thens

107+ , maybe (return "") (fmap (" else " ++) . prettyPrintJS') elses

108+ ]

109+ match (JSReturn value) = fmap concat $ sequence

110+ [ return "return "

111+ , prettyPrintJS' value

112+ ]

113+ match (JSThrow value) = fmap concat $ sequence

114+ [ return "throw "

115+ , prettyPrintJS' value

116+ ]

117+ match (JSBreak lbl) = return $ "break " ++ lbl

118+ match (JSContinue lbl) = return $ "continue " ++ lbl

119+ match (JSLabel lbl js) = fmap concat $ sequence

120+ [ return $ lbl ++ ": "

121+ , prettyPrintJS' js

122+ ]

123+ match (JSComment com js) = fmap concat $ sequence $

124+ [ return "\n"

125+ , currentIndent

126+ , return "/**\n"

127+ ] ++

128+ map asLine (concatMap commentLines com) ++

129+ [ currentIndent

130+ , return " */\n"

131+ , currentIndent

132+ , prettyPrintJS' js

133+ ]

134+ where

135+ commentLines :: Comment -> [String]

136+ commentLines (LineComment s) = [s]

137+ commentLines (BlockComment s) = lines s

138+

139+ asLine :: String -> StateT PrinterState Maybe String

140+ asLine s = do

141+ i <- currentIndent

142+ return $ i ++ " * " ++ removeComments s ++ "\n"

143+

144+ removeComments :: String -> String

145+ removeComments ('*' : '/' : s) = removeComments s

146+ removeComments (c : s) = c : removeComments s

147+

148+ removeComments [] = []

149+ match (JSRaw js) = return js

150+ match _ = mzero

151+

152+string :: String -> String

153+string s = '"' : concatMap encodeChar s ++ "\""

154+ where

155+ encodeChar :: Char -> String

156+ encodeChar '\b' = "\\b"

157+ encodeChar '\t' = "\\t"

158+ encodeChar '\n' = "\\n"

159+ encodeChar '\v' = "\\v"

160+ encodeChar '\f' = "\\f"

161+ encodeChar '\r' = "\\r"

162+ encodeChar '"' = "\\\""

163+ encodeChar '\\' = "\\\\"

164+ encodeChar c | fromEnum c > 0xFFF = "\\u" ++ showHex (fromEnum c) ""

165+ encodeChar c | fromEnum c > 0xFF = "\\u0" ++ showHex (fromEnum c) ""

166+ encodeChar c = [c]

167+

168+conditional :: Pattern PrinterState JS ((JS, JS), JS)

169+conditional = mkPattern match

170+ where

171+ match (JSConditional cond th el) = Just ((th, el), cond)

172+ match _ = Nothing

173+

174+accessor :: Pattern PrinterState JS (String, JS)

175+accessor = mkPattern match

176+ where

177+ match (JSAccessor prop val) = Just (prop, val)

178+ match _ = Nothing

179+

180+indexer :: Pattern PrinterState JS (String, JS)

181+indexer = mkPattern' match

182+ where

183+ match (JSIndexer index val) = (,) <$> prettyPrintJS' index <*> pure val

184+ match _ = mzero

185+

186+lam :: Pattern PrinterState JS ((Maybe String, [String]), JS)

187+lam = mkPattern match

188+ where

189+ match (JSFunction name args ret) = Just ((name, args), ret)

190+ match _ = Nothing

191+

192+app :: Pattern PrinterState JS (String, JS)

193+app = mkPattern' match

194+ where

195+ match (JSApp val args) = do

196+ jss <- mapM prettyPrintJS' args

197+ return (intercalate ", " jss, val)

198+ match _ = mzero

199+

200+typeOf :: Pattern PrinterState JS ((), JS)

201+typeOf = mkPattern match

202+ where

203+ match (JSTypeOf val) = Just ((), val)

204+ match _ = Nothing

205+

206+instanceOf :: Pattern PrinterState JS (JS, JS)

207+instanceOf = mkPattern match

208+ where

209+ match (JSInstanceOf val ty) = Just (val, ty)

210+ match _ = Nothing

211+

212+unary' :: UnaryOperator -> (JS -> String) -> Operator PrinterState JS String

213+unary' op mkStr = Wrap match (++)

214+ where

215+ match :: Pattern PrinterState JS (String, JS)

216+ match = mkPattern match'

217+ where

218+ match' (JSUnary op' val) | op' == op = Just (mkStr val, val)

219+ match' _ = Nothing

220+

221+unary :: UnaryOperator -> String -> Operator PrinterState JS String

222+unary op str = unary' op (const str)

223+

224+negateOperator :: Operator PrinterState JS String

225+negateOperator = unary' Negate (\v -> if isNegate v then "- " else "-")

226+ where

227+ isNegate (JSUnary Negate _) = True

228+ isNegate _ = False

229+

230+binary :: BinaryOperator -> String -> Operator PrinterState JS String

231+binary op str = AssocL match (\v1 v2 -> v1 ++ " " ++ str ++ " " ++ v2)

232+ where

233+ match :: Pattern PrinterState JS (JS, JS)

234+ match = mkPattern match'

235+ where

236+ match' (JSBinary op' v1 v2) | op' == op = Just (v1, v2)

237+ match' _ = Nothing

238+

239+prettyStatements :: [JS] -> StateT PrinterState Maybe String

240+prettyStatements sts = do

241+ jss <- forM sts prettyPrintJS'

242+ indentString <- currentIndent

243+ return $ intercalate "\n" $ map ((++ ";") . (indentString ++)) jss

244+

245+-- |

246+-- Generate a pretty-printed string representing a Javascript expression

247+--

248+prettyPrintJS1 :: JS -> String

249+prettyPrintJS1 = fromMaybe (error "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyPrintJS'

250+

251+-- |

252+-- Generate a pretty-printed string representing a collection of Javascript expressions at the same indentation level

253+--

254+prettyPrintJS :: [JS] -> String

255+prettyPrintJS = fromMaybe (error "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyStatements

256+

257+-- |

258+-- Generate an indented, pretty-printed string representing a Javascript expression

259+--

260+prettyPrintJS' :: JS -> StateT PrinterState Maybe String

261+prettyPrintJS' = A.runKleisli $ runPattern matchValue

262+ where

263+ matchValue :: Pattern PrinterState JS String

264+ matchValue = buildPrettyPrinter operators (literals <+> fmap parens matchValue)

265+ operators :: OperatorTable PrinterState JS String

266+ operators =

267+ OperatorTable [ [ Wrap accessor $ \prop val -> val ++ "." ++ prop ]

268+ , [ Wrap indexer $ \index val -> val ++ "[" ++ index ++ "]" ]

269+ , [ Wrap app $ \args val -> val ++ "(" ++ args ++ ")" ]

270+ , [ unary JSNew "new " ]

271+ , [ Wrap lam $ \(name, args) ret -> "function "

272+ ++ fromMaybe "" name

273+ ++ "(" ++ intercalate ", " args ++ ") "

274+ ++ ret ]

275+ , [ binary LessThan "<" ]

276+ , [ binary LessThanOrEqualTo "<=" ]

277+ , [ binary GreaterThan ">" ]

278+ , [ binary GreaterThanOrEqualTo ">=" ]

279+ , [ Wrap typeOf $ \_ s -> "typeof " ++ s ]

280+ , [ AssocR instanceOf $ \v1 v2 -> v1 ++ " instanceof " ++ v2 ]

281+ , [ unary Not "!" ]

282+ , [ unary BitwiseNot "~" ]

283+ , [ negateOperator ]

284+ , [ unary Positive "+" ]

285+ , [ binary Multiply "*"

286+ , binary Divide "/"

287+ , binary Modulus "%" ]

288+ , [ binary Add "+"

289+ , binary Subtract "-" ]

290+ , [ binary ShiftLeft "<<" ]

291+ , [ binary ShiftRight ">>" ]

292+ , [ binary ZeroFillShiftRight ">>>" ]

293+ , [ binary EqualTo "===" ]

294+ , [ binary NotEqualTo "!==" ]

295+ , [ binary BitwiseAnd "&" ]

296+ , [ binary BitwiseXor "^" ]

297+ , [ binary BitwiseOr "|" ]

298+ , [ binary And "&&" ]

299+ , [ binary Or "||" ]

300+ , [ Wrap conditional $ \(th, el) cond -> cond ++ " ? " ++ prettyPrintJS1 th ++ " : " ++ prettyPrintJS1 el ]

301+ ]

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

@@ -0,0 +1,59 @@

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.hsnew file+129

@@ -0,0 +1,129 @@

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.hsnew file+250

@@ -0,0 +1,250 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : Language.PureScript.Pretty.Values

4+-- Copyright : Kinds.hs(c) Phil Freeman 2013

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- |

12+-- Pretty printer for values

13+--

14+-----------------------------------------------------------------------------

15+

16+module Language.PureScript.Pretty.Values (

17+ prettyPrintValue,

18+ prettyPrintBinder

19+) where

20+

21+import Data.Maybe (fromMaybe)

22+import Data.List (intercalate)

23+

24+import Control.Arrow ((<+>), runKleisli, second)

25+import Control.PatternArrows

26+import Control.Monad.State

27+import Control.Applicative

28+

29+import Language.PureScript.AST

30+import Language.PureScript.Names

31+import Language.PureScript.Pretty.Common

32+import Language.PureScript.Pretty.Types (prettyPrintType)

33+

34+literals :: Pattern PrinterState Expr String

35+literals = mkPattern' match

36+ where

37+ match :: Expr -> StateT PrinterState Maybe String

38+ match (NumericLiteral n) = return $ either show show n

39+ match (StringLiteral s) = return $ show s

40+ match (BooleanLiteral True) = return "true"

41+ match (BooleanLiteral False) = return "false"

42+ match (ArrayLiteral xs) = concat <$> sequence

43+ [ return "[ "

44+ , withIndent $ prettyPrintMany prettyPrintValue' xs

45+ , return " ]"

46+ ]

47+ match (ObjectLiteral ps) = prettyPrintObject' $ second Just `map` ps

48+ match (ObjectConstructor ps) = prettyPrintObject' ps

49+ match (ObjectGetter prop) = return $ "(." ++ prop ++ ")"

50+ match (TypeClassDictionaryConstructorApp className ps) = concat <$> sequence

51+ [ return (show className ++ "(\n")

52+ , match ps

53+ , return ")"

54+ ]

55+ match (Constructor name) = return $ show name

56+ match (Case values binders) = concat <$> sequence

57+ [ return "case "

58+ , unwords <$> forM values prettyPrintValue'

59+ , return " of\n"

60+ , withIndent $ prettyPrintMany prettyPrintCaseAlternative binders

61+ , currentIndent

62+ ]

63+ match (Let ds val) = concat <$> sequence

64+ [ return "let\n"

65+ , withIndent $ prettyPrintMany prettyPrintDeclaration ds

66+ , return "\n"

67+ , currentIndent

68+ , return "in "

69+ , prettyPrintValue' val

70+ ]

71+ match (Var ident) = return $ show ident

72+ match (Do els) = concat <$> sequence

73+ [ return "do "

74+ , withIndent $ prettyPrintMany prettyPrintDoNotationElement els

75+ , currentIndent

76+ ]

77+ match (OperatorSection op (Right val)) = return $ "(" ++ prettyPrintValue op ++ " " ++ prettyPrintValue val ++ ")"

78+ match (OperatorSection op (Left val)) = return $ "(" ++ prettyPrintValue val ++ " " ++ prettyPrintValue op ++ ")"

79+ match (TypeClassDictionary name _ _) = return $ "<<dict " ++ show name ++ ">>"

80+ match (SuperClassDictionary name _) = return $ "<<superclass dict " ++ show name ++ ">>"

81+ match (TypedValue _ val _) = prettyPrintValue' val

82+ match (PositionedValue _ _ val) = prettyPrintValue' val

83+ match _ = mzero

84+

85+prettyPrintDeclaration :: Declaration -> StateT PrinterState Maybe String

86+prettyPrintDeclaration (TypeDeclaration ident ty) = return $ show ident ++ " :: " ++ prettyPrintType ty

87+prettyPrintDeclaration (ValueDeclaration ident _ [] (Right val)) = concat <$> sequence

88+ [ return $ show ident ++ " = "

89+ , prettyPrintValue' val

90+ ]

91+prettyPrintDeclaration (PositionedDeclaration _ _ d) = prettyPrintDeclaration d

92+prettyPrintDeclaration _ = error "Invalid argument to prettyPrintDeclaration"

93+

94+prettyPrintCaseAlternative :: CaseAlternative -> StateT PrinterState Maybe String

95+prettyPrintCaseAlternative (CaseAlternative binders result) =

96+ concat <$> sequence

97+ [ intercalate ", " <$> forM binders prettyPrintBinder'

98+ , prettyPrintResult result

99+ ]

100+ where

101+ prettyPrintResult (Left gs) = concat <$> mapM prettyPrintGuardedValue gs

102+ prettyPrintResult (Right v) = (" -> " ++) <$> prettyPrintValue' v

103+

104+ prettyPrintGuardedValue (grd, val) =

105+ concat <$> sequence

106+ [ return "| "

107+ , prettyPrintValue' grd

108+ , return " -> "

109+ , prettyPrintValue' val

110+ , return "\n"

111+ ]

112+

113+prettyPrintDoNotationElement :: DoNotationElement -> StateT PrinterState Maybe String

114+prettyPrintDoNotationElement (DoNotationValue val) =

115+ prettyPrintValue' val

116+prettyPrintDoNotationElement (DoNotationBind binder val) =

117+ concat <$> sequence

118+ [ prettyPrintBinder' binder

119+ , return " <- "

120+ , prettyPrintValue' val

121+ ]

122+prettyPrintDoNotationElement (DoNotationLet ds) =

123+ concat <$> sequence

124+ [ return "let "

125+ , withIndent $ prettyPrintMany prettyPrintDeclaration ds

126+ ]

127+prettyPrintDoNotationElement (PositionedDoNotationElement _ _ el) = prettyPrintDoNotationElement el

128+

129+prettyPrintObject' :: [(String, Maybe Expr)] -> StateT PrinterState Maybe String

130+prettyPrintObject' [] = return "{}"

131+prettyPrintObject' ps = concat <$> sequence

132+ [ return "{\n"

133+ , withIndent $ prettyPrintMany prettyPrintObjectProperty ps

134+ , return "\n"

135+ , currentIndent

136+ , return "}"

137+ ]

138+

139+ifThenElse :: Pattern PrinterState Expr ((Expr, Expr), Expr)

140+ifThenElse = mkPattern match

141+ where

142+ match (IfThenElse cond th el) = Just ((th, el), cond)

143+ match _ = Nothing

144+

145+accessor :: Pattern PrinterState Expr (String, Expr)

146+accessor = mkPattern match

147+ where

148+ match (Accessor prop val) = Just (prop, val)

149+ match _ = Nothing

150+

151+objectUpdate :: Pattern PrinterState Expr ([String], Expr)

152+objectUpdate = mkPattern match

153+ where

154+ match (ObjectUpdate o ps) = Just (flip map ps $ \(key, val) -> key ++ " = " ++ prettyPrintValue val, o)

155+ match (ObjectUpdater o ps) = Just (flip map ps $ \(key, val) -> key ++ " = " ++ maybe "_" prettyPrintValue val, fromMaybe (Var (Qualified Nothing $ Ident "_")) o)

156+ match _ = Nothing

157+

158+app :: Pattern PrinterState Expr (String, Expr)

159+app = mkPattern match

160+ where

161+ match (App val arg) = Just (prettyPrintValue arg, val)

162+ match _ = Nothing

163+

164+lam :: Pattern PrinterState Expr (String, Expr)

165+lam = mkPattern match

166+ where

167+ match (Abs (Left arg) val) = Just (show arg, val)

168+ match _ = Nothing

169+

170+-- |

171+-- Generate a pretty-printed string representing an expression

172+--

173+prettyPrintValue :: Expr -> String

174+prettyPrintValue = fromMaybe (error "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyPrintValue'

175+

176+prettyPrintValue' :: Expr -> StateT PrinterState Maybe String

177+prettyPrintValue' = runKleisli $ runPattern matchValue

178+ where

179+ matchValue :: Pattern PrinterState Expr String

180+ matchValue = buildPrettyPrinter operators (literals <+> fmap parens matchValue)

181+ operators :: OperatorTable PrinterState Expr String

182+ operators =

183+ OperatorTable [ [ Wrap accessor $ \prop val -> val ++ "." ++ prop ]

184+ , [ Wrap objectUpdate $ \ps val -> val ++ "{ " ++ intercalate ", " ps ++ " }" ]

185+ , [ Wrap app $ \arg val -> val ++ "(" ++ arg ++ ")" ]

186+ , [ Split lam $ \arg val -> "\\" ++ arg ++ " -> " ++ prettyPrintValue val ]

187+ , [ Wrap ifThenElse $ \(th, el) cond -> "if " ++ cond ++ " then " ++ prettyPrintValue th ++ " else " ++ prettyPrintValue el ]

188+ ]

189+

190+prettyPrintBinderAtom :: Pattern PrinterState Binder String

191+prettyPrintBinderAtom = mkPattern' match

192+ where

193+ match :: Binder -> StateT PrinterState Maybe String

194+ match NullBinder = return "_"

195+ match (StringBinder str) = return $ show str

196+ match (NumberBinder num) = return $ either show show num

197+ match (BooleanBinder True) = return "true"

198+ match (BooleanBinder False) = return "false"

199+ match (VarBinder ident) = return $ show ident

200+ match (ConstructorBinder ctor args) = concat <$> sequence

201+ [ return $ show ctor ++ " "

202+ , unwords <$> forM args match

203+ ]

204+ match (ObjectBinder bs) = concat <$> sequence

205+ [ return "{\n"

206+ , withIndent $ prettyPrintMany prettyPrintObjectPropertyBinder bs

207+ , currentIndent

208+ , return "}"

209+ ]

210+ match (ArrayBinder bs) = concat <$> sequence

211+ [ return "["

212+ , unwords <$> mapM prettyPrintBinder' bs

213+ , return "]"

214+ ]

215+ match (NamedBinder ident binder) = ((show ident ++ "@") ++) <$> prettyPrintBinder' binder

216+ match (PositionedBinder _ _ binder) = prettyPrintBinder' binder

217+ match _ = mzero

218+

219+-- |

220+-- Generate a pretty-printed string representing a Binder

221+--

222+prettyPrintBinder :: Binder -> String

223+prettyPrintBinder = fromMaybe (error "Incomplete pattern") . flip evalStateT (PrinterState 0) . prettyPrintBinder'

224+

225+prettyPrintBinder' :: Binder -> StateT PrinterState Maybe String

226+prettyPrintBinder' = runKleisli $ runPattern matchBinder

227+ where

228+ matchBinder :: Pattern PrinterState Binder String

229+ matchBinder = buildPrettyPrinter operators (prettyPrintBinderAtom <+> fmap parens matchBinder)

230+ operators :: OperatorTable PrinterState Binder String

231+ operators =

232+ OperatorTable [ [ AssocR matchConsBinder (\b1 b2 -> b1 ++ " : " ++ b2) ] ]

233+

234+matchConsBinder :: Pattern PrinterState Binder (Binder, Binder)

235+matchConsBinder = mkPattern match'

236+ where

237+ match' (ConsBinder b1 b2) = Just (b1, b2)

238+ match' _ = Nothing

239+

240+prettyPrintObjectPropertyBinder :: (String, Binder) -> StateT PrinterState Maybe String

241+prettyPrintObjectPropertyBinder (key, binder) = concat <$> sequence

242+ [ return $ prettyPrintObjectKey key ++ ": "

243+ , prettyPrintBinder' binder

244+ ]

245+

246+prettyPrintObjectProperty :: (String, Maybe Expr) -> StateT PrinterState Maybe String

247+prettyPrintObjectProperty (key, value) = concat <$> sequence

248+ [ return $ prettyPrintObjectKey key ++ ": "

249+ , maybe (pure "_") prettyPrintValue' value

250+ ]

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

@@ -0,0 +1,194 @@

1+-----------------------------------------------------------------------------

2+-----------------------------------------------------------------------------

3+--

4+-- Module : Language.PureScript.Renamer

6+-- License : MIT

7+--

8+-- Maintainer : Phil Freeman <paf31@cantab.net>

9+-- Stability : experimental

10+-- Portability :

11+--

12+-- |

13+-- Renaming pass that prevents shadowing of local identifiers.

14+--

15+-----------------------------------------------------------------------------

16+

17+module Language.PureScript.Renamer (renameInModules) where

18+

19+import Control.Applicative

20+import Control.Monad.State

21+

22+import Data.List (find)

23+

24+import qualified Data.Map as M

25+import qualified Data.Set as S

26+

27+import Language.PureScript.CoreFn

28+import Language.PureScript.Names

29+import Language.PureScript.Traversals

30+

31+import qualified Language.PureScript.Constants as C

32+

33+-- |

34+-- The state object used in this module

35+--

36+data RenameState = RenameState {

37+ -- |

38+ -- A map from names bound (in the input) to their names (in the output)

39+ --

40+ rsBoundNames :: M.Map Ident Ident

41+ -- |

42+ -- The set of names which have been used and are in scope in the output

43+ --

44+ , rsUsedNames :: S.Set Ident

45+ }

46+

47+type Rename = State RenameState

48+

49+initState :: [Ident] -> RenameState

50+initState scope = RenameState (M.fromList (zip scope scope)) (S.fromList scope)

51+

52+-- |

53+-- Runs renaming starting with a list of idents for the initial scope.

54+--

55+runRename :: [Ident] -> Rename a -> a

56+runRename scope = flip evalState (initState scope)

57+

58+-- |

59+-- Creates a new renaming scope using the current as a basis. Used to backtrack

60+-- when leaving an Abs.

61+--

62+newScope :: Rename a -> Rename a

63+newScope x = do

64+ scope <- get

65+ a <- x

66+ put scope

67+ return a

68+

69+-- |

70+-- Adds a new scope entry for an ident. If the ident is already present, a new

71+-- unique name is generated and stored.

72+--

73+updateScope :: Ident -> Rename Ident

74+updateScope i@(Ident name) | name == C.__unused = return i

75+updateScope name = do

76+ scope <- get

77+ let name' = case name `S.member` rsUsedNames scope of

78+ True ->

79+ let

80+ newNames = [ Ident (runIdent name ++ "_" ++ show (i :: Int)) | i <- [1..] ]

81+ Just newName = find (`S.notMember` rsUsedNames scope) newNames

82+ in newName

83+ False -> name

84+ modify $ \s -> s { rsBoundNames = M.insert name name' (rsBoundNames s)

85+ , rsUsedNames = S.insert name' (rsUsedNames s)

86+ }

87+ return name'

88+

89+-- |

90+-- Finds the new name to use for an ident.

91+--

92+lookupIdent :: Ident -> Rename Ident

93+lookupIdent i@(Ident name) | name == C.__unused = return i

94+lookupIdent name = do

95+ name' <- gets $ M.lookup name . rsBoundNames

96+ case name' of

97+ Just name'' -> return name''

98+ Nothing -> error $ "Rename scope is missing ident '" ++ show name ++ "'"

99+

100+-- |

101+-- Finds idents introduced by declarations.

102+--

103+findDeclIdents :: [Bind Ann] -> [Ident]

104+findDeclIdents = concatMap go

105+ where

106+ go (NonRec ident _) = [ident]

107+ go (Rec ds) = map fst ds

108+

109+-- |

110+-- Renames within each declaration in a module.

111+--

112+renameInModules :: [Module Ann] -> [Module Ann]

113+renameInModules = map go

114+ where

115+ go :: Module Ann -> Module Ann

116+ go m@(Module _ _ _ _ _ decls) = m { moduleDecls = renameInDecl' (findDeclIdents decls) `map` decls }

117+ renameInDecl' :: [Ident] -> Bind Ann -> Bind Ann

118+ renameInDecl' scope = runRename scope . renameInDecl True

119+

120+-- |

121+-- Renames within a declaration. isTopLevel is used to determine whether the

122+-- declaration is a module member or appearing within a Let. At the top level

123+-- declarations are not renamed or added to the scope (they should already have

124+-- been added), whereas in a Let declarations are renamed if their name shadows

125+-- another in the current scope.

126+--

127+renameInDecl :: Bool -> Bind Ann -> Rename (Bind Ann)

128+renameInDecl isTopLevel (NonRec name val) = do

129+ name' <- if isTopLevel then return name else updateScope name

130+ NonRec name' <$> renameInValue val

131+renameInDecl isTopLevel (Rec ds) = do

132+ ds' <- mapM updateNames ds

133+ Rec <$> mapM updateValues ds'

134+ where

135+ updateNames :: (Ident, Expr Ann) -> Rename (Ident, Expr Ann)

136+ updateNames (name, val) = do

137+ name' <- if isTopLevel then return name else updateScope name

138+ return (name', val)

139+ updateValues :: (Ident, Expr Ann) -> Rename (Ident, Expr Ann)

140+ updateValues (name, val) = (,) name <$> renameInValue val

141+

142+-- |

143+-- Renames within a value.

144+--

145+renameInValue :: Expr Ann -> Rename (Expr Ann)

146+renameInValue (Literal ann l) =

147+ Literal ann <$> renameInLiteral renameInValue l

148+renameInValue c@(Constructor{}) = return c

149+renameInValue (Accessor ann prop v) =

150+ Accessor ann prop <$> renameInValue v

151+renameInValue (ObjectUpdate ann obj vs) =

152+ ObjectUpdate ann <$> renameInValue obj <*> mapM (\(name, v) -> (,) name <$> renameInValue v) vs

153+renameInValue e@(Abs (_, _, _, Just IsTypeClassConstructor) _ _) = return e

154+renameInValue (Abs ann name v) =

155+ newScope $ Abs ann <$> updateScope name <*> renameInValue v

156+renameInValue (App ann v1 v2) =

157+ App ann <$> renameInValue v1 <*> renameInValue v2

158+renameInValue (Var ann (Qualified Nothing name)) =

159+ Var ann . Qualified Nothing <$> lookupIdent name

160+renameInValue v@(Var{}) = return v

161+renameInValue (Case ann vs alts) =

162+ newScope $ Case ann <$> mapM renameInValue vs <*> mapM renameInCaseAlternative alts

163+renameInValue (Let ann ds v) =

164+ newScope $ Let ann <$> mapM (renameInDecl False) ds <*> renameInValue v

165+

166+-- |

167+-- Renames within literals.

168+--

169+renameInLiteral :: (a -> Rename a) -> Literal a -> Rename (Literal a)

170+renameInLiteral rename (ArrayLiteral bs) = ArrayLiteral <$> mapM rename bs

171+renameInLiteral rename (ObjectLiteral bs) = ObjectLiteral <$> mapM (sndM rename) bs

172+renameInLiteral _ l = return l

173+

174+-- |

175+-- Renames within case alternatives.

176+--

177+renameInCaseAlternative :: CaseAlternative Ann -> Rename (CaseAlternative Ann)

178+renameInCaseAlternative (CaseAlternative bs v) =

179+ CaseAlternative <$> mapM renameInBinder bs

180+ <*> eitherM (mapM (pairM renameInValue renameInValue)) renameInValue v

181+

182+-- |

183+-- Renames within binders.

184+--

185+renameInBinder :: Binder a -> Rename (Binder a)

186+renameInBinder n@(NullBinder{}) = return n

187+renameInBinder (LiteralBinder ann b) =

188+ LiteralBinder ann <$> renameInLiteral renameInBinder b

189+renameInBinder (VarBinder ann name) =

190+ VarBinder ann <$> updateScope name

191+renameInBinder (ConstructorBinder ann tctor dctor bs) =

192+ ConstructorBinder ann tctor dctor <$> mapM renameInBinder bs

193+renameInBinder (NamedBinder ann name b) =

194+ NamedBinder ann <$> updateScope name <*> renameInBinder b

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

@@ -0,0 +1,71 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : Language.PureScript.Sugar

4+-- Copyright : (c) Phil Freeman 2013

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- |

12+-- Desugaring passes

13+--

14+-----------------------------------------------------------------------------

15+

16+{-# LANGUAGE FlexibleContexts #-}

17+

18+module Language.PureScript.Sugar (desugar, module S) where

19+

20+import Control.Monad

21+import Control.Category ((>>>))

22+import Control.Applicative

23+import Control.Monad.Error.Class

24+import Control.Monad.Supply.Class

25+

26+import Language.PureScript.AST

27+import Language.PureScript.Errors

28+

29+import Language.PureScript.Sugar.BindingGroups as S

30+import Language.PureScript.Sugar.CaseDeclarations as S

31+import Language.PureScript.Sugar.DoNotation as S

32+import Language.PureScript.Sugar.Names as S

33+import Language.PureScript.Sugar.ObjectWildcards as S

34+import Language.PureScript.Sugar.Operators as S

35+import Language.PureScript.Sugar.TypeClasses as S

36+import Language.PureScript.Sugar.TypeDeclarations as S

37+

38+-- |

39+-- The desugaring pipeline proceeds as follows:

40+--

41+-- * Remove signed literals in favour of `negate` applications

42+--

43+-- * Desugar object literals with wildcards into lambdas

44+--

45+-- * Desugar operator sections

46+--

47+-- * Desugar do-notation using the @Prelude.Monad@ type class

48+--

49+-- * Desugar top-level case declarations into explicit case expressions

50+--

51+-- * Desugar type declarations into value declarations with explicit type annotations

52+--

53+-- * Qualify any unqualified names and types

54+--

55+-- * Rebracket user-defined binary operators

56+--

57+-- * Introduce type synonyms for type class dictionaries

58+--

59+-- * Group mutually recursive value and data declarations into binding groups.

60+--

61+desugar :: (Applicative m, MonadSupply m, MonadError 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.hsnew file+207

@@ -0,0 +1,207 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : Language.PureScript.BindingGroups

4+-- Copyright : (c) Phil Freeman 2013

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- |

12+-- This module implements the desugaring pass which creates binding groups from sets of

13+-- mutually-recursive value declarations and mutually-recursive type declarations.

14+--

15+-----------------------------------------------------------------------------

16+

17+{-# LANGUAGE FlexibleContexts #-}

18+

19+module Language.PureScript.Sugar.BindingGroups (

20+ createBindingGroups,

21+ createBindingGroupsModule,

22+ collapseBindingGroups,

23+ collapseBindingGroupsModule

24+) where

25+

26+import Data.Graph

27+import Data.List (nub, intersect)

28+import Data.Maybe (isJust, mapMaybe)

29+import Control.Applicative

30+import Control.Monad ((<=<))

31+import Control.Monad.Error.Class

32+

33+import qualified Data.Set as S

34+

35+import Language.PureScript.AST

36+import Language.PureScript.Names

37+import Language.PureScript.Types

38+import Language.PureScript.Environment

39+import Language.PureScript.Errors

40+

41+-- |

42+-- Replace all sets of mutually-recursive declarations in a module with binding groups

43+--

44+createBindingGroupsModule :: (Functor m, Applicative m, MonadError 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 _ (CyclicSCC [d]) = return d

161+toBindingGroup moduleName (CyclicSCC ds') =

162+ -- Once we have a mutually-recursive group of declarations, we need to sort

163+ -- them further by their immediate dependencies (those outside function

164+ -- bodies). In particular, this is relevant for type instance dictionaries

165+ -- whose members require other type instances (for example, functorEff

166+ -- defines (<$>) = liftA1, which depends on applicativeEff). Note that

167+ -- superclass references are still inside functions, so don't count here.

168+ -- If we discover declarations that still contain mutually-recursive

169+ -- immediate references, we're guaranteed to get an undefined reference at

170+ -- runtime, so treat this as an error. See also github issue #365.

171+ BindingGroupDeclaration <$> mapM toBinding (stronglyConnComp valueVerts)

172+ where

173+ idents :: [Ident]

174+ idents = map (\(_, i, _) -> i) valueVerts

175+

176+ valueVerts :: [(Declaration, Ident, [Ident])]

177+ valueVerts = map (\d -> (d, getIdent d, usedImmediateIdents moduleName d `intersect` idents)) ds'

178+

179+ toBinding :: (MonadError MultipleErrors m) => SCC Declaration -> m (Ident, NameKind, Expr)

180+ toBinding (AcyclicSCC d) = return $ fromValueDecl d

181+ toBinding (CyclicSCC ~(d:ds)) = cycleError d ds

182+

183+ cycleError :: (MonadError MultipleErrors m) => Declaration -> [Declaration] -> m a

184+ cycleError (PositionedDeclaration p _ d) ds = rethrowWithPosition p $ cycleError d ds

185+ cycleError (ValueDeclaration n _ _ (Right _)) [] = throwError . errorMessage $ CycleInDeclaration n

186+ cycleError d ds@(_:_) = rethrow (onErrorMessages (NotYetDefined (map getIdent ds))) $ cycleError d []

187+ cycleError _ _ = error "Expected ValueDeclaration"

188+

189+toDataBindingGroup :: (MonadError MultipleErrors m) => SCC Declaration -> m Declaration

190+toDataBindingGroup (AcyclicSCC d) = return d

191+toDataBindingGroup (CyclicSCC [d]) = case isTypeSynonym d of

192+ Just pn -> throwError . errorMessage $ CycleInTypeSynonym (Just pn)

193+ _ -> return d

194+toDataBindingGroup (CyclicSCC ds')

195+ | all (isJust . isTypeSynonym) ds' = throwError . errorMessage $ CycleInTypeSynonym Nothing

196+ | otherwise = return $ DataBindingGroupDeclaration ds'

197+

198+isTypeSynonym :: Declaration -> Maybe ProperName

199+isTypeSynonym (TypeSynonymDeclaration pn _ _) = Just pn

200+isTypeSynonym (PositionedDeclaration _ _ d) = isTypeSynonym d

201+isTypeSynonym _ = Nothing

202+

203+fromValueDecl :: Declaration -> (Ident, NameKind, Expr)

204+fromValueDecl (ValueDeclaration ident nameKind [] (Right val)) = (ident, nameKind, val)

205+fromValueDecl ValueDeclaration{} = error "Binders should have been desugared"

206+fromValueDecl (PositionedDeclaration _ _ d) = fromValueDecl d

207+fromValueDecl _ = error "Expected ValueDeclaration"

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

@@ -0,0 +1,129 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : Language.PureScript.CaseDeclarations

4+-- Copyright : (c) Phil Freeman 2013

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- |

12+-- This module implements the desugaring pass which replaces top-level binders with

13+-- case expressions.

14+--

15+-----------------------------------------------------------------------------

16+

17+{-# LANGUAGE FlexibleContexts #-}

18+

19+module Language.PureScript.Sugar.CaseDeclarations (

20+ desugarCases,

21+ desugarCasesModule

22+) where

23+

24+import Data.List (nub, groupBy)

25+

26+import Control.Applicative

27+import Control.Monad ((<=<), forM, join, unless, replicateM)

28+import Control.Monad.Except (throwError)

29+import Control.Monad.Error.Class (MonadError)

30+import Control.Monad.Supply.Class

31+

32+import Language.PureScript.Names

33+import Language.PureScript.AST

34+import Language.PureScript.Environment

35+import Language.PureScript.Errors

36+import Language.PureScript.Traversals

37+import Language.PureScript.TypeChecker.Monad (guardWith)

38+

39+-- Data.Either.isLeft (base 4.7)

40+isLeft :: Either a b -> Bool

41+isLeft (Left _) = True

42+isLeft (Right _) = False

43+

44+-- |

45+-- Replace all top-level binders in a module with case expressions.

46+--

47+desugarCasesModule :: (Functor m, Applicative m, MonadSupply m, MonadError 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 :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => [Declaration] -> m [Declaration]

93+toDecls [ValueDeclaration ident nameKind bs (Right val)] | all isVarBinder bs = do

94+ let args = map (\(VarBinder arg) -> arg) bs

95+ body = foldr (Abs . Left) val args

96+ guardWith (errorMessage (OverlappingArgNames (Just ident))) $ length (nub args) == length args

97+ return [ValueDeclaration ident nameKind [] (Right body)]

98+toDecls ds@(ValueDeclaration ident _ bs result : _) = do

99+ let tuples = map toTuple ds

100+ unless (all ((== length bs) . length . fst) tuples) $

101+ throwError . errorMessage $ ArgListLengthsDiffer ident

102+ unless (not (null bs) || isLeft result) $

103+ throwError . errorMessage $ DuplicateValueDeclaration ident

104+ caseDecl <- makeCaseDeclaration ident tuples

105+ return [caseDecl]

106+toDecls (PositionedDeclaration pos com d : ds) = do

107+ (d' : ds') <- rethrowWithPosition pos $ toDecls (d : ds)

108+ return (PositionedDeclaration pos com d' : ds')

109+toDecls ds = return ds

110+

111+isVarBinder :: Binder -> Bool

112+isVarBinder (VarBinder _) = True

113+isVarBinder _ = False

114+

115+toTuple :: Declaration -> ([Binder], Either [(Guard, Expr)] Expr)

116+toTuple (ValueDeclaration _ _ bs result) = (bs, result)

117+toTuple (PositionedDeclaration _ _ d) = toTuple d

118+toTuple _ = error "Not a value declaration"

119+

120+makeCaseDeclaration :: (Functor m, Applicative m, MonadSupply m, MonadError MultipleErrors m) => Ident -> [([Binder], Either [(Guard, Expr)] Expr)] -> m Declaration

121+makeCaseDeclaration ident alternatives = do

122+ let argPattern = length . fst . head $ alternatives

123+ args <- map Ident <$> replicateM argPattern freshName

124+ let

125+ vars = map (Var . Qualified Nothing) args

126+ binders = [ CaseAlternative bs result | (bs, result) <- alternatives ]

127+ value = foldr (Abs . Left) (Case vars binders) args

128+ return $ ValueDeclaration ident Value [] (Right value)

129+

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

@@ -0,0 +1,77 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : Language.PureScript.Sugar.DoNotation

4+-- Copyright : (c) Phil Freeman 2013

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- |

12+-- This module implements the desugaring pass which replaces do-notation statements with

13+-- appropriate calls to (>>=) from the Prelude.Monad type class.

14+--

15+-----------------------------------------------------------------------------

16+

17+{-# LANGUAGE FlexibleContexts #-}

18+{-# LANGUAGE ScopedTypeVariables #-}

19+

20+module Language.PureScript.Sugar.DoNotation (

21+ desugarDoModule

22+) where

23+

24+import Language.PureScript.Names

25+import Language.PureScript.AST

26+import Language.PureScript.Errors

27+

28+import qualified Language.PureScript.Constants as C

29+

30+import Control.Applicative

31+import Control.Monad.Error.Class

32+import Control.Monad.Supply.Class

33+

34+-- |

35+-- Replace all @DoNotationBind@ and @DoNotationValue@ constructors with applications of the Prelude.(>>=) function,

36+-- and all @DoNotationLet@ constructors with let expressions.

37+--

38+desugarDoModule :: forall m. (Applicative m, MonadSupply m, MonadError 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+ prelude :: ModuleName

48+ prelude = ModuleName [ProperName C.prelude]

49+

50+ bind :: Expr

51+ bind = Var (Qualified (Just prelude) (Op (C.>>=)))

52+

53+ replace :: Expr -> m Expr

54+ replace (Do els) = go els

55+ replace (PositionedValue pos com v) = PositionedValue pos com <$> rethrowWithPosition pos (replace v)

56+ replace other = return other

57+

58+ go :: [DoNotationElement] -> m Expr

59+ go [] = error "The impossible happened in desugarDo"

60+ go [DoNotationValue val] = return val

61+ go (DoNotationValue val : rest) = do

62+ rest' <- go rest

63+ return $ App (App bind val) (Abs (Left (Ident C.__unused)) rest')

64+ go [DoNotationBind _ _] = throwError . errorMessage $ InvalidDoBind

65+ go (DoNotationBind NullBinder val : rest) = go (DoNotationValue val : rest)

66+ go (DoNotationBind (VarBinder ident) val : rest) = do

67+ rest' <- go rest

68+ return $ App (App bind val) (Abs (Left ident) rest')

69+ go (DoNotationBind binder val : rest) = do

70+ rest' <- go rest

71+ ident <- Ident <$> freshName

72+ return $ App (App bind val) (Abs (Left ident) (Case [Var (Qualified Nothing ident)] [CaseAlternative [binder] (Right rest')]))

73+ go [DoNotationLet _] = throwError . errorMessage $ InvalidDoLet

74+ go (DoNotationLet ds : rest) = do

75+ rest' <- go rest

76+ return $ Let ds rest'

77+ go (PositionedDoNotationElement pos com el : rest) = rethrowWithPosition pos $ PositionedValue pos com <$> go (el : rest)

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

@@ -0,0 +1,541 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : Language.PureScript.Sugar.Names

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- |

12+--

13+-----------------------------------------------------------------------------

14+

15+{-# LANGUAGE FlexibleContexts #-}

16+{-# LANGUAGE ScopedTypeVariables #-}

17+

18+module Language.PureScript.Sugar.Names (

19+ desugarImports

20+) where

21+

22+import Data.List (nub)

23+import Data.Maybe (fromMaybe, isJust, mapMaybe)

24+

25+import Control.Applicative (Applicative(..), (<$>), (<*>))

26+import Control.Monad.Except

27+

28+import qualified Data.Map as M

29+

30+import Language.PureScript.AST

31+import Language.PureScript.Names

32+import Language.PureScript.Types

33+import Language.PureScript.Environment

34+import Language.PureScript.Errors

35+import Language.PureScript.Traversals

36+

37+import qualified Language.PureScript.Constants as C

38+

39+-- |

40+-- The global export environment - every declaration exported from every module.

41+--

42+type ExportEnvironment = M.Map ModuleName Exports

43+

44+-- |

45+-- The exported declarations from a module.

46+--

47+data Exports = Exports

48+ {

49+ -- |

50+ -- The types exported from each module

51+ --

52+ exportedTypes :: [(ProperName, [ProperName])]

53+ -- |

54+ -- The classes exported from each module

55+ --

56+ , exportedTypeClasses :: [ProperName]

57+ -- |

58+ -- The values exported from each module

59+ --

60+ , exportedValues :: [Ident]

61+ } deriving (Show)

62+

63+-- |

64+-- An imported environment for a particular module. This also contains the module's own members.

65+--

66+data ImportEnvironment = ImportEnvironment

67+ {

68+ -- |

69+ -- Local names for types within a module mapped to to their qualified names

70+ --

71+ importedTypes :: M.Map (Qualified ProperName) (Qualified ProperName)

72+ -- |

73+ -- Local names for data constructors within a module mapped to to their qualified names

74+ --

75+ , importedDataConstructors :: M.Map (Qualified ProperName) (Qualified ProperName)

76+ -- |

77+ -- Local names for classes within a module mapped to to their qualified names

78+ --

79+ , importedTypeClasses :: M.Map (Qualified ProperName) (Qualified ProperName)

80+ -- |

81+ -- Local names for values within a module mapped to to their qualified names

82+ --

83+ , importedValues :: M.Map (Qualified Ident) (Qualified Ident)

84+ } deriving (Show)

85+

86+-- |

87+-- Updates the exports for a module from the global environment. If the module was not previously

88+-- present in the global environment, it is created.

89+--

90+updateExportedModule :: (Applicative m, MonadError MultipleErrors m) => ExportEnvironment -> ModuleName -> (Exports -> m Exports) -> m ExportEnvironment

91+updateExportedModule env mn update = do

92+ let exports = fromMaybe (error "Module was undefined in updateExportedModule") $ mn `M.lookup` env

93+ exports' <- update exports

94+ return $ M.insert mn exports' env

95+

96+-- |

97+-- Adds an empty module to an ExportEnvironment.

98+--

99+addEmptyModule :: (Applicative m, MonadError MultipleErrors m) => ExportEnvironment -> ModuleName -> m ExportEnvironment

100+addEmptyModule env name =

101+ if name `M.member` env

102+ then throwError . errorMessage $ RedefinedModule name

103+ else return $ M.insert name (Exports [] [] []) env

104+

105+-- |

106+-- Adds a type belonging to a module to the export environment.

107+--

108+addType :: (Applicative m, MonadError MultipleErrors m) => ExportEnvironment -> ModuleName -> ProperName -> [ProperName] -> m ExportEnvironment

109+addType env mn name dctors = updateExportedModule env mn $ \m -> do

110+ let exTypes = exportedTypes m

111+ let exDctors = snd `concatMap` exTypes

112+ let exClasses = exportedTypeClasses m

113+ when (any ((== name) . fst) exTypes) $ throwConflictError ConflictingTypeDecls name

114+ when (name `elem` exClasses) $ throwConflictError TypeConflictsWithClass name

115+ forM_ dctors $ \dctor -> do

116+ when (dctor `elem` exDctors) $ throwConflictError ConflictingCtorDecls dctor

117+ when (dctor `elem` exClasses) $ throwConflictError CtorConflictsWithClass dctor

118+ return $ m { exportedTypes = (name, dctors) : exTypes }

119+

120+-- |

121+-- Adds a class to the export environment.

122+--

123+addTypeClass :: (Applicative m, MonadError MultipleErrors m) => ExportEnvironment -> ModuleName -> ProperName -> m ExportEnvironment

124+addTypeClass env mn name = updateExportedModule env mn $ \m -> do

125+ let exTypes = exportedTypes m

126+ let exDctors = snd `concatMap` exTypes

127+ when (any ((== name) . fst) exTypes) $ throwConflictError ClassConflictsWithType name

128+ when (name `elem` exDctors) $ throwConflictError ClassConflictsWithCtor name

129+ classes <- addExport DuplicateClassExport (exportedTypeClasses m) name

130+ return $ m { exportedTypeClasses = classes }

131+

132+-- |

133+-- Adds a class to the export environment.

134+--

135+addValue :: (Applicative m, MonadError MultipleErrors m) => ExportEnvironment -> ModuleName -> Ident -> m ExportEnvironment

136+addValue env mn name = updateExportedModule env mn $ \m -> do

137+ values <- addExport DuplicateValueExport (exportedValues m) name

138+ return $ m { exportedValues = values }

139+

140+-- |

141+-- Adds an entry to a list of exports unless it is already present, in which case an error is

142+-- returned.

143+--

144+addExport :: (Applicative m, MonadError MultipleErrors m, Eq a, Show a) => (a -> ErrorMessage) -> [a] -> a -> m [a]

145+addExport what exports name =

146+ if name `elem` exports

147+ then throwConflictError what name

148+ else return $ name : exports

149+

150+-- |

151+-- Replaces all local names with qualified names within a set of modules.

152+--

153+desugarImports :: forall m. (Applicative m, MonadError MultipleErrors m) => [Module] -> m [Module]

154+desugarImports modules = do

155+ unfilteredExports <- findExports modules

156+ exports <- foldM filterModuleExports unfilteredExports modules

157+ mapM (renameInModule' unfilteredExports exports) modules

158+ where

159+

160+ -- Filters the exports for a module in the global exports environment so that only explicitly

161+ -- exported members remain. If the module does not explicitly export anything, everything is

162+ -- exported.

163+ filterModuleExports :: ExportEnvironment -> Module -> m ExportEnvironment

164+ filterModuleExports env (Module _ mn _ (Just exps)) = filterExports mn exps env

165+ filterModuleExports env _ = return env

166+

167+ -- Rename and check all the names within a module. We tweak the global exports environment so

168+ -- the module has access to an unfiltered list of its own members.

169+ renameInModule' :: ExportEnvironment -> ExportEnvironment -> Module -> m Module

170+ renameInModule' unfilteredExports exports m@(Module _ mn _ _) =

171+ rethrow (onErrorMessages (ErrorInModule mn)) $ do

172+ let env = M.update (\_ -> M.lookup mn unfilteredExports) mn exports

173+ let exps = fromMaybe (error "Module is missing in renameInModule'") $ M.lookup mn exports

174+ imports <- resolveImports env m

175+ elaborateImports <$> renameInModule imports env (elaborateExports exps m)

176+

177+-- |

178+-- Make all exports for a module explicit. This may still effect modules that have an exports list,

179+-- as it will also make all data constructor exports explicit.

180+--

181+elaborateExports :: Exports -> Module -> Module

182+elaborateExports exps (Module coms mn decls _) = Module coms mn decls (Just $

183+ map (\(ctor, dctors) -> TypeRef ctor (Just dctors)) (exportedTypes exps) ++

184+ map TypeClassRef (exportedTypeClasses exps) ++

185+ map ValueRef (exportedValues exps))

186+

187+-- |

188+-- Add `import X ()` for any modules where there are only fully qualified references to members.

189+-- This ensures transitive instances are included when using a member from a module.

190+--

191+elaborateImports :: Module -> Module

192+elaborateImports (Module coms mn decls exps) = Module coms mn decls' exps

193+ where

194+ decls' :: [Declaration]

195+ decls' =

196+ let (f, _, _, _, _) = everythingOnValues (++) (const []) fqValues (const []) (const []) (const [])

197+ in mkImport `map` nub (f `concatMap` decls) ++ decls

198+ fqValues :: Expr -> [ModuleName]

199+ fqValues (Var (Qualified (Just mn') _)) = [mn']

200+ fqValues _ = []

201+ mkImport :: ModuleName -> Declaration

202+ mkImport mn' = ImportDeclaration mn' (Qualifying []) Nothing

203+

204+-- |

205+-- Replaces all local names with qualified names within a module and checks that all existing

206+-- qualified names are valid.

207+--

208+renameInModule :: forall m. (Applicative m, MonadError MultipleErrors m) => ImportEnvironment -> ExportEnvironment -> Module -> m Module

209+renameInModule imports exports (Module coms mn decls exps) =

210+ Module coms mn <$> parU decls go <*> pure exps

211+ where

212+ (go, _, _, _, _) = everywhereWithContextOnValuesM (Nothing, []) updateDecl updateValue updateBinder updateCase defS

213+

214+ updateDecl :: (Maybe SourceSpan, [Ident]) -> Declaration -> m ((Maybe SourceSpan, [Ident]), Declaration)

215+ updateDecl (_, bound) d@(PositionedDeclaration pos _ _) = return ((Just pos, bound), d)

216+ updateDecl (pos, bound) (DataDeclaration dtype name args dctors) =

217+ (,) (pos, bound) <$> (DataDeclaration dtype name args <$> mapM (sndM (mapM (updateTypesEverywhere pos))) dctors)

218+ updateDecl (pos, bound) (TypeSynonymDeclaration name ps ty) =

219+ (,) (pos, bound) <$> (TypeSynonymDeclaration name ps <$> updateTypesEverywhere pos ty)

220+ updateDecl (pos, bound) (TypeClassDeclaration className args implies ds) =

221+ (,) (pos, bound) <$> (TypeClassDeclaration className args <$> updateConstraints pos implies <*> pure ds)

222+ updateDecl (pos, bound) (TypeInstanceDeclaration name cs cn ts ds) =

223+ (,) (pos, bound) <$> (TypeInstanceDeclaration name <$> updateConstraints pos cs <*> updateClassName cn pos <*> mapM (updateTypesEverywhere pos) ts <*> pure ds)

224+ updateDecl (pos, bound) (ExternInstanceDeclaration name cs cn ts) =

225+ (,) (pos, bound) <$> (ExternInstanceDeclaration name <$> updateConstraints pos cs <*> updateClassName cn Nothing <*> mapM (updateTypesEverywhere pos) ts)

226+ updateDecl (pos, bound) (TypeDeclaration name ty) =

227+ (,) (pos, bound) <$> (TypeDeclaration name <$> updateTypesEverywhere pos ty)

228+ updateDecl (pos, bound) (ExternDeclaration fit name js ty) =

229+ (,) (pos, name : bound) <$> (ExternDeclaration fit name js <$> updateTypesEverywhere pos ty)

230+ updateDecl s d = return (s, d)

231+

232+ updateValue :: (Maybe SourceSpan, [Ident]) -> Expr -> m ((Maybe SourceSpan, [Ident]), Expr)

233+ updateValue (_, bound) v@(PositionedValue pos' _ _) = return ((Just pos', bound), v)

234+ updateValue (pos, bound) (Abs (Left arg) val') = return ((pos, arg : bound), Abs (Left arg) val')

235+ updateValue (pos, bound) (Let ds val') = do

236+ let args = mapMaybe letBoundVariable ds

237+ unless (length (nub args) == length args) $

238+ maybe id rethrowWithPosition pos $

239+ throwError . errorMessage $ OverlappingNamesInLet

240+ return ((pos, args ++ bound), Let ds val')

241+ where

242+ updateValue (pos, bound) (Var name'@(Qualified Nothing ident)) | ident `notElem` bound =

243+ (,) (pos, bound) <$> (Var <$> updateValueName name' pos)

244+ updateValue (pos, bound) (Var name'@(Qualified (Just _) _)) =

245+ (,) (pos, bound) <$> (Var <$> updateValueName name' pos)

246+ updateValue s@(pos, _) (Constructor name) = (,) s <$> (Constructor <$> updateDataConstructorName name pos)

247+ updateValue s@(pos, _) (TypedValue check val ty) = (,) s <$> (TypedValue check val <$> updateTypesEverywhere pos ty)

248+ updateValue s v = return (s, v)

249+

250+ updateBinder :: (Maybe SourceSpan, [Ident]) -> Binder -> m ((Maybe SourceSpan, [Ident]), Binder)

251+ updateBinder (_, bound) v@(PositionedBinder pos _ _) = return ((Just pos, bound), v)

252+ updateBinder s@(pos, _) (ConstructorBinder name b) = (,) s <$> (ConstructorBinder <$> updateDataConstructorName name pos <*> pure b)

253+ updateBinder s v = return (s, v)

254+

255+ updateCase :: (Maybe SourceSpan, [Ident]) -> CaseAlternative -> m ((Maybe SourceSpan, [Ident]), CaseAlternative)

256+ updateCase (pos, bound) c@(CaseAlternative bs _) = return ((pos, concatMap binderNames bs ++ bound), c)

257+

258+ letBoundVariable :: Declaration -> Maybe Ident

259+ letBoundVariable (ValueDeclaration ident _ _ _) = Just ident

260+ letBoundVariable (PositionedDeclaration _ _ d) = letBoundVariable d

261+ letBoundVariable _ = Nothing

262+

263+ updateTypesEverywhere :: Maybe SourceSpan -> Type -> m Type

264+ updateTypesEverywhere pos0 = everywhereOnTypesM (updateType pos0)

265+ where

266+ updateType :: Maybe SourceSpan -> Type -> m Type

267+ updateType pos (TypeConstructor name) = TypeConstructor <$> updateTypeName name pos

268+ updateType pos (SaturatedTypeSynonym name tys) = SaturatedTypeSynonym <$> updateTypeName name pos <*> pure tys

269+ updateType pos (ConstrainedType cs t) = ConstrainedType <$> updateConstraints pos cs <*> pure t

270+ updateType _ t = return t

271+

272+ updateConstraints pos = mapM (\(name, ts) -> (,) <$> updateClassName name pos <*> mapM (updateTypesEverywhere pos) ts)

273+

274+ updateTypeName = update UnknownType importedTypes (\mes -> isJust . (`lookup` exportedTypes mes))

275+ updateClassName = update UnknownTypeClass importedTypeClasses (flip elem . exportedTypeClasses)

276+ updateValueName = update UnknownValue importedValues (flip elem . exportedValues)

277+ updateDataConstructorName = update (flip UnknownDataConstructor Nothing) importedDataConstructors (\mes -> flip elem (join $ snd `map` exportedTypes mes))

278+

279+ -- Update names so unqualified references become qualified, and locally qualified references

280+ -- are replaced with their canoncial qualified names (e.g. M.Map -> Data.Map.Map)

281+ update :: (Ord a, Show a) => (Qualified a -> ErrorMessage)

282+ -> (ImportEnvironment -> M.Map (Qualified a) (Qualified a))

283+ -> (Exports -> a -> Bool)

284+ -> Qualified a

285+ -> Maybe SourceSpan

286+ -> m (Qualified a)

287+ update unknown getI checkE qname@(Qualified mn' name) pos = positioned $ case (M.lookup qname imports', mn') of

288+ (Just qname', _) -> return qname'

289+ (Nothing, Just mn'') -> do

290+ when (isExplicitQualModule mn'') . throwError . errorMessage $ unknown qname

291+ modExports <- getExports mn''

292+ if checkE modExports name

293+ then return qname

294+ else throwError . errorMessage $ unknown qname

295+ _ -> throwError . errorMessage $ unknown qname

296+ where

297+ isExplicitQualModule :: ModuleName -> Bool

298+ isExplicitQualModule = flip elem $ mapMaybe (\(Qualified q _) -> q) (M.keys imports')

299+ imports' = getI imports

300+ positioned err = case pos of

301+ Nothing -> err

302+ Just pos' -> rethrowWithPosition pos' err

303+

304+ -- Gets the exports for a module, or an error message if the module doesn't exist

305+ getExports :: ModuleName -> m Exports

306+ getExports mn' = maybe (throwError . errorMessage $ UnknownModule mn') return $ M.lookup mn' exports

307+

308+-- |

309+-- Finds all exported declarations in a set of modules.

310+--

311+findExports :: forall m. (Applicative m, MonadError MultipleErrors m) => [Module] -> m ExportEnvironment

312+findExports = foldM addModule $ M.singleton (ModuleName [ProperName C.prim]) primExports

313+ where

314+

315+ -- The exported types from the Prim module

316+ primExports = Exports (mkTypeEntry `map` M.keys primTypes) [] []

317+ where

318+ mkTypeEntry (Qualified _ name) = (name, [])

319+

320+ -- Add all of the exported declarations from a module to the global export environment

321+ addModule :: ExportEnvironment -> Module -> m ExportEnvironment

322+ addModule env (Module _ mn ds _) = do

323+ env' <- addEmptyModule env mn

324+ rethrow (onErrorMessages (ErrorInModule mn)) $ foldM (addDecl mn) env' ds

325+

326+ -- Add a declaration from a module to the global export environment

327+ addDecl :: ModuleName -> ExportEnvironment -> Declaration -> m ExportEnvironment

328+ addDecl mn env (TypeClassDeclaration tcn _ _ ds) = do

329+ env' <- addTypeClass env mn tcn

330+ foldM go env' ds

331+ where

332+ go env'' (TypeDeclaration name _) = addValue env'' mn name

333+ go env'' (PositionedDeclaration pos _ d) = rethrowWithPosition pos $ go env'' d

334+ go _ _ = error "Invalid declaration in TypeClassDeclaration"

335+ addDecl mn env (DataDeclaration _ tn _ dcs) = addType env mn tn (map fst dcs)

336+ addDecl mn env (TypeSynonymDeclaration tn _ _) = addType env mn tn []

337+ addDecl mn env (ExternDataDeclaration tn _) = addType env mn tn []

338+ addDecl mn env (ValueDeclaration name _ _ _) = addValue env mn name

339+ addDecl mn env (ExternDeclaration _ name _ _) = addValue env mn name

340+ addDecl mn env (PositionedDeclaration pos _ d) = rethrowWithPosition pos $ addDecl mn env d

341+ addDecl _ env _ = return env

342+

343+-- |

344+-- Filters the exports for a module to ensure only explicit exports are kept in the global exports

345+-- environment.

346+--

347+filterExports :: forall m. (Applicative m, MonadError MultipleErrors m) => ModuleName -> [DeclarationRef] -> ExportEnvironment -> m ExportEnvironment

348+filterExports mn exps env = do

349+ let moduleExports = fromMaybe (error "Module is missing") (mn `M.lookup` env)

350+ moduleExports' <- rethrow (onErrorMessages (ErrorInModule mn)) $ filterModule moduleExports

351+ return $ M.insert mn moduleExports' env

352+ where

353+

354+ -- Filter the exports for the specific module

355+ filterModule :: Exports -> m Exports

356+ filterModule exported = do

357+ types' <- foldM (filterTypes $ exportedTypes exported) [] exps

358+ values <- foldM (filterValues $ exportedValues exported) [] exps

359+ classes <- foldM (filterClasses $ exportedTypeClasses exported) [] exps

360+ return exported { exportedTypes = types', exportedTypeClasses = classes, exportedValues = values }

361+

362+ -- Ensure the exported types and data constructors exist in the module and add them to the set of

363+ -- exports

364+ filterTypes :: [(ProperName, [ProperName])] -> [(ProperName, [ProperName])] -> DeclarationRef -> m [(ProperName, [ProperName])]

365+ filterTypes expTys result (PositionedDeclarationRef pos _ r) = rethrowWithPosition pos $ filterTypes expTys result r

366+ filterTypes expTys result (TypeRef name expDcons) = do

367+ dcons <- maybe (throwError . errorMessage . UnknownType $ Qualified (Just mn) name) return $ name `lookup` expTys

368+ dcons' <- maybe (return dcons) (foldM (filterDcons name dcons) []) expDcons

369+ return $ (name, dcons') : result

370+ filterTypes _ result _ = return result

371+

372+ -- Ensure the exported data constructors exists for a type and add them to the list of exports

373+ filterDcons :: ProperName -> [ProperName] -> [ProperName] -> ProperName -> m [ProperName]

374+ filterDcons tcon exps' result name =

375+ if name `elem` exps'

376+ then return $ name : result

377+ else throwError . errorMessage $ UnknownDataConstructor (Qualified (Just mn) name) (Just (Qualified (Just mn) tcon))

378+

379+ -- Ensure the exported classes exist in the module and add them to the set of exports

380+ filterClasses :: [ProperName] -> [ProperName] -> DeclarationRef -> m [ProperName]

381+ filterClasses exps' result (PositionedDeclarationRef pos _ r) = rethrowWithPosition pos $ filterClasses exps' result r

382+ filterClasses exps' result (TypeClassRef name) =

383+ if name `elem` exps'

384+ then return $ name : result

385+ else throwError . errorMessage . UnknownTypeClass $ Qualified (Just mn) name

386+ filterClasses _ result _ = return result

387+

388+ -- Ensure the exported values exist in the module and add them to the set of exports

389+ filterValues :: [Ident] -> [Ident] -> DeclarationRef -> m [Ident]

390+ filterValues exps' result (PositionedDeclarationRef pos _ r) = rethrowWithPosition pos $ filterValues exps' result r

391+ filterValues exps' result (ValueRef name) =

392+ if name `elem` exps'

393+ then return $ name : result

394+ else throwError . errorMessage . UnknownValue $ Qualified (Just mn) name

395+ filterValues _ result _ = return result

396+

397+-- |

398+-- Finds the imports within a module, mapping the imported module name to an optional set of

399+-- explicitly imported declarations.

400+--

401+findImports :: [Declaration] -> M.Map ModuleName (Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)

402+findImports = foldl (findImports' Nothing) M.empty

403+ where

404+ findImports' pos result (ImportDeclaration mn typ qual) = M.insert mn (pos, typ, qual) result

405+ findImports' _ result (PositionedDeclaration pos _ d) = findImports' (Just pos) result d

406+ findImports' _ result _ = result

407+

408+-- |

409+-- Constructs a local environment for a module.

410+--

411+resolveImports :: forall m. (Applicative m, MonadError MultipleErrors m) => ExportEnvironment -> Module -> m ImportEnvironment

412+resolveImports env (Module _ currentModule decls _) =

413+ foldM resolveImport' (ImportEnvironment M.empty M.empty M.empty M.empty) (M.toList scope)

414+ where

415+

416+ -- A Map from module name to the source position for the import, the list of imports from that

417+ -- module (where Nothing indicates everything is to be imported), and optionally a qualified name

418+ -- for the module

419+ scope :: M.Map ModuleName (Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)

420+ scope = M.insert currentModule (Nothing, Unqualified, Nothing) (findImports decls)

421+

422+ resolveImport' :: ImportEnvironment -> (ModuleName, (Maybe SourceSpan, ImportDeclarationType, Maybe ModuleName)) -> m ImportEnvironment

423+ resolveImport' imp (mn, (pos, typ, impQual)) = do

424+ modExports <- positioned $ maybe (throwError . errorMessage $ UnknownModule mn) return $ mn `M.lookup` env

425+ positioned $ resolveImport currentModule mn modExports imp impQual typ

426+ where

427+ positioned err = case pos of

428+ Nothing -> err

429+ Just pos' -> rethrowWithPosition pos' err

430+

431+-- |

432+-- Extends the local environment for a module by resolving an import of another module.

433+--

434+resolveImport :: forall m. (Applicative m, MonadError MultipleErrors m) => ModuleName -> ModuleName -> Exports -> ImportEnvironment -> Maybe ModuleName -> ImportDeclarationType -> m ImportEnvironment

435+resolveImport currentModule importModule exps imps impQual =

436+ resolveByType

437+ where

438+

439+ resolveByType :: ImportDeclarationType -> m ImportEnvironment

440+ resolveByType Unqualified = importAll importExplicit

441+ resolveByType (Qualifying explImports) = (checkedRefs >=> foldM importExplicit imps) explImports

442+ resolveByType (Hiding hiddenImports) = do

443+ hiddenImports' <- checkedRefs hiddenImports

444+ importAll (importNonHidden hiddenImports')

445+

446+ importNonHidden :: [DeclarationRef] -> ImportEnvironment -> DeclarationRef -> m ImportEnvironment

447+ importNonHidden hidden m ref =

448+ if isHidden hidden ref

449+ then return m

450+ else importExplicit m ref

451+

452+ isHidden :: [DeclarationRef] -> DeclarationRef -> Bool

453+ isHidden hidden ref@(TypeRef _ _) =

454+ let

455+ checkTypeRef _ True _ = True

456+ checkTypeRef (TypeRef _ Nothing) acc (TypeRef _ (Just _)) = acc

457+ checkTypeRef (TypeRef name (Just dctor)) _ (TypeRef name' (Just dctor')) = name == name' && dctor == dctor'

458+ checkTypeRef (TypeRef name _) _ (TypeRef name' Nothing) = name == name'

459+ checkTypeRef (PositionedDeclarationRef _ _ r) acc hiddenRef = checkTypeRef r acc hiddenRef

460+ checkTypeRef _ acc _ = acc

461+ in foldl (checkTypeRef ref) False hidden

462+ isHidden hidden ref = ref `elem` hidden

463+

464+ -- Import all symbols

465+ importAll :: (ImportEnvironment -> DeclarationRef -> m ImportEnvironment) -> m ImportEnvironment

466+ importAll importer = do

467+ imp' <- foldM (\m (name, dctors) -> importer m (TypeRef name (Just dctors))) imps (exportedTypes exps)

468+ imp'' <- foldM (\m name -> importer m (ValueRef name)) imp' (exportedValues exps)

469+ foldM (\m name -> importer m (TypeClassRef name)) imp'' (exportedTypeClasses exps)

470+

471+ -- Import something explicitly

472+ importExplicit :: ImportEnvironment -> DeclarationRef -> m ImportEnvironment

473+ importExplicit imp (PositionedDeclarationRef pos _ r) = rethrowWithPosition pos $ importExplicit imp r

474+ importExplicit imp (ValueRef name) = do

475+ values' <- updateImports (importedValues imp) name

476+ return $ imp { importedValues = values' }

477+ importExplicit imp (TypeRef name dctors) = do

478+ types' <- updateImports (importedTypes imp) name

479+ let allDctors = allExportedDataConstructors name

480+ dctors' <- maybe (return allDctors) (mapM $ checkDctorExists allDctors) dctors

481+ dctors'' <- foldM updateImports (importedDataConstructors imp) dctors'

482+ return $ imp { importedTypes = types', importedDataConstructors = dctors'' }

483+ importExplicit imp (TypeClassRef name) = do

484+ typeClasses' <- updateImports (importedTypeClasses imp) name

485+ return $ imp { importedTypeClasses = typeClasses' }

486+ importExplicit _ _ = error "Invalid argument to importExplicit"

487+

488+ -- Check if DeclarationRef points to an existent symbol

489+ checkedRefs :: [DeclarationRef] -> m [DeclarationRef]

490+ checkedRefs = mapM check

491+ where

492+ check (PositionedDeclarationRef pos _ r) =

493+ rethrowWithPosition pos $ check r

494+ check ref@(ValueRef name) =

495+ checkImportExists UnknownValue values name >> return ref

496+ check ref@(TypeRef name dctors) = do

497+ _ <- checkImportExists UnknownType availableTypes name

498+ let allDctors = allExportedDataConstructors name

499+ _ <- maybe (return allDctors) (mapM $ checkDctorExists allDctors) dctors

500+ return ref

501+ check ref@(TypeClassRef name) =

502+ checkImportExists UnknownTypeClass classes name >> return ref

503+ check _ = error "Invalid argument to checkRefIsValid"

504+

505+ -- Find all exported data constructors for a given type

506+ allExportedDataConstructors :: ProperName -> [ProperName]

507+ allExportedDataConstructors name = fromMaybe [] $ name `lookup` exportedTypes exps

508+

509+ -- Add something to the ImportEnvironment if it does not already exist there

510+ updateImports :: (Ord a, Show a) => M.Map (Qualified a) (Qualified a) -> a -> m (M.Map (Qualified a) (Qualified a))

511+ updateImports m name = case M.lookup (Qualified impQual name) m of

512+ Nothing -> return $ M.insert (Qualified impQual name) (Qualified (Just importModule) name) m

513+ Just (Qualified Nothing _) -> error "Invalid state in updateImports"

514+ Just (Qualified (Just mn) _) -> throwError . errorMessage $ err

515+ where

516+ err = if mn == currentModule || importModule == currentModule

517+ then ConflictingImport (show name) mn

518+ else ConflictingImports (show name) mn importModule

519+

520+ -- The available values, types, and classes in the module being imported

521+ values = exportedValues exps

522+ availableTypes = fst `map` exportedTypes exps

523+ classes = exportedTypeClasses exps

524+

525+ -- Ensure that an explicitly imported data constructor exists for the type it is being imported

526+ -- from

527+ checkDctorExists :: [ProperName] -> ProperName -> m ProperName

528+ checkDctorExists = checkImportExists (flip UnknownDataConstructor Nothing)

529+

530+ -- Check that an explicitly imported item exists in the module it is being imported from

531+ checkImportExists :: (Eq a, Show a) => (Qualified a -> ErrorMessage) -> [a] -> a -> m a

532+ checkImportExists unknown exports item =

533+ if item `elem` exports

534+ then return item

535+ else throwError . errorMessage . unknown $ Qualified (Just importModule) item

536+

537+-- |

538+-- Raises an error for when there is more than one definition for something.

539+--

540+throwConflictError :: (Applicative m, MonadError MultipleErrors m, Show a) => (a -> ErrorMessage) -> a -> m b

541+throwConflictError conflict = throwError . errorMessage . conflict

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

@@ -0,0 +1,65 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : Language.PureScript.Sugar.ObjectWildcards

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>, Gary Burgess <gary.burgess@gmail.com>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- |

12+--

13+-----------------------------------------------------------------------------

14+

15+{-# LANGUAGE FlexibleContexts #-}

16+{-# LANGUAGE ScopedTypeVariables #-}

17+

18+module Language.PureScript.Sugar.ObjectWildcards (

19+ desugarObjectConstructors

20+) where

21+

22+import Control.Applicative

23+import Control.Arrow (second)

24+import Control.Monad.Error.Class

25+import Control.Monad.Supply.Class

26+

27+import Data.List (partition)

28+import Data.Maybe (isJust, fromJust, catMaybes)

29+

30+import Language.PureScript.AST

31+import Language.PureScript.Errors

32+import Language.PureScript.Names

33+

34+desugarObjectConstructors :: forall m. (Applicative m, MonadSupply m, MonadError 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.hsnew file+166

@@ -0,0 +1,166 @@

1+-----------------------------------------------------------------------------

2+--

3+-- Module : Language.PureScript.Sugar.Operators

4+-- Copyright : (c) Phil Freeman 2013

5+-- License : MIT

6+--

7+-- Maintainer : Phil Freeman <paf31@cantab.net>

8+-- Stability : experimental

9+-- Portability :

10+--

11+-- |

12+-- This module implements the desugaring pass which reapplies binary operators based

13+-- on their fixity data and removes explicit parentheses.

14+--

15+-- The value parser ignores fixity data when parsing binary operator applications, so

16+-- it is necessary to reorder them here.

17+--

18+-----------------------------------------------------------------------------

19+

20+{-# LANGUAGE Rank2Types #-}

21+{-# LANGUAGE FlexibleContexts #-}

22+{-# LANGUAGE ScopedTypeVariables #-}

23+

24+module Language.PureScript.Sugar.Operators (

25+ rebracket,

26+ removeSignedLiterals,

27+ desugarOperatorSections

28+) where

29+

30+import Language.PureScript.AST

31+import Language.PureScript.Errors

32+import Language.PureScript.Names

33+

34+import Control.Applicative

35+import Control.Monad.State

36+import Control.Monad.Except

37+import Control.Monad.Supply.Class

38+

39+import Data.Function (on)

40+import Data.Functor.Identity

41+import Data.List (groupBy, sortBy)

42+

43+import qualified Text.Parsec as P

44+import qualified Text.Parsec.Pos as P

45+import qualified Text.Parsec.Expr as P

46+

47+import qualified Language.PureScript.Constants as C

48+

49+-- |

50+-- Remove explicit parentheses and reorder binary operator applications

51+--

52+rebracket :: (Applicative m, MonadError 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.hsnew file+297

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

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

This diff is too big to show here.

src/Tests.hsdeleted−141

This diff is too big to show here.

stack.nixdeleted−23

This diff is too big to show here.

stack.yamldeleted−24

This diff is too big to show here.

support/ffi-loader.godeleted−30

This diff is too big to show here.

support/go.mod.ffi-loaderdeleted−2

This diff is too big to show here.

support/go.mod.outputdeleted−2

This diff is too big to show here.

support/go.mod.workingdeleted−1

This diff is too big to show here.

test/Spec.hsdeleted−2

This diff is too big to show here.

tests/Main.hsnew file+108

This diff is too big to show here.

travis-after-script.shnew file+7

This diff is too big to show here.

travis-script.shnew file+11

This diff is too big to show here.