diff options
| author | PhilFreeman <> | 2017-01-02 06:19:00 (GMT) |
|---|---|---|
| committer | hdiff <hdiff@hdiff.luite.com> | 2017-01-02 06:19:00 (GMT) |
| commit | dfc92b2cabaa9529df644929982e90166ffdea4d (patch) | |
| tree | 1c11edbd2d2d5c27b40182bf17d44959b53b83b5 | |
| parent | 79948f219fa19b886408053ae2e9ec97d28ccf45 (diff) | |
version 0.10.40.10.4
98 files changed, 2900 insertions, 725 deletions
diff --git a/CONTRIBUTORS.md b/CONTRIBUTORS.md index d4e6edf..192f952 100644 --- a/CONTRIBUTORS.md +++ b/CONTRIBUTORS.md @@ -86,6 +86,7 @@ This file lists the contributors to the PureScript compiler project, and the ter - [@brandonhamilton](https://github.com/brandonhamilton) (Brandon Hamilton) My existing contributions and all future contributions until further notice are Copyright Brandon Hamilton, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@bbqbaron](https://github.com/bbqbaron) (Eric Loren) My existing contributions and all future contributions until further notice are Copyright Eric Loren, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). - [@RyanGlScott](https://github.com/RyanGlScott) (Ryan Scott) My existing contributions and all future contributions until further notice are Copyright Ryan Scott, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). +- [@seungha-kim](https://github.com/seungha-kim) (Seungha Kim) My existing contributions and all future contributions until further notice are Copyright Seungha Kim, and are licensed to the owners and users of the PureScript compiler project under the terms of the [MIT license](http://opensource.org/licenses/MIT). ### Companies @@ -16,6 +16,8 @@ PureScript uses the following Haskell library packages. Their license files foll Glob SHA + StateVar + adjunctions aeson aeson-better-errors aeson-pretty @@ -31,7 +33,9 @@ PureScript uses the following Haskell library packages. Their license files foll auto-update base base-compat + base-orphans base64-bytestring + bifunctors binary blaze-builder blaze-html @@ -46,16 +50,19 @@ PureScript uses the following Haskell library packages. Their license files foll cereal clock cmdargs + comonad conduit conduit-extra connection containers + contravariant cookie cryptonite data-default-class data-ordlist deepseq directory + distributive dlist easy-file edit-distance @@ -65,12 +72,15 @@ PureScript uses the following Haskell library packages. Their license files foll fast-logger file-embed filepath + foldl + free fsnotify ghc-prim hashable haskeline hex - hfsevents + hinotify + hostname hourglass http-client http-client-tls @@ -79,8 +89,11 @@ PureScript uses the following Haskell library packages. Their license files foll http2 integer-gmp iproute + kan-extensions language-javascript + lens lifted-base + managed memory mime-types mmorph @@ -88,10 +101,12 @@ PureScript uses the following Haskell library packages. Their license files foll monad-logger monad-loops mtl + mwc-random network network-uri old-locale old-time + optional-args optparse-applicative parallel parsec @@ -99,16 +114,20 @@ PureScript uses the following Haskell library packages. Their license files foll pem pipes pipes-http + prelude-extras primitive process + profunctors protolude psqueues random + reflection regex-base regex-tdfa resourcet safe scientific + semigroupoids semigroups simple-sendfile socks @@ -120,16 +139,19 @@ PureScript uses the following Haskell library packages. Their license files foll streaming-commons stringsearch syb + system-fileio + system-filepath tagged template-haskell + temporary terminfo text time - time-locale-compat tls transformers transformers-base transformers-compat + turtle unix unix-compat unix-time @@ -215,6 +237,67 @@ SHA LICENSE file: ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +StateVar LICENSE file: + + Copyright (c) 2014-2015, Edward Kmett + Copyright (c) 2009-2016, Sven Panne + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + 1. Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + + 3. Neither the name of the author nor the names of its contributors may be + used to endorse or promote products derived from this software without + specific prior written permission. + + 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. + +adjunctions LICENSE file: + + Copyright 2011-2014 Edward Kmett + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + + THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``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 AUTHORS 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. + aeson LICENSE file: Copyright (c) 2011, MailRank, Inc. @@ -762,6 +845,29 @@ base-compat LICENSE file: OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. +base-orphans LICENSE file: + + Copyright (c) 2015-2016 Simon Hengel <sol@typeful.net>, João Cristóvão <jmacristovao@gmail.com>, Ryan Scott <ryan.gl.scott@gmail.com> + + Permission is hereby granted, free of charge, to any person obtaining + a copy of this software and associated documentation files (the + "Software"), to deal in the Software without restriction, including + without limitation the rights to use, copy, modify, merge, publish, + distribute, sublicense, and/or sell copies of the Software, and to + permit persons to whom the Software is furnished to do so, subject to + the following conditions: + + The above copyright notice and this permission notice shall be included + in all copies or substantial portions of the Software. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, + EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF + MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. + IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY + CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, + TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE + SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. + base64-bytestring LICENSE file: Copyright (c) 2010 Bryan O'Sullivan <bos@serpentine.com> @@ -795,6 +901,35 @@ base64-bytestring LICENSE file: ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +bifunctors LICENSE file: + + Copyright 2008-2016 Edward Kmett + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + + THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``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 AUTHORS 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. + binary LICENSE file: Copyright (c) Lennart Kolmodin @@ -1244,6 +1379,36 @@ cmdargs LICENSE file: (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +comonad LICENSE file: + + Copyright 2008-2014 Edward Kmett + Copyright 2004-2008 Dave Menendez + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + + THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``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 AUTHORS 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. + conduit LICENSE file: Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/ @@ -1354,6 +1519,39 @@ containers LICENSE file: OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +contravariant LICENSE file: + + Copyright 2007-2015 Edward Kmett + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + + 3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``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 AUTHORS 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. + cookie LICENSE file: Copyright (c) 2010 Michael Snoyman, http://www.yesodweb.com/ @@ -1426,16 +1624,16 @@ data-default-class LICENSE file: may be used to endorse or promote products derived from this software without specific prior written permission. - 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 + THIS SOFTWARE IS PROVIDED BY LUKAS MAI 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 HOLDERS 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. + DISCLAIMED. IN NO EVENT SHALL THE REGENTS 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. data-ordlist LICENSE file: @@ -1558,9 +1756,38 @@ directory LICENSE file: ----------------------------------------------------------------------------- +distributive LICENSE file: + + Copyright 2011-2016 Edward Kmett + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + + THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``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 AUTHORS 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. + dlist LICENSE file: - Copyright (c) 2006-2009 Don Stewart, 2013-2016 Sean Leather + Copyright (c) 2006-2009 Don Stewart, 2013-2014 Sean Leather All rights reserved. @@ -1842,6 +2069,66 @@ filepath LICENSE file: (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +foldl LICENSE file: + + Copyright (c) 2013 Gabriel Gonzalez + All rights reserved. + + Redistribution and use in source and binary forms, with or without modification, + are permitted provided that the following conditions are met: + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + * Neither the name of Gabriel Gonzalez nor the names of other contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + 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. + +free LICENSE file: + + Copyright 2008-2013 Edward Kmett + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + + 3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``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 AUTHORS 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. + fsnotify LICENSE file: Copyright (c) 2012, Mark Dittmer @@ -2001,40 +2288,93 @@ haskeline LICENSE file: hex LICENSE file: - Page not found: Sorry, it's just not here. - -hfsevents LICENSE file: - - Copyright (c) 2012, Luite Stegeman - + Copyright (c) 2008, Taru Karttunen All rights reserved. Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions are met: + modification, are permitted provided that the following conditions + are met: - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. + Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. + Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. - * Neither the name of Luite Stegeman nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. + Neither the name of the Taru Karttunen; nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. 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. + 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. + +hinotify LICENSE file: + + Copyright (c) Lennart Kolmodin + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + + 3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE 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 AUTHORS 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. + +hostname LICENSE file: + + Copyright (c) 2008, Maximilian Bolingbroke + All rights reserved. + + Redistribution and use in source and binary forms, with or without modification, are permitted + provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, this list of + conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright notice, this list of + conditions and the following disclaimer in the documentation and/or other materials + provided with the distribution. + * Neither the name of Maximilian Bolingbroke nor the names of other contributors may be used to + endorse or promote products derived from this software without specific prior written permission. + + 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. hourglass LICENSE file: @@ -2275,6 +2615,39 @@ iproute LICENSE file: ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +kan-extensions LICENSE file: + + Copyright 2008-2013 Edward Kmett + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + + 3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``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 AUTHORS 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. + language-javascript LICENSE file: Copyright (c)2010, Alan Zimmerman @@ -2308,6 +2681,39 @@ language-javascript LICENSE file: (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +lens LICENSE file: + + Copyright 2012-2015 Edward Kmett + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + + 3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``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 AUTHORS 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. + lifted-base LICENSE file: Copyright © 2010-2012, Bas van Dijk, Anders Kaseorg @@ -2340,6 +2746,33 @@ lifted-base LICENSE file: (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +managed LICENSE file: + + Copyright (c) 2014 Gabriel Gonzalez + All rights reserved. + + Redistribution and use in source and binary forms, with or without modification, + are permitted provided that the following conditions are met: + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + * Neither the name of Gabriel Gonzalez nor the names of other contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + 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. + memory LICENSE file: Copyright (c) 2015 Vincent Hanquez <vincent@snarc.org> @@ -2477,10 +2910,6 @@ monad-logger LICENSE file: OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -monad-loops LICENSE file: - - Page not found: Sorry, it's just not here. - mtl LICENSE file: The Glasgow Haskell Compiler License @@ -2515,6 +2944,35 @@ mtl LICENSE file: OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +mwc-random LICENSE file: + + Copyright (c) 2009, Bryan O'Sullivan + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + 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. + network LICENSE file: Copyright (c) 2002-2010, The University Court of the University of Glasgow. @@ -2711,6 +3169,33 @@ old-time LICENSE file: ----------------------------------------------------------------------------- +optional-args LICENSE file: + + Copyright (c) 2015 Gabriel Gonzalez + All rights reserved. + + Redistribution and use in source and binary forms, with or without modification, + are permitted provided that the following conditions are met: + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + * Neither the name of Gabriel Gonzalez nor the names of other contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + 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. + optparse-applicative LICENSE file: Copyright (c) 2012, Paolo Capriotti @@ -2865,7 +3350,7 @@ pem LICENSE file: pipes LICENSE file: - Copyright (c) 2012-2016 Gabriel Gonzalez + Copyright (c) 2012-2014 Gabriel Gonzalez All rights reserved. Redistribution and use in source and binary forms, with or without modification, @@ -2917,6 +3402,39 @@ pipes-http LICENSE file: (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +prelude-extras LICENSE file: + + Copyright 2011-2016 Edward Kmett + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + + 3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``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 AUTHORS 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. + primitive LICENSE file: Copyright (c) 2008-2009, Roman Leshchinskiy @@ -3016,6 +3534,39 @@ process LICENSE file: ----------------------------------------------------------------------------- +profunctors LICENSE file: + + Copyright 2011-2015 Edward Kmett + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + + 3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``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 AUTHORS 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. + protolude LICENSE file: Copyright (c) 2016, Stephen Diehl @@ -3138,6 +3689,40 @@ random LICENSE file: ----------------------------------------------------------------------------- +reflection LICENSE file: + + Copyright (c) 2009-2013 Edward Kmett + Copyright (c) 2004 Oleg Kiselyov and Chung-chieh Shan + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are + met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Edward Kmett nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + + 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. + regex-base LICENSE file: This modile is under this "3 clause" BSD license: @@ -3203,7 +3788,7 @@ resourcet LICENSE file: safe LICENSE file: - Copyright Neil Mitchell 2007-2015. + Copyright Neil Mitchell 2007-2016. All rights reserved. Redistribution and use in source and binary forms, with or without @@ -3267,6 +3852,35 @@ scientific LICENSE file: (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +semigroupoids LICENSE file: + + Copyright 2011-2015 Edward Kmett + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions + are met: + + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + + THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``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 AUTHORS 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. + semigroups LICENSE file: Copyright 2011-2015 Edward Kmett @@ -3552,7 +4166,36 @@ streaming-commons LICENSE file: stringsearch LICENSE file: - Page not found: Sorry, it's just not here. + Copyright (c)2010, Daniel Fischer + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Daniel Fischer nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + + 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. syb LICENSE file: @@ -3640,6 +4283,56 @@ syb LICENSE file: ----------------------------------------------------------------------------- +system-fileio LICENSE file: + + Copyright (c) 2011 John Millikin + + Permission is hereby granted, free of charge, to any person + obtaining a copy of this software and associated documentation + files (the "Software"), to deal in the Software without + restriction, including without limitation the rights to use, + copy, modify, merge, publish, distribute, sublicense, and/or sell + copies of the Software, and to permit persons to whom the + Software is furnished to do so, subject to the following + conditions: + + The above copyright notice and this permission notice shall be + included in all copies or substantial portions of the Software. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, + EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES + OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND + NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT + HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, + WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING + FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR + OTHER DEALINGS IN THE SOFTWARE. + +system-filepath LICENSE file: + + Copyright (c) 2010 John Millikin + + Permission is hereby granted, free of charge, to any person + obtaining a copy of this software and associated documentation + files (the "Software"), to deal in the Software without + restriction, including without limitation the rights to use, + copy, modify, merge, publish, distribute, sublicense, and/or sell + copies of the Software, and to permit persons to whom the + Software is furnished to do so, subject to the following + conditions: + + The above copyright notice and this permission notice shall be + included in all copies or substantial portions of the Software. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, + EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES + OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND + NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT + HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, + WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING + FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR + OTHER DEALINGS IN THE SOFTWARE. + tagged LICENSE file: Copyright (c) 2009-2015 Edward Kmett @@ -3709,6 +4402,31 @@ template-haskell LICENSE file: DAMAGE. +temporary LICENSE file: + + Copyright (c) 2008, Maximilian Bolingbroke + All rights reserved. + + Redistribution and use in source and binary forms, with or without modification, are permitted + provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, this list of + conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright notice, this list of + conditions and the following disclaimer in the documentation and/or other materials + provided with the distribution. + * Neither the name of Maximilian Bolingbroke nor the names of other contributors may be used to + endorse or promote products derived from this software without specific prior written permission. + + 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. + terminfo LICENSE file: Copyright 2007, Judah Jacobson. @@ -3777,39 +4495,6 @@ time LICENSE file: 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. -time-locale-compat LICENSE file: - - Copyright (c) 2014, Kei Hibino - - All rights reserved. - - Redistribution and use in source and binary forms, with or without - modification, are permitted provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Kei Hibino nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - - 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. - tls LICENSE file: Copyright (c) 2010-2015 Vincent Hanquez <vincent@snarc.org> @@ -3906,7 +4591,7 @@ transformers-base LICENSE file: transformers-compat LICENSE file: - Copyright 2012-2015 Edward Kmett + Copyright 2012 Edward Kmett All rights reserved. @@ -3937,6 +4622,33 @@ transformers-compat LICENSE file: ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +turtle LICENSE file: + + Copyright (c) 2015 Gabriel Gonzalez + All rights reserved. + + Redistribution and use in source and binary forms, with or without modification, + are permitted provided that the following conditions are met: + * Redistributions of source code must retain the above copyright notice, + this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + * Neither the name of Gabriel Gonzalez nor the names of other contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + + 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. + unix LICENSE file: The Glasgow Haskell Compiler License @@ -4343,7 +5055,36 @@ warp LICENSE file: websockets LICENSE file: - Page not found: Sorry, it's just not here. + Copyright Jasper Van der Jeugt, 2011 + + All rights reserved. + + Redistribution and use in source and binary forms, with or without + modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Siniša Biđin nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + + 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. word8 LICENSE file: @@ -4499,7 +5240,7 @@ x509-validation LICENSE file: zlib LICENSE file: - Copyright (c) 2006-2015, Duncan Coutts + Copyright (c) 2006-2016, Duncan Coutts All rights reserved. Redistribution and use in source and binary forms, with or without @@ -4,10 +4,6 @@ A small strongly typed programming language with expressive types that compiles [](http://hackage.haskell.org/package/purescript) [](http://travis-ci.org/purescript/purescript) -[](http://stackage.org/lts-2/package/purescript) -[](http://stackage.org/lts-3/package/purescript) -[](http://stackage.org/nightly/package/purescript) - ## Language info - [PureScript home](http://purescript.org) diff --git a/examples/docs/src/DocComments.purs b/examples/docs/src/DocComments.purs new file mode 100644 index 0000000..4bc2e93 --- /dev/null +++ b/examples/docs/src/DocComments.purs @@ -0,0 +1,11 @@ +module DocComments where + +-- | This declaration has a code block: +-- | +-- | example == 0 +-- | +-- | Here we are really testing that the leading whitespace is not stripped, as +-- | this ensures that we don't accidentally change code blocks into normal +-- | paragraphs. +example :: Int +example = 0 diff --git a/examples/failing/DiffKindsSameName.purs b/examples/failing/DiffKindsSameName.purs new file mode 100644 index 0000000..afcf48a --- /dev/null +++ b/examples/failing/DiffKindsSameName.purs @@ -0,0 +1,15 @@ +-- @shouldFailWith KindsDoNotUnify +module DiffKindsSameName where + +import DiffKindsSameName.LibA as LibA +import DiffKindsSameName.LibB as LibB + +-- both `LibA` and `LibB` define a kind locally called `DemoKind` +-- `LibB` defines `DemoData :: LibB.DemoKind` +-- if we try to use `DemoData` in a place where `LibA.DemoKind` is expected, it should fail with `KindsDoNotUnify` + +data AProxy (m :: LibA.DemoKind) = AProxy + +bProxy :: AProxy LibB.DemoData +bProxy = AProxy + diff --git a/examples/failing/DiffKindsSameName/LibA.purs b/examples/failing/DiffKindsSameName/LibA.purs new file mode 100644 index 0000000..d36b2ec --- /dev/null +++ b/examples/failing/DiffKindsSameName/LibA.purs @@ -0,0 +1,4 @@ +module DiffKindsSameName.LibA where + +foreign import kind DemoKind + diff --git a/examples/failing/DiffKindsSameName/LibB.purs b/examples/failing/DiffKindsSameName/LibB.purs new file mode 100644 index 0000000..52bcb0f --- /dev/null +++ b/examples/failing/DiffKindsSameName/LibB.purs @@ -0,0 +1,6 @@ +module DiffKindsSameName.LibB where + +foreign import kind DemoKind + +foreign import data DemoData :: DemoKind + diff --git a/examples/failing/OrphanInstanceFunDepCycle.purs b/examples/failing/OrphanInstanceFunDepCycle.purs new file mode 100644 index 0000000..c11877c --- /dev/null +++ b/examples/failing/OrphanInstanceFunDepCycle.purs @@ -0,0 +1,5 @@ +-- @shouldFailWith OrphanInstance +module Main where +import Lib +data L +instance clr :: C L R diff --git a/examples/failing/OrphanInstanceFunDepCycle/Lib.purs b/examples/failing/OrphanInstanceFunDepCycle/Lib.purs new file mode 100644 index 0000000..5c77a8d --- /dev/null +++ b/examples/failing/OrphanInstanceFunDepCycle/Lib.purs @@ -0,0 +1,4 @@ +module Lib where +-- covering sets: {{l}, {r}} +class C l r | l -> r, r -> l +data R diff --git a/examples/failing/OrphanInstanceNullary.purs b/examples/failing/OrphanInstanceNullary.purs new file mode 100644 index 0000000..cd2e6af --- /dev/null +++ b/examples/failing/OrphanInstanceNullary.purs @@ -0,0 +1,4 @@ +-- @shouldFailWith OrphanInstance
+module Test where
+import Lib
+instance c :: C
diff --git a/examples/failing/OrphanInstanceNullary/Lib.purs b/examples/failing/OrphanInstanceNullary/Lib.purs new file mode 100644 index 0000000..b96dc89 --- /dev/null +++ b/examples/failing/OrphanInstanceNullary/Lib.purs @@ -0,0 +1,2 @@ +module Lib where
+class C
diff --git a/examples/failing/OrphanInstanceWithDetermined.purs b/examples/failing/OrphanInstanceWithDetermined.purs new file mode 100644 index 0000000..f905fd5 --- /dev/null +++ b/examples/failing/OrphanInstanceWithDetermined.purs @@ -0,0 +1,5 @@ +-- @shouldFailWith OrphanInstance +module Main where +import Lib +data R +instance cflr :: C F L R diff --git a/examples/failing/OrphanInstanceWithDetermined/Lib.purs b/examples/failing/OrphanInstanceWithDetermined/Lib.purs new file mode 100644 index 0000000..03b701f --- /dev/null +++ b/examples/failing/OrphanInstanceWithDetermined/Lib.purs @@ -0,0 +1,5 @@ +module Lib where +-- covering sets: {{f, l}} +class C f l r | l -> r +data F +data L diff --git a/examples/passing/DeriveNewtype.purs b/examples/passing/DeriveNewtype.purs index bdcdce4..3f0648c 100644 --- a/examples/passing/DeriveNewtype.purs +++ b/examples/passing/DeriveNewtype.purs @@ -4,7 +4,9 @@ import Control.Monad.Eff.Console (log) import Data.Newtype -newtype Test = Test String +type MyString = String + +newtype Test = Test MyString derive instance newtypeTest :: Newtype Test _ diff --git a/examples/passing/DeriveWithNestedSynonyms.purs b/examples/passing/DeriveWithNestedSynonyms.purs new file mode 100644 index 0000000..c23c8e3 --- /dev/null +++ b/examples/passing/DeriveWithNestedSynonyms.purs @@ -0,0 +1,29 @@ +module Main where + +import Prelude +import Control.Monad.Eff.Console (log) + +type L = {} +data X = X L +derive instance eqX :: Eq X + +type M = {} +data Y = Y {foo :: M} +derive instance eqY :: Eq Y + +type N = {} +data Z = Z N +derive instance eqZ :: Eq Z + +type Foo = String + +type Bar = { foo :: Foo } + +type Baz = { baz :: Bar } + +newtype T = T Baz + +derive instance eqT :: Eq T +derive instance ordT :: Ord T + +main = log "Done" diff --git a/examples/passing/Deriving.purs b/examples/passing/Deriving.purs index 2609cf3..9630699 100644 --- a/examples/passing/Deriving.purs +++ b/examples/passing/Deriving.purs @@ -10,7 +10,9 @@ derive instance eqV :: Eq V derive instance ordV :: Ord V -data X = X Int | Y String +type MyString = String + +data X = X Int | Y MyString derive instance eqX :: Eq X diff --git a/examples/passing/DerivingFunctor.purs b/examples/passing/DerivingFunctor.purs new file mode 100644 index 0000000..bd40cac --- /dev/null +++ b/examples/passing/DerivingFunctor.purs @@ -0,0 +1,28 @@ +module Main where + +import Prelude +import Control.Monad.Eff.Console (log) +import Test.Assert + +type MyRecord a = { myField :: a } + +data M f a + = M0 a (Array a) + | M1 Int + | M2 (f a) + | M3 { foo :: Int, bar :: a, baz :: f a } + | M4 (MyRecord a) + +derive instance eqM :: (Eq (f a), Eq a) => Eq (M f a) + +derive instance functorM :: Functor f => Functor (M f) + +type MA = M Array + +main = do + assert $ map show (M0 0 [1, 2] :: MA Int) == M0 "0" ["1", "2"] + assert $ map show (M1 0 :: MA Int) == M1 0 + assert $ map show (M2 [0, 1] :: MA Int) == M2 ["0", "1"] + assert $ map show (M3 {foo: 0, bar: 1, baz: [2, 3]} :: MA Int) == M3 {foo: 0, bar: "1", baz: ["2", "3"]} + assert $ map show (M4 { myField: 42 }) == M4 { myField: "42" } :: MA String + log "Done" diff --git a/examples/passing/EntailsKindedType.purs b/examples/passing/EntailsKindedType.purs new file mode 100644 index 0000000..cd2489a --- /dev/null +++ b/examples/passing/EntailsKindedType.purs @@ -0,0 +1,11 @@ +module Main where + +import Prelude +import Control.Monad.Eff +import Control.Monad.Eff.Console + +test x = show (x :: _ :: *) + +main = do + when (show (unit :: Unit :: *) == "unit") (log "Done") + when (test unit == "unit") (log "Done") diff --git a/examples/passing/ForeignKind.purs b/examples/passing/ForeignKind.purs new file mode 100644 index 0000000..0b91f7d --- /dev/null +++ b/examples/passing/ForeignKind.purs @@ -0,0 +1,10 @@ +module Main where + +import Prelude +import ForeignKinds.Lib (kind Nat, Zero, Succ, N3, NatProxy, class AddNat, addNat, proxy1, proxy2) +import Control.Monad.Eff.Console (log) + +proxy1Add2Is3 :: NatProxy N3 +proxy1Add2Is3 = addNat proxy1 proxy2 + +main = log "Done" diff --git a/examples/passing/ForeignKind/Lib.purs b/examples/passing/ForeignKind/Lib.purs new file mode 100644 index 0000000..0ca2c13 --- /dev/null +++ b/examples/passing/ForeignKind/Lib.purs @@ -0,0 +1,60 @@ +module ForeignKinds.Lib (kind Nat, Kinded, Zero, Succ, N0, N1, N2, N3, NatProxy(..), class AddNat, addNat, proxy1, proxy2) where + +-- declaration + +foreign import kind Nat + +-- use in foreign data + +foreign import data Zero :: Nat +foreign import data Succ :: Nat -> Nat + +-- use in data + +data NatProxy (t :: Nat) = NatProxy + +-- use in type sig + +succProxy :: forall n. NatProxy n -> NatProxy (Succ n) +succProxy _ = NatProxy + +-- use in alias + +type Kinded f = f :: Nat + +type KindedZero = Kinded Zero + +type N0 = Zero +type N1 = Succ N0 +type N2 = Succ N1 +type N3 = Succ N2 + +-- use of alias + +proxy0 :: NatProxy N0 +proxy0 = NatProxy + +proxy1 :: NatProxy N1 +proxy1 = NatProxy + +proxy2 :: NatProxy N2 +proxy2 = NatProxy + +proxy3 :: NatProxy N3 +proxy3 = NatProxy + +-- use in class + +class AddNat (l :: Nat) (r :: Nat) (o :: Nat) | l -> r o + +instance addNatZero + :: AddNat Zero r r + +instance addNatSucc + :: AddNat l r o + => AddNat (Succ l) r (Succ o) + +-- use of class + +addNat :: forall l r o. AddNat l r o => NatProxy l -> NatProxy r -> NatProxy o +addNat _ _ = NatProxy diff --git a/examples/passing/GenericsRep.purs b/examples/passing/GenericsRep.purs index 4f60106..be75d86 100644 --- a/examples/passing/GenericsRep.purs +++ b/examples/passing/GenericsRep.purs @@ -27,7 +27,9 @@ derive instance genericZ :: Generic Z _ instance eqZ :: Eq Z where eq x y = genericEq x y -newtype W = W { x :: Int, y :: String } +type MyString = String + +newtype W = W { x :: Int, y :: MyString } derive instance genericW :: Generic W _ diff --git a/examples/passing/HasOwnProperty.purs b/examples/passing/HasOwnProperty.purs new file mode 100644 index 0000000..6a70fb7 --- /dev/null +++ b/examples/passing/HasOwnProperty.purs @@ -0,0 +1,5 @@ +module Main where + +import Control.Monad.Eff.Console (log) + +main = log ({hasOwnProperty: "Hi"} {hasOwnProperty = "Done"}).hasOwnProperty diff --git a/examples/passing/NewtypeInstance.purs b/examples/passing/NewtypeInstance.purs index 8a83399..f7b9ea8 100644 --- a/examples/passing/NewtypeInstance.purs +++ b/examples/passing/NewtypeInstance.purs @@ -4,7 +4,9 @@ import Prelude import Control.Monad.Eff import Control.Monad.Eff.Console -newtype X = X String +type MyString = String + +newtype X = X MyString derive newtype instance showX :: Show X diff --git a/examples/passing/NonOrphanInstanceFunDepExtra.purs b/examples/passing/NonOrphanInstanceFunDepExtra.purs new file mode 100644 index 0000000..eb86ead --- /dev/null +++ b/examples/passing/NonOrphanInstanceFunDepExtra.purs @@ -0,0 +1,8 @@ +-- Both f and l must be known, thus can be in separate modules +module Main where +import Control.Monad.Eff.Console (log) +import Lib +data F +data R +instance cflr :: C F L R +main = log "Done" diff --git a/examples/passing/NonOrphanInstanceFunDepExtra/Lib.purs b/examples/passing/NonOrphanInstanceFunDepExtra/Lib.purs new file mode 100644 index 0000000..5909771 --- /dev/null +++ b/examples/passing/NonOrphanInstanceFunDepExtra/Lib.purs @@ -0,0 +1,4 @@ +module Lib where +-- covering sets: {{f, l}} +class C f l r | l -> r +data L diff --git a/examples/passing/NonOrphanInstanceMulti.purs b/examples/passing/NonOrphanInstanceMulti.purs new file mode 100644 index 0000000..71d5634 --- /dev/null +++ b/examples/passing/NonOrphanInstanceMulti.purs @@ -0,0 +1,7 @@ +-- Both l and r must be known, thus can be in separate modules +module Main where +import Control.Monad.Eff.Console (log) +import Lib +data L +instance clr :: C L R +main = log "Done" diff --git a/examples/passing/NonOrphanInstanceMulti/Lib.purs b/examples/passing/NonOrphanInstanceMulti/Lib.purs new file mode 100644 index 0000000..49b5b73 --- /dev/null +++ b/examples/passing/NonOrphanInstanceMulti/Lib.purs @@ -0,0 +1,4 @@ +module Lib where +-- covering sets: {{l, r}} +class C l r +data R diff --git a/examples/passing/SolvingAppendSymbol.purs b/examples/passing/SolvingAppendSymbol.purs new file mode 100644 index 0000000..41fa545 --- /dev/null +++ b/examples/passing/SolvingAppendSymbol.purs @@ -0,0 +1,32 @@ +module Main where + +import Prelude +import Control.Monad.Eff.Console (log) +import Type.Data.Symbol (SProxy(..), class AppendSymbol, appendSymbol, reflectSymbol) + +sym :: SProxy "" +sym = SProxy + +symA :: SProxy "A" +symA = SProxy + +symB :: SProxy "B" +symB = SProxy + +egAB :: SProxy "AB" +egAB = appendSymbol symA symB + +egBA :: SProxy "BA" +egBA = appendSymbol symB symA + +egA' :: SProxy "A" +egA' = appendSymbol sym (appendSymbol symA sym) + +main = do + let gotAB = reflectSymbol egAB == "AB" + gotBA = reflectSymbol egBA == "BA" + gotA' = reflectSymbol egA' == "A" + when (not gotAB) $ log "Did not get AB" + when (not gotBA) $ log "Did not get BA" + when (not gotA') $ log "Did not get A" + when (gotAB && gotBA && gotA') $ log "Done" diff --git a/examples/passing/SolvingCompareSymbol.purs b/examples/passing/SolvingCompareSymbol.purs new file mode 100644 index 0000000..24ffece --- /dev/null +++ b/examples/passing/SolvingCompareSymbol.purs @@ -0,0 +1,30 @@ +module Main where + +import Prelude +import Control.Monad.Eff.Console (log) +import Type.Data.Symbol (SProxy(..), class CompareSymbol, compareSymbol) +import Type.Data.Ordering (OProxy(..), kind Ordering, LT, EQ, GT, reflectOrdering) + +symA :: SProxy "A" +symA = SProxy + +symB :: SProxy "B" +symB = SProxy + +egLT :: OProxy LT +egLT = compareSymbol symA symB + +egEQ :: OProxy EQ +egEQ = compareSymbol symA symA + +egGT :: OProxy GT +egGT = compareSymbol symB symA + +main = do + let gotLT = reflectOrdering egLT == LT + gotEQ = reflectOrdering egEQ == EQ + gotGT = reflectOrdering egGT == GT + when (not gotLT) $ log "Did not get LT" + when (not gotEQ) $ log "Did not get EQ" + when (not gotGT) $ log "Did not get GT" + when (gotLT && gotEQ && gotGT) $ log "Done" diff --git a/psc-bundle/Main.hs b/psc-bundle/Main.hs index ab4a09a..2bd9428 100644 --- a/psc-bundle/Main.hs +++ b/psc-bundle/Main.hs @@ -9,6 +9,8 @@ module Main (main) where import Data.Traversable (for) import Data.Version (showVersion) import Data.Monoid ((<>)) +import Data.Aeson (encode) +import Data.Maybe (isNothing) import Control.Applicative import Control.Monad @@ -16,12 +18,15 @@ import Control.Monad.Error.Class import Control.Monad.Trans.Except import Control.Monad.IO.Class -import System.FilePath (takeDirectory) +import System.FilePath (takeDirectory, (</>), (<.>), takeFileName) import System.FilePath.Glob (glob) import System.Exit (exitFailure) import System.IO (stderr, stdout, hPutStrLn, hSetEncoding, utf8) import System.IO.UTF8 (readUTF8File, writeUTF8File) -import System.Directory (createDirectoryIfMissing) +import System.Directory (createDirectoryIfMissing, getCurrentDirectory) + +import qualified Data.ByteString.Lazy as B +import qualified Data.ByteString.UTF8 as BU8 import Language.PureScript.Bundle @@ -30,6 +35,9 @@ import qualified Options.Applicative as Opts import qualified Paths_purescript as Paths +import SourceMap +import SourceMap.Types + -- | Command line options. data Options = Options { optionsInputFiles :: [FilePath] @@ -37,25 +45,32 @@ data Options = Options , optionsEntryPoints :: [String] , optionsMainModule :: Maybe String , optionsNamespace :: String + , optionsSourceMaps :: Bool } deriving Show -- | The main application function. -- This function parses the input files, performs dead code elimination, filters empty modules -- and generates and prints the final Javascript bundle. -app :: (MonadError ErrorMessage m, MonadIO m) => Options -> m String +app :: (MonadError ErrorMessage m, MonadIO m) => Options -> m (Maybe SourceMapping, String) app Options{..} = do inputFiles <- concat <$> mapM (liftIO . glob) optionsInputFiles when (null inputFiles) . liftIO $ do hPutStrLn stderr "psc-bundle: No input files." exitFailure + when (isNothing optionsOutputFile && optionsSourceMaps == True) . liftIO $ do + hPutStrLn stderr "psc-bundle: Source maps only supported when output file specified." + exitFailure + input <- for inputFiles $ \filename -> do js <- liftIO (readUTF8File filename) mid <- guessModuleIdentifier filename - length js `seq` return (mid, js) -- evaluate readFile till EOF before returning, not to exhaust file handles + length js `seq` return (mid, Just filename, js) -- evaluate readFile till EOF before returning, not to exhaust file handles let entryIds = map (`ModuleIdentifier` Regular) optionsEntryPoints - bundle input entryIds optionsMainModule optionsNamespace + currentDir <- liftIO getCurrentDirectory + let outFile = if optionsSourceMaps then fmap (currentDir </>) optionsOutputFile else Nothing + bundleSM input entryIds optionsMainModule optionsNamespace outFile -- | Command line options parser. options :: Parser Options @@ -64,6 +79,7 @@ options = Options <$> some inputFile <*> many entryPoint <*> optional mainModule <*> namespace + <*> sourceMaps where inputFile :: Parser FilePath inputFile = Opts.strArgument $ @@ -95,6 +111,11 @@ options = Options <$> some inputFile <> Opts.showDefault <> Opts.help "Specify the namespace that PureScript modules will be exported to when running in the browser." + sourceMaps :: Parser Bool + sourceMaps = Opts.switch $ + Opts.long "source-maps" + <> Opts.help "Whether to generate source maps for the bundle (requires --output)." + -- | Make it go. main :: IO () main = do @@ -106,11 +127,15 @@ main = do Left err -> do hPutStrLn stderr (unlines (printErrorMessage err)) exitFailure - Right js -> + Right (sourcemap, js) -> case optionsOutputFile opts of Just outputFile -> do createDirectoryIfMissing True (takeDirectory outputFile) - writeUTF8File outputFile js + case sourcemap of + Just sm -> do + writeUTF8File outputFile $ js ++ "\n//# sourceMappingURL=" ++ (takeFileName outputFile <.> "map") ++ "\n" + writeUTF8File (outputFile <.> "map") $ BU8.toString . B.toStrict . encode $ generate sm + Nothing -> writeUTF8File outputFile js Nothing -> putStrLn js where infoModList = Opts.fullDesc <> headerInfo <> footerInfo diff --git a/psc-docs/Main.hs b/psc-docs/Main.hs index ff557bc..a1ca8ec 100644 --- a/psc-docs/Main.hs +++ b/psc-docs/Main.hs @@ -9,6 +9,7 @@ import Control.Category ((>>>)) import Control.Monad.Writer import Data.Text (Text) import qualified Data.Text as T +import qualified Data.Text.IO as T import Data.Function (on) import Data.List import Data.Maybe (fromMaybe) @@ -22,7 +23,7 @@ import qualified Language.PureScript as P import qualified Paths_purescript as Paths import System.Exit (exitFailure) import System.IO (hPutStrLn, hPrint, hSetEncoding, stderr, stdout, utf8) -import System.IO.UTF8 (readUTF8FileT) +import System.IO.UTF8 (readUTF8FileT, writeUTF8FileT) import System.Directory (createDirectoryIfMissing) import System.FilePath (takeDirectory) import System.FilePath.Glob (glob) @@ -65,11 +66,11 @@ docgen (PSCDocsOptions fmt inputGlob output) = do case output of EverythingToStdOut -> - putStrLn (D.runDocs (D.modulesAsMarkdown ms)) + T.putStrLn (D.runDocs (D.modulesAsMarkdown ms)) ToStdOut names -> do let (ms', missing) = takeByName ms names guardMissing missing - putStrLn (D.runDocs (D.modulesAsMarkdown ms')) + T.putStrLn (D.runDocs (D.modulesAsMarkdown ms')) ToFiles names -> do let (ms', missing) = takeByName' ms names guardMissing missing @@ -78,7 +79,7 @@ docgen (PSCDocsOptions fmt inputGlob output) = do forM_ ms'' $ \grp -> do let fp = fst (head grp) createDirectoryIfMissing True (takeDirectory fp) - writeFile fp (D.runDocs (D.modulesAsMarkdown (map snd grp))) + writeUTF8FileT fp (D.runDocs (D.modulesAsMarkdown (map snd grp))) where guardMissing [] = return () diff --git a/psc-docs/Tags.hs b/psc-docs/Tags.hs index df5d2be..5bee382 100644 --- a/psc-docs/Tags.hs +++ b/psc-docs/Tags.hs @@ -17,4 +17,5 @@ tags = map (first T.unpack) . concatMap dtags . P.exportedDeclarations names (P.TypeSynonymDeclaration name _ _) = [P.runProperName name] names (P.TypeClassDeclaration name _ _ _ _) = [P.runProperName name] names (P.TypeInstanceDeclaration name _ _ _ _) = [P.showIdent name] + names (P.ExternKindDeclaration name) = [P.runProperName name] names _ = [] diff --git a/psc-package/Main.hs b/psc-package/Main.hs index b6b7943..71d9560 100644 --- a/psc-package/Main.hs +++ b/psc-package/Main.hs @@ -7,17 +7,20 @@ module Main where +import qualified Control.Foldl as Foldl import qualified Data.Aeson as Aeson import Data.Aeson.Encode.Pretty import Data.Foldable (fold, for_, traverse_) import Data.List (nub) import qualified Data.Map as Map -import Data.Maybe (mapMaybe) +import Data.Maybe (fromMaybe, mapMaybe) import qualified Data.Set as Set import Data.Text (pack) +import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8) import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Builder as TB -import Data.Text.Encoding (encodeUtf8) +import qualified Data.Text.Read as TR import Data.Traversable (for) import Data.Version (showVersion) import qualified Filesystem.Path.CurrentOS as Path @@ -25,7 +28,8 @@ import GHC.Generics (Generic) import qualified Options.Applicative as Opts import qualified Paths_purescript as Paths import qualified System.IO as IO -import Turtle hiding (fold) +import Turtle hiding (fold, s, x) +import qualified Turtle packageFile :: Path.FilePath packageFile = "psc-package.json" @@ -61,8 +65,8 @@ readPackageFile = do exit (ExitFailure 1) Just pkg -> return pkg -encodePrettyToText :: Aeson.ToJSON json => json -> Text -encodePrettyToText = +packageConfigToJSON :: PackageConfig -> Text +packageConfigToJSON = TL.toStrict . TB.toLazyText . encodePrettyToTextBuilder' config @@ -76,10 +80,18 @@ encodePrettyToText = ] } +packageSetToJSON :: PackageSet -> Text +packageSetToJSON = + TL.toStrict + . TB.toLazyText + . encodePrettyToTextBuilder' config + where + config = defConfig { confCompare = compare } + writePackageFile :: PackageConfig -> IO () writePackageFile = writeTextFile packageFile - . encodePrettyToText + . packageConfigToJSON data PackageInfo = PackageInfo { repo :: Text @@ -108,6 +120,18 @@ cloneShallow from ref into = , pathToTextUnsafe into ] empty .||. exit (ExitFailure 1) +listRemoteTags + :: Text + -- ^ repo + -> Turtle.Shell Text +listRemoteTags from = + inproc "git" + [ "ls-remote" + , "-q" + , "-t" + , from + ] empty + getPackageSet :: PackageConfig -> IO () getPackageSet PackageConfig{ source, set } = do let pkgDir = ".psc-package" </> fromText set </> ".set" @@ -128,11 +152,18 @@ readPackageSet PackageConfig{ set } = do exit (ExitFailure 1) Just db -> return db -installOrUpdate :: PackageConfig -> Text -> PackageInfo -> IO () -installOrUpdate PackageConfig{ set } pkgName PackageInfo{ repo, version } = do +writePackageSet :: PackageConfig -> PackageSet -> IO () +writePackageSet PackageConfig{ set } = + let dbFile = ".psc-package" </> fromText set </> ".set" </> "packages.json" + in writeTextFile dbFile . packageSetToJSON + +installOrUpdate :: Text -> Text -> PackageInfo -> IO Turtle.FilePath +installOrUpdate set pkgName PackageInfo{ repo, version } = do + echo ("Updating " <> pkgName) let pkgDir = ".psc-package" </> fromText set </> fromText pkgName </> fromText version exists <- testdir pkgDir unless exists . void $ cloneShallow repo version pkgDir + pure pkgDir getTransitiveDeps :: PackageSet -> [Text] -> IO [(Text, PackageInfo)] getTransitiveDeps db depends = do @@ -151,9 +182,7 @@ updateImpl config@PackageConfig{ depends } = do db <- readPackageSet config trans <- getTransitiveDeps db depends echo ("Updating " <> pack (show (length trans)) <> " packages...") - for_ trans $ \(pkgName, pkg) -> do - echo ("Updating " <> pkgName) - installOrUpdate config pkgName pkg + for_ trans $ \(pkgName, pkg) -> installOrUpdate (set config) pkgName pkg initialize :: IO () initialize = do @@ -233,6 +262,101 @@ exec exeName = do (map pathToTextUnsafe ("src" </> "**" </> "*.purs" : paths)) empty +checkForUpdates :: Bool -> Bool -> IO () +checkForUpdates applyMinorUpdates applyMajorUpdates = do + pkg <- readPackageFile + db <- readPackageSet pkg + + echo ("Checking " <> pack (show (Map.size db)) <> " packages for updates.") + echo "Warning: this could take some time!" + + newDb <- Map.fromList <$> (for (Map.toList db) $ \(name, p@PackageInfo{ repo, version }) -> do + echo ("Checking package " <> name) + tagLines <- Turtle.fold (listRemoteTags repo) Foldl.list + let tags = mapMaybe parseTag tagLines + newVersion <- case parseVersion version of + Just parts -> + let applyMinor = + case filter (isMinorReleaseFrom parts) tags of + [] -> pure version + minorReleases -> do + echo ("New minor release available") + case applyMinorUpdates of + True -> do + let latestMinorRelease = maximum minorReleases + pure ("v" <> T.intercalate "." (map (pack . show) latestMinorRelease)) + False -> pure version + applyMajor = + case filter (isMajorReleaseFrom parts) tags of + [] -> applyMinor + newReleases -> do + echo ("New major release available") + case applyMajorUpdates of + True -> do + let latestRelease = maximum newReleases + pure ("v" <> T.intercalate "." (map (pack . show) latestRelease)) + False -> applyMinor + in applyMajor + _ -> do + echo "Unable to parse version string" + pure version + pure (name, p { version = newVersion })) + + when (applyMinorUpdates || applyMajorUpdates) + (writePackageSet pkg newDb) + where + parseTag :: Text -> Maybe [Int] + parseTag line = + case T.splitOn "\t" line of + [_sha, ref] -> + case T.stripPrefix "refs/tags/" ref of + Just tag -> + case parseVersion tag of + Just parts -> pure parts + _ -> Nothing + _ -> Nothing + _ -> Nothing + + parseVersion :: Text -> Maybe [Int] + parseVersion ref = + case T.stripPrefix "v" ref of + Just tag -> + traverse parseDecimal (T.splitOn "." tag) + _ -> Nothing + + parseDecimal :: Text -> Maybe Int + parseDecimal s = + case TR.decimal s of + Right (n, "") -> Just n + _ -> Nothing + + isMajorReleaseFrom :: [Int] -> [Int] -> Bool + isMajorReleaseFrom (0 : xs) (0 : ys) = isMajorReleaseFrom xs ys + isMajorReleaseFrom (x : _) (y : _) = y > x + isMajorReleaseFrom _ _ = False + + isMinorReleaseFrom :: [Int] -> [Int] -> Bool + isMinorReleaseFrom (0 : xs) (0 : ys) = isMinorReleaseFrom xs ys + isMinorReleaseFrom (x : xs) (y : ys) = y == x && ys > xs + isMinorReleaseFrom _ _ = False + +verifyPackageSet :: IO () +verifyPackageSet = do + pkg <- readPackageFile + db <- readPackageSet pkg + + echo ("Verifying " <> pack (show (Map.size db)) <> " packages.") + echo "Warning: this could take some time!" + + let installOrUpdate' (name, pkgInfo) = (name, ) <$> installOrUpdate (set pkg) name pkgInfo + paths <- Map.fromList <$> traverse installOrUpdate' (Map.toList db) + + for_ (Map.toList db) $ \(name, PackageInfo{..}) -> do + let dirFor = fromMaybe (error "verifyPackageSet: no directory") . (`Map.lookup` paths) + echo ("Verifying package " <> name) + let srcGlobs = map (pathToTextUnsafe . (</> ("src" </> "**" </> "*.purs")) . dirFor) (name : dependencies) + procs "psc" srcGlobs empty + main :: IO () main = do IO.hSetEncoding IO.stdout IO.utf8 @@ -275,8 +399,22 @@ main = do , Opts.command "available" (Opts.info (pure listPackages) (Opts.progDesc "List all packages available in the package set")) + , Opts.command "updates" + (Opts.info (checkForUpdates <$> apply <*> applyMajor) + (Opts.progDesc "Check all packages in the package set for new releases")) + , Opts.command "verify-set" + (Opts.info (pure verifyPackageSet) + (Opts.progDesc "Verify that the packages in the package set build correctly")) ] where pkg = Opts.strArgument $ Opts.metavar "PACKAGE" <> Opts.help "The name of the package to install" + + apply = Opts.switch $ + Opts.long "apply" + <> Opts.help "Apply all minor package updates" + + applyMajor = Opts.switch $ + Opts.long "apply-breaking" + <> Opts.help "Apply all major package updates" diff --git a/psc-publish/Main.hs b/psc-publish/Main.hs index dd8f663..5d2e902 100644 --- a/psc-publish/Main.hs +++ b/psc-publish/Main.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE OverloadedStrings #-} module Main where diff --git a/psci/Main.hs b/psci/Main.hs index e86f758..1a8bec8 100644 --- a/psci/Main.hs +++ b/psci/Main.hs @@ -72,10 +72,16 @@ inputFile = Opts.strArgument $ Opts.metavar "FILE" <> Opts.help "Optional .purs files to load on start" -nodeFlagsFlag :: Opts.Parser [String] -nodeFlagsFlag = Opts.option parser $ +nodePathOption :: Opts.Parser (Maybe FilePath) +nodePathOption = Opts.optional . Opts.strOption $ + Opts.metavar "FILE" + <> Opts.long "node-path" + <> Opts.help "Path to the Node executable" + +nodeFlagsOption :: Opts.Parser [String] +nodeFlagsOption = Opts.option parser $ Opts.long "node-opts" - <> Opts.metavar "NODE_OPTS" + <> Opts.metavar "OPTS" <> Opts.value [] <> Opts.help "Flags to pass to node, separated by spaces" where @@ -90,7 +96,7 @@ port = Opts.option Opts.auto $ backend :: Opts.Parser Backend backend = (browserBackend <$> port) - <|> (nodeBackend <$> nodeFlagsFlag) + <|> (nodeBackend <$> nodePathOption <*> nodeFlagsOption) psciOptions :: Opts.Parser PSCiOptions psciOptions = PSCiOptions <$> many inputFile @@ -293,8 +299,8 @@ browserBackend serverPort = Backend setup evaluate reload shutdown result <- takeMVar resultVar putStrLn result -nodeBackend :: [String] -> Backend -nodeBackend nodeArgs = Backend setup eval reload shutdown +nodeBackend :: Maybe FilePath -> [String] -> Backend +nodeBackend nodePath nodeArgs = Backend setup eval reload shutdown where setup :: IO () setup = return () @@ -302,12 +308,12 @@ nodeBackend nodeArgs = Backend setup eval reload shutdown eval :: () -> String -> IO () eval _ _ = do writeFile indexFile "require('$PSCI')['$main']();" - process <- findNodeProcess + process <- maybe findNodeProcess (pure . pure) nodePath result <- traverse (\node -> readProcessWithExitCode node (nodeArgs ++ [indexFile]) "") process case result of - Just (ExitSuccess, out, _) -> putStrLn out - Just (ExitFailure _, _, err) -> putStrLn err - Nothing -> putStrLn "Couldn't find node.js" + Just (ExitSuccess, out, _) -> putStrLn out + Just (ExitFailure _, _, err) -> putStrLn err + Nothing -> putStrLn "Couldn't find node.js" reload :: () -> IO () reload _ = return () diff --git a/psci/static/index.js b/psci/static/index.js index 08b5f1e..e6ea3ea 100644 --- a/psci/static/index.js +++ b/psci/static/index.js @@ -34,7 +34,7 @@ var evaluate = function evaluate(js) { return buffer.join('\n'); }; window.onload = function() { - var socket = new WebSocket('ws://0.0.0.0:' + location.port); + var socket = new WebSocket('ws://localhost:' + location.port); var evalNext = function reload() { get('js/latest.js', function(response) { try { diff --git a/purescript.cabal b/purescript.cabal index d39f3fe..bf50897 100644 --- a/purescript.cabal +++ b/purescript.cabal @@ -1,5 +1,5 @@ name: purescript -version: 0.10.3 +version: 0.10.4 cabal-version: >=1.8 build-type: Simple license: BSD3 @@ -28,6 +28,7 @@ extra-source-files: examples/passing/*.purs , examples/passing/ExplicitImportReExport/*.purs , examples/passing/ExportExplicit/*.purs , examples/passing/ExportExplicit2/*.purs + , examples/passing/ForeignKind/*.purs , examples/passing/Import/*.purs , examples/passing/ImportExplicit/*.purs , examples/passing/ImportQualified/*.purs @@ -39,6 +40,8 @@ extra-source-files: examples/passing/*.purs , examples/passing/ModuleExportQualified/*.purs , examples/passing/ModuleExportSelf/*.purs , examples/passing/NonConflictingExports/*.purs + , examples/passing/NonOrphanInstanceMulti/*.purs + , examples/passing/NonOrphanInstanceFunDepExtra/*.purs , examples/passing/OperatorAliasElsewhere/*.purs , examples/passing/Operators/*.purs , examples/passing/PendingConflictingImports/*.purs @@ -63,6 +66,7 @@ extra-source-files: examples/passing/*.purs , examples/failing/ConflictingImports2/*.purs , examples/failing/ConflictingQualifiedImports/*.purs , examples/failing/ConflictingQualifiedImports2/*.purs + , examples/failing/DiffKindsSameName/*.purs , examples/failing/DuplicateModule/*.purs , examples/failing/ExportConflictClass/*.purs , examples/failing/ExportConflictCtor/*.purs @@ -78,6 +82,9 @@ extra-source-files: examples/passing/*.purs , examples/failing/ImportModule/*.purs , examples/failing/InstanceExport/*.purs , examples/failing/OrphanInstance/*.purs + , examples/failing/OrphanInstanceFunDepCycle/*.purs + , examples/failing/OrphanInstanceWithDetermined/*.purs + , examples/failing/OrphanInstanceNullary/*.purs , examples/warning/*.purs , examples/warning/*.js , examples/warning/UnusedExplicitImportTypeOp/*.purs @@ -124,7 +131,7 @@ library haskeline >= 0.7.0.0, http-client >= 0.4.30 && <0.5, http-types -any, - language-javascript == 0.6.*, + language-javascript >= 0.6.0.9 && < 0.7, lens == 4.*, lifted-base >= 0.2.3 && < 0.2.4, monad-control >= 1.0.0.0 && < 1.1, @@ -250,6 +257,7 @@ library Language.PureScript.Docs.Convert Language.PureScript.Docs.Convert.Single Language.PureScript.Docs.Convert.ReExports + Language.PureScript.Docs.Prim Language.PureScript.Docs.Render Language.PureScript.Docs.Types Language.PureScript.Docs.RenderedCode @@ -426,7 +434,7 @@ executable psc-package optparse-applicative -any, system-filepath -any, text -any, - turtle -any + turtle <1.3 main-is: Main.hs other-modules: Paths_purescript buildable: True @@ -456,14 +464,19 @@ executable psc-bundle other-modules: Paths_purescript other-extensions: build-depends: base >=4 && <5, + bytestring -any, purescript -any, directory -any, + aeson >= 0.8 && < 1.0, filepath -any, Glob -any, mtl -any, optparse-applicative >= 0.12.1, + sourcemap >= 0.1.6, transformers -any, - transformers-compat -any + transformers-compat -any, + utf8-string >= 1 && < 2 + ghc-options: -Wall -O2 hs-source-dirs: psc-bundle @@ -510,6 +523,7 @@ test-suite tests aeson -any, aeson-better-errors -any, base-compat -any, + bower-json -any, boxes -any, bytestring -any, containers -any, @@ -539,6 +553,7 @@ test-suite tests other-modules: TestUtils TestCompiler TestDocs + TestPrimDocs TestPscPublish TestPsci TestPscIde diff --git a/src/Language/PureScript/AST/Declarations.hs b/src/Language/PureScript/AST/Declarations.hs index 9029b1a..781ec09 100644 --- a/src/Language/PureScript/AST/Declarations.hs +++ b/src/Language/PureScript/AST/Declarations.hs @@ -240,6 +240,10 @@ data DeclarationRef -- | ModuleRef ModuleName -- | + -- A named kind + -- + | KindRef (ProperName 'KindName) + -- | -- A value re-exported from another module. These will be inserted during -- elaboration in name desugaring. -- @@ -258,6 +262,7 @@ instance Eq DeclarationRef where (TypeClassRef name) == (TypeClassRef name') = name == name' (TypeInstanceRef name) == (TypeInstanceRef name') = name == name' (ModuleRef name) == (ModuleRef name') = name == name' + (KindRef name) == (KindRef name') = name == name' (ReExportRef mn ref) == (ReExportRef mn' ref') = mn == mn' && ref == ref' (PositionedDeclarationRef _ _ r) == r' = r == r' r == (PositionedDeclarationRef _ _ r') = r == r' @@ -274,6 +279,7 @@ compDecRef (ValueOpRef name) (ValueOpRef name') = compare name name' compDecRef (TypeClassRef name) (TypeClassRef name') = compare name name' compDecRef (TypeInstanceRef ident) (TypeInstanceRef ident') = compare ident ident' compDecRef (ModuleRef name) (ModuleRef name') = compare name name' +compDecRef (KindRef name) (KindRef name') = compare name name' compDecRef (ReExportRef name _) (ReExportRef name' _) = compare name name' compDecRef (PositionedDeclarationRef _ _ ref) ref' = compDecRef ref ref' compDecRef ref (PositionedDeclarationRef _ _ ref') = compDecRef ref ref' @@ -286,7 +292,8 @@ compDecRef ref ref' = compare orderOf (TypeRef _ _) = 2 orderOf (ValueRef _) = 3 orderOf (ValueOpRef _) = 4 - orderOf _ = 5 + orderOf (KindRef _) = 5 + orderOf _ = 6 getTypeRef :: DeclarationRef -> Maybe (ProperName 'TypeName, Maybe [ProperName 'ConstructorName]) getTypeRef (TypeRef name dctors) = Just (name, dctors) @@ -313,6 +320,11 @@ getTypeClassRef (TypeClassRef name) = Just name getTypeClassRef (PositionedDeclarationRef _ _ r) = getTypeClassRef r getTypeClassRef _ = Nothing +getKindRef :: DeclarationRef -> Maybe (ProperName 'KindName) +getKindRef (KindRef name) = Just name +getKindRef (PositionedDeclarationRef _ _ r) = getKindRef r +getKindRef _ = Nothing + isModuleRef :: DeclarationRef -> Bool isModuleRef (PositionedDeclarationRef _ _ r) = isModuleRef r isModuleRef (ModuleRef _) = True @@ -381,6 +393,10 @@ data Declaration -- | ExternDataDeclaration (ProperName 'TypeName) Kind -- | + -- A foreign kind import (name) + -- + | ExternKindDeclaration (ProperName 'KindName) + -- | -- A fixity declaration -- | FixityDeclaration (Either ValueFixity TypeFixity) @@ -470,6 +486,14 @@ isExternDataDecl (PositionedDeclaration _ _ d) = isExternDataDecl d isExternDataDecl _ = False -- | +-- Test if a declaration is a foreign kind import +-- +isExternKindDecl :: Declaration -> Bool +isExternKindDecl ExternKindDeclaration{} = True +isExternKindDecl (PositionedDeclaration _ _ d) = isExternKindDecl d +isExternKindDecl _ = False + +-- | -- Test if a declaration is a fixity declaration -- isFixityDecl :: Declaration -> Bool diff --git a/src/Language/PureScript/AST/Exported.hs b/src/Language/PureScript/AST/Exported.hs index ab9a2f3..8c7c720 100644 --- a/src/Language/PureScript/AST/Exported.hs +++ b/src/Language/PureScript/AST/Exported.hs @@ -132,6 +132,7 @@ isExported (Just exps) decl = any (matches decl) exps matches (ExternDeclaration ident _) (ValueRef ident') = ident == ident' matches (DataDeclaration _ ident _ _) (TypeRef ident' _) = ident == ident' matches (ExternDataDeclaration ident _) (TypeRef ident' _) = ident == ident' + matches (ExternKindDeclaration ident) (KindRef ident') = ident == ident' matches (TypeSynonymDeclaration ident _ _) (TypeRef ident' _) = ident == ident' matches (TypeClassDeclaration ident _ _ _ _) (TypeClassRef ident') = ident == ident' matches (ValueFixityDeclaration _ _ op) (ValueOpRef op') = op == op' diff --git a/src/Language/PureScript/AST/Traversals.hs b/src/Language/PureScript/AST/Traversals.hs index 610cd7e..e15b30d 100644 --- a/src/Language/PureScript/AST/Traversals.hs +++ b/src/Language/PureScript/AST/Traversals.hs @@ -14,11 +14,12 @@ import Data.Maybe (mapMaybe) import qualified Data.Set as S import Language.PureScript.AST.Binders -import Language.PureScript.AST.Literals import Language.PureScript.AST.Declarations -import Language.PureScript.Types -import Language.PureScript.Traversals +import Language.PureScript.AST.Literals +import Language.PureScript.Kinds import Language.PureScript.Names +import Language.PureScript.Traversals +import Language.PureScript.Types everywhereOnValues :: (Declaration -> Declaration) @@ -588,6 +589,42 @@ accumTypes f = everythingOnValues mappend forDecls forValues (const mempty) (con forValues (TypedValue _ _ ty) = f ty forValues _ = mempty +accumKinds + :: (Monoid r) + => (Kind -> r) + -> ( Declaration -> r + , Expr -> r + , Binder -> r + , CaseAlternative -> r + , DoNotationElement -> r + ) +accumKinds f = everythingOnValues mappend forDecls forValues (const mempty) (const mempty) (const mempty) + where + forDecls (DataDeclaration _ _ args dctors) = + foldMap (foldMap f . snd) args `mappend` + foldMap (foldMap forTypes . snd) dctors + forDecls (TypeClassDeclaration _ args implies _ _) = + foldMap (foldMap f . snd) args `mappend` + foldMap (foldMap forTypes . constraintArgs) implies + forDecls (TypeInstanceDeclaration _ cs _ tys _) = + foldMap (foldMap forTypes . constraintArgs) cs `mappend` + foldMap forTypes tys + forDecls (TypeSynonymDeclaration _ args ty) = + foldMap (foldMap f . snd) args `mappend` + forTypes ty + forDecls (TypeDeclaration _ ty) = forTypes ty + forDecls (ExternDeclaration _ ty) = forTypes ty + forDecls (ExternDataDeclaration _ kn) = f kn + forDecls _ = mempty + + forValues (TypeClassDictionary c _ _) = foldMap forTypes (constraintArgs c) + forValues (DeferredDictionary _ tys) = foldMap forTypes tys + forValues (TypedValue _ _ ty) = forTypes ty + forValues _ = mempty + + forTypes (KindedType _ k) = f k + forTypes _ = mempty + -- | -- Map a function over type annotations appearing inside a value -- diff --git a/src/Language/PureScript/Bundle.hs b/src/Language/PureScript/Bundle.hs index 2a36afe..6b63d19 100644 --- a/src/Language/PureScript/Bundle.hs +++ b/src/Language/PureScript/Bundle.hs @@ -6,6 +6,7 @@ -- and generates the final Javascript bundle. module Language.PureScript.Bundle ( bundle + , bundleSM , guessModuleIdentifier , ModuleIdentifier(..) , moduleName @@ -19,6 +20,7 @@ import Prelude.Compat import Control.Monad import Control.Monad.Error.Class +import Control.Arrow ((&&&)) import Data.Char (chr, digitToInt) import Data.Generics (everything, everywhere, mkQ, mkT) @@ -33,7 +35,9 @@ import Language.JavaScript.Parser.AST import qualified Paths_purescript as Paths -import System.FilePath (takeFileName, takeDirectory) +import System.FilePath (takeFileName, takeDirectory, takeDirectory, makeRelative) + +import SourceMap.Types -- | The type of error messages. We separate generation and rendering of errors using a data -- type, in case we need to match on error types later. @@ -98,10 +102,11 @@ data ModuleElement | Member JSStatement Bool String JSExpression [Key] | ExportsList [(ExportType, String, JSExpression, [Key])] | Other JSStatement + | Skip JSStatement deriving (Show) -- | A module is just a list of elements of the types listed above. -data Module = Module ModuleIdentifier [ModuleElement] deriving (Show) +data Module = Module ModuleIdentifier (Maybe FilePath) [ModuleElement] deriving (Show) -- | Prepare an error message for consumption by humans. printErrorMessage :: ErrorMessage -> [String] @@ -159,7 +164,7 @@ checkImportPath name _ _ = Left name -- -- where name is the name of a member defined in the current module. withDeps :: Module -> Module -withDeps (Module modulePath es) = Module modulePath (map expandDeps es) +withDeps (Module modulePath fn es) = Module modulePath fn (map expandDeps es) where -- | Collects all modules which are imported, so that we can identify dependencies of the first type. imports :: [(String, ModuleIdentifier)] @@ -248,9 +253,9 @@ trailingCommaList (JSCTLNone l) = commaList l -- -- Each type of module element is matched using pattern guards, and everything else is bundled into the -- Other constructor. -toModule :: forall m. (MonadError ErrorMessage m) => S.Set String -> ModuleIdentifier -> JSAST -> m Module -toModule mids mid top - | JSAstProgram smts _ <- top = Module mid <$> traverse toModuleElement smts +toModule :: forall m. (MonadError ErrorMessage m) => S.Set String -> ModuleIdentifier -> Maybe FilePath -> JSAST -> m Module +toModule mids mid filename top + | JSAstProgram smts _ <- top = Module mid filename <$> traverse toModuleElement smts | otherwise = err InvalidTopLevel where err = throwError . ErrorInModule mid @@ -389,7 +394,7 @@ compile modules entryPoints = filteredModules -- | The vertex set verts :: [(ModuleElement, Key, [Key])] verts = do - Module mid els <- modules + Module mid _ els <- modules concatMap (toVertices mid) els where -- | Create a set of vertices for a module element. @@ -425,14 +430,21 @@ compile modules entryPoints = filteredModules filteredModules = map filterUsed modules where filterUsed :: Module -> Module - filterUsed (Module mid ds) = Module mid (map filterExports (go ds)) + filterUsed (Module mid fn ds) = Module mid fn (map filterExports (go ds)) where go :: [ModuleElement] -> [ModuleElement] go [] = [] go (d : rest) - | not (isDeclUsed d) = go rest + | not (isDeclUsed d) = skipDecl d : go rest | otherwise = d : go rest + skipDecl :: ModuleElement -> ModuleElement + skipDecl (Require s _ _) = Skip s + skipDecl (Member s _ _ _ _) = Skip s + skipDecl (ExportsList _) = Skip (JSEmptyStatement JSNoAnnot) + skipDecl (Other s) = Skip s + skipDecl (Skip s) = Skip s + -- | Filter out the exports for members which aren't used. filterExports :: ModuleElement -> ModuleElement filterExports (ExportsList exps) = ExportsList (filter (\(_, nm, _, _) -> isKeyUsed (mid, nm)) exps) @@ -453,7 +465,7 @@ sortModules :: [Module] -> [Module] sortModules modules = map (\v -> case nodeFor v of (n, _, _) -> n) (reverse (topSort graph)) where (graph, nodeFor, _) = graphFromEdges $ do - m@(Module mid els) <- modules + m@(Module mid _ els) <- modules return (m, mid, mapMaybe getKey els) getKey :: ModuleElement -> Maybe ModuleIdentifier @@ -466,12 +478,13 @@ sortModules modules = map (\v -> case nodeFor v of (n, _, _) -> n) (reverse (top -- -- If a module is empty, we don't want to generate code for it. isModuleEmpty :: Module -> Bool -isModuleEmpty (Module _ els) = all isElementEmpty els +isModuleEmpty (Module _ _ els) = all isElementEmpty els where isElementEmpty :: ModuleElement -> Bool isElementEmpty (ExportsList exps) = null exps isElementEmpty Require{} = True isElementEmpty (Other _) = True + isElementEmpty (Skip _) = True isElementEmpty _ = False -- | Generate code for a set of modules, including a call to main(). @@ -490,16 +503,62 @@ isModuleEmpty (Module _ els) = all isElementEmpty els codeGen :: Maybe String -- ^ main module -> String -- ^ namespace -> [Module] -- ^ input modules - -> String -codeGen optionsMainModule optionsNamespace ms = renderToString (JSAstProgram (prelude : concatMap moduleToJS ms ++ maybe [] runMain optionsMainModule) JSNoAnnot) + -> Maybe String -- ^ output filename + -> (Maybe SourceMapping, String) +codeGen optionsMainModule optionsNamespace ms outFileOpt = (fmap sourceMapping outFileOpt, rendered) where - moduleToJS :: Module -> [JSStatement] - moduleToJS (Module mn ds) = wrap (moduleName mn) (indent (concatMap declToJS ds)) + rendered = renderToString (JSAstProgram (prelude : concatMap fst modulesJS ++ maybe [] runMain optionsMainModule) JSNoAnnot) + + sourceMapping :: String -> SourceMapping + sourceMapping outFile = SourceMapping { + smFile = outFile, + smSourceRoot = Nothing, + smMappings = concat $ + zipWith3 (\file (pos :: Int) positions -> + map (\(porig, pgen) -> Mapping { + mapOriginal = Just (Pos (fromIntegral $ porig + 1) 0) + , mapSourceFile = pathToFile <$> file + , mapGenerated = (Pos (fromIntegral $ pos + pgen) 0) + , mapName = Nothing + }) + (offsets (0,0) (Right 1 : positions))) + moduleFns + (scanl (+) (3 + moduleLength [prelude]) (map (3+) moduleLengths)) -- 3 lines between each module & at top + (map snd modulesJS) + } where - declToJS :: ModuleElement -> [JSStatement] - declToJS (Member n _ _ _ _) = [n] - declToJS (Other n) = [n] - declToJS (Require _ nm req) = + pathToFile = makeRelative (takeDirectory outFile) + + offsets (m, n) (Left d:rest) = offsets (m+d, n) rest + offsets (m, n) (Right d:rest) = map ((m+) &&& (n+)) [0 .. d - 1] ++ offsets (m+d, n+d) rest + offsets _ _ = [] + + moduleLength :: [JSStatement] -> Int + moduleLength = everything (+) (mkQ 0 countw) + where + countw :: CommentAnnotation -> Int + countw (WhiteSpace _ s) = length (filter (== '\n') s) + countw _ = 0 + + moduleLengths :: [Int] + moduleLengths = map (sum . map (either (const 0) id) . snd) modulesJS + moduleFns = map (\(Module _ fn _) -> fn) ms + + modulesJS = map moduleToJS ms + + moduleToJS :: Module -> ([JSStatement], [Either Int Int]) + moduleToJS (Module mn _ ds) = (wrap (moduleName mn) (indent (concat jsDecls)), lengths) + where + (jsDecls, lengths) = unzip $ map declToJS ds + + withLength :: [JSStatement] -> ([JSStatement], Either Int Int) + withLength n = (n, Right $ moduleLength n) + + declToJS :: ModuleElement -> ([JSStatement], Either Int Int) + declToJS (Member n _ _ _ _) = withLength [n] + declToJS (Other n) = withLength [n] + declToJS (Skip n) = ([], Left $ moduleLength [n]) + declToJS (Require _ nm req) = withLength [ JSVariable lfsp (cList [ @@ -507,9 +566,10 @@ codeGen optionsMainModule optionsNamespace ms = renderToString (JSAstProgram (p (JSVarInit sp $ either require (moduleReference sp . moduleName) req ) ]) (JSSemi JSNoAnnot) ] - declToJS (ExportsList exps) = map toExport exps + declToJS (ExportsList exps) = withLength $ map toExport exps where + toExport :: (ExportType, String, JSExpression, [Key]) -> JSStatement toExport (_, nm, val, _) = JSAssignStatement @@ -612,26 +672,39 @@ codeGen optionsMainModule optionsNamespace ms = renderToString (JSAstProgram (p -- | The bundling function. -- This function performs dead code elimination, filters empty modules -- and generates and prints the final Javascript bundle. -bundle :: (MonadError ErrorMessage m) - => [(ModuleIdentifier, String)] -- ^ The input modules. Each module should be javascript rendered from 'Language.PureScript.Make' or @psc@. +bundleSM :: (MonadError ErrorMessage m) + => [(ModuleIdentifier, Maybe FilePath, String)] -- ^ The input modules. Each module should be javascript rendered from 'Language.PureScript.Make' or @psc@. -> [ModuleIdentifier] -- ^ Entry points. These module identifiers are used as the roots for dead-code elimination -> Maybe String -- ^ An optional main module. -> String -- ^ The namespace (e.g. PS). - -> m String -bundle inputStrs entryPoints mainModule namespace = do + -> Maybe FilePath -- ^ The output file name (if there is one - in which case generate source map) + -> m (Maybe SourceMapping, String) +bundleSM inputStrs entryPoints mainModule namespace outFilename = do + let mid (a,_,_) = a forM_ mainModule $ \mname -> - when (mname `notElem` map (moduleName . fst) inputStrs) (throwError (MissingMainModule mname)) + when (mname `notElem` map (moduleName . mid) inputStrs) (throwError (MissingMainModule mname)) forM_ entryPoints $ \mIdent -> - when (mIdent `notElem` map fst inputStrs) (throwError (MissingEntryPoint (moduleName mIdent))) - input <- forM inputStrs $ \(ident, js) -> do + when (mIdent `notElem` map mid inputStrs) (throwError (MissingEntryPoint (moduleName mIdent))) + input <- forM inputStrs $ \(ident, filename, js) -> do ast <- either (throwError . ErrorInModule ident . UnableToParseModule) pure $ parse js (moduleName ident) - return (ident, ast) + return (ident, filename, ast) - let mids = S.fromList (map (moduleName . fst) input) + let mids = S.fromList (map (moduleName . mid) input) - modules <- traverse (fmap withDeps . uncurry (toModule mids)) input + modules <- traverse (fmap withDeps . (\(a,fn,c) -> toModule mids a fn c)) input let compiled = compile modules entryPoints sorted = sortModules (filter (not . isModuleEmpty) compiled) - return (codeGen mainModule namespace sorted) + return (codeGen mainModule namespace sorted outFilename) + +-- | The bundling function. +-- This function performs dead code elimination, filters empty modules +-- and generates and prints the final Javascript bundle. +bundle :: (MonadError ErrorMessage m) + => [(ModuleIdentifier, String)] -- ^ The input modules. Each module should be javascript rendered from 'Language.PureScript.Make' or @psc@. + -> [ModuleIdentifier] -- ^ Entry points. These module identifiers are used as the roots for dead-code elimination + -> Maybe String -- ^ An optional main module. + -> String -- ^ The namespace (e.g. PS). + -> m String +bundle inputStrs entryPoints mainModule namespace = snd <$> bundleSM (map (\(a,b) -> (a,Nothing,b)) inputStrs) entryPoints mainModule namespace Nothing diff --git a/src/Language/PureScript/CodeGen/JS.hs b/src/Language/PureScript/CodeGen/JS.hs index 2625a6a..c92de6b 100644 --- a/src/Language/PureScript/CodeGen/JS.hs +++ b/src/Language/PureScript/CodeGen/JS.hs @@ -293,7 +293,7 @@ moduleToJs (Module coms mn imps exps foreigns decls) foreign_ = evaluate = JSVariableIntroduction Nothing evaluatedObj (Just obj) objAssign = JSVariableIntroduction Nothing newObj (Just $ JSObjectLiteral Nothing []) copy = JSForIn Nothing key jsEvaluatedObj $ JSBlock Nothing [JSIfElse Nothing cond assign Nothing] - cond = JSApp Nothing (JSAccessor Nothing "hasOwnProperty" jsEvaluatedObj) [jsKey] + cond = JSApp Nothing (JSAccessor Nothing "call" (JSAccessor Nothing "hasOwnProperty" (JSObjectLiteral Nothing []))) [jsEvaluatedObj, jsKey] assign = JSBlock Nothing [JSAssignment Nothing (JSIndexer Nothing jsKey jsNewObj) (JSIndexer Nothing jsKey jsEvaluatedObj)] stToAssign (s, js) = JSAssignment Nothing (accessorString s jsNewObj) js extend = map stToAssign sts diff --git a/src/Language/PureScript/Constants.hs b/src/Language/PureScript/Constants.hs index a472387..3d9351d 100644 --- a/src/Language/PureScript/Constants.hs +++ b/src/Language/PureScript/Constants.hs @@ -139,6 +139,9 @@ compose = "compose" composeFlipped :: Text composeFlipped = "composeFlipped" +map :: Text +map = "map" + -- Functions negate :: Text @@ -314,10 +317,38 @@ fromSpine = "fromSpine" toSignature :: Text toSignature = "toSignature" --- IsSymbol class +-- Data.Symbol + +pattern DataSymbol :: ModuleName +pattern DataSymbol = ModuleName [ProperName "Data", ProperName "Symbol"] pattern IsSymbol :: Qualified (ProperName 'ClassName) -pattern IsSymbol = Qualified (Just (ModuleName [ProperName "Data", ProperName "Symbol"])) (ProperName "IsSymbol") +pattern IsSymbol = Qualified (Just DataSymbol) (ProperName "IsSymbol") + +-- Type.Data.Symbol + +pattern TypeDataSymbol :: ModuleName +pattern TypeDataSymbol = ModuleName [ProperName "Type", ProperName "Data", ProperName "Symbol"] + +pattern CompareSymbol :: Qualified (ProperName 'ClassName) +pattern CompareSymbol = Qualified (Just TypeDataSymbol) (ProperName "CompareSymbol") + +pattern AppendSymbol :: Qualified (ProperName 'ClassName) +pattern AppendSymbol = Qualified (Just TypeDataSymbol) (ProperName "AppendSymbol") + +-- Type.Data.Ordering + +typeDataOrdering :: ModuleName +typeDataOrdering = ModuleName [ProperName "Type", ProperName "Data", ProperName "Ordering"] + +orderingLT :: Qualified (ProperName 'TypeName) +orderingLT = Qualified (Just typeDataOrdering) (ProperName "LT") + +orderingEQ :: Qualified (ProperName 'TypeName) +orderingEQ = Qualified (Just typeDataOrdering) (ProperName "EQ") + +orderingGT :: Qualified (ProperName 'TypeName) +orderingGT = Qualified (Just typeDataOrdering) (ProperName "GT") -- Main module @@ -329,11 +360,23 @@ main = "main" partial :: Text partial = "Partial" +pattern Prim :: ModuleName +pattern Prim = ModuleName [ProperName "Prim"] + pattern Partial :: Qualified (ProperName 'ClassName) -pattern Partial = Qualified (Just (ModuleName [ProperName "Prim"])) (ProperName "Partial") +pattern Partial = Qualified (Just Prim) (ProperName "Partial") pattern Fail :: Qualified (ProperName 'ClassName) -pattern Fail = Qualified (Just (ModuleName [ProperName "Prim"])) (ProperName "Fail") +pattern Fail = Qualified (Just Prim) (ProperName "Fail") + +typ :: Text +typ = "Type" + +effect :: Text +effect = "Effect" + +symbol :: Text +symbol = "Symbol" -- Code Generation diff --git a/src/Language/PureScript/Docs.hs b/src/Language/PureScript/Docs.hs index 9297000..9f36874 100644 --- a/src/Language/PureScript/Docs.hs +++ b/src/Language/PureScript/Docs.hs @@ -7,6 +7,7 @@ module Language.PureScript.Docs ( ) where import Language.PureScript.Docs.Convert as Docs +import Language.PureScript.Docs.Prim as Docs import Language.PureScript.Docs.ParseAndBookmark as Docs import Language.PureScript.Docs.Render as Docs import Language.PureScript.Docs.RenderedCode.Render as Docs diff --git a/src/Language/PureScript/Docs/AsMarkdown.hs b/src/Language/PureScript/Docs/AsMarkdown.hs index a336030..bcc258e 100644 --- a/src/Language/PureScript/Docs/AsMarkdown.hs +++ b/src/Language/PureScript/Docs/AsMarkdown.hs @@ -13,7 +13,9 @@ import Control.Monad.Error.Class (MonadError) import Control.Monad.Writer (Writer, tell, execWriter) import Data.Foldable (for_) +import Data.Monoid ((<>)) import Data.List (partition) +import Data.Text (Text) import qualified Data.Text as T import Language.PureScript.Docs.RenderedCode @@ -24,27 +26,28 @@ import qualified Language.PureScript.Docs.Render as Render -- | -- Take a list of modules and render them all in order, returning a single --- Markdown-formatted String. +-- Markdown-formatted Text. -- renderModulesAsMarkdown :: (MonadError P.MultipleErrors m) => [P.Module] -> - m String + m Text renderModulesAsMarkdown = - fmap (runDocs . modulesAsMarkdown) . Convert.convertModules + fmap (runDocs . modulesAsMarkdown) . Convert.convertModules Local modulesAsMarkdown :: [Module] -> Docs modulesAsMarkdown = mapM_ moduleAsMarkdown moduleAsMarkdown :: Module -> Docs moduleAsMarkdown Module{..} = do - headerLevel 2 $ "Module " ++ T.unpack (P.runModuleName modName) + headerLevel 2 $ "Module " <> P.runModuleName modName spacer for_ modComments tell' mapM_ (declAsMarkdown modName) modDeclarations spacer - for_ modReExports $ \(mn, decls) -> do - headerLevel 3 $ "Re-exported from " ++ T.unpack (P.runModuleName mn) ++ ":" + for_ modReExports $ \(mn', decls) -> do + let mn = ignorePackage mn' + headerLevel 3 $ "Re-exported from " <> P.runModuleName mn <> ":" spacer mapM_ (declAsMarkdown mn) decls @@ -71,7 +74,7 @@ declAsMarkdown mn decl@Declaration{..} = do isChildInstance (ChildInstance _ _) = True isChildInstance _ = False -codeToString :: RenderedCode -> String +codeToString :: RenderedCode -> Text codeToString = outputWith elemAsMarkdown where elemAsMarkdown (Syntax x) = x @@ -95,14 +98,14 @@ codeToString = outputWith elemAsMarkdown -- P.Infixr -> "right-associative" -- P.Infix -> "non-associative" -childToString :: First -> ChildDeclaration -> String +childToString :: First -> ChildDeclaration -> Text childToString f decl@ChildDeclaration{..} = case cdeclInfo of ChildDataConstructor _ -> let c = if f == First then "=" else "|" - in " " ++ c ++ " " ++ str + in " " <> c <> " " <> str ChildTypeClassMember _ -> - " " ++ str + " " <> str ChildInstance _ _ -> str where @@ -113,19 +116,19 @@ data First | NotFirst deriving (Show, Eq, Ord) -type Docs = Writer [String] () +type Docs = Writer [Text] () -runDocs :: Docs -> String -runDocs = unlines . execWriter +runDocs :: Docs -> Text +runDocs = T.unlines . execWriter -tell' :: String -> Docs +tell' :: Text -> Docs tell' = tell . (:[]) spacer :: Docs spacer = tell' "" -headerLevel :: Int -> String -> Docs -headerLevel level hdr = tell' (replicate level '#' ++ ' ' : hdr) +headerLevel :: Int -> Text -> Docs +headerLevel level hdr = tell' (T.replicate level "#" <> " " <> hdr) fencedBlock :: Docs -> Docs fencedBlock inner = do @@ -133,5 +136,5 @@ fencedBlock inner = do inner tell' "```" -ticks :: String -> String -ticks = ("`" ++) . (++ "`") +ticks :: Text -> Text +ticks = ("`" <>) . (<> "`") diff --git a/src/Language/PureScript/Docs/Convert.hs b/src/Language/PureScript/Docs/Convert.hs index 5473cff..541d80b 100644 --- a/src/Language/PureScript/Docs/Convert.hs +++ b/src/Language/PureScript/Docs/Convert.hs @@ -15,8 +15,9 @@ import Control.Monad import Control.Monad.Error.Class (MonadError) import Control.Monad.State (runStateT) import Control.Monad.Writer.Strict (runWriterT) +import Data.List (find) import qualified Data.Map as Map -import qualified Data.Text as T +import Data.Text (Text) import Language.PureScript.Docs.Convert.ReExports (updateReExports) import Language.PureScript.Docs.Convert.Single (convertSingleModule, collectBookmarks) @@ -42,9 +43,18 @@ convertModulesInPackage modules = map P.getModuleName (takeLocals modules) go = map ignorePackage - >>> convertModules + >>> convertModules withPackage >>> fmap (filter ((`elem` localNames) . modName)) + withPackage :: P.ModuleName -> InPackage P.ModuleName + withPackage mn = + case find ((== mn) . P.getModuleName . ignorePackage) modules of + Just m -> + fmap P.getModuleName m + Nothing -> + P.internalError $ "withPackage: missing module:" ++ + show (P.runModuleName mn) + -- | -- Convert a group of modules to the intermediate format, designed for -- producing documentation from. It is also necessary to pass an Env containing @@ -61,12 +71,13 @@ convertModulesInPackage modules = -- convertModules :: (MonadError P.MultipleErrors m) => + (P.ModuleName -> InPackage P.ModuleName) -> [P.Module] -> m [Module] -convertModules = +convertModules withPackage = P.sortModules >>> fmap (fst >>> map importPrim) - >=> convertSorted + >=> convertSorted withPackage importPrim :: P.Module -> P.Module importPrim = P.addDefaultImport (P.ModuleName [P.ProperName C.prim]) @@ -76,16 +87,17 @@ importPrim = P.addDefaultImport (P.ModuleName [P.ProperName C.prim]) -- convertSorted :: (MonadError P.MultipleErrors m) => + (P.ModuleName -> InPackage P.ModuleName) -> [P.Module] -> m [Module] -convertSorted modules = do +convertSorted withPackage modules = do (env, convertedModules) <- second (map convertSingleModule) <$> partiallyDesugar modules modulesWithTypes <- typeCheckIfNecessary modules convertedModules let moduleMap = Map.fromList (map (modName &&& id) modulesWithTypes) let traversalOrder = map P.getModuleName modules - pure (Map.elems (updateReExports env traversalOrder moduleMap)) + pure (Map.elems (updateReExports env traversalOrder withPackage moduleMap)) -- | -- If any exported value declarations have either wildcard type signatures, or @@ -167,9 +179,9 @@ insertValueTypes env m = err msg = P.internalError ("Docs.Convert.insertValueTypes: " ++ msg) -runParser :: P.TokenParser a -> String -> Either String a +runParser :: P.TokenParser a -> Text -> Either String a runParser p s = either (Left . show) Right $ do - ts <- P.lex "" (T.pack s) + ts <- P.lex "" s P.runTokenParser "" (p <* eof) ts -- | diff --git a/src/Language/PureScript/Docs/Convert/ReExports.hs b/src/Language/PureScript/Docs/Convert/ReExports.hs index f4fcec2..044cf98 100644 --- a/src/Language/PureScript/Docs/Convert/ReExports.hs +++ b/src/Language/PureScript/Docs/Convert/ReExports.hs @@ -16,6 +16,7 @@ import Data.Map (Map) import Data.Maybe (mapMaybe) import Data.Monoid ((<>)) import qualified Data.Map as Map +import Data.Text (Text) import qualified Data.Text as T import Language.PureScript.Docs.Types @@ -34,9 +35,10 @@ import qualified Language.PureScript as P updateReExports :: P.Env -> [P.ModuleName] -> + (P.ModuleName -> InPackage P.ModuleName) -> Map P.ModuleName Module -> Map P.ModuleName Module -updateReExports env order = execState action +updateReExports env order withPackage = execState action where action = void (traverse go order) @@ -44,7 +46,7 @@ updateReExports env order = execState action go mn = do mdl <- lookup' mn reExports <- getReExports env mn - let mdl' = mdl { modReExports = reExports } + let mdl' = mdl { modReExports = map (first withPackage) reExports } modify (Map.insert mn mdl') lookup' mn = do @@ -108,13 +110,14 @@ collectDeclarations imports exports = do typeClasses <- collect lookupTypeClassDeclaration impTCs expTCs types <- collect lookupTypeDeclaration impTypes expTypes typeOps <- collect lookupTypeOpDeclaration impTypeOps expTypeOps + kinds <- collect lookupKindDeclaration impKinds expKinds (vals, classes) <- handleTypeClassMembers valsAndMembers typeClasses let filteredTypes = filterDataConstructors expCtors types let filteredClasses = filterTypeClassMembers (Map.keys expVals) classes - pure (Map.toList (Map.unionsWith (<>) [filteredTypes, filteredClasses, vals, valOps, typeOps])) + pure (Map.toList (Map.unionsWith (<>) [filteredTypes, filteredClasses, vals, valOps, typeOps, kinds])) where @@ -145,6 +148,9 @@ collectDeclarations imports exports = do expTCs = P.exportedTypeClasses exports impTCs = concat (Map.elems (P.importedTypeClasses imports)) + expKinds = P.exportedKinds exports + impKinds = concat (Map.elems (P.importedKinds imports)) + -- | -- Given a list of imported declarations (of a particular kind, ie. type, data, -- class, value, etc), and the name of an exported declaration of the same @@ -184,12 +190,12 @@ lookupValueDeclaration :: MonadReader P.ModuleName m) => P.ModuleName -> P.Ident -> - m (P.ModuleName, [Either (String, P.Constraint, ChildDeclaration) Declaration]) + m (P.ModuleName, [Either (Text, P.Constraint, ChildDeclaration) Declaration]) lookupValueDeclaration importedFrom ident = do decls <- lookupModuleDeclarations "lookupValueDeclaration" importedFrom let rs = - filter (\d -> declTitle d == T.unpack (P.showIdent ident) + filter (\d -> declTitle d == P.showIdent ident && (isValue d || isValueAlias d)) decls errOther other = internalErrorInModule @@ -215,7 +221,7 @@ lookupValueDeclaration importedFrom ident = do (declChildren d)) matchesIdent cdecl = - cdeclTitle cdecl == T.unpack (P.showIdent ident) + cdeclTitle cdecl == P.showIdent ident matchesAndIsTypeClassMember = uncurry (&&) . (matchesIdent &&& isTypeClassMember) @@ -239,7 +245,7 @@ lookupValueOpDeclaration -> m (P.ModuleName, [Declaration]) lookupValueOpDeclaration importedFrom op = do decls <- lookupModuleDeclarations "lookupValueOpDeclaration" importedFrom - case filter (\d -> declTitle d == T.unpack (P.showOp op) && isValueAlias d) decls of + case filter (\d -> declTitle d == P.showOp op && isValueAlias d) decls of [d] -> pure (importedFrom, [d]) other -> @@ -259,7 +265,7 @@ lookupTypeDeclaration :: lookupTypeDeclaration importedFrom ty = do decls <- lookupModuleDeclarations "lookupTypeDeclaration" importedFrom let - ds = filter (\d -> declTitle d == T.unpack (P.runProperName ty) && isType d) decls + ds = filter (\d -> declTitle d == P.runProperName ty && isType d) decls case ds of [d] -> pure (importedFrom, [d]) @@ -275,7 +281,7 @@ lookupTypeOpDeclaration lookupTypeOpDeclaration importedFrom tyOp = do decls <- lookupModuleDeclarations "lookupTypeOpDeclaration" importedFrom let - ds = filter (\d -> declTitle d == ("type " ++ T.unpack (P.showOp tyOp)) && isTypeAlias d) decls + ds = filter (\d -> declTitle d == ("type " <> P.showOp tyOp) && isTypeAlias d) decls case ds of [d] -> pure (importedFrom, [d]) @@ -291,7 +297,7 @@ lookupTypeClassDeclaration lookupTypeClassDeclaration importedFrom tyClass = do decls <- lookupModuleDeclarations "lookupTypeClassDeclaration" importedFrom let - ds = filter (\d -> declTitle d == T.unpack (P.runProperName tyClass) + ds = filter (\d -> declTitle d == P.runProperName tyClass && isTypeClass d) decls case ds of @@ -302,6 +308,24 @@ lookupTypeClassDeclaration importedFrom tyClass = do ("lookupTypeClassDeclaration: unexpected result: " ++ (unlines . map show) other) +lookupKindDeclaration + :: (MonadState (Map P.ModuleName Module) m, MonadReader P.ModuleName m) + => P.ModuleName + -> P.ProperName 'P.KindName + -> m (P.ModuleName, [Declaration]) +lookupKindDeclaration importedFrom kind = do + decls <- lookupModuleDeclarations "lookupKindDeclaration" importedFrom + let + ds = filter (\d -> declTitle d == P.runProperName kind + && isKind d) + decls + case ds of + [d] -> + pure (importedFrom, [d]) + other -> + internalErrorInModule + ("lookupKindDeclaration: unexpected result: " ++ show other) + -- | -- Get the full list of declarations for a particular module out of the -- state, or raise an internal error if it is not there. @@ -324,7 +348,7 @@ lookupModuleDeclarations definedIn moduleName = do handleTypeClassMembers :: (MonadReader P.ModuleName m) => - Map P.ModuleName [Either (String, P.Constraint, ChildDeclaration) Declaration] -> + Map P.ModuleName [Either (Text, P.Constraint, ChildDeclaration) Declaration] -> Map P.ModuleName [Declaration] -> m (Map P.ModuleName [Declaration], Map P.ModuleName [Declaration]) handleTypeClassMembers valsAndMembers typeClasses = @@ -339,7 +363,7 @@ handleTypeClassMembers valsAndMembers typeClasses = |> fmap splitMap valsAndMembersToEnv :: - [Either (String, P.Constraint, ChildDeclaration) Declaration] -> TypeClassEnv + [Either (Text, P.Constraint, ChildDeclaration) Declaration] -> TypeClassEnv valsAndMembersToEnv xs = let (envUnhandledMembers, envValues) = partitionEithers xs envTypeClasses = [] @@ -360,11 +384,11 @@ typeClassesToEnv classes = -- data TypeClassEnv = TypeClassEnv { -- | - -- Type class members which have not yet been dealt with. The String is the + -- Type class members which have not yet been dealt with. The Text is the -- name of the type class they belong to, and the constraint is used to -- make sure that they have the correct type if they get promoted. -- - envUnhandledMembers :: [(String, P.Constraint, ChildDeclaration)] + envUnhandledMembers :: [(Text, P.Constraint, ChildDeclaration)] -- | -- A list of normal value declarations. Type class members will be added to -- this list if their parent type class is not available. @@ -428,7 +452,7 @@ handleEnv TypeClassEnv{..} = _ -> internalErrorInModule ("handleEnv: Bad child declaration passed to promoteChild: " - ++ cdeclTitle) + ++ T.unpack cdeclTitle) addConstraint constraint = P.quantify . P.moveQuantifiersToFront . P.ConstrainedType [constraint] @@ -448,7 +472,7 @@ filterDataConstructors -> Map P.ModuleName [Declaration] -> Map P.ModuleName [Declaration] filterDataConstructors = - filterExportedChildren isDataConstructor (T.unpack . P.runProperName) + filterExportedChildren isDataConstructor P.runProperName -- | -- Given a list of exported type class member names, remove any data @@ -460,12 +484,12 @@ filterTypeClassMembers -> Map P.ModuleName [Declaration] -> Map P.ModuleName [Declaration] filterTypeClassMembers = - filterExportedChildren isTypeClassMember (T.unpack . P.showIdent) + filterExportedChildren isTypeClassMember P.showIdent filterExportedChildren :: (Functor f) => (ChildDeclaration -> Bool) - -> (name -> String) + -> (name -> Text) -> [name] -> f [Declaration] -> f [Declaration] @@ -504,7 +528,7 @@ typeClassConstraintFor :: Declaration -> Maybe P.Constraint typeClassConstraintFor Declaration{..} = case declInfo of TypeClassDeclaration tyArgs _ _ -> - Just (P.Constraint (P.Qualified Nothing (P.ProperName (T.pack declTitle))) (mkConstraint (map (first T.pack) tyArgs)) Nothing) + Just (P.Constraint (P.Qualified Nothing (P.ProperName declTitle)) (mkConstraint tyArgs) Nothing) _ -> Nothing where diff --git a/src/Language/PureScript/Docs/Convert/Single.hs b/src/Language/PureScript/Docs/Convert/Single.hs index 0743560..36dbc36 100644 --- a/src/Language/PureScript/Docs/Convert/Single.hs +++ b/src/Language/PureScript/Docs/Convert/Single.hs @@ -5,24 +5,19 @@ module Language.PureScript.Docs.Convert.Single import Prelude.Compat -import Control.Arrow (first) import Control.Category ((>>>)) import Control.Monad -import Data.Bifunctor (bimap) import Data.Either import Data.List (nub) -import Data.Maybe (mapMaybe) +import Data.Maybe (mapMaybe, fromMaybe) import Data.Monoid ((<>)) import Data.Text (Text) import qualified Data.Text as T -import qualified Data.Vector as V import Language.PureScript.Docs.Types import qualified Language.PureScript as P --- TODO (Christoph): Get rid of the T.unpack s - -- | -- Convert a single Module, but ignore re-exports; any re-exported types or -- values will not appear in the result. @@ -48,14 +43,14 @@ convertSingleModule m@(P.Module _ coms moduleName _ _) = -- In the second pass, we go over all of the Left values and augment the -- relevant declarations, leaving only the augmented Right values. -- --- Note that in the Left case, we provide a [String] as well as augment --- information. The [String] value should be a list of titles of declarations +-- Note that in the Left case, we provide a [Text] as well as augment +-- information. The [Text] value should be a list of titles of declarations -- that the augmentation should apply to. For example, for a type instance -- declaration, that would be any types or type classes mentioned in the -- instance. For a fixity declaration, it would be just the relevant operator's -- name. type IntermediateDeclaration - = Either ([String], DeclarationAugment) Declaration + = Either ([Text], DeclarationAugment) Declaration -- | Some data which will be used to augment a Declaration in the -- output. @@ -88,6 +83,7 @@ getDeclarationTitle (P.ValueDeclaration name _ _ _) = Just (P.showIdent name) getDeclarationTitle (P.ExternDeclaration name _) = Just (P.showIdent name) getDeclarationTitle (P.DataDeclaration _ name _ _) = Just (P.runProperName name) getDeclarationTitle (P.ExternDataDeclaration name _) = Just (P.runProperName name) +getDeclarationTitle (P.ExternKindDeclaration name) = Just (P.runProperName name) getDeclarationTitle (P.TypeSynonymDeclaration name _ _) = Just (P.runProperName name) getDeclarationTitle (P.TypeClassDeclaration name _ _ _ _) = Just (P.runProperName name) getDeclarationTitle (P.TypeInstanceDeclaration name _ _ _ _) = Just (P.showIdent name) @@ -99,7 +95,7 @@ getDeclarationTitle _ = Nothing -- | Create a basic Declaration value. mkDeclaration :: Text -> DeclarationInfo -> Declaration mkDeclaration title info = - Declaration { declTitle = T.unpack title + Declaration { declTitle = title , declComments = Nothing , declSourceSpan = Nothing , declChildren = [] @@ -121,42 +117,29 @@ convertDeclaration (P.ExternDeclaration _ ty) title = convertDeclaration (P.DataDeclaration dtype _ args ctors) title = Just (Right (mkDeclaration title info) { declChildren = children }) where - info = DataDeclaration dtype (map (first T.unpack) args) + info = DataDeclaration dtype args children = map convertCtor ctors convertCtor (ctor', tys) = - ChildDeclaration (T.unpack (P.runProperName ctor')) Nothing Nothing (ChildDataConstructor tys) + ChildDeclaration (P.runProperName ctor') Nothing Nothing (ChildDataConstructor tys) convertDeclaration (P.ExternDataDeclaration _ kind') title = basicDeclaration title (ExternDataDeclaration kind') +convertDeclaration (P.ExternKindDeclaration _) title = + basicDeclaration title ExternKindDeclaration convertDeclaration (P.TypeSynonymDeclaration _ args ty) title = - basicDeclaration title (TypeSynonymDeclaration (map (first T.unpack) args) ty) + basicDeclaration title (TypeSynonymDeclaration args ty) convertDeclaration (P.TypeClassDeclaration _ args implies fundeps ds) title = Just (Right (mkDeclaration title info) { declChildren = children }) where - info = TypeClassDeclaration (map (first T.unpack) args) implies (map (bimap (map T.unpack) (map T.unpack)) fundeps') + info = TypeClassDeclaration args implies (convertFundepsToStrings args fundeps) children = map convertClassMember ds convertClassMember (P.PositionedDeclaration _ _ d) = convertClassMember d convertClassMember (P.TypeDeclaration ident' ty) = - ChildDeclaration (T.unpack (P.showIdent ident')) Nothing Nothing (ChildTypeClassMember ty) + ChildDeclaration (P.showIdent ident') Nothing Nothing (ChildTypeClassMember ty) convertClassMember _ = P.internalError "convertDeclaration: Invalid argument to convertClassMember." - fundeps' = map (\(P.FunctionalDependency from to) -> toArgs from to) fundeps - where - argsVec = V.fromList (map fst args) - getArg i = - maybe - (P.internalError $ unlines - [ "convertDeclaration: Functional dependency index" - , show i - , "is bigger than arguments list" - , show (map fst args) - , "Functional dependencies are" - , show fundeps - ] - ) id $ argsVec V.!? i - toArgs from to = (map getArg from, map getArg to) convertDeclaration (P.TypeInstanceDeclaration _ constraints className tys _) title = - Just (Left (T.unpack classNameString : map T.unpack typeNameStrings, AugmentChild childDecl)) + Just (Left (classNameString : typeNameStrings, AugmentChild childDecl)) where classNameString = unQual className typeNameStrings = nub (concatMap (P.everythingOnTypes (++) extractProperNames) tys) @@ -165,7 +148,7 @@ convertDeclaration (P.TypeInstanceDeclaration _ constraints className tys _) tit extractProperNames (P.TypeConstructor n) = [unQual n] extractProperNames _ = [] - childDecl = ChildDeclaration (T.unpack title) Nothing Nothing (ChildInstance constraints classApp) + childDecl = ChildDeclaration title Nothing Nothing (ChildInstance constraints classApp) classApp = foldl P.TypeApp (P.TypeConstructor (fmap P.coerceProperName className)) tys convertDeclaration (P.ValueFixityDeclaration fixity (P.Qualified mn alias) _) title = Just $ Right $ mkDeclaration title (AliasDeclaration fixity (P.Qualified mn (Right alias))) @@ -189,25 +172,24 @@ convertDeclaration (P.PositionedDeclaration srcSpan com d') title = withAugmentChild f (t, AugmentChild d) = (t, AugmentChild (f d)) convertDeclaration _ _ = Nothing -convertComments :: [P.Comment] -> Maybe String +convertComments :: [P.Comment] -> Maybe Text convertComments cs = do let raw = concatMap toLines cs let docs = mapMaybe stripPipe raw guard (not (null docs)) - pure (unlines docs) + pure (T.unlines docs) where - toLines (P.LineComment s) = [T.unpack s] - toLines (P.BlockComment s) = lines (T.unpack s) - - stripPipe s' = - case dropWhile (== ' ') s' of - ('|':' ':s) -> - Just s - ('|':s) -> - Just s - _ -> - Nothing + toLines (P.LineComment s) = [s] + toLines (P.BlockComment s) = T.lines s + + stripPipe = + T.dropWhile (== ' ') + >>> T.stripPrefix "|" + >>> fmap (dropPrefix " ") + + dropPrefix prefix str = + fromMaybe str (T.stripPrefix prefix str) -- | Go through a PureScript module and extract a list of Bookmarks; references -- to data types or values, to be used as a kind of index. These are used for @@ -216,8 +198,7 @@ collectBookmarks :: InPackage P.Module -> [Bookmark] collectBookmarks (Local m) = map Local (collectBookmarks' m) collectBookmarks (FromDep pkg m) = map (FromDep pkg) (collectBookmarks' m) -collectBookmarks' :: P.Module -> [(P.ModuleName, String)] +collectBookmarks' :: P.Module -> [(P.ModuleName, Text)] collectBookmarks' m = map (P.getModuleName m, ) - (mapMaybe (fmap T.unpack . getDeclarationTitle) - (P.exportedDeclarations m)) + (mapMaybe getDeclarationTitle (P.exportedDeclarations m)) diff --git a/src/Language/PureScript/Docs/Prim.hs b/src/Language/PureScript/Docs/Prim.hs new file mode 100644 index 0000000..41b53dc --- /dev/null +++ b/src/Language/PureScript/Docs/Prim.hs @@ -0,0 +1,244 @@ +-- | This module provides documentation for the builtin Prim module. +module Language.PureScript.Docs.Prim (primDocsModule) where + +import Prelude.Compat hiding (fail) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Map as Map +import qualified Data.Set as Set +import Language.PureScript.Docs.Types +import qualified Language.PureScript as P + +primDocsModule :: Module +primDocsModule = Module + { modName = P.moduleNameFromString "Prim" + , modComments = Just "The Prim module is embedded in the PureScript compiler in order to provide compiler support for certain types — for example, value literals, or syntax sugar." + , modDeclarations = + [ function + , array + , record + , number + , int + , string + , char + , boolean + , partial + , fail + , typeConcat + , typeString + , kindType + , kindEffect + , kindSymbol + ] + , modReExports = [] + } + +unsafeLookup :: forall v (a :: P.ProperNameType). + Map.Map (P.Qualified (P.ProperName a)) v -> String -> Text -> v +unsafeLookup m errorMsg name = go name + where + go = fromJust' . flip Map.lookup m . P.primName + + fromJust' (Just x) = x + fromJust' _ = P.internalError $ errorMsg ++ show name + +primKind :: Text -> Text -> Declaration +primKind title comments = + if Set.member (P.primName title) P.primKinds + then Declaration + { declTitle = title + , declComments = Just comments + , declSourceSpan = Nothing + , declChildren = [] + , declInfo = ExternKindDeclaration + } + else P.internalError $ "Docs.Prim: No such Prim kind: " ++ T.unpack title + +lookupPrimTypeKind :: Text -> P.Kind +lookupPrimTypeKind = fst . unsafeLookup P.primTypes "Docs.Prim: No such Prim type: " + +primType :: Text -> Text -> Declaration +primType title comments = Declaration + { declTitle = title + , declComments = Just comments + , declSourceSpan = Nothing + , declChildren = [] + , declInfo = ExternDataDeclaration (lookupPrimTypeKind title) + } + +-- | Lookup the TypeClassData of a Prim class. This function is specifically +-- not exported because it is partial. +lookupPrimClass :: Text -> P.TypeClassData +lookupPrimClass = unsafeLookup P.primClasses "Docs.Prim: No such Prim class: " + +primClass :: Text -> Text -> Declaration +primClass title comments = Declaration + { declTitle = title + , declComments = Just comments + , declSourceSpan = Nothing + , declChildren = [] + , declInfo = + let + tcd = lookupPrimClass title + args = P.typeClassArguments tcd + superclasses = P.typeClassSuperclasses tcd + fundeps = convertFundepsToStrings args (P.typeClassDependencies tcd) + in + TypeClassDeclaration args superclasses fundeps + } + +kindType :: Declaration +kindType = primKind "Type" $ T.unlines + [ "`Type` (also known as `*`) is the kind of all proper types: those that" + , "classify value-level terms." + , "For example the type `Boolean` has kind `Type`; denoted by `Boolean :: Type`." + ] + +kindEffect :: Declaration +kindEffect = primKind "Effect" $ T.unlines + [ "`Effect` (also known as `!`) is the kind of all effect types." + ] + +kindSymbol :: Declaration +kindSymbol = primKind "Symbol" $ T.unlines + [ "`Symbol` is the kind of type-level strings." + , "" + , "Construct types of this kind using the same literal syntax as documented" + , "for strings." + ] + +function :: Declaration +function = primType "Function" $ T.unlines + [ "A function, which takes values of the type specified by the first type" + , "parameter, and returns values of the type specified by the second." + , "In the JavaScript backend, this is a standard JavaScript Function." + , "" + , "The type constructor `(->)` is syntactic sugar for this type constructor." + , "It is recommended to use `(->)` rather than `Function`, where possible." + , "" + , "That is, prefer this:" + , "" + , " f :: Number -> Number" + , "" + , "to either of these:" + , "" + , " f :: Function Number Number" + , " f :: (->) Number Number" + ] + +array :: Declaration +array = primType "Array" $ T.unlines + [ "An Array: a data structure supporting efficient random access. In" + , "the JavaScript backend, values of this type are represented as JavaScript" + , "Arrays at runtime." + , "" + , "Construct values using literals:" + , "" + , " x = [1,2,3,4,5] :: Array Int" + ] + +record :: Declaration +record = primType "Record" $ T.unlines + [ "The type of records whose fields are known at compile time. In the" + , "JavaScript backend, values of this type are represented as JavaScript" + , "Objects at runtime." + , "" + , "The type signature here means that the `Record` type constructor takes" + , "a row of concrete types. For example:" + , "" + , " type Person = Record (name :: String, age :: Number)" + , "" + , "The syntactic sugar with curly braces `{ }` is generally preferred, though:" + , "" + , " type Person = { name :: String, age :: Number }" + ] + +number :: Declaration +number = primType "Number" $ T.unlines + [ "A double precision floating point number (IEEE 754)." + , "" + , "Construct values of this type with literals:" + , "" + , " y = 35.23 :: Number" + , " z = 1.224e6 :: Number" + ] + +int :: Declaration +int = primType "Int" $ T.unlines + [ "A 32-bit signed integer. See the purescript-integers package for details" + , "of how this is accomplished when compiling to JavaScript." + , "" + , "Construct values of this type with literals:" + , "" + , " x = 23 :: Int" + ] + +string :: Declaration +string = primType "String" $ T.unlines + [ "A String. As in JavaScript, String values represent sequences of UTF-16" + , "code units, which are not required to form a valid encoding of Unicode" + , "text (for example, lone surrogates are permitted)." + , "" + , "Construct values of this type with literals, using double quotes `\"`:" + , "" + , " x = \"hello, world\" :: String" + , "" + , "Multi-line string literals are also supported with triple quotes (`\"\"\"`)." + ] + +char :: Declaration +char = primType "Char" $ T.unlines + [ "A single character (UTF-16 code unit). The JavaScript representation is a" + , "normal String, which is guaranteed to contain one code unit. This means" + , "that astral plane characters (i.e. those with code point values greater" + , "than 0xFFFF) cannot be represented as Char values." + , "" + , "Construct values of this type with literals, using single quotes `'`:" + , "" + , " x = 'a' :: Char" + ] + +boolean :: Declaration +boolean = primType "Boolean" $ T.unlines + [ "A JavaScript Boolean value." + , "" + , "Construct values of this type with the literals `true` and `false`." + ] + +partial :: Declaration +partial = primClass "Partial" $ T.unlines + [ "The Partial type class is used to indicate that a function is *partial,*" + , "that is, it is not defined for all inputs. In practice, attempting to use" + , "a partial function with a bad input will usually cause an error to be" + , "thrown, although it is not safe to assume that this will happen in all" + , "cases. For more information, see" + , "[the Partial type class guide](https://github.com/purescript/documentation/blob/master/guides/The-Partial-type-class.md)." + ] + +fail :: Declaration +fail = primClass "Fail" $ T.unlines + [ "The Fail type class is part of the custom type errors feature. To provide" + , "a custom type error when someone tries to use a particular instance," + , "write that instance out with a Fail constraint." + , "" + , "For more information, see" + , "[the Custom Type Errors guide](https://github.com/purescript/documentation/blob/master/guides/Custom-Type-Errors.md)." + ] + +typeConcat :: Declaration +typeConcat = primType "TypeConcat" $ T.unlines + [ "The TypeConcat type constructor concatenates two Symbols in a custom type" + , "error." + , "" + , "For more information, see" + , "[the Custom Type Errors guide](https://github.com/purescript/documentation/blob/master/guides/Custom-Type-Errors.md)." + ] + +typeString :: Declaration +typeString = primType "TypeString" $ T.unlines + [ "The TypeString type constructor renders any concrete type into a Symbol" + , "in a custom type error." + , "" + , "For more information, see" + , "[the Custom Type Errors guide](https://github.com/purescript/documentation/blob/master/guides/Custom-Type-Errors.md)." + ] diff --git a/src/Language/PureScript/Docs/Render.hs b/src/Language/PureScript/Docs/Render.hs index 352bff9..639824c 100644 --- a/src/Language/PureScript/Docs/Render.hs +++ b/src/Language/PureScript/Docs/Render.hs @@ -13,16 +13,14 @@ import Prelude.Compat import Data.Maybe (maybeToList) import Data.Monoid ((<>)) -import qualified Data.Text as T import Data.Text (Text) +import qualified Data.Text as T import Language.PureScript.Docs.RenderedCode import Language.PureScript.Docs.Types import Language.PureScript.Docs.Utils.MonoidExtras import qualified Language.PureScript as P --- TODO (Christoph): get rid of T.unpack's - renderDeclaration :: Declaration -> RenderedCode renderDeclaration = renderDeclarationWithOptions defaultRenderTypeOptions @@ -35,7 +33,7 @@ renderDeclarationWithOptions opts Declaration{..} = , renderType' ty ] DataDeclaration dtype args -> - [ keyword (T.unpack (P.showDataDeclType dtype)) + [ keyword (P.showDataDeclType dtype) , renderType' (typeApp declTitle args) ] ExternDataDeclaration kind' -> @@ -76,20 +74,25 @@ renderDeclarationWithOptions opts Declaration{..} = AliasDeclaration (P.Fixity associativity precedence) for@(P.Qualified _ alias) -> [ keywordFixity associativity - , syntax $ show precedence + , syntax $ T.pack $ show precedence , ident $ renderQualAlias for , keyword "as" , ident $ adjustAliasName alias declTitle ] + ExternKindDeclaration -> + [ keywordKind + , renderKind (P.NamedKind (notQualified declTitle)) + ] + where renderType' :: P.Type -> RenderedCode renderType' = renderTypeWithOptions opts - renderQualAlias :: FixityAlias -> String + renderQualAlias :: FixityAlias -> Text renderQualAlias (P.Qualified mn alias) - | mn == currentModule opts = T.unpack (renderAlias id alias) - | otherwise = T.unpack (renderAlias (\f -> P.showQualified f . P.Qualified mn) alias) + | mn == currentModule opts = renderAlias id alias + | otherwise = renderAlias (\f -> P.showQualified f . P.Qualified mn) alias renderAlias :: (forall a. (a -> Text) -> a -> Text) @@ -99,8 +102,7 @@ renderDeclarationWithOptions opts Declaration{..} = = either (("type " <>) . f P.runProperName) $ either (f P.runIdent) (f P.runProperName) - -- adjustAliasName (P.AliasType{}) title = drop 6 (init title) - adjustAliasName _ title = tail (init title) + adjustAliasName _ title = T.tail (T.init title) renderChildDeclaration :: ChildDeclaration -> RenderedCode renderChildDeclaration = renderChildDeclarationWithOptions defaultRenderTypeOptions @@ -146,15 +148,15 @@ renderConstraintsWithOptions opts constraints mintersperse (syntax "," <> sp) (map (renderConstraintWithOptions opts) constraints) -notQualified :: String -> P.Qualified (P.ProperName a) -notQualified = P.Qualified Nothing . P.ProperName . T.pack +notQualified :: Text -> P.Qualified (P.ProperName a) +notQualified = P.Qualified Nothing . P.ProperName -typeApp :: String -> [(String, Maybe P.Kind)] -> P.Type +typeApp :: Text -> [(Text, Maybe P.Kind)] -> P.Type typeApp title typeArgs = foldl P.TypeApp (P.TypeConstructor (notQualified title)) (map toTypeVar typeArgs) -toTypeVar :: (String, Maybe P.Kind) -> P.Type -toTypeVar (s, Nothing) = P.TypeVar (T.pack s) -toTypeVar (s, Just k) = P.KindedType (P.TypeVar (T.pack s)) k +toTypeVar :: (Text, Maybe P.Kind) -> P.Type +toTypeVar (s, Nothing) = P.TypeVar s +toTypeVar (s, Just k) = P.KindedType (P.TypeVar s) k diff --git a/src/Language/PureScript/Docs/RenderedCode/Render.hs b/src/Language/PureScript/Docs/RenderedCode/Render.hs index bae5544..281cd6b 100644 --- a/src/Language/PureScript/Docs/RenderedCode/Render.hs +++ b/src/Language/PureScript/Docs/RenderedCode/Render.hs @@ -14,10 +14,9 @@ import Prelude.Compat import Data.Maybe (fromMaybe) import Data.Monoid ((<>)) -import qualified Data.Text as T import Data.Text (Text) -import Control.Arrow ((<+>), first) +import Control.Arrow ((<+>)) import Control.PatternArrows as PA import Language.PureScript.Crash @@ -35,7 +34,7 @@ typeLiterals = mkPattern match match TypeWildcard{} = Just (syntax "_") match (TypeVar var) = - Just (ident (T.unpack var)) + Just (ident var) match (PrettyPrintObject row) = Just $ mintersperse sp [ syntax "{" @@ -43,7 +42,7 @@ typeLiterals = mkPattern match , syntax "}" ] match (TypeConstructor (Qualified mn name)) = - Just (ctor (T.unpack (runProperName name)) (maybeToContainingModule mn)) + Just (ctor (runProperName name) (maybeToContainingModule mn)) match REmpty = Just (syntax "()") match row@RCons{} = @@ -51,7 +50,7 @@ typeLiterals = mkPattern match match (BinaryNoParensType op l r) = Just $ renderTypeAtom l <> sp <> renderTypeAtom op <> sp <> renderTypeAtom r match (TypeOp (Qualified mn op)) = - Just (ident' (T.unpack (runOpName op)) (maybeToContainingModule mn)) + Just (ident' (runOpName op) (maybeToContainingModule mn)) match _ = Nothing @@ -76,16 +75,14 @@ renderConstraints deps ty = -- Render code representing a Row -- renderRow :: Type -> RenderedCode -renderRow = uncurry renderRow' . convertString . rowToList +renderRow = uncurry renderRow' . rowToList where - convertString :: ([(Text, Type)], Type) -> ([(String, Type)], Type) - convertString = first (map (first T.unpack)) renderRow' h t = renderHead h <> renderTail t -renderHead :: [(String, Type)] -> RenderedCode +renderHead :: [(Text, Type)] -> RenderedCode renderHead = mintersperse (syntax "," <> sp) . map renderLabel -renderLabel :: (String, Type) -> RenderedCode +renderLabel :: (Text, Type) -> RenderedCode renderLabel (label, ty) = mintersperse sp [ ident label @@ -145,10 +142,10 @@ matchType = buildPrettyPrinter operators matchTypeAtom , [ Wrap explicitParens $ \_ ty -> ty ] ] -forall_ :: Pattern () Type ([String], Type) +forall_ :: Pattern () Type ([Text], Type) forall_ = mkPattern match where - match (PrettyPrintForAll idents ty) = Just (map T.unpack idents, ty) + match (PrettyPrintForAll idents ty) = Just (idents, ty) match _ = Nothing insertPlaceholders :: RenderTypeOptions -> Type -> Type @@ -180,7 +177,7 @@ preprocessType opts = dePrim . insertPlaceholders opts -- Render code representing a Kind -- renderKind :: Kind -> RenderedCode -renderKind = kind . T.unpack . prettyPrintKind +renderKind = kind . prettyPrintKind -- | -- Render code representing a Type, as it should appear inside parentheses diff --git a/src/Language/PureScript/Docs/RenderedCode/Types.hs b/src/Language/PureScript/Docs/RenderedCode/Types.hs index 05bd8a1..ea42d66 100644 --- a/src/Language/PureScript/Docs/RenderedCode/Types.hs +++ b/src/Language/PureScript/Docs/RenderedCode/Types.hs @@ -29,6 +29,7 @@ module Language.PureScript.Docs.RenderedCode.Types , keywordInstance , keywordWhere , keywordFixity + , keywordKind ) where import Prelude.Compat @@ -37,7 +38,7 @@ import Control.Monad.Error.Class (MonadError(..)) import Data.Aeson.BetterErrors import qualified Data.Aeson as A -import qualified Data.Text as T +import Data.Text (Text) import qualified Language.PureScript as P @@ -46,11 +47,11 @@ import qualified Language.PureScript as P -- multiple output formats. For example, plain text, or highlighted HTML. -- data RenderedCodeElement - = Syntax String - | Ident String ContainingModule - | Ctor String ContainingModule - | Kind String - | Keyword String + = Syntax Text + | Ident Text ContainingModule + | Ctor Text ContainingModule + | Kind Text + | Keyword Text | Space deriving (Show, Eq, Ord) @@ -66,9 +67,9 @@ instance A.ToJSON RenderedCodeElement where toJSON (Keyword str) = A.toJSON ["keyword", str] toJSON Space = - A.toJSON ["space" :: String] + A.toJSON ["space" :: Text] -asRenderedCodeElement :: Parse String RenderedCodeElement +asRenderedCodeElement :: Parse Text RenderedCodeElement asRenderedCodeElement = a Syntax "syntax" <|> asIdent <|> @@ -80,14 +81,14 @@ asRenderedCodeElement = where p <|> q = catchError p (const q) - a ctor' ctorStr = ctor' <$> (nth 0 (withString (eq ctorStr)) *> nth 1 asString) - asIdent = nth 0 (withString (eq "ident")) *> (Ident <$> nth 1 asString <*> nth 2 asContainingModule) - asCtor = nth 0 (withString (eq "ctor")) *> (Ctor <$> nth 1 asString <*> nth 2 asContainingModule) - asSpace = nth 0 (withString (eq "space")) *> pure Space + a ctor' ctorStr = ctor' <$> (nth 0 (withText (eq ctorStr)) *> nth 1 asText) + asIdent = nth 0 (withText (eq "ident")) *> (Ident <$> nth 1 asText <*> nth 2 asContainingModule) + asCtor = nth 0 (withText (eq "ctor")) *> (Ctor <$> nth 1 asText <*> nth 2 asContainingModule) + asSpace = nth 0 (withText (eq "space")) *> pure Space eq s s' = if s == s' then Right () else Left "" - unableToParse = withString (Left . show) + unableToParse = withText Left -- | -- This type is isomorphic to 'Maybe' 'P.ModuleName'. It makes code a bit easier @@ -103,7 +104,7 @@ instance A.ToJSON ContainingModule where asContainingModule :: Parse e ContainingModule asContainingModule = - maybeToContainingModule <$> perhaps (P.moduleNameFromString . T.pack <$> asString) + maybeToContainingModule <$> perhaps (P.moduleNameFromString <$> asText) -- | -- Convert a 'Maybe' 'P.ModuleName' to a 'ContainingModule', using the obvious @@ -139,7 +140,7 @@ newtype RenderedCode instance A.ToJSON RenderedCode where toJSON (RC elems) = A.toJSON elems -asRenderedCode :: Parse String RenderedCode +asRenderedCode :: Parse Text RenderedCode asRenderedCode = RC <$> eachInArray asRenderedCodeElement -- | @@ -157,22 +158,22 @@ outputWith f = foldMap f . unRC sp :: RenderedCode sp = RC [Space] -syntax :: String -> RenderedCode +syntax :: Text -> RenderedCode syntax x = RC [Syntax x] -ident :: String -> RenderedCode +ident :: Text -> RenderedCode ident x = RC [Ident x ThisModule] -ident' :: String -> ContainingModule -> RenderedCode +ident' :: Text -> ContainingModule -> RenderedCode ident' x m = RC [Ident x m] -ctor :: String -> ContainingModule -> RenderedCode +ctor :: Text -> ContainingModule -> RenderedCode ctor x m = RC [Ctor x m] -kind :: String -> RenderedCode +kind :: Text -> RenderedCode kind x = RC [Kind x] -keyword :: String -> RenderedCode +keyword :: Text -> RenderedCode keyword kw = RC [Keyword kw] keywordForall :: RenderedCode @@ -200,3 +201,6 @@ keywordFixity :: P.Associativity -> RenderedCode keywordFixity P.Infixl = keyword "infixl" keywordFixity P.Infixr = keyword "infixr" keywordFixity P.Infix = keyword "infix" + +keywordKind :: RenderedCode +keywordKind = keyword "kind" diff --git a/src/Language/PureScript/Docs/Types.hs b/src/Language/PureScript/Docs/Types.hs index 506d24c..69edffa 100644 --- a/src/Language/PureScript/Docs/Types.hs +++ b/src/Language/PureScript/Docs/Types.hs @@ -8,14 +8,16 @@ import Prelude.Compat import Control.Arrow (first, (***)) import Control.Monad (when) +import Control.Monad.Error.Class (catchError) import Data.Aeson ((.=)) import Data.Aeson.BetterErrors import Data.ByteString.Lazy (ByteString) import Data.Either (isLeft, isRight) -import Data.Maybe (mapMaybe) +import Data.Maybe (mapMaybe, fromMaybe) import Data.Text (Text) import Data.Version +import qualified Data.Vector as V import qualified Data.Aeson as A import qualified Data.Text as T @@ -36,7 +38,7 @@ import Language.PureScript.Docs.RenderedCode as ReExports data Package a = Package { pkgMeta :: PackageMeta , pkgVersion :: Version - , pkgVersionTag :: String + , pkgVersionTag :: Text , pkgModules :: [Module] , pkgBookmarks :: [Bookmark] , pkgResolvedDependencies :: [(PackageName, Version)] @@ -71,16 +73,16 @@ packageName = bowerName . pkgMeta data Module = Module { modName :: P.ModuleName - , modComments :: Maybe String + , modComments :: Maybe Text , modDeclarations :: [Declaration] -- Re-exported values from other modules - , modReExports :: [(P.ModuleName, [Declaration])] + , modReExports :: [(InPackage P.ModuleName, [Declaration])] } deriving (Show, Eq, Ord) data Declaration = Declaration - { declTitle :: String - , declComments :: Maybe String + { declTitle :: Text + , declComments :: Maybe Text , declSourceSpan :: Maybe P.SourceSpan , declChildren :: [ChildDeclaration] , declInfo :: DeclarationInfo @@ -107,7 +109,7 @@ data DeclarationInfo -- newtype) and its type arguments. Constructors are represented as child -- declarations. -- - | DataDeclaration P.DataDeclType [(String, Maybe P.Kind)] + | DataDeclaration P.DataDeclType [(Text, Maybe P.Kind)] -- | -- A data type foreign import, with its kind. @@ -117,30 +119,54 @@ data DeclarationInfo -- | -- A type synonym, with its type arguments and its type. -- - | TypeSynonymDeclaration [(String, Maybe P.Kind)] P.Type + | TypeSynonymDeclaration [(Text, Maybe P.Kind)] P.Type -- | -- A type class, with its type arguments, its superclasses and functional -- dependencies. Instances and members are represented as child declarations. -- - | TypeClassDeclaration [(String, Maybe P.Kind)] [P.Constraint] [([String], [String])] + | TypeClassDeclaration [(Text, Maybe P.Kind)] [P.Constraint] [([Text], [Text])] -- | -- An operator alias declaration, with the member the alias is for and the -- operator's fixity. -- | AliasDeclaration P.Fixity FixityAlias + + -- | + -- A kind declaration + -- + | ExternKindDeclaration deriving (Show, Eq, Ord) +convertFundepsToStrings :: [(Text, Maybe P.Kind)] -> [P.FunctionalDependency] -> [([Text], [Text])] +convertFundepsToStrings args fundeps = + map (\(P.FunctionalDependency from to) -> toArgs from to) fundeps + where + argsVec = V.fromList (map fst args) + getArg i = + fromMaybe + (P.internalError $ unlines + [ "convertDeclaration: Functional dependency index" + , show i + , "is bigger than arguments list" + , show (map fst args) + , "Functional dependencies are" + , show fundeps + ] + ) $ argsVec V.!? i + toArgs from to = (map getArg from, map getArg to) + type FixityAlias = P.Qualified (Either (P.ProperName 'P.TypeName) (Either P.Ident (P.ProperName 'P.ConstructorName))) -declInfoToString :: DeclarationInfo -> String +declInfoToString :: DeclarationInfo -> Text declInfoToString (ValueDeclaration _) = "value" declInfoToString (DataDeclaration _ _) = "data" declInfoToString (ExternDataDeclaration _) = "externData" declInfoToString (TypeSynonymDeclaration _ _) = "typeSynonym" declInfoToString (TypeClassDeclaration _ _ _) = "typeClass" declInfoToString (AliasDeclaration _ _) = "alias" +declInfoToString ExternKindDeclaration = "kind" isTypeClass :: Declaration -> Bool isTypeClass Declaration{..} = @@ -174,14 +200,20 @@ isTypeAlias Declaration{..} = AliasDeclaration _ (P.Qualified _ d) -> isLeft d _ -> False +isKind :: Declaration -> Bool +isKind Declaration{..} = + case declInfo of + ExternKindDeclaration{} -> True + _ -> False + -- | Discard any children which do not satisfy the given predicate. filterChildren :: (ChildDeclaration -> Bool) -> Declaration -> Declaration filterChildren p decl = decl { declChildren = filter p (declChildren decl) } data ChildDeclaration = ChildDeclaration - { cdeclTitle :: String - , cdeclComments :: Maybe String + { cdeclTitle :: Text + , cdeclComments :: Maybe Text , cdeclSourceSpan :: Maybe P.SourceSpan , cdeclInfo :: ChildDeclarationInfo } @@ -206,7 +238,7 @@ data ChildDeclarationInfo | ChildTypeClassMember P.Type deriving (Show, Eq, Ord) -childDeclInfoToString :: ChildDeclarationInfo -> String +childDeclInfoToString :: ChildDeclarationInfo -> Text childDeclInfoToString (ChildInstance _ _) = "instance" childDeclInfoToString (ChildDataConstructor _) = "dataConstructor" childDeclInfoToString (ChildTypeClassMember _) = "typeClassMember" @@ -224,11 +256,11 @@ isDataConstructor ChildDeclaration{..} = _ -> False newtype GithubUser - = GithubUser { runGithubUser :: String } + = GithubUser { runGithubUser :: Text } deriving (Show, Eq, Ord) newtype GithubRepo - = GithubRepo { runGithubRepo :: String } + = GithubRepo { runGithubRepo :: Text } deriving (Show, Eq, Ord) data PackageError @@ -237,14 +269,14 @@ data PackageError -- parser, and actual version used. | ErrorInPackageMeta BowerError | InvalidVersion - | InvalidDeclarationType String - | InvalidChildDeclarationType String + | InvalidDeclarationType Text + | InvalidChildDeclarationType Text | InvalidFixity - | InvalidKind String - | InvalidDataDeclType String + | InvalidKind Text + | InvalidDataDeclType Text deriving (Show, Eq, Ord) -type Bookmark = InPackage (P.ModuleName, String) +type Bookmark = InPackage (P.ModuleName, Text) data InPackage a = Local a @@ -286,7 +318,7 @@ asPackage minimumVersion uploader = do Package <$> key "packageMeta" asPackageMeta .! ErrorInPackageMeta <*> key "version" asVersion - <*> key "versionTag" asString + <*> key "versionTag" asText <*> key "modules" (eachInArray asModule) <*> key "bookmarks" asBookmarks .! ErrorInPackageMeta <*> key "resolvedDependencies" asResolvedDependencies @@ -317,15 +349,15 @@ displayPackageError e = case e of InvalidVersion -> "Invalid version" InvalidDeclarationType str -> - "Invalid declaration type: \"" <> T.pack str <> "\"" + "Invalid declaration type: \"" <> str <> "\"" InvalidChildDeclarationType str -> - "Invalid child declaration type: \"" <> T.pack str <> "\"" + "Invalid child declaration type: \"" <> str <> "\"" InvalidFixity -> "Invalid fixity" InvalidKind str -> - "Invalid kind: \"" <> T.pack str <> "\"" + "Invalid kind: \"" <> str <> "\"" InvalidDataDeclType str -> - "Invalid data declaration type: \"" <> T.pack str <> "\"" + "Invalid data declaration type: \"" <> str <> "\"" where (<>) = T.append @@ -334,7 +366,7 @@ instance A.FromJSON a => A.FromJSON (Package a) where (asPackage (Version [0,0,0,0] []) fromAesonParser) asGithubUser :: Parse e GithubUser -asGithubUser = GithubUser <$> asString +asGithubUser = GithubUser <$> asText instance A.FromJSON GithubUser where parseJSON = toAesonParser' asGithubUser @@ -351,22 +383,33 @@ parseVersion' str = asModule :: Parse PackageError Module asModule = Module <$> key "name" (P.moduleNameFromString <$> asText) - <*> key "comments" (perhaps asString) + <*> key "comments" (perhaps asText) <*> key "declarations" (eachInArray asDeclaration) <*> key "reExports" (eachInArray asReExport) asDeclaration :: Parse PackageError Declaration asDeclaration = - Declaration <$> key "title" asString - <*> key "comments" (perhaps asString) + Declaration <$> key "title" asText + <*> key "comments" (perhaps asText) <*> key "sourceSpan" (perhaps asSourceSpan) <*> key "children" (eachInArray asChildDeclaration) <*> key "info" asDeclarationInfo -asReExport :: Parse PackageError (P.ModuleName, [Declaration]) +asReExport :: Parse PackageError (InPackage P.ModuleName, [Declaration]) asReExport = - (,) <$> key "moduleName" fromAesonParser + (,) <$> key "moduleName" asReExportModuleName <*> key "declarations" (eachInArray asDeclaration) + where + -- This is to preserve backwards compatibility with 0.10.3 and earlier versions + -- of the compiler, where the modReExports field had the type + -- [(P.ModuleName, [Declaration])]. This should eventually be removed, + -- possibly at the same time as the next breaking change to this JSON format. + asReExportModuleName :: Parse PackageError (InPackage P.ModuleName) + asReExportModuleName = + asInPackage fromAesonParser .! ErrorInPackageMeta + <|> fmap Local fromAesonParser + + (<|>) p q = catchError p (const q) asInPackage :: Parse BowerError a -> Parse BowerError (InPackage a) asInPackage inner = @@ -396,7 +439,7 @@ asAssociativity = withString (maybe (Left InvalidFixity) Right . parseAssociativ asDeclarationInfo :: Parse PackageError DeclarationInfo asDeclarationInfo = do - ty <- key "declType" asString + ty <- key "declType" asText case ty of "value" -> ValueDeclaration <$> key "type" asType @@ -415,13 +458,15 @@ asDeclarationInfo = do "alias" -> AliasDeclaration <$> key "fixity" asFixity <*> key "alias" asFixityAlias + "kind" -> + pure ExternKindDeclaration other -> throwCustomError (InvalidDeclarationType other) -asTypeArguments :: Parse PackageError [(String, Maybe P.Kind)] +asTypeArguments :: Parse PackageError [(Text, Maybe P.Kind)] asTypeArguments = eachInArray asTypeArgument where - asTypeArgument = (,) <$> nth 0 asString <*> nth 1 (perhaps asKind) + asTypeArgument = (,) <$> nth 0 asText <*> nth 1 (perhaps asKind) asKind :: Parse e P.Kind asKind = fromAesonParser @@ -429,28 +474,28 @@ asKind = fromAesonParser asType :: Parse e P.Type asType = fromAesonParser -asFunDeps :: Parse PackageError [([String], [String])] +asFunDeps :: Parse PackageError [([Text], [Text])] asFunDeps = eachInArray asFunDep where - asFunDep = (,) <$> nth 0 (eachInArray asString) <*> nth 1 (eachInArray asString) + asFunDep = (,) <$> nth 0 (eachInArray asText) <*> nth 1 (eachInArray asText) asDataDeclType :: Parse PackageError P.DataDeclType asDataDeclType = - withString $ \s -> case s of + withText $ \s -> case s of "data" -> Right P.Data "newtype" -> Right P.Newtype other -> Left (InvalidDataDeclType other) asChildDeclaration :: Parse PackageError ChildDeclaration asChildDeclaration = - ChildDeclaration <$> key "title" asString - <*> key "comments" (perhaps asString) + ChildDeclaration <$> key "title" asText + <*> key "comments" (perhaps asText) <*> key "sourceSpan" (perhaps asSourceSpan) <*> key "info" asChildDeclarationInfo asChildDeclarationInfo :: Parse PackageError ChildDeclarationInfo asChildDeclarationInfo = do - ty <- key "declType" asString + ty <- key "declType" asText case ty of "instance" -> ChildInstance <$> key "dependencies" (eachInArray asConstraint) @@ -483,7 +528,7 @@ asBookmarks = eachInArray asBookmark asBookmark :: Parse BowerError Bookmark asBookmark = asInPackage ((,) <$> nth 0 (P.moduleNameFromString <$> asText) - <*> nth 1 asString) + <*> nth 1 asText) asResolvedDependencies :: Parse PackageError [(PackageName, Version)] asResolvedDependencies = @@ -493,8 +538,8 @@ asResolvedDependencies = mapLeft _ (Right x) = Right x asGithub :: Parse e (GithubUser, GithubRepo) -asGithub = (,) <$> nth 0 (GithubUser <$> asString) - <*> nth 1 (GithubRepo <$> asString) +asGithub = (,) <$> nth 0 (GithubUser <$> asText) + <*> nth 1 (GithubRepo <$> asText) asSourceSpan :: Parse e P.SourceSpan asSourceSpan = P.SourceSpan <$> key "name" asString @@ -562,6 +607,7 @@ instance A.ToJSON DeclarationInfo where TypeSynonymDeclaration args ty -> ["arguments" .= args, "type" .= ty] TypeClassDeclaration args super fundeps -> ["arguments" .= args, "superclasses" .= super, "fundeps" .= fundeps] AliasDeclaration fixity alias -> ["fixity" .= fixity, "alias" .= alias] + ExternKindDeclaration -> [] instance A.ToJSON ChildDeclarationInfo where toJSON info = A.object $ "declType" .= childDeclInfoToString info : props diff --git a/src/Language/PureScript/Environment.hs b/src/Language/PureScript/Environment.hs index 01adeed..a62315f 100644 --- a/src/Language/PureScript/Environment.hs +++ b/src/Language/PureScript/Environment.hs @@ -8,11 +8,13 @@ import Data.Aeson.TH import qualified Data.Aeson as A import qualified Data.Map as M import qualified Data.Set as S -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, mapMaybe) import Data.Text (Text) import qualified Data.Text as T import Data.List (nub) +import Data.Tree (Tree, rootLabel) import qualified Data.Graph as G +import Data.Foldable (toList) import Language.PureScript.Crash import Language.PureScript.Kinds @@ -36,6 +38,8 @@ data Environment = Environment -- ^ Available type class dictionaries , typeClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData -- ^ Type classes + , kinds :: S.Set (Qualified (ProperName 'KindName)) + -- ^ Kinds in scope } deriving Show -- | Information about a type class @@ -55,6 +59,8 @@ data TypeClassData = TypeClassData -- ^ A set of indexes of type argument that are fully determined by other -- arguments via functional dependencies. This can be computed from both -- typeClassArguments and typeClassDependencies. + , typeClassCoveringSets :: S.Set (S.Set Int) + -- ^ A sets of arguments that can be used to infer all other arguments. } deriving Show -- | A functional dependency indicates a relationship between two sets of @@ -70,11 +76,14 @@ data FunctionalDependency = FunctionalDependency -- The initial environment with no values and only the default javascript types defined -- initEnvironment :: Environment -initEnvironment = Environment M.empty primTypes M.empty M.empty M.empty primClasses +initEnvironment = Environment M.empty primTypes M.empty M.empty M.empty primClasses primKinds -- | --- A constructor for TypeClassData that computes which type class arguments are fully determined. +-- A constructor for TypeClassData that computes which type class arguments are fully determined +-- and argument covering sets. -- Fully determined means that this argument cannot be used when selecting a type class instance. +-- A covering set is a minimal collection of arguments that can be used to find an instance and +-- therefore determine all other type arguments. -- -- An example of the difference between determined and fully determined would be with the class: -- ```class C a b c | a -> b, b -> a, b -> c``` @@ -82,7 +91,8 @@ initEnvironment = Environment M.empty primTypes M.empty M.empty M.empty primClas -- Both `a` and `b` can be used in selecting a type class instance. However, `c` cannot - it is -- fully determined by `a` and `b`. -- --- Define a graph of type class arguments with edges being fundep determiners to determined. +-- Define a graph of type class arguments with edges being fundep determiners to determined. Each +-- argument also has a self looping edge. -- An argument is fully determined if doesn't appear at the start of a path of strongly connected components. -- An argument is not fully determined otherwise. -- @@ -95,26 +105,51 @@ makeTypeClassData -> [Constraint] -> [FunctionalDependency] -> TypeClassData -makeTypeClassData args m s deps = TypeClassData args m s deps determinedArgs +makeTypeClassData args m s deps = TypeClassData args m s deps determinedArgs coveringSets where + argumentIndicies = [0 .. length args - 1] + + -- each argument determines themselves + identities = (\i -> (i, [i])) <$> argumentIndicies + -- list all the edges in the graph: for each fundep an edge exists for each determiner to each determined - contributingDeps = M.fromListWith (++) $ do + contributingDeps = M.fromListWith (++) $ identities ++ do fd <- deps src <- fdDeterminers fd (src, fdDetermined fd) : map (, []) (fdDetermined fd) - -- here we build a graph of which arguments determine other arguments - (depGraph, _, fromKey) = G.graphFromEdges ((\(n, v) -> (n, n, nub v)) <$> M.toList contributingDeps) + -- build a graph of which arguments determine other arguments + (depGraph, fromVertex, fromKey) = G.graphFromEdges ((\(n, v) -> (n, n, nub v)) <$> M.toList contributingDeps) -- do there exist any arguments that contribute to `arg` that `arg` doesn't contribute to + isFunDepDetermined :: Int -> Bool isFunDepDetermined arg = case fromKey arg of - Nothing -> False -- not mentioned in fundeps + Nothing -> internalError "Unknown argument index in makeTypeClassData" Just v -> let contributesToVar = G.reachable (G.transposeG depGraph) v varContributesTo = G.reachable depGraph v in any (\r -> not (r `elem` varContributesTo)) contributesToVar -- find all the arguments that are determined - determinedArgs = S.fromList $ filter isFunDepDetermined [0 .. length args - 1] + determinedArgs :: S.Set Int + determinedArgs = S.fromList $ filter isFunDepDetermined argumentIndicies + + argFromVertex :: G.Vertex -> Int + argFromVertex index = let (_, arg, _) = fromVertex index in arg + + isVertexDetermined :: G.Vertex -> Bool + isVertexDetermined = isFunDepDetermined . argFromVertex + + -- from an scc find the non-determined args + sccNonDetermined :: Tree G.Vertex -> Maybe [Int] + sccNonDetermined tree + -- if any arg in an scc is determined then all of them are + | isVertexDetermined (rootLabel tree) = Nothing + | otherwise = Just (argFromVertex <$> toList tree) + + -- find the covering sets + coveringSets :: S.Set (S.Set Int) + coveringSets = let funDepSets = sequence (mapMaybe sccNonDetermined (G.scc depGraph)) + in S.fromList (S.fromList <$> funDepSets) -- | -- The visibility of a name in scope @@ -209,6 +244,21 @@ instance A.FromJSON DataDeclType where primName :: Text -> Qualified (ProperName a) primName = Qualified (Just $ ModuleName [ProperName C.prim]) . ProperName +primKind :: Text -> Kind +primKind = NamedKind . primName + +-- | +-- Kinds in prim +-- +kindType :: Kind +kindType = primKind C.typ + +kindEffect :: Kind +kindEffect = primKind C.effect + +kindSymbol :: Kind +kindSymbol = primKind C.symbol + -- | -- Construct a type in the Prim module -- @@ -286,6 +336,16 @@ function :: Type -> Type -> Type function t1 = TypeApp (TypeApp tyFunction t1) -- | +-- The primitive kinds +primKinds :: S.Set (Qualified (ProperName 'KindName)) +primKinds = + S.fromList + [ primName C.typ + , primName C.effect + , primName C.symbol + ] + +-- | -- The primitive types in the external javascript environment with their -- associated kinds. There are also pseudo `Fail` and `Partial` types -- that correspond to the classes with the same names. @@ -293,18 +353,18 @@ function t1 = TypeApp (TypeApp tyFunction t1) primTypes :: M.Map (Qualified (ProperName 'TypeName)) (Kind, TypeKind) primTypes = M.fromList - [ (primName "Function", (FunKind Star (FunKind Star Star), ExternData)) - , (primName "Array", (FunKind Star Star, ExternData)) - , (primName "Record", (FunKind (Row Star) Star, ExternData)) - , (primName "String", (Star, ExternData)) - , (primName "Char", (Star, ExternData)) - , (primName "Number", (Star, ExternData)) - , (primName "Int", (Star, ExternData)) - , (primName "Boolean", (Star, ExternData)) - , (primName "Partial", (Star, ExternData)) - , (primName "Fail", (FunKind Symbol Star, ExternData)) - , (primName "TypeString", (FunKind Star Symbol, ExternData)) - , (primName "TypeConcat", (FunKind Symbol (FunKind Symbol Symbol), ExternData)) + [ (primName "Function", (FunKind kindType (FunKind kindType kindType), ExternData)) + , (primName "Array", (FunKind kindType kindType, ExternData)) + , (primName "Record", (FunKind (Row kindType) kindType, ExternData)) + , (primName "String", (kindType, ExternData)) + , (primName "Char", (kindType, ExternData)) + , (primName "Number", (kindType, ExternData)) + , (primName "Int", (kindType, ExternData)) + , (primName "Boolean", (kindType, ExternData)) + , (primName "Partial", (kindType, ExternData)) + , (primName "Fail", (FunKind kindSymbol kindType, ExternData)) + , (primName "TypeString", (FunKind kindType kindSymbol, ExternData)) + , (primName "TypeConcat", (FunKind kindSymbol (FunKind kindSymbol kindSymbol), ExternData)) ] -- | @@ -316,7 +376,7 @@ primClasses :: M.Map (Qualified (ProperName 'ClassName)) TypeClassData primClasses = M.fromList [ (primName "Partial", (makeTypeClassData [] [] [] [])) - , (primName "Fail", (makeTypeClassData [("message", Just Symbol)] [] [] [])) + , (primName "Fail", (makeTypeClassData [("message", Just kindSymbol)] [] [] [])) ] -- | diff --git a/src/Language/PureScript/Errors.hs b/src/Language/PureScript/Errors.hs index 40ee521..74831b4 100644 --- a/src/Language/PureScript/Errors.hs +++ b/src/Language/PureScript/Errors.hs @@ -289,8 +289,8 @@ onTypesInErrorMessageM f (ErrorMessage hints simple) = ErrorMessage <$> traverse gTypeSearch (TSBefore env) = pure (TSBefore env) gTypeSearch (TSAfter result) = TSAfter <$> traverse (traverse f) result -wikiUri :: ErrorMessage -> Text -wikiUri e = "https://github.com/purescript/purescript/wiki/Error-Code-" <> errorCode e +errorDocUri :: ErrorMessage -> Text +errorDocUri e = "https://github.com/purescript/documentation/blob/master/errors/" <> errorCode e <> ".md" -- TODO Other possible suggestions: -- WildcardInferredType - source span not small enough @@ -373,7 +373,7 @@ data PPEOptions = PPEOptions { ppeCodeColor :: Maybe (ANSI.ColorIntensity, ANSI.Color) -- ^ Color code with this color... or not , ppeFull :: Bool -- ^ Should write a full error message? , ppeLevel :: Level -- ^ Should this report an error or a warning? - , ppeShowWiki :: Bool -- ^ Should show a link to error message's wiki page? + , ppeShowDocs :: Bool -- ^ Should show a link to error message's doc page? } -- | Default options for PPEOptions @@ -382,7 +382,7 @@ defaultPPEOptions = PPEOptions { ppeCodeColor = Just defaultCodeColor , ppeFull = False , ppeLevel = Error - , ppeShowWiki = True + , ppeShowDocs = True } @@ -390,7 +390,7 @@ defaultPPEOptions = PPEOptions -- Pretty print a single error, simplifying if necessary -- prettyPrintSingleError :: PPEOptions -> ErrorMessage -> Box.Box -prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalState defaultUnknownMap $ do +prettyPrintSingleError (PPEOptions codeColor full level showDocs) e = flip evalState defaultUnknownMap $ do em <- onTypesInErrorMessageM replaceUnknowns (if full then e else simplifyErrorMessage e) um <- get return (prettyPrintErrorMessage um em) @@ -405,10 +405,10 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS ] ++ maybe [] (return . Box.moveDown 1) typeInformation ++ [ Box.moveDown 1 $ paras - [ line $ "See " <> wikiUri e <> " for more information, " + [ line $ "See " <> errorDocUri e <> " for more information, " , line $ "or to contribute content related to this " <> levelText <> "." ] - | showWiki + | showDocs ] where typeInformation :: Maybe Box.Box @@ -716,7 +716,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS , Box.vcat Box.left (map typeAtomAsBox ts) ] , line "is an orphan instance." - , line "An orphan instance is an instance which is defined in neither the class module nor the data type module." + , line "An orphan instance is one which is defined in a module that is unrelated to either the class or the collection of data types that the instance is defined for." , line "Consider moving the instance, if possible, or using a newtype wrapper." ] renderSimpleErrorMessage (InvalidNewtype name) = @@ -1030,6 +1030,7 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS nameType (DctorName _) = "data constructor" nameType (TyClassName _) = "type class" nameType (ModName _) = "module" + nameType (KiName _) = "kind" runName :: Qualified Name -> Text runName (Qualified mn (IdentName name)) = @@ -1044,6 +1045,8 @@ prettyPrintSingleError (PPEOptions codeColor full level showWiki) e = flip evalS showQualified runProperName (Qualified mn name) runName (Qualified mn (TyClassName name)) = showQualified runProperName (Qualified mn name) + runName (Qualified mn (KiName name)) = + showQualified runProperName (Qualified mn name) runName (Qualified Nothing (ModName name)) = runModuleName name runName (Qualified _ ModName{}) = @@ -1148,6 +1151,8 @@ prettyPrintRef (TypeInstanceRef ident) = Just $ showIdent ident prettyPrintRef (ModuleRef name) = Just $ "module " <> runModuleName name +prettyPrintRef (KindRef pn) = + Just $ "kind " <> runProperName pn prettyPrintRef (ReExportRef _ _) = Nothing prettyPrintRef (PositionedDeclarationRef _ _ ref) = diff --git a/src/Language/PureScript/Errors/JSON.hs b/src/Language/PureScript/Errors/JSON.hs index 8b0eadc..c7f085c 100644 --- a/src/Language/PureScript/Errors/JSON.hs +++ b/src/Language/PureScript/Errors/JSON.hs @@ -52,7 +52,7 @@ toJSONError verbose level e = JSONError (toErrorPosition <$> sspan) (P.renderBox (P.prettyPrintSingleError (P.PPEOptions Nothing verbose level False) (P.stripModuleAndSpan e))) (P.errorCode e) - (P.wikiUri e) + (P.errorDocUri e) (P.spanName <$> sspan) (P.runModuleName <$> P.errorModule e) (toSuggestion e) diff --git a/src/Language/PureScript/Externs.hs b/src/Language/PureScript/Externs.hs index 12f04ad..a75d094 100644 --- a/src/Language/PureScript/Externs.hs +++ b/src/Language/PureScript/Externs.hs @@ -24,6 +24,7 @@ import Data.Text (Text) import qualified Data.Text as T import Data.Version (showVersion) import qualified Data.Map as M +import qualified Data.Set as S import Language.PureScript.AST import Language.PureScript.Crash @@ -133,6 +134,10 @@ data ExternsDeclaration = , edInstanceTypes :: [Type] , edInstanceConstraints :: Maybe [Constraint] } + -- | A kind declaration + | EDKind + { edKindName :: ProperName 'KindName + } deriving Show -- | Convert an externs file back into a module @@ -145,6 +150,7 @@ applyExternsFileToEnvironment ExternsFile{..} = flip (foldl' applyDecl) efDeclar applyDecl env (EDDataConstructor pn dTy tNm ty nms) = env { dataConstructors = M.insert (qual pn) (dTy, tNm, ty, nms) (dataConstructors env) } applyDecl env (EDValue ident ty) = env { names = M.insert (Qualified (Just efModuleName) ident) (ty, External, Defined) (names env) } applyDecl env (EDClass pn args members cs deps) = env { typeClasses = M.insert (qual pn) (makeTypeClassData args members cs deps) (typeClasses env) } + applyDecl env (EDKind pn) = env { kinds = S.insert (qual pn) (kinds env) } applyDecl env (EDInstance className ident tys cs) = env { typeClassDictionaries = updateMap (updateMap (M.insert (qual ident) dict) className) (Just efModuleName) (typeClassDictionaries env) } where dict :: NamedDict @@ -220,6 +226,9 @@ moduleToExternsFile (Module _ _ mn ds (Just exps)) env = ExternsFile{..} , m2 <- M.elems m1 , TypeClassDictionaryInScope{..} <- maybeToList (M.lookup (Qualified (Just mn) ident) m2) ] + toExternsDeclaration (KindRef pn) + | Qualified (Just mn) pn `S.member` kinds env + = [ EDKind pn ] toExternsDeclaration _ = [] $(deriveJSON (defaultOptions { sumEncoding = ObjectWithSingleField }) ''ExternsImport) diff --git a/src/Language/PureScript/Ide/Externs.hs b/src/Language/PureScript/Ide/Externs.hs index d02f6bf..e50fb12 100644 --- a/src/Language/PureScript/Ide/Externs.hs +++ b/src/Language/PureScript/Ide/Externs.hs @@ -94,6 +94,7 @@ convertDecl P.EDDataConstructor{..} = Just $ IdeDeclDataConstructor $ convertDecl P.EDValue{..} = Just $ IdeDeclValue $ IdeValue edValueName edValueType convertDecl P.EDClass{..} = Just (IdeDeclTypeClass edClassName) +convertDecl P.EDKind{..} = Just (IdeDeclKind edKindName) convertDecl P.EDInstance{} = Nothing convertOperator :: P.ExternsFixity -> IdeDeclaration @@ -137,9 +138,12 @@ annotateModule (defs, types) (moduleName, decls) = annotateValue (op ^. ideValueOpAlias & valueOperatorAliasT) (IdeDeclValueOperator op) IdeDeclTypeOperator op -> annotateType (op ^. ideTypeOpAlias & typeOperatorAliasT) (IdeDeclTypeOperator op) + IdeDeclKind i -> + annotateKind (i ^. properNameT) (IdeDeclKind i) where - annotateFunction x = IdeDeclarationAnn (ann { annLocation = Map.lookup (Left (P.runIdent x)) defs + annotateFunction x = IdeDeclarationAnn (ann { annLocation = Map.lookup (IdeNSValue (P.runIdent x)) defs , annTypeAnnotation = Map.lookup x types }) - annotateValue x = IdeDeclarationAnn (ann {annLocation = Map.lookup (Left x) defs}) - annotateType x = IdeDeclarationAnn (ann {annLocation = Map.lookup (Right x) defs}) + annotateValue x = IdeDeclarationAnn (ann {annLocation = Map.lookup (IdeNSValue x) defs}) + annotateType x = IdeDeclarationAnn (ann {annLocation = Map.lookup (IdeNSType x) defs}) + annotateKind x = IdeDeclarationAnn (ann {annLocation = Map.lookup (IdeNSKind x) defs}) diff --git a/src/Language/PureScript/Ide/SourceFile.hs b/src/Language/PureScript/Ide/SourceFile.hs index c0b9695..21f1e0c 100644 --- a/src/Language/PureScript/Ide/SourceFile.hs +++ b/src/Language/PureScript/Ide/SourceFile.hs @@ -92,25 +92,26 @@ extractSpans -- ^ The surrounding span -> P.Declaration -- ^ The declaration to extract spans from - -> [(Either Text Text, P.SourceSpan)] - -- ^ A @Right@ corresponds to a type level declaration, and a @Left@ to a - -- value level one + -> [(IdeDeclNamespace, P.SourceSpan)] + -- ^ Declarations and their source locations extractSpans ss d = case d of P.PositionedDeclaration ss' _ d' -> extractSpans ss' d' P.ValueDeclaration i _ _ _ -> - [(Left (P.runIdent i), ss)] + [(IdeNSValue (P.runIdent i), ss)] P.TypeSynonymDeclaration name _ _ -> - [(Right (P.runProperName name), ss)] + [(IdeNSType (P.runProperName name), ss)] P.TypeClassDeclaration name _ _ _ members -> - (Right (P.runProperName name), ss) : concatMap (extractSpans' ss) members + (IdeNSType (P.runProperName name), ss) : concatMap (extractSpans' ss) members P.DataDeclaration _ name _ ctors -> - (Right (P.runProperName name), ss) - : map (\(cname, _) -> (Left (P.runProperName cname), ss)) ctors + (IdeNSType (P.runProperName name), ss) + : map (\(cname, _) -> (IdeNSValue (P.runProperName cname), ss)) ctors P.ExternDeclaration ident _ -> - [(Left (P.runIdent ident), ss)] + [(IdeNSValue (P.runIdent ident), ss)] P.ExternDataDeclaration name _ -> - [(Right (P.runProperName name), ss)] + [(IdeNSType (P.runProperName name), ss)] + P.ExternKindDeclaration name -> + [(IdeNSKind (P.runProperName name), ss)] _ -> [] where -- We need this special case to be able to also get the position info for @@ -121,5 +122,5 @@ extractSpans ss d = case d of P.PositionedDeclaration ssP' _ dP' -> extractSpans' ssP' dP' P.TypeDeclaration ident _ -> - [(Left (P.runIdent ident), ssP)] + [(IdeNSValue (P.runIdent ident), ssP)] _ -> [] diff --git a/src/Language/PureScript/Ide/Types.hs b/src/Language/PureScript/Ide/Types.hs index 3408e34..75e5d25 100644 --- a/src/Language/PureScript/Ide/Types.hs +++ b/src/Language/PureScript/Ide/Types.hs @@ -36,6 +36,7 @@ data IdeDeclaration | IdeDeclTypeClass (P.ProperName 'P.ClassName) | IdeDeclValueOperator IdeValueOperator | IdeDeclTypeOperator IdeTypeOperator + | IdeDeclKind (P.ProperName 'P.KindName) deriving (Show, Eq, Ord) data IdeValue = IdeValue @@ -102,7 +103,7 @@ emptyAnn = Annotation Nothing Nothing Nothing type Module = (P.ModuleName, [IdeDeclarationAnn]) -type DefinitionSites a = Map (Either Text Text) a +type DefinitionSites a = Map IdeDeclNamespace a type TypeAnnotations = Map P.Ident P.Type newtype AstData a = AstData (Map P.ModuleName (DefinitionSites a, TypeAnnotations)) -- ^ SourceSpans for the definition sites of Values and Types aswell as type @@ -214,6 +215,7 @@ identifierFromDeclarationRef :: P.DeclarationRef -> Text identifierFromDeclarationRef (P.TypeRef name _) = P.runProperName name identifierFromDeclarationRef (P.ValueRef ident) = P.runIdent ident identifierFromDeclarationRef (P.TypeClassRef name) = P.runProperName name +identifierFromDeclarationRef (P.KindRef name) = P.runProperName name identifierFromDeclarationRef _ = "" data Success = @@ -293,3 +295,12 @@ instance ToJSON PursuitResponse where , "package" .= package , "text" .= text ] + +data IdeDeclNamespace = + -- | An identifier in the value namespace + IdeNSValue Text + -- | An identifier in the type namespace + | IdeNSType Text + -- | An identifier in the kind namespace + | IdeNSKind Text + deriving (Show, Eq, Ord) diff --git a/src/Language/PureScript/Ide/Util.hs b/src/Language/PureScript/Ide/Util.hs index 0a61278..3345b9b 100644 --- a/src/Language/PureScript/Ide/Util.hs +++ b/src/Language/PureScript/Ide/Util.hs @@ -49,6 +49,7 @@ identifierFromIdeDeclaration d = case d of IdeDeclTypeClass name -> P.runProperName name IdeDeclValueOperator op -> op ^. ideValueOpName & P.runOpName IdeDeclTypeOperator op -> op ^. ideTypeOpName & P.runOpName + IdeDeclKind name -> P.runProperName name discardAnn :: IdeDeclarationAnn -> IdeDeclaration discardAnn (IdeDeclarationAnn _ d) = d @@ -73,6 +74,7 @@ completionFromMatch (Match (m, IdeDeclarationAnn ann decl)) = (P.runOpName op, maybe (showFixity precedence associativity (valueOperatorAliasT ref) op) prettyTypeT typeP) IdeDeclTypeOperator (IdeTypeOperator op ref precedence associativity kind) -> (P.runOpName op, maybe (showFixity precedence associativity (typeOperatorAliasT ref) op) (toS . P.prettyPrintKind) kind) + IdeDeclKind k -> (P.runProperName k, "kind") complModule = P.runModuleName m diff --git a/src/Language/PureScript/Interactive.hs b/src/Language/PureScript/Interactive.hs index b926383..db1cce7 100644 --- a/src/Language/PureScript/Interactive.hs +++ b/src/Language/PureScript/Interactive.hs @@ -200,6 +200,8 @@ handleShowImportedModules = do Just $ N.runIdent ident showRef (P.ModuleRef name) = Just $ "module " <> N.runModuleName name + showRef (P.KindRef pn) = + Just $ "kind " <> N.runProperName pn showRef (P.ReExportRef _ _) = Nothing showRef (P.PositionedDeclarationRef _ _ ref) = diff --git a/src/Language/PureScript/Interactive/Message.hs b/src/Language/PureScript/Interactive/Message.hs index 97ef4cb..e340da1 100644 --- a/src/Language/PureScript/Interactive/Message.hs +++ b/src/Language/PureScript/Interactive/Message.hs @@ -27,8 +27,8 @@ helpMessage = "The following commands are available:\n\n " ++ ] extraHelp = - "Further information is available on the PureScript wiki:\n" ++ - " --> https://github.com/purescript/purescript/wiki/psci" + "Further information is available on the PureScript documentation repository:\n" ++ + " --> https://github.com/purescript/documentation/blob/master/PSCi.md" -- | The welcome prologue. prologueMessage :: String @@ -48,7 +48,7 @@ supportModuleMessage = unlines , "" , " psc-package install psci-support" , "" - , "For help getting started, visit http://wiki.purescript.org/PSCi" + , "For help getting started, visit https://github.com/purescript/documentation/blob/master/PSCi.md" ] -- | The quit message. diff --git a/src/Language/PureScript/Interactive/Parser.hs b/src/Language/PureScript/Interactive/Parser.hs index e310543..160a04b 100644 --- a/src/Language/PureScript/Interactive/Parser.hs +++ b/src/Language/PureScript/Interactive/Parser.hs @@ -114,6 +114,7 @@ acceptable P.ExternDeclaration{} = True acceptable P.ExternDataDeclaration{} = True acceptable P.TypeClassDeclaration{} = True acceptable P.TypeInstanceDeclaration{} = True +acceptable P.ExternKindDeclaration{} = True acceptable _ = False parseReplQuery' :: String -> Either String ReplQuery diff --git a/src/Language/PureScript/Kinds.hs b/src/Language/PureScript/Kinds.hs index 519584e..78d126b 100644 --- a/src/Language/PureScript/Kinds.hs +++ b/src/Language/PureScript/Kinds.hs @@ -6,20 +6,18 @@ import Prelude.Compat import qualified Data.Aeson.TH as A +import Language.PureScript.Names + -- | The data type of kinds data Kind -- | Unification variable of type Kind = KUnknown Int - -- | The kind of types - | Star - -- | The kind of effects - | Bang -- | Kinds for labelled, unordered rows without duplicates | Row Kind -- | Function kinds | FunKind Kind Kind - -- | Type-level strings - | Symbol + -- | A named kind + | NamedKind (Qualified (ProperName 'KindName)) deriving (Show, Eq, Ord) $(A.deriveJSON A.defaultOptions ''Kind) diff --git a/src/Language/PureScript/Names.hs b/src/Language/PureScript/Names.hs index 508a256..8ca8fcc 100644 --- a/src/Language/PureScript/Names.hs +++ b/src/Language/PureScript/Names.hs @@ -24,6 +24,7 @@ data Name | DctorName (ProperName 'ConstructorName) | TyClassName (ProperName 'ClassName) | ModName ModuleName + | KiName (ProperName 'KindName) deriving (Eq, Show) getIdentName :: Name -> Maybe Ident @@ -117,7 +118,12 @@ instance FromJSON (ProperName a) where -- | -- The closed set of proper name types. -- -data ProperNameType = TypeName | ConstructorName | ClassName | Namespace +data ProperNameType + = TypeName + | ConstructorName + | ClassName + | KindName + | Namespace -- | -- Coerces a ProperName from one ProperNameType to another. This should be used diff --git a/src/Language/PureScript/Parser/Common.hs b/src/Language/PureScript/Parser/Common.hs index 67b4205..d60a394 100644 --- a/src/Language/PureScript/Parser/Common.hs +++ b/src/Language/PureScript/Parser/Common.hs @@ -32,6 +32,12 @@ typeName :: TokenParser (ProperName 'TypeName) typeName = ProperName <$> tyname -- | +-- Parse a proper name for a kind. +-- +kindName :: TokenParser (ProperName 'KindName) +kindName = ProperName <$> kiname + +-- | -- Parse a proper name for a data constructor. -- dataConstructorName :: TokenParser (ProperName 'ConstructorName) diff --git a/src/Language/PureScript/Parser/Declarations.hs b/src/Language/PureScript/Parser/Declarations.hs index eea6165..161a9b2 100644 --- a/src/Language/PureScript/Parser/Declarations.hs +++ b/src/Language/PureScript/Parser/Declarations.hs @@ -109,12 +109,16 @@ parseValueDeclaration = do return $ maybe value (`Let` value) whereClause parseExternDeclaration :: TokenParser Declaration -parseExternDeclaration = reserved "foreign" *> indented *> reserved "import" *> indented *> - (ExternDataDeclaration <$> (reserved "data" *> indented *> typeName) - <*> (indented *> doubleColon *> parseKind) - <|> (do ident <- parseIdent - ty <- indented *> doubleColon *> noWildcards parsePolyType - return $ ExternDeclaration ident ty)) +parseExternDeclaration = reserved "foreign" *> indented *> reserved "import" *> indented *> parseExternAlt where + parseExternAlt = parseExternData <|> P.try parseExternKind <|> parseExternTerm + + parseExternData = ExternDataDeclaration <$> (reserved "data" *> indented *> typeName) + <*> (indented *> doubleColon *> parseKind) + + parseExternKind = ExternKindDeclaration <$> (reserved "kind" *> indented *> kindName) + + parseExternTerm = ExternDeclaration <$> parseIdent + <*> (indented *> doubleColon *> noWildcards parsePolyType) parseAssociativity :: TokenParser Associativity parseAssociativity = @@ -163,7 +167,8 @@ parseImportDeclaration' = do parseDeclarationRef :: TokenParser DeclarationRef parseDeclarationRef = withSourceSpan PositionedDeclarationRef - $ (ValueRef <$> parseIdent) + $ (KindRef <$> P.try (reserved "kind" *> kindName)) + <|> (ValueRef <$> parseIdent) <|> (ValueOpRef <$> parens parseOperator) <|> parseTypeRef <|> (TypeClassRef <$> (reserved "class" *> properName)) diff --git a/src/Language/PureScript/Parser/Kinds.hs b/src/Language/PureScript/Parser/Kinds.hs index 6e0c09f..a0517bf 100644 --- a/src/Language/PureScript/Parser/Kinds.hs +++ b/src/Language/PureScript/Parser/Kinds.hs @@ -5,6 +5,7 @@ module Language.PureScript.Parser.Kinds (parseKind) where import Prelude.Compat +import Language.PureScript.Environment import Language.PureScript.Kinds import Language.PureScript.Parser.Common import Language.PureScript.Parser.Lexer @@ -13,26 +14,27 @@ import qualified Text.Parsec as P import qualified Text.Parsec.Expr as P parseStar :: TokenParser Kind -parseStar = const Star <$> symbol' "*" +parseStar = const kindType <$> symbol' "*" parseBang :: TokenParser Kind -parseBang = const Bang <$> symbol' "!" +parseBang = const kindEffect <$> symbol' "!" -parseSymbol :: TokenParser Kind -parseSymbol = const Symbol <$> uname' "Symbol" +parseNamedKind :: TokenParser Kind +parseNamedKind = NamedKind <$> parseQualified kindName -parseTypeAtom :: TokenParser Kind -parseTypeAtom = indented *> P.choice +parseKindAtom :: TokenParser Kind +parseKindAtom = indented *> P.choice [ parseStar , parseBang - , parseSymbol + , parseNamedKind , parens parseKind ] + -- | -- Parse a kind -- parseKind :: TokenParser Kind -parseKind = P.buildExpressionParser operators parseTypeAtom P.<?> "kind" +parseKind = P.buildExpressionParser operators parseKindAtom P.<?> "kind" where operators = [ [ P.Prefix (symbol' "#" >> return Row) ] , [ P.Infix (rarrow >> return FunKind) P.AssocRight ] ] diff --git a/src/Language/PureScript/Parser/Lexer.hs b/src/Language/PureScript/Parser/Lexer.hs index cbe90f5..59eff68 100644 --- a/src/Language/PureScript/Parser/Lexer.hs +++ b/src/Language/PureScript/Parser/Lexer.hs @@ -43,6 +43,7 @@ module Language.PureScript.Parser.Lexer , lname' , qualifier , tyname + , kiname , dconsname , uname , uname' @@ -474,6 +475,12 @@ tyname = token go P.<?> "type name" go (UName s) = Just s go _ = Nothing +kiname :: TokenParser Text +kiname = token go P.<?> "kind name" + where + go (UName s) = Just s + go _ = Nothing + dconsname :: TokenParser Text dconsname = token go P.<?> "data constructor name" where diff --git a/src/Language/PureScript/Pretty/Kinds.hs b/src/Language/PureScript/Pretty/Kinds.hs index 364ace9..0ec29ba 100644 --- a/src/Language/PureScript/Pretty/Kinds.hs +++ b/src/Language/PureScript/Pretty/Kinds.hs @@ -16,15 +16,14 @@ import Data.Text (Text) import Language.PureScript.Crash import Language.PureScript.Kinds +import Language.PureScript.Names import Language.PureScript.Pretty.Common typeLiterals :: Pattern () Kind String typeLiterals = mkPattern match where - match Star = Just "*" - match Bang = Just "!" - match Symbol = Just "Symbol" match (KUnknown u) = Just $ 'u' : show u + match (NamedKind name) = Just $ T.unpack (showQualified runProperName name) match _ = Nothing matchRow :: Pattern () Kind ((), Kind) diff --git a/src/Language/PureScript/Pretty/Values.hs b/src/Language/PureScript/Pretty/Values.hs index 72b1734..14838c5 100644 --- a/src/Language/PureScript/Pretty/Values.hs +++ b/src/Language/PureScript/Pretty/Values.hs @@ -54,15 +54,15 @@ prettyPrintValue d (IfThenElse cond th el) = // moveRight 2 (vcat left [ text "then " <> prettyPrintValueAtom (d - 1) th , text "else " <> prettyPrintValueAtom (d - 1) el ]) -prettyPrintValue d (Accessor prop val) = prettyPrintValueAtom (d - 1) val <> textT ("." Monoid.<> prettyPrintObjectKey prop) -prettyPrintValue d (ObjectUpdate o ps) = prettyPrintValueAtom (d - 1) o <> text " " <> list '{' '}' (\(key, val) -> textT (key Monoid.<> " = ") <> prettyPrintValue (d - 1) val) ps +prettyPrintValue d (Accessor prop val) = prettyPrintValueAtom (d - 1) val `before` textT ("." Monoid.<> prettyPrintObjectKey prop) +prettyPrintValue d (ObjectUpdate o ps) = prettyPrintValueAtom (d - 1) o `beforeWithSpace` list '{' '}' (\(key, val) -> textT (key Monoid.<> " = ") <> prettyPrintValue (d - 1) val) ps prettyPrintValue d (App val arg) = prettyPrintValueAtom (d - 1) val `beforeWithSpace` prettyPrintValueAtom (d - 1) arg prettyPrintValue d (Abs (Left arg) val) = text ('\\' : T.unpack (showIdent arg) ++ " -> ") // moveRight 2 (prettyPrintValue (d - 1) val) prettyPrintValue d (Abs (Right arg) val) = text ('\\' : T.unpack (prettyPrintBinder arg) ++ " -> ") // moveRight 2 (prettyPrintValue (d - 1) val) prettyPrintValue d (TypeClassDictionaryConstructorApp className ps) = text (T.unpack (runProperName (disqualify className)) ++ " ") <> prettyPrintValueAtom (d - 1) ps prettyPrintValue d (Case values binders) = - (text "case " <> foldl1 beforeWithSpace (map (prettyPrintValueAtom (d - 1)) values) <> text " of") // + (text "case " <> foldr beforeWithSpace (text "of") (map (prettyPrintValueAtom (d - 1)) values)) // moveRight 2 (vcat left (map (prettyPrintCaseAlternative (d - 1)) binders)) prettyPrintValue d (Let ds val) = text "let" // @@ -96,7 +96,7 @@ prettyPrintValueAtom d (BinaryNoParens op lhs rhs) = prettyPrintValue (d - 1) lhs `beforeWithSpace` printOp op `beforeWithSpace` prettyPrintValue (d - 1) rhs where printOp (Op (Qualified _ name)) = text $ T.unpack $ runOpName name - printOp expr = text "`" <> prettyPrintValue (d - 1) expr <> text "`" + printOp expr = text "`" <> prettyPrintValue (d - 1) expr `before` text "`" prettyPrintValueAtom d (TypedValue _ val _) = prettyPrintValueAtom d val prettyPrintValueAtom d (PositionedValue _ _ val) = prettyPrintValueAtom d val prettyPrintValueAtom d (Parens expr) = (text "(" <> prettyPrintValue d expr) `before` text ")" diff --git a/src/Language/PureScript/Publish.hs b/src/Language/PureScript/Publish.hs index 83589ba..136991a 100644 --- a/src/Language/PureScript/Publish.hs +++ b/src/Language/PureScript/Publish.hs @@ -23,7 +23,7 @@ module Language.PureScript.Publish import Prelude () import Prelude.Compat hiding (userError) -import Control.Arrow ((***)) +import Control.Arrow ((***), first) import Control.Category ((>>>)) import Control.Exception (catch, try) import Control.Monad.Error.Class (MonadError(..)) @@ -35,12 +35,13 @@ import Data.Aeson.BetterErrors import Data.Char (isSpace) import Data.Foldable (traverse_) import Data.Function (on) -import Data.List (stripPrefix, isSuffixOf, (\\), nubBy) +import Data.List (stripPrefix, (\\), nubBy) import Data.List.NonEmpty (NonEmpty(..)) import Data.List.Split (splitOn) import Data.Maybe import Data.Version import qualified Data.SPDX as SPDX +import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TL @@ -65,7 +66,7 @@ import qualified Language.PureScript.Docs as D data PublishOptions = PublishOptions { -- | How to obtain the version tag and version that the data being -- generated will refer to. - publishGetVersion :: PrepareM (String, Version) + publishGetVersion :: PrepareM (Text, Version) , -- | What to do when the working tree is dirty publishWorkingTreeDirty :: PrepareM () } @@ -184,21 +185,20 @@ checkCleanWorkingTree opts = do unless (status == Clean) $ publishWorkingTreeDirty opts -getVersionFromGitTag :: PrepareM (String, Version) +getVersionFromGitTag :: PrepareM (Text, Version) getVersionFromGitTag = do out <- readProcess' "git" ["tag", "--list", "--points-at", "HEAD"] "" let vs = map trimWhitespace (lines out) case mapMaybe parseMay vs of [] -> userError TagMustBeCheckedOut - [x] -> return x + [x] -> return (first T.pack x) xs -> userError (AmbiguousVersions (map snd xs)) where trimWhitespace = dropWhile isSpace >>> reverse >>> dropWhile isSpace >>> reverse - parseMay str = - (str,) <$> D.parseVersion' (dropPrefix "v" str) - dropPrefix prefix str = - fromMaybe str (stripPrefix prefix str) + parseMay str = do + digits <- stripPrefix "v" str + (str,) <$> D.parseVersion' digits getBowerRepositoryInfo :: PackageMeta -> PrepareM (D.GithubUser, D.GithubRepo) getBowerRepositoryInfo = either (userError . BadRepositoryField) return . tryExtract @@ -209,7 +209,7 @@ getBowerRepositoryInfo = either (userError . BadRepositoryField) return . tryExt Just Repository{..} -> do unless (repositoryType == "git") (Left (BadRepositoryType repositoryType)) - maybe (Left NotOnGithub) Right (extractGithub repositoryUrl) + maybe (Left NotOnGithub) Right (extractGithub (T.pack repositoryUrl)) checkLicense :: PackageMeta -> PrepareM () checkLicense pkgMeta = @@ -226,9 +226,9 @@ checkLicense pkgMeta = isValidSPDX :: String -> Bool isValidSPDX = (== 1) . length . SPDX.parseExpression -extractGithub :: String -> Maybe (D.GithubUser, D.GithubRepo) +extractGithub :: Text -> Maybe (D.GithubUser, D.GithubRepo) extractGithub = stripGitHubPrefixes - >>> fmap (splitOn "/") + >>> fmap (T.splitOn "/") >=> takeTwo >>> fmap (D.GithubUser *** (D.GithubRepo . dropDotGit)) @@ -237,18 +237,18 @@ extractGithub = stripGitHubPrefixes takeTwo [x, y] = Just (x, y) takeTwo _ = Nothing - stripGitHubPrefixes :: String -> Maybe String + stripGitHubPrefixes :: Text -> Maybe Text stripGitHubPrefixes = stripPrefixes [ "git://github.com/" , "https://github.com/" , "git@github.com:" ] - stripPrefixes :: [String] -> String -> Maybe String - stripPrefixes prefixes str = msum $ (`stripPrefix` str) <$> prefixes + stripPrefixes :: [Text] -> Text -> Maybe Text + stripPrefixes prefixes str = msum $ (`T.stripPrefix` str) <$> prefixes - dropDotGit :: String -> String + dropDotGit :: Text -> Text dropDotGit str - | ".git" `isSuffixOf` str = take (length str - 4) str + | ".git" `T.isSuffixOf` str = T.take (T.length str - 4) str | otherwise = str readProcess' :: String -> [String] -> String -> PrepareM String @@ -265,12 +265,12 @@ data DependencyStatus -- _resolution key. This can be caused by adding the dependency using -- `bower link`, or simply copying it into bower_components instead of -- installing it normally. - | ResolvedOther String - -- ^ Resolved, but to something other than a version. The String argument + | ResolvedOther Text + -- ^ Resolved, but to something other than a version. The Text argument -- is the resolution type. The values it can take that I'm aware of are -- "commit" and "branch". - | ResolvedVersion String - -- ^ Resolved to a version. The String argument is the resolution tag (eg, + | ResolvedVersion Text + -- ^ Resolved to a version. The Text argument is the resolution tag (eg, -- "v0.1.0"). deriving (Show, Eq) @@ -341,9 +341,9 @@ asDependencyStatus = do else key "pkgMeta" $ keyOrDefault "_resolution" NoResolution $ do - type_ <- key "type" asString + type_ <- key "type" asText case type_ of - "version" -> ResolvedVersion <$> key "tag" asString + "version" -> ResolvedVersion <$> key "tag" asText other -> return (ResolvedOther other) warnUndeclared :: [PackageName] -> [PackageName] -> PrepareM () @@ -374,15 +374,16 @@ handleDeps deps = do bowerDir pkgName = "bower_components/" ++ runPackageName pkgName -- Try to extract a version, and warn if unsuccessful. + tryExtractVersion' :: (PackageName, Text) -> PrepareM (Maybe (PackageName, Version)) tryExtractVersion' pair = maybe (warn (UnacceptableVersion pair) >> return Nothing) (return . Just) (tryExtractVersion pair) -tryExtractVersion :: (PackageName, String) -> Maybe (PackageName, Version) +tryExtractVersion :: (PackageName, Text) -> Maybe (PackageName, Version) tryExtractVersion (pkgName, tag) = - let tag' = fromMaybe tag (stripPrefix "v" tag) - in (pkgName,) <$> D.parseVersion' tag' + let tag' = fromMaybe tag (T.stripPrefix "v" tag) + in (pkgName,) <$> D.parseVersion' (T.unpack tag') -- | Returns whether it looks like there is a purescript package checked out -- in the given directory. diff --git a/src/Language/PureScript/Publish/ErrorsWarnings.hs b/src/Language/PureScript/Publish/ErrorsWarnings.hs index db7d7de..597b2a4 100644 --- a/src/Language/PureScript/Publish/ErrorsWarnings.hs +++ b/src/Language/PureScript/Publish/ErrorsWarnings.hs @@ -24,6 +24,7 @@ import Data.Maybe import Data.Monoid import Data.Version import qualified Data.List.NonEmpty as NonEmpty +import Data.Text (Text) import qualified Data.Text as T import Language.PureScript.Publish.BoxesHelpers @@ -43,7 +44,7 @@ data PackageError data PackageWarning = NoResolvedVersion PackageName | UndeclaredDependency PackageName - | UnacceptableVersion (PackageName, String) + | UnacceptableVersion (PackageName, Text) | DirtyWorkingTree_Warn deriving (Show) @@ -147,9 +148,8 @@ displayUserError e = case e of , "version." ]) , spacer - , para "Note: tagged versions must be in one of the following forms:" - , indented (para "* v{MAJOR}.{MINOR}.{PATCH} (example: \"v1.6.2\")") - , indented (para "* {MAJOR}.{MINOR}.{PATCH} (example: \"1.6.2\")") + , para "Note: tagged versions must be in the form" + , indented (para "v{MAJOR}.{MINOR}.{PATCH} (example: \"v1.6.2\")") , spacer , para (concat [ "If the version you are publishing is not yet tagged, you might " @@ -311,7 +311,7 @@ displayOtherError e = case e of data CollectedWarnings = CollectedWarnings { noResolvedVersions :: [PackageName] , undeclaredDependencies :: [PackageName] - , unacceptableVersions :: [(PackageName, String)] + , unacceptableVersions :: [(PackageName, Text)] , dirtyWorkingTree :: Any } deriving (Show, Eq, Ord) @@ -387,7 +387,7 @@ warnUndeclaredDependencies pkgNames = ]) : bulletedList runPackageName (NonEmpty.toList pkgNames) -warnUnacceptableVersions :: NonEmpty (PackageName, String) -> Box +warnUnacceptableVersions :: NonEmpty (PackageName, Text) -> Box warnUnacceptableVersions pkgs = let singular = NonEmpty.length pkgs == 1 pl a b = if singular then b else a @@ -414,7 +414,7 @@ warnUnacceptableVersions pkgs = ]) ] where - showTuple (pkgName, tag) = runPackageName pkgName ++ "#" ++ tag + showTuple (pkgName, tag) = runPackageName pkgName ++ "#" ++ T.unpack tag warnDirtyWorkingTree :: Box warnDirtyWorkingTree = diff --git a/src/Language/PureScript/Sugar.hs b/src/Language/PureScript/Sugar.hs index 7ec61cf..0a1d272 100644 --- a/src/Language/PureScript/Sugar.hs +++ b/src/Language/PureScript/Sugar.hs @@ -62,6 +62,6 @@ desugar externs = >=> desugarImports externs >=> rebracket externs >=> traverse checkFixityExports - >=> traverse deriveInstances + >=> traverse (deriveInstances externs) >=> desugarTypeClasses externs >=> traverse createBindingGroupsModule diff --git a/src/Language/PureScript/Sugar/BindingGroups.hs b/src/Language/PureScript/Sugar/BindingGroups.hs index a7cd113..4d0d7a5 100644 --- a/src/Language/PureScript/Sugar/BindingGroups.hs +++ b/src/Language/PureScript/Sugar/BindingGroups.hs @@ -73,6 +73,7 @@ createBindingGroups moduleName = mapM f <=< handleDecls valueVerts = map (\d -> (d, declIdent d, usedIdents moduleName d `intersect` allIdents)) values bindingGroupDecls <- parU (stronglyConnComp valueVerts) (toBindingGroup moduleName) return $ filter isImportDecl ds ++ + filter isExternKindDecl ds ++ filter isExternDataDecl ds ++ dataBindingGroupDecls ++ filter isTypeClassDeclaration ds ++ diff --git a/src/Language/PureScript/Sugar/Names.hs b/src/Language/PureScript/Sugar/Names.hs index 2d2a483..a0ffbfa 100644 --- a/src/Language/PureScript/Sugar/Names.hs +++ b/src/Language/PureScript/Sugar/Names.hs @@ -25,6 +25,7 @@ import Language.PureScript.AST import Language.PureScript.Crash import Language.PureScript.Errors import Language.PureScript.Externs +import Language.PureScript.Kinds import Language.PureScript.Linter.Imports import Language.PureScript.Names import Language.PureScript.Sugar.Names.Env @@ -98,6 +99,9 @@ desugarImportsWithEnv externs modules = do exportedRefs :: Ord a => (DeclarationRef -> Maybe a) -> M.Map a ModuleName exportedRefs f = M.fromList $ (, efModuleName) <$> mapMaybe f efExports + exportedKinds :: M.Map (ProperName 'KindName) ModuleName + exportedKinds = exportedRefs getKindRef + updateEnv :: ([Module], Env) -> Module -> m ([Module], Env) updateEnv (ms, env) m@(Module ss _ mn _ refs) = do members <- findExportable m @@ -128,6 +132,7 @@ elaborateExports exps (Module ss coms mn decls refs) = ++ go TypeClassRef exportedTypeClasses ++ go ValueRef exportedValues ++ go ValueOpRef exportedValueOps + ++ go KindRef exportedKinds ++ maybe [] (filter isModuleRef) refs where @@ -165,17 +170,24 @@ renameInModule imports (Module ss coms mn decls exps) = updateDecl (_, bound) d@(PositionedDeclaration pos _ _) = return ((Just pos, bound), d) updateDecl (pos, bound) (DataDeclaration dtype name args dctors) = - (,) (pos, bound) <$> (DataDeclaration dtype name args <$> traverse (sndM (traverse (updateTypesEverywhere pos))) dctors) + (,) (pos, bound) <$> (DataDeclaration dtype name <$> updateTypeArguments pos args + <*> traverse (sndM (traverse (updateTypesEverywhere pos))) dctors) updateDecl (pos, bound) (TypeSynonymDeclaration name ps ty) = - (,) (pos, bound) <$> (TypeSynonymDeclaration name ps <$> updateTypesEverywhere pos ty) + (,) (pos, bound) <$> (TypeSynonymDeclaration name <$> updateTypeArguments pos ps + <*> updateTypesEverywhere pos ty) updateDecl (pos, bound) (TypeClassDeclaration className args implies deps ds) = - (,) (pos, bound) <$> (TypeClassDeclaration className args <$> updateConstraints pos implies <*> pure deps <*> pure ds) + (,) (pos, bound) <$> (TypeClassDeclaration className <$> updateTypeArguments pos args + <*> updateConstraints pos implies + <*> pure deps + <*> pure ds) updateDecl (pos, bound) (TypeInstanceDeclaration name cs cn ts ds) = (,) (pos, bound) <$> (TypeInstanceDeclaration name <$> updateConstraints pos cs <*> updateClassName cn pos <*> traverse (updateTypesEverywhere pos) ts <*> pure ds) updateDecl (pos, bound) (TypeDeclaration name ty) = (,) (pos, bound) <$> (TypeDeclaration name <$> updateTypesEverywhere pos ty) updateDecl (pos, bound) (ExternDeclaration name ty) = (,) (pos, name : bound) <$> (ExternDeclaration name <$> updateTypesEverywhere pos ty) + updateDecl (pos, bound) (ExternDataDeclaration name ki) = + (,) (pos, bound) <$> (ExternDataDeclaration name <$> updateKindsEverywhere pos ki) updateDecl (pos, bound) (TypeFixityDeclaration fixity alias op) = (,) (pos, bound) <$> (TypeFixityDeclaration fixity <$> updateTypeName alias pos <*> pure op) updateDecl (pos, bound) (ValueFixityDeclaration fixity (Qualified mn' (Left alias)) op) = @@ -238,6 +250,19 @@ renameInModule imports (Module ss coms mn decls exps) = letBoundVariable (PositionedDeclaration _ _ d) = letBoundVariable d letBoundVariable _ = Nothing + updateKindsEverywhere :: Maybe SourceSpan -> Kind -> m Kind + updateKindsEverywhere pos = everywhereOnKindsM updateKind + where + updateKind :: Kind -> m Kind + updateKind (NamedKind name) = NamedKind <$> updateKindName name pos + updateKind k = return k + + updateTypeArguments + :: (Traversable f, Traversable g) + => Maybe SourceSpan + -> f (a, g Kind) -> m (f (a, g Kind)) + updateTypeArguments pos = traverse (sndM (traverse (updateKindsEverywhere pos))) + updateTypesEverywhere :: Maybe SourceSpan -> Type -> m Type updateTypesEverywhere pos = everywhereOnTypesM updateType where @@ -245,16 +270,17 @@ renameInModule imports (Module ss coms mn decls exps) = updateType (TypeOp name) = TypeOp <$> updateTypeOpName name pos updateType (TypeConstructor name) = TypeConstructor <$> updateTypeName name pos updateType (ConstrainedType cs t) = ConstrainedType <$> traverse updateInConstraint cs <*> pure t + updateType (KindedType t k) = KindedType t <$> updateKindsEverywhere pos k updateType t = return t updateInConstraint :: Constraint -> m Constraint updateInConstraint (Constraint name ts info) = Constraint <$> updateClassName name pos <*> pure ts <*> pure info updateConstraints :: Maybe SourceSpan -> [Constraint] -> m [Constraint] - updateConstraints pos = traverse $ \(Constraint name ts info) ->
- Constraint
- <$> updateClassName name pos
- <*> traverse (updateTypesEverywhere pos) ts
+ updateConstraints pos = traverse $ \(Constraint name ts info) -> + Constraint + <$> updateClassName name pos + <*> traverse (updateTypesEverywhere pos) ts <*> pure info updateTypeName @@ -290,6 +316,12 @@ renameInModule imports (Module ss coms mn decls exps) = -> m (Qualified (OpName 'ValueOpName)) updateValueOpName = update (importedValueOps imports) ValOpName + updateKindName + :: Qualified (ProperName 'KindName) + -> Maybe SourceSpan + -> m (Qualified (ProperName 'KindName)) + updateKindName = update (importedKinds imports) KiName + -- Update names so unqualified references become qualified, and locally -- qualified references are replaced with their canoncial qualified names -- (e.g. M.Map -> Data.Map.Map). diff --git a/src/Language/PureScript/Sugar/Names/Env.hs b/src/Language/PureScript/Sugar/Names/Env.hs index 36c5700..7b527e4 100644 --- a/src/Language/PureScript/Sugar/Names/Env.hs +++ b/src/Language/PureScript/Sugar/Names/Env.hs @@ -16,6 +16,7 @@ module Language.PureScript.Sugar.Names.Env , exportTypeClass , exportValue , exportValueOp + , exportKind , getExports , checkImportConflicts ) where @@ -71,27 +72,27 @@ type ImportMap a = M.Map (Qualified a) [ImportRecord a] data Imports = Imports { -- | - -- Local names for types within a module mapped to to their qualified names + -- Local names for types within a module mapped to their qualified names -- importedTypes :: ImportMap (ProperName 'TypeName) -- | - -- Local names for type operators within a module mapped to to their qualified names + -- Local names for type operators within a module mapped to their qualified names -- , importedTypeOps :: ImportMap (OpName 'TypeOpName) -- | - -- Local names for data constructors within a module mapped to to their qualified names + -- Local names for data constructors within a module mapped to their qualified names -- , importedDataConstructors :: ImportMap (ProperName 'ConstructorName) -- | - -- Local names for classes within a module mapped to to their qualified names + -- Local names for classes within a module mapped to their qualified names -- , importedTypeClasses :: ImportMap (ProperName 'ClassName) -- | - -- Local names for values within a module mapped to to their qualified names + -- Local names for values within a module mapped to their qualified names -- , importedValues :: ImportMap Ident -- | - -- Local names for value operators within a module mapped to to their qualified names + -- Local names for value operators within a module mapped to their qualified names -- , importedValueOps :: ImportMap (OpName 'ValueOpName) -- | @@ -104,10 +105,14 @@ data Imports = Imports -- The "as" names of modules that have been imported qualified. -- , importedQualModules :: S.Set ModuleName + -- | + -- Local names for kinds within a module mapped to their qualified names + -- + , importedKinds :: ImportMap (ProperName 'KindName) } deriving (Show) nullImports :: Imports -nullImports = Imports M.empty M.empty M.empty M.empty M.empty M.empty S.empty S.empty +nullImports = Imports M.empty M.empty M.empty M.empty M.empty M.empty S.empty S.empty M.empty -- | -- An 'Imports' value with imports for the `Prim` module. @@ -117,6 +122,7 @@ primImports = nullImports { importedTypes = M.fromList $ mkEntries `concatMap` M.keys primTypes , importedTypeClasses = M.fromList $ mkEntries `concatMap` M.keys primClasses + , importedKinds = M.fromList $ mkEntries `concatMap` S.toList primKinds } where mkEntries :: Qualified a -> [(Qualified a, [ImportRecord a])] @@ -155,13 +161,17 @@ data Exports = Exports -- from. -- , exportedValueOps :: M.Map (OpName 'ValueOpName) ModuleName + -- | + -- The exported kinds along with the module they originally came from. + -- + , exportedKinds :: M.Map (ProperName 'KindName) ModuleName } deriving (Show) -- | -- An empty 'Exports' value. -- nullExports :: Exports -nullExports = Exports M.empty M.empty M.empty M.empty M.empty +nullExports = Exports M.empty M.empty M.empty M.empty M.empty M.empty -- | -- The imports and exports for a collection of modules. The 'SourceSpan' is used @@ -196,10 +206,12 @@ primExports = nullExports { exportedTypes = M.fromList $ mkTypeEntry `map` M.keys primTypes , exportedTypeClasses = M.fromList $ mkClassEntry `map` M.keys primClasses + , exportedKinds = M.fromList $ mkKindEntry `map` S.toList primKinds } where mkTypeEntry (Qualified mn name) = (name, ([], fromJust mn)) mkClassEntry (Qualified mn name) = (name, fromJust mn) + mkKindEntry (Qualified mn name) = (name, fromJust mn) -- | Environment which only contains the Prim module. primEnv :: Env @@ -317,6 +329,19 @@ exportValueOp exps op mn = do return $ exps { exportedValueOps = valueOps } -- | +-- Safely adds a kind to some exports, returning an error if a conflict occurs. +-- +exportKind + :: MonadError MultipleErrors m + => Exports + -> ProperName 'KindName + -> ModuleName + -> m Exports +exportKind exps name mn = do + kinds <- addExport KiName name mn (exportedKinds exps) + return $ exps { exportedKinds = kinds } + +-- | -- Adds an entry to a list of exports unless it is already present, in which -- case an error is returned. -- diff --git a/src/Language/PureScript/Sugar/Names/Exports.hs b/src/Language/PureScript/Sugar/Names/Exports.hs index 51facc0..ac502f5 100644 --- a/src/Language/PureScript/Sugar/Names/Exports.hs +++ b/src/Language/PureScript/Sugar/Names/Exports.hs @@ -19,7 +19,7 @@ import Language.PureScript.AST import Language.PureScript.Crash import Language.PureScript.Errors import Language.PureScript.Names -import Language.PureScript.Sugar.Names.Env
+import Language.PureScript.Sugar.Names.Env import Language.PureScript.Sugar.Names.Common (warnDuplicateRefs) -- | @@ -51,6 +51,8 @@ findExportable (Module _ _ mn ds _) = exportTypeOp exps op mn updateExports exps (ExternDeclaration name _) = exportValue exps name mn + updateExports exps (ExternKindDeclaration pn) = + exportKind exps pn mn updateExports exps (PositionedDeclaration pos _ d) = rethrowWithPosition pos $ updateExports exps d updateExports exps _ = return exps @@ -61,21 +63,21 @@ findExportable (Module _ _ mn ds _) = -- resolveExports :: forall m - . (MonadError MultipleErrors m, MonadWriter MultipleErrors m)
- => Env
- -> SourceSpan
+ . (MonadError MultipleErrors m, MonadWriter MultipleErrors m) + => Env + -> SourceSpan -> ModuleName -> Imports -> Exports -> [DeclarationRef] -> m Exports -resolveExports env ss mn imps exps refs =
- warnAndRethrow (addHint (ErrorInModule mn)) $ do
+resolveExports env ss mn imps exps refs = + warnAndRethrow (addHint (ErrorInModule mn)) $ do filtered <- filterModule mn exps refs - exps' <- foldM elaborateModuleExports filtered refs
- warnDuplicateRefs ss DuplicateExportRef refs
- return exps'
-
+ exps' <- foldM elaborateModuleExports filtered refs + warnDuplicateRefs ss DuplicateExportRef refs + return exps' + where -- Takes the current module's imports, the accumulated list of exports, and a @@ -83,19 +85,21 @@ resolveExports env ss mn imps exps refs = -- module, export anything from the imports that matches for that module. elaborateModuleExports :: Exports -> DeclarationRef -> m Exports elaborateModuleExports result (PositionedDeclarationRef pos _ r) = - warnAndRethrowWithPosition pos $ elaborateModuleExports result r
+ warnAndRethrowWithPosition pos $ elaborateModuleExports result r elaborateModuleExports result (ModuleRef name) | name == mn = do let types' = exportedTypes result `M.union` exportedTypes exps let typeOps' = exportedTypeOps result `M.union` exportedTypeOps exps let classes' = exportedTypeClasses result `M.union` exportedTypeClasses exps let values' = exportedValues result `M.union` exportedValues exps let valueOps' = exportedValueOps result `M.union` exportedValueOps exps + let kinds' = exportedKinds result `M.union` exportedKinds exps return result { exportedTypes = types' , exportedTypeOps = typeOps' , exportedTypeClasses = classes' , exportedValues = values' , exportedValueOps = valueOps' + , exportedKinds = kinds' } elaborateModuleExports result (ModuleRef name) = do let isPseudo = isPseudoModule name @@ -107,11 +111,13 @@ resolveExports env ss mn imps exps refs = reClasses <- extract isPseudo name TyClassName (importedTypeClasses imps) reValues <- extract isPseudo name IdentName (importedValues imps) reValueOps <- extract isPseudo name ValOpName (importedValueOps imps) + reKinds <- extract isPseudo name KiName (importedKinds imps) foldM (\exps' ((tctor, dctors), mn') -> exportType ReExport exps' tctor dctors mn') result (resolveTypeExports reTypes reDctors) >>= flip (foldM (uncurry . exportTypeOp)) (map resolveTypeOp reTypeOps) >>= flip (foldM (uncurry . exportTypeClass ReExport)) (map resolveClass reClasses) >>= flip (foldM (uncurry . exportValue)) (map resolveValue reValues) >>= flip (foldM (uncurry . exportValueOp)) (map resolveValueOp reValueOps) + >>= flip (foldM (uncurry . exportKind)) (map resolveKind reKinds) elaborateModuleExports result _ = return result -- Extracts a list of values for a module based on a lookup table. If the @@ -146,6 +152,7 @@ resolveExports env ss mn imps exps refs = || any (isQualifiedWith mn') (f (importedTypeClasses imps)) || any (isQualifiedWith mn') (f (importedValues imps)) || any (isQualifiedWith mn') (f (importedValueOps imps)) + || any (isQualifiedWith mn') (f (importedKinds imps)) -- Check whether a module name refers to a module that has been imported -- without qualification into an import scope. @@ -203,6 +210,14 @@ resolveExports env ss mn imps exps refs = . fromMaybe (internalError "Missing value in resolveValueOp") $ resolve exportedValueOps op + -- Looks up an imported kind and re-qualifies it with the original + -- module it came from. + resolveKind :: Qualified (ProperName 'KindName) -> (ProperName 'KindName, ModuleName) + resolveKind kind + = splitQual + . fromMaybe (internalError "Missing value in resolveKind") + $ resolve exportedKinds kind + resolve :: Ord a => (Exports -> M.Map a ModuleName) @@ -237,12 +252,14 @@ filterModule mn exps refs = do classes <- foldM (filterExport TyClassName getTypeClassRef exportedTypeClasses) M.empty refs values <- foldM (filterExport IdentName getValueRef exportedValues) M.empty refs valueOps <- foldM (filterExport ValOpName getValueOpRef exportedValueOps) M.empty refs + kinds <- foldM (filterExport KiName getKindRef exportedKinds) M.empty refs return Exports { exportedTypes = types , exportedTypeOps = typeOps , exportedTypeClasses = classes , exportedValues = values , exportedValueOps = valueOps + , exportedKinds = kinds } where diff --git a/src/Language/PureScript/Sugar/Names/Imports.hs b/src/Language/PureScript/Sugar/Names/Imports.hs index 616921b..9250038 100644 --- a/src/Language/PureScript/Sugar/Names/Imports.hs +++ b/src/Language/PureScript/Sugar/Names/Imports.hs @@ -130,6 +130,8 @@ resolveImport importModule exps imps impQual = resolveByType checkImportExists TyClassName (exportedTypeClasses exps) name check (ModuleRef name) | isHiding = throwError . errorMessage $ ImportHidingModule name + check (KindRef name) = do + checkImportExists KiName (exportedKinds exps) name check r = internalError $ "Invalid argument to checkRefs: " ++ show r -- Check that an explicitly imported item exists in the module it is being imported from @@ -181,6 +183,7 @@ resolveImport importModule exps imps impQual = resolveByType >>= flip (foldM (\m (name, _) -> importer m (ValueRef name))) (M.toList (exportedValues exps)) >>= flip (foldM (\m (name, _) -> importer m (ValueOpRef name))) (M.toList (exportedValueOps exps)) >>= flip (foldM (\m (name, _) -> importer m (TypeClassRef name))) (M.toList (exportedTypeClasses exps)) + >>= flip (foldM (\m (name, _) -> importer m (KindRef name))) (M.toList (exportedKinds exps)) importRef :: ImportProvenance -> Imports -> DeclarationRef -> m Imports importRef prov imp (PositionedDeclarationRef pos _ r) = @@ -205,6 +208,9 @@ resolveImport importModule exps imps impQual = resolveByType importRef prov imp (TypeClassRef name) = do let typeClasses' = updateImports (importedTypeClasses imp) (exportedTypeClasses exps) id name prov return $ imp { importedTypeClasses = typeClasses' } + importRef prov imp (KindRef name) = do + let kinds' = updateImports (importedKinds imp) (exportedKinds exps) id name prov + return $ imp { importedKinds = kinds' } importRef _ _ TypeInstanceRef{} = internalError "TypeInstanceRef in importRef" importRef _ _ ModuleRef{} = internalError "ModuleRef in importRef" importRef _ _ ReExportRef{} = internalError "ReExportRef in importRef" diff --git a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs index fbf0be8..8b5ad3c 100755 --- a/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs +++ b/src/Language/PureScript/Sugar/TypeClasses/Deriving.hs @@ -3,77 +3,102 @@ -- module Language.PureScript.Sugar.TypeClasses.Deriving (deriveInstances) where -import Prelude.Compat - -import Control.Arrow (second) -import Control.Monad (replicateM) -import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.Supply.Class (MonadSupply) - -import Data.List (foldl', find, sortBy, unzip5) -import Data.Maybe (fromMaybe) -import Data.Ord (comparing) -import Data.Text (Text) - -import Language.PureScript.AST -import Language.PureScript.Crash -import Language.PureScript.Environment -import Language.PureScript.Errors -import Language.PureScript.Names -import Language.PureScript.Types -import Language.PureScript.TypeChecker (checkNewtype) +import Prelude.Compat + +import Control.Arrow (second) +import Control.Monad (replicateM, zipWithM) +import Control.Monad.Error.Class (MonadError(..)) +import Control.Monad.Supply.Class (MonadSupply) +import Data.List (foldl', find, sortBy, unzip5) +import qualified Data.Map as M +import Data.Maybe (fromMaybe, mapMaybe) +import Data.Ord (comparing) +import Data.Text (Text) +import Language.PureScript.AST import qualified Language.PureScript.Constants as C +import Language.PureScript.Crash +import Language.PureScript.Environment +import Language.PureScript.Errors +import Language.PureScript.Externs +import Language.PureScript.Kinds +import Language.PureScript.Names +import Language.PureScript.Types +import Language.PureScript.TypeChecker (checkNewtype) +import Language.PureScript.TypeChecker.Synonyms (SynonymMap, replaceAllTypeSynonymsM) -- | Elaborates deriving instance declarations by code generation. deriveInstances - :: (MonadError MultipleErrors m, MonadSupply m) - => Module + :: forall m + . (MonadError MultipleErrors m, MonadSupply m) + => [ExternsFile] + -> Module -> m Module -deriveInstances (Module ss coms mn ds exts) = Module ss coms mn <$> mapM (deriveInstance mn ds) ds <*> pure exts +deriveInstances externs (Module ss coms mn ds exts) = + Module ss coms mn <$> mapM (deriveInstance mn synonyms ds) ds <*> pure exts + where + -- We need to collect type synonym information, since synonyms will not be + -- removed until later, during type checking. + synonyms :: SynonymMap + synonyms = + M.fromList $ (externs >>= \ExternsFile{..} -> mapMaybe (fromExternsDecl efModuleName) efDeclarations) + ++ mapMaybe fromLocalDecl ds + where + fromExternsDecl mn' (EDTypeSynonym name args ty) = Just (Qualified (Just mn') name, (args, ty)) + fromExternsDecl _ _ = Nothing + + fromLocalDecl (TypeSynonymDeclaration name args ty) = do + Just (Qualified (Just mn) name, (args, ty)) + fromLocalDecl (PositionedDeclaration _ _ d) = fromLocalDecl d + fromLocalDecl _ = Nothing -- | Takes a declaration, and if the declaration is a deriving TypeInstanceDeclaration, -- elaborates that into an instance declaration via code generation. deriveInstance :: (MonadError MultipleErrors m, MonadSupply m) => ModuleName + -> SynonymMap -> [Declaration] -> Declaration -> m Declaration -deriveInstance mn ds (TypeInstanceDeclaration nm deps className tys@[ty] DerivedInstance) +deriveInstance mn syns ds (TypeInstanceDeclaration nm deps className tys@[ty] DerivedInstance) | className == Qualified (Just dataGeneric) (ProperName C.generic) , Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor ty , mn == fromMaybe mn mn' - = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveGeneric mn ds tyCon args + = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveGeneric mn syns ds tyCon args | className == Qualified (Just dataEq) (ProperName "Eq") , Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor ty , mn == fromMaybe mn mn' - = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveEq mn ds tyCon + = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveEq mn syns ds tyCon | className == Qualified (Just dataOrd) (ProperName "Ord") , Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor ty , mn == fromMaybe mn mn' - = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveOrd mn ds tyCon -deriveInstance mn ds (TypeInstanceDeclaration nm deps className [wrappedTy, unwrappedTy] DerivedInstance) + = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveOrd mn syns ds tyCon + | className == Qualified (Just dataFunctor) (ProperName "Functor") + , Just (Qualified mn' tyCon, _) <- unwrapTypeConstructor ty + , mn == fromMaybe mn mn' + = TypeInstanceDeclaration nm deps className tys . ExplicitInstance <$> deriveFunctor mn syns ds tyCon +deriveInstance mn syns ds (TypeInstanceDeclaration nm deps className [wrappedTy, unwrappedTy] DerivedInstance) | className == Qualified (Just dataNewtype) (ProperName "Newtype") , Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor wrappedTy , mn == fromMaybe mn mn' - = do (inst, actualUnwrappedTy) <- deriveNewtype mn ds tyCon args unwrappedTy + = do (inst, actualUnwrappedTy) <- deriveNewtype mn syns ds tyCon args unwrappedTy return $ TypeInstanceDeclaration nm deps className [wrappedTy, actualUnwrappedTy] (ExplicitInstance inst) -deriveInstance mn ds (TypeInstanceDeclaration nm deps className [actualTy, repTy] DerivedInstance) +deriveInstance mn syns ds (TypeInstanceDeclaration nm deps className [actualTy, repTy] DerivedInstance) | className == Qualified (Just dataGenericRep) (ProperName C.generic) , Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor actualTy , mn == fromMaybe mn mn' - = do (inst, inferredRepTy) <- deriveGenericRep mn ds tyCon args repTy + = do (inst, inferredRepTy) <- deriveGenericRep mn syns ds tyCon args repTy return $ TypeInstanceDeclaration nm deps className [actualTy, inferredRepTy] (ExplicitInstance inst) -deriveInstance _ _ (TypeInstanceDeclaration _ _ className tys DerivedInstance) +deriveInstance _ _ _ (TypeInstanceDeclaration _ _ className tys DerivedInstance) = throwError . errorMessage $ CannotDerive className tys -deriveInstance mn ds (TypeInstanceDeclaration nm deps className tys@(_ : _) NewtypeInstance) +deriveInstance mn syns ds (TypeInstanceDeclaration nm deps className tys@(_ : _) NewtypeInstance) | Just (Qualified mn' tyCon, args) <- unwrapTypeConstructor (last tys) , mn == fromMaybe mn mn' - = TypeInstanceDeclaration nm deps className tys . NewtypeInstanceWithDictionary <$> deriveNewtypeInstance className ds tys tyCon args -deriveInstance _ _ (TypeInstanceDeclaration _ _ className tys NewtypeInstance) + = TypeInstanceDeclaration nm deps className tys . NewtypeInstanceWithDictionary <$> deriveNewtypeInstance syns className ds tys tyCon args +deriveInstance _ _ _ (TypeInstanceDeclaration _ _ className tys NewtypeInstance) = throwError . errorMessage $ InvalidNewtypeInstance className tys -deriveInstance mn ds (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> deriveInstance mn ds d -deriveInstance _ _ e = return e +deriveInstance mn syns ds (PositionedDeclaration pos com d) = PositionedDeclaration pos com <$> deriveInstance mn syns ds d +deriveInstance _ _ _ e = return e unwrapTypeConstructor :: Type -> Maybe (Qualified (ProperName 'TypeName), [Type]) unwrapTypeConstructor = fmap (second reverse) . go @@ -87,13 +112,14 @@ unwrapTypeConstructor = fmap (second reverse) . go deriveNewtypeInstance :: forall m . MonadError MultipleErrors m - => Qualified (ProperName 'ClassName) + => SynonymMap + -> Qualified (ProperName 'ClassName) -> [Declaration] -> [Type] -> ProperName 'TypeName -> [Type] -> m Expr -deriveNewtypeInstance className ds tys tyConNm dargs = do +deriveNewtypeInstance syns className ds tys tyConNm dargs = do tyCon <- findTypeDecl tyConNm ds go tyCon where @@ -109,7 +135,8 @@ deriveNewtypeInstance className ds tys tyConNm dargs = do -- type argument | Just wrapped' <- stripRight (takeReverse (length tyArgNames - length dargs) tyArgNames) wrapped = do let subst = zipWith (\(name, _) t -> (name, t)) tyArgNames dargs - return (DeferredDictionary className (init tys ++ [replaceAllTypeVars subst wrapped'])) + wrapped'' <- replaceAllTypeSynonymsM syns wrapped' + return (DeferredDictionary className (init tys ++ [replaceAllTypeVars subst wrapped''])) go (PositionedDeclaration _ _ d) = go d go _ = throwError . errorMessage $ InvalidNewtypeInstance className tys @@ -143,14 +170,18 @@ dataOrd = ModuleName [ ProperName "Data", ProperName "Ord" ] dataNewtype :: ModuleName dataNewtype = ModuleName [ ProperName "Data", ProperName "Newtype" ] +dataFunctor :: ModuleName +dataFunctor = ModuleName [ ProperName "Data", ProperName "Functor" ] + deriveGeneric :: forall m. (MonadError MultipleErrors m, MonadSupply m) => ModuleName + -> SynonymMap -> [Declaration] -> ProperName 'TypeName -> [Type] -> m [Declaration] -deriveGeneric mn ds tyConNm dargs = do +deriveGeneric mn syns ds tyConNm dargs = do tyCon <- findTypeDecl tyConNm ds toSpine <- mkSpineFunction tyCon fromSpine <- mkFromSpineFunction tyCon @@ -174,12 +205,12 @@ deriveGeneric mn ds tyConNm dargs = do mkCtorClause :: (ProperName 'ConstructorName, [Type]) -> m CaseAlternative mkCtorClause (ctorName, tys) = do idents <- replicateM (length tys) freshIdent' - return $ CaseAlternative [ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents)] (Right (caseResult idents)) - where - caseResult idents = - App (prodConstructor (Literal . StringLiteral . showQualified runProperName $ Qualified (Just mn) ctorName)) - . Literal . ArrayLiteral - $ zipWith toSpineFun (map (Var . Qualified Nothing) idents) tys + tys' <- mapM (replaceAllTypeSynonymsM syns) tys + let caseResult = + App (prodConstructor (Literal . StringLiteral . showQualified runProperName $ Qualified (Just mn) ctorName)) + . Literal . ArrayLiteral + $ zipWith toSpineFun (map (Var . Qualified Nothing) idents) tys' + return $ CaseAlternative [ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents)] (Right caseResult) toSpineFun :: Expr -> Type -> Expr toSpineFun i r | Just rec <- objectType r = @@ -314,12 +345,13 @@ deriveGenericRep :: forall m . (MonadError MultipleErrors m, MonadSupply m) => ModuleName + -> SynonymMap -> [Declaration] -> ProperName 'TypeName -> [Type] -> Type -> m ([Declaration], Type) -deriveGenericRep mn ds tyConNm tyConArgs repTy = do +deriveGenericRep mn syns ds tyConNm tyConArgs repTy = do checkIsWildcard tyConNm repTy go =<< findTypeDecl tyConNm ds where @@ -370,7 +402,8 @@ deriveGenericRep mn ds tyConNm tyConArgs repTy = do :: (ProperName 'ConstructorName, [Type]) -> m (Type, CaseAlternative, CaseAlternative) makeInst (ctorName, args) = do - (ctorTy, matchProduct, ctorArgs, matchCtor, mkProduct) <- makeProduct args + args' <- mapM (replaceAllTypeSynonymsM syns) args + (ctorTy, matchProduct, ctorArgs, matchCtor, mkProduct) <- makeProduct args' return ( TypeApp (TypeApp (TypeConstructor constructor) (TypeLevelString (runProperName ctorName))) ctorTy @@ -494,10 +527,11 @@ checkIsWildcard tyConNm _ = deriveEq :: forall m. (MonadError MultipleErrors m, MonadSupply m) => ModuleName + -> SynonymMap -> [Declaration] -> ProperName 'TypeName -> m [Declaration] -deriveEq mn ds tyConNm = do +deriveEq mn syns ds tyConNm = do tyCon <- findTypeDecl tyConNm ds eqFun <- mkEqFunction tyCon return [ ValueDeclaration (Ident C.eq) Public [] (Right eqFun) ] @@ -527,7 +561,8 @@ deriveEq mn ds tyConNm = do mkCtorClause (ctorName, tys) = do identsL <- replicateM (length tys) (freshIdent "l") identsR <- replicateM (length tys) (freshIdent "r") - let tests = zipWith3 toEqTest (map (Var . Qualified Nothing) identsL) (map (Var . Qualified Nothing) identsR) tys + tys' <- mapM (replaceAllTypeSynonymsM syns) tys + let tests = zipWith3 toEqTest (map (Var . Qualified Nothing) identsL) (map (Var . Qualified Nothing) identsR) tys' return $ CaseAlternative [caseBinder identsL, caseBinder identsR] (Right (conjAll tests)) where caseBinder idents = ConstructorBinder (Qualified (Just mn) ctorName) (map VarBinder idents) @@ -546,10 +581,11 @@ deriveEq mn ds tyConNm = do deriveOrd :: forall m. (MonadError MultipleErrors m, MonadSupply m) => ModuleName + -> SynonymMap -> [Declaration] -> ProperName 'TypeName -> m [Declaration] -deriveOrd mn ds tyConNm = do +deriveOrd mn syns ds tyConNm = do tyCon <- findTypeDecl tyConNm ds compareFun <- mkCompareFunction tyCon return [ ValueDeclaration (Ident C.compare) Public [] (Right compareFun) ] @@ -590,7 +626,8 @@ deriveOrd mn ds tyConNm = do mkCtorClauses ((ctorName, tys), isLast) = do identsL <- replicateM (length tys) (freshIdent "l") identsR <- replicateM (length tys) (freshIdent "r") - let tests = zipWith3 toOrdering (map (Var . Qualified Nothing) identsL) (map (Var . Qualified Nothing) identsR) tys + tys' <- mapM (replaceAllTypeSynonymsM syns) tys + let tests = zipWith3 toOrdering (map (Var . Qualified Nothing) identsL) (map (Var . Qualified Nothing) identsR) tys' extras | not isLast = [ CaseAlternative [ ConstructorBinder (Qualified (Just mn) ctorName) (replicate (length tys) NullBinder) , NullBinder ] @@ -632,12 +669,13 @@ deriveNewtype :: forall m . (MonadError MultipleErrors m, MonadSupply m) => ModuleName + -> SynonymMap -> [Declaration] -> ProperName 'TypeName -> [Type] -> Type -> m ([Declaration], Type) -deriveNewtype mn ds tyConNm tyConArgs unwrappedTy = do +deriveNewtype mn syns ds tyConNm tyConArgs unwrappedTy = do checkIsWildcard tyConNm unwrappedTy go =<< findTypeDecl tyConNm ds where @@ -649,7 +687,8 @@ deriveNewtype mn ds tyConNm tyConArgs unwrappedTy = do wrappedIdent <- freshIdent "n" unwrappedIdent <- freshIdent "a" let (ctorName, [ty]) = head dctors - inst = + ty' <- replaceAllTypeSynonymsM syns ty + let inst = [ ValueDeclaration (Ident "wrap") Public [] $ Right $ Constructor (Qualified (Just mn) ctorName) , ValueDeclaration (Ident "unwrap") Public [] $ Right $ @@ -660,7 +699,7 @@ deriveNewtype mn ds tyConNm tyConArgs unwrappedTy = do ] ] subst = zipWith ((,) . fst) args tyConArgs - return (inst, replaceAllTypeVars subst ty) + return (inst, replaceAllTypeVars subst ty') go (PositionedDeclaration _ _ d) = go d go _ = internalError "deriveNewtype go: expected DataDeclaration" @@ -702,3 +741,70 @@ decomposeRec :: Type -> [(Text, Type)] decomposeRec = sortBy (comparing fst) . go where go (RCons str typ typs) = (str, typ) : decomposeRec typs go _ = [] + +deriveFunctor + :: forall m + . (MonadError MultipleErrors m, MonadSupply m) + => ModuleName + -> SynonymMap + -> [Declaration] + -> ProperName 'TypeName + -> m [Declaration] +deriveFunctor mn syns ds tyConNm = do + tyCon <- findTypeDecl tyConNm ds + mapFun <- mkMapFunction tyCon + return [ ValueDeclaration (Ident C.map) Public [] (Right mapFun) ] + where + mkMapFunction :: Declaration -> m Expr + mkMapFunction (DataDeclaration _ _ tys ctors) = case reverse tys of + [] -> throwError . errorMessage $ KindsDoNotUnify (FunKind kindType kindType) kindType + ((iTy, _) : _) -> do + f <- freshIdent "f" + m <- freshIdent "m" + lam f . lamCase m <$> mapM (mkCtorClause iTy f) ctors + mkMapFunction (PositionedDeclaration _ _ d) = mkMapFunction d + mkMapFunction _ = internalError "mkMapFunction: expected DataDeclaration" + + mkCtorClause :: Text -> Ident -> (ProperName 'ConstructorName, [Type]) -> m CaseAlternative + mkCtorClause iTyName f (ctorName, ctorTys) = do + idents <- replicateM (length ctorTys) (freshIdent "v") + ctorTys' <- mapM (replaceAllTypeSynonymsM syns) ctorTys + args <- zipWithM transformArg idents ctorTys' + let ctor = Constructor (Qualified (Just mn) ctorName) + rebuilt = foldl App ctor args + caseBinder = ConstructorBinder (Qualified (Just mn) ctorName) (VarBinder <$> idents) + return $ CaseAlternative [caseBinder] (Right rebuilt) + where + fVar = mkVar f + mapVar = mkVarMn (Just dataFunctor) (Ident C.map) + + -- TODO: deal with type synonyms, ala https://github.com/purescript/purescript/pull/2516 + transformArg :: Ident -> Type -> m Expr + transformArg ident = fmap (foldr App (mkVar ident)) . goType where + + goType :: Type -> m (Maybe Expr) + -- argument matches the index type + goType (TypeVar t) | t == iTyName = return (Just fVar) + + -- records + goType recTy | Just row <- objectType recTy = + traverse buildUpdate (decomposeRec row) >>= (traverse buildRecord . justUpdates) + where + justUpdates :: [Maybe (Text, Expr)] -> Maybe [(Text, Expr)] + justUpdates = foldMap (fmap return) + + buildUpdate :: (Text, Type) -> m (Maybe (Text, Expr)) + buildUpdate (lbl, ty) = do upd <- goType ty + return ((lbl,) <$> upd) + + buildRecord :: [(Text, Expr)] -> m Expr + buildRecord updates = do arg <- freshIdent "o" + let argVar = mkVar arg + mkAssignment (l, x) = (l, App x (Accessor l argVar)) + return (lam arg (ObjectUpdate argVar (mkAssignment <$> updates))) + + -- under a `* -> *`, just assume functor for now + goType (TypeApp _ t) = fmap (App mapVar) <$> goType t + + -- otherwise do nothing - will fail type checking if type does actually contain index + goType _ = return Nothing diff --git a/src/Language/PureScript/TypeChecker.hs b/src/Language/PureScript/TypeChecker.hs index 9b6e1bb..c94e828 100644 --- a/src/Language/PureScript/TypeChecker.hs +++ b/src/Language/PureScript/TypeChecker.hs @@ -18,7 +18,7 @@ import Control.Monad.Supply.Class (MonadSupply) import Control.Monad.Writer.Class (MonadWriter(..)) import Control.Lens ((^..), _1, _2) -import Data.Foldable (for_, traverse_) +import Data.Foldable (for_, traverse_, toList) import Data.List (nub, nubBy, (\\), sort, group) import Data.Maybe import qualified Data.Map as M @@ -274,11 +274,15 @@ typeCheckAll moduleName _ = traverse go env <- getEnv putEnv $ env { types = M.insert (Qualified (Just moduleName) name) (kind, ExternData) (types env) } return d + go (d@(ExternKindDeclaration name)) = do + env <- getEnv + putEnv $ env { kinds = S.insert (Qualified (Just moduleName) name) (kinds env) } + return d go (d@(ExternDeclaration name ty)) = do warnAndRethrow (addHint (ErrorInForeignImport name)) $ do env <- getEnv kind <- kindOf ty - guardWith (errorMessage (ExpectedType ty kind)) $ kind == Star + guardWith (errorMessage (ExpectedType ty kind)) $ kind == kindType case M.lookup (Qualified (Just moduleName) name) (names env) of Just _ -> throwError . errorMessage $ RedefinedIdent name Nothing -> putEnv (env { names = M.insert (Qualified (Just moduleName) name) (ty, External, Defined) (names env) }) @@ -294,7 +298,7 @@ typeCheckAll moduleName _ = traverse go Nothing -> internalError "typeCheckAll: Encountered unknown type class in instance declaration" Just typeClass -> do sequence_ (zipWith (checkTypeClassInstance typeClass) [0..] tys) - checkOrphanInstance dictName className tys + checkOrphanInstance dictName className typeClass tys _ <- traverseTypeInstanceBody checkInstanceMembers body let dict = TypeClassDictionaryInScope (Qualified (Just moduleName) dictName) [] className tys (Just deps) addTypeClassDictionaries (Just moduleName) . M.singleton className $ M.singleton (tcdValue dict) dict @@ -320,19 +324,35 @@ typeCheckAll moduleName _ = traverse go | otherwise = firstDuplicate xs firstDuplicate _ = Nothing - checkOrphanInstance :: Ident -> Qualified (ProperName 'ClassName) -> [Type] -> m () - checkOrphanInstance dictName className@(Qualified (Just mn') _) tys' - | moduleName == mn' || any checkType tys' = return () + checkOrphanInstance :: Ident -> Qualified (ProperName 'ClassName) -> TypeClassData -> [Type] -> m () + checkOrphanInstance dictName className@(Qualified (Just mn') _) typeClass tys' + | moduleName == mn' || moduleName `S.member` nonOrphanModules = return () | otherwise = throwError . errorMessage $ OrphanInstance dictName className tys' where - checkType :: Type -> Bool - checkType (TypeVar _) = False - checkType (TypeLevelString _) = False - checkType (TypeConstructor (Qualified (Just mn'') _)) = moduleName == mn'' - checkType (TypeConstructor (Qualified Nothing _)) = internalError "Unqualified type name in checkOrphanInstance" - checkType (TypeApp t1 _) = checkType t1 - checkType _ = internalError "Invalid type in instance in checkOrphanInstance" - checkOrphanInstance _ _ _ = internalError "Unqualified class name in checkOrphanInstance" + typeModule :: Type -> Maybe ModuleName + typeModule (TypeVar _) = Nothing + typeModule (TypeLevelString _) = Nothing + typeModule (TypeConstructor (Qualified (Just mn'') _)) = Just mn'' + typeModule (TypeConstructor (Qualified Nothing _)) = internalError "Unqualified type name in checkOrphanInstance" + typeModule (TypeApp t1 _) = typeModule t1 + typeModule _ = internalError "Invalid type in instance in checkOrphanInstance" + + modulesByTypeIndex :: M.Map Int (Maybe ModuleName) + modulesByTypeIndex = M.fromList (zip [0 ..] (typeModule <$> tys')) + + lookupModule :: Int -> S.Set ModuleName + lookupModule idx = case M.lookup idx modulesByTypeIndex of + Just ms -> S.fromList (toList ms) + Nothing -> internalError "Unknown type index in checkOrphanInstance" + + -- If the instance is declared in a module that wouldn't be found based on a covering set + -- then it is considered an orphan - because we'd have a situation in which we expect an + -- instance but can't find it. So a valid module must be applicable across *all* covering + -- sets - therefore we take the intersection of covering set modules. + nonOrphanModules :: S.Set ModuleName + nonOrphanModules = foldl1 S.intersection (foldMap lookupModule `S.map` typeClassCoveringSets typeClass) + + checkOrphanInstance _ _ _ _ = internalError "Unqualified class name in checkOrphanInstance" -- | -- This function adds the argument kinds for a type constructor so that they may appear in the externs file, diff --git a/src/Language/PureScript/TypeChecker/Entailment.hs b/src/Language/PureScript/TypeChecker/Entailment.hs index a857cdf..ae5374f 100644 --- a/src/Language/PureScript/TypeChecker/Entailment.hs +++ b/src/Language/PureScript/TypeChecker/Entailment.hs @@ -45,6 +45,10 @@ data Evidence -- ^ An existing named instance | IsSymbolInstance Text -- ^ Computed instance of the IsSymbol type class for a given Symbol literal + | CompareSymbolInstance + -- ^ Computed instance of CompareSymbol + | AppendSymbolInstance + -- ^ Computed instance of AppendSymbol deriving (Eq) -- | Extract the identifier of a named instance @@ -138,7 +142,18 @@ entails SolverOptions{..} constraint context hints = solve constraint where forClassName :: InstanceContext -> Qualified (ProperName 'ClassName) -> [Type] -> [TypeClassDict] - forClassName _ C.IsSymbol [TypeLevelString sym] = [TypeClassDictionaryInScope (IsSymbolInstance sym) [] C.IsSymbol [TypeLevelString sym] Nothing] + forClassName _ C.IsSymbol [TypeLevelString sym] = + [TypeClassDictionaryInScope (IsSymbolInstance sym) [] C.IsSymbol [TypeLevelString sym] Nothing] + forClassName _ C.CompareSymbol [arg0@(TypeLevelString lhs), arg1@(TypeLevelString rhs), _] = + let ordering = case compare lhs rhs of + LT -> C.orderingLT + EQ -> C.orderingEQ + GT -> C.orderingGT + args = [arg0, arg1, TypeConstructor ordering] + in [TypeClassDictionaryInScope CompareSymbolInstance [] C.CompareSymbol args Nothing] + forClassName _ C.AppendSymbol [arg0@(TypeLevelString lhs), arg1@(TypeLevelString rhs), _] = + let args = [arg0, arg1, TypeLevelString (lhs <> rhs)] + in [TypeClassDictionaryInScope AppendSymbolInstance [] C.AppendSymbol args Nothing] forClassName ctx cn@(Qualified (Just mn) _) tys = concatMap (findDicts ctx cn) (nub (Nothing : Just mn : map Just (mapMaybe ctorModules tys))) forClassName _ _ _ = internalError "forClassName: expected qualified class name" @@ -146,6 +161,7 @@ entails SolverOptions{..} constraint context hints = ctorModules (TypeConstructor (Qualified (Just mn) _)) = Just mn ctorModules (TypeConstructor (Qualified Nothing _)) = internalError "ctorModules: unqualified type name" ctorModules (TypeApp ty _) = ctorModules ty + ctorModules (KindedType ty _) = ctorModules ty ctorModules _ = Nothing findDicts :: InstanceContext -> Qualified (ProperName 'ClassName) -> Maybe ModuleName -> [TypeClassDict] @@ -266,6 +282,7 @@ entails SolverOptions{..} constraint context hints = canBeGeneralized :: Type -> Bool canBeGeneralized TUnknown{} = True + canBeGeneralized (KindedType t _) = canBeGeneralized t canBeGeneralized _ = False -- | @@ -291,9 +308,13 @@ entails SolverOptions{..} constraint context hints = -- Make a dictionary from subgoal dictionaries by applying the correct function mkDictionary :: Evidence -> Maybe [Expr] -> Expr mkDictionary (NamedInstance n) args = foldl App (Var n) (fold args) - mkDictionary (IsSymbolInstance sym) _ = TypeClassDictionaryConstructorApp C.IsSymbol (Literal (ObjectLiteral fields)) where - fields = [ ("reflectSymbol", Abs (Left (Ident C.__unused)) (Literal (StringLiteral sym))) - ] + mkDictionary (IsSymbolInstance sym) _ = + let fields = [ ("reflectSymbol", Abs (Left (Ident C.__unused)) (Literal (StringLiteral sym))) ] in + TypeClassDictionaryConstructorApp C.IsSymbol (Literal (ObjectLiteral fields)) + mkDictionary CompareSymbolInstance _ = + TypeClassDictionaryConstructorApp C.CompareSymbol (Literal (ObjectLiteral [])) + mkDictionary AppendSymbolInstance _ = + TypeClassDictionaryConstructorApp C.AppendSymbol (Literal (ObjectLiteral [])) -- Turn a DictionaryValue into a Expr subclassDictionaryValue :: Expr -> Qualified (ProperName a) -> Integer -> Expr @@ -346,6 +367,8 @@ matches deps TypeClassDictionaryInScope{..} tys = do -- and return a substitution from type variables to types which makes the type heads unify. -- typeHeadsAreEqual :: Type -> Type -> (Bool, Matching [Type]) + typeHeadsAreEqual (KindedType t1 _) t2 = typeHeadsAreEqual t1 t2 + typeHeadsAreEqual t1 (KindedType t2 _) = typeHeadsAreEqual t1 t2 typeHeadsAreEqual (TUnknown u1) (TUnknown u2) | u1 == u2 = (True, M.empty) typeHeadsAreEqual (Skolem _ s1 _ _) (Skolem _ s2 _ _) | s1 == s2 = (True, M.empty) typeHeadsAreEqual t (TypeVar v) = (True, M.singleton v [t]) @@ -365,6 +388,8 @@ matches deps TypeClassDictionaryInScope{..} tys = do sd2 = [ (name, t2) | (name, t2) <- s2, name `notElem` map fst s1 ] go :: [(Text, Type)] -> Type -> [(Text, Type)] -> Type -> (Bool, Matching [Type]) + go l (KindedType t1 _) r t2 = go l t1 r t2 + go l t1 r (KindedType t2 _) = go l t1 r t2 go [] REmpty [] REmpty = (True, M.empty) go [] (TUnknown u1) [] (TUnknown u2) | u1 == u2 = (True, M.empty) go [] (TypeVar v1) [] (TypeVar v2) | v1 == v2 = (True, M.empty) @@ -386,6 +411,8 @@ matches deps TypeClassDictionaryInScope{..} tys = do -- which was _not_ solved, i.e. one which was inferred by a functional -- dependency. typesAreEqual :: Type -> Type -> Bool + typesAreEqual (KindedType t1 _) t2 = typesAreEqual t1 t2 + typesAreEqual t1 (KindedType t2 _) = typesAreEqual t1 t2 typesAreEqual (TUnknown u1) (TUnknown u2) | u1 == u2 = True typesAreEqual (Skolem _ s1 _ _) (Skolem _ s2 _ _) = s1 == s2 typesAreEqual (TypeVar v1) (TypeVar v2) = v1 == v2 @@ -403,6 +430,8 @@ matches deps TypeClassDictionaryInScope{..} tys = do in all (uncurry typesAreEqual) int && go sd1 r1' sd2 r2' where go :: [(Text, Type)] -> Type -> [(Text, Type)] -> Type -> Bool + go l (KindedType t1 _) r t2 = go l t1 r t2 + go l t1 r (KindedType t2 _) = go l t1 r t2 go [] (TUnknown u1) [] (TUnknown u2) | u1 == u2 = True go [] (Skolem _ s1 _ _) [] (Skolem _ s2 _ _) = s1 == s2 go [] REmpty [] REmpty = True diff --git a/src/Language/PureScript/TypeChecker/Kinds.hs b/src/Language/PureScript/TypeChecker/Kinds.hs index fedd623..05e7a1e 100644 --- a/src/Language/PureScript/TypeChecker/Kinds.hs +++ b/src/Language/PureScript/TypeChecker/Kinds.hs @@ -85,9 +85,7 @@ unifyKinds k1 k2 = do go (KUnknown u1) (KUnknown u2) | u1 == u2 = return () go (KUnknown u) k = solveKind u k go k (KUnknown u) = solveKind u k - go Star Star = return () - go Bang Bang = return () - go Symbol Symbol = return () + go (NamedKind k1') (NamedKind k2') | k1' == k2' = return () go (Row k1') (Row k2') = go k1' k2' go (FunKind k1' k2') (FunKind k3 k4) = do go k1' k3 @@ -182,15 +180,15 @@ solveTypes solveTypes isData ts kargs tyCon = do ks <- traverse (fmap fst . infer) ts when isData $ do - unifyKinds tyCon (foldr FunKind Star kargs) - forM_ ks $ \k -> unifyKinds k Star + unifyKinds tyCon (foldr FunKind kindType kargs) + forM_ ks $ \k -> unifyKinds k kindType unless isData $ unifyKinds tyCon (foldr FunKind (head ks) kargs) return tyCon --- | Default all unknown kinds to the Star kind of types +-- | Default all unknown kinds to the kindType kind of types starIfUnknown :: Kind -> Kind -starIfUnknown (KUnknown _) = Star +starIfUnknown (KUnknown _) = kindType starIfUnknown (Row k) = Row (starIfUnknown k) starIfUnknown (FunKind k1 k2) = FunKind (starIfUnknown k1) (starIfUnknown k2) starIfUnknown k = k @@ -211,8 +209,8 @@ infer' (ForAll ident ty _) = do k1 <- freshKind Just moduleName <- checkCurrentModule <$> get (k2, args) <- bindLocalTypeVariables moduleName [(ProperName ident, k1)] $ infer ty - unifyKinds k2 Star - return (Star, (ident, k1) : args) + unifyKinds k2 kindType + return (kindType, (ident, k1) : args) infer' (KindedType ty k) = do (k', args) <- infer ty unifyKinds k k' @@ -224,14 +222,14 @@ infer' other = (, []) <$> go other k1 <- freshKind Just moduleName <- checkCurrentModule <$> get k2 <- bindLocalTypeVariables moduleName [(ProperName ident, k1)] $ go ty - unifyKinds k2 Star - return Star + unifyKinds k2 kindType + return kindType go (KindedType ty k) = do k' <- go ty unifyKinds k k' return k' go TypeWildcard{} = freshKind - go (TypeLevelString _) = return Symbol + go (TypeLevelString _) = return kindSymbol go (TypeVar v) = do Just moduleName <- checkCurrentModule <$> get lookupTypeVariable moduleName (Qualified Nothing (ProperName v)) @@ -260,8 +258,8 @@ infer' other = (, []) <$> go other go (ConstrainedType deps ty) = do forM_ deps $ \(Constraint className tys _) -> do k <- go $ foldl TypeApp (TypeConstructor (fmap coerceProperName className)) tys - unifyKinds k Star + unifyKinds k kindType k <- go ty - unifyKinds k Star - return Star + unifyKinds k kindType + return kindType go ty = internalError $ "Invalid argument to infer: " ++ show ty diff --git a/src/Language/PureScript/TypeChecker/Synonyms.hs b/src/Language/PureScript/TypeChecker/Synonyms.hs index 829ec57..08016b2 100644 --- a/src/Language/PureScript/TypeChecker/Synonyms.hs +++ b/src/Language/PureScript/TypeChecker/Synonyms.hs @@ -4,44 +4,59 @@ -- Functions for replacing fully applied type synonyms -- module Language.PureScript.TypeChecker.Synonyms - ( replaceAllTypeSynonyms + ( SynonymMap + , replaceAllTypeSynonyms + , replaceAllTypeSynonymsM ) where -import Prelude.Compat +import Prelude.Compat -import Control.Monad.Error.Class (MonadError(..)) -import Control.Monad.State - -import Data.Maybe (fromMaybe) +import Control.Monad.Error.Class (MonadError(..)) +import Control.Monad.State +import Data.Maybe (fromMaybe) import qualified Data.Map as M - -import Language.PureScript.Environment -import Language.PureScript.Errors -import Language.PureScript.TypeChecker.Monad -import Language.PureScript.Types - --- | --- Replace fully applied type synonyms. --- -replaceAllTypeSynonyms' :: Environment -> Type -> Either MultipleErrors Type -replaceAllTypeSynonyms' env = everywhereOnTypesTopDownM try +import Data.Text (Text) +import Language.PureScript.Environment +import Language.PureScript.Errors +import Language.PureScript.Kinds +import Language.PureScript.Names +import Language.PureScript.TypeChecker.Monad +import Language.PureScript.Types + +-- | Type synonym information (arguments with kinds, aliased type), indexed by name +type SynonymMap = M.Map (Qualified (ProperName 'TypeName)) ([(Text, Maybe Kind)], Type) + +replaceAllTypeSynonyms' + :: SynonymMap + -> Type + -> Either MultipleErrors Type +replaceAllTypeSynonyms' syns = everywhereOnTypesTopDownM try where try :: Type -> Either MultipleErrors Type try t = fromMaybe t <$> go 0 [] t go :: Int -> [Type] -> Type -> Either MultipleErrors (Maybe Type) go c args (TypeConstructor ctor) - | Just (synArgs, body) <- M.lookup ctor (typeSynonyms env) + | Just (synArgs, body) <- M.lookup ctor syns , c == length synArgs = let repl = replaceAllTypeVars (zip (map fst synArgs) args) body in Just <$> try repl - | Just (synArgs, _) <- M.lookup ctor (typeSynonyms env) + | Just (synArgs, _) <- M.lookup ctor syns , length synArgs > c = throwError . errorMessage $ PartiallyAppliedSynonym ctor go c args (TypeApp f arg) = go (c + 1) (arg : args) f go _ _ _ = return Nothing +-- | Replace fully applied type synonyms replaceAllTypeSynonyms :: (e ~ MultipleErrors, MonadState CheckState m, MonadError e m) => Type -> m Type replaceAllTypeSynonyms d = do env <- getEnv - either throwError return $ replaceAllTypeSynonyms' env d + either throwError return $ replaceAllTypeSynonyms' (typeSynonyms env) d + +-- | Replace fully applied type synonyms by explicitly providing a 'SynonymMap'. +replaceAllTypeSynonymsM + :: MonadError MultipleErrors m + => SynonymMap + -> Type + -> m Type +replaceAllTypeSynonymsM syns = either throwError pure . replaceAllTypeSynonyms' syns diff --git a/src/Language/PureScript/TypeChecker/Types.hs b/src/Language/PureScript/TypeChecker/Types.hs index e417a4a..665f569 100644 --- a/src/Language/PureScript/TypeChecker/Types.hs +++ b/src/Language/PureScript/TypeChecker/Types.hs @@ -240,7 +240,7 @@ checkTypeKind :: Type -> Kind -> m () -checkTypeKind ty kind = guardWith (errorMessage (ExpectedType ty kind)) $ kind == Star +checkTypeKind ty kind = guardWith (errorMessage (ExpectedType ty kind)) $ kind == kindType -- | Remove any ForAlls and ConstrainedType constructors in a type by introducing new unknowns -- or TypeClassDictionary values. diff --git a/tests/Language/PureScript/Ide/Imports/IntegrationSpec.hs b/tests/Language/PureScript/Ide/Imports/IntegrationSpec.hs index 61021cc..01f474a 100644 --- a/tests/Language/PureScript/Ide/Imports/IntegrationSpec.hs +++ b/tests/Language/PureScript/Ide/Imports/IntegrationSpec.hs @@ -28,7 +28,7 @@ outputFileShouldBe :: [Text] -> IO () outputFileShouldBe expectation = do outFp <- (</> "src" </> "ImportsSpecOut.tmp") <$> Integration.projectDirectory outRes <- readUTF8FileT outFp - shouldBe (T.lines outRes) expectation + shouldBe (T.strip <$> T.lines outRes) expectation spec :: Spec spec = beforeAll_ setup . describe "Adding imports" $ do diff --git a/tests/Language/PureScript/Ide/ImportsSpec.hs b/tests/Language/PureScript/Ide/ImportsSpec.hs index bba7441..e830ed0 100644 --- a/tests/Language/PureScript/Ide/ImportsSpec.hs +++ b/tests/Language/PureScript/Ide/ImportsSpec.hs @@ -74,7 +74,7 @@ spec = do addDtorImport i t mn is = prettyPrintImportSection (addExplicitImport' (IdeDeclDataConstructor (IdeDataConstructor (P.ProperName i) t wildcard)) mn is) addTypeImport i mn is = - prettyPrintImportSection (addExplicitImport' (IdeDeclType (IdeType (P.ProperName i) P.Star)) mn is) + prettyPrintImportSection (addExplicitImport' (IdeDeclType (IdeType (P.ProperName i) P.kindType)) mn is) it "adds an implicit unqualified import" $ shouldBe (addImplicitImport' simpleFileImports (P.moduleNameFromString "Data.Map")) @@ -143,7 +143,7 @@ spec = do moduleName = (P.moduleNameFromString "Control.Monad") addImport imports import' = addExplicitImport' import' moduleName imports valueImport ident = (IdeDeclValue (IdeValue (P.Ident ident) wildcard)) - typeImport name = (IdeDeclType (IdeType (P.ProperName name) P.Star)) + typeImport name = (IdeDeclType (IdeType (P.ProperName name) P.kindType)) classImport name = (IdeDeclTypeClass (P.ProperName name)) dtorImport name typeName = (IdeDeclDataConstructor (IdeDataConstructor (P.ProperName name) (P.ProperName typeName) wildcard)) -- expect any list of provided identifiers, when imported, to come out as specified diff --git a/tests/Language/PureScript/Ide/ReexportsSpec.hs b/tests/Language/PureScript/Ide/ReexportsSpec.hs index d5d394c..adbdc74 100644 --- a/tests/Language/PureScript/Ide/ReexportsSpec.hs +++ b/tests/Language/PureScript/Ide/ReexportsSpec.hs @@ -18,7 +18,7 @@ d = IdeDeclarationAnn emptyAnn valueA, typeA, classA, dtorA1, dtorA2 :: IdeDeclarationAnn valueA = d (IdeDeclValue (IdeValue (P.Ident "valueA") P.REmpty)) -typeA = d (IdeDeclType (IdeType(P.ProperName "TypeA") P.Star)) +typeA = d (IdeDeclType (IdeType(P.ProperName "TypeA") P.kindType)) classA = d (IdeDeclTypeClass (P.ProperName "ClassA")) dtorA1 = d (IdeDeclDataConstructor (IdeDataConstructor (P.ProperName "DtorA1") (P.ProperName "TypeA") P.REmpty)) dtorA2 = d (IdeDeclDataConstructor (IdeDataConstructor (P.ProperName "DtorA2") (P.ProperName "TypeA") P.REmpty)) diff --git a/tests/Language/PureScript/Ide/SourceFileSpec.hs b/tests/Language/PureScript/Ide/SourceFileSpec.hs index ac53dde..eae3de7 100644 --- a/tests/Language/PureScript/Ide/SourceFileSpec.hs +++ b/tests/Language/PureScript/Ide/SourceFileSpec.hs @@ -6,6 +6,7 @@ import Protolude import qualified Language.PureScript as P import Language.PureScript.Ide.SourceFile +import Language.PureScript.Ide.Types import Test.Hspec span0, span1, span2 :: P.SourceSpan @@ -13,7 +14,7 @@ span0 = P.SourceSpan "ModuleLevel" (P.SourcePos 0 0) (P.SourcePos 1 1) span1 = P.SourceSpan "" (P.SourcePos 1 1) (P.SourcePos 2 2) span2 = P.SourceSpan "" (P.SourcePos 2 2) (P.SourcePos 3 3) -typeAnnotation1, value1, synonym1, class1, class2, data1, data2, foreign1, foreign2, member1 :: P.Declaration +typeAnnotation1, value1, synonym1, class1, class2, data1, data2, foreign1, foreign2, foreign3, member1 :: P.Declaration typeAnnotation1 = P.TypeDeclaration (P.Ident "value1") P.REmpty value1 = P.ValueDeclaration (P.Ident "value1") P.Public [] (Left []) synonym1 = P.TypeSynonymDeclaration (P.ProperName "Synonym1") [] P.REmpty @@ -23,28 +24,31 @@ class2 = P.TypeClassDeclaration (P.ProperName "Class2") [] [] [] data1 = P.DataDeclaration P.Newtype (P.ProperName "Data1") [] [] data2 = P.DataDeclaration P.Data (P.ProperName "Data2") [] [(P.ProperName "Cons1", [])] foreign1 = P.ExternDeclaration (P.Ident "foreign1") P.REmpty -foreign2 = P.ExternDataDeclaration (P.ProperName "Foreign2") P.Star +foreign2 = P.ExternDataDeclaration (P.ProperName "Foreign2") P.kindType +foreign3 = P.ExternKindDeclaration (P.ProperName "Foreign3") member1 = P.TypeDeclaration (P.Ident "member1") P.REmpty spec :: Spec spec = do describe "Extracting Spans" $ do it "extracts a span for a value declaration" $ - extractSpans span0 (P.PositionedDeclaration span1 [] value1) `shouldBe` [(Left "value1", span1)] + extractSpans span0 (P.PositionedDeclaration span1 [] value1) `shouldBe` [(IdeNSValue "value1", span1)] it "extracts a span for a type synonym declaration" $ - extractSpans span0 (P.PositionedDeclaration span1 [] synonym1) `shouldBe` [(Right "Synonym1", span1)] + extractSpans span0 (P.PositionedDeclaration span1 [] synonym1) `shouldBe` [(IdeNSType "Synonym1", span1)] it "extracts a span for a typeclass declaration" $ - extractSpans span0 (P.PositionedDeclaration span1 [] class1) `shouldBe` [(Right "Class1", span1)] + extractSpans span0 (P.PositionedDeclaration span1 [] class1) `shouldBe` [(IdeNSType "Class1", span1)] it "extracts spans for a typeclass declaration and its members" $ - extractSpans span0 (P.PositionedDeclaration span1 [] class2) `shouldBe` [(Right "Class2", span1), (Left "member1", span2)] + extractSpans span0 (P.PositionedDeclaration span1 [] class2) `shouldBe` [(IdeNSType "Class2", span1), (IdeNSValue "member1", span2)] it "extracts a span for a data declaration" $ - extractSpans span0 (P.PositionedDeclaration span1 [] data1) `shouldBe` [(Right "Data1", span1)] + extractSpans span0 (P.PositionedDeclaration span1 [] data1) `shouldBe` [(IdeNSType "Data1", span1)] it "extracts spans for a data declaration and its constructors" $ - extractSpans span0 (P.PositionedDeclaration span1 [] data2) `shouldBe` [(Right "Data2", span1), (Left "Cons1", span1)] + extractSpans span0 (P.PositionedDeclaration span1 [] data2) `shouldBe` [(IdeNSType "Data2", span1), (IdeNSValue "Cons1", span1)] it "extracts a span for a foreign declaration" $ - extractSpans span0 (P.PositionedDeclaration span1 [] foreign1) `shouldBe` [(Left "foreign1", span1)] + extractSpans span0 (P.PositionedDeclaration span1 [] foreign1) `shouldBe` [(IdeNSValue "foreign1", span1)] it "extracts a span for a data foreign declaration" $ - extractSpans span0 (P.PositionedDeclaration span1 [] foreign2) `shouldBe` [(Right "Foreign2", span1)] + extractSpans span0 (P.PositionedDeclaration span1 [] foreign2) `shouldBe` [(IdeNSType "Foreign2", span1)] + it "extracts a span for a foreign kind declaration" $ + extractSpans span0 (P.PositionedDeclaration span1 [] foreign3) `shouldBe` [(IdeNSKind "Foreign3", span1)] describe "Type annotations" $ do it "extracts a type annotation" $ extractTypeAnnotations [typeAnnotation1] `shouldBe` [(P.Ident "value1", P.REmpty)] diff --git a/tests/Language/PureScript/Ide/StateSpec.hs b/tests/Language/PureScript/Ide/StateSpec.hs index 2779662..5126fe2 100644 --- a/tests/Language/PureScript/Ide/StateSpec.hs +++ b/tests/Language/PureScript/Ide/StateSpec.hs @@ -24,7 +24,7 @@ typeOperator = testModule :: Module testModule = (mn "Test", [ d (IdeDeclValue (IdeValue (P.Ident "function") P.REmpty)) , d (IdeDeclDataConstructor (IdeDataConstructor (P.ProperName "Cons") (P.ProperName "List") (P.REmpty))) - , d (IdeDeclType (IdeType (P.ProperName "List") P.Star)) + , d (IdeDeclType (IdeType (P.ProperName "List") P.kindType)) , valueOperator Nothing , ctorOperator Nothing , typeOperator Nothing @@ -48,4 +48,4 @@ spec = describe "resolving operators" $ do it "resolves the type for a constructor operator" $ resolveOperatorsForModule testState (snd testModule) `shouldSatisfy` elem (ctorOperator (Just P.REmpty)) it "resolves the kind for a type operator" $ - resolveOperatorsForModule testState (snd testModule) `shouldSatisfy` elem (typeOperator (Just P.Star)) + resolveOperatorsForModule testState (snd testModule) `shouldSatisfy` elem (typeOperator (Just P.kindType)) diff --git a/tests/Main.hs b/tests/Main.hs index 61d1824..acfce36 100644 --- a/tests/Main.hs +++ b/tests/Main.hs @@ -13,6 +13,7 @@ import qualified TestDocs import qualified TestPsci import qualified TestPscIde import qualified TestPscPublish +import qualified TestPrimDocs import qualified TestUtils import System.IO (hSetEncoding, stdout, stderr, utf8) @@ -28,6 +29,7 @@ main = do TestCompiler.main heading "Documentation test suite" TestDocs.main + TestPrimDocs.main heading "psc-publish test suite" TestPscPublish.main heading "psci test suite" diff --git a/tests/TestCompiler.hs b/tests/TestCompiler.hs index 4fc8552..86a6ef3 100644 --- a/tests/TestCompiler.hs +++ b/tests/TestCompiler.hs @@ -61,13 +61,13 @@ main = hspec spec spec :: Spec spec = do - (supportExterns, passingTestCases, warningTestCases, failingTestCases) <- runIO $ do + (supportExterns, supportForeigns, passingTestCases, warningTestCases, failingTestCases) <- runIO $ do cwd <- getCurrentDirectory let passing = cwd </> "examples" </> "passing" let warning = cwd </> "examples" </> "warning" let failing = cwd </> "examples" </> "failing" let supportDir = cwd </> "tests" </> "support" </> "bower_components" - let supportFiles ext = Glob.globDir1 (Glob.compile ("purescript-*/**/*." ++ ext)) supportDir + let supportFiles ext = Glob.globDir1 (Glob.compile ("purescript-*/src/**/*." ++ ext)) supportDir passingFiles <- getTestFiles passing <$> testGlob passing warningFiles <- getTestFiles warning <$> testGlob warning failingFiles <- getTestFiles failing <$> testGlob failing @@ -77,10 +77,10 @@ spec = do modules <- ExceptT . return $ P.parseModulesFromFiles id supportPursFiles foreigns <- inferForeignModules modules externs <- ExceptT . fmap fst . runTest $ P.make (makeActions foreigns) (map snd modules) - return (zip (map snd modules) externs) + return (zip (map snd modules) externs, foreigns) case supportExterns of Left errs -> fail (P.prettyPrintMultipleErrors P.defaultPPEOptions errs) - Right externs -> return (externs, passingFiles, warningFiles, failingFiles) + Right (externs, foreigns) -> return (externs, foreigns, passingFiles, warningFiles, failingFiles) outputFile <- runIO $ do tmp <- getTemporaryDirectory @@ -90,21 +90,21 @@ spec = do context "Passing examples" $ forM_ passingTestCases $ \testPurs -> it ("'" <> takeFileName (getTestMain testPurs) <> "' should compile and run without error") $ - assertCompiles supportExterns testPurs outputFile + assertCompiles supportExterns supportForeigns testPurs outputFile context "Warning examples" $ forM_ warningTestCases $ \testPurs -> do let mainPath = getTestMain testPurs expectedWarnings <- runIO $ getShouldWarnWith mainPath it ("'" <> takeFileName mainPath <> "' should compile with warning(s) '" <> intercalate "', '" expectedWarnings <> "'") $ - assertCompilesWithWarnings supportExterns testPurs expectedWarnings + assertCompilesWithWarnings supportExterns supportForeigns testPurs expectedWarnings context "Failing examples" $ forM_ failingTestCases $ \testPurs -> do let mainPath = getTestMain testPurs expectedFailures <- runIO $ getShouldFailWith mainPath it ("'" <> takeFileName mainPath <> "' should fail with '" <> intercalate "', '" expectedFailures <> "'") $ - assertDoesNotCompile supportExterns testPurs expectedFailures + assertDoesNotCompile supportExterns supportForeigns testPurs expectedFailures where @@ -197,27 +197,29 @@ runTest = P.runMake P.defaultOptions compile :: [(P.Module, P.ExternsFile)] + -> M.Map P.ModuleName FilePath -> [FilePath] -> ([P.Module] -> IO ()) -> IO (Either P.MultipleErrors [P.ExternsFile], P.MultipleErrors) -compile supportExterns inputFiles check = silence $ runTest $ do +compile supportExterns supportForeigns inputFiles check = silence $ runTest $ do fs <- liftIO $ readInput inputFiles ms <- P.parseModulesFromFiles id fs foreigns <- inferForeignModules ms liftIO (check (map snd ms)) - let actions = makeActions foreigns + let actions = makeActions (foreigns `M.union` supportForeigns) case ms of [singleModule] -> pure <$> P.rebuildModule actions (map snd supportExterns) (snd singleModule) _ -> P.make actions (map fst supportExterns ++ map snd ms) assert :: [(P.Module, P.ExternsFile)] + -> M.Map P.ModuleName FilePath -> [FilePath] -> ([P.Module] -> IO ()) -> (Either P.MultipleErrors P.MultipleErrors -> IO (Maybe String)) -> Expectation -assert supportExterns inputFiles check f = do - (e, w) <- compile supportExterns inputFiles check +assert supportExterns supportForeigns inputFiles check f = do + (e, w) <- compile supportExterns supportForeigns inputFiles check maybeErr <- f (const w <$> e) maybe (return ()) expectationFailure maybeErr @@ -235,11 +237,12 @@ checkShouldFailWith expected errs = assertCompiles :: [(P.Module, P.ExternsFile)] + -> M.Map P.ModuleName FilePath -> [FilePath] -> Handle -> Expectation -assertCompiles supportExterns inputFiles outputFile = - assert supportExterns inputFiles checkMain $ \e -> +assertCompiles supportExterns supportForeigns inputFiles outputFile = + assert supportExterns supportForeigns inputFiles checkMain $ \e -> case e of Left errs -> return . Just . P.prettyPrintMultipleErrors P.defaultPPEOptions $ errs Right _ -> do @@ -260,11 +263,12 @@ assertCompiles supportExterns inputFiles outputFile = assertCompilesWithWarnings :: [(P.Module, P.ExternsFile)] + -> M.Map P.ModuleName FilePath -> [FilePath] -> [String] -> Expectation -assertCompilesWithWarnings supportExterns inputFiles shouldWarnWith = - assert supportExterns inputFiles checkMain $ \e -> +assertCompilesWithWarnings supportExterns supportForeigns inputFiles shouldWarnWith = + assert supportExterns supportForeigns inputFiles checkMain $ \e -> case e of Left errs -> return . Just . P.prettyPrintMultipleErrors P.defaultPPEOptions $ errs @@ -279,11 +283,12 @@ assertCompilesWithWarnings supportExterns inputFiles shouldWarnWith = assertDoesNotCompile :: [(P.Module, P.ExternsFile)] + -> M.Map P.ModuleName FilePath -> [FilePath] -> [String] -> Expectation -assertDoesNotCompile supportExterns inputFiles shouldFailWith = - assert supportExterns inputFiles noPreCheck $ \e -> +assertDoesNotCompile supportExterns supportForeigns inputFiles shouldFailWith = + assert supportExterns supportForeigns inputFiles noPreCheck $ \e -> case e of Left errs -> return $ if null shouldFailWith diff --git a/tests/TestDocs.hs b/tests/TestDocs.hs index c689437..c995336 100644 --- a/tests/TestDocs.hs +++ b/tests/TestDocs.hs @@ -1,18 +1,21 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} module TestDocs where import Prelude () import Prelude.Compat -import Data.Version (Version(..)) +import Control.Arrow (first) +import Data.Version (Version(..)) import Data.Monoid import Data.Maybe (fromMaybe) import Data.List ((\\)) import Data.Foldable +import Data.Text (Text) import qualified Data.Text as T import System.Exit @@ -22,6 +25,8 @@ import Language.PureScript.Docs.AsMarkdown (codeToString) import qualified Language.PureScript.Publish as Publish import qualified Language.PureScript.Publish.ErrorsWarnings as Publish +import Web.Bower.PackageMeta (parsePackageName) + import TestUtils publishOpts :: Publish.PublishOptions @@ -37,7 +42,7 @@ main = pushd "examples/docs" $ do case res of Left e -> Publish.printErrorToStdout e >> exitFailure Right Docs.Package{..} -> - forM_ testCases $ \(P.moduleNameFromString . T.pack -> mn, pragmas) -> + forM_ testCases $ \(P.moduleNameFromString -> mn, pragmas) -> let mdl = takeJust ("module not found in docs: " ++ T.unpack (P.runModuleName mn)) (find ((==) mn . Docs.modName) pkgModules) in forM_ pragmas (`runAssertionIO` mdl) @@ -49,25 +54,31 @@ takeJust msg = fromMaybe (error msg) data Assertion -- | Assert that a particular declaration is documented with the given -- children - = ShouldBeDocumented P.ModuleName String [String] + = ShouldBeDocumented P.ModuleName Text [Text] -- | Assert that a particular declaration is not documented - | ShouldNotBeDocumented P.ModuleName String + | ShouldNotBeDocumented P.ModuleName Text -- | Assert that a particular declaration exists, but without a particular -- child. - | ChildShouldNotBeDocumented P.ModuleName String String + | ChildShouldNotBeDocumented P.ModuleName Text Text -- | Assert that a particular declaration has a particular type class -- constraint. - | ShouldBeConstrained P.ModuleName String String + | ShouldBeConstrained P.ModuleName Text Text -- | Assert that a particular typeclass declaration has a functional -- dependency list. - | ShouldHaveFunDeps P.ModuleName String [([String],[String])] + | ShouldHaveFunDeps P.ModuleName Text [([Text],[Text])] -- | Assert that a particular value declaration exists, and its type -- satisfies the given predicate. - | ValueShouldHaveTypeSignature P.ModuleName String (ShowFn (P.Type -> Bool)) + | ValueShouldHaveTypeSignature P.ModuleName Text (ShowFn (P.Type -> Bool)) -- | Assert that a particular type alias exists, and its corresponding -- type, when rendered, matches a given string exactly -- fields: module, type synonym name, expected type - | TypeSynonymShouldRenderAs P.ModuleName String String + | TypeSynonymShouldRenderAs P.ModuleName Text Text + -- | Assert that a documented declaration includes a documentation comment + -- containing a particular string + | ShouldHaveDocComment P.ModuleName Text Text + -- | Assert that there should be some declarations re-exported from a + -- particular module in a particular package. + | ShouldHaveReExport (Docs.InPackage P.ModuleName) deriving (Show) newtype ShowFn a = ShowFn a @@ -77,28 +88,34 @@ instance Show (ShowFn a) where data AssertionFailure -- | A declaration was not documented, but should have been - = NotDocumented P.ModuleName String + = NotDocumented P.ModuleName Text -- | A child declaration was not documented, but should have been - | ChildrenNotDocumented P.ModuleName String [String] + | ChildrenNotDocumented P.ModuleName Text [Text] -- | A declaration was documented, but should not have been - | Documented P.ModuleName String + | Documented P.ModuleName Text -- | A child declaration was documented, but should not have been - | ChildDocumented P.ModuleName String String + | ChildDocumented P.ModuleName Text Text -- | A constraint was missing. - | ConstraintMissing P.ModuleName String String + | ConstraintMissing P.ModuleName Text Text -- | A functional dependency was missing. - | FunDepMissing P.ModuleName String [([String], [String])] + | FunDepMissing P.ModuleName Text [([Text], [Text])] -- | A declaration had the wrong "type" (ie, value, type, type class) -- Fields: declaration title, expected "type", actual "type". - | WrongDeclarationType P.ModuleName String String String + | WrongDeclarationType P.ModuleName Text Text Text -- | A value declaration had the wrong type (in the sense of "type -- checking"), eg, because the inferred type was used when the explicit type -- should have been. -- Fields: module name, declaration name, actual type. - | ValueDeclarationWrongType P.ModuleName String P.Type + | ValueDeclarationWrongType P.ModuleName Text P.Type -- | A Type synonym has been rendered in an unexpected format -- Fields: module name, declaration name, expected rendering, actual rendering - | TypeSynonymMismatch P.ModuleName String String String + | TypeSynonymMismatch P.ModuleName Text Text Text + -- | A doc comment was not found or did not match what was expected + -- Fields: module name, expected substring, actual comments + | DocCommentMissing P.ModuleName Text (Maybe Text) + -- | A module was missing re-exports from a particular module. + -- Fields: module name, expected re-export, actual re-exports. + | ReExportMissing P.ModuleName (Docs.InPackage P.ModuleName) [Docs.InPackage P.ModuleName] deriving (Show) data AssertionResult @@ -135,75 +152,84 @@ runAssertion assertion Docs.Module{..} = Fail (NotDocumented mn decl) ShouldBeConstrained mn decl tyClass -> - case find ((==) decl . Docs.declTitle) (declarationsFor mn) of - Nothing -> - Fail (NotDocumented mn decl) - Just Docs.Declaration{..} -> - case declInfo of - Docs.ValueDeclaration ty -> - if checkConstrained ty tyClass - then Pass - else Fail (ConstraintMissing mn decl tyClass) - _ -> - Fail (WrongDeclarationType mn decl "value" - (Docs.declInfoToString declInfo)) + findDecl mn decl $ \Docs.Declaration{..} -> + case declInfo of + Docs.ValueDeclaration ty -> + if checkConstrained ty tyClass + then Pass + else Fail (ConstraintMissing mn decl tyClass) + _ -> + Fail (WrongDeclarationType mn decl "value" + (Docs.declInfoToString declInfo)) ShouldHaveFunDeps mn decl fds -> - case find ((==) decl . Docs.declTitle) (declarationsFor mn) of - Nothing -> - Fail (NotDocumented mn decl) - Just Docs.Declaration{..} -> - case declInfo of - Docs.TypeClassDeclaration _ _ fundeps -> - if fundeps == fds - then Pass - else Fail (FunDepMissing mn decl fds) - _ -> - Fail (WrongDeclarationType mn decl "value" - (Docs.declInfoToString declInfo)) + findDecl mn decl $ \Docs.Declaration{..} -> + case declInfo of + Docs.TypeClassDeclaration _ _ fundeps -> + if fundeps == fds + then Pass + else Fail (FunDepMissing mn decl fds) + _ -> + Fail (WrongDeclarationType mn decl "value" + (Docs.declInfoToString declInfo)) ValueShouldHaveTypeSignature mn decl (ShowFn tyPredicate) -> - case find ((==) decl . Docs.declTitle) (declarationsFor mn) of - Nothing -> - Fail (NotDocumented mn decl) - Just Docs.Declaration{..} -> - case declInfo of - Docs.ValueDeclaration ty -> - if tyPredicate ty - then Pass - else Fail - (ValueDeclarationWrongType mn decl ty) - _ -> - Fail (WrongDeclarationType mn decl "value" - (Docs.declInfoToString declInfo)) + findDecl mn decl $ \Docs.Declaration{..} -> + case declInfo of + Docs.ValueDeclaration ty -> + if tyPredicate ty + then Pass + else Fail + (ValueDeclarationWrongType mn decl ty) + _ -> + Fail (WrongDeclarationType mn decl "value" + (Docs.declInfoToString declInfo)) TypeSynonymShouldRenderAs mn decl expected -> - case find ((==) decl . Docs.declTitle) (declarationsFor mn) of - Nothing -> - Fail (NotDocumented mn decl) - Just Docs.Declaration{..} -> - case declInfo of - Docs.TypeSynonymDeclaration [] ty -> - let actual = codeToString (Docs.renderType ty) in - if actual == expected - then Pass - else Fail (TypeSynonymMismatch mn decl expected actual) - _ -> - Fail (WrongDeclarationType mn decl "synonym" - (Docs.declInfoToString declInfo)) + findDecl mn decl $ \Docs.Declaration{..} -> + case declInfo of + Docs.TypeSynonymDeclaration [] ty -> + let actual = codeToString (Docs.renderType ty) in + if actual == expected + then Pass + else Fail (TypeSynonymMismatch mn decl expected actual) + _ -> + Fail (WrongDeclarationType mn decl "synonym" + (Docs.declInfoToString declInfo)) + + ShouldHaveDocComment mn decl expected -> + findDecl mn decl $ \Docs.Declaration{..} -> + if maybe False (expected `T.isInfixOf`) declComments + then Pass + else Fail (DocCommentMissing mn decl declComments) + + ShouldHaveReExport reExp -> + let + reExps = map fst modReExports + in + if reExp `elem` reExps + then Pass + else Fail (ReExportMissing modName reExp reExps) where declarationsFor mn = if mn == modName then modDeclarations - else fromMaybe [] (lookup mn modReExports) + else fromMaybe [] (lookup mn (map (first Docs.ignorePackage) modReExports)) findChildren title = fmap childrenTitles . find ((==) title . Docs.declTitle) + findDecl mn title f = + case find ((==) title . Docs.declTitle) (declarationsFor mn) of + Nothing -> + Fail (NotDocumented mn title) + Just decl -> + f decl + childrenTitles = map Docs.cdeclTitle . Docs.declChildren -checkConstrained :: P.Type -> String -> Bool +checkConstrained :: P.Type -> Text -> Bool checkConstrained ty tyClass = -- Note that we don't recurse on ConstrainedType if none of the constraints -- match; this is by design, as constraints should be moved to the front @@ -217,7 +243,7 @@ checkConstrained ty tyClass = False where matches className = - (==) className . T.unpack . P.runProperName . P.disqualify . P.constraintClass + (==) className . P.runProperName . P.disqualify . P.constraintClass runAssertionIO :: Assertion -> Docs.Module -> IO () runAssertionIO assertion mdl = do @@ -228,7 +254,7 @@ runAssertionIO assertion mdl = do putStrLn ("Failed: " <> show reason) exitFailure -testCases :: [(String, [Assertion])] +testCases :: [(Text, [Assertion])] testCases = [ ("Example", [ -- From dependencies @@ -238,7 +264,12 @@ testCases = -- From local files , ShouldBeDocumented (n "Example2") "one" [] , ShouldNotBeDocumented (n "Example2") "two" + + -- Re-exports + , ShouldHaveReExport (Docs.FromDep (pkg "purescript-prelude") (n "Prelude")) + , ShouldHaveReExport (Docs.Local (n "Example2")) ]) + , ("Example2", [ ShouldBeDocumented (n "Example2") "one" [] , ShouldBeDocumented (n "Example2") "two" [] @@ -319,10 +350,15 @@ testCases = , ValueShouldHaveTypeSignature (n "TypeOpAliases") "test4" (renderedType "forall a b c d. ((a ~> b) ~> c) ~> d") , ValueShouldHaveTypeSignature (n "TypeOpAliases") "third" (renderedType "forall a b c. a × b × c -> c") ]) + + , ("DocComments", + [ ShouldHaveDocComment (n "DocComments") "example" " example == 0" + ]) ] where n = P.moduleNameFromString . T.pack + pkg str = let Right p = parsePackageName str in p hasTypeVar varName = getAny . P.everythingOnTypes (<>) (Any . isVar varName) diff --git a/tests/TestPrimDocs.hs b/tests/TestPrimDocs.hs new file mode 100644 index 0000000..9309684 --- /dev/null +++ b/tests/TestPrimDocs.hs @@ -0,0 +1,30 @@ +module TestPrimDocs where + +import Control.Monad +import Data.List ((\\)) +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Language.PureScript as P +import qualified Language.PureScript.Docs as D +import qualified Language.PureScript.Docs.AsMarkdown as D + +main :: IO () +main = do + putStrLn "Test that there are no bottoms hiding in primDocsModule" + seq (D.runDocs (D.modulesAsMarkdown [D.primDocsModule])) (return ()) + + putStrLn "Test that Prim is fully documented" + let actualPrimNames = + -- note that prim type classes are listed in P.primTypes + (map (P.runProperName . P.disqualify . fst) $ Map.toList P.primTypes) ++ + (map (P.runProperName . P.disqualify) $ Set.toList P.primKinds) + let documentedPrimNames = map D.declTitle (D.modDeclarations D.primDocsModule) + + let undocumentedNames = actualPrimNames \\ documentedPrimNames + let extraNames = documentedPrimNames \\ actualPrimNames + + when (not (null undocumentedNames)) $ + error $ "Undocumented Prim names: " ++ show undocumentedNames + + when (not (null extraNames)) $ + error $ "Extra Prim names: " ++ show undocumentedNames diff --git a/tests/TestPscPublish.hs b/tests/TestPscPublish.hs index 05c082f..14bd037 100644 --- a/tests/TestPscPublish.hs +++ b/tests/TestPscPublish.hs @@ -1,20 +1,12 @@ {-# OPTIONS_GHC -fno-warn-missing-signatures #-} -{-# OPTIONS_GHC -fno-warn-unused-imports #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} module TestPscPublish where -import Control.Monad -import Control.Applicative -import Control.Exception -import System.Process -import System.Directory -import System.IO -import System.Exit -import qualified Data.ByteString.Lazy as BL +import System.Exit (exitFailure) import Data.ByteString.Lazy (ByteString) import qualified Data.Aeson as A -import Data.Aeson.BetterErrors import Data.Version import Language.PureScript.Docs diff --git a/tests/TestUtils.hs b/tests/TestUtils.hs index cf67a38..67e3fbf 100644 --- a/tests/TestUtils.hs +++ b/tests/TestUtils.hs @@ -57,6 +57,8 @@ supportModules = , "Control.Alternative" , "Control.Applicative" , "Control.Apply" + , "Control.Biapplicative" + , "Control.Biapply" , "Control.Bind" , "Control.Category" , "Control.Comonad" @@ -72,6 +74,15 @@ supportModules = , "Control.MonadZero" , "Control.Plus" , "Control.Semigroupoid" + , "Data.Bifoldable" + , "Data.Bifunctor" + , "Data.Bifunctor.Clown" + , "Data.Bifunctor.Flip" + , "Data.Bifunctor.Join" + , "Data.Bifunctor.Joker" + , "Data.Bifunctor.Product" + , "Data.Bifunctor.Wrap" + , "Data.Bitraversable" , "Data.Boolean" , "Data.BooleanAlgebra" , "Data.Bounded" @@ -79,18 +90,24 @@ supportModules = , "Data.Eq" , "Data.EuclideanRing" , "Data.Field" + , "Data.Foldable" , "Data.Function" , "Data.Function.Uncurried" , "Data.Functor" , "Data.Functor.Invariant" , "Data.Generic.Rep" - , "Data.Generic.Rep.Monoid" , "Data.Generic.Rep.Eq" + , "Data.Generic.Rep.Monoid" , "Data.Generic.Rep.Ord" , "Data.Generic.Rep.Semigroup" + , "Data.Generic.Rep.Show" , "Data.HeytingAlgebra" + , "Data.Maybe" + , "Data.Maybe.First" + , "Data.Maybe.Last" , "Data.Monoid" , "Data.Monoid.Additive" + , "Data.Monoid.Alternate" , "Data.Monoid.Conj" , "Data.Monoid.Disj" , "Data.Monoid.Dual" @@ -104,8 +121,9 @@ supportModules = , "Data.Ring" , "Data.Semigroup" , "Data.Semiring" - , "Data.Symbol" , "Data.Show" + , "Data.Symbol" + , "Data.Traversable" , "Data.Unit" , "Data.Void" , "Partial" @@ -113,6 +131,11 @@ supportModules = , "Prelude" , "Test.Assert" , "Test.Main" + , "Type.Data.Ordering" + , "Type.Data.Symbol" + , "Type.Equality" + , "Type.Prelude" + , "Type.Proxy" , "Unsafe.Coerce" ] diff --git a/tests/support/bower.json b/tests/support/bower.json index 2de10e8..c6a7173 100644 --- a/tests/support/bower.json +++ b/tests/support/bower.json @@ -1,16 +1,17 @@ { "name": "purescript-test-suite-support", "dependencies": { - "purescript-assert": "1.0.0-rc.1", - "purescript-console": "1.0.0-rc.1", - "purescript-eff": "1.0.0-rc.1", - "purescript-functions": "1.0.0-rc.1", - "purescript-prelude": "1.1.0", - "purescript-st": "1.0.0-rc.1", + "purescript-assert": "2.0.0", + "purescript-console": "2.0.0", + "purescript-eff": "2.0.0", + "purescript-functions": "2.0.0", + "purescript-prelude": "2.1.0", + "purescript-st": "2.0.0", "purescript-partial": "1.1.2", - "purescript-newtype": "0.1.0", - "purescript-generics-rep": "2.0.0", - "purescript-symbols": "^1.0.1", - "purescript-unsafe-coerce": "^1.0.0" + "purescript-newtype": "1.1.0", + "purescript-generics-rep": "4.0.0", + "purescript-symbols": "^2.0.0", + "purescript-typelevel-prelude": "https://github.com/purescript/purescript-typelevel-prelude.git#29a7123a0c29c85d4b923fcf4a7df8e45ebf9bac", + "purescript-unsafe-coerce": "^2.0.0" } } |